I am running the Win32 Hugs interpreter of November 1999 under Windows 95.
During the compilation of a program, which contains errors, the Hugs
interpreter aborts instead of generating an error message. I have inserted
the source at the bottom of this e-mail in verbatim.
By the way, here is a symptom: line 25 reads:
> class Order a => Typology a where
If I change line 25 into:
> class Ord a => Typology a where
the Hugs interpreter works fine and produces a awfully lovely error message.
This behavior suggests a flaw in the type checking of overloading.
Here is the source code:
> module Classification where
> chain str [] = []
> chain str (x:xs) = foldl f x xs where f x y = x++str++y
> class Identified a where
> name :: a->String
> data Concept = C String deriving Eq
> instance Identified Concept where
> name (C str) = str
> data Classification a = Cl a [Classification a] | Bottom
> root :: Classification a -> a
> root (Cl c cls) = c
> subs :: Classification a -> [Classification a]
> subs (Cl c cls) = cls
> isBot :: Classification a -> Bool
> isBot Bottom =True
> isBot _ = False
> conts Bottom = []
> conts (Cl r cls) = r: [c| cl<-cls, c<-conts cl]
> class Order a => Typology a where
> world :: Classification a
> rInvParent :: Classification a -> a->a->Bool
> isDefinedIn :: a -> Classification a -> Bool
> c `isDefinedIn` Bottom = False
> c `isDefinedIn` (Cl r cls)
> | r==c = True
> | otherwise = or [c `isDefinedIn` cl| cl<-cls]
> locate :: a -> Classification a -> Classification a
> locate c Bottom = Bottom
> locate c (Cl r cls)
> | r==c = (Cl r cls)
> | otherwise = head([Cl r cls| Cl r cls<-[locate c cl|
cl<-cls]]++[Bottom])
> update :: (Classification a -> Classification a)
> -> a -> Classification a -> Classification a
> update upd c Bottom = Bottom
> update upd c (Cl r cls)
> | r==c = upd(Cl r cls)
> | otherwise = Cl r [update upd c cl| cl<-cls]
> union:: Classification a -> Classification a -> Classification a
> union x Bottom = x
> union Bottom y = y
> union x y
> | root x==root y = foldl insert x (subs y)
> | aINb && not bINa = insert y x
> | not aINb && bINa = insert x y
> where
> aINb = root x `isDefinedIn` y
> bINa = root y `isDefinedIn` x
> insert:: Classification a -> Classification a -> Classification a
> insert wls Bottom = wls
> insert Bottom cls = cls
> insert wls cls
> | (root cls) `isDefinedIn` wls = update up (root cls) wls
> | otherwise = Cl (root wls) (subs wls++[cls])
> where up wls' = foldl insert wls' (subs cls)
> ins:: Classification a -> [a] -> Classification a
> ins wls [] = wls
> ins Bottom (c:cs) = Cl c [ins Bottom cs]
> ins wls (c:cs)
> | c `isDefinedIn` wls = update up c wls
> | otherwise = Cl (root wls) (subs wls++[ins Bottom (c:cs)])
> where up cl = ins cl cs
> typify :: a -> Classification a
> typify c = locate c world
> diagnose :: (Show a, Typology a) => Classification a -> [String]
> diagnose Bottom = []
> diagnose world@(Cl c cls) = diag [] (Cl c cls)++
> concat[diagnose cl| cl<-cls]
> where
> diag seen (Cl c []) = []
> diag seen (Cl c (cl:cls))
> = message c seen cl++diag (root cl: seen) (Cl c cls)
> message c seen cl
> | c==root cl = [s c++"is its own parent."]
> | c `isDefinedIn` cl = [s c++"is defined cyclically."]
> | root cl `elem` seen = [s (root cl)++"is multiply defined."]
> | rInvParent world c (root cl)
> = [s (root cl)++"is not a proper specialization of "++show c++"."]
> | otherwise
> = [s (root cl)++"is redefined as a "++show (root cl')
> | cl'<-cls, root cl/=root cl', root cl `isDefinedIn` cl']
> where s c = "!Err: \""++show c++"\" "
Here are the morphic functions
> ident :: Concept -> Morphism
> ident c = Id c
> isIdent :: Morphism -> Bool
> isIdent (Id c) = True
> isIdent _ = False
> dom :: Morphism -> Concept
> dom (Id c) = c
> dom (M(nm,LR,a,b,ps)) = a
> dom (M(nm,RL,a,b,ps)) = b
> dLift:: Concept -> Morphism -> Morphism
> dLift c' (Id c) = Id c' -- precondition: ltEq c c'
> dLift c (M(nm,LR,a,b,ps)) = M(nm,LR,c,b,ps) -- precond: ltEq a c
> cod :: Morphism -> Concept
> cod (Id c) = c
> cod (M(nm,LR,a,b,ps)) = b
> cod (M(nm,RL,a,b,ps)) = a
> cLift :: Concept -> Morphism -> Morphism
> cLift c' (Id c) = Id c' -- precondition: ltEq c c'
> cLift c (M(nm,LR,a,b,ps)) = M(nm,LR,a,c,ps) -- precond: ltEq b c
> card :: Morphism -> [Prop]
> card (Id c) = [Fun,Tot,Inj,Sur]
> card (M(nm,d,a,b,ps)) = ps
> compose :: Classification Concept ->
> Morphism -> Morphism -> Morphism
> compose world ma mb
> | bOVERa && isIdent mb = cLift (dom mb) ma
> | aOVERb && isIdent ma = dLift (dom ma) mb
> | bOVERa || aOVERb
> = M( name ma++";"++name mb, LR, dom ma, cod mb
> , [p| p<-card ma, elem p (card mb)])
> where
> aOVERb = gtEq world (cod ma) (dom mb)
> bOVERa = ltEq world (cod ma) (dom mb)
> flp :: Morphism -> Morphism
> flp (Id c) = Id c
> flp (M(nm,d,a,b,ps)) = M(nm,f d,a,b,map flipProp ps)
> where
> f LR = RL
> f RL = LR
> flipProp Fun = Inj
> flipProp Tot = Sur
> flipProp Sur = Tot
> flipProp Inj = Fun
> mType :: Morphism -> Morphtype
> mType (Id a) = MT a a
> mType mm = MT (dom mm) (cod mm)
> data Morphism = M (String, Dir, Concept, Concept, [Prop]) |
> Id Concept deriving Show
> data Morphtype = MT Concept Concept deriving Eq
> data Dir = LR | RL deriving (Eq, Show)
> data Prop = Fun | Tot | Inj | Sur deriving (Eq, Show)
> instance Eq Morphism where
> Id c==Id c' = c==c'
> M(nm,d,a,b,ps)==M(nm',d',a',b',ps')
> = nm==nm' && a==a' && b==b'
> m==m' = False
> class (Eq a, Typology a) => Order a where
> ltEq, gtEq, lt, gt :: Classification a -> a->a->Bool
> ltEq world l r = if l==r then True else
> r `isDefinedIn` locate l world
> gtEq world l r = if l==r then True else
> l `isDefinedIn` locate r world
> lt world l r = if l==r then False else
> r `isDefinedIn` locate l world
> gt world l r = if l==r then False else
> l `isDefinedIn` locate r world
> instance Order Concept
> instance Order Morphism
> instance Identified Morphism where
> name (Id c) = "Id"
> name (M(nm,LR,a,b,ps)) = nm
> name (M(nm,RL,a,b,ps)) = '~': nm
> class Representation a where
> rInv :: a->Bool
> rInv x = True
> instance (Show a, Typology a) => Representation (Classification a) where
> rInv Bottom = True
> rInv (Cl c cls)
> = and [ if c `isDefinedIn` world
> then rInvParent world c r && rInv (Cl r rls) else False
> | Cl r rls<-cls] &&
> null (diagnose (Cl c cls))
> data Language
> = L (Classification Concept) (Classification Morphism)
> deriving Show
instance Representation Language where
rInv (L wc wm)
=
> concepts :: Classification Morphism -> Classification Concept
> concepts cl
> = foldl insert Bottom (c dom cl++c cod cl)
> where
> c f (Cl r cls) = Cl (f r) []:[Cl (f r) [cl']| cl<-cls, cl'<-c f cl ]
> c f Bottom = []
> checkSpec :: Typology a =>
> Classification a -> [(a,a)] ->
> Classification a -> Bool
> checkSpec cl map world
> = and [ p `isDefinedIn` world &&
> c `isDefinedIn` cl
> | (p,c)<-map] &&
> and [ not(c' `isDefinedIn` world)
> | (p,c)<-map, c'<-conts(locate c cl)]
> specialize :: Typology a =>
> Classification a -> [(a,a)] ->
> Classification a -> Classification a
> specialize cls [] world
> = world `union` cls
> specialize cl ((p,c):map) world
> = specialize (update up c cl) map (update (upd c) p world)
> where
> up (Cl c cls) = Bottom
> upd c (Cl p cls) = Cl p (Cl c cls':cls)
> where
> Cl c' cls' = locate c cl
Show section
> instance Show a => Show (Classification a) where
> showsPrec p cls
> = showString (shw "\n " cls)
> where
> shw indent (Cl r cls)
> = chain indent (show r:[shw (indent++" ") (Cl r cls')
> | Cl r cls'<-cls])
> shw indent Bottom = ""
> instance Show Concept where
> showsPrec p (C name) = showString name
Test section
> testC i = specialize cWF (take i gluC) cOO
> tesCC = [checkSpec cWF (take i gluC) cOO| i<-[0..length gluC]]
> gluC = [ (C "Object", C "Activity")
> , (C "Object", C "Actor")
> , (C "Object", C "Data Item")
> , (C "Object", C "Work List")
> , (C "Message", C "Work Item")
> ]
> testM i = specialize mWF (take i gluM) mOO
> tesCM = [checkSpec mWF (take i gluM) mOO| i<-[0..length gluM]]
> gluM = [ (send, occur)
> , (receive, flp cause)
> , (referO,use)
> , (actual,contain)
> ]
> langOO = L cOO mOO
> cOO= (Cl (C "Concept")
> [ Cl (C "Object") []
> , Cl (C "Class") []
> , Cl (C "Method") []
> , Cl (C "Message") []
> , Cl (C "Name") []
> , Cl (C "Binding") []])
> mOO= (Cl (Id (C "Concept"))> [ Cl classname [], Cl methodname
[]
> , Cl declaredInN [], Cl declaredInM [], Cl declaredAs []
> , Cl formal [], Cl actual []
> , Cl instnce [], Cl superC [], Cl superO []
> , Cl inheritC [], Cl inheritO []
> , Cl accessN [], Cl accessM []
> , Cl reach [], Cl binder [], Cl value [], Cl name' []
> , Cl referO [], Cl referC []
> , Cl send [], Cl receive [], Cl invoke []
> ])
> langWFM = L cWF mWF
> cWF= (Cl (C "Concept")
> [ Cl (C "Work Item") []
> , Cl (C "Data Item") []
> , Cl (C "Activity") []
> , Cl (C "Actor") []
> , Cl (C "Work List") []])
> mWF= (Cl (Id (C "Concept"))
> [ Cl contain [], Cl cause []
> , Cl occur [], Cl use [], Cl require []
> , Cl classname [Cl schedule []] -- contains mistake!
> , Cl own []])
> instance Typology Concept where
> world = Cl (C "Concept")
> [ Cl (C "Object")
> [ Cl (C "Resource") [], Cl (C "Activity") []
> , Cl (C "Actor") []
> , Cl (C "Data Item") [], Cl (C "Work List") []]
> , Cl (C "Class") []
> , Cl (C "Method") []
> , Cl (C "Message") [Cl (C "Work Item") []]
> , Cl (C "Name") []
> , Cl (C "Binding") []]
> rInvParent world p c = True
> classname = M ("classname", LR, C "Class", C "Name", [Fun, Tot])
> methodname = M ("methodname", LR, C "Method", C "Name", [Fun, Tot])
> declaredInN = M ("declaredInN", LR, C "Name", C "Class", [Fun, Tot])
> declaredInM = M ("declaredInM", LR, C "Method", C "Class", [Fun, Tot])
> declaredAs = M ("declaredAs", LR, C "Name", C "Class", [Fun])
> formal = M ("formal", LR, C "Method", C "Name", [])
> actual = M ("actual", LR, C "Message", C "Object", [])
> instnce = M ("instance", LR, C "Object", C "Class", [Fun, Tot])
> superC = M ("superC", LR, C "Class", C "Class", [Fun])
> superO = M ("superO", LR, C "Object", C "Object", [Fun])
> inheritC = M ("inheritC", LR, C "Class", C "Class", [])
> inheritO = M ("inheritO", LR, C "Object", C "Object", [])
> accessN = M ("accessN", LR, C "Object", C "Name", [])
> accessM = M ("accessM", LR, C "Object", C "Method", [])
> reach = M ("reach", LR, C "Name", C "Object", [])
> binder = M ("binder", LR, C "Binding", C "Object", [Fun, Tot])
> value = M ("value", LR, C "Binding", C "Object", [Fun, Tot])
> name' = M ("name", LR, C "Binding", C "Name", [Fun, Tot])
> referC = M ("referC", LR, C "Class", C "Class", [])
> referO = M ("referO", LR, C "Object", C "Object", [])
> send = M ("send", LR, C "Message", C "Object", [Fun, Tot])
> receive = M ("receive", LR, C "Message", C "Object", [Fun, Tot])
> invoke = M ("invoke", LR, C "Message", C "Method", [Fun, Tot])
> contain = M ("contain", LR, C "Work Item", C "Data Item", [])
> cause = M ("cause", LR, C "Activity", C "Work Item", [Fun,
Tot])
> occur = M ("occur", LR, C "Work Item", C "Activity", [Fun,
Tot])
> use = M ("use", LR, C "Activity", C "Data Item", [])
> require = M ("require", LR, C "Activity", C "Data Item", [])
> schedule = M ("schedule", LR, C "Work Item", C "Work List", [])
> own = M ("own", LR, C "Work List", C "Actor", [Fun, Tot])
> perform = M ("perform", LR, C "Actor", C "Activity", [Fun, Tot])
> instance Typology Morphism where
> world
> = Cl (Id (C "Concept"))
> [ Cl classname [], Cl methodname []
> , Cl declaredInN [], Cl declaredInM [], Cl declaredAs []
> , Cl formal [], Cl actual []
> , Cl instnce [], Cl superC [], Cl superO []
> , Cl inheritC [], Cl inheritO []
> , Cl accessN [], Cl accessM []
> , Cl reach [], Cl binder [], Cl value [], Cl name' []
> , Cl referO [Cl use []], Cl referC []
> , Cl send [], Cl receive [], Cl invoke []
> ]
> rInvParent world p c = lt world (dom p) (dom c) &&
> lt world (cod p) (cod c)
