(<.>) infixr 6
(<.>) a b = a +++ "." +++ b
+(<->) infixr 6
+(<->) a b = a +++ "->" +++ b
+
result r op s = indent [r, " ", op, " ", s, ";\n"]
assign r s = result r "=" s
parsename s = "parse_" +++ safe s
tail = ["\treturn r;\n}\n"]
-parsenameimp t def = def t [" {\n\t", prefix t, safe (typeName t), " r;\n\n"]
+parsenameimp t c def = def t [" {\n\t":ctypename t [" ", c, "\n\n"]]
+ctypename t c = [prefix t, safe (typeName t):c]
/**
* Generate a single parser for a type.
* This does not terminate for a recursive type
*/
flatParser :: Type -> Either String ([String], [String])
-flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
+flatParser t = tuple (parsedef [";\n"]) <$> runReaderT (execWriterT (tell (parsenameimp t "r;" \_->parsedef) >>| fpd t True "r" >>| tell tail)) 1
where
- parsedef c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void))":c]
+ parsedef c = ctypename t [" ", parsefun t, "(uint8_t (*get)())":c]
fpd :: Type Bool String -> FPMonad
fpd (TyRef s) tl r = assign r (parsename s)
- fpd (TyBasic t) tl r
+ fpd (TyBasic t) tl r
| tl = pure ()
= case t of
BTInt = assign r "(int64_t)get()<<54"
:: TPMonad :== WriterT [String] (StateT TPState (Either String)) ()
:: TPState :== 'Data.Map'.Map String (String, Bool)
parsers :: [[Type]] -> Either String ([String], [String])
-parsers ts = tuple ([""]) <$> evalStateT (execWriterT (mapM_ parsergroup ts >>| tell tail)) 'Data.Map'.newMap
+parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap
where
- parsedef t c = [prefix t, safe (typeName t), " ", parsefun t, "(uint8_t (*get)(void)",pd t, ")":c]
+ parsedefs :: ([[Type]] -> [String])
+ parsedefs = foldr (\t c->parsedef t [";\n":c]) [] o flatten
+
+ parsedef :: Type [String] -> [String]
+ parsedef t c = ctypename t [" *", parsefun t, "(uint8_t (*get)()",pd t, ")":c]
where
- pd (TyUList _ _) = ", void *parse_0(uint8_t (*)(void))"
- pd (TyUMaybe _) = ", void *parse_0(uint8_t (*)(void))"
- pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)(void))"\\i<-[0..gtd.gtd_arity-1]]
- pd (TyRecord grd _) = abort "not implemented yet\n"
- pd (TyNewType _ _ _) = abort "not implemented yet\n"
- pd _ = abort "not implemented yet\n"
+ pd (TyBasic s) = ""
+ pd (TyUList _ _) = ", void *parse_0(uint8_t (*get)())"
+ pd (TyUMaybe _) = ", void *parse_0(uint8_t (*get)())"
+ pd (TyObject gtd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..gtd.gtd_arity-1]]
+ pd (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity grd.grd_type-1]]
+// pd (TyNewType _ _ _) = abort "not implemented yet\n"
+ pd t = abort $ "not implemented yet: " +++ toString t +++ "\n"
+
+ recordArity :: GenType -> Int
+ recordArity (GenTypeCons _) = 0
+ recordArity (GenTypeVar _) = 0
+ recordArity (GenTypeApp _ _) = 0
+ recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 0
+ recordArity (GenTypeArrow l r) = inc $ recordArity r
parsergroup :: [Type] -> TPMonad
parsergroup ts
= liftT (modify ('Data.Map'.putList [(typeName ty, (prefix ty, True))\\ty<-ts]))
- >>| mapM_ (\t->tell (parsenameimp t parsedef) >>| parser t >>| tell ["\n"]) ts
+ >>| mapM_ (\t->tell (parsenameimp t (declaration t) parsedef) >>| parser t >>| tell ["\n":tail]) ts
+ where
+ declaration t = concat ["*r = (":ctypename t [" *)malloc(sizeof(":ctypename t ["));"]]]
printTypeName :: String -> TPMonad
printTypeName tname
parser t=:(TyRef s) = tell [parsefun t]
parser (TyBasic t)
= case t of
- BTInt = tell ["\tr = (int64_t)get()<<54;\n"
- , "\tr += (int64_t)get()<<48;\n"
- , "\tr += (int64_t)get()<<40;\n"
- , "\tr += (int64_t)get()<<32;\n"
- , "\tr += (int64_t)get()<<24;\n"
- , "\tr += (int64_t)get()<<16;\n"
- , "\tr += (int64_t)get()<<8;\n"
- , "\tr += (int64_t)get();\n"]
- BTChar = tell ["\tr = (char)get();\n"]
- BTReal = tell ["\tr = double;\n"]
- BTBool = tell ["\tr = (bool)get();\n"]
+ BTInt = tell ["\t*r = (Int)get()<<54;\n"
+ , "\t*r += (Int)get()<<48;\n"
+ , "\t*r += (Int)get()<<40;\n"
+ , "\t*r += (Int)get()<<32;\n"
+ , "\t*r += (Int)get()<<24;\n"
+ , "\t*r += (Int)get()<<16;\n"
+ , "\t*r += (Int)get()<<8;\n"
+ , "\t*r += (Int)get();\n"]
+ BTChar = tell ["\t*r = (Char)get();\n"]
+ BTBool = tell ["\t*r = (Bool)get();\n"]
+ //BTReal = tell ["\t*r = double;\n"]
t = fail $ "parser: there is no basic type for " +++ toString t
parser (TyArrow _ _) = fail $ "parser: function cannot be serialized"
parser (TyNewType ti ci a) = parser a
parser (TyArray _ _) = fail $ "parser: arrays are not supported since they require dynamic memory"
parser (TyRecord ti fs)
- = fmtFields 1 ti.grd_type ["r" <.> fi.gfd_name\\(fi, _)<-fs]
+ = fmtFields 1 ti.grd_type ["r" <-> fi.gfd_name\\(fi, _)<-fs]
//Enumeration
parser (TyObject ti fs)
| and [t =: [] \\ (_, t)<-fs]
- = tell ["\tr = (" +++ consName ti +++ ") get();\n"]
+ = tell ["\t*r = (", consName ti, ") get();\n"]
//Single constructor, single field (box)
- parser (TyObject ti [(ci, [ty])]) = tell ["\tr = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
+ parser (TyObject ti [(ci, [ty])]) = tell ["\t*r = "] >>| fmtField ci.gcd_type >>| tell [");\n"]
//Single constructor
parser t=:(TyObject ti [(ci, ts)])
- = fmtFields 1 ci.gcd_type ["r.f" +++ toString i\\i<-indexList ts]
+ = fmtFields 1 ci.gcd_type ["r" <-> "f" +++ toString i\\i<-indexList ts]
//Complex adt
parser (TyObject ti fs)
- = tell ["\tr.cons = (", consName ti, ") get();\n"]
- >>| tell ["\tswitch(r.cons) {\n"]
+ = tell ["\tr" <-> "cons = (", consName ti, ") get();\n"]
+ >>| tell ["\tswitch(r" <-> "cons) {\n"]
>>| mapM_ fmtCons fs
>>| tell ["\t}\n"]
where
>>| fmtFields 2 ci.gcd_type [cs i\\i<-[0..] & ty<-ts]
>>| tell ["\t\tbreak;\n"]
where
- cs i = "r.data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" (".f" +++ toString i)
+ cs i = "r" <-> "data" <.> safe ci.gcd_name +++ if (ts=:[_]) "" ("" <-> "f" +++ toString i)
parser t = fail $ "parser: unsupported type " +++ toString t
fmtFields :: Int GenType [String] -> TPMonad
where
ufold (GenTypeApp l r) = [l:ufold r]
ufold t = [t]
-
-// fmtField x t=:(GenTypeArrow _ _)
-// = mapM (fmap (concat o snd) o listen o fmtField "") (collectArgs t [])
-// >>= \[r:as]->tell [r, " (*",x,")(",join ", " as, ")"]
-// where
-// collectArgs (GenTypeArrow l r) c = collectArgs r (c ++ [l])
-// collectArgs t c = [t:c]
-// | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
-// | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
= liftT (gets (\s->maybe [safe tname, " "] (\(p, b)->[p, safe tname, if b " *" " "]) $ 'Data.Map'.get tname s))
>>= tell
- header :: Type [String] -> WriterT [String] m () | Monad m
- header t c = tell ["// ", toString (replaceBuiltins t), "\n":c]
-
typedef :: Type -> TDMonad
typedef (TyRef s) = printTypeName s
typedef (TyBasic t) = case t of
- BTInt = printTypeName "int64_t"
- BTChar = printTypeName "char"
- BTReal = printTypeName "double"
- BTBool = printTypeName "bool"
+ BTInt = tell ["typedef uint64_t Int;\n"]
+ BTChar = tell ["typedef char Char;\n"]
+ BTReal = tell ["typedef double Real;\n"]
+ BTBool = tell ["typedef bool Bool;\n"]
t = fail $ "basic type: " +++ toString t +++ " not implemented"
typedef (TyArray _ a) = tell ["*"] >>| typedef a
typedef t=:(TyNewType ti ci a)
- = header t []
- >>| tydef ti.gtd_name ci.gcd_type
+ = tydef ti.gtd_name ci.gcd_type
typedef t=:(TyRecord ti fs)
- = header t ["struct ", safe ti.grd_name, " {\n"]
+ = tell ["struct ", safe ti.grd_name, " {\n"]
>>| fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs]
>>| tell ["};\n"]
//Enumeration
typedef t=:(TyObject ti fs)
- | and [t =: [] \\ (_, t)<-fs] = header t
+ | and [t =: [] \\ (_, t)<-fs] = tell
[consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"]
//Single constructor, single field (box)
- typedef t=:(TyObject ti [(ci, [ty])]) = header t [] >>| tydef ti.gtd_name ci.gcd_type
+ typedef t=:(TyObject ti [(ci, [ty])]) = tydef ti.gtd_name ci.gcd_type
//Single constructor
typedef t=:(TyObject ti [(ci, ts)])
- = header t ["struct ", safe ti.gtd_name, " {\n"]
+ = tell ["struct ", safe ti.gtd_name, " {\n"]
>>| fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
>>| tell ["};\n"]
//Complex adt
- typedef t=:(TyObject ti fs) = header t
+ typedef t=:(TyObject ti fs) = tell
["struct ", safe ti.gtd_name, " {\n"
, "\t", consName ti, " {", 'Text'.join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n"
, "\tstruct {\n"]
>>| fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
>>| tell ["\t\t} ", safe ci.gcd_name, ";\n"]
typedef t = fail $ toString t +++ " not implemented"
-
+
tydef :: String GenType -> TDMonad
tydef name (GenTypeArrow l r) = tell ["typedef "] >>| fmtField "" l >>| tell [safe name,";\n"]
-
+
fmtFields :: Int GenType [String] -> TDMonad
fmtFields i _ [] = pure ()
fmtFields i (GenTypeArrow l r) [x:xs]
= tell [createArray i '\t'] >>| fmtField x l >>| tell [";\n"] >>| fmtFields i r xs
-
+
fmtField :: String GenType -> TDMonad
fmtField x (GenTypeCons a) = printTypeName a >>| tell [x]
fmtField x (GenTypeVar a) = tell ["void *",x]
genFiles :: String (Box GType a) *World -> *World | gType{|*|} a
genFiles bn t w
- # tds = map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+// # tds = map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
+ # tds = map (map gTypeToType) $ flattenGType $ unBox t
# (ok, h, w) = fopen (bn <.> "h") FWriteText w
| not ok = abort ("Couldn't open: " +++ bn <.> "h")
# (ok, c, w) = fopen (bn <.> "c") FWriteText w
<<< "#define " <<< toUpperCase bn <<< "_H\n"
<<< includes
# c = c <<< includes
- <<< "#include \"" <<< (bn <.> "h") <<< "\"\n"
+ <<< "#include <stdlib.h>\n"
+ <<< "#include \"" <<< (bn <.> "h") <<< "\"\n\n"
# h = case typedefs tds of
Left e = abort ("Couldn't generate typedef: " +++ e)
Right d = foldl (<<<) h d
<<< "#define " <<< toUpperCase bn <<< "_H\n"
<<< includes
# c = c <<< includes
- <<< "#include \"" <<< (bn <.> "h") <<< "\"\n"
+ <<< "#include \"" <<< (bn <.> "h") <<< "\"\n\n"
# h = case flatTypedef ty of
Left e = abort ("Couldn't generate typedef: " +++ e)
Right d = foldl (<<<) h d
[ genFiles "maybeInt" maybeInt
, genFiles "eitherIntChar" eitherIntChar
, genFiles "eitherIntMaybeChar" eitherIntMaybeChar
+ , genFiles "cp" cp
+ , genFiles "raint" raInt
+ , genFiles "lmint" lmInt
]
// ( flatTypedef $ gTypeToType $ unBox t
// , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t
eitherIntMaybeChar :: Box GType (Either Int (?Char))
eitherIntMaybeChar = gType{|*|}
+ cp :: Box GType CP
+ cp = gType{|*|}
+
+ raInt :: Box GType (RA Int)
+ raInt = gType{|*|}
+
+ lmInt :: Box GType [?Int]
+ lmInt = gType{|*|}
+
//Start = typedefs //$ (\x->[[gTypeToType x]])
// $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
// $ (\x->[[x]])
repositories / clean-tests.git / commitdiff