From 59f7b8d0a2beec7b714878f9810df65892b2c14d Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Fri, 21 Aug 2020 13:26:48 +0200 Subject: [PATCH] flatparser --- gengen/Data/GenType/CParser.dcl | 15 ++++++ gengen/Data/GenType/CParser.icl | 95 +++++++++++++++++++++++++++++++++ gengen/Data/GenType/CType.dcl | 16 ++++++ gengen/Data/GenType/CType.icl | 44 +++++++-------- gengen/test.icl | 12 +++-- 5 files changed, 157 insertions(+), 25 deletions(-) create mode 100644 gengen/Data/GenType/CParser.dcl create mode 100644 gengen/Data/GenType/CParser.icl diff --git a/gengen/Data/GenType/CParser.dcl b/gengen/Data/GenType/CParser.dcl new file mode 100644 index 0000000..70da0b3 --- /dev/null +++ b/gengen/Data/GenType/CParser.dcl @@ -0,0 +1,15 @@ +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]) diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl new file mode 100644 index 0000000..ab8417d --- /dev/null +++ b/gengen/Data/GenType/CParser.icl @@ -0,0 +1,95 @@ +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 \n#include \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 diff --git a/gengen/Data/GenType/CType.dcl b/gengen/Data/GenType/CType.dcl index 6efad22..ec6622f 100644 --- a/gengen/Data/GenType/CType.dcl +++ b/gengen/Data/GenType/CType.dcl @@ -1,5 +1,6 @@ definition module Data.GenType.CType +from StdGeneric import :: GenericTypeDefDescriptor from Data.Either import :: Either from Data.GenType import :: Type @@ -13,3 +14,18 @@ typedefs :: [[Type]] -> Either String [String] * 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 diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl index 7caa64e..3c4ca1e 100644 --- a/gengen/Data/GenType/CType.icl +++ b/gengen/Data/GenType/CType.icl @@ -28,6 +28,18 @@ where ,('-', "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)) () @@ -38,7 +50,7 @@ where 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"] @@ -55,7 +67,7 @@ where //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 @@ -84,8 +96,8 @@ where 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"] @@ -97,21 +109,10 @@ typedefs ts = evalStateT (execWriterT (mapM_ typedefgroup ts)) 'Data.Map'.newMap 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 @@ -140,8 +141,7 @@ where //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 @@ -158,7 +158,7 @@ where >>| 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] @@ -169,7 +169,7 @@ where 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 diff --git a/gengen/test.icl b/gengen/test.icl index 12169c2..122b099 100644 --- a/gengen/test.icl +++ b/gengen/test.icl @@ -13,10 +13,11 @@ import Data.Either 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, @@ -33,6 +34,10 @@ 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} + +:: 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 @@ -44,6 +49,7 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, 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]]) @@ -59,6 +65,6 @@ Start = //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{|*|} -- 2.20.1