gengen/Data/GenType/CType.icl

   1 implementation module Data.GenType.CType
   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.GenType
  14 import Data.List
  15 import qualified Data.Map
  16 from Data.Map import :: Map(..)
  17 import Data.Maybe
  18 import Data.Tuple
  19 import StdEnv
  20 import qualified Text
  21 from Text import class Text(concat), instance Text String
  22
  23 instance MonadFail (Either String) where fail s = Left s
  24
  25 safe :: String -> String
  26 safe s = concat [fromMaybe {c} $ lookup c cs\\c <-:s]
  27 where
  28         cs = [('~', "Tld"), ('@', "At"), ('#', "Hsh"), ('$', "Dlr"), ('%', "Prc")
  29                 ,('^', "Hat"), ('?', "Qtn"), ('!', "Bng"), (':', "Cln"), ('+', "Pls")
  30                 ,('-', "Min"), ('*', "Ast"), ('<', "Les"), ('>', "Gre"), ('\\', "Bsl")
  31                 ,('/', "Slh"), ('|', "Pip"), ('&', "Amp"), ('=', "Eq"), ('.', "Dot")]
  32
  33 prefix :: Type -> String
  34 prefix (TyRecord _ _) = "struct "
  35 prefix (TyObject _ fs)
  36         | and [t =: [] \\ (_, t)<-fs] = "enum "
  37         | fs =: [(_, [_])] = ""
  38         | fs =: [_] = "struct "
  39         = "struct "
  40 prefix  _ = ""
  41
  42 consName :: GenericTypeDefDescriptor -> String
  43 consName s = "enum " +++ safe s.gtd_name +++ "_cons"
  44
  45 iindent = mapWriterT $ mapStateT $ local inc
  46 indent c = liftT (liftT ask) >>= \i->tell [createArray i '\t':c]
  47
  48 :: FTMonad :== WriterT [String] (StateT [(String, [String])] (ReaderT Int (Either String))) ()
  49 flatTypedef :: Type -> Either String [String]
  50 flatTypedef t = (\(w, es)->flatten (map snd es) ++ w)
  51         <$> runReaderT (runStateT (execWriterT (ftd t True )) []) 0
  52 where
  53         ftd :: Type Bool -> FTMonad
  54         ftd (TyRef s) tl = indent [s]
  55         ftd (TyBasic t) tl
  56                 | tl = pure ()
  57                 = case t of
  58                         BTInt  = indent ["int64_t"]
  59                         BTChar = indent ["char"]
  60                         BTReal = indent ["double"]
  61                         BTBool = indent ["bool"]
  62                         t = fail $ "flatTypedef: there is no basic type for " +++ toString t
  63         ftd (TyArrow l r) tl = fail "flatTypedef: functions cannot be serialized"
  64         ftd (TyNewType ti ci a) tl = ftd a tl
  65         ftd (TyArray _ a) tl = indent ["*"] >>| ftd a tl
  66         ftd (TyRecord ti fs) tl
  67                 = indent ["struct ", if tl (safe ti.grd_name) "", " {\n"
  68                 ] >>| mapM_ (iindent o fmtField) [(fi.gfd_name, ty)\\(fi, ty)<-fs]
  69                 >>| indent ["}\n"]
  70         //Enumeration
  71         ftd (TyObject ti fs) tl
  72                 | and [t =: [] \\ (_, t)<-fs]
  73                         | tl = pure ()
  74                         = indent [] >>| enum ti fs
  75         //Single constructor, single field (box)
  76         ftd (TyObject ti [(ci, [ty])]) tl = ftd ty tl
  77         //Single constructor
  78         ftd (TyObject ti [(ci, ts)]) tl
  79                 =   indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
  80                 >>| mapM_ (iindent o fmtField) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  81                 >>| indent ["}"]
  82         //Complex adt
  83         ftd (TyObject ti fs) tl
  84                 =   indent ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
  85                 >>| iindent (indent []) >>| enum ti fs >>| tell [" cons;\n"]
  86                 >>| iindent (indent ["struct {\n"])
  87                 >>| mapM_ (iindent o iindent o fmtCons) fs
  88                 >>| iindent (indent ["} data;\n"])
  89                 >>| indent ["}", if tl ";" ""]
  90         where
  91                 fmtCons (ci, []) = pure ()
  92                 fmtCons (ci, [t]) = ftd t False >>| tell [" ", safe ci.gcd_name, ";\n"]
  93                 fmtCons (ci, ts)
  94                         =   indent ["struct {\n"]
  95                         >>| mapM_ (iindent o fmtField) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  96                         >>| indent ["} ", safe ci.gcd_name, ";\n"]
  97         ftd t tl = fail $ "cannot flatTypedef: " +++ toString t
  98
  99         enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad
 100         enum ti fs = liftT (gets (lookup ti.gtd_name)) >>= \e->case e of
 101                 ?None = liftT (modify \s->[(ti.gtd_name, [consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
 102                 ?Just _ = tell [consName ti]
 103
 104         fmtField :: (String, Type) -> FTMonad
 105         fmtField (name, ty) = ftd ty False >>| tell [" ", name, ";\n"]
 106
 107 :: TDMonad :== WriterT [String] (StateT TDState (Either String)) ()
 108 :: TDState :== 'Data.Map'.Map String (String, Bool)
 109 typedefs :: [[Type]] -> Either String [String]
 110 typedefs ts = evalStateT (execWriterT (mapM_ typedefgroup ts)) 'Data.Map'.newMap
 111 where
 112         typedefgroup :: [Type] -> TDMonad
 113         typedefgroup ts
 114                 =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, False))\\ty<-ts]))
 115                 >>| mapM_ (\x->printTypeName x >>| tell [";\n"]) (if (ts=:[_,_:_]) (map typeName ts) [])
 116                 >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->True)) o typeName) ts))
 117                 >>| mapM_ (\t->typedef t >>| tell ["\n"]) ts
 118
 119         printTypeName :: String -> TDMonad
 120         printTypeName tname
 121                 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
 122                 >>= tell
 123
 124         header :: Type [String] -> WriterT [String] m () | Monad m
 125         header t c = tell ["// ", toString (replaceBuiltins t), "\n":c]
 126
 127         typedef :: Type -> TDMonad
 128         typedef (TyRef s) = printTypeName s
 129         typedef (TyBasic t) = case t of
 130                 BTInt = printTypeName "int64_t"
 131                 BTChar = printTypeName "char"
 132                 BTReal = printTypeName "double"
 133                 BTBool = printTypeName "bool"
 134                 t = fail $ "basic type: " +++ toString t +++ " not implemented"
 135         typedef (TyArray _ a) = tell ["*"] >>| typedef a
 136         typedef t=:(TyNewType ti ci a)
 137                 =   header t []
 138                 >>| tydef ti.gtd_name ci.gcd_type
 139         typedef t=:(TyRecord ti fs)
 140                 =   header t ["struct ", safe ti.grd_name, " {\n"]
 141                 >>| fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs]
 142                 >>| tell ["};\n"]
 143         //Enumeration
 144         typedef t=:(TyObject ti fs)
 145                 | and [t =: [] \\ (_, t)<-fs] = header t
 146                         [consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
 147         //Single constructor, single field (box)
 148         typedef t=:(TyObject ti [(ci, [ty])]) = header t [] >>| tydef ti.gtd_name ci.gcd_type
 149         //Single constructor
 150         typedef t=:(TyObject ti [(ci, ts)])
 151                 =   header t ["struct ", safe ti.gtd_name, " {\n"]
 152                 >>| fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
 153                 >>| tell ["};\n"]
 154         //Complex adt
 155         typedef t=:(TyObject ti fs) = header t
 156                 ["struct ", safe ti.gtd_name, " {\n"
 157                 , "\t", consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
 158                 , "\tstruct {\n"]
 159                 >>| mapM_ fmtCons fs
 160                 >>| tell ["\t} data;\n};\n"]
 161         where
 162                 fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
 163                 fmtCons (ci, []) = pure ()
 164                 fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name]
 165                 fmtCons (ci, ts) = tell ["\t\tstruct {\n"]
 166                         >>| fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
 167                         >>| tell ["\t\t} ", safe ci.gcd_name, ";\n"]
 168         typedef t = fail $ toString t +++ " not implemented"
 169
 170         tydef :: String GenType -> TDMonad
 171         tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
 172
 173         fmtFields :: Int GenType [String] -> TDMonad
 174         fmtFields i _ [] = pure ()
 175         fmtFields i (GenTypeArrow l r) [x:xs]
 176                 = tell [createArray i '\t'] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs
 177
 178         fmtField :: String GenType -> TDMonad
 179         fmtField x (GenTypeCons a) = printTypeName a >>| tell [x]
 180         fmtField x (GenTypeVar a) = tell ["void *",x]
 181         fmtField x (GenTypeApp l r) = fmtField x l
 182         fmtField x t=:(GenTypeArrow _ _)
 183                 = mapM (fmap (concat o snd) o listen o fmtField "") (collectArgs t [])
 184                         >>= \[r:as]->tell [r, " (*",x,")(",'Text'.join ", " as, ")"]
 185         where
 186                 collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
 187                 collectArgs t c = [t:c]