non flat parsers

diff --git a/gengen/Data/GenType/CParser.dcl b/gengen/Data/GenType/CParser.dcl
index 70da0b3..32b8066 100644 (file)
--- a/gengen/Data/GenType/CParser.dcl
+++ b/gengen/Data/GenType/CParser.dcl
@@ -3,13 +3,13 @@ definition module Data.GenType.CParser
 from Data.Either import :: Either
 from Data.GenType import :: Type
 
-/**
- * generate parsers for the types grouped by strongly connected components
- */
-parser :: [[Type]] -> Either String [String]
-
 /**
  * Generate a single parser for a type.
  * This does not terminate for a recursive type
  */
 flatParser :: Type -> Either String ([String], [String])
+
+/**
+ * generate parsers for the types grouped by strongly connected components
+ */
+parsers :: [[Type]] -> Either String [String]

diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl
index c363450..6616fac 100644 (file)
--- a/gengen/Data/GenType/CParser.icl
+++ b/gengen/Data/GenType/CParser.icl
@@ -1,18 +1,22 @@
 implementation module Data.GenType.CParser
 
-import StdEnv
 import Control.Applicative
 import Control.Monad => qualified join
+import Control.Monad.Fail
+import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Trans
 import Control.Monad.Writer
-import Control.Monad.Reader
-import Control.Monad.Fail
 import Data.Either
 import Data.Func
 import Data.Functor
-import Data.Tuple
 import Data.List
+import qualified Data.Map
+from Data.Map import :: Map(..)
+import Data.Maybe
+import Data.Tuple
+import StdEnv
+import Text
 
 import Data.GenType
 import Data.GenType.CType
@@ -22,9 +26,16 @@ 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
 (<.>) a b = a +++ "." +++ b
 
+result r op s = indent [r, " ", op, " ", s, ";\n"]
+assign r s = result r "=" s
+
 /**
  * Generate a single parser for a type.
  * This does not terminate for a recursive type
@@ -32,14 +43,11 @@ indent c = liftT ask >>= \i->tell [createArray i '\t':c]
 flatParser :: Type -> Either String ([String], [String])
 flatParser t = tuple header <$> runReaderT (execWriterT (tell head >>| fpd t True "r" >>| tell tail)) 1
 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"]]
+       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
-       result r op s = indent [r, " ", op, " ", s, ";\n"]
-       assign r s = result r "=" s
 
        fpd :: Type Bool String -> FPMonad
        fpd (TyRef s) tl r = assign r (parsename s)
@@ -93,5 +101,87 @@ where
 /**
  * generate parsers for the types grouped by strongly connected components
  */
-parser :: [[Type]] -> Either String [String]
-parser _ = undef
+:: 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)]

diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
index b359194..c56e408 100644 (file)
--- a/gengen/Data/GenType/CType.icl
+++ b/gengen/Data/GenType/CType.icl
@@ -2,21 +2,21 @@ implementation module Data.GenType.CType
 
 import Control.Applicative
 import Control.Monad => qualified join
+import Control.Monad.Fail
+import Control.Monad.Reader
 import Control.Monad.State
 import Control.Monad.Trans
 import Control.Monad.Writer
-import Control.Monad.Reader
-import Control.Monad.Fail
 import Data.Either
 import Data.Func
 import Data.Functor
-import Data.Tuple
+import Data.GenType
+import Data.List
 import qualified Data.Map
 from Data.Map import :: Map(..)
 import Data.Maybe
-import Data.List
+import Data.Tuple
 import StdEnv
-import Data.GenType
 import Text
 
 instance MonadFail (Either String) where fail s = Left s

diff --git a/gengen/test.icl b/gengen/test.icl
index 122b099..e0e46ef 100644 (file)
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -15,7 +15,7 @@ import Data.GenType
 import Data.GenType.CType
 import Data.GenType.CParser
 
-derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP
+derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest
 
 :: T a = T2 a Char
 :: NT =: NT Int
@@ -24,7 +24,7 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp,
        f5 :: [([#Int], [#Int!], [!Int!], [!Int], [Int!])],
        f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/
        f7 :: {!Int}}
-:: Tr m b= Tr (m Int b)
+:: Tr m b= Tr (m Int b) | TrBork
 :: Frac a = (/.) infixl 7 a a  | Flurp
 :: Fix f = Fix (f (Fix f))
 
@@ -34,7 +34,8 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp,
 
 :: EnumList = ECons Enum EnumList | ENil
 
-:: ER = {nat :: T Int, bool :: Bool}
+:: ER = {nat :: Int, bool :: Bool}
+:: RA a = {a1 :: a, a2 :: Int}
 
 :: CP = CLeft Int Bool | CRight Char Char
 
@@ -50,6 +51,7 @@ Start =
        ( flatTypedef $ gTypeToType $ unBox t
        , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
        , flatParser $ gTypeToType $ unBox t
+       , parsers $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
        )
 
 //Start = typedefs //$ (\x->[[gTypeToType x]])
@@ -60,11 +62,12 @@ Start =
 //     $ flattenGType
 //     $ unBox t
 
+:: Nest m = Nest (m (m (m Int))) | NestBlurp
 
 //t :: Box GType (?# Int)
 //t :: Box GType (Maybe [Maybe (Either Bool String)])
 //t :: Box GType ([SR], Enum, T Int, NT, Blurp Int)
 //t :: Box GType [EnumList]
-t :: Box GType (Either (Int, Char) (?CP))
+t :: Box GType (Nest ?, Tr Either (?(Int, Enum)))
 //t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
 t = gType{|*|}