--- /dev/null
+definition module Data.GenType
+
+import StdGeneric
+from StdMaybe import :: Maybe
+
+:: Box b a =: Box b
+derive bimap Box
+unBox (Box b) :== b
+box b :== Box b
+reBox x :== box (unBox x)
+
+:: GType
+ = GTyBasic BasicType
+ | GTyRef String
+ | GTyArrow GType GType
+ | GTyArray ArrayType GType
+ | GTyUList UListType GType
+ | GTyUnit
+ | GTyEither GType GType
+ | GTyPair GType GType
+ | GTyCons GenericConsDescriptor GType
+ | GTyField GenericFieldDescriptor GType
+ | GTyObject GenericTypeDefDescriptor GType
+ | GTyRecord GenericRecordDescriptor GType
+
+:: Type
+ = TyBasic BasicType
+ | TyRef String
+ | TyArrow Type Type
+ | TyArray ArrayType Type
+ | TyUList UListType Type
+ | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
+ | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
+ | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
+
+:: BasicType = BTInt | BTChar | BTReal | BTBool | BTDynamic | BTFile | BTWorld
+:: ArrayType = AStrict | ALazy | AUnboxed | APacked
+:: UListType = ULLazy | ULStrict
+
+instance == GType, Type, BasicType, ArrayType, UListType, GenType
+instance toString GType, Type, BasicType, ArrayType, UListType, GenType
+
+/**
+ * Removes recursive types by replacing them with references
+ *
+ * @param gtype
+ * @result the main type
+ * @result all the separate types grouped in the strongly connected components
+ */
+flattenGType :: GType -> [[GType]]
+
+/**
+ * Convert a GType to a Type. This always returns a Just if the GType was
+ * constructed using the gType generic function
+ *
+ * @param gtype
+ * @result a type on success
+ */
+gTypeToType :: GType -> Maybe Type
+
+/**
+ * Gives the name for the type
+ */
+typeName :: Type -> String
+
+/**
+ * Predicate whether the outer type is a builtin type
+ */
+class isBuiltin a :: a -> Bool
+instance isBuiltin Type
+instance isBuiltin GType
+
+/**
+ * Replace builtin constructors with their pretty names
+ */
+class replaceBuiltins a :: a -> a
+instance replaceBuiltins Type
+instance replaceBuiltins GType
+instance replaceBuiltins GenType
+
+/**
+ * Creates a deep representation of the type
+ */
+generic gType a :: Box GType a
+derive gType UNIT, EITHER, PAIR, CONS of gcd, FIELD of gfd, OBJECT of gtd, RECORD of grd
+derive gType Int, Bool, Real, Char, World, Dynamic, File
+derive gType (->)
+derive gType /*?#,*/ ?, ?^
+derive gType [], [! ], [ !], [!!], [#], [#!], {}, {!}, {#}, {32#}
+derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
--- /dev/null
+implementation module Data.GenType
+
+import StdEnv, StdGeneric, StdMaybe
+import Control.Applicative
+
+import Control.Monad => qualified join
+import Control.Monad.State
+import Data.GenEq
+import Control.Monad.Writer
+import Control.Monad.Trans
+import Data.Func
+import Data.Functor
+import Data.Functor.Identity
+import Data.Generics
+import Data.List
+import Data.Maybe
+import Text
+
+derive bimap Box
+derive gEq BasicType, UListType, ArrayType, GenType
+instance == BasicType where (==) a b = a === b
+instance == UListType where (==) a b = a === b
+instance == ArrayType where (==) a b = a === b
+instance == GenType where (==) a b = a === b
+instance == GType where (==) x y = gTypeEqShallow (2<<30-1) x y
+
+/**
+ * Compares two GTypes only up to a given depth
+ *
+ * @param depth
+ * @param lhs
+ * @param rhs
+ * @return equality
+ */
+gTypeEqShallow :: Int GType GType -> Bool
+gTypeEqShallow i _ _
+ | i < 0 = True
+gTypeEqShallow _ (GTyBasic i) (GTyBasic j) = i == j
+gTypeEqShallow _ (GTyRef i) (GTyRef j) = i == j
+gTypeEqShallow _ (GTyRef i) (GTyObject j _) = i == j.gtd_name
+gTypeEqShallow _ (GTyRef i) (GTyRecord j _) = i == j.grd_name
+gTypeEqShallow _ (GTyObject j _) (GTyRef i) = i == j.gtd_name
+gTypeEqShallow _ (GTyRecord j _) (GTyRef i) = i == j.grd_name
+gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
+gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
+gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
+gTypeEqShallow _ GTyUnit GTyUnit = True
+gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
+gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
+gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
+gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
+ = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
+gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
+ = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
+gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
+ = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
+gTypeEqShallow _ _ _ = False
+
+instance == Type
+where
+ (==) (TyBasic a1) (TyBasic a2) = a1 == a2
+ (==) (TyRef a1) (TyRef a2) = a1 == a2
+ (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
+ (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
+ (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
+ (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
+ = i1.gtd_name == i2.gtd_name && a1 == a2
+ (==) (TyObject i1 a1) (TyObject i2 a2)
+ = i1.gtd_name == i2.gtd_name && length a1 == length a2
+ && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
+ (==) (TyRecord i1 a1) (TyRecord i2 a2)
+ = i1.grd_name == i2.grd_name && length a1 == length a2
+ && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
+ (==) _ _ = False
+
+class print a :: a [String] -> [String]
+instance print Bool where print s c = [toString s:c]
+instance print Int where print s c = [toString s:c]
+instance print Char where print s c = [toString s:c]
+instance print String where print s c = [s:c]
+instance print BasicType
+where
+ print BTInt c = ["Int":c]
+ print BTChar c = ["Char":c]
+ print BTReal c = ["Real":c]
+ print BTBool c = ["Bool":c]
+ print BTDynamic c = ["Dynamic":c]
+ print BTFile c = ["File":c]
+ print BTWorld c = ["World":c]
+instance print UListType
+where
+ print ULStrict c = ["!":c]
+ print ULLazy c = c
+instance print ArrayType
+where
+ print AStrict c = ["!":c]
+ print AUnboxed c = ["#":c]
+ print APacked c = ["32#":c]
+ print ALazy c = c
+instance print GType
+where
+ print (GTyBasic s) c = print s c
+ print (GTyRef s) c = [s:c]
+ print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
+ print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
+ print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
+ print GTyUnit c = ["UNIT":c]
+ print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
+ print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
+ print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
+ print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
+ print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
+ print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
+instance print Type
+where
+ print (TyBasic s) c = print s c
+ print (TyRef s) c = [s:c]
+ print (TyArrow l r) c = print l [" -> ":print r c]
+ print (TyArray s a) c = ["{":print s ["}":print a c]]
+ print (TyUList s a) c = ["[#":print s ["]":print a c]]
+ print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
+ [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
+ where
+ nttype (GenTypeArrow l r) = l
+ print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
+ [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
+ print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
+ $ [" ":isperse " | " (map pCons conses) c]
+ where
+ pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
+ pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
+ where
+ n c = case i.gcd_prio of
+ GenConsNoPrio = [i.gcd_name:c]
+ GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
+ GenConsAssocRight = "r";
+ GenConsAssocLeft = "l"
+ _ = "", " ":print s c]
+
+pTyVars :: String Int [String] -> [String]
+pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
+
+pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
+pField pre [] _ = []
+pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
+
+instance print GenType
+where
+ print (GenTypeVar i) c = print (['a'..] !! i) c
+ print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
+ where
+ collectApps (GenTypeApp l r) c = collectApps l [print r:c]
+ collectApps a c = [print a:c]
+ print (GenTypeCons s) c = [s:c]
+ print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
+
+instance toString GType where toString a = concat $ print a []
+instance toString Type where toString a = concat $ print a []
+instance toString BasicType where toString a = concat $ print a []
+instance toString ArrayType where toString a = concat $ print a []
+instance toString UListType where toString a = concat $ print a []
+instance toString GenType where toString a = concat $ print a []
+
+isperse :: a [[a] -> [a]] [a] -> [a]
+isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
+
+gTypeToType :: GType -> Maybe Type
+gTypeToType (GTyBasic a) = pure $ TyBasic a
+gTypeToType (GTyRef a) = pure $ TyRef a
+gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
+gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
+gTypeToType (GTyUList s a) = TyUList s <$> gTypeToType a
+gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
+where
+ gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
+ gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
+ gtrec _ = Nothing
+gTypeToType (GTyObject i=:{gtd_num_conses=0} t)
+ = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
+gTypeToType (GTyObject i t) = TyObject i <$> gtobj t
+where
+ gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
+ gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
+ gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
+ gtobj _ = Nothing
+
+ gtcons :: GType -> Maybe [Type]
+ gtcons GTyUnit = pure []
+ gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
+ gtcons t = (\x->[x]) <$> gTypeToType t
+
+:: FlatMonad :== State FMState GType
+:: FMState = { objects :: [String], types :: [GType], otypes :: [GType], depth :: Int }
+flattenGType :: GType -> [[GType]]
+flattenGType ot
+ # {types} = execState (mkf ot) {objects=[], otypes=[], types=[], depth=10}
+ = scc [(t, refs t [])\\t<-types]
+where
+ refs (GTyObject _ a) c = refs a c
+ refs (GTyRecord _ a) c = refs a c
+ refs (GTyEither l r) c = refs l $ refs r c
+ refs (GTyPair l r) c = refs l $ refs r c
+ refs (GTyCons _ a) c = refs a c
+ refs (GTyField _ a) c = refs a c
+ refs GTyUnit c = c
+ refs (GTyArrow l r) c = refs l $ refs r c
+ refs (GTyArray _ a) c = refs a c
+ refs (GTyUList _ a) c = refs a c
+ refs (GTyBasic _) c = c
+ refs a=:(GTyRef _) c = [a:c]
+
+ write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
+ write cons t a = getState >>= \s
+ //We have seen the type but it might've had different arguments
+ | isMember name s.objects
+ //We have not seen this configuration
+ | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
+ = modify (\x->{x & depth=dec x.depth}) *> mkf a *> pure (GTyRef name)
+ //If not, just return the basictype
+ = pure $ GTyRef name
+ //We have not seen the type so we add, calculate and output it
+ = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
+ >>= \ty->addIfNotThere ty >>| pure (GTyRef name)
+ where
+ name = genericDescriptorName t
+
+ addIfNotThere :: GType -> FlatMonad
+ addIfNotThere ty = getState >>= \s
+ | isMember ty s.types
+ = pure ty
+ = modify (\s->{s & types=[ty:s.types]}) >>| pure ty
+
+ mkf :: GType -> FlatMonad
+ mkf (GTyObject t a) = write GTyObject t a
+ mkf (GTyRecord t a) = write GTyRecord t a
+ mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
+ mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
+ mkf (GTyCons i a) = GTyCons i <$> mkf a
+ mkf (GTyField i a) = GTyField i <$> mkf a
+ mkf GTyUnit = pure GTyUnit
+ mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
+ mkf (GTyArray s a) = GTyArray s <$> mkf a
+ mkf (GTyUList s a) = GTyUList s <$> mkf a
+ mkf a=:(GTyBasic _) = addIfNotThere a
+ mkf a=:(GTyRef _) = pure a
+
+typeName :: Type -> String
+typeName (TyBasic a) = toString a
+typeName (TyRef a) = a
+typeName (TyArrow l r) = typeName l +++ "->" +++ typeName r
+typeName (TyArray s a) = "{" +++ toString s +++ typeName a +++ "}"
+typeName (TyUList s a) = "{" +++ toString s +++ typeName a +++ "}"
+typeName (TyNewType i _ _) = i.gtd_name
+typeName (TyObject i _) = i.gtd_name
+typeName (TyRecord i _) = i.grd_name
+
+instance isBuiltin String
+where
+ isBuiltin s = [()\\(l, r)<-predef | l == s || r == s] =: [_:_]
+instance isBuiltin Type
+where
+ isBuiltin (TyObject i a) = isBuiltin i.gtd_name
+ isBuiltin (TyRecord i a) = isBuiltin i.grd_name
+ isBuiltin (TyRef a) = isBuiltin a
+ isBuiltin _ = True
+instance isBuiltin GType
+where
+ isBuiltin (GTyObject i a) = isBuiltin i.gtd_name
+ isBuiltin (GTyRecord i a) = isBuiltin i.grd_name
+ isBuiltin (GTyRef a) = isBuiltin a
+ isBuiltin _ = True
+
+instance replaceBuiltins GenericFieldDescriptor
+where
+ replaceBuiltins s = {s & gfd_name=replaceBuiltins s.gfd_name}
+instance replaceBuiltins GenericConsDescriptor
+where
+ replaceBuiltins s = {s & gcd_name=replaceBuiltins s.gcd_name, gcd_type=replaceBuiltins s.gcd_type}
+instance replaceBuiltins GenericTypeDefDescriptor
+where
+ replaceBuiltins s = {s & gtd_name=replaceBuiltins s.gtd_name}
+instance replaceBuiltins GenericRecordDescriptor
+where
+ replaceBuiltins s = {s & grd_name=replaceBuiltins s.grd_name, grd_type=replaceBuiltins s.grd_type}
+instance replaceBuiltins String
+where
+ replaceBuiltins a = fromMaybe a $ lookup a predef
+instance replaceBuiltins Type
+where
+ replaceBuiltins (TyRef a) = TyRef (replaceBuiltins a)
+ replaceBuiltins (TyArrow l r) = TyArrow (replaceBuiltins l) (replaceBuiltins r)
+ replaceBuiltins (TyArray s a) = TyArray s (replaceBuiltins a)
+ replaceBuiltins (TyUList s a) = TyUList s (replaceBuiltins a)
+ replaceBuiltins (TyNewType i j a) = TyNewType (replaceBuiltins i) (replaceBuiltins j) (replaceBuiltins a)
+ replaceBuiltins (TyObject i cs) = TyObject (replaceBuiltins i) [(replaceBuiltins i, map replaceBuiltins fs)\\(i, fs)<-cs]
+ replaceBuiltins (TyRecord j fs) = TyRecord (replaceBuiltins j) [(replaceBuiltins i, replaceBuiltins a)\\(i, a)<-fs]
+ replaceBuiltins t = t
+instance replaceBuiltins GType
+where
+ replaceBuiltins (GTyEither l r) = GTyEither (replaceBuiltins l) (replaceBuiltins r)
+ replaceBuiltins (GTyPair l r) = GTyPair (replaceBuiltins l) (replaceBuiltins r)
+ replaceBuiltins (GTyArrow l r) = GTyArrow (replaceBuiltins l) (replaceBuiltins r)
+ replaceBuiltins (GTyArray s a) = GTyArray s (replaceBuiltins a)
+ replaceBuiltins (GTyUList s a) = GTyUList s (replaceBuiltins a)
+ replaceBuiltins (GTyObject i a) = GTyObject (replaceBuiltins i) (replaceBuiltins a)
+ replaceBuiltins (GTyRecord i a) = GTyRecord (replaceBuiltins i) (replaceBuiltins a)
+ replaceBuiltins (GTyCons i a) = GTyCons (replaceBuiltins i) (replaceBuiltins a)
+ replaceBuiltins (GTyField i a) = GTyField (replaceBuiltins i) (replaceBuiltins a)
+ replaceBuiltins (GTyRef a) = GTyRef (replaceBuiltins a)
+ replaceBuiltins a = a
+instance replaceBuiltins GenType
+where
+ replaceBuiltins (GenTypeCons a) = GenTypeCons (replaceBuiltins a)
+ replaceBuiltins (GenTypeApp l r) = GenTypeApp (replaceBuiltins l) (replaceBuiltins r)
+ replaceBuiltins (GenTypeArrow l r) = GenTypeArrow (replaceBuiltins l) (replaceBuiltins r)
+ replaceBuiltins a = a
+
+predef :: [(String, String)]
+predef =:
+ [ ("_List", "[]"), ("_Cons", "(:)"), ("_Nil", "[]")
+ , ("_!List", "[! ]"), ("_!Cons", "(:)"), ("_!Nil", "[! ]")
+ , ("_List!", "[ !]"), ("_Cons!", "(:)"), ("_Nil!", "[ !]")
+ , ("_!List!", "[!!]"), ("_!Cons!", "(:)"), ("_!Nil!", "[ !]")
+ , ("_#List", "[#]"), ("_#Cons", "(:)"), ("_#Nil", "[#]")
+ , ("_#List!", "[#!]"), ("_#Cons!", "(:)"), ("_#Nil!", "[#!]")
+ , ("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}"), ("_32#Array", "{32#}")
+ , ("_Unit", "()")
+ :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
+
+generic type a :: Box GType a
+gType{|UNIT|} = box GTyUnit
+gType{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
+gType{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
+gType{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
+gType{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
+gType{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
+gType{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
+gType{|Int|} = box $ GTyBasic BTInt
+gType{|Bool|} = box $ GTyBasic BTBool
+gType{|Real|} = box $ GTyBasic BTReal
+gType{|Char|} = box $ GTyBasic BTChar
+gType{|World|} = box $ GTyBasic BTWorld
+gType{|Dynamic|} = box $ GTyBasic BTDynamic
+gType{|File|} = box $ GTyBasic BTFile
+gType{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
+gType{|[#]|} a = box $ GTyUList ULLazy $ unBox a
+gType{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
+gType{|{}|} a = box $ GTyArray ALazy $ unBox a
+gType{|{!}|} a = box $ GTyArray AStrict $ unBox a
+gType{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
+gType{|{32#}|} a = box $ GTyArray APacked $ unBox a
+derive gType ?#, ?, ?^
+derive gType [], [! ], [ !], [!!]
+derive gType (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
--- /dev/null
+definition module Data.GenType.CType
+
+from Data.Either import :: Either
+from Data.GenType import :: Type
+
+/**
+ * generate typedefs for the types grouped by strongly connected components
+ */
+typedefs :: [[Type]] -> Either String [String]
--- /dev/null
+implementation module Data.GenType.CType
+
+import Control.Applicative
+import Control.Monad => qualified join
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Either
+import Data.Maybe
+import Data.Func
+import Data.Functor
+import Data.List
+import StdEnv
+import Data.GenType
+import Text
+
+typedefs :: [[Type]] -> Either String [String]
+typedefs ts = flatten <$> evalStateT (mapM typedefgroup ts) { tinfo = [] }
+
+:: TDMonad :== StateT TDState (Either String) [String]
+:: TDState = { tinfo :: [(String, Bool)] }
+
+typedefgroup :: [Type] -> TDMonad
+typedefgroup ts
+ = flatten
+ <$ mapM (\t->modify \s->{s & tinfo=[(typeName t, if (ts =: [_]) (maybeInfinite t) True):s.tinfo]}) ts
+ <*> mapM (\t->typedef t >>= post ["\n"]) ts
+where
+ maybeInfinite :: Type -> Bool
+ maybeInfinite t = False
+
+printTypeName :: String -> TDMonad
+printTypeName tname = maybe [tname] (\b->[tname, " ", if b "*" ""])
+ <$> gets \s->lookup tname s.tinfo
+
+pre :: [String] (m [String]) -> m [String] | Monad m
+pre t s = ((++)t) <$> s
+
+post :: [String] [String] -> m [String] | pure m
+post t s = pure (s ++ t)
+
+import StdDebug
+typedef :: Type -> TDMonad
+typedef (TyRef s) = printTypeName s
+typedef (TyBasic BTInt) = pure [IF_INT_64_OR_32 "int64_t" "int32_t"]
+typedef (TyBasic BTChar) = pure ["char"]
+typedef (TyBasic BTReal) = pure ["double"]
+typedef (TyBasic BTBool) = pure ["bool"]
+typedef (TyArray _ a) = pre ["*"] $ typedef a
+typedef t=:(TyNewType ti ci a)
+ = pre ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
+typedef t=:(TyRecord ti fs) = pre
+ [ "// ", toString t, "\n", "struct ", 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 ", ti.gtd_name, " {"
+ , join ", " [ci.gcd_name\\(ci, _)<-fs], "};\n"]
+//Single constructor, single field (box)
+typedef t=:(TyObject ti [(ci, [ty])]) = pre
+ ["// ", toString t, "\n", "typedef ", ti.gtd_name, " "] $ fmtFields 0 ci.gcd_type [""]
+//Single constructor
+typedef t=:(TyObject ti [(ci, ts)]) = pre
+ [ "// ", toString t, "\n", "struct ", 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 ", ti.gtd_name, " {\n"
+ , "\tenum {", join ", " [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, ts) = pre ["\t\tstruct {\n"]
+ $ fmtFields 3 ci.gcd_type ["f" +++ toString i\\i<-indexList ts]
+ >>= post ["\t\t} ", ci.gcd_name, ";\n"]
+typedef t = pure []//liftT $ Left $ toString t +++ " not implemented"
+
+fmtFields :: Int GenType [String] -> TDMonad
+fmtFields i _ [] = pure []
+fmtFields i (GenTypeArrow l r) [x:xs] = fmtField i x l >>= flip pre (fmtFields i r xs)
+
+fmtField :: Int String GenType -> TDMonad
+fmtField i x (GenTypeCons a) = pre [createArray i '\t'] $ printTypeName a >>= post [x,";\n"]
+fmtField i x (GenTypeVar a) = fmtField i x (GenTypeCons "void *")
+fmtField i x (GenTypeApp l r) = fmtField i x l
+fmtField i x t=:(GenTypeArrow _ _) = liftT $ Left $ toString t +++ " unsupported"
+//typedef t=:(TyRecord ti fs) = pre
+// [ "// ", toString t, "\n", "struct ", i.grd_name, " {\n"]
+// $ mapM (fmtField 1) [(i.gfd_name, t)\\(i, t)<-fs]
+// >>= post ["};\n"] o flatten
+////Enumeration
+//typedef t=:(TyObject i fs)
+// | and [t =: [] \\ (_, t)<-fs] = pure
+// [ "// ", toString t, "\n", "enum ", i.gtd_name, " {"
+// , join ", " [i.gcd_name\\(i, _)<-fs], "};\n"]
+////Single constructor, single field (box)
+//typedef t=:(TyObject i [(j, [ty])]) = pre
+// ["// ", toString t, "\n", "typedef ", i.gtd_name, " "] $ typedef ty
+////Single constructor
+//typedef t=:(TyObject i [(j, ts)]) = pre
+// [ "// ", toString t, "\n", "struct ", i.gtd_name, " {\n"]
+// $ mapM (fmtField 1) (numberConsData ts)
+// >>= post ["};\n"] o flatten
+////Complex adt
+//typedef t=:(TyObject i fs) = pre
+// [ "// ", toString t, "\nstruct ", i.gtd_name, " {\n"
+// , "\tenum {", join ", " [i.gcd_name\\(i, _)<-fs], "} cons;\n"
+// , "\tstruct {\n"]
+// $ mapM fmtCons fs
+// >>= post ["\t} data;\n};\n"] o flatten
+//where
+// fmtCons :: (GenericConsDescriptor, [Type]) -> TDMonad
+// fmtCons (i, []) = pure []
+// fmtCons (i, ts) = pre ["\t\tstruct {\n"]
+// $ mapM (fmtField 3) (numberConsData ts)
+// >>= post ["\t\t} ", i.gcd_name, ";\n"] o flatten
+
+numberConsData ts = [("f"+++toString i, t)\\i<-[0..] & t<-ts]
+
+//fmtField :: Int (String, Type) -> TDMonad
+//fmtField indent (i, t) = pre [createArray indent '\t'] $ typedef t >>= post [" ", i, ";\n"]
+++ /dev/null
-module gen
-
-import Control.Applicative
-import Control.Monad => qualified join
-import Control.Monad.State
-import Control.Monad.Writer
-:mport Control.Monad.Trans
-import Data.Either
-import Data.Func
-import Data.Functor
-import Data.Functor.Identity
-import Data.Generics
-import Data.List
-import Data.Maybe
-import Data.Monoid
-import Data.Tuple
-import StdEnv, StdGeneric
-import Text
-
-:: Box b a =: Box b
-derive bimap Box
-unBox (Box b) :== b
-box b :== Box b
-reBox x :== box (unBox x)
-
-:: GType
- = GTyBasic String
- | GTyArrow GType GType
- | GTyArray ArrayType GType
- | GTyUList UListType GType
- | GTyUnit
- | GTyEither GType GType
- | GTyPair GType GType
- | GTyCons GenericConsDescriptor GType
- | GTyField GenericFieldDescriptor GType
- | GTyObject GenericTypeDefDescriptor GType
- | GTyRecord GenericRecordDescriptor GType
-:: ArrayType = AStrict | ALazy | AUnboxed | A32Unboxed
-:: UListType = ULLazy | ULStrict
-instance == UListType
-where
- (==) ULLazy ULLazy = True
- (==) ULStrict ULStrict = True
- (==) _ _ = False
-instance == ArrayType
-where
- (==) AStrict AStrict = True
- (==) ALazy ALazy = True
- (==) AUnboxed AUnboxed = True
- (==) A32Unboxed A32Unboxed = True
- (==) _ _ = False
-
-instance == GType where (==) x y = gTypeEqShallow 999 x y
-gTypeEqShallow :: Int GType GType -> Bool
-gTypeEqShallow i _ _
- | i < 0 = True
-gTypeEqShallow _ (GTyBasic i) (GTyBasic j) = i == j
-gTypeEqShallow i (GTyArrow l1 r1) (GTyArrow l2 r2) = gTypeEqShallow (dec i) l1 l2 && gTypeEqShallow (dec i) r1 r2
-gTypeEqShallow i (GTyArray s1 a1) (GTyArray s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
-gTypeEqShallow i (GTyUList s1 a1) (GTyUList s2 a2) = s1 == s2 && gTypeEqShallow (dec i) a1 a2
-gTypeEqShallow _ GTyUnit GTyUnit = True
-gTypeEqShallow i (GTyEither l1 r1) (GTyEither l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
-gTypeEqShallow i (GTyPair l1 r1) (GTyPair l2 r2) = gTypeEqShallow i l1 l2 && gTypeEqShallow i r1 r2
-gTypeEqShallow i (GTyCons i1 a1) (GTyCons i2 a2) = i1.gcd_name == i2.gcd_name && gTypeEqShallow i a1 a2
-gTypeEqShallow i (GTyField i1 a1) (GTyField i2 a2)
- = i1.gfd_name == i2.gfd_name && i1.gfd_cons.grd_name == i2.gfd_cons.grd_name && gTypeEqShallow i a1 a2
-gTypeEqShallow i (GTyObject i1 a1) (GTyObject i2 a2)
- = i1.gtd_name == i2.gtd_name && gTypeEqShallow (dec i) a1 a2
-gTypeEqShallow i (GTyRecord i1 a1) (GTyRecord i2 a2)
- = i1.grd_name == i2.grd_name && gTypeEqShallow (dec i) a1 a2
-gTypeEqShallow _ _ _ = False
-
-class print a :: a [String] -> [String]
-instance print Bool where print s c = [toString s:c]
-instance print Int where print s c = [toString s:c]
-instance print Char where print s c = [toString s:c]
-instance print String where print s c = [s:c]
-instance print UListType
-where
- print ULStrict c = ["!":c]
- print ULLazy c = c
-instance print ArrayType
-where
- print AStrict c = ["!":c]
- print AUnboxed c = ["#":c]
- print A32Unboxed c = ["32#":c]
- print ALazy c = c
-instance print GType
-where
- print (GTyBasic s) c = [s:c]
- print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
- print (GTyArray s a) c = ["{":print s $ print a ["}":c]]
- print (GTyUList s a) c = ["[#":print s $ print s ["]":c]]
- print GTyUnit c = ["UNIT":c]
- print (GTyEither l r) c = ["(EITHER ":print l [" ":print r [")":c]]]
- print (GTyPair l r) c = ["(PAIR ":print l [")":c]]
- print (GTyCons i a) c = ["(CONS ", i.gcd_name, " ":print a [")":c]]
- print (GTyField i a) c = ["(FIELD ", i.gfd_name, " ":print a [")":c]]
- print (GTyObject i a) c = ["(OBJECT ", i.gtd_name, " ":print a [")":c]]
- print (GTyRecord i a) c = ["(RECORD ", i.grd_name, " ":print a [")":c]]
-
-:: Type
- = TyBasic String
- | TyArrow Type Type
- | TyArray ArrayType Type
- | TyUList UListType Type
- | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
- | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
- | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
-instance == Type
-where
- (==) (TyBasic a1) (TyBasic a2) = a1 == a2
- (==) (TyArrow l1 r1) (TyArrow l2 r2) = l1 == l2 && r1 == r2
- (==) (TyArray s1 a1) (TyArray s2 a2) = s1 == s2 && a1 == a2
- (==) (TyUList s1 a1) (TyUList s2 a2) = s1 == s2 && a1 == a2
- (==) (TyNewType i1 j1 a1) (TyNewType i2 j2 a2)
- = i1.gtd_name == i2.gtd_name && a1 == a2
- (==) (TyObject i1 a1) (TyObject i2 a2)
- = i1.gtd_name == i2.gtd_name && length a1 == length a2
- && and [l1.gcd_name == l2.gcd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
- (==) (TyRecord i1 a1) (TyRecord i2 a2)
- = i1.grd_name == i2.grd_name && length a1 == length a2
- && and [l1.gfd_name == l2.gfd_name && t1 == t2\\(l1, t1)<-a1 & (l2, t2)<-a2]
- (==) _ _ = False
-
-predef :: [(String, String)]
-predef =:
- [("_List", "[]"), ("_!List", "[! ]"), ("_List!", "[ !]"), ("_!List!", "[!!]")
- ,("_#List", "[#]"), ("_#List!", "[#!]")
- ,("_Array", "{}"), ("_!Array", "{!}"), ("_#Array", "{#}")
- :[("_Tuple" +++ toString i, "(" +++ createArray i ',' +++")")\\i<-[2..32]]]
-
-translateType :: String -> String
-translateType s = maybe s id $ lookup s predef
-
-instance print Type
-where
- print (TyBasic s) c = [translateType s:c]
- print (TyArrow l r) c = print l [" -> ":print r c]
- print (TyArray s a) c = ["{":print s ["}":print a c]]
- print (TyUList s a) c = ["[#":print s ["]":print a c]]
- print (TyNewType i j cons) c = pTyVars i.gtd_name i.gtd_arity
- [": ", j.gcd_name, " ":print (nttype j.gcd_type) c]
- where nttype (GenTypeArrow l r) = l
- print (TyRecord i fields) c = pTyVars i.grd_name i.grd_type_arity
- [" {":isperse ", " (pField (\i c->[i.gfd_name, " :: ":c]) fields i.grd_type) ["}":c]]
- print (TyObject i conses) c = pTyVars i.gtd_name i.gtd_arity
- $ [" ":isperse " | " (map pCons conses) c]
- where
- pCons :: (GenericConsDescriptor, [Type]) [String] -> [String]
- pCons (i, ts) c = n [" ":isperse " " (pField (\_->id) [(i, t)\\t<-ts] i.gcd_type) c]
- where
- n c = case i.gcd_prio of
- GenConsNoPrio = [i.gcd_name:c]
- GenConsPrio a s = ["(",i.gcd_name,") infix",case a of
- GenConsAssocRight = "r";
- GenConsAssocLeft = "l"
- _ = "", " ":print s c]
-
-pTyVars :: String Int [String] -> [String]
-pTyVars ty arity c = [":: ", ty, " ":isperse " " (map print ['a'..'a'+toChar (arity-1)]) [" =":c]]
-
-pField :: (a [String] -> [String]) [(a, Type)] GenType -> [[String] -> [String]]
-pField pre [] _ = []
-pField pre [(i, t):xs] (GenTypeArrow l r) = [pre i o print l:pField pre xs r]
-
-instance == GenType
-where
- (==) (GenTypeVar i) (GenTypeVar j) = i == j
- (==) (GenTypeApp l1 r1) (GenTypeApp l2 r2) = l1 == l2 && r1 == r2
- (==) (GenTypeCons i) (GenTypeCons j) = i == j
- (==) (GenTypeArrow l1 r1) (GenTypeArrow l2 r2) = l1 == l2 && r1 == r2
- (==) _ _ = False
-instance print GenType
-where
- print (GenTypeVar i) c = print (['a'..] !! i) c
- print t=:(GenTypeApp _ _) c = ["(":isperse " " (collectApps t []) [")":c]]
- where
- collectApps (GenTypeApp l r) c = collectApps l [print r:c]
- collectApps a c = [print a:c]
- print (GenTypeCons s) c = [translateType s:c]
- print (GenTypeArrow l r) c = ["(":print l [" -> ":print r [")":c]]]
-
-isperse :: a [[a] -> [a]] [a] -> [a]
-isperse s m c = foldr id c $ intersperse (\c->[s:c]) m
-
-gTypeToType :: GType -> Maybe Type
-gTypeToType (GTyBasic a) = pure $ TyBasic a
-gTypeToType (GTyArrow l r) = TyArrow <$> gTypeToType l <*> gTypeToType r
-gTypeToType (GTyArray s a) = TyArray s <$> gTypeToType a
-gTypeToType (GTyUList s a) = TyUList s <$> gTypeToType a
-gTypeToType (GTyRecord i t) = TyRecord i <$> gtrec t
-where
- gtrec (GTyField i t) = (\x->[(i, x)]) <$> gTypeToType t
- gtrec (GTyPair l r) = (++) <$> gtrec l <*> gtrec r
- gtrec _ = Nothing
-gTypeToType (GTyObject i t)
- | i.gtd_num_conses == 0 = TyNewType i (hd i.gtd_conses) <$> gTypeToType t
- = TyObject i <$> gtobj t
-where
- gtobj :: GType -> Maybe [(GenericConsDescriptor, [Type])]
- gtobj (GTyEither l r) = (++) <$> gtobj l <*> gtobj r
- gtobj (GTyCons i a) = (\x->[(i, x)]) <$> gtcons a
- gtobj _ = Nothing
-
- gtcons :: GType -> Maybe [Type]
- gtcons GTyUnit = pure []
- gtcons (GTyPair l r) = (++) <$> gtcons l <*> gtcons r
- gtcons t = (\x->[x]) <$> gTypeToType t
-
-:: FlatMonad :== State FMState GType
-:: FMState = { objects :: [String], otypes :: [GType], types :: [GType], depth :: Int}
-flattenGType :: GType -> (GType, [GType])
-flattenGType ot = appSnd (\x->x.types) $ runState (mkf ot) {objects=[], types=[], otypes=[], depth=10}
-where
- write :: (a GType -> GType) a GType -> FlatMonad | genericDescriptorName a
- write cons t a = modify (\x->{x & depth=dec x.depth}) >>| getState >>= \s
- //We have seen the type but it might've had different arguments
- | isMember name s.objects
- //We have not seen this configuration
- | isEmpty [ot \\ ot<-s.otypes | gTypeEqShallow s.depth ot a]
- = mkf a *> r
- //If not, just return the basictype
- = r
- //We have not seen the type so we add, calculate and output it
- = cons t <$ modify (\x->{x & otypes=[a:x.otypes], objects=[name:x.objects]}) <*> mkf a
- >>= \ty->modify (\x->{x & types=[ty:x.types]}) >>| r
- where
- name = genericDescriptorName t
- r = pure $ GTyBasic name
-
- mkf :: GType -> FlatMonad
- mkf (GTyObject t a) = write GTyObject t a
- mkf (GTyRecord t a) = write GTyRecord t a
- mkf (GTyEither l r) = GTyEither <$> mkf l <*> mkf r
- mkf (GTyPair l r) = GTyPair <$> mkf l <*> mkf r
- mkf (GTyCons i a) = GTyCons i <$> mkf a
- mkf (GTyField i a) = GTyField i <$> mkf a
- mkf (GTyArrow l r) = GTyArrow <$> mkf l <*> mkf r
- mkf (GTyArray s a) = GTyArray s <$> mkf a
- mkf (GTyUList s a) = GTyUList s <$> mkf a
- mkf GTyUnit = pure GTyUnit
- mkf a=:(GTyBasic _) = pure a
-
-generic type a :: Box GType a
-type{|Int|} = box $ GTyBasic "Int"
-type{|Bool|} = box $ GTyBasic "Bool"
-type{|Real|} = box $ GTyBasic "Real"
-type{|Char|} = box $ GTyBasic "Char"
-type{|World|} = box $ GTyBasic "World"
-type{|Dynamic|} = box $ GTyBasic "Dynamic"
-type{|(->)|} l r = box $ GTyArrow (unBox l) (unBox r)
-type{|[#]|} a = box $ GTyUList ULLazy $ unBox a
-type{|[#!]|} a = box $ GTyUList ULStrict $ unBox a
-type{|{}|} a = box $ GTyArray ALazy $ unBox a
-type{|{!}|} a = box $ GTyArray AStrict $ unBox a
-type{|{#}|} a = box $ GTyArray AUnboxed $ unBox a
-type{|{32#}|} a = box $ GTyArray A32Unboxed $ unBox a
-
-type{|UNIT|} = box GTyUnit
-type{|EITHER|} l r = box $ GTyEither (unBox l) (unBox r)
-type{|PAIR|} l r = box $ GTyPair (unBox l) (unBox r)
-type{|CONS of gcd|} a = box $ GTyCons gcd $ unBox a
-type{|FIELD of gfd|} a = box $ GTyField gfd $ unBox a
-type{|OBJECT of gtd|} a = box $ GTyObject gtd $ unBox a
-type{|RECORD of grd|} a = box $ GTyRecord grd $ unBox a
-
-derive type ?#, ?, ?^
-derive type [], [! ], [ !], [!!]
-derive type (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
-derive type Either, Maybe, T, R, Frac, Tr, Fix
-
-:: T a =: T2 a
-:: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic,
- f5 :: [[([#Int], [#Int!], [!Int!], [!Int], [Int!], {!Int}, {R Bool}, {#Char})]]/*({!Int}, {#Char}, {R Bool})*/}
-
-:: Tr m b= Tr (m Int b)
-
-:: Frac a = (/.) infixl 7 a a
-
-//Start :: [String]
-//Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
-Start = foldr (\i c->print i ["\n":c]) []
- $ catMaybes
- $ map gTypeToType
- $ snd $ flattenGType
- $ unBox t
-
-:: Fix f = Fix (f (Fix f))
-
-//t :: Box GType (?# Int)
-//t :: Box GType (Maybe [Maybe (Either Bool String)])
-//t :: Box GType [Either [[!Int]] [[![Bool]]]]
-t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
-t = type{|*|}
--- /dev/null
+{-# LANGUAGE GADTs, DeriveGeneric, DefaultSignatures, TypeOperators #-}
+module Main where
+
+import GHC.Generics
+
+data GType a where
+ Unit :: GType (U1 p)
+ Product :: (GType a) (GType b) -> GType ((a :*: b) p)
+ Sum :: (GType a) (GType b) -> GType (a :+: b)
+
+
+main = putStrLn ""
--- /dev/null
+{-# LANGUAGE GADTs #-}
+module Main where
+
+data GType
+data GType a where
+ Unit :: GType UNIT
+ Add :: (Num a, Eq a) => Expr a -> Expr a -> Expr a
+ Ext :: (Eval v, Print v, Opt v, Typeable v) => v a -> Expr a
+
+main = putStrLn ""
import StdEnv, StdGeneric, StdMaybe
-import Data.Either, Data.Func
-
-:: Box b a =: Box b
-derive bimap Box
-unBox (Box b) :== b
-box b :== Box b
-reBox x :== box (unBox x)
-
-:: GGFuns st a =
- { int :: st -> Either String (Int, st)
- , bool :: st -> Either String (Bool, st)
- , real :: st -> Either String (Real, st)
- , char :: st -> Either String (Char, st)
-
- , unit :: st -> Either String (UNIT, st)
-// , cons :: (st -> Either String (a, st)) GenericConsDescriptor st -> Either String (CONS b, st)
-// , field :: (st -> Either String (a, st)) GenericFieldDescriptor st -> Either String (FIELD b, st)
-// , record :: (st -> Either String (a, st)) GenericRecordDescriptor st -> Either String (RECORD b, st)
-// , object :: (st -> Either String (a, st)) GenericTypeDefDescriptor st -> Either String (OBJECT b, st)
-// , pair :: (st -> Either String (al, st)) (st -> Either String (br, st)) st -> Either String (PAIR bl br, st)
-// , either :: (st -> Either String (al, st)) (st -> Either String (br, st)) st -> Either String (EITHER bl br, st)
- }
-
-ggcast :: (GGFuns st a) -> GGFuns st c
-ggcast d = {d & int=d.int}
-
-generic gGeneric a :: (GGFuns st a) st -> Either String (a, st)
-
-gGeneric{|Int|} d st = d.int st
-gGeneric{|Bool|} d st = d.bool st
-gGeneric{|Real|} d st = d.real st
-gGeneric{|Char|} d st = d.char st
-
-gGeneric{|UNIT|} d st = d.unit st
-//gGeneric{|CONS of gcd|} f d st = d.cons (f (ggcast d)) gcd st
-//gGeneric{|FIELD of gfd|} f d st = d.field (f (ggcast d)) gfd st
-//gGeneric{|OBJECT of gtd|} f d st = d.object (f (ggcast d)) gtd st
-//gGeneric{|RECORD of grd|} f d st = d.record (f (ggcast d)) grd st
-//gGeneric{|PAIR|} fl fr d st = d.pair (fl (ggcast d)) (fr (ggcast d)) st
-//gGeneric{|EITHER|} fl fr d st = d.either (fl (ggcast d)) (fr (ggcast d)) st
-
-gDefault :: a | gGeneric{|*|} a
-gDefault = fromRight o snd $
- { int=basic 0, bool=basic True, real=basic 0.0, char=basic 'a', unit=basic UNIT
- }
-where
- basic c = \_->Right (c, ())
-
-Start = 42
+import Data.Func
+import Data.Functor
+import Data.List
+import Data.Tuple
+import Data.Bifunctor
+import Control.GenBimap
+import Data.Maybe
+import Data.Either
+
+import Data.GenType
+import Data.GenType.CType
+
+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}
+:: 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})*/}
+:: Tr m b= Tr (m Int b)
+:: Frac a = (/.) infixl 7 a a
+:: Fix f = Fix (f (Fix f))
+
+:: List a = Cons a (List a) | Nil
+
+////Start :: [String]
+////Start = foldr (\i c->print i ["\n":c]) [] $ catMaybes $ map gTypeToType $ flattenGType $ unBox t
+//:: Pair a b = Pair a b
+//instance == (Pair a b) | == a where (==) (Pair a1 _) (Pair a2 _) = a1 == a2
+//instance < (Pair a b) | < a where (<) (Pair a1 _) (Pair a2 _) = a1 < a2
+:: Odd a = Odd (Even a) | OddBlurp
+:: Even a = Even (Odd a) | EvenBlurp
+:: Enum = A | B | C
+Start = typedefs
+// $ map (/*filter (not o isBuiltin) o*/ catMaybes o map gTypeToType)
+// $ flattenGType
+ $ (\x->[[fromJust x]])
+ $ gTypeToType
+ $ unBox t
+//
+//
+//t :: Box GType (?# Int)
+//t :: Box GType (Maybe [Maybe (Either Bool String)])
+t :: Box GType ([SR], Enum, T Int, NT)
+//t :: Box GType (Tr Either Enum)
+//t :: Box GType (Odd Int, (), [Either (R (T *World)) (Frac Real)], Tr Either Bool, Fix Maybe)
+t = gType{|*|}
+
+//Start = toString t
+//
+//t :: GGType [Int]
+//t = ggType{|*|}
+//
+//:: BM a b =
+// { ab :: a -> b
+// , ba :: b -> a
+//// , mab :: A.m: (m a) -> m b
+//// , mba :: A.m: (m b) -> m a
+// }
+//bm :: BM a a
+//bm = {ab=id, ba=id}//, mab=id, mba=id}
+//
+//:: GGType a
+// = GGBasicType BasicType
+// | GGTyRef String
+// | GGUnit
+// | E.e: GGObject (BM a (OBJECT e)) GenericTypeDefDescriptor (GGType e)
+// | E.e: GGRecord (BM a (RECORD e)) GenericRecordDescriptor (GGType e)
+// | E.e: GGCons (BM a (CONS e)) GenericConsDescriptor (GGType e)
+// | E.e: GGField (BM a (FIELD e)) GenericFieldDescriptor (GGType e)
+// | E.l r: GGEither (BM a (EITHER l r)) (GGType l) (GGType r)
+// | E.l r: GGPair (BM a (PAIR l r)) (GGType l) (GGType r)
+// | E.l r: GGArrow (BM a (l -> r)) (GGType l) (GGType r)
+//
+//instance toString (GGType a)
+//where
+// toString (GGBasicType t) = toString t
+// toString GGUnit = "UNIT"
+// toString (GGObject bm i e) = "(OBJECT " +++ i.gtd_name +++ " " +++ toString e +++ ")"
+// toString (GGRecord bm i e) = "(RECORD " +++ i.grd_name +++ " " +++ toString e +++ ")"
+// toString (GGCons bm i e) = "(CONS " +++ i.gcd_name +++ " " +++ toString e +++ ")"
+// toString (GGField bm i e) = "(FIELD " +++ i.gfd_name +++ " " +++ toString e +++ ")"
+// toString (GGEither bm l r) = "(EITHER " +++ toString l +++ " " +++ toString r +++ ")"
+// toString (GGPair bm l r) = "(PAIR " +++ toString l +++ " " +++ toString r +++ ")"
+//
+//ggtypemap :: (.a -> .b) (.b -> .a) u:(GGType .a) -> u:GGType .b
+//ggtypemap ab ba (GGBasicType t) = (GGBasicType t)
+//ggtypemap ab ba GGUnit = GGUnit
+//ggtypemap ab ba (GGObject bm i a) = GGObject {bm & ab=bm.ab o ba, ba=ab o bm.ba} i a
+//ggtypemap ab ba (GGRecord bm i a) = GGRecord {bm & ab=bm.ab o ba, ba=ab o bm.ba} i a
+//ggtypemap ab ba (GGCons bm i a) = GGCons {bm & ab=bm.ab o ba, ba=ab o bm.ba} i a
+//ggtypemap ab ba (GGField bm i a) = GGField {bm & ab=bm.ab o ba, ba=ab o bm.ba} i a
+//ggtypemap ab ba (GGEither bm l r) = GGEither {bm & ab=bm.ab o ba, ba=ab o bm.ba} l r
+//ggtypemap ab ba (GGPair bm l r) = GGPair {bm & ab=bm.ab o ba, ba=ab o bm.ba} l r
+//ggtypemap ab ba (GGArrow bm l r) = GGArrow {bm & ab=bm.ab o ba, ba=ab o bm.ba} l r
+//
+//bimap{|GGType|} ab ba t = ggtypemap ab ba t
+//
+//generic ggType a :: GGType a
+//ggType{|UNIT|} = GGUnit
+//ggType{|OBJECT of gtd|} f = GGObject bm gtd f
+//ggType{|CONS of gcd|} f = GGCons bm gcd f
+//ggType{|RECORD of grd|} f = GGRecord bm grd f
+//ggType{|FIELD of gfd|} f = GGField bm gfd f
+//ggType{|EITHER|} fl fr = GGEither bm fl fr
+//ggType{|PAIR|} fl fr = GGPair bm fl fr
+//
+//ggType{|Int|} = GGBasicType BTInt
+//ggType{|Bool|} = GGBasicType BTBool
+//ggType{|Real|} = GGBasicType BTReal
+//ggType{|Char|} = GGBasicType BTChar
+//ggType{|World|} = GGBasicType BTWorld
+//ggType{|Dynamic|} = GGBasicType BTDynamic
+//ggType{|File|} = GGBasicType BTFile
+//
+//ggType{|(->)|} fl fr = GGArrow bm fl fr
+////ggType{|[#]|} f = GGUList ULLazy f
+////ggType{|[#!]|} f = GGUList ULStrict f
+////ggType{|{}|} f = GGArray ALazy f
+////ggType{|{!}|} f = GGAray AStrict f
+////ggType{|{#}|} f = GGArray AUnboxed f
+////ggType{|{32#}|} f = GGArray APacked f
+//derive ggType []
repositories / clean-tests.git / commitdiff