From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 5 Jun 2020 08:38:04 +0000 (+0200)
Subject: t
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=65e5bccfdd395caa062a6c63c8023bd2d625f193;p=clean-tests.git

t
---

diff --git a/lambda/test.dcl b/lambda/test.dcl
new file mode 100644
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
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
--- 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
--- 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
index 0000000..e69de29
diff --git a/structs/test.icl b/structs/test.icl
index 8585bd0..a0cd464 100644
--- 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
--- 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