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