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