gengen/src/GenType/CType.icl

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