gengen/Data/GenType/CParser.icl

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