module Types where 


import Prelude hiding (maybe, either)
import List (union)


data Kind = KStar | KArrow Kind Kind
            deriving (Eq)


instance Show Kind where 
  show KStar = "*"
  show (KArrow k1 k2) = show k1 ++ " -> " ++ show k2


(->*) a b = KArrow a b
infixr 4 ->*



type Var = String 

data Type = TVar Var 
          | TCtor String Kind
          | TList Type
          | TFunc Type Type 
          | TPair Type Type 
          | TAppl Type Type 
            deriving (Eq)


instance Show Type where 
  show (TVar s) = s
  show (TCtor s _) = s
  show (TList t) = "[" ++ show t ++ "]"
  show (TFunc t1@(TFunc _ _) t2) = "(" ++ show t1 ++ ")" ++ " -> " ++ show t2
  show (TFunc t1 t2) = show t1 ++ " -> " ++ show t2 
  show (TPair t1 t2) = "(" ++ show t1 ++ ", " ++ show t2 ++ ")"
  show (TAppl t1 t2@(TFunc _ _)) = show t1 ++ " (" ++ show t2 ++ ")"
  show (TAppl t1 t2) = show t1 ++ " " ++ show t2 


kind :: Type -> Kind
kind (TVar _)     = KStar
kind (TCtor _ k)  = k
kind (TList _)    = KStar
kind (TFunc _ _)  = KStar
kind (TAppl t1 _)  = case kind t1 of
                        KArrow k' k -> k

vars :: Type -> [Var]
vars (TVar v)      = [v]
vars (TList t)     = vars t
vars (TFunc t1 t2) = vars t1 `union` vars t2
vars (TAppl t1 t2) = vars t1 `union` vars t2
vars _             = []


tfmap f (TVar v)      = TVar $ f v
tfmap f (TList t)     = TList $ tfmap f t
tfmap f (TFunc t1 t2) = TFunc (tfmap f t1) (tfmap f t2)
tfmap f (TAppl t1 t2) = TAppl (tfmap f t1) (tfmap f t2)
tfmap f t             = t


unit = TCtor "()" KStar
bool = TCtor "Bool" KStar
char = TCtor "Char" KStar
int = TCtor "Int" KStar
integer = TCtor "Integer" KStar
double = TCtor "Double" KStar
float = TCtor "Float" KStar
string = list char
filepath = list char
ordering = TCtor "Ordering" KStar
ioerror = TCtor "IOError" KStar


a = TVar "a" ; b = TVar "b" ; c = TVar "c" ; d = TVar "d" ; e = TVar "e" ; f = TVar "f"
g = TVar "g" ; h = TVar "h" ; i = TVar "i" ; j = TVar "j" ; k = TVar "k" ; l = TVar "l"
m = TVar "m" ; n = TVar "n" ; o = TVar "o" ; p = TVar "p" ; q = TVar "q" ; r = TVar "r"
s = TVar "s" ; t = TVar "t" ; u = TVar "u" ; v = TVar "v" ; w = TVar "w" ; x = TVar "x"
y = TVar "y" ; z = TVar "z"


(->:) a b = TFunc a b
infixr 4 ->:

list a = TList a 

pair a b = TPair a b

maybe a = TAppl (TCtor "Maybe" $ KStar ->* KStar) a
io a = TAppl (TCtor "IO" $ KStar ->* KStar) a
either a b = TAppl (TAppl (TCtor "Either" $ KStar ->* KStar ->* KStar) a) b