From 937becfac41c4deb6a3c4de9b89d430c99a6695d Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Thu, 20 Aug 2020 15:43:58 +0200 Subject: [PATCH] make writerT as well from non-flat typedef --- gengen/Data/GenType/CType.icl | 91 +++++++++++++++++------------------ 1 file changed, 45 insertions(+), 46 deletions(-) diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl index ec0d5fb..7caa64e 100644 --- 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] -- 2.20.1