--- /dev/null
+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])
--- /dev/null
+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
definition module Data.GenType.CType
+from StdGeneric import :: GenericTypeDefDescriptor
from Data.Either import :: Either
from Data.GenType import :: Type
* This does not terminate for recursive types
*/
flatTypedef :: Type -> Either String [String]
+
+/**
+ * Create a C-safe type name
+ */
+safe :: String -> String
+
+/**
+ * Return the C type prefix, e.g. struct, enum
+ */
+prefix :: Type -> String
+
+/**
+ * Return the C constructorname
+ */
+consName :: GenericTypeDefDescriptor -> String
,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
+prefix :: Type -> String
+prefix (TyRecord _ _) = "struct "
+prefix (TyObject _ fs)
+ | and [t =: [] \\ (_, t)<-fs] = "enum "
+ | fs =: [(_, [_])] = ""
+ | fs =: [_] = "struct "
+ = "struct "
+prefix _ = ""
+
+consName :: GenericTypeDefDescriptor -> String
+consName s = "enum " +++ safe s.gtd_name +++ "_cons"
+
indent i c = tell [createArray i '\t':c]
:: FTMonad :== WriterT [String] (StateT [(String, [String])] (Either String)) ()
ftd :: Type Bool Int -> FTMonad
ftd (TyRef s) tl i = indent i [s]
ftd (TyBasic t) tl i
- | tl = tell []
+ | tl = pure ()
= case t of
BTInt = indent i ["int64_t"]
BTChar = indent i ["char"]
//Enumeration
ftd (TyObject ti fs) tl i
| and [t =: [] \\ (_, t)<-fs]
- | tl = tell []
+ | tl = pure ()
= indent i [] >>| enum ti fs
//Single constructor, single field (box)
ftd (TyObject ti [(ci, [ty])]) tl i = ftd ty tl i
enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad
enum ti fs = liftT (gets (lookup ti.gtd_name)) >>= \e->case e of
- ?None = liftT (modify \s->[(ti.gtd_name, ["enum ", safe ti.gtd_name, "_cons {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
- ?Just _ = tell ["enum ", safe ti.gtd_name, "_cons"]
+ ?None = liftT (modify \s->[(ti.gtd_name, [consName ti, " {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
+ ?Just _ = tell [consName ti]
fmtField :: Int (String, Type) -> FTMonad
fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
where
typedefgroup :: [Type] -> TDMonad
typedefgroup ts
- = liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
+ = liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, False))\\ty<-ts]))
+ >>| mapM_ (\x->printTypeName x >>| tell [";\n"]) (if (ts=:[_,_:_]) (map typeName ts) [])
+ >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->True)) o typeName) ts))
>>| mapM_ (\t->typedef t >>| tell ["\n"]) ts
- >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->False)) o typeName) ts))
- >>| case ts of
- [_] = tell []
- ts = mapM_ (\x->printTypeName x >>| tell [";\n"]) (map typeName ts)
- where
- prefix :: Type -> String
- prefix (TyRecord _ _) = "struct "
- prefix (TyObject _ fs)
- | and [t =: [] \\ (_, t)<-fs] = "enum "
- | fs =: [(_, [_])] = ""
- | fs =: [_] = "struct "
- = "struct "
- prefix _ = ""
printTypeName :: String -> TDMonad
printTypeName tname
//Enumeration
typedef t=:(TyObject ti fs)
| and [t =: [] \\ (_, t)<-fs] = header t
- ["enum ", safe ti.gtd_name, "_cons {"
- , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
+ [consName ti, " {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
//Single constructor, single field (box)
typedef t=:(TyObject ti [(ci, [ty])]) = header t [] >>| tydef ti.gtd_name ci.gcd_type
//Single constructor
>>| tell ["\t} data;\n};\n"]
where
fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
- fmtCons (ci, []) = tell []
+ fmtCons (ci, []) = pure ()
fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
fmtCons (ci, ts) = tell ["\t\tstruct {\n"]
>>| fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
fmtFields :: Int GenType [String] -> TDMonad
- fmtFields i _ [] = tell []
+ fmtFields i _ [] = pure ()
fmtFields i (GenTypeArrow l r) [x:xs]
= indent i [] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs
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
+derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP
-:: T a =: T2 a
+:: T a = T2 a Char
:: NT =: NT Int
:: SR = {f1 :: Int, f2 :: Bool, f3 :: Tr Either Bool, f4 :: Enum}
:: R a = {f1 :: ? (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
:: EnumList = ECons Enum EnumList | ENil
+:: ER = {nat :: T Int, bool :: Bool}
+
+:: CP = CLeft Int Bool | CRight Char Char
+
////Start :: [String]
////Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
//:: Pair a b = Pair a b
Start =
( flatTypedef $ gTypeToType $ unBox t
, typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+ , flatParser $ gTypeToType $ unBox t
)
//Start = typedefs //$ (\x->[[gTypeToType x]])
//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 (?(?(?(?^Enum))))
+t :: Box GType (Either (Int, Char) (?CP))
//t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
t = gType{|*|}
repositories / clean-tests.git / commitdiff