aboutsummaryrefslogtreecommitdiff
path: root/sucl/clean.icl
diff options
context:
space:
mode:
Diffstat (limited to 'sucl/clean.icl')
-rw-r--r--sucl/clean.icl441
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