t

diff --git a/lambda/test.dcl b/lambda/test.dcl
new file mode 100644 (file)
index 0000000..7829f92
--- /dev/null
+++ b/lambda/test.dcl
@@ -0,0 +1,2 @@
+definition module test
+

diff --git a/lambda/test.icl b/lambda/test.icl
new file mode 100644 (file)
index 0000000..2dfb06f
--- /dev/null
+++ b/lambda/test.icl
@@ -0,0 +1,82 @@
+module test
+
+import StdEnv
+import Data.Functor
+import Data.Func
+import Data.Maybe
+import Control.Applicative
+import Control.Monad
+
+:: In a b = In infixl 0 a b
+class lambda v
+where
+       (@) infixr 1 :: (v (a -> b)) (v a) -> v b
+       \| :: ((v a) -> v b) -> v (a -> b)
+
+class expr v
+where
+       lit :: a -> v a | toString a
+       (+.) infixl 6 :: (v a) (v a) -> v a | + a
+       (-.) infixl 6 :: (v a) (v a) -> v a | - a
+       (*.) infixl 6 :: (v a) (v a) -> v a | * a
+       (/.) infixl 6 :: (v a) (v a) -> v a | / a
+       (==.) infix 4 :: (v a) (v a) -> v Bool | == a
+       If :: (v Bool) (v a) (v a) -> v a
+
+class let v
+where
+       lett :: ((v a) -> In (v a) (v b)) -> v b
+
+:: Printer a = P ([String] [String] -> [String])
+unP (P a) = a
+print :: (Printer a) -> [String]
+print (P a) = a ["v" +++ toString i\\i<-[0..]] []
+instance lambda Printer
+where
+       (@) (P l) (P r) = P \i c->l i [" ":r i c]
+       \| def = P \[i:is] c->["(\\", i, "->":unP (def (P \_ c->[i:c])) is [")":c]]
+
+instance expr Printer
+where
+       lit a = P \i c->[toString a:c]
+       (+.) (P l) (P r) = P \i c->["(":l i ["+":r i [")":c]]]
+       (-.) (P l) (P r) = P \i c->["(":l i ["-":r i [")":c]]]
+       (*.) (P l) (P r) = P \i c->["(":l i ["*":r i [")":c]]]
+       (/.) (P l) (P r) = P \i c->["(":l i ["/":r i [")":c]]]
+       (==.) (P l) (P r) = P \i c->["(":l i ["==":r i [")":c]]]
+       If (P p) (P t) (P e) = P \i c->["if ":p i [" then ":t i [" else ":e i [" fi":c]]]]
+
+instance let Printer
+where
+       lett def = P \[i:is] c->
+               let (x In y) = def $ P \_ c->[i:c]
+               in  ["let ",i,"=":(unP x) [i:is] [" in ":(unP y) is c]]
+
+eval :: (Maybe a) -> Maybe a
+eval a = a
+
+instance lambda Maybe
+where
+       (@) l r = ($) <$> l <*> r
+       \| def = Just (\a->fromJust (def (Just a)))
+
+instance expr Maybe
+where
+       lit a = pure a
+       (+.) l r = (+) <$> l <*> r
+       (-.) l r = (-) <$> l <*> r
+       (*.) l r = (*) <$> l <*> r
+       (/.) l r = (/) <$> l <*> r
+       (==.) l r = (==) <$> l <*> r
+       If i t e = if` <$> i <*> t <*> e
+
+instance let Maybe
+where
+       lett def = let (x In y) = def x in y
+
+Start = (print t, "\n", eval t)
+where
+       t :: (v Int) | expr, lambda, let v
+       t  = lett \id =(\| \x->x)
+         In lett \fac=(\| \n->If (n ==. lit 0) (lit 1) (n *. (fac @ n -. lit 1)))
+         In fac @ lit 10

diff --git a/structs/GenC.dcl b/structs/GenC.dcl
index b33d991..840bc09 100644 (file)
--- a/structs/GenC.dcl
+++ b/structs/GenC.dcl
@@ -28,7 +28,7 @@ toStruct :: Box GTSState a | gToStruct{|*|} a
 :: GTSState
 instance zero GTSState
 generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
-derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_name,grd_fields}
+derive gToStruct Int, Bool, Char, Real, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_arity,gtd_name,gtd_conses,gtd_num_conses}, RECORD of {grd_arity,grd_name,grd_fields}
 
 /**
  * Given a GTSState, generate typedefinitions

diff --git a/structs/GenC.icl b/structs/GenC.icl
index c566d23..19a0652 100644 (file)
--- a/structs/GenC.icl
+++ b/structs/GenC.icl
@@ -5,6 +5,7 @@ import Data.Map => qualified updateAt
 import Data.Func, Data.Tuple
 import Data.Maybe
 import Data.Either
+import Data.List => qualified difference, union, find
 import Text
 
 import scc
@@ -35,7 +36,7 @@ gPotInf{|RECORD of {grd_name}|} f s
 :: CType
        = CTTypeDef String
        | CTEnum [String]
-       | CTStruct [(String, [(String, Bool, String)])]
+       | CTStruct Int [(String, [(String, Bool, String)])]
 
 :: GTSState = {dict :: Map String CType}
 instance zero GTSState where zero = {dict=newMap}
@@ -75,7 +76,8 @@ gToStruct{|PAIR|} fl _ fr _ st
                (a, GTSPair l) = GTSPair [a:l]
                (l, r) = GTSPair [l, r]
        , box st)
-gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st
+import Debug.Trace
+gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
        # (Box isPInf) = i []
        # ty = GTSType isPInf
        = case get gtd_name st.dict of
@@ -92,18 +94,26 @@ gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st
                        # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
                        =
                                ( GTSType isPInf gtd_name
-                               , box $ putst gtd_name (CTStruct (zip2 [gcd.gcd_name\\gcd<-gtd_conses] (map (toT o mkccons) n))) st
+                               , box $ putst gtd_name
+                                       (CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
                                )
        where
+               mkty :: GTSResult -> [GTSResult]
                mkty (GTSEither l) = l
                mkty t = [t]
 
+               mkccons :: GTSResult -> [GTSResult]
                mkccons (GTSType pi t) = [GTSType pi t]
                mkccons (GTSPair t) = t
                mkccons _ = []
-               
-               toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
-gToStruct{|RECORD of {grd_name,grd_fields}|} f i st
+
+               ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
+               ctcons gcd cons
+                       # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
+                       = (gcd_name, toT cons)
+               where
+                       toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
+gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st
        # (Box isPInf) = i []
        = case get grd_name st.dict of
                Just n = (GTSType isPInf grd_name, box st)
@@ -112,7 +122,7 @@ gToStruct{|RECORD of {grd_name,grd_fields}|} f i st
                        = case n of
                                GTSPair l =
                                        ( GTSType isPInf grd_name
-                                       , box $ putst grd_name (CTStruct [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
+                                       , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
                                _ = (GTSError, box st)
 
 /**
@@ -123,7 +133,7 @@ toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
 where
        refs (CTTypeDef s) = [s]
        refs (CTEnum _) = []
-       refs (CTStruct cs) = map fst3 (flatten (map snd cs))
+       refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
 
        proc [] c = c
        proc [x] c = ctypedef x (find x m) c
@@ -135,12 +145,12 @@ where
        ctypedef :: String CType [String] -> [String]
        ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c]
        ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
-       ctypedef name (CTStruct [(_, fs)]) c =
+       ctypedef name (CTStruct _ [(_, fs)]) c =
                [ "struct ", name, " {\n"
                : foldr (uncurry3 (field 1))
                ["};\n":c] fs
                ]
-       ctypedef name (CTStruct cs) c =
+       ctypedef name (CTStruct _ cs) c =
                [ "struct ", name, " {\n"
                : ind 1 ["enum {"
                : enum (map fst cs)
@@ -162,7 +172,7 @@ where
        enum [x:xs] c = [x, ",": enum xs c]
 
 typeName ty m c = [case get ty m of
-               Just (CTStruct _) = "struct "
+               Just (CTStruct _ _) = "struct "
                Just (CTEnum _) = "enum "
                _ = ""
        , ty:c]
@@ -179,24 +189,32 @@ uncurry3 f (x,y,z) = f x y z
 toCParser :: GTSState -> ([String], [String])
 toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
 where
-       funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
+       funsigs = foldr (uncurry funsig) [";\n"] $ toList m
        pfname n c = ["parse_", n:c]
        pfcall n c = pfname n ["(get, alloc, err);":c]
-       funsig n c
-               = typeName n m [" ": pfname n ["(\n"
-               : ind 1 ["uint8_t (*get)(void),\n"
-               : ind 1 ["void *(*alloc)(size_t),\n"
-               : ind 1 ["void (*err)(const char *errmsg, ...))"
-               :c]]]]]
-       funbody (n, ty) c = funsig n
+       funsig n (CTStruct i _) c
+               | i > 0
+                       = typeName n m [" "
+                       : pfname n ["(\n"
+                       : funargs 1
+                       $ foldr (\i c->
+                               [",\n":ind 1 ["void *(*parse_", toString i, ")(\n"
+                               : funargs 2 [")":c]]]) [")":c] [0..i-1]]]
+       funsig n _ c = typeName n m [" ": pfname n ["(\n":funargs 1 [")":c]]]
+       funbody (n, ty) c = funsig n ty
                ["\n{\n"
                :ind 1 $ typeName n m [" r;\n"
                :funb ty $ ind 1 ["return r;\n}\n":c]]]
+       funargs i c
+               = ind i ["uint8_t (*get)(void),\n"
+               : ind i ["void *(*alloc)(size_t size),\n"
+               : ind i ["void (*err)(const char *errmsg, ...)"
+               :c]]]
 
        funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]]
        funb (CTEnum a) c = ind 1 ["r = get()\n":c]
-       funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs
-       funb (CTStruct fs) c
+       funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
+       funb (CTStruct _ fs) c
                = ind 1 ["switch(r.cons = get()) {\n"
                :foldr field
                ( ind 1 ["default:\n"
@@ -233,8 +251,8 @@ where
 
        funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c]
        funb (CTEnum a) c = ind 1 ["put(r)\n":c]
-       funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs
-       funb (CTStruct fs) c =
+       funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
+       funb (CTStruct _ fs) c =
                ind 1 ["put(r.cons);\n"
                : ind 1 ["switch(r.cons) {\n"
                :foldr field

diff --git a/structs/qualified b/structs/qualified
new file mode 100644 (file)
index 0000000..e69de29

diff --git a/structs/test.icl b/structs/test.icl
index 8585bd0..a0cd464 100644 (file)
--- a/structs/test.icl
+++ b/structs/test.icl
@@ -1,6 +1,7 @@
 module test
 
 import GenC
+import Text
 
 :: List a = Nil | Cons a (List a)
 :: NInt =: NInt Int
@@ -11,9 +12,12 @@ import GenC
 derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
 derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
 
-Start = (toCFiles t)
+
+Start = let (l, r) = (toCParser (unBox t2)) in concat r
 where
        t :: Box String (List (Muta Int))
 //     t :: Box GTSState NInt
        t = Box "listmutaint"
 
+       t2 :: Box GTSState (Bool, Int)
+       t2 = toStruct

diff --git a/test.icl b/test.icl
index dddfbe1..6df4935 100644 (file)
--- a/test.icl
+++ b/test.icl
@@ -1,20 +1,5 @@
 module test
+class C m :: u:m -> v:m
 
-import StdEnv
-
-import graph_copy_with_names, symbols_in_program
-import System.CommandLine
-
-test :: !{#Symbol} a -> a
-test symbols a
-       # (a, b, c) = copy_to_string_with_names a
-       # (a, r) = copy_from_string_with_names a b c symbols
-       = a
-
-polyid :: (A.a: a -> a) -> (Int, Bool)
-polyid f = (f 42, f True)
-
-Start w
-       # ([argv0:_], w) = getCommandLine w
-       # (symbols, w) = accFiles (read_symbols argv0) w
-       = test symbols (polyid id)
+//Start :: *World -> *(State () *World)
+Start = 42