NewTiMonad.hs

module NewTiMonad(
   IM,--TI,KI,
   KEnv,
   getEnv,getTEnv,getKEnv,getIEnv,getModule,getDefaults,
   extendts,extend,extend1,extendkts,extendEnv,extendIEnv,inModule,inEnv,
   env,kenv,sch,kindOf,constrain,getConstraints,
   (>:),errmap,freshInt
  ) where
import HsIdent(HsIdentI)
import HsName(ModuleName(..))
import TiTypes
--import TiKinds(Kind,TypeInfo{-,KindConstraint-})
import TiEnv(lookup,extenv1,extenv)
import qualified TiEnv(Env,empty)
import TiInstanceDB(IDB,emptyIdb,extendIdb)
import TiConstraints(Constraints,empty,single,merge)
import MUtils
import Lift
import PrettyPrint(pp)

import MT(MT(..))
import OutputMT
import StateMT
import EnvMT
import ExceptM

import qualified Tree

type TEnv i = TiEnv.Env (HsIdentI i) (Scheme i) -- type of value identifiers
type KEnv i = TiEnv.Env (HsIdentI i) (Kind,TypeInfo i)   -- kind of type identifiers

data TiEnv i  = Env { inMod::FilePath->ModuleName,
		      monomorph::Bool, -- use the monomorpism restriction?
		      defaults::[[Type i]], -- from all default(t1,...,t2)
		      kenv::KEnv i,
		      tenv::TEnv i,
		      idb::IDB i }

emptyEnv = Env (const (Module "nomodule")) True [] TiEnv.empty TiEnv.empty emptyIdb

-- IM should really be an abstract type!
type IM i c = WithOutput c 
            ( WithEnv (TiEnv i) 
            ( WithState Unique
            ( ExceptM Error ))) 

--type TI i   = IM i (TypeConstraint i)
--type KI i   = IM i KindConstraint
type Error  = String
type Unique = [Int]


errmap f m = do e <- getEnv
                s <- getSt
                case withStS s (withEnv e (removeOutput m)) of
                  Left x -> raise (f x)
                  Right ((a,t),s) -> setSt_ s >> outputTree t >> return a

run :: TiEnv i -> IM i c a -> Either Error a
run env = removeExcept . withSt [1..] . withEnv env . fmap fst . removeOutput

instance Monad m => Lift (IM i c) m where
  lift = either fail return . run emptyEnv

getConstraints :: IM i c a -> IM i d (a, Tree.T c)
getConstraints m = MT.lift (removeOutput m)

typeError :: Error -> IM i c a
typeError err = raise err

constrain :: c -> IM i c ()
constrain c = output c

modEnv :: (TiEnv i -> TiEnv i) -> IM i c a -> IM i c a
modEnv f  = inModEnv f
modTEnv f = modEnv (\env@Env{tenv=e}->env{tenv=f e})
modKEnv f = modEnv (\env@Env{kenv=e}->env{kenv=f e})
modIEnv f = modEnv (\env@Env{idb=e}->env{idb=f e})

getTEnv :: IM i c (TEnv i)
getTEnv = tenv # getEnv

getKEnv :: IM i c (KEnv i)
getKEnv = kenv # getEnv

getIEnv :: IM i c (IDB i)
getIEnv = idb # getEnv

getModule :: IM i c (FilePath->ModuleName)
getModule = inMod # getEnv

getDefaults :: IM i c [[Type i]]
getDefaults = defaults # getEnv

extend1 x t = modTEnv (extenv1 x t)
extend x    = modTEnv (extenv x)
extendts ts = extend [(x,t)|x:>:t<-ts]

extendk1 x t  = modKEnv (extenv1 x t)
extendk x     = modKEnv (extenv x)
extendkts ts  = extendk [(x,t)|x:>:t<-ts]

extendEnv (ks, ts) = extendkts ks . extendts ts
extendEnv' (ks, ts) = extendk ks . extend ts

extendIEnv x  = modIEnv (extendIdb x)

inModule m d = modEnv (\env->env{inMod=m,defaults=d})

env proj x =
  do env <- getEnv
     case TiEnv.lookup (proj env) x of
       Nothing -> typeError ("Not in scope: "++pp x{-++" in "++show (proj env)-})
       Just sch -> return sch

sch x = env tenv x
kindOf x = fst # env kenv x

freshInt :: IM i c Int
freshInt = head # updSt tail

infix 4 >:
(>:) :: e -> t -> IM i c (Typing e t)
e >: t = return (e :>: t)