From ef1da130ffb2428deeeec0bfcd3e5511b2c50a5c Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Fri, 21 Aug 2020 16:25:34 +0200 Subject: [PATCH] non flat parsers --- gengen/Data/GenType/CParser.dcl | 10 +-- gengen/Data/GenType/CParser.icl | 114 ++++++++++++++++++++++++++++---- gengen/Data/GenType/CType.icl | 10 +-- gengen/test.icl | 11 +-- 4 files changed, 119 insertions(+), 26 deletions(-) diff --git a/gengen/Data/GenType/CParser.dcl b/gengen/Data/GenType/CParser.dcl index 70da0b3..32b8066 100644 --- 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 --- 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 \n#include \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 \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"]] + 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 --- 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 --- 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{|*|} -- 2.20.1