1 implementation module Data.GenType.CParser
3 import Control.Applicative
5 import Control.Monad.Fail
6 import Control.Monad.Reader
7 import Control.Monad.State
8 import Control.Monad.Trans
9 import Control.Monad.Writer
14 import qualified Data.Map
15 from Data.Map import :: Map(..)
20 from Text import class Text(concat), instance Text String
23 import Data.GenType.CType
25 instance MonadFail (Either String) where fail s = Left s
26 :: FPMonad :== WriterT [String] (ReaderT Int (Either String)) ()
28 indent c = liftT ask >>= \i->tell [createArray i '\t':c]
30 parsefun t = "parse_" +++ safe (typeName t)
33 (<.>) a b = a +++ "." +++ b
36 (<->) a b = a +++ "->" +++ b
38 result r op s = indent [r, " ", op, " ", s, ";\n"]
39 assign r s = result r "=" s
40 parsename s = "parse_" +++ safe s
41 tail = ["\treturn r;\n}\n"]
42 parsenameimp t c def = def t [" {\n\t":ctypename t [" ", c, "\n\n"]]
43 ctypename t c = [prefix t, safe (typeName t):c]
46 * Generate a single parser for a type.
47 * This does not terminate for a recursive type
49 flatParser :: Type -> Either String ([String], [String])
50 flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t "r;" \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
52 parsedef c = ctypename t [" ", parsefun t, "(uint8_t (*get)())":c]
54 fpd :: Type Bool String -> FPMonad
55 fpd (TyRef s) tl r = assign r (parsename s)
59 BTInt = assign r "(int64_t)get()<<54"
60 >>| result r "+=" "(int64_t)get()<<48"
61 >>| result r "+=" "(int64_t)get()<<40"
62 >>| result r "+=" "(int64_t)get()<<32"
63 >>| result r "+=" "(int64_t)get()<<24"
64 >>| result r "+=" "(int64_t)get()<<16"
65 >>| result r "+=" "(int64_t)get()<<8"
66 >>| result r "+=" "(int64_t)get()"
67 BTChar = assign r "(char)get()"
68 BTReal = assign r "double"
69 BTBool = assign r "(bool)get()"
70 t = fail $ "flatParse: there is no basic type for " +++ toString t
71 fpd (TyArrow _ _) tl r = fail $ "flatParser: function cannot be serialized"
72 fpd (TyNewType ti ci a) tl r = fpd a tl r
73 fpd (TyArray _ _) tl r = fail $ "flatParser: arrays are not supported since they require dynamic memory"
74 fpd (TyRecord ti fs) tl r
75 = mapM_ (fmtField) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs]
77 fpd (TyObject ti fs) tl r
78 | and [t =: [] \\ (_, t)<-fs]
79 = assign r $ "(" +++ consName ti +++ ") get()"
80 //Single constructor, single field (box)
81 fpd (TyObject ti [(ci, [ty])]) tl r = fpd ty tl r
83 fpd (TyObject ti [(ci, ts)]) tl r
84 = mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
86 fpd (TyObject ti fs) tl r
87 = assign (r <.> "cons") ("(" +++ consName ti +++ ") get()")
88 >>| indent ["switch (", r <.> "cons){\n"]
92 fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad
93 fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"]
94 >>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts]
95 >>| mapWriterT (local inc) (indent ["break;\n"])
97 cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
98 fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
100 fmtField :: (String, Type) -> FPMonad
101 fmtField (name, ty) = fpd ty False name
104 * generate parsers for the types grouped by strongly connected components
106 :: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
107 :: TPState :== 'Data.Map'.Map String (String, Bool)
109 parsers :: [[Type]] -> Either String ([String], [String])
110 parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
112 parsedefs :: ([[Type]] -> [String])
113 parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
115 parsedef :: Type [String] -> [String]
117 # (pt, _) = trace_stdout (parsefun t, toString $ genTypeKind $ typeGenType t)
118 = ctypename t [" *", /*parsefun */pt, "(uint8_t (*get)()",pd t, ")":c]
121 pd (TyUList _ _) = ", void *parse_0(uint8_t (*get)())"
122 pd (TyUMaybe _) = ", void *parse_0(uint8_t (*get)())"
123 pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..gtd.gtd_arity-1]]
124 pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity (trace_stdout grd.grd_type)-1]]
125 // pd (TyNewType _ _ _) = abort "not implemented yet\n"
126 pd t = abort $ "not implemented yet: " +++ toString t +++ "\n"
128 recordArity :: GenType -> Int
129 recordArity (GenTypeCons _) = 0
130 recordArity (GenTypeVar _) = 0
131 recordArity (GenTypeApp _ _) = 0
132 recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 1
133 recordArity (GenTypeArrow l r) = inc $ recordArity l
135 parsergroup :: [Type] -> TPMonad
137 = liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
138 >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
140 declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
142 printTypeName :: String -> TPMonad
144 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
147 parser :: Type -> TPMonad
148 parser t=:(TyRef s) = tell [parsefun t]
151 BTInt = tell ["\t*r = (Int)get()<<54;\n"
152 , "\t*r += (Int)get()<<48;\n"
153 , "\t*r += (Int)get()<<40;\n"
154 , "\t*r += (Int)get()<<32;\n"
155 , "\t*r += (Int)get()<<24;\n"
156 , "\t*r += (Int)get()<<16;\n"
157 , "\t*r += (Int)get()<<8;\n"
158 , "\t*r += (Int)get();\n"]
159 BTChar = tell ["\t*r = (Char)get();\n"]
160 BTBool = tell ["\t*r = (Bool)get();\n"]
161 //BTReal = tell ["\t*r = double;\n"]
162 t = fail $ "parser: there is no basic type for " +++ toString t
163 parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
164 parser (TyNewType ti ci a) = parser a
165 parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
166 parser (TyRecord ti fs)
167 = fmtFields 1 ti.grd_type ["r" <-> fi.gfd_name\\(fi, _)<-fs]
169 parser (TyObject ti fs)
170 | and [t =: [] \\ (_, t)<-fs]
171 = tell ["\t*r = (", consName ti, ") get();\n"]
172 //Single constructor, single field (box)
173 parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = ":fmtField ci.gcd_type [");\n"]]
175 parser t=:(TyObject ti [(ci, ts)])
176 = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
178 parser (TyObject ti fs)
179 = tell ["\tr" <-> "cons = (", consName ti, ") get();\n"]
180 >>| tell ["\tswitch(r" <-> "cons) {\n"]
184 fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
185 fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
186 >>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
187 >>| tell ["\t\tbreak;\n"]
189 cs i = "r" <-> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" ("" <-> "f" +++ toString i)
190 parser t = fail $ "parser: unsupported type " +++ toString t
192 fmtFields :: Int GenType [String] -> TPMonad
193 fmtFields i _ [] = pure ()
194 fmtFields i (GenTypeArrow l r) [x:xs]
195 = tell [createArray i '\t', x, " = "] >>| tell (fmtField l []) >>| tell [");\n"] >>| fmtFields i r xs
197 fmtField :: GenType [String] -> [String]
198 fmtField (GenTypeCons a) c = ["parse_", safe a, "(get":c]
199 fmtField (GenTypeVar a) c = ["parse_", toString a, "(get":c]
200 fmtField t=:(GenTypeApp _ _) c = ufold t c
202 ufold (GenTypeApp l r) c = ufold l [", ":fmtField r [")":c]]
203 ufold t c = fmtField t c