implementation module clean // $Id$ /* clean.lit - Clean core language =============================== Description ----------- This script contains the implementation of the core of the Clean language. ------------------------------------------------------------ Interface --------- Exported identifiers: > %export || law.lit cli.lit test.lit > cleanpart || + + - > node || + + + > symbol || + + + > typenode || + + + > typesymbol || + + + > cleantyperule || - + - > corecomplete || + + - > coretypeinfo > coretyperule || - + - > readcleanparts || - + - > showcleanpart > shownode || - - + > showsymbol || + + + > showtypenode || - + - > showtypesymbol || - + - > symbolmodule > typesymbolmodule > usersym > cleanalias > cleanmacro > cleantype > cleanrule > heap || Infinite list of anonymous nodes > typeheap || Infinite list of anonymous type nodes ------------------------------------------------------------ Includes -------- > %include "basic.lit" > %include "hunt.lit" > %include "graph.lit" -extgraph > %include "rule.lit" ------------------------------------------------------------ Implementation -------------- Implementation of identifier > typesymbol > ::= INT | || Integer > BOOL | || Boolean > CHAR | || Character > STRING | || String > REAL | || Real > FILE | || File > FN | || Function > LIST | || List > TUPLE num | || Tuple of specific arity > USER [char] [char] || User-defined type > typenode > ::= NAMED [char] | || A type node with an explicit nodeid > ANONYMOUS num || A type node without an explicit nodeid > symbol > ::= Int num | || A specific integer > Bool bool | || A specific boolean > Char char | || A specific character > String [char] | || A specific string > Real num | || A specific real > Tuple num | || The tuple constructor of specific arity > Cons | || The list constructor > Nil | || The empty list > Apply | || The curried function application symbol > If | || The predefined if symbol > Select num num | || The tuple element selector for tuple arity and element number > User [char] [char] || A user-defined symbol > node > ::= Named [char] | || A node with an explicit nodeid > Anonymous num || A node without an explicit nodeid > cleanpart > ::= Typeexport typesymbol | > Alias typesymbol [typenode] typenode [(typenode,(typesymbol,[typenode]))] | > Algebra typesymbol [symbol] | > Export symbol | > Macro symbol [node] node [(node,(symbol,[node]))] | > Type symbol [typenode] typenode [(typenode,(typesymbol,[typenode]))] [char] | > Rules symbol | > Rule symbol [node] node [(node,(symbol,[node]))] | > Constructor symbol > showcleanpart :: cleanpart -> [char] > showcleanpart = show > ct = printrule show show.coretyperule > coreconstructor :: symbol -> bool > coreconstructor (Int i) = True > coreconstructor (Bool b) = True > coreconstructor (Char c) = True > coreconstructor (String s) = True > coreconstructor (Real r) = True > coreconstructor (Tuple a) = True > coreconstructor (Cons ) = True > coreconstructor (Nil ) = True > coreconstructor (Apply ) = True > coreconstructor (If ) = False > coreconstructor (Select a i) = False > coreconstructor (User m n) = False > coreexports :: [symbol] > coreexports = [] > coreimported :: symbol -> bool > coreimported (Int i) = False > coreimported (Bool b) = False > coreimported (Char c) = False > coreimported (String s) = False > coreimported (Real r) = False > coreimported (Tuple a) = False > coreimported (Cons ) = False > coreimported (Nil ) = False > coreimported (Apply ) = True > coreimported (If ) = False > coreimported (Select a i) = False > coreimported (User m n) = False > corerules :: symbol -> [rule symbol node] > corerules (Int i) = [] > corerules (Bool b) = [] > corerules (Char c) = [] > corerules (String s) = [] > corerules (Real r) = [] > corerules (Tuple a) = [] > corerules (Cons ) = [] > corerules (Nil ) = [] > corerules (Apply ) = [] > corerules (If ) > = [ mkrule [Named "cond",Named "then",Named "else"] (Named "else") (updategraph (Named "cond") (Bool False,[]) emptygraph) > , mkrule [Named "cond",Named "then",Named "else"] (Named "then") (updategraph (Named "cond") (Bool True ,[]) emptygraph) > ] > corerules (Select a i) = [mkrule [Named "tuple"] (Anonymous i) (updategraph (Named "tuple") (Tuple a,map Anonymous [1..a]) emptygraph)] > corerules (User m n) = [] coresymbols :: [symbol] coresymbols = [If,Select a i] > coretyperule (Int i) = mkrule [] (NAMED "int" ) (updategraph (NAMED "int" ) (INT ,[]) emptygraph) > coretyperule (Bool b) = mkrule [] (NAMED "bool" ) (updategraph (NAMED "bool" ) (BOOL ,[]) emptygraph) > coretyperule (Char c) = mkrule [] (NAMED "char" ) (updategraph (NAMED "char" ) (CHAR ,[]) emptygraph) > coretyperule (String s) = mkrule [] (NAMED "string") (updategraph (NAMED "string") (STRING,[]) emptygraph) > coretyperule (Real r) = mkrule [] (NAMED "real" ) (updategraph (NAMED "real" ) (REAL ,[]) emptygraph) > coretyperule (Tuple a) > = mkrule args (NAMED "tuple") (updategraph (NAMED "tuple") (TUPLE a,args) emptygraph) > where args = take a (map ANONYMOUS [1..]) > coretyperule Cons = mkrule [NAMED "element",NAMED "list"] (NAMED "list") (updategraph (NAMED "list") (LIST,[NAMED "element"]) emptygraph) > coretyperule Nil = mkrule [] (NAMED "list") (updategraph (NAMED "list") (LIST,[NAMED "element"]) emptygraph) > coretyperule Apply = mkrule [NAMED "fn",NAMED "arg"] (NAMED "res") (updategraph (NAMED "fn") (FN,[NAMED "arg",NAMED "res"]) emptygraph) > coretyperule If = mkrule [NAMED "bool",NAMED "res",NAMED "res"] (NAMED "res") (updategraph (NAMED "bool") (BOOL,[]) emptygraph) > coretyperule (Select a i) = mkrule [NAMED "tuple"] (ANONYMOUS i) (updategraph (NAMED "tuple") (TUPLE a,map ANONYMOUS [1..a]) emptygraph) > coretyperule (User m n) = error ("coretyperule: untyped user symbol "++m++'.':n) > coretypeinfo :: symbol -> (rule typesymbol typenode,[bool]) > coretypeinfo sym > = (trule,corestricts sym) > where corestricts Apply = [True,False] > corestricts If = [True,False,False] > corestricts (Select a i) = [True] > corestricts sym = map (const False) (lhs trule) > trule = coretyperule sym > readcleanparts :: [char] -> [cleanpart] > readcleanparts = readvals.findclean > findclean :: [char] -> [char] > findclean base > = foldr const (error ("findclean: "++show base++" not found.")) files > where files = findfiles readable ["",".cli"] (getpath ["."] "CLIPATH") base > corecomplete :: typesymbol -> [symbol] -> bool > corecomplete INT = const False > corecomplete BOOL = superset (map Bool [False,True]) > corecomplete CHAR = superset (map (Char.decode) [0..255]) > corecomplete STRING = const False > corecomplete REAL = const False > corecomplete FILE = const False > corecomplete FN = const False > corecomplete LIST = superset [Nil,Cons] > corecomplete (TUPLE arity) = superset [Tuple arity] > corecomplete (USER module identifier) = const False > showtypesymbol INT = "INT" > showtypesymbol BOOL = "BOOL" > showtypesymbol CHAR = "CHAR" > showtypesymbol STRING = "STRING" > showtypesymbol REAL = "REAL" > showtypesymbol FILE = "FILE" > showtypesymbol FN = "=>" > showtypesymbol LIST = "_LIST" > showtypesymbol (TUPLE a) = "_TUPLE"++shownum a > showtypesymbol (USER module ident) = ident > showtypenode (NAMED ident) = ident > showtypenode (ANONYMOUS n) = "type"++shownum n > showtypenodedef :: typesymbol -> [([char],[char])] -> ([char],[char]) > showtypenodedef (TUPLE a) [] = issafe "()" > showtypenodedef (TUPLE a) [arg] = arg > showtypenodedef (TUPLE a) ((safearg,unsafearg):args) > = issafe ('(':unsafearg++f args) > where f [] = ")" > f ((safearg,unsafearg):args) = ',':unsafearg++f args > showtypenodedef LIST [(safearg,unsafearg)] = issafe ('[':unsafearg++"]") > showtypenodedef symbol [] = issafe (showtypesymbol symbol) > showtypenodedef symbol args = showappl (showtypesymbol symbol) args > showsymbol :: symbol -> [char] > showsymbol (Int i) = shownum i > showsymbol (Bool False) = "FALSE" > showsymbol (Bool True) = "TRUE" > showsymbol (Char c) = show c > showsymbol (String s) = show s > showsymbol (Real r) = show (r+0.0) > showsymbol (Tuple a) = "_Tuple"++show a > showsymbol Cons = "_CONS" > showsymbol Nil = "[]" > showsymbol Apply = "_AP" > showsymbol If = "IF" > showsymbol (Select a i) = "_Select"++show a++'.':show i > showsymbol (User module ident) = ident > shownode (Named ident) = ident > shownode (Anonymous n) = "node"++shownum n > shownodedef :: symbol -> [([char],[char])] -> ([char],[char]) > shownodedef (Tuple a) [] = issafe "()" > shownodedef (Tuple a) [arg] = arg > shownodedef (Tuple a) ((safearg,unsafearg):args) > = issafe ('(':unsafearg++f args) > where f [] = ")" > f ((safearg,unsafearg):args) = ',':unsafearg++f args > shownodedef Cons [(safehead,unsafehead),(safetail,unsafetail)] > = issafe ('[':unsafehead++f unsafetail) > where f "[]" = "]" > f ('[':ttail) = ',':ttail > f unsafetail = '|':unsafetail++"]" > shownodedef Apply [fn] = fn > shownodedef Apply ((safefn,unsafefn):args) = showappl unsafefn args > shownodedef symbol [] = issafe (showsymbol symbol) > shownodedef symbol args = showappl (showsymbol symbol) args > showappl sym args = mksafe (sym++concat (map ((' ':).fst) args)) > mksafe unsafe = ('(':unsafe++")",unsafe) > issafe safe = (safe,safe) > cleantyperule :: symbol -> (rule typesymbol typenode,[bool]) -> [char] > cleantyperule sym (trule,tstricts) > = ":: "++showsymbol sym++concat (map2 printarg tstricts targs)++" -> "++snd (lookup' troot)++";" > where targs = lhs trule; troot = rhs trule; tgraph = rulegraph trule > lookup' = lookup table > table = map (pairwith printunraveled) (nodelist tgraph (troot:targs)) > printunraveled tnode > = showtypenodedef tsym (map lookup' targs), if tdef > = issafe (showtypenode tnode), otherwise > where (tdef,(tsym,targs)) = nodecontents tgraph tnode > printarg tstrict targ = ' ':cond tstrict ('!':) id (fst (lookup' targ)) > prettyrule :: (**->[char]) -> (*->[([char],[char])]->([char],[char])) -> rule * ** -> [char] > prettyrule shownode shownodedef rule > = concat (map ((++" ").fst) (init shownnodes))++"-> "++snd (last shownnodes) > where shownnodes = foldgraph prettydef (issafe.shownode) shownodedef graph (args++[root]) > prettydef node (saferef,unsaferef) = issafe (shownode node++':':saferef) > graph = rulegraph rule > args = lhs rule > root = rhs rule > usersym :: symbol -> bool > usersym (User module name) = True > usersym sym = False > symbolmodule :: symbol -> optional [char] > symbolmodule (User module ident) = Present module > symbolmodule symbol = Absent > typesymbolmodule :: typesymbol -> optional [char] > typesymbolmodule (USER module ident) = Present module > typesymbolmodule symbol = Absent ======================================================================== Get the Select nodes from a graph. > getselectnodes :: graph symbol ** -> ** -> [((**,num),(num,**))] > getselectnodes graph root > = foldr (withmeta (nodecontents graph) addselectnode) [] (nodelist graph [root]) > where addselectnode (True,(Select arity index,[tuplenode])) selectnode > = (((tuplenode,arity),(index,selectnode)):) > addselectnode contents node = id Distribute the Select nodes over their indexes. > splitselectnodes :: ((**,num),[(num,**)]) -> (**,[[**]]) > splitselectnodes ((tuplenode,arity),selects) > = (tuplenode,foldr dist (rep arity []) selects) > where dist (1,selectnode) (ns:nss) = (selectnode:ns):nss > dist (index,selectnode) (ns:nss) = ns:dist (index-1,selectnode) nss Make left hand sides. > makelhss :: [**] -> [[**]] -> ([**],[[**]]) > makelhss heap nss > = (heap,[]), if empty > = (heap'',ns':nss''), otherwise > where (heap'',nss'') = makelhss heap' nss' > (empty,ns',heap',nss') = heads heap nss > heads heap [] = (True,[],heap,[]) > heads (node:heap) ([]:nss) > = (empty,node:ns',heap',[]:nss') > where (empty,ns',heap',nss') = heads heap nss > heads heap ((n:ns):nss) > = (False,n:ns',heap',ns:nss') > where (empty,ns',heap',nss') = heads heap nss > maketuplenodedefs :: [**] -> [(**,[[**]])] -> [([**],**)] > maketuplenodedefs heap [] > = [] > maketuplenodedefs heap ((tuplenode,nss):rest) > = map (converse pair tuplenode) lhss++tuplenodedefs > where (heap',lhss) = makelhss heap nss > tuplenodedefs = maketuplenodedefs heap' rest > printtree :: graph symbol node -> node -> ([char],[char]) > printtree = unravelwith (issafe.shownode) shownodedef > cleanalias sym = indent ":: ".totalpretty typeheap (const (const [])) showtypesymbol showtypenodedef showtypenode sym > cleanmacro sym = indent " ".totalpretty heap (const (const [])) showsymbol shownodedef shownode sym > cleantype sym = indent ":: ".totalpretty typeheap (const (const [])) showsymbol showtypenodedef showtypenode sym > cleanrule sym = indent " ".totalpretty heap getselectnodes showsymbol shownodedef shownode sym > heap = map Anonymous [0..] > typeheap = map ANONYMOUS [0..] > totalpretty > :: [***] -> > (graph ** ***->***->[((***,num),(num,***))]) -> > (*->[char]) -> > (**->[([char],[char])]->([char],[char])) -> > (***->[char]) -> > * -> > rule ** *** -> > [[char]] > totalpretty heap getselectnodes showlhssymbol shownodedef shownode lhssymbol rule > = punctuate "" "," " " "" lhsheader lhsbody++ > punctuate "-> " "," " " ";" rhsheader rhsbody > where > args = lhs rule; root = rhs rule; graph = rulegraph rule > selectnodes = getselectnodes graph root > prunedgraph = foldr prunegraph graph (map (snd.snd) selectnodes) > tuplenodedefs > = ( maketuplenodedefs (heap--nodelist graph (root:args)). > map splitselectnodes. > partition fst snd > ) selectnodes > tuplenodes = map snd tuplenodedefs > count = refcount prunedgraph (args++root:tuplenodes) > sharednodes = [node|node<-nodelist prunedgraph (args++root:tuplenodes);count node>1;fst (nodecontents prunedgraph node)] > reprunedgraph = foldr prunegraph prunedgraph sharednodes > (argreprs:[rootrepr]:tuplereprs:sharedargreprs) > = map (map (unravelwith (issafe.shownode) shownodedef reprunedgraph)) (args:[root]:tuplenodes:map (snd.snd.nodecontents prunedgraph) sharednodes) > showtupledef (selectnodes,tuplenode) tuplerepr > = '(':join ',' (map shownode selectnodes)++"): "++snd tuplerepr > showshareddef (node,argreprs) > = mapfst addline, if patnode node > = mapsnd addline, otherwise > where addline = ((shownode node++": "++snd (shownodedef (fst cont) argreprs)):) > (True,cont) = nodecontents prunedgraph node > patnode = member (nodelist graph args) > lhsheader = showlhssymbol lhssymbol++concat (map ((' ':).fst) argreprs) > rhsheader = snd rootrepr > (lhslines,rhslines) = foldr showshareddef ([],[]) (zip2 sharednodes sharedargreprs) > lhsbody = lhslines > rhsbody = map2 showtupledef tuplenodedefs tuplereprs++rhslines > punctuate :: [char] -> [char] -> [char] -> [char] -> [char] -> [[char]] -> [[char]] > punctuate open endline beginline close l ls > = (open++l++end):ls' > where (end,ls') = f ls > f [] = (close,[]) > f (l:ls) = (endline,punctuate beginline endline beginline close l ls) ------------------------------------------------------------------------ Useful (higher order) functions. > withmeta :: (*->**) -> (**->*->***) -> * -> *** > withmeta meta f x = f (meta x) x > pair :: * -> ** -> (*,**) > pair x y = (x,y) > unravelwith :: (**->***) -> (*->[***]->***) -> graph * ** -> ** -> *** > unravelwith foldopen foldclosed graph > = unravel > where unravel node > = foldclosed sym (map unravel args), if def > = foldopen node, otherwise > where (def,(sym,args)) = nodecontents graph node */