Implement QuantifiedConstraints
[ghc.git] / compiler / typecheck / TcPluginM.hs
index ecf8ed9..a112003 100644 (file)
@@ -3,7 +3,7 @@
 -- access select functions of the 'TcM', principally those to do with
 -- reading parts of the state.
 module TcPluginM (
-#ifdef GHCI
+#if defined(GHCI)
         -- * Basic TcPluginM functionality
         TcPluginM,
         tcPluginIO,
@@ -43,32 +43,34 @@ module TcPluginM (
         newWanted,
         newDerived,
         newGiven,
+        newCoercionHole,
 
         -- * Manipulating evidence bindings
         newEvVar,
         setEvBind,
-        getEvBindsTcPluginM,
-        getEvBindsTcPluginM_maybe
+        getEvBindsTcPluginM
 #endif
     ) where
 
-#ifdef GHCI
-import qualified TcRnMonad
-import qualified TcSMonad
-import qualified TcEnv
-import qualified TcMType
-import qualified Inst
-import qualified FamInst
+#if defined(GHCI)
+import GhcPrelude
+
+import qualified TcRnMonad as TcM
+import qualified TcSMonad  as TcS
+import qualified TcEnv     as TcM
+import qualified TcMType   as TcM
+import qualified FamInst   as TcM
 import qualified IfaceEnv
 import qualified Finder
 
 import FamInstEnv ( FamInstEnv )
 import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
-                  , unsafeTcPluginTcM, getEvBindsTcPluginM_maybe
+                  , unsafeTcPluginTcM, getEvBindsTcPluginM
                   , liftIO, traceTc )
 import TcMType    ( TcTyVar, TcType )
 import TcEnv      ( TcTyThing )
-import TcEvidence ( TcCoercion, EvTerm, EvBind, EvBindsVar, mkGivenEvBind )
+import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
+                  , EvExpr, EvBind, mkGivenEvBind )
 import TcRnTypes  ( CtEvidence(..) )
 import Var        ( EvVar )
 
@@ -83,7 +85,6 @@ import Type
 import Id
 import InstEnv
 import FastString
-import Maybes
 import Unique
 
 
@@ -106,62 +107,61 @@ lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod
 
 
 tcLookupGlobal :: Name -> TcPluginM TyThing
-tcLookupGlobal = unsafeTcPluginTcM . TcEnv.tcLookupGlobal
+tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal
 
 tcLookupTyCon :: Name -> TcPluginM TyCon
-tcLookupTyCon = unsafeTcPluginTcM . TcEnv.tcLookupTyCon
+tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon
 
 tcLookupDataCon :: Name -> TcPluginM DataCon
-tcLookupDataCon = unsafeTcPluginTcM . TcEnv.tcLookupDataCon
+tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon
 
 tcLookupClass :: Name -> TcPluginM Class
-tcLookupClass = unsafeTcPluginTcM . TcEnv.tcLookupClass
+tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass
 
 tcLookup :: Name -> TcPluginM TcTyThing
-tcLookup = unsafeTcPluginTcM . TcEnv.tcLookup
+tcLookup = unsafeTcPluginTcM . TcM.tcLookup
 
 tcLookupId :: Name -> TcPluginM Id
-tcLookupId = unsafeTcPluginTcM . TcEnv.tcLookupId
+tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId
 
 
 getTopEnv :: TcPluginM HscEnv
-getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv
+getTopEnv = unsafeTcPluginTcM TcM.getTopEnv
 
 getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
-getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs
+getEnvs = unsafeTcPluginTcM TcM.getEnvs
 
 getInstEnvs :: TcPluginM InstEnvs
-getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs
+getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs
 
 getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
-getFamInstEnvs = unsafeTcPluginTcM FamInst.tcGetFamInstEnvs
-
-matchFam :: TyCon -> [Type] -> TcPluginM (Maybe (TcCoercion, TcType))
-matchFam tycon args = unsafeTcPluginTcM $ TcSMonad.matchFamTcM tycon args
+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
 
+matchFam :: TyCon -> [Type]
+         -> TcPluginM (Maybe (TcCoercion, TcType))
+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
 
 newUnique :: TcPluginM Unique
-newUnique = unsafeTcPluginTcM TcRnMonad.newUnique
+newUnique = unsafeTcPluginTcM TcM.newUnique
 
 newFlexiTyVar :: Kind -> TcPluginM TcTyVar
-newFlexiTyVar = unsafeTcPluginTcM . TcMType.newFlexiTyVar
+newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar
 
 isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
-isTouchableTcPluginM = unsafeTcPluginTcM . TcRnMonad.isTouchableTcM
-
+isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM
 
+-- Confused by zonking? See Note [What is zonking?] in TcMType.
 zonkTcType :: TcType -> TcPluginM TcType
-zonkTcType = unsafeTcPluginTcM . TcMType.zonkTcType
+zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType
 
 zonkCt :: Ct -> TcPluginM Ct
-zonkCt = unsafeTcPluginTcM . TcMType.zonkCt
+zonkCt = unsafeTcPluginTcM . TcM.zonkCt
 
 
 -- | Create a new wanted constraint.
 newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence
-newWanted loc pty = do
-    new_ev <- newEvVar pty
-    return CtWanted { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
+newWanted loc pty
+  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)
 
 -- | Create a new derived constraint.
 newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
@@ -170,28 +170,27 @@ newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }
 -- | Create a new given constraint, with the supplied evidence.  This
 -- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it
 -- will panic.
-newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM CtEvidence
+newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence
 newGiven loc pty evtm = do
    new_ev <- newEvVar pty
-   setEvBind $ mkGivenEvBind new_ev evtm
+   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)
    return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }
 
 -- | Create a fresh evidence variable.
 newEvVar :: PredType -> TcPluginM EvVar
-newEvVar = unsafeTcPluginTcM . TcMType.newEvVar
+newEvVar = unsafeTcPluginTcM . TcM.newEvVar
+
+-- | Create a fresh coercion hole.
+newCoercionHole :: PredType -> TcPluginM CoercionHole
+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole
 
 -- | Bind an evidence variable.  This must not be invoked from
 -- 'tcPluginInit' or 'tcPluginStop', or it will panic.
 setEvBind :: EvBind -> TcPluginM ()
 setEvBind ev_bind = do
     tc_evbinds <- getEvBindsTcPluginM
-    unsafeTcPluginTcM $ TcMType.addTcEvBind tc_evbinds ev_bind
-
--- | Access the 'EvBindsVar' carried by the 'TcPluginM' during
--- constraint solving.  This must not be invoked from 'tcPluginInit'
--- or 'tcPluginStop', or it will panic.
-getEvBindsTcPluginM :: TcPluginM EvBindsVar
-getEvBindsTcPluginM = fmap (expectJust oops) getEvBindsTcPluginM_maybe
-  where
-    oops = "plugin attempted to read EvBindsVar outside the constraint solver"
+    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind
+#else
+-- this dummy import is needed as a consequence of NoImplicitPrelude
+import GhcPrelude ()
 #endif