+implementation module Data.GenType.CParser
+
+import StdEnv
+import Control.Applicative
+import Control.Monad => qualified join
+import Control.Monad.State
+import Control.Monad.Trans
+import Control.Monad.Writer
+import Control.Monad.Fail
+import Data.Either
+import Data.Func
+import Data.Functor
+import Data.Tuple
+import Data.List
+
+import Data.GenType
+import Data.GenType.CType
+
+instance MonadFail (Either String) where fail s = Left s
+:: FPMonad :== WriterT [String] (Either String) ()
+
+indent i c = tell [createArray i '\t':c]
+
+(<.>) infixr 6
+(<.>) a b = a +++ "." +++ b
+
+/**
+ * Generate a single parser for a type.
+ * 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)
+where
+ includes = "#include <stdint.h>\n#include <stdbool.h>\n"
+ header = [includes:parsefun [";\n"]]
+ parsefun c = [prefix t, safe (typeName t), " parse_", safe (typeName t), "(uint8_t (*get)(void))":c]
+ 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
+
+ fpd :: Type Bool String Int -> FPMonad
+ fpd (TyRef s) tl r i = assign r i (parsename s)
+ fpd (TyBasic t) tl r i
+ | 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()"
+ 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]
+ //Enumeration
+ fpd (TyObject ti fs) tl r i
+ | and [t =: [] \\ (_, t)<-fs]
+ = assign r i $ "(" +++ consName ti +++ ") get()"
+ //Single constructor, single field (box)
+ fpd (TyObject ti [(ci, [ty])]) tl r i = fpd ty tl r i
+ //Single constructor
+ fpd (TyObject ti [(ci, ts)]) tl r i
+ = mapM_ (fmtField i) [(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"]
+ 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"]
+ where
+ cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
+ fpd t tl r i = fail $ "flatParser: unsupported " +++ toString t
+
+ fmtField :: Int (String, Type) -> FPMonad
+ fmtField i (name, ty) = fpd ty False name i
+
+/**
+ * generate parsers for the types grouped by strongly connected components
+ */
+parser :: [[Type]] -> Either String [String]
+parser _ = undef