flatparser

[clean-tests.git] / gengen / Data / GenType / CType.icl

diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index 7caa64e..3c4ca1e 100644 (file)
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -28,6 +28,18 @@ where
                ,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
                ,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
 
+prefix :: Type -> String
+prefix (TyRecord _ _) = "struct "
+prefix (TyObject _ fs)
+       | and [t =: [] \\ (_, t)<-fs] = "enum "
+       | fs =: [(_, [_])] = ""
+       | fs =: [_] = "struct "
+       = "struct "
+prefix  _ = ""
+
+consName :: GenericTypeDefDescriptor -> String
+consName s = "enum " +++ safe s.gtd_name +++ "_cons"
+
 indent i c = tell [createArray i '\t':c]
 
 :: FTMonad :== WriterT [String] (StateT [(String, [String])] (Either String)) ()
@@ -38,7 +50,7 @@ where
        ftd :: Type Bool Int -> FTMonad
        ftd (TyRef s) tl i = indent i [s]
        ftd (TyBasic t) tl i 
-               | tl = tell []
+               | tl = pure ()
                 = case t of
                        BTInt  = indent i ["int64_t"]
                        BTChar = indent i ["char"]
@@ -55,7 +67,7 @@ where
        //Enumeration
        ftd (TyObject ti fs) tl i
                | and [t =: [] \\ (_, t)<-fs]
-                       | tl = tell []
+                       | tl = pure ()
                        = indent i [] >>| enum ti fs
        //Single constructor, single field (box)
        ftd (TyObject ti [(ci, [ty])]) tl i = ftd ty tl i
@@ -84,8 +96,8 @@ where
        
        enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad
        enum ti fs = liftT (gets (lookup ti.gtd_name)) >>= \e->case e of
-               ?None = liftT (modify \s->[(ti.gtd_name, ["enum ", safe ti.gtd_name, "_cons {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
-               ?Just _ = tell ["enum ", safe ti.gtd_name, "_cons"]
+               ?None = liftT (modify \s->[(ti.gtd_name, [consName ti, " {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
+               ?Just _ = tell [consName ti]
 
        fmtField :: Int (String, Type) -> FTMonad
        fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
@@ -97,21 +109,10 @@ typedefs ts = evalStateT (execWriterT (mapM_ typedefgroup ts)) 'Data.Map'.newMap
 where
        typedefgroup :: [Type] -> TDMonad
        typedefgroup ts
-               =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
+               =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, False))\\ty<-ts]))
+               >>| mapM_ (\x->printTypeName x >>| tell [";\n"]) (if (ts=:[_,_:_]) (map typeName ts) [])
+               >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->True)) o typeName) ts))
                >>| mapM_ (\t->typedef t >>| tell ["\n"]) ts
-               >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->False)) o typeName) ts))
-               >>| case ts of
-                       [_] = tell []
-                       ts = mapM_ (\x->printTypeName x >>| tell [";\n"]) (map typeName ts)
-       where
-               prefix :: Type -> String
-               prefix (TyRecord _ _) = "struct "
-               prefix (TyObject _ fs)
-                       | and [t =: [] \\ (_, t)<-fs] = "enum "
-                       | fs =: [(_, [_])] = ""
-                       | fs =: [_] = "struct "
-                       = "struct "
-               prefix  _ = ""
 
        printTypeName :: String -> TDMonad
        printTypeName tname
@@ -140,8 +141,7 @@ where
        //Enumeration
        typedef t=:(TyObject ti fs)
                | and [t =: [] \\ (_, t)<-fs] = header t
-                       ["enum ", safe ti.gtd_name, "_cons {"
-                               , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
+                       [consName ti, " {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
        //Single constructor, single field (box)
        typedef t=:(TyObject ti [(ci, [ty])]) = header t [] >>| tydef ti.gtd_name ci.gcd_type
        //Single constructor
@@ -158,7 +158,7 @@ where
                >>| tell ["\t} data;\n};\n"]
        where
                fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
-               fmtCons (ci, []) = tell []
+               fmtCons (ci, []) = pure ()
                fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
                fmtCons (ci, ts) = tell ["\t\tstruct {\n"]
                        >>| fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
@@ -169,7 +169,7 @@ where
        tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
        
        fmtFields :: Int GenType [String] -> TDMonad
-       fmtFields i _ [] = tell []
+       fmtFields i _ [] = pure ()
        fmtFields i (GenTypeArrow l r) [x:xs]
                = indent i [] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs