Combine stc conversion functions to produce a cli structure

Work out typerule/strictness separation in coreclean module

sucl/absmodule.dcl

@@ -5,11 +5,9 @@ definition module absmodule
 from rule import Rule
 
 :: Module sym pvar tsym tvar
-   = { //exportedtypesymbols :: [tsym]                            // Exported type symbols (from DCL)
-   //, typealias           :: [(tsym,Rule tsym tvar)]           // Alias types
-       typeconstructors    :: [(tsym,[sym])]                    // All constructor symbols of each declared algebraic type
-     , exportedsymbols     :: [sym]                             // Exported function/constructor symbols
-   //, aliases             :: [(sym,Rule sym pvar)]             // Macros
-     , typerules           :: [(sym,(Rule tsym tvar,[Bool]))]   // Info from type rules (actual type and argument strictnesses)
-     , rules               :: [(sym,[Rule sym pvar])]           // Rewrite rules of each symbol, absent if imported
+   = { typeconstructors    :: [(tsym,[sym])]            // All constructor symbols of each declared algebraic type
+     , exportedsymbols     :: [sym]                     // Exported function/constructor symbols
+     , typerules           :: [(sym,Rule tsym tvar)]    // Principal types of symbols
+     , stricts             :: [(sym,[Bool])]            // Strict arguments of functions
+     , rules               :: [(sym,[Rule sym pvar])]   // Rewrite rules of each symbol, absent if imported
      }

sucl/absmodule.icl

@@ -27,49 +27,12 @@ Includes.
 ------------------------------------------------------------------------
 Module implementation.
 
->   module * *** **** *****
->   ==  (   (   [****],                         ||  Exported types
->               [(****,rule **** *****)],       ||  Type alias rules
->               [(****,[*])]                    ||  Constructor symbols for algebraic type symbol
->           ),
->           (   [*],                            ||  Exported symbols
->               [(*,rule * ***)],               ||  Alias rules
->               [(*,(rule **** *****,[bool]))], ||  Typerule for symbol
->               [(*,[rule * ***])]              ||  Rewrite rules for symbol, absent if imported
->           )
->       )
-
 */
 
 :: Module sym pvar tsym tvar
-   = {// exportedtypesymbols :: [tsym]                            // Exported type symbols (from DCL)
-     //, typealias           :: [(tsym,Rule tsym tvar)]           // Alias types
-       typeconstructors    :: [(tsym,[sym])]                    // All constructor symbols of each declared algebraic type
-     , exportedsymbols     :: [sym]                             // Exported function/constructor symbols
-   //, aliases             :: [(sym,Rule sym pvar)]             // Macros
-     , typerules           :: [(sym,(Rule tsym tvar,[Bool]))]   // Info from type rules (actual type and argument strictnesses)
-     , rules               :: [(sym,[Rule sym pvar])]           // Rewrite rules of each symbol, absent if imported
+   = { typeconstructors    :: [(tsym,[sym])]            // All constructor symbols of each declared algebraic type
+     , exportedsymbols     :: [sym]                     // Exported function/constructor symbols
+     , typerules           :: [(sym,Rule tsym tvar)]    // Principal types of symbols
+     , stricts             :: [(sym,[Bool])]            // Strict arguments of functions
+     , rules               :: [(sym,[Rule sym pvar])]   // Rewrite rules of each symbol, absent if imported
      }
-
-/*
-
->   newmodule :: module * *** **** *****
->   newmodule = (([],[],[]),([],[],[],[]))
-
->   addtalias :: **** -> bool -> rule **** ***** -> module * *** **** ***** -> module * *** **** *****
->   addtalias ts exp tr ((tes,tas,tcs),defs)
->   =   ((cond exp (ts:tes) tes,(ts,tr):tas,tcs),defs)
-
->   addtsymdef :: **** -> bool -> [*] -> module * *** **** ***** -> module * *** **** *****
->   addtsymdef ts exp ss ((tes,tas,tcs),defs)
->   =   ((cond exp (ts:tes) tes,tas,(ts,ss):tcs),defs)
-
->   addalias :: * -> bool -> rule * *** -> module * *** **** ***** -> module * *** **** *****
->   addalias s exp r (tdefs,(es,as,ts,rs))
->   =   (tdefs,(cond exp (s:es) es,(s,r):as,ts,rs))
-
->   addsymdef :: * -> bool -> rule **** ***** -> bool -> [rule * ***] -> module * *** **** ***** -> module * *** **** *****
->   addsymdef s exp t imp rr (tdefs,(es,as,ts,rs))
->   =   (tdefs,(cond exp (s:es) es,as,(s,(t,[])):ts,cond imp rs ((s,rr):rs)))
-
-*/

sucl/cli.dcl

@@ -20,3 +20,12 @@ typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
 exports :: Cli -> [SuclSymbol]
 complete :: Cli -> [SuclSymbol] -> Bool
 clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
+
+// Build a cli structure
+mkcli ::
+    [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
+    [(SuclSymbol,[Bool])]
+    [SuclSymbol]
+    [(SuclTypeSymbol,[SuclSymbol])]
+    [(SuclSymbol,[Rule SuclSymbol SuclVariable])]
+ -> Cli

sucl/cli.icl

@@ -124,12 +124,12 @@ exports :: Cli -> [SuclSymbol]
 exports m = m.exportedsymbols
 
 /*
->   typerule (tdefs,(es,as,ts,rs)) = fst.maxtypeinfo ts
+>   typerule (tdefs,(es,as,ts,rs)) = maxtyperule ts
 */
 
 typerule :: Cli SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
 typerule m sym
-= fst (maxtypeinfo m.typerules sym)
+= maxtyperule m.typerules sym
 
 /*
 >   rules (tdefs,(es,as,ts,rs)) = foldmap Present Absent rs
@@ -154,7 +154,7 @@ typerule m sym
 
 clistrategy :: Cli ((Graph SuclSymbol SuclVariable) SuclVariable var -> Bool) -> Strategy SuclSymbol var SuclVariable answer | == var
 clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable
- = ( checkarity (typearity o maxtypeinfo ts)        // Checks curried occurrences and strict arguments
+ = ( checkarity (typearity o maxtyperule ts)        // Checks curried occurrences and strict arguments
    o checklaws cleanlaws                            // Checks for special (hard coded) rules (+x0=x /y1=y ...)
    o checkrules matchable (foldmap id [] rs)        // Checks normal rewrite rules
    o checkimport islocal                            // Checks for delta symbols
@@ -163,11 +163,17 @@ clistrategy {typeconstructors=tcs,typerules=ts,rules=rs} matchable
    where islocal rsym=:(SuclUser s) = isMember rsym (map fst rs)
          islocal rsym = True                        // Symbols in the language core are always completely known
 
-typearity :: (Rule SuclTypeSymbol SuclTypeVariable,[Bool]) -> Int
-typearity ti = length (arguments (fst ti))
+typearity :: (Rule SuclTypeSymbol SuclTypeVariable) -> Int
+typearity ti = length (arguments ti)
 
-maxtypeinfo :: [(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))] SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
-maxtypeinfo defs sym = extendfn defs coretypeinfo sym
+//maxtypeinfo :: [(SuclSymbol,(Rule SuclTypeSymbol SuclTypeVariable,[Bool]))] SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
+//maxtypeinfo defs sym = extendfn defs coretypeinfo sym
+
+maxtyperule :: [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)] SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
+maxtyperule defs sym = extendfn defs coretyperule sym
+
+maxstricts :: [(SuclSymbol,[Bool])] SuclSymbol -> [Bool]
+maxstricts defs sym = extendfn defs corestricts sym
 
 /*
 >   constrs ((tes,tas,tcs),defs) = tcs
@@ -176,7 +182,7 @@ maxtypeinfo defs sym = extendfn defs coretypeinfo sym
 */
 
 complete :: Cli -> [SuclSymbol] -> Bool
-complete m = mkclicomplete m.typeconstructors (fst o maxtypeinfo m.typerules)
+complete m = mkclicomplete m.typeconstructors (maxtyperule m.typerules)
 
 /*
 >   showcli = printcli
@@ -310,3 +316,19 @@ Compiling clean parts into module information...
 >             ctgraph = updategraph ctroot (fn,[last targs,troot]) tgraph
 
 */
+
+mkcli ::
+    [(SuclSymbol,Rule SuclTypeSymbol SuclTypeVariable)]
+    [(SuclSymbol,[Bool])]
+    [SuclSymbol]
+    [(SuclTypeSymbol,[SuclSymbol])]
+    [(SuclSymbol,[Rule SuclSymbol SuclVariable])]
+ -> Cli
+
+mkcli typerules stricts exports constrs bodies
+= { typeconstructors = constrs
+  , exportedsymbols  = exports
+  , typerules        = typerules
+  , stricts          = stricts
+  , rules            = bodies
+  }

sucl/coreclean.dcl

@@ -59,7 +59,8 @@ instance == SuclSymbol
 instance == SuclVariable
 
 // Get the type rule and strictness of a built in core clean symbol
-coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
+coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
+corestricts :: SuclSymbol -> [Bool]
 
 // Determine if a list of constructors completely covers a given type
 corecomplete :: SuclTypeSymbol -> [SuclSymbol] -> Bool

sucl/coreclean.icl

@@ -94,12 +94,15 @@ where (==) (SuclAnonymous i1) (SuclAnonymous i2) = i1 == i2
       (==) _                  _                  = False
 
 // Get the type rule and strictness of a built in core clean symbol
-coretypeinfo :: SuclSymbol -> (Rule SuclTypeSymbol SuclTypeVariable,[Bool])
-coretypeinfo sym
- = (trule,corestricts sym)
-   where corestricts (SuclApply argc) = [True,False]
-         corestricts sym = map (const False) (arguments trule)
-         trule = coretyperule sym
+
+corestricts :: SuclSymbol -> [Bool]
+corestricts sym
+= case sym
+  of (SuclApply argc)
+      -> maphd (const True) stricts
+     _
+      -> stricts
+  where stricts = map (const False) (arguments (coretyperule sym))
 
 coretyperule :: SuclSymbol -> Rule SuclTypeSymbol SuclTypeVariable
 coretyperule (SuclApply argc)

sucl/supercompile.icl

@@ -36,10 +36,12 @@ supercompile common_defs array_instances dcl_mods main_dcl_module_n components f
 = (components,fun_defs,dcl_types,used_conses,var_heap,type_heaps,expression_heap)
   where used_conses = abort "supercompile: not implemented"
 		// Determine defined functions
-        _ = cts_function fun_defs
+        (sucl_typerules,sucl_stricts,sucl_bodies,sucl_kinds) = cts_function fun_defs
 		// Determine exported functions
-        _ = cts_exports fun_defs dcl_mods main_dcl_module_n
+        sucl_exports = cts_exports fun_defs dcl_mods main_dcl_module_n
 		// Get constructor lists of algebraic types
-		_ = cts_getconstrs dcl_mods main_dcl_module_n
+		sucl_constrs = cts_getconstrs dcl_mods main_dcl_module_n
+        // Build abstract CLI module
+        sucl_module = mkcli sucl_typerules sucl_stricts sucl_exports sucl_constrs sucl_bodies
         // Convert sucl-generated function body back to core clean
         (expression_heap`,var_heap`,func_body) = stc_funcdef dcl_mods expression_heap var_heap undef