From: Mart Lubbers <mart@martlubbers.net>
Date: Wed, 22 Jul 2020 08:23:09 +0000 (+0200)
Subject: .
X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=aaa63abaeb98d48d01ee1c61f4463ce2e42ec454;p=clean-tests.git

.
---

diff --git a/gengen/Data/GenType/CType.dcl b/gengen/Data/GenType/CType.dcl
index b79c58e..6efad22 100644
--- a/gengen/Data/GenType/CType.dcl
+++ b/gengen/Data/GenType/CType.dcl
@@ -7,3 +7,9 @@ from Data.GenType import :: Type
  * generate typedefs for the types grouped by strongly connected components
  */
 typedefs :: [[Type]] -> Either String [String]
+
+/**
+ * Generate a single typedef for a type.
+ * This does not terminate for recursive types
+ */
+flatTypedef :: Type -> Either String [String]
diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index 3b61d0d..538ce9a 100644
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -15,6 +15,62 @@ import StdEnv
 import Data.GenType
 import Text
 
+flatTypedef :: Type -> Either String [String]
+flatTypedef t = case ftd t 0 [] of
+	[] = Left ("Unable to flatTypedef: " +++ toString t)
+	c = Right c
+where
+	indent i c = [createArray i '\t':c]
+
+	ftd :: Type Int [String] -> [String]
+	ftd (TyRef s) i c = indent i [s:c]
+	ftd (TyBasic t) i c = case t of
+		BTInt  = indent i ["int64_t":c]
+		BTChar = indent i ["char":c]
+		BTReal = indent i ["double":c]
+		BTBool = indent i ["bool":c]
+		t = []
+	ftd (TyArrow l r) i c = indent i ["*":ftd a i c]
+	ftd (TyArray _ a) i c = indent i ["*":ftd a i c]
+	ftd (TyNewType ti ci a) i c = ftd a i c
+	ftd (TyRecord ti fs) i c
+		= indent i ["struct ", safe ti.grd_name, " {\n"
+		: foldr (fmtField $ i+1) (indent i ["}\n":c])
+			[(fi.gfd_name, ty)\\(fi, ty)<-fs]
+		]
+	//Enumeration
+	ftd (TyObject ti fs) i c
+		| and [t =: [] \\ (_, t)<-fs]
+			= indent i ["enum ", safe ti.gtd_name, " {"
+				, join ", " [safe ci.gcd_name\\(ci, _)<-fs], "}":c]
+	//Single constructor, single field (box)
+	ftd (TyObject ti [(ci, [ty])]) i c = ftd ty i c
+	//Single constructor
+	ftd (TyObject ti [(ci, ts)]) i c
+		= indent i ["struct ", safe ti.gtd_name, " {\n"
+		: flip (foldr (fmtField $ i+1)) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
+		$ indent i ["}":c]]
+	//Complex adt
+	ftd (TyObject ti fs) i c
+		= indent i ["struct ", safe ti.gtd_name, " {\n"
+		: indent (i+1) ["enum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
+		: indent (i+1) ["struct {\n"
+		: flip (foldr (fmtCons $ i + 2)) fs
+		$ indent (i+1) ["} data;\n"
+		: indent i ["}":c]
+		]]]]
+	where
+		fmtCons i (ci, []) c = c
+		fmtCons i (ci, [t]) c = ftd t i [" ", safe ci.gcd_name, ";\n":c]
+		fmtCons i (ci, ts) c
+			= indent i ["struct {\n"
+			: flip (foldr (fmtField (i+1))) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
+			$ indent i ["} ", safe ci.gcd_name, ";\n":c]
+			]
+	ftd t i c = []
+
+	fmtField i (name, ty) c = ftd ty i [" ", name, ";\n":c]
+
 typedefs :: [[Type]] -> Either String [String]
 typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
 
@@ -75,6 +131,8 @@ pre t s = ((++)t) <$> s
 post :: [String] [String] -> m [String] | pure m
 post t s = pure (s ++ t)
 
+header t c = pre ["// ", toString (replaceBuiltins t), "\n":c]
+
 typedef :: Type -> TDMonad
 typedef (TyRef s) = printTypeName s
 typedef (TyBasic t) = case t of
@@ -85,37 +143,36 @@ typedef (TyBasic t) = case t of
 	t = pure []//liftT $ Left $ "basic type: " +++ toString t +++ " not implemented"
 typedef (TyArray _ a) = pre ["*"] $ typedef a
 typedef t=:(TyNewType ti ci a)
-	= pre ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
-typedef t=:(TyRecord ti fs) = pre
-	[ "// ", toString t, "\n", "struct ", safe ti.grd_name, " {\n"]
+	= header t [] $ tydef ti.gtd_name ci.gcd_type
+typedef t=:(TyRecord ti fs) = header t ["struct ", safe ti.grd_name, " {\n"]
 	$ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs] >>= post ["};\n"]
 //Enumeration
 typedef t=:(TyObject ti fs)
-	| and [t =: [] \\ (_, t)<-fs] = pure
-		[ "// ", toString t, "\n", "enum ", safe ti.gtd_name, " {"
-		, join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
+	| and [t =: [] \\ (_, t)<-fs] = header t
+		["enum ", safe ti.gtd_name, " {"
+			, join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"] $ pure []
 //Single constructor, single field (box)
-typedef t=:(TyObject ti [(ci, [ty])]) = pre
-	["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
+typedef t=:(TyObject ti [(ci, [ty])]) = header t [] $ tydef ti.gtd_name ci.gcd_type
 //Single constructor
-typedef t=:(TyObject ti [(ci, ts)]) = pre
-	[ "// ", toString t, "\n", "struct ", safe ti.gtd_name, " {\n"]
+typedef t=:(TyObject ti [(ci, ts)]) = header t ["struct ", safe ti.gtd_name, " {\n"]
 	$ fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts] >>= post ["};\n"]
 //Complex adt
-typedef t=:(TyObject ti fs) = pre
-	[ "// ", toString t, "\nstruct ", safe ti.gtd_name, " {\n"
-	, "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
-	, "\tstruct {\n"]
+typedef t=:(TyObject ti fs) = header t
+	["struct ", safe ti.gtd_name, " {\n"
+		, "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
+		, "\tstruct {\n"]
 	$ mapM fmtCons fs
 	>>= post ["\t} data;\n};\n"] o flatten
 where
 	fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
 	fmtCons (ci, []) = pure []
+	fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
 	fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
 		$ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
 		>>= post ["\t\t} ", safe ci.gcd_name, ";\n"]
 typedef t = liftT $ Left $ toString t +++ " not implemented"
 
+tydef :: String GenType -> TDMonad
 tydef name (GenTypeArrow l r) = pre ["typedef "] $ fmtField "" l >>= post [safe name,";\n"]
 
 fmtFields :: Int GenType [String] -> TDMonad
diff --git a/gengen/test.icl b/gengen/test.icl
index 1348136..18fde1d 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -18,7 +18,7 @@ derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT,
 
 :: T a =: T2 a
 :: NT =: NT Int
-:: SR = {f1 :: Int, f2 :: Bool}
+:: SR = {f1 :: Int, f2 :: Bool, f3 :: Tr Either Bool, f4 :: Enum}
 :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
 	f5 :: [([#Int], [#Int!], [!Int!], [!Int], [Int!])],
 	f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/
@@ -41,21 +41,25 @@ derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT,
 :: Odd a = Odd (Even a) | OddBlurp
 :: Even a = Even (Odd a) | EvenBlurp
 :: Enum = A | B | C
-Start = typedefs //$ (\x->[[gTypeToType x]])
+Start =
+	( flatTypedef $ gTypeToType $ unBox t
+	, typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+	)
+//Start = typedefs //$ (\x->[[gTypeToType x]])
 //	$ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
 //	$ (\x->[[x]])
-	$ map (map gTypeToType)
-	$ map (filter (not o isBasic))
-	$ flattenGType
-	$ unBox t
+//	$ map (map gTypeToType)
+//	$ map (filter (not o isBasic))
+//	$ flattenGType
+//	$ unBox t
 
 
 //t :: Box GType (?# Int)
 //t :: Box GType (Maybe [Maybe (Either Bool String)])
 //t :: Box GType ([SR], Enum, T Int, NT, Blurp Int)
 //t :: Box GType [EnumList]
-//t :: Box GType (Tr Either Enum)
-t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
+t :: Box GType (Int -> SR)
+//t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
 t = gType{|*|}
 
 //Start = toString t