structure

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

diff --git a/gengen/Data/GenType/CParser.icl b/gengen/src/GenType/CParser.icl
similarity index 82%
rename from gengen/Data/GenType/CParser.icl
rename to gengen/src/GenType/CParser.icl
index 130ee3d..0677604 100644 (file)
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/src/GenType/CParser.icl
@@ -1,4 +1,4 @@
-implementation module Data.GenType.CParser
+implementation module GenType.CParser
 
 import Control.Applicative
 import Control.Monad
@@ -19,15 +19,15 @@ import StdEnv
 import qualified Text
 from Text import class Text(concat), instance Text String
 
-import Data.GenType
-import Data.GenType.CType
+import GenType
+import GenType.CType
 
 instance MonadFail (Either String) where fail s = Left s
 :: FPMonad :== WriterT [String] (ReaderT Int (Either String)) ()
 
 indent c = liftT ask >>= \i->tell [createArray i '\t':c]
 
-parsefun t = "parse_" +++ safe (typeName t)
+parsefun t c = ["parse_", safe (typeName t):c]
 
 (<.>) infixr 6
 (<.>) a b = a +++ "." +++ b
@@ -42,14 +42,10 @@ tail = ["\treturn 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 "r;" \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
 where
-       parsedef c = ctypename t [" ", parsefun t, "(uint8_t (*get)())":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)
@@ -65,7 +61,7 @@ where
                                >>| result r "+=" "(int64_t)get()<<8"
                                >>| result r "+=" "(int64_t)get()"
                        BTChar = assign r "(char)get()"
-                       BTReal = assign r "double"
+//                     BTReal = assign r "double"
                        BTBool = assign r "(bool)get()"
                        t = fail $ "flatParse: there is no basic type for " +++ toString t
        fpd (TyArrow _ _) tl r = fail $ "flatParser: function cannot be serialized"
@@ -100,12 +96,8 @@ where
        fmtField :: (String, Type) -> FPMonad
        fmtField (name, ty) = fpd ty False name
 
-/**
- * generate parsers for the types grouped by strongly connected components
- */
 :: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
 :: TPState :== 'Data.Map'.Map String (String, Bool)
-import Debug.Trace
 parsers :: [[Type]] -> Either String ([String], [String])
 parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
 where
@@ -113,24 +105,20 @@ where
        parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
 
        parsedef :: Type [String] -> [String]
-       parsedef t c
-               # (pt, _) = trace_stdout (parsefun t, toString $ genTypeKind $ typeGenType t)
-               = ctypename t [" *", /*parsefun */pt, "(uint8_t (*get)()",pd t, ")":c]
+       parsedef t c = ctypename t [" *":parsefun t ["(uint8_t (*get)()":pks (typeKind t) True [")":c]]]
        where
-               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 (trace_stdout 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 _ _)) = 1
-       recordArity (GenTypeArrow l r) = inc $ recordArity l
+               pks :: Kind Bool [String] -> [String]
+               pks k tl c = foldr (\(i, k) c->pd k tl i c) c $ zip2 [0..] $ typeArgs k
+
+               pd :: Kind Bool Int [String] -> [String]
+               pd KStar tl i c = [", void *(*", if tl ("parse_"+++toString i) "", ")(uint8_t (*)())":c]
+               pd (l KArrow r) tl i c =
+                       [ ", void *(*", if tl ("parse_"+++toString i) "", ")(uint8_t (*)()"
+                       : pks l False $ pd r False (inc i) [")":c]]
+
+               typeArgs :: Kind -> [Kind]
+               typeArgs KStar = []
+               typeArgs (l KArrow r) = [l:typeArgs r]
 
        parsergroup :: [Type] -> TPMonad
        parsergroup ts
@@ -145,7 +133,7 @@ where
                >>= tell
 
        parser :: Type -> TPMonad
-       parser t=:(TyRef s) = tell [parsefun t]
+       parser t=:(TyRef s) = tell $ parsefun t []
        parser (TyBasic t)
                = case t of
                        BTInt = tell ["\t*r = (Int)get()<<54;\n"