.

diff --git a/gengen/Data/GenType/CType.dcl b/gengen/Data/GenType/CType.dcl
index b79c58e..6efad22 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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