gengen/Data/GenType/CParser.icl

   1 implementation module Data.GenType.CParser
   2
   3 import StdEnv
   4 import Control.Applicative
   5 import Control.Monad => qualified join
   6 import Control.Monad.State
   7 import Control.Monad.Trans
   8 import Control.Monad.Writer
   9 import Control.Monad.Reader
  10 import Control.Monad.Fail
  11 import Data.Either
  12 import Data.Func
  13 import Data.Functor
  14 import Data.Tuple
  15 import Data.List
  16
  17 import Data.GenType
  18 import Data.GenType.CType
  19
  20 instance MonadFail (Either String) where fail s = Left s
  21 :: FPMonad :== WriterT [String] (ReaderT Int (Either String)) ()
  22
  23 indent c = liftT ask >>= \i->tell [createArray i '\t':c]
  24
  25 (<.>) infixr 6
  26 (<.>) a b = a +++ "." +++ b
  27
  28 /**
  29  * Generate a single parser for a type.
  30  * This does not terminate for a recursive type
  31  */
  32 flatParser :: Type -> Either String ([String], [String])
  33 flatParser t = tuple header <$> runReaderT (execWriterT (tell head >>| fpd t True "r" >>| tell tail)) 1
  34 where
  35         includes = "#include <stdint.h>\n#include <stdbool.h>\n"
  36         header = [includes:parsefun [";\n"]]
  37         parsefun c = [prefix t, safe (typeName t), " parse_",  safe (typeName t), "(uint8_t (*get)(void))":c]
  38         head = [includes:parsefun [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]]
  39         tail = ["\treturn r;\n}\n"]
  40         parsename s = "parse_" +++ safe s
  41         result r op s = indent [r, " ", op, " ", s, ";\n"]
  42         assign r s = result r "=" s
  43
  44         fpd :: Type Bool String -> FPMonad
  45         fpd (TyRef s) tl r = assign r (parsename s)
  46         fpd (TyBasic t) tl r
  47                 | tl = pure ()
  48                 = case t of
  49                         BTInt  = assign r "(int64_t)get()<<54"
  50                                 >>| result r "+=" "(int64_t)get()<<48"
  51                                 >>| result r "+=" "(int64_t)get()<<40"
  52                                 >>| result r "+=" "(int64_t)get()<<32"
  53                                 >>| result r "+=" "(int64_t)get()<<24"
  54                                 >>| result r "+=" "(int64_t)get()<<16"
  55                                 >>| result r "+=" "(int64_t)get()<<8"
  56                                 >>| result r "+=" "(int64_t)get()"
  57                         BTChar = assign r "(char)get()"
  58                         BTReal = assign r "double"
  59                         BTBool = assign r "(bool)get()"
  60                         t = fail $ "flatParse: there is no basic type for " +++ toString t
  61         fpd (TyArrow _ _) tl r = fail $ "flatParser: function cannot be serialized"
  62         fpd (TyNewType ti ci a) tl r = fpd a tl r
  63         fpd (TyArray _ _) tl r = fail $ "flatParser: arrays are not supported since they require dynamic memory"
  64         fpd (TyRecord ti fs) tl r
  65                 = mapM_ (fmtField) [(r <.> fi.gfd_name, ty)\\(fi, ty)<-fs]
  66         //Enumeration
  67         fpd (TyObject ti fs) tl r
  68                 | and [t =: [] \\ (_, t)<-fs]
  69                         = assign r $ "(" +++ consName ti +++ ") get()"
  70         //Single constructor, single field (box)
  71         fpd (TyObject ti [(ci, [ty])]) tl r = fpd ty tl r
  72         //Single constructor
  73         fpd (TyObject ti [(ci, ts)]) tl r
  74                 =   mapM_ fmtField [(r <.> "f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  75         //Complex adt
  76         fpd (TyObject ti fs) tl r
  77                 =   assign (r +++ ".cons") ("(" +++ consName ti +++ ") get()")
  78                 >>| indent ["switch (", r <.> "cons){\n"]
  79                 >>| mapM_ (mapWriterT (local inc) o fmtCons) fs
  80                 >>| indent ["}\n"]
  81         where
  82                 fmtCons :: (GenericConsDescriptor,[Type]) -> FPMonad
  83                 fmtCons (ci, ts) = indent ["case ", safe ci.gcd_name, ":\n"]
  84                         >>| mapM_ (mapWriterT (local inc) o fmtField) [(cs i, ty) \\i<-[0..] & ty<-ts]
  85                         >>| indent ["break;\n"]
  86                 where
  87                         cs i = r <.> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
  88         fpd t tl r = fail $ "flatParser: unsupported " +++ toString t
  89
  90         fmtField :: (String, Type) -> FPMonad
  91         fmtField (name, ty) = fpd ty False name
  92
  93 /**
  94  * generate parsers for the types grouped by strongly connected components
  95  */
  96 parser :: [[Type]] -> Either String [String]
  97 parser _ = undef