structs/GenC.icl

   1 implementation module GenC
   2
   3 import StdEnv, StdGeneric, StdMaybe
   4 import Data.Map => qualified updateAt
   5 import Data.Func, Data.Tuple
   6 import Data.Maybe
   7 import Data.Either
   8 import Data.List => qualified difference, union, find
   9 import Text
  10
  11 import scc
  12
  13 derive bimap Box
  14
  15 potInf :: Box Bool a | gPotInf{|*|} a
  16 potInf = gPotInf{|*|} []
  17
  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]))
  35
  36 :: CType
  37         = CTTypeDef String
  38         | CTEnum [String]
  39         | CTStruct Int [(String, [(String, Bool, String)])]
  40
  41 :: GTSState = {dict :: Map String CType}
  42 instance zero GTSState where zero = {dict=newMap}
  43
  44 toStruct :: Box GTSState a | gToStruct{|*|} a
  45 toStruct = snd $ gToStruct{|*|} zero
  46 generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
  47 :: GTSResult
  48         = GTSType Bool String //ispointer and the name
  49         | GTSUnit
  50         | GTSEither [GTSResult]
  51         | GTSPair [GTSResult]
  52         | GTSError
  53
  54 putst k v st = {st & dict=put k v st.dict}
  55
  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
  64         # (l, Box st) = fl st
  65         # (r, Box st) = fr st
  66         = (case (l, r) of
  67                 (GTSEither l, GTSEither r) = GTSEither (l ++ r)
  68                 (a, GTSEither l) = GTSEither [a:l]
  69                 (l, r) = GTSEither [l, r]
  70         , box st)
  71 gToStruct{|PAIR|} fl _ fr _ st
  72         # (l, Box st) = fl st
  73         # (r, Box st) = fr st
  74         = (case (l, r) of
  75                 (GTSPair l, GTSPair r) = GTSPair (l ++ r)
  76                 (a, GTSPair l) = GTSPair [a:l]
  77                 (l, r) = GTSPair [l, r]
  78         , box st)
  79 import Debug.Trace
  80 gToStruct{|OBJECT of {gtd_name,gtd_arity,gtd_conses,gtd_num_conses}|} f i st
  81         # (Box isPInf) = i []
  82         # ty = GTSType isPInf
  83         = case get gtd_name st.dict of
  84                 Just _ = (GTSType isPInf gtd_name, box st)
  85                 Nothing
  86                         //Newtype
  87                         | gtd_num_conses == 0
  88                                 = case f st of
  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
  95                         =
  96                                 ( GTSType isPInf gtd_name
  97                                 , box $ putst gtd_name
  98                                         (CTStruct gtd_arity $ zipWith ctcons gtd_conses $ map mkccons n) st
  99                                 )
 100         where
 101                 mkty :: GTSResult -> [GTSResult]
 102                 mkty (GTSEither l) = l
 103                 mkty t = [t]
 104
 105                 mkccons :: GTSResult -> [GTSResult]
 106                 mkccons (GTSType pi t) = [GTSType pi t]
 107                 mkccons (GTSPair t) = t
 108                 mkccons _ = []
 109
 110                 ctcons :: GenericConsDescriptor [GTSResult] -> (String, [(String, Bool, String)])
 111                 ctcons gcd cons
 112                         # (_, gcd_name, _, cons, _) = trace_stdout ("\n---\n", gcd.gcd_name, gcd.gcd_type, cons, "\n---\n")
 113                         = (gcd_name, toT cons)
 114                 where
 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)
 120                 Nothing
 121                         # (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st
 122                         = case n of
 123                                 GTSPair l =
 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)
 127
 128 /**
 129  * Given a GTSState, generate typedefinitions
 130  */
 131 toCType :: GTSState -> [String]
 132 toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
 133 where
 134         refs (CTTypeDef s) = [s]
 135         refs (CTEnum _) = []
 136         refs (CTStruct _ cs) = map fst3 (flatten (map snd cs))
 137
 138         proc [] c = c
 139         proc [x] c = ctypedef x (find x m) c
 140         proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts
 141         where
 142                 ts = [(x, find x m)\\x<-xs]
 143                 prototype x c = ["struct ", x, ";\n":c]
 144
 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))
 151                 ["};\n":c] fs
 152                 ]
 153         ctypedef name (CTStruct _ cs) c =
 154                 [ "struct ", name, " {\n"
 155                 : ind 1 ["enum {"
 156                 : enum (map fst cs)
 157                 ["} cons;\n"
 158                 : ind 1 ["union {\n"
 159                 : foldr (uncurry struct)
 160                         (ind 1 ["} data;\n};\n":c])
 161                 cs]]]]
 162
 163         struct name [] c = 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]
 166
 167         field i ty pi name c
 168                 = ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
 169
 170         enum [] c = c
 171         enum [x] c = [x:c]
 172         enum [x:xs] c = [x, ",": enum xs c]
 173
 174 typeName ty m c = [case get ty m of
 175                 Just (CTStruct _ _) = "struct "
 176                 Just (CTEnum _) = "enum "
 177                 _ = ""
 178         , ty:c]
 179
 180 ind n c = [createArray n '\t':c]
 181
 182 uncurry3 f (x,y,z) = f x y z
 183
 184 /**
 185  * Given a GTSState, generate a parser
 186  * @result Function signature
 187  * @result Function
 188  */
 189 toCParser :: GTSState -> ([String], [String])
 190 toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
 191 where
 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
 196                 | i > 0
 197                         = typeName n m [" "
 198                         : pfname n ["(\n"
 199                         : funargs 1
 200                         $ foldr (\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
 205                 ["\n{\n"
 206                 :ind 1 $ typeName n m [" r;\n"
 207                 :funb ty $ ind 1 ["return r;\n}\n":c]]]
 208         funargs i 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, ...)"
 212                 :c]]]
 213
 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"
 219                 :foldr field
 220                 ( ind 1 ["default:\n"
 221                 : ind 2 ["break;\n"
 222                 : ind 1 ["}\n":c]]]) fs]
 223         where
 224                 field (n, []) c = c
 225                 field (n, fs) c =
 226                         ind 1 ["case ", n, ":\n"
 227                         : foldr (sfield 2 ("r.data."+++ n))
 228                         (ind 2 ["break;\n":c]) fs]
 229
 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]]
 233
 234 /**
 235  * Given a GTSState, generate a printer
 236  * @result Function signature
 237  * @result Function
 238  */
 239 toCPrinter :: GTSState -> ([String], [String])
 240 toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m))
 241 where
 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]
 245         funsig n c =
 246                 ["void ":pfname n ["(\n"
 247                 : ind 1 $ typeName n m [" r,\n"
 248                 : ind 1 ["void (*put)(uint8_t))"
 249                 :c]]]]
 250         funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]]
 251
 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"
 258                 :foldr field
 259                 ( ind 1 ["default:\n"
 260                 : ind 2 ["break;\n"
 261                 : ind 1 ["}\n":c]]]) fs]]
 262         where
 263                 field (n, []) c = c
 264                 field (n, fs) c
 265                         = ind 1 ["case ", n, ":\n"
 266                         : foldr (sfield 2 ("r.data."+++ n))
 267                         (ind 2 ["break;\n":c]) fs]
 268
 269         sfield i r (ty, ptr, f) c
 270                 = ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]
 271
 272 toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
 273 toCValue a c = gToCValue{|*|} a c
 274
 275 gToCValue{|Char|} x c = [x:c]
 276 gToCValue{|Int|} x c =
 277         [ toChar (x >> 56)
 278         , toChar (x >> 48)
 279         , toChar (x >> 40)
 280         , toChar (x >> 32)
 281         , toChar (x >> 24)
 282         , toChar (x >> 16)
 283         , toChar (x >> 8)
 284         , toChar 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
 294
 295 fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
 296 fromCValue i = gFromCValue{|*|} i
 297
 298 :: Parser a :== [Char] -> Either FromCValueError (a, [Char])
 299 top :: Parser Char
 300 top = satisfy (\_->True) CVEInputExhausted
 301
 302 satisfy :: (Char -> Bool) FromCValueError -> Parser Char
 303 satisfy f e = \c->case c of
 304         [c:cs]
 305                 | f c = Right (c, cs)
 306                       = Left e
 307         [] = Left CVEInputExhausted
 308
 309 yield :: a -> Parser a
 310 yield a = \c->Right (a, c)
 311
 312 list :: [Parser a] -> Parser [a]
 313 list [] = yield []
 314 list [x:xs] = cons <<$>> x <<*>> list xs
 315
 316 cons x xs = [x:xs]
 317
 318 (<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b
 319 (<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a
 320
 321 (<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b
 322 (<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f
 323
 324 (<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a
 325 (<<|>>) l r = \c->either (\_->r c) Right $ l c
 326
 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
 339
 340 toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
 341 toCFiles b=:(Box fn)
 342         # (padefs, paimp) = toCParser gts
 343         # (prdefs, primp) = toCPrinter gts
 344         =
 345                 ( flatten
 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
 352                         , ["#endif\n"]
 353                         ]
 354                 , flatten
 355                         [["#include \"", fn, ".h\"\n"]
 356                         , paimp
 357                         , primp]
 358                 )
 359 where
 360         guard = {safe c\\c<-:fn +++ ".h"}
 361         safe c
 362                 | not (isAlphanum c) = '_'
 363                 = toUpper c
 364         gts = unBox (cast b)
 365
 366         cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a
 367         cast _ = toStruct