diff options
Diffstat (limited to 'sucl/clean.icl')
| -rw-r--r-- | sucl/clean.icl | 441 |
1 files changed, 441 insertions, 0 deletions
diff --git a/sucl/clean.icl b/sucl/clean.icl new file mode 100644 index 0000000..0451a4d --- /dev/null +++ b/sucl/clean.icl @@ -0,0 +1,441 @@ +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 <module.ident> + +> 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 <module.ident> + +> 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 |