Expose enabled language extensions to TH
[ghc.git] / compiler / typecheck / Inst.hs
index b91498f..fba320c 100644 (file)
@@ -6,29 +6,30 @@
 The @Inst@ type: dictionaries or method instances
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, MultiWayIf #-}
 
 module Inst (
-       deeplySkolemise,
-       deeplyInstantiate, instCall, instStupidTheta,
-       emitWanted, emitWanteds,
+       deeplySkolemise, deeplyInstantiate,
+       instCall, instDFunType, instStupidTheta,
+       newWanted, newWanteds,
 
        newOverloadedLit, mkOverLit,
 
        newClsInst,
        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
-       tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
+       tcExtendLocalInstEnv,
+       instCallConstraints, newMethodFromName,
        tcSyntaxName,
 
        -- Simple functions over evidence variables
-       tyVarsOfWC, tyVarsOfBag,
-       tyVarsOfCt, tyVarsOfCts,
+       tyCoVarsOfWC,
+       tyCoVarsOfCt, tyCoVarsOfCts,
     ) where
 
 #include "HsVersions.h"
 
 import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )
-import {-# SOURCE #-}   TcUnify( unifyType )
+import {-# SOURCE #-}   TcUnify( unifyType, noThing )
 
 import FastString
 import HsSyn
@@ -37,10 +38,11 @@ import TcRnMonad
 import TcEnv
 import TcEvidence
 import InstEnv
+import DataCon     ( dataConWrapId )
+import TysWiredIn  ( heqDataCon )
 import FunDeps
 import TcMType
 import Type
-import Coercion ( Role(..) )
 import TcType
 import HscTypes
 import Class( Class )
@@ -49,35 +51,24 @@ import Id
 import Name
 import Var      ( EvVar )
 import VarEnv
-import VarSet
 import PrelNames
 import SrcLoc
 import DynFlags
-import Bag
 import Util
 import Outputable
+import qualified GHC.LanguageExtensions as LangExt
+
 import Control.Monad( unless )
 import Data.Maybe( isJust )
 
 {-
 ************************************************************************
 *                                                                      *
-                Emitting constraints
+                Creating and emittind constraints
 *                                                                      *
 ************************************************************************
 -}
 
-emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
-emitWanteds origin theta = mapM (emitWanted origin) theta
-
-emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
-emitWanted origin pred
-  = do { loc <- getCtLoc origin
-       ; ev  <- newEvVar pred
-       ; emitSimple $ mkNonCanonical $
-             CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
-       ; return ev }
-
 newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
 -- Used when Name is the wired-in name for a wired-in class method,
 -- so the caller knows its type for sure, which should be of form
@@ -92,13 +83,12 @@ newMethodFromName origin name inst_ty
               -- meant to find whatever thing is in scope, and that may
               -- be an ordinary function.
 
-       ; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
-             (the_tv:rest) = tvs
-             subst = zipOpenTvSubst [the_tv] [inst_ty]
+       ; let ty = piResultTy (idType id) inst_ty
+             (theta, _caller_knows_this) = tcSplitPhiTy ty
+       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
+                 instCall origin [inst_ty] theta
 
-       ; wrap <- ASSERT( null rest && isSingleton theta )
-                 instCall origin [inst_ty] (substTheta subst theta)
-       ; return (mkHsWrap wrap (HsVar id)) }
+       ; return (mkHsWrap wrap (HsVar (noLoc id))) }
 
 {-
 ************************************************************************
@@ -135,7 +125,10 @@ ToDo: this eta-abstraction plays fast and loose with termination,
 
 deeplySkolemise
   :: TcSigmaType
-  -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
+  -> TcM ( HsWrapper
+         , [TyVar]     -- all skolemised variables
+         , [EvVar]     -- all "given"s
+         , TcRhoType)
 
 deeplySkolemise ty
   | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
@@ -188,6 +181,16 @@ deeplyInstantiate orig ty
             Instantiating a call
 *                                                                      *
 ************************************************************************
+
+Note [Handling boxed equality]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The solver deals entirely in terms of unboxed (primitive) equality.
+There should never be a boxed Wanted equality. Ever. But, what if
+we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality
+is boxed, so naive treatment here would emit a boxed Wanted equality.
+
+So we simply check for this case and make the right boxing of evidence.
+
 -}
 
 ----------------
@@ -216,25 +219,39 @@ instCallConstraints orig preds
        ; return (mkWpEvApps evs) }
   where
     go pred
-     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut
-     = do  { co <- unifyType ty1 ty2
+     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1
+     = do  { co <- unifyType noThing ty1 ty2
            ; return (EvCoercion co) }
+
+       -- Try short-cut #2
+     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred
+     , tc `hasKey` heqTyConKey
+     = do { co <- unifyType noThing ty1 ty2
+          ; return (EvDFunApp (dataConWrapId heqDataCon) args [EvCoercion co]) }
+
      | otherwise
-     = do { ev_var <- emitWanted modified_orig pred
-          ; return (EvId ev_var) }
-      where
-        -- Coercible constraints appear as normal class constraints, but
-        -- are aggressively canonicalized and manipulated during solving.
-        -- The final equality to solve may barely resemble the initial
-        -- constraint. Here, we remember the initial constraint in a
-        -- CtOrigin for better error messages. It's perhaps worthwhile
-        -- considering making this approach general, for other class
-        -- constraints, too.
-        modified_orig
-          | Just (Representational, ty1, ty2) <- getEqPredTys_maybe pred
-          = CoercibleOrigin ty1 ty2
-          | otherwise
-          = orig
+     = emitWanted orig pred
+
+instDFunType :: DFunId -> [DFunInstType]
+             -> TcM ( [TcType]      -- instantiated argument types
+                    , TcThetaType ) -- instantiated constraint
+-- See Note [DFunInstType: instantiating types] in InstEnv
+instDFunType dfun_id dfun_inst_tys
+  = do { (subst, inst_tys) <- go emptyTCvSubst dfun_tvs dfun_inst_tys
+       ; return (inst_tys, substTheta subst dfun_theta) }
+  where
+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy (idType dfun_id)
+
+    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
+    go subst [] [] = return (subst, [])
+    go subst (tv:tvs) (Just ty : mb_tys)
+      = do { (subst', tys) <- go (extendTCvSubst subst tv ty) tvs mb_tys
+           ; return (subst', ty : tys) }
+    go subst (tv:tvs) (Nothing : mb_tys)
+      = do { (subst', tv') <- tcInstTyVarX subst tv
+           ; (subst'', tys) <- go subst' tvs mb_tys
+           ; return (subst'', mkTyVarTy tv' : tys) }
+    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)
 
 ----------------
 instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
@@ -346,7 +363,7 @@ tcSyntaxName :: CtOrigin
 -- USED ONLY FOR CmdTop (sigh) ***
 -- See Note [CmdSyntaxTable] in HsExpr
 
-tcSyntaxName orig ty (std_nm, HsVar user_nm)
+tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm))
   | std_nm == user_nm
   = do rhs <- newMethodFromName orig std_nm ty
        return (std_nm, rhs)
@@ -355,8 +372,8 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do
     std_id <- tcLookupId std_nm
     let
         -- C.f. newMethodAtLoc
-        ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
-        sigma1          = substTyWith [tv] [ty] tau
+        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)
+        sigma1         = substTyWith [tv] [ty] tau
         -- Actually, the "tau-type" might be a sigma-type in the
         -- case of locally-polymorphic methods.
 
@@ -372,12 +389,12 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) = do
 syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
                -> TcRn (TidyEnv, SDoc)
 syntaxNameCtxt name orig ty tidy_env
-  = do { inst_loc <- getCtLoc orig
+  = do { inst_loc <- getCtLocM orig (Just TypeLevel)
        ; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
                           <+> ptext (sLit "(needed by a syntactic construct)")
                         , nest 2 (ptext (sLit "has the required type:")
                                   <+> ppr (tidyType tidy_env ty))
-                        , nest 2 (pprArisingAt inst_loc) ]
+                        , nest 2 (pprCtLoc inst_loc) ]
        ; return (tidy_env, msg) }
 
 {-
@@ -389,15 +406,18 @@ syntaxNameCtxt name orig ty tidy_env
 -}
 
 getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
+-- Construct the OverlapFlag from the global module flags,
+-- but if the overlap_mode argument is (Just m),
+--     set the OverlapMode to 'm'
 getOverlapFlag overlap_mode
   = do  { dflags <- getDynFlags
-        ; let overlap_ok    = xopt Opt_OverlappingInstances dflags
-              incoherent_ok = xopt Opt_IncoherentInstances  dflags
+        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags
+              incoherent_ok = xopt LangExt.IncoherentInstances  dflags
               use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                   , overlapMode   = x }
-              default_oflag | incoherent_ok = use Incoherent
-                            | overlap_ok    = use Overlaps
-                            | otherwise     = use NoOverlap
+              default_oflag | incoherent_ok = use (Incoherent "")
+                            | overlap_ok    = use (Overlaps "")
+                            | otherwise     = use (NoOverlap "")
 
               final_oflag = setOverlapModeMaybe default_oflag overlap_mode
         ; return final_oflag }
@@ -420,7 +440,21 @@ newClsInst overlap_mode dfun_name tvs theta clas tys
              -- Not sure if this is really the right place to do so,
              -- but it'll do fine
        ; oflag <- getOverlapFlag overlap_mode
-       ; return (mkLocalInstance dfun oflag tvs' clas tys') }
+       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'
+       ; dflags <- getDynFlags
+       ; warnIf (isOrphan (is_orphan inst) && wopt Opt_WarnOrphans dflags) (instOrphWarn inst)
+       ; return inst }
+
+instOrphWarn :: ClsInst -> SDoc
+instOrphWarn inst
+  = hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
+    $$ text "To avoid this"
+    $$ nest 4 (vcat possibilities)
+  where
+    possibilities =
+      text "move the instance declaration to the module of the class or of the type, or" :
+      text "wrap the type with a newtype and declare the instance on the new type." :
+      []
 
 tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
   -- Add new locally-defined instances
@@ -440,21 +474,6 @@ addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
 -- If overwrite_inst, then we can overwrite a direct match
 addLocalInst (home_ie, my_insts) ispec
    = do {
-         -- Instantiate the dfun type so that we extend the instance
-         -- envt with completely fresh template variables
-         -- This is important because the template variables must
-         -- not overlap with anything in the things being looked up
-         -- (since we do unification).
-             --
-             -- We use tcInstSkolType because we don't want to allocate fresh
-             --  *meta* type variables.
-             --
-             -- We use UnkSkol --- and *not* InstSkol or PatSkol --- because
-             -- these variables must be bindable by tcUnifyTys.  See
-             -- the call to tcUnifyTys in InstEnv, and the special
-             -- treatment that instanceBindFun gives to isOverlappableTyVar
-             -- This is absurdly delicate.
-
              -- Load imported instances, so that we report
              -- duplicates correctly
 
@@ -472,27 +491,26 @@ addLocalInst (home_ie, my_insts) ispec
                  | isGHCi    = deleteFromInstEnv home_ie ispec
                  | otherwise = home_ie
 
-               (_tvs, cls, tys) = instanceHead ispec
                -- If we're compiling sig-of and there's an external duplicate
                -- instance, silently ignore it (that's the instance we're
                -- implementing!)  NB: we still count local duplicate instances
                -- as errors.
                -- See Note [Signature files and type class instances]
-               global_ie
-                    | isJust (tcg_sig_of tcg_env) = emptyInstEnv
-                    | otherwise = eps_inst_env eps
-               inst_envs       = InstEnvs { ie_global  = global_ie
-                                          , ie_local   = home_ie'
-                                          , ie_visible = tcg_visible_orphan_mods tcg_env }
-               (matches, _, _) = lookupInstEnv inst_envs cls tys
-               dups            = filter (identicalClsInstHead ispec) (map fst matches)
-
-             -- Check functional dependencies
-         ; case checkFunDeps inst_envs ispec of
-             Just specs -> funDepErr ispec specs
-             Nothing    -> return ()
+               global_ie | isJust (tcg_sig_of tcg_env) = emptyInstEnv
+                         | otherwise = eps_inst_env eps
+               inst_envs = InstEnvs { ie_global  = global_ie
+                                    , ie_local   = home_ie'
+                                    , ie_visible = tcVisibleOrphanMods tcg_env }
+
+             -- Check for inconsistent functional dependencies
+         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec
+         ; unless (null inconsistent_ispecs) $
+           funDepErr ispec inconsistent_ispecs
 
              -- Check for duplicate instance decls.
+         ; let (_tvs, cls, tys) = instanceHead ispec
+               (matches, _, _)  = lookupInstEnv False inst_envs cls tys
+               dups             = filter (identicalClsInstHead ispec) (map fst matches)
          ; unless (null dups) $
            dupInstErr ispec (head dups)
 
@@ -578,40 +596,3 @@ addClsInstsErr herald ispecs
    -- The sortWith just arranges that instances are dislayed in order
    -- of source location, which reduced wobbling in error messages,
    -- and is better for users
-
-{-
-************************************************************************
-*                                                                      *
-        Simple functions over evidence variables
-*                                                                      *
-************************************************************************
--}
-
----------------- Getting free tyvars -------------------------
-tyVarsOfCt :: Ct -> TcTyVarSet
-tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi })     = extendVarSet (tyVarsOfType xi) tv
-tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
-tyVarsOfCt (CDictCan { cc_tyargs = tys })                = tyVarsOfTypes tys
-tyVarsOfCt (CIrredEvCan { cc_ev = ev })                  = tyVarsOfType (ctEvPred ev)
-tyVarsOfCt (CHoleCan { cc_ev = ev })                     = tyVarsOfType (ctEvPred ev)
-tyVarsOfCt (CNonCanonical { cc_ev = ev })                = tyVarsOfType (ctEvPred ev)
-
-tyVarsOfCts :: Cts -> TcTyVarSet
-tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
-
-tyVarsOfWC :: WantedConstraints -> TyVarSet
--- Only called on *zonked* things, hence no need to worry about flatten-skolems
-tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
-  = tyVarsOfCts simple `unionVarSet`
-    tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
-    tyVarsOfCts insol
-
-tyVarsOfImplic :: Implication -> TyVarSet
--- Only called on *zonked* things, hence no need to worry about flatten-skolems
-tyVarsOfImplic (Implic { ic_skols = skols
-                       , ic_given = givens, ic_wanted = wanted })
-  = (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
-    `delVarSetList` skols
-
-tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
-tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet