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
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
* 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 <stdint.h>\n#include <stdbool.h>\n"
header = [includes:parsefun [";\n"]]
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
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 / commitdiff