From: Mart Lubbers Date: Fri, 4 Sep 2020 14:11:44 +0000 (+0200) Subject: geg X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=6201af433af465129ebe27f5753306036391f47d;p=clean-tests.git geg --- diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl index de08c75..7f751da 100644 --- a/gengen/Data/GenType.dcl +++ b/gengen/Data/GenType.dcl @@ -65,6 +65,11 @@ gTypeToType :: GType -> Type */ typeName :: Type -> String +/** + * Gives the genType for a type + */ +typeGenType :: Type -> GenType + /** * Predicate whether the outer type is a builtin type */ diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl index a391391..553dac5 100644 --- a/gengen/Data/GenType.icl +++ b/gengen/Data/GenType.icl @@ -263,6 +263,21 @@ typeName (TyNewType i _ _) = i.gtd_name typeName (TyObject i _) = i.gtd_name typeName (TyRecord i _) = i.grd_name +typeGenType :: Type -> GenType +typeGenType (TyBasic a) = GenTypeCons $ toString a +typeGenType (TyRef a) = GenTypeCons $ toString a +typeGenType (TyArrow l r) = GenTypeArrow (typeGenType l) (typeGenType r) +typeGenType (TyArray s a) = GenTypeApp (GenTypeCons (toString s)) (typeGenType a) +typeGenType (TyUList s a) = GenTypeApp (GenTypeCons (toString s)) (typeGenType a) +typeGenType (TyUMaybe a) = GenTypeApp (GenTypeCons "_#Maybe") (typeGenType a) +typeGenType (TyNewType _ _ a) = abort "typeGenType for newtypes not yet implemented\n" +typeGenType (TyObject i _) = gent i.gtd_arity (GenTypeCons i.gtd_name) +where + gent 0 t = t + gent n t = gent (dec n) (GenTypeApp t (GenTypeVar n)) + +typeGenType (TyRecord i _) = i.grd_type + instance isBuiltin String where isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_] diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl index b29d8a5..c0ce75d 100644 --- a/gengen/Data/GenType/CParser.icl +++ b/gengen/Data/GenType/CParser.icl @@ -32,24 +32,28 @@ parsefun t = "parse_" +++ safe (typeName t) (<.>) 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" @@ -102,21 +106,35 @@ where :: 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 @@ -127,36 +145,36 @@ where 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 @@ -165,7 +183,7 @@ 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 @@ -183,12 +201,3 @@ where 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)] diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl index 8ff9341..4a5a63a 100644 --- a/gengen/Data/GenType/CType.icl +++ b/gengen/Data/GenType/CType.icl @@ -121,38 +121,34 @@ where = 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"] @@ -166,15 +162,15 @@ where >>| 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] diff --git a/gengen/test.icl b/gengen/test.icl index 7664753..66ef797 100644 --- a/gengen/test.icl +++ b/gengen/test.icl @@ -53,7 +53,8 @@ includes = "#include \n#include \n" 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 @@ -62,7 +63,8 @@ genFiles bn t w <<< "#define " <<< toUpperCase bn <<< "_H\n" <<< includes # c = c <<< includes - <<< "#include \"" <<< (bn <.> "h") <<< "\"\n" + <<< "#include \n" + <<< "#include \"" <<< (bn <.> "h") <<< "\"\n\n" # h = case typedefs tds of Left e = abort ("Couldn't generate typedef: " +++ e) Right d = foldl (<<<) h d @@ -87,7 +89,7 @@ genFilesFlat bn t w <<< "#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 @@ -105,6 +107,9 @@ Start w = foldr ($) w [ 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 @@ -120,6 +125,15 @@ where 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]])