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 indent i c = tell [createArray i '\t':c]
  32
  33 :: FTMonad :== WriterT [String] (StateT [(String, [String])] (Either String)) ()
  34 flatTypedef :: Type -> Either String [String]
  35 flatTypedef t = (\(w, es)->flatten (map snd es) ++ w)
  36         <$> runStateT (execWriterT (ftd t True 0)) []
  37 where
  38         ftd :: Type Bool Int -> FTMonad
  39         ftd (TyRef s) tl i = indent i [s]
  40         ftd (TyBasic t) tl i
  41                 | tl = tell []
  42                  = case t of
  43                         BTInt  = indent i ["int64_t"]
  44                         BTChar = indent i ["char"]
  45                         BTReal = indent i ["double"]
  46                         BTBool = indent i ["bool"]
  47                         t = fail $ "cannot flatTypedef: " +++ toString t
  48 //      ftd (TyArrow l r) i c = indent i ["*":ftd a i c]
  49         ftd (TyNewType ti ci a) tl i = ftd a tl i
  50         ftd (TyArray _ a) tl i = indent i ["*"] >>| ftd a tl i
  51         ftd (TyRecord ti fs) tl i
  52                 = indent i ["struct ", if tl (safe ti.grd_name) "", " {\n"
  53                 ] >>| mapM_ (fmtField $ i+1) [(fi.gfd_name, ty)\\(fi, ty)<-fs]
  54                 >>| indent i ["}\n"]
  55         //Enumeration
  56         ftd (TyObject ti fs) tl i
  57                 | and [t =: [] \\ (_, t)<-fs]
  58                         | tl = tell []
  59                         = indent i [] >>| enum ti fs
  60         //Single constructor, single field (box)
  61         ftd (TyObject ti [(ci, [ty])]) tl i = ftd ty tl i
  62         //Single constructor
  63         ftd (TyObject ti [(ci, ts)]) tl i
  64                 =   indent i ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
  65                 >>| mapM_ (fmtField $ i+1) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  66                 >>| indent i ["}"]
  67         //Complex adt
  68         ftd (TyObject ti fs) tl i
  69                 =   indent i ["struct ", if tl (safe ti.gtd_name) "", " {\n"]
  70                 >>| indent (i+1) [] >>| enum ti fs >>| tell [" cons;\n"]
  71                 >>| indent (i+1) ["struct {\n"]
  72                 >>| mapM_ (fmtCons $ i+2) fs
  73                 >>| indent (i+1) ["} data;\n"]
  74                 >>| indent i ["}", if tl ";" ""]
  75         where
  76                 fmtCons i (ci, []) = pure ()
  77                 fmtCons i (ci, [t]) = ftd t False i >>| tell [" ", safe ci.gcd_name, ";\n"]
  78                 fmtCons i (ci, ts)
  79                         =   indent i ["struct {\n"]
  80                         >>| mapM_ (fmtField $ i+1) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts]
  81                         >>| indent i ["} ", safe ci.gcd_name, ";\n"]
  82         ftd t tl i = fail $ "cannot flatTypedef: " +++ toString t
  83
  84
  85         enum :: GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])] -> FTMonad
  86         enum ti fs = liftT (gets (lookup ti.gtd_name)) >>= \e->case e of
  87                 ?None = liftT (modify \s->[(ti.gtd_name, ["enum ", safe ti.gtd_name, "_cons {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]):s]) >>| enum ti fs
  88                 ?Just _ = tell ["enum ", safe ti.gtd_name, "_cons"]
  89
  90         fmtField :: Int (String, Type) -> FTMonad
  91         fmtField i (name, ty) = ftd ty False i >>| tell [" ", name, ";\n"]
  92
  93 :: TDMonad :== WriterT [String] (StateT TDState (Either String)) ()
  94 :: TDState :== 'Data.Map'.Map String (String, Bool)
  95 typedefs :: [[Type]] -> Either String [String]
  96 typedefs ts = evalStateT (execWriterT (mapM_ typedefgroup ts)) 'Data.Map'.newMap
  97 where
  98         typedefgroup :: [Type] -> TDMonad
  99         typedefgroup ts
 100                 =   liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
 101                 >>| mapM_ (\t->typedef t >>| tell ["\n"]) ts
 102                 >>| liftT (modify (flip (foldr $ 'Data.Map'.alter (fmap (fmap \_->False)) o typeName) ts))
 103                 >>| case ts of
 104                         [_] = tell []
 105                         ts = mapM_ (\x->printTypeName x >>| tell [";\n"]) (map typeName ts)
 106         where
 107                 prefix :: Type -> String
 108                 prefix (TyRecord _ _) = "struct "
 109                 prefix (TyObject _ fs)
 110                         | and [t =: [] \\ (_, t)<-fs] = "enum "
 111                         | fs =: [(_, [_])] = ""
 112                         | fs =: [_] = "struct "
 113                         = "struct "
 114                 prefix  _ = ""
 115
 116         printTypeName :: String -> TDMonad
 117         printTypeName tname
 118                 = liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
 119                 >>= tell
 120
 121         header :: Type [String] -> WriterT [String] m () | Monad m
 122         header t c = tell ["// ", toString (replaceBuiltins t), "\n":c]
 123
 124         typedef :: Type -> TDMonad
 125         typedef (TyRef s) = printTypeName s
 126         typedef (TyBasic t) = case t of
 127                 BTInt = printTypeName "int64_t"
 128                 BTChar = printTypeName "char"
 129                 BTReal = printTypeName "double"
 130                 BTBool = printTypeName "bool"
 131                 t = fail $ "basic type: " +++ toString t +++ " not implemented"
 132         typedef (TyArray _ a) = tell ["*"] >>| typedef a
 133         typedef t=:(TyNewType ti ci a)
 134                 =   header t []
 135                 >>| tydef ti.gtd_name ci.gcd_type
 136         typedef t=:(TyRecord ti fs)
 137                 =   header t ["struct ", safe ti.grd_name, " {\n"]
 138                 >>| fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs]
 139                 >>| tell ["};\n"]
 140         //Enumeration
 141         typedef t=:(TyObject ti fs)
 142                 | and [t =: [] \\ (_, t)<-fs] = header t
 143                         ["enum ", safe ti.gtd_name, "_cons {"
 144                                 , 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, []) = tell []
 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 _ [] = tell []
 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]