From: Mart Lubbers Date: Sun, 6 Sep 2020 14:14:45 +0000 (+0200) Subject: . X-Git-Url: https://git.martlubbers.net/?a=commitdiff_plain;h=c2914dc5aee23c84e5987915cfead21787256860;p=clean-tests.git . --- diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl index 7f751da..c77320e 100644 --- a/gengen/Data/GenType.dcl +++ b/gengen/Data/GenType.dcl @@ -68,7 +68,13 @@ typeName :: Type -> String /** * Gives the genType for a type */ -typeGenType :: Type -> GenType +typeGenType :: Type -> [GenType] + +/** + * Return the kind of the type + */ +:: Kind = KStar | KArrow Kind Kind +genTypeKind :: Type -> Kind /** * Predicate whether the outer type is a builtin type diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl index cb1296c..37f6df5 100644 --- a/gengen/Data/GenType.icl +++ b/gengen/Data/GenType.icl @@ -263,19 +263,22 @@ 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 :: 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) = [GenTypeCons "_#Nil":GenTypeApp (GenTypeCons (toString s)) <$> typeGenType a] +typeGenType (TyUMaybe a) = [GenTypeCons "_#Nothing":GenTypeApp (GenTypeCons "_#Just") <$> typeGenType a] typeGenType (TyNewType _ _ a) = abort "typeGenType for newtypes not yet implemented\n" -typeGenType (TyRecord i _) = i.grd_type -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] +typeGenType (TyObject _ fs) = [c.gcd_type\\(c, _)<-fs] + +genTypeKind :: GenType -> Kind +genTypeKind (GenTypeCons _) = KStar +genTypeKind (GenTypeVar _) = KStar +genTypeKind (GenTypeArrow l r) = undef +genTypeKind (GenTypeApp l r) = undef instance isBuiltin String where diff --git a/gengen/Data/GenType/CParser.icl b/gengen/Data/GenType/CParser.icl index b9b7bc4..7f1556d 100644 --- a/gengen/Data/GenType/CParser.icl +++ b/gengen/Data/GenType/CParser.icl @@ -105,6 +105,7 @@ where */ :: TPMonad :== WriterT [String] (StateT TPState (Either String)) () :: TPState :== 'Data.Map'.Map String (String, Bool) +import Debug.Trace parsers :: [[Type]] -> Either String ([String], [String]) parsers ts = tuple (parsedefs ts) <$> evalStateT (execWriterT $ mapM_ parsergroup ts) 'Data.Map'.newMap where @@ -118,7 +119,7 @@ where 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 (TyRecord grd _) = concat [", void *parse_" +++ toString i +++ "(uint8_t (*)())"\\i<-[0..recordArity (trace_stdout grd.grd_type)-1]] // pd (TyNewType _ _ _) = abort "not implemented yet\n" pd t = abort $ "not implemented yet: " +++ toString t +++ "\n" @@ -126,8 +127,8 @@ where recordArity (GenTypeCons _) = 0 recordArity (GenTypeVar _) = 0 recordArity (GenTypeApp _ _) = 0 - recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 0 - recordArity (GenTypeArrow l r) = inc $ recordArity r + recordArity (GenTypeArrow _ (GenTypeApp _ _)) = 1 + recordArity (GenTypeArrow l r) = inc $ recordArity l parsergroup :: [Type] -> TPMonad parsergroup ts diff --git a/gengen/test.icl b/gengen/test.icl index f7f2e17..c5f2f42 100644 --- a/gengen/test.icl +++ b/gengen/test.icl @@ -17,7 +17,7 @@ import Data.GenType.CType import Data.GenType.CParser import Text -derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest +derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, EnumList, ER, CP, RA, Nest, MR :: T a = T2 a Char :: NT =: NT Int @@ -38,6 +38,7 @@ derive gType Either, T, R, Frac, Tr, Fix, Odd, Even, SR, List, Enum, NT, Blurp, :: ER = {nat :: Int, bool :: Bool} :: RA a = {a1 :: a, a2 :: Int} +:: MR m = {b1 :: m Int} :: CP = CLeft Int Bool | CRight Char Char @@ -111,6 +112,7 @@ Start w = foldr ($) w , genFiles "raint" raInt , genFiles "lmint" lmInt , genFiles "trEitherInt" trEitherInt + , genFiles "mrMaybe" mrMaybe ] // ( flatTypedef $ gTypeToType $ unBox t // , typedefs $ map (map gTypeToType) $ map (filter (not o isBasic)) $ flattenGType $ unBox t @@ -138,6 +140,9 @@ where trEitherInt :: Box GType (Tr Either Int) trEitherInt = gType{|*|} + mrMaybe :: Box GType (MR ?) + mrMaybe = gType{|*|} + //Start = typedefs //$ (\x->[[gTypeToType x]]) // $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType) // $ (\x->[[x]])