gengeng

[clean-tests.git] / gengen / Data / GenType / CParser.icl

diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl
index 6616fac..b29d8a5 100644 (file)
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/Data/GenType/CParser.icl
@@ -1,7 +1,7 @@
 implementation module Data.GenType.CParser
 
 import Control.Applicative
-import Control.Monad => qualified join
+import Control.Monad
 import Control.Monad.Fail
 import Control.Monad.Reader
 import Control.Monad.State
@@ -16,7 +16,8 @@ from Data.Map import :: Map(..)
 import Data.Maybe
 import Data.Tuple
 import StdEnv
-import Text
+import qualified Text
+from Text import class Text(concat), instance Text String
 
 import Data.GenType
 import Data.GenType.CType
@@ -26,8 +27,6 @@ instance MonadFail (Either String) where fail s = Left s
 
 indent c = liftT ask >>= \i->tell [createArray i '\t':c]
 
-includes = "#include <stdint.h>\n#include <stdbool.h>\n"
-
 parsefun t = "parse_" +++ safe (typeName t)
 
 (<.>) infixr 6
@@ -35,19 +34,18 @@ parsefun t = "parse_" +++ safe (typeName t)
 
 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"]
 
 /**
  * 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 <$> runReaderT (execWriterT (tell head >>| fpd t True "r" >>| tell tail)) 1
+flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
 where
-       header = [includes:parsedef [";\n"]]
-       parsedef c = [prefix t, safe (typeName t), parsefun t, "(uint8_t (*get)(void))":c]
-       head = [includes:parsedef [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]]
-       tail = ["\treturn r;\n}\n"]
-       parsename s = "parse_" +++ safe s
+       parsedef c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void))":c]
 
        fpd :: Type Bool String -> FPMonad
        fpd (TyRef s) tl r = assign r (parsename s)
@@ -82,15 +80,15 @@ where
                =   mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
        //Complex adt
        fpd (TyObject ti fs) tl r
-               =   assign (r +++ ".cons") ("(" +++ consName ti +++ ") get()")
+               =   assign (r <.> "cons") ("(" +++ consName ti +++ ") get()")
                >>| indent ["switch (", r <.> "cons){\n"]
-               >>| mapM_ (mapWriterT (local inc) o fmtCons) fs
+               >>| mapM_ fmtCons fs
                >>| indent ["}\n"]
        where
                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"]
+                       >>| mapWriterT (local inc) (indent ["break;\n"])
                where
                        cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
        fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
@@ -103,13 +101,22 @@ where
  */
 :: 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
+parsers :: [[Type]] -> Either String ([String], [String])
+parsers ts = tuple ([""]) <$> evalStateT (execWriterT (mapM_ parsergroup ts >>| tell tail)) 'Data.Map'.newMap
 where
+       parsedef t c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void)",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"
+
        parsergroup :: [Type] -> TPMonad
        parsergroup ts
                =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
-               >>| mapM_ (\t->parser t >>| tell ["\n"]) ts
+               >>| mapM_ (\t->tell (parsenameimp t parsedef) >>| parser t >>| tell ["\n"]) ts
 
        printTypeName :: String -> TPMonad
        printTypeName tname
@@ -118,7 +125,7 @@ where
 
        parser :: Type -> TPMonad
        parser t=:(TyRef s) = tell [parsefun t]
-       parser (TyBasic t) 
+       parser (TyBasic t)
                = case t of
                        BTInt = tell ["\tr = (int64_t)get()<<54;\n"
                                , "\tr += (int64_t)get()<<48;\n"
@@ -148,7 +155,7 @@ where
                = 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 ["\tr.cons = (", consName ti, ") get();\n"]
                >>| tell ["\tswitch(r.cons) {\n"]
                >>| mapM_ fmtCons fs
                >>| tell ["\t}\n"]