(<.>) infixr 6
(<.>) a b = a +++ "." +++ b
+(<->) infixr 6
+(<->) a b = a +++ "->" +++ b
+
result r op s = indent [r, " ", op, " ", s, ";\n"]
assign r s = result r "=" s
parsename s = "parse_" +++ safe s
tail = ["\treturn r;\n}\n"]
-parsenameimp t def = def t [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]
+parsenameimp t c def = def t [" {\n\t":ctypename t [" ", c, "\n\n"]]
+ctypename t c = [prefix t, safe (typeName t):c]
/**
* Generate a single parser for a type.
* This does not terminate for a recursive type
*/
flatParser :: Type -> Either String ([String], [String])
-flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
+flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t "r;" \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
where
- parsedef c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void))":c]
+ parsedef c = ctypename t [" ", parsefun t, "(uint8_t (*get)())":c]
fpd :: Type Bool String -> FPMonad
fpd (TyRef s) tl r = assign r (parsename s)
- fpd (TyBasic t) tl r
+ fpd (TyBasic t) tl r
| tl = pure ()
= case t of
BTInt = assign r "(int64_t)get()<<54"
:: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
:: TPState :== 'Data.Map'.Map String (String, Bool)
parsers :: [[Type]] -> Either String ([String], [String])
-parsers ts = tuple ([""]) <$> evalStateT (execWriterT (mapM_ parsergroup ts >>| tell tail)) 'Data.Map'.newMap
+parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
where
- parsedef t c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void)",pd t, ")":c]
+ parsedefs :: ([[Type]] -> [String])
+ parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
+
+ parsedef :: Type [String] -> [String]
+ parsedef t c = ctypename t [" *", parsefun t, "(uint8_t (*get)()",pd t, ")":c]
where
- pd (TyUList _ _) = ", void *parse_0(uint8_t (*)(void))"
- pd (TyUMaybe _) = ", void *parse_0(uint8_t (*)(void))"
- pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)(void))"\\i<-[0..gtd.gtd_arity-1]]
- pd (TyRecord grd _) = abort "not implemented yet\n"
- pd (TyNewType _ _ _) = abort "not implemented yet\n"
- pd _ = abort "not implemented yet\n"
+ pd (TyBasic s) = ""
+ pd (TyUList _ _) = ", void *parse_0(uint8_t (*get)())"
+ pd (TyUMaybe _) = ", void *parse_0(uint8_t (*get)())"
+ pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..gtd.gtd_arity-1]]
+ pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity grd.grd_type-1]]
+// pd (TyNewType _ _ _) = abort "not implemented yet\n"
+ pd t = abort $ "not implemented yet: " +++ toString t +++ "\n"
+
+ recordArity :: GenType -> Int
+ recordArity (GenTypeCons _) = 0
+ recordArity (GenTypeVar _) = 0
+ recordArity (GenTypeApp _ _) = 0
+ recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 0
+ recordArity (GenTypeArrow l r) = inc $ recordArity r
parsergroup :: [Type] -> TPMonad
parsergroup ts
= liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
- >>| mapM_ (\t->tell (parsenameimp t parsedef) >>| parser t >>| tell ["\n"]) ts
+ >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
+ where
+ declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
printTypeName :: String -> TPMonad
printTypeName tname
parser t=:(TyRef s) = tell [parsefun t]
parser (TyBasic t)
= case t of
- BTInt = tell ["\tr = (int64_t)get()<<54;\n"
- , "\tr += (int64_t)get()<<48;\n"
- , "\tr += (int64_t)get()<<40;\n"
- , "\tr += (int64_t)get()<<32;\n"
- , "\tr += (int64_t)get()<<24;\n"
- , "\tr += (int64_t)get()<<16;\n"
- , "\tr += (int64_t)get()<<8;\n"
- , "\tr += (int64_t)get();\n"]
- BTChar = tell ["\tr = (char)get();\n"]
- BTReal = tell ["\tr = double;\n"]
- BTBool = tell ["\tr = (bool)get();\n"]
+ BTInt = tell ["\t*r = (Int)get()<<54;\n"
+ , "\t*r += (Int)get()<<48;\n"
+ , "\t*r += (Int)get()<<40;\n"
+ , "\t*r += (Int)get()<<32;\n"
+ , "\t*r += (Int)get()<<24;\n"
+ , "\t*r += (Int)get()<<16;\n"
+ , "\t*r += (Int)get()<<8;\n"
+ , "\t*r += (Int)get();\n"]
+ BTChar = tell ["\t*r = (Char)get();\n"]
+ BTBool = tell ["\t*r = (Bool)get();\n"]
+ //BTReal = tell ["\t*r = double;\n"]
t = fail $ "parser: there is no basic type for " +++ toString t
parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
parser (TyNewType ti ci a) = parser a
parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
parser (TyRecord ti fs)
- = fmtFields 1 ti.grd_type ["r" <.> fi.gfd_name\\(fi, _)<-fs]
+ = fmtFields 1 ti.grd_type ["r" <-> fi.gfd_name\\(fi, _)<-fs]
//Enumeration
parser (TyObject ti fs)
| and [t =: [] \\ (_, t)<-fs]
- = tell ["\tr = (" +++ consName ti +++ ") get();\n"]
+ = tell ["\t*r = (", consName ti, ") get();\n"]
//Single constructor, single field (box)
- parser (TyObject ti [(ci, [ty])]) = tell ["\tr = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
+ parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
//Single constructor
parser t=:(TyObject ti [(ci, ts)])
- = fmtFields 1 ci.gcd_type ["r.f" +++ toString i\\i<-indexList ts]
+ = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
//Complex adt
parser (TyObject ti fs)
- = tell ["\tr.cons = (", consName ti, ") get();\n"]
- >>| tell ["\tswitch(r.cons) {\n"]
+ = tell ["\tr" <-> "cons = (", consName ti, ") get();\n"]
+ >>| tell ["\tswitch(r" <-> "cons) {\n"]
>>| mapM_ fmtCons fs
>>| tell ["\t}\n"]
where
>>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
>>| tell ["\t\tbreak;\n"]
where
- cs i = "r.data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
+ cs i = "r" <-> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" ("" <-> "f" +++ toString i)
parser t = fail $ "parser: unsupported type " +++ toString t
fmtFields :: Int GenType [String] -> TPMonad
where
ufold (GenTypeApp l r) = [l:ufold r]
ufold t = [t]
-
-// 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]
-// | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
-// | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
repositories / clean-tests.git / blobdiff