From 63e0b14ad4a2fbef5d9260e5a11dd09f1a4e7ac3 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Fri, 10 Jul 2020 15:48:54 +0200
Subject: [PATCH] .

---
 gengen/Data/GenType.dcl       |  14 ++--
 gengen/Data/GenType.icl       |  10 +++
 gengen/Data/GenType/CType.icl | 139 ++++++++++++++++++----------------
 gengen/test.icl               |  19 +++--
 4 files changed, 105 insertions(+), 77 deletions(-)

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
index a073c6b..aeaf7da 100644
--- a/gengen/Data/GenType.dcl
+++ b/gengen/Data/GenType.dcl
@@ -67,16 +67,20 @@ typeName :: Type -> String
  * Predicate whether the outer type is a builtin type
  */
 class isBuiltin a :: a -> Bool
-instance isBuiltin Type
-instance isBuiltin GType
+instance isBuiltin Type, GType
+
+/**
+ * Predicate whether the outer type is a basic type
+ * Int, Bool, Char, Real, World, File, Dynamic
+ */
+class isBasic a :: a -> Bool
+instance isBasic Type, GType
 
 /**
  * Replace builtin constructors with their pretty names
  */
 class replaceBuiltins a :: a -> a
-instance replaceBuiltins Type
-instance replaceBuiltins GType
-instance replaceBuiltins GenType
+instance replaceBuiltins Type, GType, GenType
 
 /**
  * Creates a deep representation of the type
diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
index e6cfe8b..aeaf5aa 100644
--- a/gengen/Data/GenType.icl
+++ b/gengen/Data/GenType.icl
@@ -271,6 +271,16 @@ where
 	isBuiltin (GTyRef a) = isBuiltin a
 	isBuiltin _ = True
 
+instance isBasic Type
+where
+	isBasic (TyBasic t) = True
+	isBasic _ = False
+
+instance isBasic GType
+where
+	isBasic (GTyBasic t) = True
+	isBasic _ = False
+
 instance replaceBuiltins GenericFieldDescriptor
 where
 	replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}
diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index 3ce9216..3b61d0d 100644
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -8,31 +8,66 @@ import Data.Either
 import Data.Maybe
 import Data.Func
 import Data.Functor
-import Data.List
+import Data.Tuple
+import qualified Data.Map
+from Data.Map import :: Map(..), putList, alter, get, union, fromList
 import StdEnv
 import Data.GenType
 import Text
 
 typedefs :: [[Type]] -> Either String [String]
-typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) { tinfo = [] }
+typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
 
 :: TDMonad :== StateT TDState (Either String) [String]
-:: TDState = { tinfo :: [(String, Bool)] }
+:: TDState :== 'Data.Map'.Map String (String, Bool)
 
 typedefgroup :: [Type] -> TDMonad
 typedefgroup ts
 	=   flatten
-//	<$  mapM (\t->modify \s->{s & tinfo=[(typeName t, True):s.tinfo]}) ts
-	<$  modify (\s->{s & tinfo=[(typeName t, True)\\t<-ts] ++ s.tinfo})
+	<$  modify (putList [(typeName ty, (prefix ty, True))\\ty<-ts])
 	<*> mapM (\t->typedef t >>= post ["\n"]) ts
-	<*  modify (\s->{s & tinfo=[(typeName t, maybeInfinite t)\\t<-ts] ++ s.tinfo})
+	<*  modify (flip (foldr $ alter (fmap (fmap \_->False)) o typeName) ts)
+	>>= \c->case ts of
+		[_] = pure c
+		ts = mapM (\x->printTypeName x >>= post [";\n"]) (map typeName ts)
+			>>= post c o flatten
 where
-	maybeInfinite :: Type -> Bool
-	maybeInfinite t = False
+	prefix :: Type -> String
+	prefix (TyRecord _ _) = "struct "
+	prefix (TyObject _ fs)
+		| and [t =: [] \\ (_, t)<-fs] = "enum "
+		| fs =: [(_, [_])] = ""
+		| fs =: [_] = "struct "
+		= "struct "
+	prefix  _ = ""
 
 printTypeName :: String -> TDMonad
-printTypeName tname = maybe [tname] (\b->[tname, " ", if b "*" ""])
-	<$> gets \s->lookup tname s.tinfo
+printTypeName tname
+	= gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o get tname
+
+safe s = concat [sf c\\c <-:s]
+where
+	sf '~' = "Tld"
+	sf '@' = "At"
+	sf '#' = "Hsh"
+	sf '$' = "Dlr"
+	sf '%' = "Prc"
+	sf '^' = "Hat"
+	sf '?' = "Qtn"
+	sf '!' = "Bng"
+	sf ':' = "Cln"
+	sf '+' = "Pls"
+	sf '-' = "Min"
+	sf '*' = "Ast"
+	sf '<' = "Les"
+	sf '>' = "Gre"
+	sf '\\' = "Bsl"
+	sf '/' = "Slh"
+	sf '|' = "Pip"
+	sf '&' = "Amp"
+	sf '=' = "Eq"
+	sf '.' = "Dot"
+	sf c = toString c
 
 pre :: [String] (m [String]) -> m [String] | Monad m
 pre t s = ((++)t) <$> s
@@ -42,32 +77,34 @@ post t s = pure (s ++ t)
 
 typedef :: Type -> TDMonad
 typedef (TyRef s) = printTypeName s
-typedef (TyBasic BTInt) = pure [IF_INT_64_OR_32 "int64_t" "int32_t"]
-typedef (TyBasic BTChar) = pure ["char"]
-typedef (TyBasic BTReal) = pure ["double"]
-typedef (TyBasic BTBool) = pure ["bool"]
+typedef (TyBasic t) = case t of
+	BTInt = printTypeName "int64_t"
+	BTChar = printTypeName "char"
+	BTReal = printTypeName "double"
+	BTBool = printTypeName "bool"
+	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", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
+	= pre ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
 typedef t=:(TyRecord ti fs) = pre
-	[ "// ", toString t, "\n", "struct ", ti.grd_name, " {\n"]
+	[ "// ", toString t, "\n", "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 ", ti.gtd_name, " {"
-		, join ", " [ci.gcd_name\\(ci, _)<-fs], "};\n"]
+		[ "// ", toString t, "\n", "enum ", safe ti.gtd_name, " {"
+		, join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
 //Single constructor, single field (box)
 typedef t=:(TyObject ti [(ci, [ty])]) = pre
-	["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
+	["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type
 //Single constructor
 typedef t=:(TyObject ti [(ci, ts)]) = pre
-	[ "// ", toString t, "\n", "struct ", ti.gtd_name, " {\n"]
+	[ "// ", toString t, "\n", "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 ", ti.gtd_name, " {\n"
-	, "\tenum {", join ", " [ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
+	[ "// ", toString t, "\nstruct ", 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
@@ -76,50 +113,22 @@ where
 	fmtCons (ci, []) = pure []
 	fmtCons (ci, ts) = pre ["\t\tstruct {\n"]
 		$ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
-		>>= post ["\t\t} ", ci.gcd_name, ";\n"]
-typedef t = pure []//liftT $ Left $ toString t +++ " not implemented"
+		>>= post ["\t\t} ", safe ci.gcd_name, ";\n"]
+typedef t = liftT $ Left $ toString t +++ " not implemented"
+
+tydef name (GenTypeArrow l r) = pre ["typedef "] $ fmtField "" l >>= post [safe name,";\n"]
 
 fmtFields :: Int GenType [String] -> TDMonad
 fmtFields i _ [] = pure []
-fmtFields i (GenTypeArrow l r) [x:xs] = fmtField i x l >>= flip pre (fmtFields i r xs)
+fmtFields i (GenTypeArrow l r) [x:xs] = pre [createArray i '\t'] $ fmtField x l >>= \c->pre (c ++ [";\n"]) $ fmtFields i r xs
 
-fmtField :: Int String GenType -> TDMonad
-fmtField i x (GenTypeCons a) = pre [createArray i '\t'] $ printTypeName a >>= post [x,";\n"]
-fmtField i x (GenTypeVar a) = fmtField i x (GenTypeCons "void *")
-fmtField i x (GenTypeApp l r) = fmtField i x l
-fmtField i x t=:(GenTypeArrow _ _) = liftT $ Left $ toString t +++ " unsupported"
-//typedef t=:(TyRecord ti fs) = pre
-//	[ "// ", toString t, "\n", "struct ", i.grd_name, " {\n"]
-//	$ mapM (fmtField 1) [(i.gfd_name, t)\\(i, t)<-fs]
-//	>>= post ["};\n"] o flatten
-////Enumeration
-//typedef t=:(TyObject i fs)
-//	| and [t =: [] \\ (_, t)<-fs] = pure
-//		[ "// ", toString t, "\n", "enum ", i.gtd_name, " {"
-//		, join ", " [i.gcd_name\\(i, _)<-fs], "};\n"]
-////Single constructor, single field (box)
-//typedef t=:(TyObject i [(j, [ty])]) = pre
-//	["// ", toString t, "\n", "typedef ", i.gtd_name, " "] $ typedef ty
-////Single constructor
-//typedef t=:(TyObject i [(j, ts)]) = pre
-//	[ "// ", toString t, "\n", "struct ", i.gtd_name, " {\n"]
-//	$ mapM (fmtField 1) (numberConsData ts)
-//	>>= post ["};\n"] o flatten
-////Complex adt
-//typedef t=:(TyObject i fs) = pre
-//	[ "// ", toString t, "\nstruct ", i.gtd_name, " {\n"
-//	, "\tenum {", join ", " [i.gcd_name\\(i, _)<-fs], "} cons;\n"
-//	, "\tstruct {\n"]
-//	$ mapM fmtCons fs
-//	>>= post ["\t} data;\n};\n"] o flatten
-//where
-//	fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
-//	fmtCons (i, []) = pure []
-//	fmtCons (i, ts) = pre ["\t\tstruct {\n"]
-//		$ mapM (fmtField 3) (numberConsData ts)
-//		>>= post ["\t\t} ", i.gcd_name, ";\n"] o flatten
-
-numberConsData ts = [("f"+++toString i, t)\\i<-[0..] & t<-ts]
-
-//fmtField :: Int (String, Type) -> TDMonad
-//fmtField indent (i, t) = pre [createArray indent '\t'] $ typedef t >>= post [" ", i, ";\n"]
+fmtField :: String GenType -> TDMonad
+fmtField x (GenTypeCons a) = printTypeName a >>= post [x]
+fmtField x (GenTypeVar a) = pure ["void *",x]
+fmtField x (GenTypeApp l r) = fmtField x l
+fmtField x t=:(GenTypeArrow _ r)
+	= map concat <$> mapM (fmtField "") (collectArgs t [])
+		>>= \[r:as]->pure [r, " (*",x,")(",join ", " as, ")"]
+where
+	collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
+	collectArgs t c = [t:c]
diff --git a/gengen/test.icl b/gengen/test.icl
index 2a59baa..1348136 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -14,22 +14,25 @@ import Data.Either
 import Data.GenType
 import Data.GenType.CType
 
-derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp
+derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList
 
 :: T a =: T2 a
 :: NT =: NT Int
 :: SR = {f1 :: Int, f2 :: Bool}
 :: 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})*/}
+	f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/
+	f7 :: {!Int}}
 :: Tr m b= Tr (m Int b)
-:: Frac a = (/.) infixl 7 a a 
+:: Frac a = (/.) infixl 7 a a  | Flurp
 :: Fix f = Fix (f (Fix f))
 
 :: List a = Cons a (List a) | Nil
 
 :: Blurp a = Blurp (List a) | Blorp
 
+:: EnumList = ECons Enum EnumList | ENil
+
 ////Start :: [String]
 ////Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
 //:: Pair a b = Pair a b
@@ -42,15 +45,17 @@ 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
-//
-//
+
+
 //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 ([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 (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
 t = gType{|*|}
 
 //Start = toString t
-- 
2.20.1