TiClasses.hs

module TiClasses where
import TiMonad(TI,KI)
import TiTypes
import TiKinds
import List(nub)
import MUtils

type TypedDecls i ds = Typing ds (DeclsType i)
type DeclsType i = ([Typing (HsIdentI i) (Kind,TypeInfo i)],[Assump i])
(xs1,ys1)+++(xs2,ys2) = (xs1++xs2,ys1++ys2)

class AddDeclsType i d | d->i where
  addDeclsType :: DeclsType i -> d -> d
  addDeclsType _ d = d

{-
Although their syntax are different, and they are type checked differently,
the base syntax uses *the same* type for, top level declarations,
local declarations, declarations in class definitions and declarations
in instance definitions. Obviously we can't use the same overloaded function
for type checking all of them...
-}
type CheckDecls i s r = s -> TI i (TypedDecls i r)

class TypeCheckDecls i s r {-| s->r-} where
  tcTopDecls, tcInstDecls --,tcLocalDecls' --, tcClassDecls
    :: CheckDecls i s r
  --tcLocalDecls' = tcTopDecls

class TypeCheckDecl i s r where
  tcDecl :: [Assump i] -> s -> TI i r

tcLocalDecls ds = fmap snd # tcTopDecls ds -- discard kind env

class TypeCheck i s r {-| s->r-} where tc :: s -> TI i r
class KindCheck i t r | t->r where kc :: t -> KI i r

{-
instance KindCheck t r=> KindCheck [t] [r] where
  kc = mapM kc
  
instance (KindCheck t1 r1,
	  KindCheck t2 r2) => KindCheck (t1,t2) (r1,r2) where
  kc (t1,t2) = (,) # kc t1 <# kc t2
-}
--instance TypeCheck s r => TypeCheck [s] [r] where tc = mapM tc

class HasId i e | e->i where
  ident :: HsIdentI i -> e
  isId :: e -> Maybe (HsIdentI i)

var x = ident (HsVar x)

isVar e = do HsVar x <- isId e
	     return x

class HasId i e => HasCoreSyntax i e | e->i where
  app :: e -> e -> e
  tuple,list :: [e] -> e
--paren :: e -> e

class HasCoreSyntax i e => HasTypeApp i e | e->i where
  spec :: HsIdentI i -> [Type i] -> e

class HasAbstr i e | e->i where
  abstract :: [i] -> e -> e

class (HasAbstr i s) => HasLocalDef i e s | s->e i where
  letvar :: Typing i (Type i) -> e -> s -> s

--letvar x e1 e2 = abstract [x] e2 `app` e1

instance HasAbstr i e => HasAbstr i [e] where
  abstract = map . abstract

instance HasLocalDef i e s => HasLocalDef i e [s] where
  letvar x e1 = map (letvar x e1)

class HasDef ds d | ds->d where
  noDef :: ds
  consDef :: d -> ds -> ds
  appendDef :: ds -> ds -> ds
  toDefs :: [d] -> ds

  toDefs = foldr consDef noDef

--class Decorate s i where decorate :: i -> s -> s