gengen/Data/GenType/CParser.icl

   1 implementation module Data.GenType.CParser
   2
   3 import Control.Applicative
   4 import Control.Monad
   5 import Control.Monad.Fail
   6 import Control.Monad.Reader
   7 import Control.Monad.State
   8 import Control.Monad.Trans
   9 import Control.Monad.Writer
  10 import Data.Either
  11 import Data.Func
  12 import Data.Functor
  13 import Data.List
  14 import qualified Data.Map
  15 from Data.Map import :: Map(..)
  16 import Data.Maybe
  17 import Data.Tuple
  18 import StdEnv
  19 import qualified Text
  20 from Text import class Text(concat), instance Text String
  21
  22 import Data.GenType
  23 import Data.GenType.CType
  24
  25 instance MonadFail (Either String) where fail s = Left s
  26 :: FPMonad :== WriterT [String] (ReaderT Int (Either String)) ()
  27
  28 indent c = liftT ask >>= \i->tell [createArray i '\t':c]
  29
  30 parsefun t = "parse_" +++ safe (typeName t)
  31
  32 (<.>) infixr 6
  33 (<.>) a b = a +++ "." +++ b
  34
  35 result r op s = indent [r, " ", op, " ", s, ";\n"]
  36 assign r s = result r "=" s
  37 parsename s = "parse_" +++ safe s
  38 tail = ["\treturn r;\n}\n"]
  39 parsenameimp t def = def t [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]
  40
  41 /**
  42  * Generate a single parser for a type.
  43  * This does not terminate for a recursive type
  44  */
  45 flatParser :: Type -> Either String ([String], [String])
  46 flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
  47 where
  48         parsedef c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void))":c]
  49
  50         fpd :: Type Bool String -> FPMonad
  51         fpd (TyRef s) tl r = assign r (parsename s)
  52         fpd (TyBasic t) tl r
  53                 | tl = pure ()
  54                 = case t of
  55                         BTInt  = assign r "(int64_t)get()<<54"
  56                                 >>| result r "+=" "(int64_t)get()<<48"
  57                                 >>| result r "+=" "(int64_t)get()<<40"
  58                                 >>| result r "+=" "(int64_t)get()<<32"
  59                                 >>| result r "+=" "(int64_t)get()<<24"
  60                                 >>| result r "+=" "(int64_t)get()<<16"
  61                                 >>| result r "+=" "(int64_t)get()<<8"
  62                                 >>| result r "+=" "(int64_t)get()"
  63                         BTChar = assign r "(char)get()"
  64                         BTReal = assign r "double"
  65                         BTBool = assign r "(bool)get()"
  66                         t = fail $ "flatParse: there is no basic type for " +++ toString t
  67         fpd (TyArrow _ _) tl r = fail $ "flatParser: function cannot be serialized"
  68         fpd (TyNewType ti ci a) tl r = fpd a tl r
  69         fpd (TyArray _ _) tl r = fail $ "flatParser: arrays are not supported since they require dynamic memory"
  70         fpd (TyRecord ti fs) tl r
  71                 = mapM_ (fmtField) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs]
  72         //Enumeration
  73         fpd (TyObject ti fs) tl r
  74                 | and [t =: [] \\ (_, t)<-fs]
  75                         = assign r $ "(" +++ consName ti +++ ") get()"
  76         //Single constructor, single field (box)
  77         fpd (TyObject ti [(ci, [ty])]) tl r = fpd ty tl r
  78         //Single constructor
  79         fpd (TyObject ti [(ci, ts)]) tl r
  80                 =   mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  81         //Complex adt
  82         fpd (TyObject ti fs) tl r
  83                 =   assign (r <.> "cons") ("(" +++ consName ti +++ ") get()")
  84                 >>| indent ["switch (", r <.> "cons){\n"]
  85                 >>| mapM_ fmtCons fs
  86                 >>| indent ["}\n"]
  87         where
  88                 fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad
  89                 fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"]
  90                         >>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts]
  91                         >>| mapWriterT (local inc) (indent ["break;\n"])
  92                 where
  93                         cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
  94         fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
  95
  96         fmtField :: (String, Type) -> FPMonad
  97         fmtField (name, ty) = fpd ty False name
  98
  99 /**
 100  * generate parsers for the types grouped by strongly connected components
 101  */
 102 :: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
 103 :: TPState :== 'Data.Map'.Map String (String, Bool)
 104 parsers :: [[Type]] -> Either String ([String], [String])
 105 parsers ts = tuple ([""]) <$> evalStateT (execWriterT (mapM_ parsergroup ts >>| tell tail)) 'Data.Map'.newMap
 106 where
 107         parsedef t c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void)",pd t, ")":c]
 108         where
 109                 pd (TyUList _ _) = ", void *parse_0(uint8_t (*)(void))"
 110                 pd (TyUMaybe _) = ", void *parse_0(uint8_t (*)(void))"
 111                 pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)(void))"\\i<-[0..gtd.gtd_arity-1]]
 112                 pd (TyRecord grd _) = abort "not implemented yet\n"
 113                 pd (TyNewType _ _ _) = abort "not implemented yet\n"
 114                 pd _ = abort "not implemented yet\n"
 115
 116         parsergroup :: [Type] -> TPMonad
 117         parsergroup ts
 118                 =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
 119                 >>| mapM_ (\t->tell (parsenameimp t parsedef) >>| parser t >>| tell ["\n"]) ts
 120
 121         printTypeName :: String -> TPMonad
 122         printTypeName tname
 123                 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
 124                 >>= tell
 125
 126         parser :: Type -> TPMonad
 127         parser t=:(TyRef s) = tell [parsefun t]
 128         parser (TyBasic t)
 129                 = case t of
 130                         BTInt = tell ["\tr = (int64_t)get()<<54;\n"
 131                                 , "\tr += (int64_t)get()<<48;\n"
 132                                 , "\tr += (int64_t)get()<<40;\n"
 133                                 , "\tr += (int64_t)get()<<32;\n"
 134                                 , "\tr += (int64_t)get()<<24;\n"
 135                                 , "\tr += (int64_t)get()<<16;\n"
 136                                 , "\tr += (int64_t)get()<<8;\n"
 137                                 , "\tr += (int64_t)get();\n"]
 138                         BTChar = tell ["\tr = (char)get();\n"]
 139                         BTReal = tell ["\tr = double;\n"]
 140                         BTBool = tell ["\tr = (bool)get();\n"]
 141                         t = fail $ "parser: there is no basic type for " +++ toString t
 142         parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
 143         parser (TyNewType ti ci a) = parser a
 144         parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
 145         parser (TyRecord ti fs)
 146                 = fmtFields 1 ti.grd_type ["r" <.> fi.gfd_name\\(fi, _)<-fs]
 147         //Enumeration
 148         parser (TyObject ti fs)
 149                 | and [t =: [] \\ (_, t)<-fs]
 150                         = tell ["\tr = (" +++ consName ti +++ ") get();\n"]
 151         //Single constructor, single field (box)
 152         parser (TyObject ti [(ci, [ty])]) = tell ["\tr = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
 153         //Single constructor
 154         parser t=:(TyObject ti [(ci, ts)])
 155                 = fmtFields 1 ci.gcd_type ["r.f" +++ toString i\\i<-indexList ts]
 156         //Complex adt
 157         parser (TyObject ti fs)
 158                 =   tell ["\tr.cons = (", consName ti, ") get();\n"]
 159                 >>| tell ["\tswitch(r.cons) {\n"]
 160                 >>| mapM_ fmtCons fs
 161                 >>| tell ["\t}\n"]
 162         where
 163                 fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
 164                 fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
 165                         >>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
 166                         >>| tell ["\t\tbreak;\n"]
 167                 where
 168                         cs i = "r.data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
 169         parser t = fail $ "parser: unsupported type " +++ toString t
 170
 171         fmtFields :: Int GenType [String] -> TPMonad
 172         fmtFields i _ [] = pure ()
 173         fmtFields i (GenTypeArrow l r) [x:xs]
 174                 = tell [createArray i '\t', x, " = "] >>| fmtField l >>| tell [");\n"] >>| fmtFields i r xs
 175
 176         fmtField :: GenType -> TPMonad
 177         fmtField (GenTypeCons a) = tell ["parse_", safe a, "(get"]
 178         fmtField (GenTypeVar a) = tell ["parse_", toString a, "(get"]
 179         fmtField t=:(GenTypeApp _ _)
 180                 = let [x:xs] = ufold t in fmtField x >>| case ufold t of
 181                         [] = tell [")"]
 182                         xs = tell [", "] >>| sequence_ (intersperse (tell [", "]) (map (\s->fmtField s >>| tell [")"]) xs))
 183         where
 184                 ufold (GenTypeApp l r) = [l:ufold r]
 185                 ufold t = [t]
 186
 187 //      fmtField x t=:(GenTypeArrow _ _)
 188 //              = mapM (fmap (concat o snd) o listen o fmtField "") (collectArgs t [])
 189 //                      >>= \[r:as]->tell [r, " (*",x,")(",join ", " as, ")"]
 190 //      where
 191 //              collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
 192 //              collectArgs t c = [t:c]
 193 //      | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
 194 //      | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]