path: root/sucl/clean.icl

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 <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

*/