From: Mart Lubbers <mart@martlubbers.net>
Date: Tue, 26 May 2020 11:58:47 +0000 (+0200)
Subject: monomorph structgen
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=dd851e8574c37cad729a3ba3b4e64a548bb4422e;p=clean-tests.git

monomorph structgen
---

diff --git a/structs/GenC.dcl b/structs/GenC.dcl
new file mode 100644
index 0000000..b33d991
--- /dev/null
+++ b/structs/GenC.dcl
@@ -0,0 +1,76 @@
+definition module GenC
+
+import StdGeneric
+from Data.Either import :: Either
+from StdOverloaded import class zero
+
+/**
+ * Helper types for @ style types
+ */
+:: Box b a =: Box b
+derive bimap Box
+unBox (Box b) :== b
+box b :== Box b
+reBox x :== box (unBox x)
+
+/**
+ * Calculate whether a type has a potentially infinite size
+ */
+potInf :: Box Bool a | gPotInf{|*|} a
+generic gPotInf a :: [String] -> Box Bool a
+derive gPotInf Int, Bool, Char, Real, World, Dynamic, UNIT, CONS, FIELD, EITHER, PAIR, OBJECT of {gtd_name}, RECORD of {grd_name}
+
+/**
+ * Calculate the ctype representation of a type
+ */
+toStruct :: Box GTSState a | gToStruct{|*|} a
+:: GTSResult
+:: 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}
+
+/**
+ * Given a GTSState, generate typedefinitions
+ */
+toCType :: GTSState -> [String]
+
+/**
+ * Given a GTSState, generate a parser
+ * @result Function signatures
+ * @result Function
+ */
+toCParser :: GTSState -> ([String], [String])
+/**
+ * Given a GTSState, generate a printer
+ * @result Function signatures
+ * @result Function
+ */
+toCPrinter :: GTSState -> ([String], [String])
+
+/**
+ * Generate a serialized value for the given type
+ * @param value
+ * @param continuation list
+ * @result Bytes
+ */
+toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
+generic gToCValue a :: a [Char] -> [Char]
+derive gToCValue Int, Bool, Char, UNIT, EITHER, PAIR, CONS of {gcd_index}, FIELD, RECORD, OBJECT
+
+/**
+ * Parse a value from the serializized value
+ * @param bytes
+ * @result Either an error or a value
+ */
+:: FromCValueError = CVEUnknownConstructor | CVEInputExhausted
+fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
+generic gFromCValue a :: ([Char] -> Either FromCValueError (a, [Char]))
+derive gFromCValue Int, Bool, Char, UNIT, EITHER, PAIR, CONS of {gcd_index}, FIELD, RECORD, OBJECT
+
+/**
+ * @param type in a box with a filename
+ * @param .h file
+ * @param .c file
+ */
+toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
diff --git a/structs/GenC.icl b/structs/GenC.icl
new file mode 100644
index 0000000..c566d23
--- /dev/null
+++ b/structs/GenC.icl
@@ -0,0 +1,349 @@
+implementation module GenC
+
+import StdEnv, StdGeneric, StdMaybe
+import Data.Map => qualified updateAt
+import Data.Func, Data.Tuple
+import Data.Maybe
+import Data.Either
+import Text
+
+import scc
+
+derive bimap Box
+
+potInf :: Box Bool a | gPotInf{|*|} a
+potInf = gPotInf{|*|} []
+
+generic gPotInf a :: [String] -> Box Bool a
+gPotInf{|Int|} _ = box False
+gPotInf{|Bool|} _ = box False
+gPotInf{|Char|} _ = box False
+gPotInf{|Real|} _ = box False
+gPotInf{|World|} _ = box False
+gPotInf{|Dynamic|} _ = box False
+gPotInf{|c|} _ = box False
+gPotInf{|UNIT|} _ = box False
+gPotInf{|CONS|} f s = reBox (f s)
+gPotInf{|FIELD|} f s = reBox (f s)
+gPotInf{|EITHER|} fl fr s = box (unBox (fl s) || unBox (fr s))
+gPotInf{|PAIR|} fl fr s = box (unBox (fl s) || unBox (fr s))
+gPotInf{|OBJECT of {gtd_name}|} f s
+	= if (isMember gtd_name s) (box True) (reBox (f [gtd_name:s]))
+gPotInf{|RECORD of {grd_name}|} f s
+	= if (isMember grd_name s) (box True) (reBox (f [grd_name:s]))
+
+:: CType
+	= CTTypeDef String
+	| CTEnum [String]
+	| CTStruct [(String, [(String, Bool, String)])]
+
+:: GTSState = {dict :: Map String CType}
+instance zero GTSState where zero = {dict=newMap}
+
+toStruct :: Box GTSState a | gToStruct{|*|} a
+toStruct = snd $ gToStruct{|*|} zero
+generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
+:: GTSResult
+	= GTSType Bool String //ispointer and the name
+	| GTSUnit
+	| GTSEither [GTSResult]
+	| GTSPair [GTSResult]
+	| GTSError
+
+putst k v st = {st & dict=put k v st.dict}
+
+gToStruct{|Int|} st  = (GTSType False "uint64_t", box st)
+gToStruct{|Bool|} st = (GTSType False "bool", box st)
+gToStruct{|Char|} st = (GTSType False "char", box st)
+gToStruct{|Real|} st = (GTSType False "double", box st)
+gToStruct{|UNIT|} st = (GTSUnit, box st)
+gToStruct{|CONS|} f _ st = appSnd reBox $ f st
+gToStruct{|FIELD|} f _ st = appSnd reBox $ f st
+gToStruct{|EITHER|} fl _ fr _ st
+	# (l, Box st) = fl st
+	# (r, Box st) = fr st
+	= (case (l, r) of
+		(GTSEither l, GTSEither r) = GTSEither (l ++ r)
+		(a, GTSEither l) = GTSEither [a:l]
+		(l, r) = GTSEither [l, r]
+	, box st)
+gToStruct{|PAIR|} fl _ fr _ st
+	# (l, Box st) = fl st
+	# (r, Box st) = fr st
+	= (case (l, r) of
+		(GTSPair l, GTSPair r) = GTSPair (l ++ r)
+		(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
+	# (Box isPInf) = i []
+	# ty = GTSType isPInf
+	= case get gtd_name st.dict of
+		Just _ = (GTSType isPInf gtd_name, box st)
+		Nothing
+			//Newtype
+			| gtd_num_conses == 0
+				= case f st of
+					(GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st)
+			//If it is just an enumeration, Just the enum
+			| and [gcd.gcd_arity == 0\\gcd<-gtd_conses]
+				= (GTSType False gtd_name, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
+			//Constructors with data fields
+			# (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
+				)
+	where
+		mkty (GTSEither l) = l
+		mkty t = [t]
+
+		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
+	# (Box isPInf) = i []
+	= case get grd_name st.dict of
+		Just n = (GTSType isPInf grd_name, box st)
+		Nothing
+			# (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) 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)
+				_ = (GTSError, box st)
+
+/**
+ * Given a GTSState, generate typedefinitions
+ */
+toCType :: GTSState -> [String]
+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))
+
+	proc [] c = c
+	proc [x] c = ctypedef x (find x m) c
+	proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts
+	where
+		ts = [(x, find x m)\\x<-xs]
+		prototype x c = ["struct ", x, ";\n":c]
+
+	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 =
+		[ "struct ", name, " {\n"
+		: foldr (uncurry3 (field 1))
+		["};\n":c] fs
+		]
+	ctypedef name (CTStruct cs) c =
+		[ "struct ", name, " {\n"
+		: ind 1 ["enum {"
+		: enum (map fst cs)
+		["} cons;\n"
+		: ind 1 ["union {\n"
+		: foldr (uncurry struct)
+			(ind 1 ["} data;\n};\n":c])
+		cs]]]]
+
+	struct name [] c = c
+	struct name [(ty, pi, _)] c = field 2 ty pi name c
+	struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs]
+	
+	field i ty pi name c
+		= ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
+	
+	enum [] c = c
+	enum [x] c = [x:c]
+	enum [x:xs] c = [x, ",": enum xs c]
+
+typeName ty m c = [case get ty m of
+		Just (CTStruct _) = "struct "
+		Just (CTEnum _) = "enum "
+		_ = ""
+	, ty:c]
+
+ind n c = [createArray n '\t':c]
+
+uncurry3 f (x,y,z) = f x y z
+
+/**
+ * Given a GTSState, generate a parser
+ * @result Function signature
+ * @result Function
+ */
+toCParser :: GTSState -> ([String], [String])
+toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
+where
+	funsigs = [concat $ funsig n [";\n"]\\(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
+		["\n{\n"
+		:ind 1 $ typeName n m [" r;\n"
+		:funb ty $ ind 1 ["return r;\n}\n":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
+		= ind 1 ["switch(r.cons = get()) {\n"
+		:foldr field
+		( ind 1 ["default:\n"
+		: ind 2 ["break;\n"
+		: ind 1 ["}\n":c]]]) fs]
+	where
+		field (n, []) c = c
+		field (n, fs) c =
+			ind 1 ["case ", n, ":\n"
+			: foldr (sfield 2 ("r.data."+++ n))
+			(ind 2 ["break;\n":c]) fs]
+
+	sfield i r (ty, ptr, f) c
+		= (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c)
+		$ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty ["\n":c]]
+
+/**
+ * Given a GTSState, generate a printer
+ * @result Function signature
+ * @result Function
+ */
+toCPrinter :: GTSState -> ([String], [String])
+toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m))
+where
+	funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
+	pfname n c = ["print_", n:c]
+	pfcall r n c = pfname n ["(", r, ", put);":c]
+	funsig n c =
+		["void ":pfname n ["(\n"
+		: ind 1 $ typeName n m [" r,\n"
+		: ind 1 ["void (*put)(uint8_t))"
+		:c]]]]
+	funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]]
+
+	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 =
+		ind 1 ["put(r.cons);\n"
+		: ind 1 ["switch(r.cons) {\n"
+		:foldr field
+		( ind 1 ["default:\n"
+		: ind 2 ["break;\n"
+		: ind 1 ["}\n":c]]]) fs]]
+	where
+		field (n, []) c = c
+		field (n, fs) c
+			= ind 1 ["case ", n, ":\n"
+			: foldr (sfield 2 ("r.data."+++ n))
+			(ind 2 ["break;\n":c]) fs]
+
+	sfield i r (ty, ptr, f) c
+		= ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]
+
+toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
+toCValue a c = gToCValue{|*|} a c
+
+gToCValue{|Char|} x c = [x:c]
+gToCValue{|Int|} x c =
+	[ toChar (x >> 56)
+	, toChar (x >> 48)
+	, toChar (x >> 40)
+	, toChar (x >> 32)
+	, toChar (x >> 24)
+	, toChar (x >> 16)
+	, toChar (x >> 8)
+	, toChar x:c]
+gToCValue{|Bool|} x c = [toChar (if x 1 0):c]
+gToCValue{|UNIT|} x c = c
+gToCValue{|EITHER|} l _ (LEFT x) c = l x c
+gToCValue{|EITHER|} _ r (RIGHT x) c = r x c
+gToCValue{|PAIR|} l r (PAIR x y) c = l x $ r y c
+gToCValue{|CONS of {gcd_index}|} f (CONS x) c = [toChar gcd_index:f x c]
+gToCValue{|FIELD|} f (FIELD x) c = f x c
+gToCValue{|RECORD|} f (RECORD x) c = f x c
+gToCValue{|OBJECT|} f (OBJECT x) c = f x c
+
+fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
+fromCValue i = gFromCValue{|*|} i
+
+:: Parser a :== [Char] -> Either FromCValueError (a, [Char])
+top :: Parser Char
+top = satisfy (\_->True) CVEInputExhausted
+
+satisfy :: (Char -> Bool) FromCValueError -> Parser Char
+satisfy f e = \c->case c of
+	[c:cs]
+		| f c = Right (c, cs)
+		      = Left e
+	[] = Left CVEInputExhausted
+
+yield :: a -> Parser a
+yield a = \c->Right (a, c)
+
+list :: [Parser a] -> Parser [a]
+list [] = yield []
+list [x:xs] = cons <<$>> x <<*>> list xs
+
+cons x xs = [x:xs]
+
+(<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b
+(<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a
+
+(<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b
+(<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f
+
+(<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a
+(<<|>>) l r = \c->either (\_->r c) Right $ l c
+
+int b = sum <<$>> list [(\x->toInt x << (i*8)) <<$>> top \\i<-[b-1,b-2..0]]
+gFromCValue{|Char|} = top
+gFromCValue{|Int|} = fromInt <<$>> int 8
+gFromCValue{|Bool|} = ((==) '\1') <<$>> top
+gFromCValue{|UNIT|} = yield UNIT
+gFromCValue{|EITHER|} l r = (LEFT <<$>> l) <<|>> (RIGHT <<$>> r)
+gFromCValue{|PAIR|} l r = PAIR <<$>> l <<*>> r
+gFromCValue{|CONS of {gcd_index}|} f
+	= (\x->CONS) <<$>> satisfy ((==)(toChar gcd_index)) CVEUnknownConstructor <<*>> f
+gFromCValue{|FIELD|} f = (\x->FIELD x) <<$>> f
+gFromCValue{|RECORD|} f = RECORD <<$>> f
+gFromCValue{|OBJECT|} f = (\x->OBJECT x) <<$>> f
+
+toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
+toCFiles b=:(Box fn)
+	# (padefs, paimp) = toCParser gts
+	# (prdefs, primp) = toCPrinter gts
+	=
+		( flatten
+			[["#ifndef ", guard, "\n"
+			, "#define ", guard, "\n"
+			, "#include <stdint.h>\n"
+			, "#include <stddef.h>\n"
+			, "#include <stdarg.h>\n"]
+			, toCType gts, padefs, prdefs
+			, ["#endif\n"]
+			]
+		, flatten
+			[["#include \"", fn, ".h\"\n"]
+			, paimp
+			, primp]
+		)
+where
+	guard = {safe c\\c<-:fn +++ ".h"}
+	safe c
+		| not (isAlphanum c) = '_'
+		= toUpper c
+	gts = unBox (cast b)
+
+	cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a
+	cast _ = toStruct
diff --git a/structs/scc.dcl b/structs/scc.dcl
new file mode 100644
index 0000000..c683730
--- /dev/null
+++ b/structs/scc.dcl
@@ -0,0 +1,13 @@
+definition module scc
+
+from StdOverloaded import class <, class ==
+from StdClass import class Ord, class Eq
+
+/*
+ * Find all strongly connected components using tarjan's algorithm
+ * see: https://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm
+ *
+ * @param list of nodes together with their successors
+ * @return the strongly connected components
+ */
+scc :: ![(a, [a])] -> [[a]] | Eq, Ord a
diff --git a/structs/scc.icl b/structs/scc.icl
new file mode 100644
index 0000000..408e647
--- /dev/null
+++ b/structs/scc.icl
@@ -0,0 +1,41 @@
+implementation module scc
+
+import StdEnv, StdMaybe
+import Data.Map => qualified updateAt
+
+:: St a  = {nextindex :: !Int, stack :: ![a], map :: !Map a Annot, sccs :: ![[a]]}
+:: Annot = {index :: !Int, lowlink :: !Int, onstack :: !Bool}
+
+scc :: ![(a, [a])] -> [[a]] | Eq, Ord a
+scc nodes = reverse (foldr (strongconnect nodes) {nextindex=zero,stack=[],map=newMap,sccs=[]} nodes).sccs
+where
+	strongconnect :: ![(a, [a])] !(a, [a]) !(St a) -> St a | Eq, Ord a
+	strongconnect nodes (v, suc) s
+		| isJust (get v s.map) = s
+		# s = foldr (processSucc nodes v)
+			{ s & map   = put v {index=s.nextindex, lowlink=s.nextindex, onstack=True} s.map
+			, stack     = [v:s.stack]
+			, nextindex = inc s.nextindex
+			} suc
+		# (Just a) = get v s.map
+		| a.index <> a.lowlink = s
+		# (scc, [sl:stack]) = span ((<>) v) s.stack
+		# scc = scc ++ [sl]
+		= { s & sccs = [scc:s.sccs]
+		  , stack    = stack
+		  , map      = foldr (alter \(Just s)->Just {s & onstack=False}) s.map scc
+		  }
+	where
+		processSucc :: ![(a, [a])] !a !a !(St a) -> St a | Eq, Ord a
+		processSucc nodes v w s = case get w s.map of
+			Nothing
+				# n = filter ((==)w o fst) nodes
+				| n =: [] = s
+				# s = strongconnect nodes (hd n) s
+				# (Just aw) = get w s.map
+				# (Just av) = get v s.map
+				= {s & map=put v {av & lowlink=min av.lowlink aw.lowlink} s.map}
+			Just aw=:{onstack=True}
+				# (Just av) = get v s.map
+				= {s & map=put v {av & lowlink=min aw.index av.lowlink} s.map}
+			Just _ = s
diff --git a/structs/test.icl b/structs/test.icl
new file mode 100644
index 0000000..8585bd0
--- /dev/null
+++ b/structs/test.icl
@@ -0,0 +1,19 @@
+module test
+
+import GenC
+
+:: List a = Nil | Cons a (List a)
+:: NInt =: NInt Int
+:: T = A | B | C
+:: R = {i :: Int, q :: T}
+:: Muta a = Muta (Mutb a)
+:: Mutb a = Mutb (Muta a)
+derive gToStruct NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
+derive gPotInf NInt, T, List, R, Muta, Mutb, (,), (), [], (,,)
+
+Start = (toCFiles t)
+where
+	t :: Box String (List (Muta Int))
+//	t :: Box GTSState NInt
+	t = Box "listmutaint"
+