gengen/src/GenType/CParser.icl

   1 implementation module 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 GenType
  23 import 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 c = ["parse_", safe (typeName t):c]
  31
  32 (<.>) infixr 6
  33 (<.>) a b = a +++ "." +++ b
  34
  35 (<->) infixr 6
  36 (<->) a b = a +++ "->" +++ b
  37
  38 result r op s = indent [r, " ", op, " ", s, ";\n"]
  39 assign r s = result r "=" s
  40 parsename s = "parse_" +++ safe s
  41 tail = ["\treturn r;\n}\n"]
  42 parsenameimp t c def = def t [" {\n\t":ctypename t [" ", c, "\n\n"]]
  43 ctypename t c = [prefix t, safe (typeName t):c]
  44
  45 flatParser :: Type -> Either String ([String], [String])
  46 flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t "r;" \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
  47 where
  48         parsedef c = ctypename t [" ":parsefun t ["(uint8_t (*get)())":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 :: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
 100 :: TPState :== 'Data.Map'.Map String (String, Bool)
 101 parsers :: [[Type]] -> Either String ([String], [String])
 102 parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
 103 where
 104         parsedefs :: ([[Type]] -> [String])
 105         parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
 106
 107         parsedef :: Type [String] -> [String]
 108         parsedef t c = ctypename t [" *":parsefun t ["(uint8_t (*get)()":pks (typeKind t) True [")":c]]]
 109         where
 110                 pks :: Kind Bool [String] -> [String]
 111                 pks k tl c = foldr (\(i, k) c->pd k tl i c) c $ zip2 [0..] $ typeArgs k
 112
 113                 pd :: Kind Bool Int [String] -> [String]
 114                 pd KStar tl i c = [", void *(*", if tl ("parse_"+++toString i) "", ")(uint8_t (*)())":c]
 115                 pd (l KArrow r) tl i c =
 116                         [ ", void *(*", if tl ("parse_"+++toString i) "", ")(uint8_t (*)()"
 117                         : pks l False $ pd r False (inc i) [")":c]]
 118
 119                 typeArgs :: Kind -> [Kind]
 120                 typeArgs KStar = []
 121                 typeArgs (l KArrow r) = [l:typeArgs r]
 122
 123         parsergroup :: [Type] -> TPMonad
 124         parsergroup ts
 125                 =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
 126                 >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
 127         where
 128                 declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
 129
 130         printTypeName :: String -> TPMonad
 131         printTypeName tname
 132                 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
 133                 >>= tell
 134
 135         parser :: Type -> TPMonad
 136         parser t=:(TyRef s) = tell $ parsefun t []
 137         parser (TyBasic t)
 138                 = case t of
 139                         BTInt = tell ["\t*r = (Int)get()<<54;\n"
 140                                 , "\t*r += (Int)get()<<48;\n"
 141                                 , "\t*r += (Int)get()<<40;\n"
 142                                 , "\t*r += (Int)get()<<32;\n"
 143                                 , "\t*r += (Int)get()<<24;\n"
 144                                 , "\t*r += (Int)get()<<16;\n"
 145                                 , "\t*r += (Int)get()<<8;\n"
 146                                 , "\t*r += (Int)get();\n"]
 147                         BTChar = tell ["\t*r = (Char)get();\n"]
 148                         BTBool = tell ["\t*r = (Bool)get();\n"]
 149                         //BTReal = tell ["\t*r = double;\n"]
 150                         t = fail $ "parser: there is no basic type for " +++ toString t
 151         parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
 152         parser (TyNewType ti ci a) = parser a
 153         parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
 154         parser (TyRecord ti fs)
 155                 = fmtFields 1 ti.grd_type ["r" <-> fi.gfd_name\\(fi, _)<-fs]
 156         //Enumeration
 157         parser (TyObject ti fs)
 158                 | and [t =: [] \\ (_, t)<-fs]
 159                         = tell ["\t*r = (", consName ti, ") get();\n"]
 160         //Single constructor, single field (box)
 161         parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = ":fmtField ci.gcd_type [");\n"]]
 162         //Single constructor
 163         parser t=:(TyObject ti [(ci, ts)])
 164                 = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
 165         //Complex adt
 166         parser (TyObject ti fs)
 167                 =   tell ["\tr" <-> "cons = (", consName ti, ") get();\n"]
 168                 >>| tell ["\tswitch(r" <-> "cons) {\n"]
 169                 >>| mapM_ fmtCons fs
 170                 >>| tell ["\t}\n"]
 171         where
 172                 fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
 173                 fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
 174                         >>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
 175                         >>| tell ["\t\tbreak;\n"]
 176                 where
 177                         cs i = "r" <-> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" ("" <-> "f" +++ toString i)
 178         parser t = fail $ "parser: unsupported type " +++ toString t
 179
 180         fmtFields :: Int GenType [String] -> TPMonad
 181         fmtFields i _ [] = pure ()
 182         fmtFields i (GenTypeArrow l r) [x:xs]
 183                 = tell [createArray i '\t', x, " = "] >>| tell (fmtField l []) >>| tell [");\n"] >>| fmtFields i r xs
 184
 185         fmtField :: GenType [String] -> [String]
 186         fmtField (GenTypeCons a) c = ["parse_", safe a, "(get":c]
 187         fmtField (GenTypeVar a) c = ["parse_", toString a, "(get":c]
 188         fmtField t=:(GenTypeApp _ _) c = ufold t c
 189         where
 190                 ufold (GenTypeApp l r) c = ufold l [", ":fmtField r [")":c]]
 191                 ufold t c = fmtField t c