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