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
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
?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)
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]
repositories / clean-tests.git / blobdiff