+:: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
+:: TPState :== 'Data.Map'.Map String (String, Bool)
+parsers :: [[Type]] -> Either String [String]
+parsers ts = evalStateT (execWriterT (mapM_ parsergroup ts)) 'Data.Map'.newMap
+where
+ parsergroup :: [Type] -> TPMonad
+ parsergroup ts
+ = liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
+ >>| mapM_ (\t->parser t >>| tell ["\n"]) ts
+
+ printTypeName :: String -> TPMonad
+ printTypeName tname
+ = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
+ >>= tell
+
+ parser :: Type -> TPMonad
+ 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"]
+ 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]
+ //Enumeration
+ parser (TyObject ti fs)
+ | and [t =: [] \\ (_, t)<-fs]
+ = tell ["\tr = (" +++ consName ti +++ ") get();\n"]
+ //Single constructor, single field (box)
+ parser (TyObject ti [(ci, [ty])]) = tell ["\tr = "] >>| 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]
+ //Complex adt
+ parser (TyObject ti fs)
+ = tell ["\tr.cons = (" +++ consName ti +++ ") get();\n"]
+ >>| tell ["\tswitch(r.cons) {\n"]
+ >>| mapM_ fmtCons fs
+ >>| tell ["\t}\n"]
+ where
+ fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
+ fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
+ >>| 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)
+ parser t = fail $ "parser: unsupported type " +++ toString t
+
+ fmtFields :: Int GenType [String] -> TPMonad
+ fmtFields i _ [] = pure ()
+ fmtFields i (GenTypeArrow l r) [x:xs]
+ = tell [createArray i '\t', x, " = "] >>| fmtField l >>| tell [");\n"] >>| fmtFields i r xs
+
+ fmtField :: GenType -> TPMonad
+ fmtField (GenTypeCons a) = tell ["parse_", safe a, "(get"]
+ fmtField (GenTypeVar a) = tell ["parse_", toString a, "(get"]
+ fmtField t=:(GenTypeApp _ _)
+ = let [x:xs] = ufold t in fmtField x >>| case ufold t of
+ [] = tell [")"]
+ xs = tell [", "] >>| sequence_ (intersperse (tell [", "]) (map (\s->fmtField s >>| tell [")"]) xs))
+ 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)]