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 (<->) 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 /**
  46  * Generate a single parser for a type.
  47  * This does not terminate for a recursive type
  48  */
  49 flatParser :: Type -> Either String ([String], [String])
  50 flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t "r;" \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
  51 where
  52         parsedef c = ctypename t [" ", parsefun t, "(uint8_t (*get)())":c]
  53
  54         fpd :: Type Bool String -> FPMonad
  55         fpd (TyRef s) tl r = assign r (parsename s)
  56         fpd (TyBasic t) tl r
  57                 | tl = pure ()
  58                 = case t of
  59                         BTInt  = assign r "(int64_t)get()<<54"
  60                                 >>| result r "+=" "(int64_t)get()<<48"
  61                                 >>| result r "+=" "(int64_t)get()<<40"
  62                                 >>| result r "+=" "(int64_t)get()<<32"
  63                                 >>| result r "+=" "(int64_t)get()<<24"
  64                                 >>| result r "+=" "(int64_t)get()<<16"
  65                                 >>| result r "+=" "(int64_t)get()<<8"
  66                                 >>| result r "+=" "(int64_t)get()"
  67                         BTChar = assign r "(char)get()"
  68                         BTReal = assign r "double"
  69                         BTBool = assign r "(bool)get()"
  70                         t = fail $ "flatParse: there is no basic type for " +++ toString t
  71         fpd (TyArrow _ _) tl r = fail $ "flatParser: function cannot be serialized"
  72         fpd (TyNewType ti ci a) tl r = fpd a tl r
  73         fpd (TyArray _ _) tl r = fail $ "flatParser: arrays are not supported since they require dynamic memory"
  74         fpd (TyRecord ti fs) tl r
  75                 = mapM_ (fmtField) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs]
  76         //Enumeration
  77         fpd (TyObject ti fs) tl r
  78                 | and [t =: [] \\ (_, t)<-fs]
  79                         = assign r $ "(" +++ consName ti +++ ") get()"
  80         //Single constructor, single field (box)
  81         fpd (TyObject ti [(ci, [ty])]) tl r = fpd ty tl r
  82         //Single constructor
  83         fpd (TyObject ti [(ci, ts)]) tl r
  84                 =   mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  85         //Complex adt
  86         fpd (TyObject ti fs) tl r
  87                 =   assign (r <.> "cons") ("(" +++ consName ti +++ ") get()")
  88                 >>| indent ["switch (", r <.> "cons){\n"]
  89                 >>| mapM_ fmtCons fs
  90                 >>| indent ["}\n"]
  91         where
  92                 fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad
  93                 fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"]
  94                         >>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts]
  95                         >>| mapWriterT (local inc) (indent ["break;\n"])
  96                 where
  97                         cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
  98         fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
  99
 100         fmtField :: (String, Type) -> FPMonad
 101         fmtField (name, ty) = fpd ty False name
 102
 103 /**
 104  * generate parsers for the types grouped by strongly connected components
 105  */
 106 :: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
 107 :: TPState :== 'Data.Map'.Map String (String, Bool)
 108 parsers :: [[Type]] -> Either String ([String], [String])
 109 parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
 110 where
 111         parsedefs :: ([[Type]] -> [String])
 112         parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
 113
 114         parsedef :: Type [String] -> [String]
 115         parsedef t c = ctypename t [" *", parsefun t, "(uint8_t (*get)()",pd t, ")":c]
 116         where
 117                 pd (TyBasic s) = ""
 118                 pd (TyUList _ _) = ", void *parse_0(uint8_t (*get)())"
 119                 pd (TyUMaybe _) = ", void *parse_0(uint8_t (*get)())"
 120                 pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..gtd.gtd_arity-1]]
 121                 pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity grd.grd_type-1]]
 122 //              pd (TyNewType _ _ _) = abort "not implemented yet\n"
 123                 pd t = abort $ "not implemented yet: " +++ toString t +++ "\n"
 124
 125         recordArity :: GenType -> Int
 126         recordArity (GenTypeCons _) = 0
 127         recordArity (GenTypeVar _) = 0
 128         recordArity (GenTypeApp _ _) = 0
 129         recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 0
 130         recordArity (GenTypeArrow l r) = inc $ recordArity r
 131
 132         parsergroup :: [Type] -> TPMonad
 133         parsergroup ts
 134                 =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
 135                 >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
 136         where
 137                 declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
 138
 139         printTypeName :: String -> TPMonad
 140         printTypeName tname
 141                 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
 142                 >>= tell
 143
 144         parser :: Type -> TPMonad
 145         parser t=:(TyRef s) = tell [parsefun t]
 146         parser (TyBasic t)
 147                 = case t of
 148                         BTInt = tell ["\t*r = (Int)get()<<54;\n"
 149                                 , "\t*r += (Int)get()<<48;\n"
 150                                 , "\t*r += (Int)get()<<40;\n"
 151                                 , "\t*r += (Int)get()<<32;\n"
 152                                 , "\t*r += (Int)get()<<24;\n"
 153                                 , "\t*r += (Int)get()<<16;\n"
 154                                 , "\t*r += (Int)get()<<8;\n"
 155                                 , "\t*r += (Int)get();\n"]
 156                         BTChar = tell ["\t*r = (Char)get();\n"]
 157                         BTBool = tell ["\t*r = (Bool)get();\n"]
 158                         //BTReal = tell ["\t*r = double;\n"]
 159                         t = fail $ "parser: there is no basic type for " +++ toString t
 160         parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
 161         parser (TyNewType ti ci a) = parser a
 162         parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
 163         parser (TyRecord ti fs)
 164                 = fmtFields 1 ti.grd_type ["r" <-> fi.gfd_name\\(fi, _)<-fs]
 165         //Enumeration
 166         parser (TyObject ti fs)
 167                 | and [t =: [] \\ (_, t)<-fs]
 168                         = tell ["\t*r = (", consName ti, ") get();\n"]
 169         //Single constructor, single field (box)
 170         parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
 171         //Single constructor
 172         parser t=:(TyObject ti [(ci, ts)])
 173                 = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
 174         //Complex adt
 175         parser (TyObject ti fs)
 176                 =   tell ["\tr" <-> "cons = (", consName ti, ") get();\n"]
 177                 >>| tell ["\tswitch(r" <-> "cons) {\n"]
 178                 >>| mapM_ fmtCons fs
 179                 >>| tell ["\t}\n"]
 180         where
 181                 fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
 182                 fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
 183                         >>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
 184                         >>| tell ["\t\tbreak;\n"]
 185                 where
 186                         cs i = "r" <-> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" ("" <-> "f" +++ toString i)
 187         parser t = fail $ "parser: unsupported type " +++ toString t
 188
 189         fmtFields :: Int GenType [String] -> TPMonad
 190         fmtFields i _ [] = pure ()
 191         fmtFields i (GenTypeArrow l r) [x:xs]
 192                 = tell [createArray i '\t', x, " = "] >>| fmtField l >>| tell [");\n"] >>| fmtFields i r xs
 193
 194         fmtField :: GenType -> TPMonad
 195         fmtField (GenTypeCons a) = tell ["parse_", safe a, "(get"]
 196         fmtField (GenTypeVar a) = tell ["parse_", toString a, "(get"]
 197         fmtField t=:(GenTypeApp _ _)
 198                 = let [x:xs] = ufold t in fmtField x >>| case ufold t of
 199                         [] = tell [")"]
 200                         xs = tell [", "] >>| sequence_ (intersperse (tell [", "]) (map (\s->fmtField s >>| tell [")"]) xs))
 201         where
 202                 ufold (GenTypeApp l r) = [l:ufold r]
 203                 ufold t = [t]