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 Text
   9
  10 import scc
  11
  12 derive bimap Box
  13
  14 potInf :: Box Bool a | gPotInf{|*|} a
  15 potInf = gPotInf{|*|} []
  16
  17 generic gPotInf a :: [String] -> Box Bool a
  18 gPotInf{|Int|} _ = box False
  19 gPotInf{|Bool|} _ = box False
  20 gPotInf{|Char|} _ = box False
  21 gPotInf{|Real|} _ = box False
  22 gPotInf{|World|} _ = box False
  23 gPotInf{|Dynamic|} _ = box False
  24 gPotInf{|c|} _ = box False
  25 gPotInf{|UNIT|} _ = box False
  26 gPotInf{|CONS|} f s = reBox (f s)
  27 gPotInf{|FIELD|} f s = reBox (f s)
  28 gPotInf{|EITHER|} fl fr s = box (unBox (fl s) || unBox (fr s))
  29 gPotInf{|PAIR|} fl fr s = box (unBox (fl s) || unBox (fr s))
  30 gPotInf{|OBJECT of {gtd_name}|} f s
  31         = if (isMember gtd_name s) (box True) (reBox (f [gtd_name:s]))
  32 gPotInf{|RECORD of {grd_name}|} f s
  33         = if (isMember grd_name s) (box True) (reBox (f [grd_name:s]))
  34
  35 :: CType
  36         = CTTypeDef String
  37         | CTEnum [String]
  38         | CTStruct [(String, [(String, Bool, String)])]
  39
  40 :: GTSState = {dict :: Map String CType}
  41 instance zero GTSState where zero = {dict=newMap}
  42
  43 toStruct :: Box GTSState a | gToStruct{|*|} a
  44 toStruct = snd $ gToStruct{|*|} zero
  45 generic gToStruct a | gPotInf a :: GTSState -> (GTSResult, Box GTSState a)
  46 :: GTSResult
  47         = GTSType Bool String //ispointer and the name
  48         | GTSUnit
  49         | GTSEither [GTSResult]
  50         | GTSPair [GTSResult]
  51         | GTSError
  52
  53 putst k v st = {st & dict=put k v st.dict}
  54
  55 gToStruct{|Int|} st  = (GTSType False "uint64_t", box st)
  56 gToStruct{|Bool|} st = (GTSType False "bool", box st)
  57 gToStruct{|Char|} st = (GTSType False "char", box st)
  58 gToStruct{|Real|} st = (GTSType False "double", box st)
  59 gToStruct{|UNIT|} st = (GTSUnit, box st)
  60 gToStruct{|CONS|} f _ st = appSnd reBox $ f st
  61 gToStruct{|FIELD|} f _ st = appSnd reBox $ f st
  62 gToStruct{|EITHER|} fl _ fr _ st
  63         # (l, Box st) = fl st
  64         # (r, Box st) = fr st
  65         = (case (l, r) of
  66                 (GTSEither l, GTSEither r) = GTSEither (l ++ r)
  67                 (a, GTSEither l) = GTSEither [a:l]
  68                 (l, r) = GTSEither [l, r]
  69         , box st)
  70 gToStruct{|PAIR|} fl _ fr _ st
  71         # (l, Box st) = fl st
  72         # (r, Box st) = fr st
  73         = (case (l, r) of
  74                 (GTSPair l, GTSPair r) = GTSPair (l ++ r)
  75                 (a, GTSPair l) = GTSPair [a:l]
  76                 (l, r) = GTSPair [l, r]
  77         , box st)
  78 gToStruct{|OBJECT of {gtd_name,gtd_conses,gtd_num_conses}|} f i st
  79         # (Box isPInf) = i []
  80         # ty = GTSType isPInf
  81         = case get gtd_name st.dict of
  82                 Just _ = (GTSType isPInf gtd_name, box st)
  83                 Nothing
  84                         //Newtype
  85                         | gtd_num_conses == 0
  86                                 = case f st of
  87                                         (GTSType pi n, Box st) = (GTSType pi gtd_name, box $ putst gtd_name (CTTypeDef n) st)
  88                         //If it is just an enumeration, Just the enum
  89                         | and [gcd.gcd_arity == 0\\gcd<-gtd_conses]
  90                                 = (GTSType False gtd_name, box $ putst gtd_name (CTEnum [gcd.gcd_name\\gcd<-gtd_conses]) st)
  91                         //Constructors with data fields
  92                         # (n, Box st) = appFst mkty $ f $ putst gtd_name (CTTypeDef gtd_name) st
  93                         =
  94                                 ( GTSType isPInf gtd_name
  95                                 , box $ putst gtd_name (CTStruct (zip2 [gcd.gcd_name\\gcd<-gtd_conses] (map (toT o mkccons) n))) st
  96                                 )
  97         where
  98                 mkty (GTSEither l) = l
  99                 mkty t = [t]
 100
 101                 mkccons (GTSType pi t) = [GTSType pi t]
 102                 mkccons (GTSPair t) = t
 103                 mkccons _ = []
 104
 105                 toT cons = [(t, pi, "f"+++toString i)\\i<-[0..] & GTSType pi t<-cons]
 106 gToStruct{|RECORD of {grd_name,grd_fields}|} f i st
 107         # (Box isPInf) = i []
 108         = case get grd_name st.dict of
 109                 Just n = (GTSType isPInf grd_name, box st)
 110                 Nothing
 111                         # (n, Box st) = f $ putst grd_name (CTTypeDef grd_name) st
 112                         = case n of
 113                                 GTSPair l =
 114                                         ( GTSType isPInf grd_name
 115                                         , box $ putst grd_name (CTStruct [(grd_name, [(t, pi, gfd)\\GTSType pi t<-l & gfd<-grd_fields])]) st)
 116                                 _ = (GTSError, box st)
 117
 118 /**
 119  * Given a GTSState, generate typedefinitions
 120  */
 121 toCType :: GTSState -> [String]
 122 toCType {dict=m} = foldr proc [] $ scc $ map (appSnd refs) $ toList m
 123 where
 124         refs (CTTypeDef s) = [s]
 125         refs (CTEnum _) = []
 126         refs (CTStruct cs) = map fst3 (flatten (map snd cs))
 127
 128         proc [] c = c
 129         proc [x] c = ctypedef x (find x m) c
 130         proc xs c = foldr (prototype o fst) (foldr (uncurry ctypedef) c ts) ts
 131         where
 132                 ts = [(x, find x m)\\x<-xs]
 133                 prototype x c = ["struct ", x, ";\n":c]
 134
 135         ctypedef :: String CType [String] -> [String]
 136         ctypedef name (CTTypeDef a) c = ["typedef ", a, " ", name, ";\n":c]
 137         ctypedef name (CTEnum a) c = ["enum ", name, " {": enum a ["};\n":c]]
 138         ctypedef name (CTStruct [(_, fs)]) c =
 139                 [ "struct ", name, " {\n"
 140                 : foldr (uncurry3 (field 1))
 141                 ["};\n":c] fs
 142                 ]
 143         ctypedef name (CTStruct cs) c =
 144                 [ "struct ", name, " {\n"
 145                 : ind 1 ["enum {"
 146                 : enum (map fst cs)
 147                 ["} cons;\n"
 148                 : ind 1 ["union {\n"
 149                 : foldr (uncurry struct)
 150                         (ind 1 ["} data;\n};\n":c])
 151                 cs]]]]
 152
 153         struct name [] c = c
 154         struct name [(ty, pi, _)] c = field 2 ty pi name c
 155         struct name fs c = ind 2 ["struct {\n" :foldr (uncurry3 (field 3)) (ind 2 ["} ", name, ";\n":c]) fs]
 156
 157         field i ty pi name c
 158                 = ind i $ typeName ty m [if pi " *" " ", name, ";\n":c]
 159
 160         enum [] c = c
 161         enum [x] c = [x:c]
 162         enum [x:xs] c = [x, ",": enum xs c]
 163
 164 typeName ty m c = [case get ty m of
 165                 Just (CTStruct _) = "struct "
 166                 Just (CTEnum _) = "enum "
 167                 _ = ""
 168         , ty:c]
 169
 170 ind n c = [createArray n '\t':c]
 171
 172 uncurry3 f (x,y,z) = f x y z
 173
 174 /**
 175  * Given a GTSState, generate a parser
 176  * @result Function signature
 177  * @result Function
 178  */
 179 toCParser :: GTSState -> ([String], [String])
 180 toCParser {dict=m} = (funsigs, foldr funbody [] (toList m))
 181 where
 182         funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
 183         pfname n c = ["parse_", n:c]
 184         pfcall n c = pfname n ["(get, alloc, err);":c]
 185         funsig n c
 186                 = typeName n m [" ": pfname n ["(\n"
 187                 : ind 1 ["uint8_t (*get)(void),\n"
 188                 : ind 1 ["void *(*alloc)(size_t),\n"
 189                 : ind 1 ["void (*err)(const char *errmsg, ...))"
 190                 :c]]]]]
 191         funbody (n, ty) c = funsig n
 192                 ["\n{\n"
 193                 :ind 1 $ typeName n m [" r;\n"
 194                 :funb ty $ ind 1 ["return r;\n}\n":c]]]
 195
 196         funb (CTTypeDef a) c = ind 1 ["r = ":pfcall a ["\n":c]]
 197         funb (CTEnum a) c = ind 1 ["r = get()\n":c]
 198         funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs
 199         funb (CTStruct fs) c
 200                 = ind 1 ["switch(r.cons = get()) {\n"
 201                 :foldr field
 202                 ( ind 1 ["default:\n"
 203                 : ind 2 ["break;\n"
 204                 : ind 1 ["}\n":c]]]) fs]
 205         where
 206                 field (n, []) c = c
 207                 field (n, fs) c =
 208                         ind 1 ["case ", n, ":\n"
 209                         : foldr (sfield 2 ("r.data."+++ n))
 210                         (ind 2 ["break;\n":c]) fs]
 211
 212         sfield i r (ty, ptr, f) c
 213                 = (\c->if ptr (ind i [r, ".", f, " = alloc(sizeof(":typeName ty m ["));\n":c]]) c)
 214                 $ ind i [if ptr "*" "", r, ".", f, " = ":pfcall ty ["\n":c]]
 215
 216 /**
 217  * Given a GTSState, generate a printer
 218  * @result Function signature
 219  * @result Function
 220  */
 221 toCPrinter :: GTSState -> ([String], [String])
 222 toCPrinter {dict=m} = (funsigs, foldr funbody [] (toList m))
 223 where
 224         funsigs = [concat $ funsig n [";\n"]\\(n, _)<-toList m]
 225         pfname n c = ["print_", n:c]
 226         pfcall r n c = pfname n ["(", r, ", put);":c]
 227         funsig n c =
 228                 ["void ":pfname n ["(\n"
 229                 : ind 1 $ typeName n m [" r,\n"
 230                 : ind 1 ["void (*put)(uint8_t))"
 231                 :c]]]]
 232         funbody (n, ty) c = funsig n ["\n{\n":funb ty ["}\n":c]]
 233
 234         funb (CTTypeDef a) c = ind 1 $ pfcall "r" a ["\n":c]
 235         funb (CTEnum a) c = ind 1 ["put(r)\n":c]
 236         funb (CTStruct [(_, fs)]) c = foldr (sfield 1 "r") c fs
 237         funb (CTStruct fs) c =
 238                 ind 1 ["put(r.cons);\n"
 239                 : ind 1 ["switch(r.cons) {\n"
 240                 :foldr field
 241                 ( ind 1 ["default:\n"
 242                 : ind 2 ["break;\n"
 243                 : ind 1 ["}\n":c]]]) fs]]
 244         where
 245                 field (n, []) c = c
 246                 field (n, fs) c
 247                         = ind 1 ["case ", n, ":\n"
 248                         : foldr (sfield 2 ("r.data."+++ n))
 249                         (ind 2 ["break;\n":c]) fs]
 250
 251         sfield i r (ty, ptr, f) c
 252                 = ind i $ pfcall (concat [if ptr "*" "", r, ".", f]) ty ["\n":c]
 253
 254 toCValue :: a [Char] -> [Char] | gToCValue{|*|} a
 255 toCValue a c = gToCValue{|*|} a c
 256
 257 gToCValue{|Char|} x c = [x:c]
 258 gToCValue{|Int|} x c =
 259         [ toChar (x >> 56)
 260         , toChar (x >> 48)
 261         , toChar (x >> 40)
 262         , toChar (x >> 32)
 263         , toChar (x >> 24)
 264         , toChar (x >> 16)
 265         , toChar (x >> 8)
 266         , toChar x:c]
 267 gToCValue{|Bool|} x c = [toChar (if x 1 0):c]
 268 gToCValue{|UNIT|} x c = c
 269 gToCValue{|EITHER|} l _ (LEFT x) c = l x c
 270 gToCValue{|EITHER|} _ r (RIGHT x) c = r x c
 271 gToCValue{|PAIR|} l r (PAIR x y) c = l x $ r y c
 272 gToCValue{|CONS of {gcd_index}|} f (CONS x) c = [toChar gcd_index:f x c]
 273 gToCValue{|FIELD|} f (FIELD x) c = f x c
 274 gToCValue{|RECORD|} f (RECORD x) c = f x c
 275 gToCValue{|OBJECT|} f (OBJECT x) c = f x c
 276
 277 fromCValue :: [Char] -> Either FromCValueError (a, [Char]) | gFromCValue{|*|} a
 278 fromCValue i = gFromCValue{|*|} i
 279
 280 :: Parser a :== [Char] -> Either FromCValueError (a, [Char])
 281 top :: Parser Char
 282 top = satisfy (\_->True) CVEInputExhausted
 283
 284 satisfy :: (Char -> Bool) FromCValueError -> Parser Char
 285 satisfy f e = \c->case c of
 286         [c:cs]
 287                 | f c = Right (c, cs)
 288                       = Left e
 289         [] = Left CVEInputExhausted
 290
 291 yield :: a -> Parser a
 292 yield a = \c->Right (a, c)
 293
 294 list :: [Parser a] -> Parser [a]
 295 list [] = yield []
 296 list [x:xs] = cons <<$>> x <<*>> list xs
 297
 298 cons x xs = [x:xs]
 299
 300 (<<$>>) infixl 4 :: (a -> b) (Parser a) -> Parser b
 301 (<<$>>) f a = fmap (\(a, b)->(f a, b)) <$> a
 302
 303 (<<*>>) infixl 4 :: (Parser (a -> b)) (Parser a) -> Parser b
 304 (<<*>>) f a = either Left (\(fa, c)->(fa <<$>> a) c) o f
 305
 306 (<<|>>) infixr 4 :: (Parser a) (Parser a) -> Parser a
 307 (<<|>>) l r = \c->either (\_->r c) Right $ l c
 308
 309 int b = sum <<$>> list [(\x->toInt x << (i*8)) <<$>> top \\i<-[b-1,b-2..0]]
 310 gFromCValue{|Char|} = top
 311 gFromCValue{|Int|} = fromInt <<$>> int 8
 312 gFromCValue{|Bool|} = ((==) '\1') <<$>> top
 313 gFromCValue{|UNIT|} = yield UNIT
 314 gFromCValue{|EITHER|} l r = (LEFT <<$>> l) <<|>> (RIGHT <<$>> r)
 315 gFromCValue{|PAIR|} l r = PAIR <<$>> l <<*>> r
 316 gFromCValue{|CONS of {gcd_index}|} f
 317         = (\x->CONS) <<$>> satisfy ((==)(toChar gcd_index)) CVEUnknownConstructor <<*>> f
 318 gFromCValue{|FIELD|} f = (\x->FIELD x) <<$>> f
 319 gFromCValue{|RECORD|} f = RECORD <<$>> f
 320 gFromCValue{|OBJECT|} f = (\x->OBJECT x) <<$>> f
 321
 322 toCFiles :: (Box String a) -> ([String], [String]) | gToStruct{|*|} a
 323 toCFiles b=:(Box fn)
 324         # (padefs, paimp) = toCParser gts
 325         # (prdefs, primp) = toCPrinter gts
 326         =
 327                 ( flatten
 328                         [["#ifndef ", guard, "\n"
 329                         , "#define ", guard, "\n"
 330                         , "#include <stdint.h>\n"
 331                         , "#include <stddef.h>\n"
 332                         , "#include <stdarg.h>\n"]
 333                         , toCType gts, padefs, prdefs
 334                         , ["#endif\n"]
 335                         ]
 336                 , flatten
 337                         [["#include \"", fn, ".h\"\n"]
 338                         , paimp
 339                         , primp]
 340                 )
 341 where
 342         guard = {safe c\\c<-:fn +++ ".h"}
 343         safe c
 344                 | not (isAlphanum c) = '_'
 345                 = toUpper c
 346         gts = unBox (cast b)
 347
 348         cast :: (Box x a) -> (Box GTSState a) | gToStruct{|*|} a
 349         cast _ = toStruct