1 implementation module GenC
3 import StdEnv, StdGeneric, StdMaybe
4 import Data.Map => qualified updateAt
5 import Data.Func, Data.Tuple
8 import Data.List => qualified difference, union, find
15 potInf :: Box Bool a | gPotInf{|*|} a
16 potInf = gPotInf{|*|} []
18 generic gPotInf a :: [String] -> Box Bool a
19 gPotInf{|Int|} _ = box False
20 gPotInf{|Bool|} _ = box False
21 gPotInf{|Char|} _ = box False
22 gPotInf{|Real|} _ = box False
23 gPotInf{|World|} _ = box False
24 gPotInf{|Dynamic|} _ = box False
25 gPotInf{|c|} _ = box False
26 gPotInf{|UNIT|} _ = box False
27 gPotInf{|CONS|} f s = reBox (f s)
28 gPotInf{|FIELD|} f s = reBox (f s)
29 gPotInf{|EITHER|} fl fr s = box (unBox (fl s) || unBox (fr s))
30 gPotInf{|PAIR|} fl fr s = box (unBox (fl s) || unBox (fr s))
31 gPotInf{|OBJECT of {gtd_name}|} f s
32 = if (isMember gtd_name s) (box True) (reBox (f [gtd_name:s]))
33 gPotInf{|RECORD of {grd_name}|} f s
34 = if (isMember grd_name s) (box True) (reBox (f [grd_name:s]))
39 | CTStruct Int [(String, [(String, Bool, String)])]
41 :: GTSState = {dict :: Map String CType}
42 instance zero GTSState where zero = {dict=newMap}
44 toStruct :: Box GTSState a | gToStruct{|*|} a
45 toStruct = snd $ gToStruct{|*|} zero
46 generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
48 = GTSType Bool String //ispointer and the name
50 | GTSEither [GTSResult]
54 putst k v st = {st & dict=put k v st.dict}
56 gToStruct{|Int|} st = (GTSType False "uint64_t", box st)
57 gToStruct{|Bool|} st = (GTSType False "bool", box st)
58 gToStruct{|Char|} st = (GTSType False "char", box st)
59 gToStruct{|Real|} st = (GTSType False "double", box st)
60 gToStruct{|UNIT|} st = (GTSUnit, box st)
61 gToStruct{|CONS|} f _ st = appSnd reBox $ f st
62 gToStruct{|FIELD|} f _ st = appSnd reBox $ f st
63 gToStruct{|EITHER|} fl _ fr _ st
67 (GTSEither l, GTSEither r) = GTSEither (l ++ r)
68 (a, GTSEither l) = GTSEither [a:l]
69 (l, r) = GTSEither [l, r]
71 gToStruct{|PAIR|} fl _ fr _ st
75 (GTSPair l, GTSPair r) = GTSPair (l ++ r)
76 (a, GTSPair l) = GTSPair [a:l]
77 (l, r) = GTSPair [l, r]
80 gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
83 = case get gtd_name st.dict of
84 Just _ = (GTSType isPInf gtd_name, box st)
89 (GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st)
90 //If it is just an enumeration, Just the enum
91 | and [gcd.gcd_arity == 0\\gcd<-gtd_conses]
92 = (GTSType False gtd_name, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
93 //Constructors with data fields
94 # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
96 ( GTSType isPInf gtd_name
97 , box $ putst gtd_name
98 (CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
101 mkty :: GTSResult -> [GTSResult]
102 mkty (GTSEither l) = l
105 mkccons :: GTSResult -> [GTSResult]
106 mkccons (GTSType pi t) = [GTSType pi t]
107 mkccons (GTSPair t) = t
110 ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
112 # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
113 = (gcd_name, toT cons)
115 toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
116 gToStruct{|RECORD of {grd_arity,grd_name,grd_fields}|} f i st
117 # (Box isPInf) = i []
118 = case get grd_name st.dict of
119 Just n = (GTSType isPInf grd_name, box st)
121 # (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st
124 ( GTSType isPInf grd_name
125 , box $ putst grd_name (CTStruct grd_arity [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
126 _ = (GTSError, box st)
129 * Given a GTSState, generate typedefinitions
131 toCType :: GTSState -> [String]
132 toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
134 refs (CTTypeDef s) = [s]
136 refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
139 proc [x] c = ctypedef x (find x m) c
140 proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts
142 ts = [(x, find x m)\\x<-xs]
143 prototype x c = ["struct ", x, ";\n":c]
145 ctypedef :: String CType [String] -> [String]
146 ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c]
147 ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
148 ctypedef name (CTStruct _ [(_, fs)]) c =
149 [ "struct ", name, " {\n"
150 : foldr (uncurry3 (field 1))
153 ctypedef name (CTStruct _ cs) c =
154 [ "struct ", name, " {\n"
159 : foldr (uncurry struct)
160 (ind 1 ["} data;\n};\n":c])
164 struct name [(ty, pi, _)] c = field 2 ty pi name c
165 struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs]
168 = ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
172 enum [x:xs] c = [x, ",": enum xs c]
174 typeName ty m c = [case get ty m of
175 Just (CTStruct _ _) = "struct "
176 Just (CTEnum _) = "enum "
180 ind n c = [createArray n '\t':c]
182 uncurry3 f (x,y,z) = f x y z
185 * Given a GTSState, generate a parser
186 * @result Function signature
189 toCParser :: GTSState -> ([String], [String])
190 toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
192 funsigs = foldr (uncurry funsig) [";\n"] $ toList m
193 pfname n c = ["parse_", n:c]
194 pfcall n c = pfname n ["(get, alloc, err);":c]
195 funsig n (CTStruct i _) c
201 [",\n":ind 1 ["void *(*parse_", toString i, ")(\n"
202 : funargs 2 [")":c]]]) [")":c] [0..i-1]]]
203 funsig n _ c = typeName n m [" ": pfname n ["(\n":funargs 1 [")":c]]]
204 funbody (n, ty) c = funsig n ty
206 :ind 1 $ typeName n m [" r;\n"
207 :funb ty $ ind 1 ["return r;\n}\n":c]]]
209 = ind i ["uint8_t (*get)(void),\n"
210 : ind i ["void *(*alloc)(size_t size),\n"
211 : ind i ["void (*err)(const char *errmsg, ...)"
214 funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]]
215 funb (CTEnum a) c = ind 1 ["r = get()\n":c]
216 funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
217 funb (CTStruct _ fs) c
218 = ind 1 ["switch(r.cons = get()) {\n"
220 ( ind 1 ["default:\n"
222 : ind 1 ["}\n":c]]]) fs]
226 ind 1 ["case ", n, ":\n"
227 : foldr (sfield 2 ("r.data."+++ n))
228 (ind 2 ["break;\n":c]) fs]
230 sfield i r (ty, ptr, f) c
231 = (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c)
232 $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty ["\n":c]]
235 * Given a GTSState, generate a printer
236 * @result Function signature
239 toCPrinter :: GTSState -> ([String], [String])
240 toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m))
242 funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
243 pfname n c = ["print_", n:c]
244 pfcall r n c = pfname n ["(", r, ", put);":c]
246 ["void ":pfname n ["(\n"
247 : ind 1 $ typeName n m [" r,\n"
248 : ind 1 ["void (*put)(uint8_t))"
250 funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]]
252 funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c]
253 funb (CTEnum a) c = ind 1 ["put(r)\n":c]
254 funb (CTStruct _ [(_, fs)]) c = foldr (sfield 1 "r") c fs
255 funb (CTStruct _ fs) c =
256 ind 1 ["put(r.cons);\n"
257 : ind 1 ["switch(r.cons) {\n"
259 ( ind 1 ["default:\n"
261 : ind 1 ["}\n":c]]]) fs]]
265 = ind 1 ["case ", n, ":\n"
266 : foldr (sfield 2 ("r.data."+++ n))
267 (ind 2 ["break;\n":c]) fs]
269 sfield i r (ty, ptr, f) c
270 = ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]
272 toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
273 toCValue a c = gToCValue{|*|} a c
275 gToCValue{|Char|} x c = [x:c]
276 gToCValue{|Int|} x c =
285 gToCValue{|Bool|} x c = [toChar (if x 1 0):c]
286 gToCValue{|UNIT|} x c = c
287 gToCValue{|EITHER|} l _ (LEFT x) c = l x c
288 gToCValue{|EITHER|} _ r (RIGHT x) c = r x c
289 gToCValue{|PAIR|} l r (PAIR x y) c = l x $ r y c
290 gToCValue{|CONS of {gcd_index}|} f (CONS x) c = [toChar gcd_index:f x c]
291 gToCValue{|FIELD|} f (FIELD x) c = f x c
292 gToCValue{|RECORD|} f (RECORD x) c = f x c
293 gToCValue{|OBJECT|} f (OBJECT x) c = f x c
295 fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
296 fromCValue i = gFromCValue{|*|} i
298 :: Parser a :== [Char] -> Either FromCValueError (a, [Char])
300 top = satisfy (\_->True) CVEInputExhausted
302 satisfy :: (Char -> Bool) FromCValueError -> Parser Char
303 satisfy f e = \c->case c of
305 | f c = Right (c, cs)
307 [] = Left CVEInputExhausted
309 yield :: a -> Parser a
310 yield a = \c->Right (a, c)
312 list :: [Parser a] -> Parser [a]
314 list [x:xs] = cons <<$>> x <<*>> list xs
318 (<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b
319 (<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a
321 (<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b
322 (<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f
324 (<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a
325 (<<|>>) l r = \c->either (\_->r c) Right $ l c
327 int b = sum <<$>> list [(\x->toInt x << (i*8)) <<$>> top \\i<-[b-1,b-2..0]]
328 gFromCValue{|Char|} = top
329 gFromCValue{|Int|} = fromInt <<$>> int 8
330 gFromCValue{|Bool|} = ((==) '\1') <<$>> top
331 gFromCValue{|UNIT|} = yield UNIT
332 gFromCValue{|EITHER|} l r = (LEFT <<$>> l) <<|>> (RIGHT <<$>> r)
333 gFromCValue{|PAIR|} l r = PAIR <<$>> l <<*>> r
334 gFromCValue{|CONS of {gcd_index}|} f
335 = (\x->CONS) <<$>> satisfy ((==)(toChar gcd_index)) CVEUnknownConstructor <<*>> f
336 gFromCValue{|FIELD|} f = (\x->FIELD x) <<$>> f
337 gFromCValue{|RECORD|} f = RECORD <<$>> f
338 gFromCValue{|OBJECT|} f = (\x->OBJECT x) <<$>> f
340 toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
342 # (padefs, paimp) = toCParser gts
343 # (prdefs, primp) = toCPrinter gts
346 [["#ifndef ", guard, "\n"
347 , "#define ", guard, "\n"
348 , "#include <stdint.h>\n"
349 , "#include <stddef.h>\n"
350 , "#include <stdarg.h>\n"]
351 , toCType gts, padefs, prdefs
355 [["#include \"", fn, ".h\"\n"]
360 guard = {safe c\\c<-:fn +++ ".h"}
362 | not (isAlphanum c) = '_'
366 cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a