From: Mart Lubbers Date: Fri, 21 Aug 2020 11:53:00 +0000 (+0200) Subject: use reader for indentation X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=bbb575e3ac52e3e67963bf602ee61a1af087ea83;p=clean-tests.git use reader for indentation --- diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl index ab8417d..c363450 100644 --- a/gengen/Data/GenType/CParser.icl +++ b/gengen/Data/GenType/CParser.icl @@ -6,6 +6,7 @@ import Control.Monad => qualified join import Control.Monad.State import Control.Monad.Trans import Control.Monad.Writer +import Control.Monad.Reader import Control.Monad.Fail import Data.Either import Data.Func @@ -17,9 +18,9 @@ import Data.GenType import Data.GenType.CType instance MonadFail (Either String) where fail s = Left s -:: FPMonad :== WriterT [String] (Either String) () +:: FPMonad :== WriterT [String] (ReaderT Int (Either String)) () -indent i c = tell [createArray i '\t':c] +indent c = liftT ask >>= \i->tell [createArray i '\t':c] (<.>) infixr 6 (<.>) a b = a +++ "." +++ b @@ -29,7 +30,7 @@ indent i c = tell [createArray i '\t':c] * This does not terminate for a recursive type */ flatParser :: Type -> Either String ([String], [String]) -flatParser t = tuple header <$> execWriterT (tell head >>| fpd t True "r" 1 >>| tell tail) +flatParser t = tuple header <$> runReaderT (execWriterT (tell head >>| fpd t True "r" >>| tell tail)) 1 where includes = "#include \n#include \n" header = [includes:parsefun [";\n"]] @@ -37,56 +38,57 @@ where head = [includes:parsefun [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]] tail = ["\treturn r;\n}\n"] parsename s = "parse_" +++ safe s - result r op i s = indent i [r, " ", op, " ", s, ";\n"] - assign r i s = result r "=" i s + result r op s = indent [r, " ", op, " ", s, ";\n"] + assign r s = result r "=" s - fpd :: Type Bool String Int -> FPMonad - fpd (TyRef s) tl r i = assign r i (parsename s) - fpd (TyBasic t) tl r i + fpd :: Type Bool String -> FPMonad + fpd (TyRef s) tl r = assign r (parsename s) + fpd (TyBasic t) tl r | tl = pure () = case t of - BTInt = assign r i "(int64_t)get()<<54" - >>| result r "+=" i "(int64_t)get()<<48" - >>| result r "+=" i "(int64_t)get()<<40" - >>| result r "+=" i "(int64_t)get()<<32" - >>| result r "+=" i "(int64_t)get()<<24" - >>| result r "+=" i "(int64_t)get()<<16" - >>| result r "+=" i "(int64_t)get()<<8" - >>| result r "+=" i "(int64_t)get()" - BTChar = assign r i "(char)get()" - BTReal = assign r i "double" - BTBool = assign r i "(bool)get()" + BTInt = assign r "(int64_t)get()<<54" + >>| result r "+=" "(int64_t)get()<<48" + >>| result r "+=" "(int64_t)get()<<40" + >>| result r "+=" "(int64_t)get()<<32" + >>| result r "+=" "(int64_t)get()<<24" + >>| result r "+=" "(int64_t)get()<<16" + >>| result r "+=" "(int64_t)get()<<8" + >>| result r "+=" "(int64_t)get()" + BTChar = assign r "(char)get()" + BTReal = assign r "double" + BTBool = assign r "(bool)get()" t = fail $ "flatParse: there is no basic type for " +++ toString t - fpd (TyArrow _ _) tl r i = fail $ "flatParser: function cannot be serialized" - fpd (TyNewType ti ci a) tl r i = fpd a tl r i - fpd (TyArray _ _) tl r i = fail $ "flatParser: arrays are not supported since they require dynamic memory" - fpd (TyRecord ti fs) tl r i - = mapM_ (fmtField i) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs] + fpd (TyArrow _ _) tl r = fail $ "flatParser: function cannot be serialized" + fpd (TyNewType ti ci a) tl r = fpd a tl r + fpd (TyArray _ _) tl r = fail $ "flatParser: arrays are not supported since they require dynamic memory" + fpd (TyRecord ti fs) tl r + = mapM_ (fmtField) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs] //Enumeration - fpd (TyObject ti fs) tl r i + fpd (TyObject ti fs) tl r | and [t =: [] \\ (_, t)<-fs] - = assign r i $ "(" +++ consName ti +++ ") get()" + = assign r $ "(" +++ consName ti +++ ") get()" //Single constructor, single field (box) - fpd (TyObject ti [(ci, [ty])]) tl r i = fpd ty tl r i + fpd (TyObject ti [(ci, [ty])]) tl r = fpd ty tl r //Single constructor - fpd (TyObject ti [(ci, ts)]) tl r i - = mapM_ (fmtField i) [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts] + fpd (TyObject ti [(ci, ts)]) tl r + = mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts] //Complex adt - fpd (TyObject ti fs) tl r i - = assign (r +++ ".cons") i ("(" +++ consName ti +++ ") get()") - >>| indent i ["switch (", r <.> "cons){\n"] - >>| mapM_ (fmtCons i) fs - >>| indent i ["}\n"] + fpd (TyObject ti fs) tl r + = assign (r +++ ".cons") ("(" +++ consName ti +++ ") get()") + >>| indent ["switch (", r <.> "cons){\n"] + >>| mapM_ (mapWriterT (local inc) o fmtCons) fs + >>| indent ["}\n"] where - fmtCons i (ci, ts) = indent i ["case ", safe ci.gcd_name, ":\n"] - >>| mapM_ (fmtField $ i+1) [(cs i, ty) \\i<-[0..] & ty<-ts] - >>| indent (i+1) ["break;\n"] + fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad + fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"] + >>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts] + >>| indent ["break;\n"] where cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i) - fpd t tl r i = fail $ "flatParser: unsupported " +++ toString t + fpd t tl r = fail $ "flatParser: unsupported " +++ toString t - fmtField :: Int (String, Type) -> FPMonad - fmtField i (name, ty) = fpd ty False name i + fmtField :: (String, Type) -> FPMonad + fmtField (name, ty) = fpd ty False name /** * generate parsers for the types grouped by strongly connected components diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl index 3c4ca1e..b359194 100644 --- a/gengen/Data/GenType/CType.icl +++ b/gengen/Data/GenType/CType.icl @@ -5,6 +5,7 @@ import Control.Monad => qualified join import Control.Monad.State import Control.Monad.Trans import Control.Monad.Writer +import Control.Monad.Reader import Control.Monad.Fail import Data.Either import Data.Func @@ -40,58 +41,60 @@ prefix _ = "" consName :: GenericTypeDefDescriptor -> String consName s = "enum " +++ safe s.gtd_name +++ "_cons" -indent i c = tell [createArray i '\t':c] +iindent = mapWriterT $ mapStateT $ local inc +indent c = liftT (liftT ask) >>= \i->tell [createArray i '\t':c] -:: FTMonad :== WriterT [String] (StateT [(String, [String])] (Either String)) () +:: FTMonad :== WriterT [String] (StateT [(String, [String])] (ReaderT Int (Either String))) () flatTypedef :: Type -> Either String [String] flatTypedef t = (\(w, es)->flatten (map snd es) ++ w) - <$> runStateT (execWriterT (ftd t True 0)) [] + <$> runReaderT (runStateT (execWriterT (ftd t True )) []) 0 where - ftd :: Type Bool Int -> FTMonad - ftd (TyRef s) tl i = indent i [s] - ftd (TyBasic t) tl i + ftd :: Type Bool -> FTMonad + ftd (TyRef s) tl = indent [s] + ftd (TyBasic t) tl | tl = pure () - = case t of - BTInt = indent i ["int64_t"] - BTChar = indent i ["char"] - BTReal = indent i ["double"] - BTBool = indent i ["bool"] - t = fail $ "cannot flatTypedef: " +++ toString t -// ftd (TyArrow l r) i c = indent i ["*":ftd a i c] - ftd (TyNewType ti ci a) tl i = ftd a tl i - ftd (TyArray _ a) tl i = indent i ["*"] >>| ftd a tl i - ftd (TyRecord ti fs) tl i - = indent i ["struct ", if tl (safe ti.grd_name) "", " {\n" - ] >>| mapM_ (fmtField $ i+1) [(fi.gfd_name, ty)\\(fi, ty)<-fs] - >>| indent i ["}\n"] + = case t of + BTInt = indent ["int64_t"] + BTChar = indent ["char"] + BTReal = indent ["double"] + BTBool = indent ["bool"] + t = fail $ "flatTypedef: there is no basic type for " +++ toString t + ftd (TyArrow l r) tl = fail "flatTypedef: functions cannot be serialized" + ftd (TyNewType ti ci a) tl = ftd a tl + ftd (TyArray _ a) tl = indent ["*"] >>| ftd a tl + ftd (TyRecord ti fs) tl + = indent ["struct ", if tl (safe ti.grd_name) "", " {\n" + ] >>| mapM_ (iindent o fmtField) [(fi.gfd_name, ty)\\(fi, ty)<-fs] + >>| indent ["}\n"] //Enumeration - ftd (TyObject ti fs) tl i + ftd (TyObject ti fs) tl | and [t =: [] \\ (_, t)<-fs] | tl = pure () - = indent i [] >>| enum ti fs + = indent [] >>| enum ti fs //Single constructor, single field (box) - ftd (TyObject ti [(ci, [ty])]) tl i = ftd ty tl i + ftd (TyObject ti [(ci, [ty])]) tl = ftd ty tl //Single constructor - ftd (TyObject ti [(ci, ts)]) tl i - = indent i ["struct ", if tl (safe ti.gtd_name) "", " {\n"] - >>| mapM_ (fmtField $ i+1) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts] - >>| indent i ["}"] + ftd (TyObject ti [(ci, ts)]) tl + = indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"] + >>| mapM_ (iindent o fmtField) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts] + >>| indent ["}"] //Complex adt - ftd (TyObject ti fs) tl i - = indent i ["struct ", if tl (safe ti.gtd_name) "", " {\n"] - >>| indent (i+1) [] >>| enum ti fs >>| tell [" cons;\n"] - >>| indent (i+1) ["struct {\n"] - >>| mapM_ (fmtCons $ i+2) fs - >>| indent (i+1) ["} data;\n"] - >>| indent i ["}", if tl ";" ""] + ftd (TyObject ti fs) tl + = indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"] + >>| iindent (indent []) >>| enum ti fs >>| tell [" cons;\n"] + >>| indent [] >>| enum ti fs >>| tell [" cons;\n"] + >>| indent ["struct {\n"] + >>| mapM_ (iindent o iindent o fmtCons) fs + >>| iindent (indent ["} data;\n"]) + >>| indent ["}", if tl ";" ""] where - fmtCons i (ci, []) = pure () - fmtCons i (ci, [t]) = ftd t False i >>| tell [" ", safe ci.gcd_name, ";\n"] - fmtCons i (ci, ts) - = indent i ["struct {\n"] - >>| mapM_ (fmtField $ i+1) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts] - >>| indent i ["} ", safe ci.gcd_name, ";\n"] - ftd t tl i = fail $ "cannot flatTypedef: " +++ toString t + fmtCons (ci, []) = pure () + fmtCons (ci, [t]) = ftd t False >>| tell [" ", safe ci.gcd_name, ";\n"] + fmtCons (ci, ts) + = indent ["struct {\n"] + >>| mapM_ (iindent o fmtField) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts] + >>| indent ["} ", safe ci.gcd_name, ";\n"] + ftd t tl = fail $ "cannot flatTypedef: " +++ toString t enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad @@ -99,8 +102,8 @@ where ?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"] + fmtField :: (String, Type) -> FTMonad + fmtField (name, ty) = ftd ty False >>| tell [" ", name, ";\n"] :: TDMonad :== WriterT [String] (StateT TDState (Either String)) () :: TDState :== 'Data.Map'.Map String (String, Bool) @@ -171,7 +174,7 @@ where fmtFields :: Int GenType [String] -> TDMonad fmtFields i _ [] = pure () fmtFields i (GenTypeArrow l r) [x:xs] - = indent i [] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs + = tell [createArray i '\t'] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs fmtField :: String GenType -> TDMonad fmtField x (GenTypeCons a) = printTypeName a >>| tell [x]