1 implementation module GenType.CType
3 import Control.Applicative
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
14 import qualified Data.Map
15 from Data.Map import :: Map(..)
20 from Text import class Text(concat), instance Text String
24 instance MonadFail (Either String) where fail s = Left s
26 safe :: String -> String
27 safe s = concat [fromMaybe {c} $ lookup c cs\\c <-:s]
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")]
34 prefix :: Type -> String
35 prefix (TyRecord _ _) = "struct "
36 prefix (TyObject _ fs)
37 | and [t =: [] \\ (_, t)<-fs] = "enum "
38 | fs =: [(_, [_])] = ""
39 | fs =: [_] = "struct "
43 consName :: GenericTypeDefDescriptor -> String
44 consName s = "enum " +++ safe s.gtd_name +++ "_cons"
46 iindent = mapWriterT $ mapStateT $ local inc
47 indent c = liftT (liftT ask) >>= \i->tell [createArray i '\t':c]
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
54 ftd :: Type Bool -> FTMonad
55 ftd (TyRef s) tl = indent [s]
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]
72 ftd (TyObject ti fs) tl
73 | and [t =: [] \\ (_, t)<-fs]
75 = indent [] >>| enum ti fs
76 //Single constructor, single field (box)
77 ftd (TyObject ti [(ci, [ty])]) tl = ftd ty tl
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]
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 ";" ""]
92 fmtCons (ci, []) = pure ()
93 fmtCons (ci, [t]) = ftd t False >>| tell [" ", safe ci.gcd_name, ";\n"]
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
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]
105 fmtField :: (String, Type) -> FTMonad
106 fmtField (name, ty) = ftd ty False >>| tell [" ", name, ";\n"]
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, [])
114 typedefgroup :: [Type] -> TDMonad
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
121 printTypeName :: String -> TDMonad
123 = liftT (gets $ maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) o 'Data.Map'.get tname o fst)
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]
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
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]
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"
158 >>| tell ["\t} data;\n};\n"]
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"
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]
172 tydef :: String GenType -> TDMonad
173 tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
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
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, ")"]
188 collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
189 collectArgs t c = [t:c]