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 ArrayType GType
	| GTyUnit
	| GTyEither GType GType
	| GTyPair GType GType
	| GTyCons GenericConsDescriptor GType
	| GTyField GenericFieldDescriptor GType
	| GTyObject GenericTypeDefDescriptor GType
	| GTyRecord GenericRecordDescriptor GType
:: ArrayType = ATStrict | ATLazy | ATBoxed
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 ArrayType
where
	print ATStrict c = ["!":c]
	print ATBoxed c = ["#":c]
	print ATLazy 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 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 ArrayType Type
	| TyNewType GenericTypeDefDescriptor GenericConsDescriptor Type
	| TyObject GenericTypeDefDescriptor [(GenericConsDescriptor, [Type])]
	| TyRecord GenericRecordDescriptor [(GenericFieldDescriptor, Type)]
instance print Type
where
	print (TyBasic s) c = [case s of
			"_List"   = "[]"
			"_!List"  = "[! ]"
			"_List!"  = "[ !]"
			"_!List!" = "[!!]"
			"_#List"  = "[#]"
			"_#List!" = "[#!]"
			"_Array"  = "{}"
			"_!Array" = "{!}"
			"_#Array" = "{#}"
			_ = s:c]
	print (TyArrow l r) c = print l [" -> ":print r c]
	print (TyArray 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]]]

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 ATLazy $ unBox a
type{|{!}|} a = box $ GTyArray ATStrict $ unBox a
type{|{#}|} a = box $ GTyArray ATBoxed $ unBox a
type{|[#]|} a = box $ GTyArray ATBoxed $ unBox a
type{|[#!]|} a = box $ GTyArray ATBoxed $ 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,
	f5 :: [([!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

t :: Box GType ([Either (R (T *World)) (Frac Real)], Tr Either Bool)
t = type{|*|}