Implement QuantifiedConstraints
[ghc.git] / compiler / typecheck / TcPluginM.hs
index 9ba89cc..a112003 100644 (file)
@@ -3,15 +3,19 @@
 -- 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,
         tcPluginTrace,
         unsafeTcPluginTcM,
 
-        -- * Lookup
-        lookupRdrName,
+        -- * Finding Modules and Names
+        FindResult(..),
+        findImportedModule,
+        lookupOrig,
+
+        -- * Looking up Names in the typechecking environment
         tcLookupGlobal,
         tcLookupTyCon,
         tcLookupDataCon,
@@ -24,42 +28,64 @@ module TcPluginM (
         getEnvs,
         getInstEnvs,
         getFamInstEnvs,
+        matchFam,
 
         -- * Type variables
+        newUnique,
         newFlexiTyVar,
         isTouchableTcPluginM,
 
         -- * Zonking
         zonkTcType,
-        zonkCt
+        zonkCt,
+
+        -- * Creating constraints
+        newWanted,
+        newDerived,
+        newGiven,
+        newCoercionHole,
+
+        -- * Manipulating evidence bindings
+        newEvVar,
+        setEvBind,
+        getEvBindsTcPluginM
 #endif
     ) where
 
-#ifdef GHCI
-import qualified TcRnMonad
-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, TcPluginM
-                  , unsafeTcPluginTcM, liftIO, traceTc )
+import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM
+                  , unsafeTcPluginTcM, getEvBindsTcPluginM
+                  , liftIO, traceTc )
 import TcMType    ( TcTyVar, TcType )
 import TcEnv      ( TcTyThing )
+import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)
+                  , EvExpr, EvBind, mkGivenEvBind )
+import TcRnTypes  ( CtEvidence(..) )
+import Var        ( EvVar )
 
 import Module
 import Name
-import RdrName
 import TyCon
 import DataCon
 import Class
 import HscTypes
 import Outputable
 import Type
-import DynamicLoading
 import Id
 import InstEnv
+import FastString
+import Unique
 
 
 -- | Perform some IO, typically to interact with an external tool.
@@ -71,53 +97,100 @@ tcPluginTrace :: String -> SDoc -> TcPluginM ()
 tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
 
 
-lookupRdrName :: ModuleName -> RdrName -> TcPluginM (Maybe Name)
-lookupRdrName mod rdr = do
-  hsc_env <- getTopEnv
-  tcPluginIO $ lookupRdrNameInModuleForPlugins hsc_env mod rdr
+findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult
+findImportedModule mod_name mb_pkg = do
+    hsc_env <- getTopEnv
+    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg
+
+lookupOrig :: Module -> OccName -> TcPluginM Name
+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
+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs
+
+matchFam :: TyCon -> [Type]
+         -> TcPluginM (Maybe (TcCoercion, TcType))
+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args
 
+newUnique :: TcPluginM Unique
+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
+  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)
+
+-- | Create a new derived constraint.
+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence
+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 -> EvExpr -> TcPluginM CtEvidence
+newGiven loc pty evtm = do
+   new_ev <- newEvVar pty
+   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 . 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 $ TcM.addTcEvBind tc_evbinds ev_bind
+#else
+-- this dummy import is needed as a consequence of NoImplicitPrelude
+import GhcPrelude ()
 #endif