+++ /dev/null
-implementation module GenType.CParser
-
-import Control.Applicative
-import Control.Monad
-import Control.Monad.Fail
-import Control.Monad.Reader
-import Control.Monad.State
-import Control.Monad.Trans
-import Control.Monad.Writer
-import Data.Either
-import Data.Func
-import Data.Functor
-import Data.List
-import qualified Data.Map
-from Data.Map import :: Map(..)
-import Data.Maybe
-import Data.Tuple
-import StdEnv
-import qualified Text
-from Text import class Text(concat), instance Text String
-
-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 c = ["parse_", safe (typeName t):c]
-
-(<.>) infixr 6
-(<.>) a b = a +++ "." +++ b
-
-(<->) infixr 6
-(<->) a b = a +++ "->" +++ b
-
-result r op s = indent [r, " ", op, " ", s, ";\n"]
-assign r s = result r "=" s
-parsename s = "parse_" +++ safe s
-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]
-
-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]]
-
- fpd :: Type Bool String -> FPMonad
- fpd (TyRef s) tl r = assign r (parsename s)
- fpd (TyBasic t) tl r
- | tl = pure ()
- = case t of
- BTInt = assign r "(int64_t)get()<<54"
- >>| result r "+=" "(int64_t)get()<<48"
- >>| result r "+=" "(int64_t)get()<<40"
- >>| result r "+=" "(int64_t)get()<<32"
- >>| result r "+=" "(int64_t)get()<<24"
- >>| result r "+=" "(int64_t)get()<<16"
- >>| result r "+=" "(int64_t)get()<<8"
- >>| result r "+=" "(int64_t)get()"
- BTChar = assign r "(char)get()"
-// 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"
- fpd (TyNewType ti ci a) tl r = fpd a tl r
- fpd (TyArray _ _) tl r = fail $ "flatParser: arrays are not supported since they require dynamic memory"
- fpd (TyRecord ti fs) tl r
- = mapM_ (fmtField) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs]
- //Enumeration
- fpd (TyObject ti fs) tl r
- | and [t =: [] \\ (_, t)<-fs]
- = assign r $ "(" +++ consName ti +++ ") get()"
- //Single constructor, single field (box)
- fpd (TyObject ti [(ci, [ty])]) tl r = fpd ty tl r
- //Single constructor
- fpd (TyObject ti [(ci, ts)]) tl r
- = mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
- //Complex adt
- fpd (TyObject ti fs) tl r
- = assign (r <.> "cons") ("(" +++ consName ti +++ ") get()")
- >>| indent ["switch (", r <.> "cons){\n"]
- >>| mapM_ fmtCons fs
- >>| indent ["}\n"]
- where
- fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad
- fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"]
- >>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts]
- >>| mapWriterT (local inc) (indent ["break;\n"])
- where
- cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
- fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
-
- fmtField :: (String, Type) -> FPMonad
- fmtField (name, ty) = fpd ty False name
-
-:: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
-:: TPState :== 'Data.Map'.Map String (String, Bool)
-parsers :: [[Type]] -> Either String ([String], [String])
-parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
-where
- parsedefs :: ([[Type]] -> [String])
- parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
-
- parsedef :: Type [String] -> [String]
- parsedef t c = ctypename t [" *":parsefun t ["(uint8_t (*get)()":pks (typeKind t) True [")":c]]]
- where
- 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
- = liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
- >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
- where
- declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
-
- 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 ["\t*r = (Int)get()<<54;\n"
- , "\t*r += (Int)get()<<48;\n"
- , "\t*r += (Int)get()<<40;\n"
- , "\t*r += (Int)get()<<32;\n"
- , "\t*r += (Int)get()<<24;\n"
- , "\t*r += (Int)get()<<16;\n"
- , "\t*r += (Int)get()<<8;\n"
- , "\t*r += (Int)get();\n"]
- BTChar = tell ["\t*r = (Char)get();\n"]
- BTBool = tell ["\t*r = (Bool)get();\n"]
- //BTReal = tell ["\t*r = double;\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 ["\t*r = (", consName ti, ") get();\n"]
- //Single constructor, single field (box)
- parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = ":fmtField ci.gcd_type [");\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, " = "] >>| tell (fmtField l []) >>| tell [");\n"] >>| fmtFields i r xs
-
- fmtField :: GenType [String] -> [String]
- fmtField (GenTypeCons a) c = ["parse_", safe a, "(get":c]
- fmtField (GenTypeVar a) c = ["parse_", toString a, "(get":c]
- fmtField t=:(GenTypeApp _ _) c = ufold t c
- where
- ufold (GenTypeApp l r) c = ufold l [", ":fmtField r [")":c]]
- ufold t c = fmtField t c
repositories / clean-tests.git / blobdiff