make writerT as well from non-flat typedef

diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index ec0d5fb..7caa64e 100644 (file)
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -28,14 +28,13 @@ where
                ,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
                ,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
 
+indent i c = tell [createArray i '\t':c]
+
 :: FTMonad :== WriterT [String] (StateT [(String, [String])] (Either String)) ()
 flatTypedef :: Type -> Either String [String]
 flatTypedef t = (\(w, es)->flatten (map snd es) ++ w)
        <$> runStateT (execWriterT (ftd t True 0)) []
 where
-       indent :: Int [String] -> FTMonad
-       indent i c = tell [createArray i '\t':c]
-
        ftd :: Type Bool Int -> FTMonad
        ftd (TyRef s) tl i = indent i [s]
        ftd (TyBasic t) tl i 
@@ -91,21 +90,19 @@ where
        fmtField :: Int (String, Type) -> FTMonad
        fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
 
-:: TDMonad :== StateT TDState (Either String) [String]
+:: TDMonad :== WriterT [String] (StateT TDState (Either String)) ()
 :: TDState :== 'Data.Map'.Map String (String, Bool)
 typedefs :: [[Type]] -> Either String [String]
-typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap
+typedefs ts = evalStateT (execWriterT (mapM_ typedefgroup ts)) 'Data.Map'.newMap
 where
        typedefgroup :: [Type] -> TDMonad
        typedefgroup ts
-               =   flatten
-               <$  modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts])
-               <*> mapM (\t->typedef t >>= post ["\n"]) ts
-               <*  modify (flip (foldr $ 'Data.Map'.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
+               =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-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 "
@@ -118,15 +115,11 @@ where
 
        printTypeName :: String -> TDMonad
        printTypeName tname
-               = gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o 'Data.Map'.get tname
+               = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
+               >>= tell
 
-       pre :: [String] (m [String]) -> m [String] | Monad m
-       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]
+       header :: Type [String] -> WriterT [String] m () | Monad m
+       header t c = tell ["// ", toString (replaceBuiltins t), "\n":c]
        
        typedef :: Type -> TDMonad
        typedef (TyRef s) = printTypeName s
@@ -135,52 +128,58 @@ where
                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
+               t = fail $ "basic type: " +++ toString t +++ " not implemented"
+       typedef (TyArray _ a) = tell ["*"] >>| typedef a
        typedef t=:(TyNewType ti ci a)
-               = 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"]
+               =   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]
+               >>| tell ["};\n"]
        //Enumeration
        typedef t=:(TyObject ti fs)
                | and [t =: [] \\ (_, t)<-fs] = header t
-                       ["enum ", safe ti.gtd_name, " {"
-                               , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"] $ pure []
+                       ["enum ", safe ti.gtd_name, "_cons {"
+                               , 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
+       typedef t=:(TyObject ti [(ci, [ty])]) = header t [] >>| tydef ti.gtd_name ci.gcd_type
        //Single constructor
-       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"]
+       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]
+               >>| tell ["};\n"]
        //Complex adt
        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
+               >>| mapM_ fmtCons fs
+               >>| tell ["\t} data;\n};\n"]
        where
                fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
-               fmtCons (ci, []) = pure []
+               fmtCons (ci, []) = tell []
                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"
+               fmtCons (ci, ts) = tell ["\t\tstruct {\n"]
+                       >>| fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
+                       >>| tell ["\t\t} ", safe ci.gcd_name, ";\n"]
+       typedef t = fail $ toString t +++ " not implemented"
        
        tydef :: String GenType -> TDMonad
-       tydef name (GenTypeArrow l r) = pre ["typedef "] $ fmtField "" l >>= post [safe name,";\n"]
+       tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
        
        fmtFields :: Int GenType [String] -> TDMonad
-       fmtFields i _ [] = pure []
-       fmtFields i (GenTypeArrow l r) [x:xs] = pre [createArray i '\t'] $ fmtField x l >>= \c->pre (c ++ [";\n"]) $ fmtFields i r xs
+       fmtFields i _ [] = tell []
+       fmtFields i (GenTypeArrow l r) [x:xs]
+               = indent i [] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs
        
        fmtField :: String GenType -> TDMonad
-       fmtField x (GenTypeCons a) = printTypeName a >>= post [x]
-       fmtField x (GenTypeVar a) = pure ["void *",x]
+       fmtField x (GenTypeCons a) = printTypeName a >>| tell [x]
+       fmtField x (GenTypeVar a) = tell ["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, ")"]
+       fmtField x t=:(GenTypeArrow _ _)
+               = mapM (fmap (concat o snd) o listen o fmtField "") (collectArgs t [])
+                       >>= \[r:as]->tell [r, " (*",x,")(",join ", " as, ")"]
        where
                collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
                collectArgs t c = [t:c]