From f189214cbbeb6ba06c5fe562189159695fb79a19 Mon Sep 17 00:00:00 2001
From: Mart Lubbers <mart@martlubbers.net>
Date: Thu, 9 Jul 2020 15:28:30 +0200
Subject: [PATCH] gengen

---
 gengen/Data/GenType.dcl       |  90 +++++++++
 gengen/Data/GenType.icl       | 354 ++++++++++++++++++++++++++++++++++
 gengen/Data/GenType/CType.dcl |   9 +
 gengen/Data/GenType/CType.icl | 126 ++++++++++++
 gengen/gen.icl                | 295 ----------------------------
 gengen/gengen.hs              |  12 ++
 gengen/test.hs                |  10 +
 gengen/test.icl               | 173 ++++++++++++-----
 8 files changed, 725 insertions(+), 344 deletions(-)
 create mode 100644 gengen/Data/GenType.dcl
 create mode 100644 gengen/Data/GenType.icl
 create mode 100644 gengen/Data/GenType/CType.dcl
 create mode 100644 gengen/Data/GenType/CType.icl
 delete mode 100644 gengen/gen.icl
 create mode 100644 gengen/gengen.hs
 create mode 100644 gengen/test.hs

diff --git a/gengen/Data/GenType.dcl b/gengen/Data/GenType.dcl
new file mode 100644
index 0000000..8bef27a
--- /dev/null
+++ b/gengen/Data/GenType.dcl
@@ -0,0 +1,90 @@
+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 (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
diff --git a/gengen/Data/GenType.icl b/gengen/Data/GenType.icl
new file mode 100644
index 0000000..64b804d
--- /dev/null
+++ b/gengen/Data/GenType.icl
@@ -0,0 +1,354 @@
+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 (), (,), (,,), (,,,), (,,,,), (,,,,,), (,,,,,,), (,,,,,,,)
diff --git a/gengen/Data/GenType/CType.dcl b/gengen/Data/GenType/CType.dcl
new file mode 100644
index 0000000..b79c58e
--- /dev/null
+++ b/gengen/Data/GenType/CType.dcl
@@ -0,0 +1,9 @@
+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]
diff --git a/gengen/Data/GenType/CType.icl b/gengen/Data/GenType/CType.icl
new file mode 100644
index 0000000..d8ba99b
--- /dev/null
+++ b/gengen/Data/GenType/CType.icl
@@ -0,0 +1,126 @@
+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"]
diff --git a/gengen/gen.icl b/gengen/gen.icl
deleted file mode 100644
index ac1d0b3..0000000
--- a/gengen/gen.icl
+++ /dev/null
@@ -1,295 +0,0 @@
-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{|*|}
diff --git a/gengen/gengen.hs b/gengen/gengen.hs
new file mode 100644
index 0000000..7b44a72
--- /dev/null
+++ b/gengen/gengen.hs
@@ -0,0 +1,12 @@
+{-# 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 ""
diff --git a/gengen/test.hs b/gengen/test.hs
new file mode 100644
index 0000000..72985ff
--- /dev/null
+++ b/gengen/test.hs
@@ -0,0 +1,10 @@
+{-# 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 ""
diff --git a/gengen/test.icl b/gengen/test.icl
index 86a0281..27fcd7d 100644
--- a/gengen/test.icl
+++ b/gengen/test.icl
@@ -2,52 +2,127 @@ module test
 
 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 []
-- 
2.20.1