+module gen
+
+import Control.Applicative
+import Control.Monad => qualified join
+import Control.Monad.State
+import Control.Monad.Writer
+import 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 Bool GType
+ | GTyUnit
+ | GTyEither GType GType
+ | GTyPair GType GType
+ | GTyCons GenericConsDescriptor GType
+ | GTyField GenericFieldDescriptor GType
+ | GTyObject GenericTypeDefDescriptor GType
+ | GTyRecord GenericRecordDescriptor GType
+class print a :: a [String] -> [String]
+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 GType
+where
+ print (GTyBasic s) c = [s:c]
+ print (GTyArrow l r) c = ["((->)":print l [" ":print r [")":c]]]
+ print (GTyArray s a) c = ["(", if s "!" "", "Array ":print a [")":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 _ a) c = ["(CONS ":print a [")":c]]
+ print (GTyField _ a) c = ["(FIELD ":print a [")":c]]
+ print (GTyObject _ a) c = ["(OBJECT ":print a [")":c]]
+ print (GTyRecord _ a) c = ["(RECORD ":print a [")":c]]
+
+:: Type
+ = TyBasic String
+ | TyArrow Type Type
+ | TyArray Bool Type
+ | TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
+ | TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
+ | TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
+instance print Type
+where
+ print (TyBasic s) c = [s:c]
+ print (TyArrow l r) c = print l [" -> ":print r c]
+ print (TyArray s a) c = ["{", if 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]]]
+
+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 (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
+
+flattenGType :: GType -> [GType]
+flattenGType t = execWriter $ evalStateT (mkf t) []
+where
+ add :: (g GType -> GType) g GType -> StateT [String] (WriterT [GType] Identity) GType | genericDescriptorName g
+ add cons t a = gets (isMember $ genericDescriptorName t) >>= \b->if b
+ (pure $ GTyBasic $ genericDescriptorName t)
+ (cons t <$ modify (\x->[genericDescriptorName t:x]) <*> mkf a
+ >>= \ty->liftT (tell [ty]) >>| add cons t a)
+
+ mkf :: GType -> StateT [String] (WriterT [GType] Identity) GType
+ mkf (GTyObject t a) = add GTyObject t a
+ mkf (GTyRecord t a) = add 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 t = pure t
+
+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 $ GTyArray False $ unBox a
+type{|{!}|} a = box $ GTyArray True $ 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 [], Either, Maybe, T, R, Frac, Tr, (,)
+
+:: T a =: T2 a
+:: R a = {f1 :: Maybe (R a), f2 :: Bool, f3 :: T a, f4 :: Char -> Dynamic}
+
+:: 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
+
+t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool)
+t = type{|*|}