gengen/Data/GenType/CType.icl

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