Propagate CtOrigins for better errors
authorRichard Eisenberg <eir@cis.upenn.edu>
Tue, 4 Aug 2015 15:47:18 +0000 (11:47 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Tue, 4 Aug 2015 15:47:18 +0000 (11:47 -0400)
compiler/hsSyn/HsExpr.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcExpr.hs-boot
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcMatches.hs-boot
compiler/typecheck/TcPat.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcUnify.hs

index c3b40c0..baa4f0c 100644 (file)
@@ -1137,11 +1137,11 @@ isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
 
 -- | Is there only one RHS in this group?
-isSingletonMatchGroup :: MatchGroup id body -> Bool
-isSingletonMatchGroup (MG { mg_alts = [match] })
+singletonMatchGroup_maybe :: MatchGroup id body -> Maybe (LMatch id body)
+singletonMatchGroup_maybe (MG { mg_alts = [match] })
   | L _ (Match { m_grhss = GRHSs { grhssGRHSs = [_] } }) <- match
-  = True
-isSingletonMatchGroup _ = False
+  = Just match
+singletonMatchGroup_maybe _ = Nothing
 
 matchGroupArity :: MatchGroup id body -> Arity
 -- Precondition: MatchGroup is non-empty
index f5edfa9..a2efd10 100644 (file)
@@ -5,11 +5,11 @@
 Typecheck arrow notation
 -}
 
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes, TupleSections #-}
 
 module TcArrows ( tcProc ) where
 
-import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferSigma, tcSyntaxOp, tcCheckId, tcPolyExpr )
+import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )
 
 import HsSyn
 import TcMatches
@@ -144,13 +144,15 @@ tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty
 
 tc_cmd env in_cmd@(HsCmdCase scrut matches _) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
-      (scrut', scrut_ty) <- tcInferSigma scrut
-      (wrap, matches') <- tcMatchesCase match_ctxt scrut_ty matches res_ty
+      (scrut', scrut_ty) <- tcInferRho scrut
+      (wrap, matches', _orig)
+        <- tcMatchesCase match_ctxt scrut_ty matches res_ty
       return (HsCmdCase scrut' matches' wrap)
   where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = mc_body }
-    mc_body body res_ty' = tcCmd env body (stk, res_ty')
+    mc_body body res_ty' = (, Shouldn'tHappenOrigin) <$>
+                           tcCmd env body (stk, res_ty')
 
 tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do  { pred' <- tcMonoExpr pred boolTy
index d0baa17..53c3651 100644 (file)
@@ -522,7 +522,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
        ; mono_ids' <- mapM tc_mono_info mono_infos
        ; return (binds', mono_ids') }
   where
-    tc_mono_info (name, _, mono_id)
+    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })
       = do { mono_ty' <- zonkTcType (idType mono_id)
              -- Zonk, mainly to expose unboxed types to checkStrictBinds
            ; let mono_id' = setIdType mono_id mono_ty'
@@ -564,11 +564,10 @@ tcPolyCheck rec_tc prag_fn
        ; spec_prags <- tcSpecPrags poly_id prag_sigs
        ; poly_id    <- addInlinePrags poly_id prag_sigs
 
-       ; let (_, _, mono_id) = mono_info
-             export = ABE { abe_wrap      = idHsWrapper
+       ; let export = ABE { abe_wrap      = idHsWrapper
                           , abe_inst_wrap = idHsWrapper
                           , abe_poly      = poly_id
-                          , abe_mono      = mono_id
+                          , abe_mono      = mbi_mono_id mono_info
                           , abe_prags     = SpecPrags spec_prags }
              abs_bind = L loc $ AbsBinds
                         { abs_tvs = tvs
@@ -648,15 +647,15 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list
              do { (binds', mono_infos)
                     <- tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
                   -- See Note [Instantiate when inferring a type]
-                ; mono_tys <- mapM (zonkTcType . idType . thirdOf3) mono_infos
+                ; mono_tys <- mapM (zonkTcType . idType . mbi_mono_id) mono_infos
+                ; let origs = map mbi_orig mono_infos
                     -- NB: zonk to uncover any foralls
                 ; (wrappers, insted_tys)
-                         -- TODO (RAE): Fix origin
-                    <- mapAndUnzipM (deeplyInstantiate AppOrigin) mono_tys
+                    <- zipWithAndUnzipM deeplyInstantiate origs mono_tys
                 ; return (binds', mono_infos, wrappers, insted_tys) }
 
-       ; let name_taus = [(name, tau) | ((name, _, _), tau)
-                                          <- zip mono_infos insted_tys]
+       ; let name_taus = [ (mbi_poly_name info, tau)
+                         | (info, tau) <- zip mono_infos insted_tys]
        ; traceTc "simplifyInfer call" (ppr name_taus $$ ppr wanted)
        ; (qtvs, givens, _mr_bites, ev_binds)
                  <- simplifyInfer tclvl mono name_taus wanted
@@ -698,7 +697,10 @@ mkExport :: PragFun
 
 -- Pre-condition: the qtvs and theta are already zonked
 
-mkExport prag_fn qtvs inferred_theta (poly_name, mb_sig, mono_id)
+mkExport prag_fn qtvs inferred_theta
+         (MBI { mbi_poly_name = poly_name
+              , mbi_sig       = mb_sig
+              , mbi_mono_id   = mono_id })
          inst_wrap inst_ty
   = do  { inst_ty <- zonkTcType inst_ty
 
@@ -1352,33 +1354,43 @@ tcMonoBinds is_rec sig_fn no_gen
     setSrcSpan b_loc    $
     do  { rhs_ty  <- newReturnTyVarTy openTypeKind
         ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
-        ; (co_fn, matches') <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
-                                 -- We extend the error context even for a non-recursive
-                                 -- function so that in type error messages we show the
-                                 -- type of the thing whose rhs we are type checking
-                               tcMatchesFun name inf matches rhs_ty
+        ; (co_fn, matches', orig)
+            <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
+                  -- We extend the error context even for a non-recursive
+                  -- function so that in type error messages we show the
+                  -- type of the thing whose rhs we are type checking
+               tcMatchesFun name inf matches rhs_ty
 
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
                                fun_matches = matches', bind_fvs = fvs,
                                fun_co_fn = co_fn, fun_tick = [] },
-                  [(name, Nothing, mono_id)]) }
+                  [MBI { mbi_poly_name = name
+                       , mbi_sig       = Nothing
+                       , mbi_mono_id   = mono_id
+                       , mbi_orig      = orig }]) }
 
 tcMonoBinds _ sig_fn no_gen binds
   = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
 
         -- Bring the monomorphic Ids, into scope for the RHSs
         ; let mono_info  = getMonoBindInfo tc_binds
-              rhs_id_env = [(name, mono_id) | (name, mb_sig, mono_id) <- mono_info
+              rhs_id_env = [(name, mono_id) | MBI { mbi_poly_name = name
+                                                  , mbi_sig       = mb_sig
+                                                  , mbi_mono_id   = mono_id }
+                                                    <- mono_info
                                             , noCompleteSig mb_sig ]
                     -- A monomorphic binding for each term variable that lacks
                     -- a type sig.  (Ones with a sig are already in scope.)
 
         ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
                                        | (n,id) <- rhs_id_env]
-        ; binds' <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
-                    mapM (wrapLocM tcRhs) tc_binds
-        ; return (listToBag binds', mono_info) }
+        ; (binds', origss) <- tcExtendLetEnvIds NotTopLevel rhs_id_env $
+                              mapAndUnzipM (wrapLocFstM tcRhs) tc_binds
+        ; let info_origs = zipEqual "tcMonoBinds" mono_info (concat origss)
+              mono_info' = [ info { mbi_orig = orig }
+                           | (info, orig) <- info_origs ]
+        ; return (listToBag binds', mono_info') }
 
 ------------------------
 -- tcLhs typechecks the LHS of the bindings, to construct the environment in which
@@ -1400,9 +1412,11 @@ data TcMonoBind         -- Half completed; LHS done, RHS not done
   = TcFunBind  MonoBindInfo  SrcSpan Bool (MatchGroup Name (LHsExpr Name))
   | TcPatBind [MonoBindInfo] (LPat TcId) (GRHSs Name (LHsExpr Name)) TcSigmaType
 
-type MonoBindInfo = (Name, Maybe TcSigInfo, TcId)
-        -- Type signature (if any), and
-        -- the monomorphic bound things
+data MonoBindInfo = MBI { mbi_poly_name :: Name
+                        , mbi_sig       :: Maybe TcSigInfo
+                        , mbi_mono_id   :: TcId
+                        , mbi_orig      :: CtOrigin }
+                               -- origin associated with RHS
 
 tcLhs :: TcSigFun -> LetBndrSpec -> HsBind Name -> TcM TcMonoBind
 tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matches = matches })
@@ -1417,12 +1431,20 @@ tcLhs sig_fn no_gen (FunBind { fun_id = L nm_loc name, fun_infix = inf, fun_matc
         ; let mono_id = mkLocalId mono_name (sig_tau sig) HasSigId
         ; addErrCtxt (typeSigCtxt sig) $
           emitWildcardHoleConstraints (sig_nwcs sig)
-        ; return (TcFunBind (name, Just sig, mono_id) nm_loc inf matches) }
+        ; return (TcFunBind (MBI { mbi_poly_name = name
+                                 , mbi_sig       = Just sig
+                                 , mbi_mono_id   = mono_id
+                                 , mbi_orig      = Shouldn'tHappenOrigin })
+                            nm_loc inf matches) }
 
   | otherwise
   = do  { mono_ty <- newFlexiTyVarTy openTypeKind
         ; mono_id <- newNoSigLetBndr no_gen name mono_ty
-        ; return (TcFunBind (name, Nothing, mono_id) nm_loc inf matches) }
+        ; return (TcFunBind (MBI { mbi_poly_name = name
+                                 , mbi_sig       = Nothing
+                                 , mbi_mono_id   = mono_id
+                                 , mbi_orig      = Shouldn'tHappenOrigin })
+                            nm_loc inf matches) }
 
 -- TODO: emit Hole Constraints for wildcards
 tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
@@ -1432,8 +1454,12 @@ tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })
                 -- After typechecking the pattern, look up the binder
                 -- names, which the pattern has brought into scope.
               lookup_info :: Name -> TcM MonoBindInfo
-              lookup_info name = do { mono_id <- tcLookupId name
-                                    ; return (name, sig_fn name, mono_id) }
+              lookup_info name
+                = do { mono_id <- tcLookupId name
+                     ; return (MBI { mbi_poly_name = name
+                                   , mbi_sig       = sig_fn name
+                                   , mbi_mono_id   = mono_id
+                                   , mbi_orig      = Shouldn'tHappenOrigin }) }
 
         ; ((pat', infos), pat_ty) <- addErrCtxt (patMonoBindsCtxt pat grhss) $
                                      tcInfer tc_pat
@@ -1444,18 +1470,22 @@ tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)
         -- AbsBind, VarBind impossible
 
 -------------------
-tcRhs :: TcMonoBind -> TcM (HsBind TcId)
-tcRhs (TcFunBind info@(_, mb_sig, mono_id) loc inf matches)
+-- the list of CtOrigin return correspond to the MonoBindInfo(s) in the
+-- provided TcMonoBind
+tcRhs :: TcMonoBind -> TcM (HsBind TcId, [CtOrigin])
+tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
+                 loc inf matches)
   = tcExtendForRhs [info]                           $
     tcExtendTyVarEnv2 (lexically_scoped_tvs mb_sig) $
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
-        ; (co_fn, matches') <- tcMatchesFun (idName mono_id) inf
-                                            matches (idType mono_id)
-        ; return (FunBind { fun_id = L loc mono_id, fun_infix = inf
-                          , fun_matches = matches'
-                          , fun_co_fn = co_fn
-                          , bind_fvs = placeHolderNamesTc
-                          , fun_tick = [] }) }
+        ; (co_fn, matches', orig) <- tcMatchesFun (idName mono_id) inf
+                                                  matches (idType mono_id)
+        ; return ( FunBind { fun_id = L loc mono_id, fun_infix = inf
+                           , fun_matches = matches'
+                           , fun_co_fn = co_fn
+                           , bind_fvs = placeHolderNamesTc
+                           , fun_tick = [] }
+                 , [orig] ) }
     where
       lexically_scoped_tvs :: Maybe TcSigInfo -> [(Name, TcTyVar)]
       lexically_scoped_tvs (Just (TcSigInfo { sig_tvs = user_tvs, sig_nwcs = hole_tvs }))
@@ -1469,11 +1499,13 @@ tcRhs (TcPatBind infos pat' grhss pat_ty)
     -- That's why we have the special case for a single FunBind in tcMonoBinds
     tcExtendForRhs infos        $
     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)
-        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
-                    tcGRHSsPat grhss pat_ty
-        ; return (PatBind { pat_lhs = pat', pat_rhs = grhss', pat_rhs_ty = pat_ty
-                          , bind_fvs = placeHolderNamesTc
-                          , pat_ticks = ([],[]) }) }
+        ; (grhss', orig) <- addErrCtxt (patMonoBindsCtxt pat' grhss) $
+                            tcGRHSsPat grhss pat_ty
+        ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'
+                           , pat_rhs_ty = pat_ty
+                           , bind_fvs = placeHolderNamesTc
+                           , pat_ticks = ([],[]) }
+                 , map (const orig) infos ) }
 
 tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a
 -- Extend the TcIdBinderStack for the RHS of the binding, with
@@ -1488,7 +1520,9 @@ tcExtendForRhs :: [MonoBindInfo] -> TcM a -> TcM a
 -- If we had the *polymorphic* version of f in the TcIdBinderStack, it
 -- would not be reported as relevant, because its type is closed
 tcExtendForRhs infos thing_inside
-  = tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel | (_, _, mono_id) <- infos] thing_inside
+  = tcExtendIdBndrs [ TcIdBndr mono_id NotTopLevel
+                    | MBI { mbi_mono_id = mono_id } <- infos ]
+                    thing_inside
     -- NotTopLevel: it's a monomorphic binding
 
 ---------------------
index 99edff9..1935ebe 100644 (file)
@@ -6,9 +6,9 @@ c%
 \section[TcExpr]{Typecheck an expression}
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
 
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
+module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExpr_O, tcMonoExprNC,
                 tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
                 tcSyntaxOp, tcCheckId,
                 addExprErrCtxt ) where
@@ -85,12 +85,23 @@ tcPolyExpr expr res_ty
   = addExprErrCtxt expr $
     do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
 
-tcPolyExprNC (L loc expr) res_ty
+tcPolyExprNC expr res_ty
+  = fst <$> tcPolyExprNC_O expr res_ty
+
+-- variant of tcPolyExpr that returns the origin
+tcPolyExprNC_O
+         :: LHsExpr Name        -- Expression to type check
+         -> TcSigmaType         -- Expected type (could be a polytype)
+         -> TcM (LHsExpr TcId, CtOrigin) -- Generalised expr with expected type
+              -- The origin is useful if you ever need to instantiate the type
+
+tcPolyExprNC_O (L loc expr) res_ty
   = setSrcSpan loc $
-    do { traceTc "tcPolyExprNC" (ppr res_ty)
-       ; (wrap, (expr', _)) <- tcSkolemise GenSigCtxt res_ty $ \ _ res_ty ->
-                               tcExpr expr res_ty
-       ; return (L loc (mkHsWrap wrap expr')) }
+    do { traceTc "tcPolyExprNC_O" (ppr res_ty)
+       ; (wrap, (expr', orig))
+           <- tcSkolemise GenSigCtxt res_ty $ \ _ res_ty ->
+              tcExpr expr res_ty
+       ; return (L loc (mkHsWrap wrap expr'), orig) }
 
 ---------------
 tcMonoExpr, tcMonoExprNC
@@ -153,18 +164,17 @@ NB: The res_ty is always deeply skolemised.
 -}
 
 tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId, CtOrigin)
-tcExpr (HsVar name)     res_ty = do { expr <- tcCheckId name res_ty
-                                    ; return (expr, OccurrenceOf name) }
-tcExpr (HsUnboundVar v) res_ty = do { expr <- tcUnboundId v res_ty
-                                    ; return (expr, UnboundOccurrenceOf v) }
+tcExpr (HsVar name)     res_ty = (, OccurrenceOf name) <$> tcCheckId name res_ty
+tcExpr (HsUnboundVar v) res_ty = (, UnboundOccurrenceOf v) <$>
+                                 tcUnboundId v res_ty
 
 tcExpr (HsApp e1 e2) res_ty
   = do { (wrap, fun, args, orig) <- tcApp Nothing e1 [e2] res_ty
        ; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args, orig) }
 
 tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
-                                 ; tcWrapResult (HsLit lit) lit_ty res_ty
-                                                Shouldn'tHappenOrigin }
+                                 ; no_origM $
+                                   tcWrapResult (HsLit lit) lit_ty res_ty }
 
 tcExpr (HsPar expr)   res_ty = do { (expr', orig) <- tcMonoExprNC_O expr res_ty
                                   ; return (HsPar expr', orig) }
@@ -201,22 +211,25 @@ tcExpr (HsIPVar x) res_ty
        ; ip_ty <- newFlexiTyVarTy openTypeKind
        ; let ip_name = mkStrLitTy (hsIPNameFS x)
        ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty])
-       ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty origin }
+       ; (, origin) <$>
+         tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var))
+                      ip_ty res_ty }
   where
   -- Coerces a dictionary for `IP "x" t` into `t`.
   fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
                           unwrapIP $ mkClassPred ipClass [x,ty]
 
 tcExpr (HsLam match) res_ty
-  = do  { (co_fn, match') <- tcMatchLambda match res_ty
-        ; return (mkHsWrap co_fn (HsLam match'), ) }
+  = do  { (co_fn, match', orig) <- tcMatchLambda match res_ty
+        ; return (mkHsWrap co_fn (HsLam match'), orig) }
 
 tcExpr e@(HsLamCase _ matches) res_ty
   = do {(wrap1, [arg_ty], body_ty) <-
             matchExpectedFunTys Expected msg 1 res_ty
-       ; (wrap2, matches') <- tcMatchesCase match_ctxt arg_ty matches body_ty
-       ; return $ mkHsWrap (wrap1 <.> mkWpFun idHsWrapper wrap2 arg_ty body_ty) $
-                  HsLamCase arg_ty matches' }
+       ; (wrap2, matches', orig)
+           <- tcMatchesCase match_ctxt arg_ty matches body_ty
+       ; return (mkHsWrap (wrap1 <.> mkWpFun idHsWrapper wrap2 arg_ty body_ty) $
+                 HsLamCase arg_ty matches', orig) }
   where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
                   , ptext (sLit "requires")]
         match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
@@ -225,7 +238,7 @@ tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
  = do { nwc_tvs <- mapM newWildcardVarMetaKind wcs
       ; tcExtendTyVarEnv nwc_tvs $ do {
         sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-      ; (gen_fn, expr')
+      ; (gen_fn, (expr', orig))
             <- tcSkolemise ExprSigCtxt sig_tc_ty $
                \ skol_tvs res_ty ->
 
@@ -234,13 +247,13 @@ tcExpr (ExprWithTySig expr sig_ty wcs) res_ty
                tcExtendTyVarEnv2
                   [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $
 
-               tcPolyExprNC expr res_ty
+               tcPolyExprNC_O expr res_ty
 
       ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
 
       ; addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
         emitWildcardHoleConstraints (zip wcs nwc_tvs)
-      ; tcWrapResult inner_expr sig_tc_ty res_ty } }
+      ; (, orig) <$> tcWrapResult inner_expr sig_tc_ty res_ty } }
 
 tcExpr (HsType ty _) _
   = failWithTc (sep [ text "Type argument used outside of a function argument:"
@@ -307,16 +320,16 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
        ; op_id <- tcLookupId op_name
        ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
-       ; return $ OpApp arg1' op' fix arg2' }
+       ; no_orig (OpApp arg1' op' fix arg2') }
 
   | (L loc (HsVar op_name)) <- op
   , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]
   = do { traceTc "Application rule" (ppr op)
-       ; (arg1', arg1_ty) <- tcInferSigma arg1
+       ; (arg1', arg1_ty, orig1) <- tcInferSigma arg1
 
        ; let doc = ptext (sLit "The first argument of ($) takes")
        ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
-           matchExpectedFunTys (Actual AppOrigin) doc 1 arg1_ty
+           matchExpectedFunTys (Actual orig1) doc 1 arg1_ty
 
          -- We have (arg1 $ arg2)
          -- So: arg1_ty = arg2_ty -> op_res_ty
@@ -337,7 +350,7 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
        ; let a2_ty = mkTyVarTy a2_tv
        ; co_a <- unifyType arg2_sigma a2_ty    -- arg2_sigma ~N a2_ty
 
-       ; wrap_res <- tcSubTypeHR op_res_ty res_ty    -- op_res -> res
+       ; wrap_res <- tcSubTypeHR orig1 op_res_ty res_ty    -- op_res -> res
 
        ; op_id  <- tcLookupId op_name
        ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id))
@@ -353,31 +366,33 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
 
              -- arg2' :: arg2_sigma
              -- wrap_a :: a2_ty "->" arg2_sigma
-       ; return $
-         OpApp (mkLHsWrap wrap1 arg1')
-               op' fix
-               (mkLHsWrapCo co_a arg2') }
+       ; return ( OpApp (mkLHsWrap wrap1 arg1')
+                        op' fix
+                        (mkLHsWrapCo co_a arg2')
+                , orig1 ) }
 
   | otherwise
   = do { traceTc "Non Application rule" (ppr op)
-       ; (wrap, op', [arg1', arg2']) <- tcApp (Just $ mk_op_msg op) AppOrigin
-                                        op [arg1, arg2] res_ty
-       ; return $ mkHsWrap wrap $ OpApp arg1' op' fix arg2' }
+       ; (wrap, op', [arg1', arg2'], orig)
+           <- tcApp (Just $ mk_op_msg op)
+                     op [arg1, arg2] res_ty
+       ; return (mkHsWrap wrap $ OpApp arg1' op' fix arg2', orig) }
 
 -- Right sections, equivalent to \ x -> x `op` expr, or
 --      \ x -> op x expr
 
 tcExpr (SectionR op arg2) res_ty
-  = do { (op', op_ty) <- tcInferFun op
+  = do { (op', op_ty, _) <- tcInferFun op
        ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
            matchExpectedFunTys (Actual SectionOrigin) (mk_op_msg op) 2 op_ty
-       ; wrap_res <- tcSubTypeHR (mkFunTy arg1_ty op_res_ty) res_ty
+       ; wrap_res <- tcSubTypeHR SectionOrigin (mkFunTy arg1_ty op_res_ty) res_ty
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
-       ; return $ mkHsWrap wrap_res $
-         SectionR (mkLHsWrap wrap_fun op') arg2' }
+       ; return ( mkHsWrap wrap_res $
+                  SectionR (mkLHsWrap wrap_fun op') arg2'
+                , SectionOrigin ) }
 
 tcExpr (SectionL arg1 op) res_ty
-  = do { (op', op_ty) <- tcInferFun op
+  = do { (op', op_ty, _) <- tcInferFun op
        ; dflags <- getDynFlags      -- Note [Left sections]
        ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
                          | otherwise                        = 2
@@ -385,17 +400,18 @@ tcExpr (SectionL arg1 op) res_ty
        ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
            <- matchExpectedFunTys (Actual SectionOrigin)
                 (mk_op_msg op) n_reqd_args op_ty
-       ; wrap_res <- tcSubTypeHR (mkFunTys arg_tys op_res_ty) res_ty
+       ; wrap_res <- tcSubTypeHR SectionOrigin (mkFunTys arg_tys op_res_ty) res_ty
        ; arg1' <- tcArg op (arg1, arg1_ty, 1)
-       ; return $ mkHsWrap wrap_res $
-         SectionL arg1' (mkLHsWrap wrap_fn op') }
+       ; return ( mkHsWrap wrap_res $
+                  SectionL arg1' (mkLHsWrap wrap_fn op')
+                , SectionOrigin ) }
 
 tcExpr (ExplicitTuple tup_args boxity) res_ty
   | all tupArgPresent tup_args
   = do { let tup_tc = tupleTyCon boxity (length tup_args)
        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
        ; tup_args1 <- tcTupArgs tup_args arg_tys
-       ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
+       ; no_orig $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) }
 
   | otherwise
   = -- The tup_args are a mixture of Present and Missing (for tuple sections)
@@ -409,30 +425,33 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty
                = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
                           (mkTyConApp tup_tc arg_tys)
 
-       ; wrap <- tcSubTypeHR actual_res_ty res_ty
+       ; wrap <- tcSubTypeHR Shouldn'tHappenOrigin actual_res_ty res_ty
 
        -- Handle tuple sections where
        ; tup_args1 <- tcTupArgs tup_args arg_tys
 
-       ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
+       ; no_orig $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
 
 tcExpr (ExplicitList _ witness exprs) res_ty
   = case witness of
       Nothing   -> do  { (coi, elt_ty) <- matchExpectedListTy res_ty
                        ; exprs' <- mapM (tc_elt elt_ty) exprs
-                       ; return $ mkHsWrapCo coi (ExplicitList elt_ty Nothing exprs') }
+                       ; no_orig $ mkHsWrapCo coi $
+                                   ExplicitList elt_ty Nothing exprs' }
 
-      Just fln -> do  { list_ty <- newFlexiTyVarTy liftedTypeKind
+      Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind
                      ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty)
                      ; (coi, elt_ty) <- matchExpectedListTy list_ty
                      ; exprs' <- mapM (tc_elt elt_ty) exprs
-                     ; return $ mkHsWrapCo coi (ExplicitList elt_ty (Just fln') exprs') }
+                     ; no_orig $ mkHsWrapCo coi $
+                                 ExplicitList elt_ty (Just fln') exprs' }
      where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
 tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
         ; exprs' <- mapM (tc_elt elt_ty) exprs
-        ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') }
+        ; no_orig $ mkHsWrapCo coi $
+                    ExplicitPArr elt_ty exprs' }
   where
     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 
@@ -445,9 +464,9 @@ tcExpr (ExplicitPArr _ exprs) res_ty    -- maybe empty
 -}
 
 tcExpr (HsLet binds expr) res_ty
-  = do  { (binds', expr') <- tcLocalBinds binds $
-                             tcMonoExpr expr res_ty
-        ; return (HsLet binds' expr') }
+  = do  { (binds', (expr', orig)) <- tcLocalBinds binds $
+                                     tcMonoExpr_O expr res_ty
+        ; return (HsLet binds' expr', orig) }
 
 tcExpr (HsCase scrut matches) exp_ty
   = do  {  -- We used to typecheck the case alternatives first.
@@ -462,8 +481,9 @@ tcExpr (HsCase scrut matches) exp_ty
           (scrut', scrut_ty) <- tcInferRho scrut
 
         ; traceTc "HsCase" (ppr scrut_ty)
-        ; (wrap, matches') <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
-        ; return $ mkHsWrap wrap $ HsCase scrut' matches' }
+        ; (wrap, matches', orig)
+            <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
+        ; return (mkHsWrap wrap $ HsCase scrut' matches', orig) }
  where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = tcBody }
@@ -475,27 +495,31 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
        ; tau_ty <- tauTvsForReturnTvs res_ty
        ; b1' <- tcMonoExpr b1 tau_ty
        ; b2' <- tcMonoExpr b2 tau_ty
-       ; tcWrapResult (HsIf Nothing pred' b1' b2') tau_ty res_ty }
+       ; no_origM $ tcWrapResult (HsIf Nothing pred' b1' b2') tau_ty res_ty }
 
 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
   -- Note [Rebindable syntax for if]
-  = do { (wrap, fun', [pred', b1', b2'])
-           <- tcApp (Just herald) IfOrigin (noLoc fun) [pred, b1, b2] res_ty
-       ; return $ mkHsWrap wrap $ (HsIf (Just (unLoc fun')) pred' b1' b2') }
+  = do { (wrap, fun', [pred', b1', b2'], orig)
+           <- tcApp (Just herald) (noLoc fun) [pred, b1, b2] res_ty
+       ; return ( mkHsWrap wrap $
+                  HsIf (Just (unLoc fun')) pred' b1' b2'
+                , orig ) }
   where
     herald = text "Rebindable" <+> quotes (text "if") <+> text "takes"
 
 tcExpr (HsMultiIf _ alts) res_ty
-  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
-       ; return $ HsMultiIf res_ty alts' }
+  = do { (alts', origs)
+           <- mapAndUnzipM (wrapLocFstM $ tcGRHS match_ctxt res_ty) alts
+       ; return (HsMultiIf res_ty alts', combineCtOrigins origs) }
   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
 
 tcExpr (HsDo do_or_lc stmts _) res_ty
-  = tcDoStmts do_or_lc stmts res_ty
+  = do { expr' <- tcDoStmts do_or_lc stmts res_ty
+       ; return (expr', DoOrigin) }
 
 tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
-        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
+        ; no_orig $ mkHsWrapCo coi (HsProc pat' cmd') }
 
 tcExpr (HsStatic expr) res_ty
   = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
@@ -516,7 +540,7 @@ tcExpr (HsStatic expr) res_ty
         -- Insert the static form in a global list for later validation.
         ; stWC <- tcg_static_wc <$> getGblEnv
         ; updTcRef stWC (andWC lie)
-        ; return $ mkHsWrapCo co $ HsStatic expr'
+        ; no_orig $ mkHsWrapCo co $ HsStatic expr'
         }
 
 {-
@@ -559,10 +583,11 @@ tcExpr (RecordCon (L loc con_name) _ rbinds) res_ty
               (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
               con_id = dataConWrapId data_con
 
-        ; res_wrap <- tcSubTypeHR actual_res_ty res_ty
+        ; res_wrap <- tcSubTypeHR Shouldn'tHappenOrigin actual_res_ty res_ty
         ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
-        ; return $ mkHsWrap res_wrap $
-          RecordCon (L loc con_id) (mkHsWrap con_wrap con_expr) rbinds' }
+        ; no_orig $ mkHsWrap res_wrap $
+                    RecordCon (L loc con_id)
+                              (mkHsWrap con_wrap con_expr) rbinds' }
 
 {-
 Note [Type of a record update]
@@ -749,7 +774,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
               scrut_ty      = TcType.substTy scrut_subst  con1_res_ty
               con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
 
-        ; wrap_res <- tcSubTypeHR rec_res_ty res_ty
+        ; wrap_res <- tcSubTypeHR Shouldn'tHappenOrigin rec_res_ty res_ty
 
         -- STEP 5
         -- Typecheck the thing to be updated, and the bindings
@@ -766,9 +791,9 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
                        | otherwise
                        = idHsWrapper
         -- Phew!
-        ; return $ mkHsWrap wrap_res $
-          RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
-                    relevant_cons scrut_inst_tys result_inst_tys  }
+        ; no_orig $ mkHsWrap wrap_res $
+                    RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
+                              relevant_cons scrut_inst_tys result_inst_tys }
   where
     upd_fld_names = hsRecFields rbinds
 
@@ -802,7 +827,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
 -}
 
 tcExpr (ArithSeq _ witness seq) res_ty
-  = tcArithSeq witness seq res_ty
+  = no_origM $ tcArithSeq witness seq res_ty
 
 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
@@ -811,8 +836,8 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
         ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
         ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
                                  (idName enumFromToP) elt_ty
-        ; return $ mkHsWrapCo coi
-                     (PArrSeq enum_from_to (FromTo expr1' expr2')) }
+        ; no_orig $ mkHsWrapCo coi $
+                    PArrSeq enum_from_to (FromTo expr1' expr2') }
 
 tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
   = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
@@ -822,8 +847,8 @@ tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
         ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
         ; eft <- newMethodFromName (PArrSeqOrigin seq)
                       (idName enumFromThenToP) elt_ty        -- !!!FIXME: chak
-        ; return $ mkHsWrapCo coi
-                     (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
+        ; no_orig $ mkHsWrapCo coi $
+                    PArrSeq eft (FromThenTo expr1' expr2' expr3') }
 
 tcExpr (PArrSeq _ _) _
   = panic "TcExpr.tcExpr: Infinite parallel array!"
@@ -838,9 +863,12 @@ tcExpr (PArrSeq _ _) _
 ************************************************************************
 -}
 
-tcExpr (HsSpliceE splice)        res_ty = tcSpliceExpr splice res_ty
-tcExpr (HsBracket brack)         res_ty = tcTypedBracket   brack res_ty
-tcExpr (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
+tcExpr (HsSpliceE splice)        res_ty
+  = no_origM $ tcSpliceExpr splice res_ty
+tcExpr (HsBracket brack)         res_ty
+  = no_origM $ tcTypedBracket   brack res_ty
+tcExpr (HsRnBracketOut brack ps) res_ty
+  = no_origM $ tcUntypedBracket brack ps res_ty
 
 {-
 ************************************************************************
@@ -854,6 +882,15 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
   -- Include ArrForm, ArrApp, which shouldn't appear at all
   -- Also HsTcBracketOut, HsQuasiQuoteE
 
+
+-- | Like 'return', but attaches 'Shouldn'tHappenOrigin'
+no_orig :: HsExpr TcId -> TcM (HsExpr TcId, CtOrigin)
+no_orig expr = return (expr, Shouldn'tHappenOrigin)
+
+-- | Run an type-checking action and attach a 'Shouldn'tHappenOrigin'
+no_origM :: TcM (HsExpr TcId) -> TcM (HsExpr TcId, CtOrigin)
+no_origM = fmap (, Shouldn'tHappenOrigin)
+
 {-
 ************************************************************************
 *                                                                      *
@@ -975,22 +1012,22 @@ mk_op_msg :: LHsExpr Name -> SDoc
 mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
 
 ----------------
-tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
+tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType, CtOrigin)
 -- Infer type of a function
 tcInferFun (L loc (HsVar name))
   = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
                -- Don't wrap a context around a plain Id
-       ; return (L loc fun, ty) }
+       ; return (L loc fun, ty, OccurrenceOf name) }
 
 tcInferFun fun
-  = do { (fun, fun_ty) <- tcInferSigma fun
+  = do { (fun, fun_ty, orig) <- tcInferSigma fun
 
          -- Zonk the function type carefully, to expose any polymorphism
          -- E.g. (( \(x::forall a. a->a). blah ) e)
          -- We can see the rank-2 type of the lambda in time to generalise e
        ; fun_ty' <- zonkTcType fun_ty
 
-       ; return (fun, fun_ty') }
+       ; return (fun, fun_ty', orig) }
 
 ----------------
 tcArgs :: LHsExpr Name                          -- The function (for error messages)
@@ -1033,8 +1070,9 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- Typecheck a syntax operator, checking that it has the specified type
 -- The operator is always a variable at this stage (i.e. renamer output)
 -- This version assumes res_ty is a monotype
-tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
-                                       ; tcWrapResult expr rho res_ty }
+tcSyntaxOp orig (HsVar op) res_ty
+  = do { (expr, rho) <- tcInferIdWithOrig orig op
+       ; tcWrapResult expr rho res_ty }
 
 tcSyntaxOp _ other         _      = pprPanic "tcSyntaxOp" (ppr other)
 
index 7d9319f..5839ed2 100644 (file)
@@ -14,9 +14,14 @@ tcMonoExpr, tcMonoExprNC ::
        -> TcRhoType
        -> TcM (LHsExpr TcId)
 
+tcMonoExpr_O ::
+          LHsExpr Name
+       -> TcRhoType
+       -> TcM (LHsExpr TcId, CtOrigin)
+
 tcInferSigma, tcInferSigmaNC ::
           LHsExpr Name
-       -> TcM (LHsExpr TcId, TcSigmaType)
+       -> TcM (LHsExpr TcId, TcSigmaType, CtOrigin)
 
 tcInferRho, tcInferRhoNC ::
           LHsExpr Name
index d635c54..f171ae1 100644 (file)
@@ -15,7 +15,8 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd
        ) where
 
 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma
-                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )
+                              , tcCheckId, tcMonoExpr_O
+                              , tcMonoExpr, tcMonoExprNC, tcPolyExpr )
 
 import HsSyn
 import BasicTypes
@@ -66,7 +67,7 @@ See Note [sig_tau may be polymorphic] in TcPat.
 tcMatchesFun :: Name -> Bool
              -> MatchGroup Name (LHsExpr Name)
              -> TcSigmaType     -- Expected type of function
-             -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+             -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId), CtOrigin)
                                 -- Returns type of body
 tcMatchesFun fun_name inf matches exp_ty
   = do  {  -- Check that they all have the same no of arguments
@@ -78,13 +79,13 @@ tcMatchesFun fun_name inf matches exp_ty
           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
         ; checkArgs fun_name matches
 
-        ; (wrap_gen, (wrap_fun, group))
+        ; (wrap_gen, (wrap_fun, group, orig))
             <- tcSkolemise (FunSigCtxt fun_name True) exp_ty $
                \ _ exp_rho ->
                   -- Note [Polymorphic expected type for tcMatchesFun]
                matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty ->
                tcMatches match_ctxt pat_tys rhs_ty matches
-        ; return (wrap_gen <.> wrap_fun, group) }
+        ; return (wrap_gen <.> wrap_fun, group, orig) }
   where
     arity = matchGroupArity matches
     herald = ptext (sLit "The equation(s) for")
@@ -101,7 +102,7 @@ tcMatchesCase :: (Outputable (body Name)) =>
               -> TcSigmaType                                  -- Type of scrutinee
               -> MatchGroup Name (Located (body Name))        -- The case alternatives
               -> TcRhoType                                    -- Type of whole case expressions
-              -> TcM (HsWrapper, MatchGroup TcId (Located (body TcId)))
+              -> TcM (HsWrapper, MatchGroup TcId (Located (body TcId)), CtOrigin)
                  -- Translated alternatives
                  -- wrapper goes from MatchGroup's ty to expected ty
 
@@ -110,13 +111,13 @@ tcMatchesCase ctxt scrut_ty matches res_ty
   = return (idHsWrapper, MG { mg_alts = []
                             , mg_arg_tys = [scrut_ty]
                             , mg_res_ty = res_ty
-                            , mg_origin = mg_origin matches })
+                            , mg_origin = mg_origin matches }, CaseOrigin)
 
   | otherwise
   = tcMatches ctxt [scrut_ty] res_ty matches
 
 tcMatchLambda :: MatchGroup Name (LHsExpr Name) -> TcRhoType
-              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId), CtOrigin)
 tcMatchLambda match res_ty
   = matchFunTys herald n_pats res_ty  $ \ pat_tys rhs_ty ->
     tcMatches match_ctxt pat_tys rhs_ty match
@@ -133,7 +134,7 @@ tcMatchLambda match res_ty
 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 
 tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType
-           -> TcM (GRHSs TcId (LHsExpr TcId))
+           -> TcM (GRHSs TcId (LHsExpr TcId), CtOrigin)
 -- Used for pattern bindings
 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
   where
@@ -144,9 +145,9 @@ matchFunTys
   :: SDoc       -- See Note [Herald for matchExpecteFunTys] in TcUnify
   -> Arity
   -> TcRhoType
-  -> ([TcSigmaType] -> TcRhoType -> TcM (HsWrapper, a))
+  -> ([TcSigmaType] -> TcRhoType -> TcM (HsWrapper, a, b))
      -- "a" is always a MatchGroup. wrapper :: a's res_ty "->" TcRhoType
-  -> TcM (HsWrapper, a)
+  -> TcM (HsWrapper, a, b)
      -- wrapper :: (pat_tys -> a's res_ty) "->" res_ty passed in
 
 -- Written in CPS style for historical reasons;
@@ -156,9 +157,9 @@ matchFunTys herald arity res_ty thing_inside
   = do  { (wrap_fun, pat_tys, res_ty')
             <- matchExpectedFunTys Expected herald arity res_ty
             -- wrap_fun :: pat_tys -> res_ty' "->" res_ty
-        ; (wrap_inner, res) <- thing_inside pat_tys res_ty'
+        ; (wrap_inner, res1, res2) <- thing_inside pat_tys res_ty'
         ; let wrap_inner_with_args = mkWpFuns pat_tys wrap_inner
-        ; return (wrap_fun <.> wrap_inner_with_args, res) }
+        ; return (wrap_fun <.> wrap_inner_with_args, res1, res2) }
 
 {-
 ************************************************************************
@@ -174,7 +175,7 @@ tcMatches :: (Outputable (body Name)) => TcMatchCtxt body
           -> [TcSigmaType]      -- Expected pattern types
           -> TcRhoType          -- Expected result-type of the Match.
           -> MatchGroup Name (Located (body Name))
-          -> TcM (HsWrapper, MatchGroup TcId (Located (body TcId)))
+          -> TcM (HsWrapper, MatchGroup TcId (Located (body TcId)), CtOrigin)
                -- wrapper goes from MatchGroup's ty to the expected ty
 
 data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
@@ -182,39 +183,42 @@ data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
          mc_body :: Located (body Name)         -- Type checker for a body of
                                                 -- an alternative
                  -> TcRhoType
-                 -> TcM (Located (body TcId)) }
+                 -> TcM (Located (body TcId), CtOrigin) }
 
 tcMatches ctxt pat_tys rhs_ty group@(MG { mg_alts = matches, mg_origin = origin })
   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
-    do  { (matches', wrap, rhs_ty') <-
-             if isSingletonMatchGroup group
-             then do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
-                     ; return (matches', idHsWrapper, rhs_ty) }
-             else do { rhs_ty' <- tauTvsForReturnTvs rhs_ty
+    do  { (matches', wrap, rhs_ty', ct_orig) <-
+             case singletonMatchGroup_maybe group of
+               Just match ->
+                 do { (match', ct_orig) <- tcMatch ctxt pat_tys rhs_ty match
+                    ; return ([match'], idHsWrapper, rhs_ty, ct_orig) }
+               Nothing ->
+                 do { rhs_ty' <- tauTvsForReturnTvs rhs_ty
                       -- TODO (RAE): Document this behavior.
-                     ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty') matches
-                     ; wrap <- tcSubTypeHR rhs_ty' rhs_ty
-                     ; return (matches', wrap, rhs_ty') }
+                    ; (matches', _)
+                        <- mapAndUnzipM (tcMatch ctxt pat_tys rhs_ty') matches
+                    ; wrap <- tcSubTypeHR Shouldn'tHappenOrigin rhs_ty' rhs_ty
+                    ; return (matches', wrap, rhs_ty', Shouldn'tHappenOrigin) }
         ; return (wrap, MG { mg_alts = matches'
                            , mg_arg_tys = pat_tys
                            , mg_res_ty = rhs_ty'
-                           , mg_origin = origin }) }
+                           , mg_origin = origin }, ct_orig) }
 
 -------------
 tcMatch :: (Outputable (body Name)) => TcMatchCtxt body
         -> [TcSigmaType]        -- Expected pattern types
         -> TcRhoType            -- Expected result-type of the Match.
         -> LMatch Name (Located (body Name))
-        -> TcM (LMatch TcId (Located (body TcId)))
+        -> TcM (LMatch TcId (Located (body TcId)), CtOrigin)
 
 tcMatch ctxt pat_tys rhs_ty match
-  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
+  = wrapLocFstM (tc_match ctxt pat_tys rhs_ty) match
   where
     tc_match ctxt pat_tys rhs_ty match@(Match _ pats maybe_rhs_sig grhss)
       = add_match_ctxt match $
-        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
-                                tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
-           ; return (Match Nothing pats' Nothing grhss') }
+        do { (pats', (grhss', orig)) <- tcPats (mc_what ctxt) pats pat_tys $
+                                        tc_grhss ctxt maybe_rhs_sig grhss rhs_ty
+           ; return (Match Nothing pats' Nothing grhss', orig) }
 
     tc_grhss ctxt Nothing grhss rhs_ty
       = tcGRHSs ctxt grhss rhs_ty       -- No result signature
@@ -232,7 +236,7 @@ tcMatch ctxt pat_tys rhs_ty match
 
 -------------
 tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType
-        -> TcM (GRHSs TcId (Located (body TcId)))
+        -> TcM (GRHSs TcId (Located (body TcId)), CtOrigin)
 
 -- Notice that we pass in the full res_ty, so that we get
 -- good inference from simple things like
@@ -241,19 +245,21 @@ tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType
 -- but we don't need to do that any more
 
 tcGRHSs ctxt (GRHSs grhss binds) res_ty
-  = do  { (binds', grhss') <- tcLocalBinds binds $
-                              mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss
+  = do  { (binds', (grhss', origs))
+            <- tcLocalBinds binds $
+               mapAndUnzipM (wrapLocFstM (tcGRHS ctxt res_ty)) grhss
 
-        ; return (GRHSs grhss' binds') }
+        ; return (GRHSs grhss' binds', combineCtOrigins origs) }
 
 -------------
 tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name))
-       -> TcM (GRHS TcId (Located (body TcId)))
+       -> TcM (GRHS TcId (Located (body TcId)), CtOrigin)
 
 tcGRHS ctxt res_ty (GRHS guards rhs)
-  = do  { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
-                             mc_body ctxt rhs
-        ; return (GRHS guards' rhs') }
+  = do  { (guards', (rhs', orig))
+            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
+               mc_body ctxt rhs
+        ; return (GRHS guards' rhs', orig) }
   where
     stmt_ctxt  = PatGuard (mc_what ctxt)
 
@@ -295,11 +301,10 @@ tcDoStmts MonadComp stmts res_ty
 
 tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
-tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
+tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId, CtOrigin)
 tcBody body res_ty
   = do  { traceTc "tcBody" (ppr res_ty)
-        ; body' <- tcMonoExpr body res_ty
-        ; return body'
+        ; tcMonoExpr_O body res_ty
         }
 
 {-
@@ -372,8 +377,9 @@ tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside
         ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 
 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
-  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs    -- Stmt has a context already
-        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat rhs_ty $
+  = do  { (rhs', rhs_ty, orig) <- tcInferSigmaNC rhs
+                                   -- Stmt has a context already
+        ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) orig pat rhs_ty $
                             thing_inside res_ty
         ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
 
@@ -443,9 +449,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
              --  passed in to tcStmtsAndThen is never looked at
        ; (stmts', (bndr_ids, by'))
             <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
-               { by' <- case by of
-                           Nothing -> return Nothing
-                           Just e  -> do { e_ty <- tcInferSigma e; return (Just e_ty) }
+               { by' <- traverse tcInferSigma by
                ; bndr_ids <- tcLookupLocalIds bndr_names
                ; return (bndr_ids, by') }
 
@@ -462,8 +466,8 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
 
              by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
              by_arrow = case by' of
-                          Nothing       -> \ty -> ty
-                          Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
+                          Nothing         -> \ty -> ty
+                          Just (_,e_ty,_) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty
 
              tup_ty        = mkBigCoreVarTupTy bndr_ids
              poly_arg_ty   = m_app alphaTy
@@ -491,7 +495,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
        ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
 
        ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
-                                , trS_by = fmap fst by', trS_using = final_using
+                                , trS_by = fmap fstOf3 by', trS_using = final_using
                                 , trS_form = form }, thing) }
 
 tcLcStmt _ _ stmt _ _
index 50bad30..6c34471 100644 (file)
@@ -3,14 +3,14 @@ import HsSyn    ( GRHSs, MatchGroup, LHsExpr )
 import TcEvidence( HsWrapper )
 import Name     ( Name )
 import TcType   ( TcRhoType )
-import TcRnTypes( TcM, TcId )
+import TcRnTypes( TcM, TcId, CtOrigin )
 --import SrcLoc   ( Located )
 
 tcGRHSsPat    :: GRHSs Name (LHsExpr Name)
               -> TcRhoType
-              -> TcM (GRHSs TcId (LHsExpr TcId))
+              -> TcM (GRHSs TcId (LHsExpr TcId), CtOrigin)
 
 tcMatchesFun :: Name -> Bool
              -> MatchGroup Name (LHsExpr Name)
              -> TcRhoType
-             -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+             -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId), CtOrigin)
index 19e37ba..9fa58e8 100644 (file)
@@ -13,7 +13,7 @@ module TcPat ( tcLetPat, TcSigFun, TcPragFun
              , findScopedTyVars, isPartialSig
              , completeSigPolyId, completeSigPolyId_maybe
              , LetBndrSpec(..), addInlinePrags, warnPrags
-             , tcPat, tcPats, newNoSigLetBndr
+             , tcPat, tcPat_O, tcPats, newNoSigLetBndr
              , addDataConStupidTheta, badFieldCon, polyPatSig ) where
 
 #include "HsVersions.h"
@@ -64,7 +64,8 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
   = tc_lpat pat pat_ty penv thing_inside
   where
     penv = PE { pe_lazy = True
-              , pe_ctxt = LetPat sig_fn no_gen }
+              , pe_ctxt = LetPat sig_fn no_gen
+              , pe_orig = PatOrigin }
 
 -----------------
 tcPats :: HsMatchContext Name
@@ -87,23 +88,31 @@ tcPats :: HsMatchContext Name
 tcPats ctxt pats pat_tys thing_inside
   = tc_lpats penv pats pat_tys thing_inside
   where
-    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt }
+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
 
 tcPat :: HsMatchContext Name
       -> LPat Name -> TcSigmaType
-      -> TcM a                 -- Checker for body, given
-                               -- its result type
+      -> TcM a                     -- Checker for body
       -> TcM (LPat TcId, a)
-tcPat ctxt pat pat_ty thing_inside
+tcPat ctxt = tcPat_O ctxt PatOrigin
+
+-- | A variant of 'tcPat' that takes a custom origin
+tcPat_O :: HsMatchContext Name
+        -> CtOrigin              -- ^ origin to use if the type needs inst'ing
+        -> LPat Name -> TcSigmaType
+        -> TcM a                 -- Checker for body
+        -> TcM (LPat TcId, a)
+tcPat_O ctxt orig pat pat_ty thing_inside
   = tc_lpat pat pat_ty penv thing_inside
   where
-    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt }
+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }
 
 
 -----------------
 data PatEnv
   = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed
        , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears
+       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing
        }
 
 data PatCtxt
@@ -537,12 +546,12 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
   = do  {
          -- Expr must have type `forall a1...aN. OPT' -> B`
          -- where overall_pat_ty is an instance of OPT'.
-        ; (expr',expr'_inferred) <- tcInferSigma expr
+        ; (expr',expr'_inferred, orig) <- tcInferSigma expr
 
          -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty`
         ; (expr_wrap, pat_ty) <- tcInfer $ \ pat_ty ->
-                tcSubTypeDS GenSigCtxt expr'_inferred
-                            (mkFunTy overall_pat_ty pat_ty)
+                tcSubTypeDS_O orig GenSigCtxt expr'_inferred
+                              (mkFunTy overall_pat_ty pat_ty)
 
          -- pattern must have pat_ty
         ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
@@ -561,7 +570,7 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
 ------------------------
 -- Lists, tuples, arrays
 tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside
-  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy pat_ty
+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
         ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
                                      pats penv thing_inside
         ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res)
@@ -570,14 +579,14 @@ tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside
 tc_pat penv (ListPat pats _ (Just (_,e))) pat_ty thing_inside
   = do  { list_pat_ty <- newFlexiTyVarTy liftedTypeKind
         ; e' <- tcSyntaxOp ListOrigin e (mkFunTy pat_ty list_pat_ty)
-        ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy list_pat_ty
+        ; (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv list_pat_ty
         ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
                                      pats penv thing_inside
         ; return (mkHsWrapPat coi (ListPat pats' elt_ty (Just (pat_ty,e'))) list_pat_ty, res)
         }
 
 tc_pat penv (PArrPat pats _) pat_ty thing_inside
-  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy pat_ty
+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty
         ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
                                      pats penv thing_inside
         ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res)
@@ -586,7 +595,7 @@ tc_pat penv (PArrPat pats _) pat_ty thing_inside
 tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
   = do  { let tc = tupleTyCon boxity (length pats)
         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)
-                              pat_ty
+                              penv pat_ty
         ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside
 
         ; dflags <- getDynFlags
@@ -624,9 +633,10 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside
 
 ------------------------
 -- Overloaded patterns: n, and n+k
-tc_pat _ (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside
+tc_pat (PE { pe_orig = pat_orig })
+       (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside
   = do  { let orig = LiteralOrigin over_lit
-        ; (wrap, lit') <- newOverloadedLit (Actual PatOrigin) over_lit pat_ty
+        ; (wrap, lit') <- newOverloadedLit (Actual pat_orig) over_lit pat_ty
         ; eq'     <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
         ; mb_neg' <- case mb_neg of
                         Nothing  -> return Nothing      -- Positive literal
@@ -641,7 +651,7 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside
   = do  { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
         ; let pat_ty' = idType bndr_id
               orig    = LiteralOrigin lit
-        ; (wrap_lit, lit') <- newOverloadedLit (Actual PatOrigin) lit pat_ty'
+        ; (wrap_lit, lit') <- newOverloadedLit (Actual $ pe_orig penv) lit pat_ty'
 
         -- The '>=' and '-' parts are re-mappable syntax
         ; ge'    <- tcSyntaxOp orig ge    (mkFunTys [pat_ty', pat_ty'] boolTy)
@@ -788,7 +798,7 @@ tcDataConPat penv (L con_span con_name) data_con pat_ty arg_pats thing_inside
           -- Instantiate the constructor type variables [a->ty]
           -- This may involve doing a family-instance coercion,
           -- and building a wrapper
-        ; (wrap, ctxt_res_tys) <- matchExpectedConTy tycon pat_ty
+        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty
 
           -- Add the stupid theta
         ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys
@@ -906,27 +916,28 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
 ----------------------------
 -- | Convenient wrapper for calling a matchExpectedXXX function
 matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))
-                    -> TcSigmaType -> TcM (HsWrapper, a)
+                    -> PatEnv -> TcSigmaType -> TcM (HsWrapper, a)
 -- See Note [Matching polytyped patterns]
 -- Returns a wrapper : pat_ty ~R inner_ty
-matchExpectedPatTy inner_match pat_ty
-  = do { (wrap, pat_rho) <- topInstantiate PatOrigin pat_ty
+matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty
+  = do { (wrap, pat_rho) <- topInstantiate orig pat_ty
        ; (co, res) <- inner_match pat_rho
        ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)
        ; return (coToHsWrapper (mkTcSymCo co) <.> wrap, res) }
 
 ----------------------------
-matchExpectedConTy :: TyCon      -- The TyCon that this data
+matchExpectedConTy :: PatEnv
+                   -> TyCon      -- The TyCon that this data
                                  -- constructor actually returns
                    -> TcSigmaType  -- The type of the pattern
                    -> TcM (HsWrapper, [TcSigmaType])
 -- See Note [Matching constructor patterns]
 -- Returns a wrapper : pat_ty "->" T ty1 ... tyn
-matchExpectedConTy data_tc pat_ty
+matchExpectedConTy (PE { pe_orig = orig }) data_tc pat_ty
   | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc
          -- Comments refer to Note [Matching constructor patterns]
          -- co_tc :: forall a. T [a] ~ T7 a
-  = do { (wrap, pat_ty) <- topInstantiate PatOrigin pat_ty
+  = do { (wrap, pat_ty) <- topInstantiate orig pat_ty
 
        ; (subst, tvs') <- tcInstTyVars (tyConTyVars data_tc)
              -- tys = [ty1,ty2]
@@ -948,7 +959,7 @@ matchExpectedConTy data_tc pat_ty
                 , tys') }
 
   | otherwise
-  = do { (wrap, pat_rho) <- topInstantiate PatOrigin pat_ty
+  = do { (wrap, pat_rho) <- topInstantiate orig pat_ty
        ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho
        ; return (coToHsWrapper (mkTcSymCo coi) <.> wrap, tys) }
 
index dd1436b..0de3110 100644 (file)
@@ -72,7 +72,7 @@ module TcRnTypes(
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,
         ctLocDepth, bumpCtLocDepth,
         setCtLocOrigin, setCtLocEnv, setCtLocSpan,
-        CtOrigin(..), pprCtOrigin, pprCtLoc,
+        CtOrigin(..), combineCtOrigins, pprCtOrigin, pprCtLoc,
         pushErrCtxt, pushErrCtxtSameOrigin,
 
         SkolemInfo(..),
@@ -2209,6 +2209,7 @@ data CtOrigin
   | DoOrigin            -- Arising from a do expression
   | MCompOrigin         -- Arising from a monad comprehension
   | IfOrigin            -- Arising from an if statement
+  | CaseOrigin          -- Arising from a case expression
   | ProcOrigin          -- Arising from a proc expression
   | AnnOrigin           -- An annotation
 
@@ -2226,7 +2227,17 @@ data CtOrigin
   | UnboundOccurrenceOf OccName
   | ListOrigin          -- An overloaded list
   | StaticOrigin        -- A static form
-  | Shouldn'tHappenOrigin   -- the user should never see this one
+  | Shouldn'tHappenOrigin   -- the user should never see this one,
+                            -- unlesss ImpredicativeTypes is on, where all
+                            -- bets are off
+
+-- | Combine several origins together. The typechecker arranges so that
+-- whenever multiple "actual" types are combined (like in the result of
+-- a conditional), the types are fully instantiated. So use
+-- Shouldn'tHappenOrigin if multiple types are indeed present.
+combineCtOrigins :: [CtOrigin] -> CtOrigin
+combineCtOrigins [orig] = orig
+combineCtOrigins _      = Shouldn'tHappenOrigin
 
 ctoHerald :: SDoc
 ctoHerald = ptext (sLit "arising from")
@@ -2280,8 +2291,12 @@ pprCtOrigin (DerivOriginCoerce meth ty1 ty2)
        2 (sep [ text "from type" <+> quotes (ppr ty1)
               , nest 2 $ text "to type" <+> quotes (ppr ty2) ])
 
-pprCtO Shouldn'tHappenOrigin
-  = vcat [ text "<< This should not appear in error messages. If you see this"
+pprCtOrigin Shouldn'tHappenOrigin
+  = sdocWithDynFlags $ \dflags ->
+    if xopt Opt_ImpredicativeTypes dflags
+    then text "a situation created by impredicative types"
+    else
+    vcat [ text "<< This should not appear in error messages. If you see this"
          , text "in an error message, please report a bug at"
          , text "https://ghc.haskell.org/trac/ghc/wiki/ReportABug >>" ]
 
@@ -2298,7 +2313,8 @@ pprCtO ExprSigOrigin         = ptext (sLit "an expression type signature")
 pprCtO PatSigOrigin          = ptext (sLit "a pattern type signature")
 pprCtO PatOrigin             = ptext (sLit "a pattern")
 pprCtO ViewPatOrigin         = ptext (sLit "a view pattern")
-pprCtO IfOrigin              = ptext (sLit "an if statement")
+pprCtO IfOrigin              = ptext (sLit "an if expression")
+pprCtO CaseOrigin            = ptext (sLit "a case expression")
 pprCtO (LiteralOrigin lit)   = hsep [ptext (sLit "the literal"), quotes (ppr lit)]
 pprCtO (ArithSeqOrigin seq)  = hsep [ptext (sLit "the arithmetic sequence"), quotes (ppr seq)]
 pprCtO (PArrSeqOrigin seq)   = hsep [ptext (sLit "the parallel array sequence"), quotes (ppr seq)]
index 831fe31..1a12a87 100644 (file)
@@ -159,7 +159,7 @@ tcTypedBracket brack@(TExpBr expr) res_ty
        ; ps' <- readMutVar ps_ref
        ; texpco <- tcLookupId unsafeTExpCoerceName
        ; tcWrapResult (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
-                                      (noLoc (HsTcBracketOut brack ps'))))
+                                              (noLoc (HsTcBracketOut brack ps'))))
                       meta_ty res_ty }
 tcTypedBracket other_brack _
   = pprPanic "tcTypedBracket" (ppr other_brack)
index 82d2eab..09a1e2e 100644 (file)
@@ -11,7 +11,8 @@ Type subsumption and unification
 module TcUnify (
   -- Full-blown subsumption
   tcWrapResult, tcSkolemise,
-  tcSubTypeHR, tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC,
+  tcSubTypeHR, tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_O,
+  tcSubTypeDS_NC,
   checkConstraints,
 
   -- Various unifications
@@ -551,7 +552,7 @@ But f1 will only typecheck if we have that
     (Int->Int) -> Int  <=  (forall a. a->a) -> Int
 And that is only true if we do the full co/contravariant thing
 in the subsumption check.  That happens in the FunTy case of
-tc_sub_type_ds, and is the sole reason for the WpFun form of
+tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of
 HsWrapper.
 
 Another powerful reason for doing this co/contra stuff is visible
@@ -575,7 +576,7 @@ skolemising the type.
 -- you know the right-hand type is deeply skolemised.
 tcSubTypeHR :: CtOrigin    -- ^ of the actual type
             -> TcSigmaType -> TcRhoType -> TcM HsWrapper
-tcSubTypeHR orig = tc_sub_type_ds orig GenSigCtxt
+tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt
 
 tcSubType :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
 -- Checks that actual <= expected
@@ -591,6 +592,17 @@ tcSubTypeDS ctxt ty_actual ty_expected
   = addSubTypeCtxt ty_actual ty_expected $
     tcSubTypeDS_NC ctxt ty_actual ty_expected
 
+-- | Like 'tcSubTypeDS', but takes a 'CtOrigin' to use when instantiating
+-- the "actual" type
+tcSubTypeDS_O :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcRhoType
+              -> TcM HsWrapper
+tcSubTypeDS_O orig ctxt ty_actual ty_expected
+  = addSubTypeCtxt ty_actual ty_expected $
+    do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig
+                                       , pprUserTypeCtxt ctxt
+                                       , ppr ty_actual
+                                       , ppr ty_expected ])
+       ; tcSubTypeDS_NC_O orig ctxt ty_actual ty_expected }
 
 addSubTypeCtxt :: TcType -> TcType -> TcM a -> TcM a
 addSubTypeCtxt ty_actual ty_expected thing_inside
@@ -623,7 +635,7 @@ tcSubType_NC ctxt ty_actual ty_expected
 tcSubTypeDS_NC :: UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper
 tcSubTypeDS_NC ctxt ty_actual ty_expected
   = do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])
-       ; tc_sub_type_ds origin ctxt ty_actual ty_expected }
+       ; tcSubTypeDS_NC_O origin ctxt ty_actual ty_expected }
   where
     origin = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty_expected }
 
@@ -648,14 +660,14 @@ tc_sub_type origin ctxt ty_actual ty_expected
   | otherwise  -- See Note [Deep skolemisation]
   = do { (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $
                                   \ _ sk_rho ->
-                                  tc_sub_type_ds origin ctxt ty_actual sk_rho
+                                  tcSubTypeDS_NC_O origin ctxt ty_actual sk_rho
        ; return (sk_wrap <.> inner_wrap) }
 
 ---------------
-tc_sub_type_ds :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper
+tcSubTypeDS_NC_O :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper
 -- Just like tcSubType, but with the additional precondition that
 -- ty_expected is deeply skolemised
-tc_sub_type_ds origin ctxt ty_actual ty_expected = go ty_actual ty_expected
+tcSubTypeDS_NC_O origin ctxt ty_actual ty_expected = go ty_actual ty_expected
   where
     go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e
                  | Just ty_e' <- tcView ty_e = go ty_a  ty_e'
@@ -664,9 +676,9 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected = go ty_actual ty_expected
       = do { lookup_res <- lookupTcTyVar tv_a
            ; case lookup_res of
                Filled ty_a' ->
-                 do { traceTc "tc_sub_type_ds following filled act meta-tyvar:"
+                 do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:"
                         (ppr tv_a <+> text "-->" <+> ppr ty_a')
-                    ; tc_sub_type_ds origin ctxt ty_a' ty_e }
+                    ; tcSubTypeDS_NC_O origin ctxt ty_a' ty_e }
                Unfilled _   -> coToHsWrapper <$> uType origin ty_a ty_e }
 
     go ty_a ty_e@(TyVarTy tv_e)
@@ -675,7 +687,7 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected = go ty_actual ty_expected
            ; lookup_res <- lookupTcTyVar tv_e
            ; case lookup_res of
                Filled ty_e' ->
-                 do { traceTc "tc_sub_type_ds following filled exp meta-tyvar:"
+                 do { traceTc "tcSubTypeDS_NC_O following filled exp meta-tyvar:"
                         (ppr tv_e <+> text "-->" <+> ppr ty_e')
                     ; tc_sub_type origin ctxt ty_a ty_e' }
                Unfilled details
@@ -696,7 +708,7 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected = go ty_actual ty_expected
       | not (isPredTy act_arg)
       , not (isPredTy exp_arg)
       = -- See Note [Co/contra-variance of subsumption checking]
-        do { res_wrap <- tc_sub_type_ds origin ctxt act_res exp_res
+        do { res_wrap <- tcSubTypeDS_NC_O origin ctxt act_res exp_res
            ; arg_wrap <- tc_sub_type    origin ctxt exp_arg act_arg
            ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res) }
                -- arg_wrap :: exp_arg ~ act_arg
@@ -714,12 +726,11 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected = go ty_actual ty_expected
            ; return (coToHsWrapper cow) }
 
 -----------------
-tcWrapResult :: HsExpr TcId -> TcSigmaType -> TcRhoType -> CtOrigin
-             -> TcM (HsExpr TcId, CtOrigin)
-     -- the CtOrigin stuff is just for convenience in tcExpr
-tcWrapResult expr actual_ty res_ty orig
+tcWrapResult :: HsExpr TcId -> TcSigmaType -> TcRhoType
+             -> TcM (HsExpr TcId)
+tcWrapResult expr actual_ty res_ty
   = do { cow <- tcSubTypeDS GenSigCtxt actual_ty res_ty
-       ; return (mkHsWrap cow expr, orig) }
+       ; return $ mkHsWrap cow expr }
 
 -----------------------------------
 wrapFunResCoercion