From aaa63abaeb98d48d01ee1c61f4463ce2e42ec454 Mon Sep 17 00:00:00 2001 From: Mart Lubbers Date: Wed, 22 Jul 2020 10:23:09 +0200 Subject: [PATCH] . --- gengen/Data/GenType/CType.dcl | 6 +++ gengen/Data/GenType/CType.icl | 85 +++++++++++++++++++++++++++++------ gengen/test.icl | 20 +++++---- 3 files changed, 89 insertions(+), 22 deletions(-) diff --git a/gengen/Data/GenType/CType.dcl b/gengen/Data/GenType/CType.dcl index b79c58e..6efad22 100644 --- a/gengen/Data/GenType/CType.dcl +++ b/gengen/Data/GenType/CType.dcl @@ -7,3 +7,9 @@ from Data.GenType import :: Type * generate typedefs for the types grouped by strongly connected components */ typedefs :: [[Type]] -> Either String [String] + +/** + * Generate a single typedef for a type. + * This does not terminate for recursive types + */ +flatTypedef :: Type -> Either String [String] diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl index 3b61d0d..538ce9a 100644 --- a/gengen/Data/GenType/CType.icl +++ b/gengen/Data/GenType/CType.icl @@ -15,6 +15,62 @@ import StdEnv import Data.GenType import Text +flatTypedef :: Type -> Either String [String] +flatTypedef t = case ftd t 0 [] of + [] = Left ("Unable to flatTypedef: " +++ toString t) + c = Right c +where + indent i c = [createArray i '\t':c] + + ftd :: Type Int [String] -> [String] + ftd (TyRef s) i c = indent i [s:c] + ftd (TyBasic t) i c = case t of + BTInt = indent i ["int64_t":c] + BTChar = indent i ["char":c] + BTReal = indent i ["double":c] + BTBool = indent i ["bool":c] + t = [] + ftd (TyArrow l r) i c = indent i ["*":ftd a i c] + ftd (TyArray _ a) i c = indent i ["*":ftd a i c] + ftd (TyNewType ti ci a) i c = ftd a i c + ftd (TyRecord ti fs) i c + = indent i ["struct ", safe ti.grd_name, " {\n" + : foldr (fmtField $ i+1) (indent i ["}\n":c]) + [(fi.gfd_name, ty)\\(fi, ty)<-fs] + ] + //Enumeration + ftd (TyObject ti fs) i c + | and [t =: [] \\ (_, t)<-fs] + = indent i ["enum ", safe ti.gtd_name, " {" + , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "}":c] + //Single constructor, single field (box) + ftd (TyObject ti [(ci, [ty])]) i c = ftd ty i c + //Single constructor + ftd (TyObject ti [(ci, ts)]) i c + = indent i ["struct ", safe ti.gtd_name, " {\n" + : flip (foldr (fmtField $ i+1)) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts] + $ indent i ["}":c]] + //Complex adt + ftd (TyObject ti fs) i c + = indent i ["struct ", safe ti.gtd_name, " {\n" + : indent (i+1) ["enum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n" + : indent (i+1) ["struct {\n" + : flip (foldr (fmtCons $ i + 2)) fs + $ indent (i+1) ["} data;\n" + : indent i ["}":c] + ]]]] + where + fmtCons i (ci, []) c = c + fmtCons i (ci, [t]) c = ftd t i [" ", safe ci.gcd_name, ";\n":c] + fmtCons i (ci, ts) c + = indent i ["struct {\n" + : flip (foldr (fmtField (i+1))) [("f" +++ toString i, ty)\\i<-[0..] & ty<-ts] + $ indent i ["} ", safe ci.gcd_name, ";\n":c] + ] + ftd t i c = [] + + fmtField i (name, ty) c = ftd ty i [" ", name, ";\n":c] + typedefs :: [[Type]] -> Either String [String] typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) 'Data.Map'.newMap @@ -75,6 +131,8 @@ pre t s = ((++)t) <$> s post :: [String] [String] -> m [String] | pure m post t s = pure (s ++ t) +header t c = pre ["// ", toString (replaceBuiltins t), "\n":c] + typedef :: Type -> TDMonad typedef (TyRef s) = printTypeName s typedef (TyBasic t) = case t of @@ -85,37 +143,36 @@ typedef (TyBasic t) = case t of t = pure []//liftT $ Left $ "basic type: " +++ toString t +++ " not implemented" typedef (TyArray _ a) = pre ["*"] $ typedef a typedef t=:(TyNewType ti ci a) - = pre ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type -typedef t=:(TyRecord ti fs) = pre - [ "// ", toString t, "\n", "struct ", safe ti.grd_name, " {\n"] + = header t [] $ tydef ti.gtd_name ci.gcd_type +typedef t=:(TyRecord ti fs) = header t ["struct ", safe ti.grd_name, " {\n"] $ fmtFields 1 ti.grd_type [fi.gfd_name\\(fi, _)<-fs] >>= post ["};\n"] //Enumeration typedef t=:(TyObject ti fs) - | and [t =: [] \\ (_, t)<-fs] = pure - [ "// ", toString t, "\n", "enum ", safe ti.gtd_name, " {" - , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"] + | and [t =: [] \\ (_, t)<-fs] = header t + ["enum ", safe ti.gtd_name, " {" + , join ", " [safe ci.gcd_name\\(ci, _)<-fs], "};\n"] $ pure [] //Single constructor, single field (box) -typedef t=:(TyObject ti [(ci, [ty])]) = pre - ["// ", toString t, "\n"] $ tydef ti.gtd_name ci.gcd_type +typedef t=:(TyObject ti [(ci, [ty])]) = header t [] $ tydef ti.gtd_name ci.gcd_type //Single constructor -typedef t=:(TyObject ti [(ci, ts)]) = pre - [ "// ", toString t, "\n", "struct ", safe ti.gtd_name, " {\n"] +typedef t=:(TyObject ti [(ci, ts)]) = header t ["struct ", safe ti.gtd_name, " {\n"] $ fmtFields 1 ci.gcd_type ["f" +++ toString i\\i<-indexList ts] >>= post ["};\n"] //Complex adt -typedef t=:(TyObject ti fs) = pre - [ "// ", toString t, "\nstruct ", safe ti.gtd_name, " {\n" - , "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n" - , "\tstruct {\n"] +typedef t=:(TyObject ti fs) = header t + ["struct ", safe ti.gtd_name, " {\n" + , "\tenum {", join ", " [safe ci.gcd_name\\(ci, _)<-fs], "} cons;\n" + , "\tstruct {\n"] $ mapM fmtCons fs >>= post ["\t} data;\n};\n"] o flatten where fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad fmtCons (ci, []) = pure [] + fmtCons (ci, [t]) = fmtFields 2 ci.gcd_type [safe ci.gcd_name] fmtCons (ci, ts) = pre ["\t\tstruct {\n"] $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts] >>= post ["\t\t} ", safe ci.gcd_name, ";\n"] typedef t = liftT $ Left $ toString t +++ " not implemented" +tydef :: String GenType -> TDMonad tydef name (GenTypeArrow l r) = pre ["typedef "] $ fmtField "" l >>= post [safe name,";\n"] fmtFields :: Int GenType [String] -> TDMonad diff --git a/gengen/test.icl b/gengen/test.icl index 1348136..18fde1d 100644 --- a/gengen/test.icl +++ b/gengen/test.icl @@ -18,7 +18,7 @@ derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, :: T a =: T2 a :: NT =: NT Int -:: SR = {f1 :: Int, f2 :: Bool} +:: SR = {f1 :: Int, f2 :: Bool, f3 :: Tr Either Bool, f4 :: Enum} :: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic, f5 :: [([#Int], [#Int!], [!Int!], [!Int], [Int!])], f6 :: ({!Int}, {R Bool}, {#Char}, {32#Int}),/*({!Int}, {#Char}, {R Bool})*/ @@ -41,21 +41,25 @@ derive gType Either, Maybe, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, :: Odd a = Odd (Even a) | OddBlurp :: Even a = Even (Odd a) | EvenBlurp :: Enum = A | B | C -Start = typedefs //$ (\x->[[gTypeToType x]]) +Start = + ( flatTypedef $ gTypeToType $ unBox t + , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t + ) +//Start = typedefs //$ (\x->[[gTypeToType x]]) // $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType) // $ (\x->[[x]]) - $ map (map gTypeToType) - $ map (filter (not o isBasic)) - $ flattenGType - $ unBox t +// $ map (map gTypeToType) +// $ map (filter (not o isBasic)) +// $ flattenGType +// $ unBox t //t :: Box GType (?# Int) //t :: Box GType (Maybe [Maybe (Either Bool String)]) //t :: Box GType ([SR], Enum, T Int, NT, Blurp Int) //t :: Box GType [EnumList] -//t :: Box GType (Tr Either Enum) -t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe) +t :: Box GType (Int -> SR) +//t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe) t = gType{|*|} //Start = toString t -- 2.20.1