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 import Debug.Trace
 109 parsers :: [[Type]] -> Either String ([String], [String])
 110 parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
 111 where
 112         parsedefs :: ([[Type]] -> [String])
 113         parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
 114
 115         parsedef :: Type [String] -> [String]
 116         parsedef t c
 117                 # (pt, _) = trace_stdout (parsefun t, toString $ genTypeKind $ typeGenType t)
 118                 = ctypename t [" *", /*parsefun */pt, "(uint8_t (*get)()",pd t, ")":c]
 119         where
 120                 pd (TyBasic s) = ""
 121                 pd (TyUList _ _) = ", void *parse_0(uint8_t (*get)())"
 122                 pd (TyUMaybe _) = ", void *parse_0(uint8_t (*get)())"
 123                 pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..gtd.gtd_arity-1]]
 124                 pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity (trace_stdout grd.grd_type)-1]]
 125 //              pd (TyNewType _ _ _) = abort "not implemented yet\n"
 126                 pd t = abort $ "not implemented yet: " +++ toString t +++ "\n"
 127
 128         recordArity :: GenType -> Int
 129         recordArity (GenTypeCons _) = 0
 130         recordArity (GenTypeVar _) = 0
 131         recordArity (GenTypeApp _ _) = 0
 132         recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 1
 133         recordArity (GenTypeArrow l r) = inc $ recordArity l
 134
 135         parsergroup :: [Type] -> TPMonad
 136         parsergroup ts
 137                 =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
 138                 >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
 139         where
 140                 declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
 141
 142         printTypeName :: String -> TPMonad
 143         printTypeName tname
 144                 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
 145                 >>= tell
 146
 147         parser :: Type -> TPMonad
 148         parser t=:(TyRef s) = tell [parsefun t]
 149         parser (TyBasic t)
 150                 = case t of
 151                         BTInt = tell ["\t*r = (Int)get()<<54;\n"
 152                                 , "\t*r += (Int)get()<<48;\n"
 153                                 , "\t*r += (Int)get()<<40;\n"
 154                                 , "\t*r += (Int)get()<<32;\n"
 155                                 , "\t*r += (Int)get()<<24;\n"
 156                                 , "\t*r += (Int)get()<<16;\n"
 157                                 , "\t*r += (Int)get()<<8;\n"
 158                                 , "\t*r += (Int)get();\n"]
 159                         BTChar = tell ["\t*r = (Char)get();\n"]
 160                         BTBool = tell ["\t*r = (Bool)get();\n"]
 161                         //BTReal = tell ["\t*r = double;\n"]
 162                         t = fail $ "parser: there is no basic type for " +++ toString t
 163         parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
 164         parser (TyNewType ti ci a) = parser a
 165         parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
 166         parser (TyRecord ti fs)
 167                 = fmtFields 1 ti.grd_type ["r" <-> fi.gfd_name\\(fi, _)<-fs]
 168         //Enumeration
 169         parser (TyObject ti fs)
 170                 | and [t =: [] \\ (_, t)<-fs]
 171                         = tell ["\t*r = (", consName ti, ") get();\n"]
 172         //Single constructor, single field (box)
 173         parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = ":fmtField ci.gcd_type [");\n"]]
 174         //Single constructor
 175         parser t=:(TyObject ti [(ci, ts)])
 176                 = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
 177         //Complex adt
 178         parser (TyObject ti fs)
 179                 =   tell ["\tr" <-> "cons = (", consName ti, ") get();\n"]
 180                 >>| tell ["\tswitch(r" <-> "cons) {\n"]
 181                 >>| mapM_ fmtCons fs
 182                 >>| tell ["\t}\n"]
 183         where
 184                 fmtCons :: (GenericConsDescriptor,[Type]) -> TPMonad
 185                 fmtCons (ci, ts) = tell ["\tcase ", safe ci.gcd_name, ":\n"]
 186                         >>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
 187                         >>| tell ["\t\tbreak;\n"]
 188                 where
 189                         cs i = "r" <-> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" ("" <-> "f" +++ toString i)
 190         parser t = fail $ "parser: unsupported type " +++ toString t
 191
 192         fmtFields :: Int GenType [String] -> TPMonad
 193         fmtFields i _ [] = pure ()
 194         fmtFields i (GenTypeArrow l r) [x:xs]
 195                 = tell [createArray i '\t', x, " = "] >>| tell (fmtField l []) >>| tell [");\n"] >>| fmtFields i r xs
 196
 197         fmtField :: GenType [String] -> [String]
 198         fmtField (GenTypeCons a) c = ["parse_", safe a, "(get":c]
 199         fmtField (GenTypeVar a) c = ["parse_", toString a, "(get":c]
 200         fmtField t=:(GenTypeApp _ _) c = ufold t c
 201         where
 202                 ufold (GenTypeApp l r) c = ufold l [", ":fmtField r [")":c]]
 203                 ufold t c = fmtField t c