Checkpoint in bugfixing
authorRichard Eisenberg <eir@cis.upenn.edu>
Wed, 8 Jul 2015 18:33:54 +0000 (14:33 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Wed, 8 Jul 2015 18:33:54 +0000 (14:33 -0400)
20 files changed:
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/parser/RdrHsSyn.hs
compiler/rename/RnExpr.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcMatches.hs-boot
compiler/typecheck/TcPat.hs
compiler/typecheck/TcSMonad.hs
compiler/typecheck/TcType.hs
compiler/typecheck/TcUnify.hs

index f5a9290..4c056ee 100644 (file)
@@ -786,10 +786,11 @@ addTickHsCmd (OpApp e1 c2 fix c3) =
                 (addTickLHsCmd c3)
 -}
 addTickHsCmd (HsCmdPar e) = liftM HsCmdPar (addTickLHsCmd e)
-addTickHsCmd (HsCmdCase e mgs) =
-        liftM2 HsCmdCase
+addTickHsCmd (HsCmdCase e mgs w) =
+        liftM3 HsCmdCase
                 (addTickLHsExpr e)
                 (addTickCmdMatchGroup mgs)
+                (return w)
 addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
         liftM3 (HsCmdIf cnd)
                 (addBinTickLHsExpr (BinBox CondBinBox) e1)
@@ -817,8 +818,8 @@ addTickHsCmd (HsCmdArrForm e fix cmdtop) =
                (return fix)
                (mapM (liftL (addTickHsCmdTop)) cmdtop)
 
-addTickHsCmd (HsCmdCast co cmd)
-  = liftM2 HsCmdCast (return co) (addTickHsCmd cmd)
+addTickHsCmd (HsCmdWrap w cmd)
+  = liftM2 HsCmdWrap (return w) (addTickHsCmd cmd)
 
 -- Others should never happen in a command context.
 --addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)
index 44795b9..e71d306 100644 (file)
@@ -49,6 +49,8 @@ import ListSetOps( assocDefault )
 import FastString
 import Data.List
 
+import Control.Arrow ( first )
+
 data DsCmdEnv = DsCmdEnv {
         arr_id, compose_id, first_id, app_id, choice_id, loop_id :: CoreExpr
     }
@@ -504,7 +506,7 @@ case bodies, containing the following fields:
 -}
 
 dsCmd ids local_vars stack_ty res_ty
-      (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
+      (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }) wrap)
       env_ids = do
     stack_id <- newSysLocalDs stack_ty
 
@@ -512,7 +514,8 @@ dsCmd ids local_vars stack_ty res_ty
     -- expressions that will (after tagging) replace these leaves
 
     let
-        leaves = concatMap leavesMatch matches
+        leaves = map (first $ mkLHsCmdWrap wrap) $
+                 concatMap leavesMatch matches
         make_branch (leaf, bound_vars) = do
             (core_leaf, _fvs, leaf_ids) <-
                   dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty res_ty leaf
@@ -611,9 +614,9 @@ dsCmd _ids local_vars _stack_ty _res_ty (HsCmdArrForm op _ args) env_ids = do
     return (mkApps (App core_op (Type env_ty)) core_args,
             unionVarSets fv_sets)
 
-dsCmd ids local_vars stack_ty res_ty (HsCmdCast coercion cmd) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdWrap wrap cmd) env_ids = do
     (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids
-    wrapped_cmd <- dsHsWrapper (mkWpCast coercion) core_cmd
+    wrapped_cmd <- dsHsWrapper wrap core_cmd
     return (wrapped_cmd, env_ids')
 
 dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)
index 5fe90f6..088d81d 100644 (file)
@@ -894,6 +894,7 @@ data HsCmd id
 
   | HsCmdCase   (LHsExpr id)
                 (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's
+                (PostTc id HsWrapper)
     -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnCase',
     --       'ApiAnnotation.AnnOf','ApiAnnotation.AnnOpen' @'{'@,
     --       'ApiAnnotation.AnnClose' @'}'@
@@ -928,10 +929,10 @@ data HsCmd id
 
     -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsCmdCast   TcCoercion     -- A simpler version of HsWrap in HsExpr
+  | HsCmdWrap   HsWrapper
                 (HsCmd id)     -- If   cmd :: arg1 --> res
-                               --       co :: arg1 ~ arg2
-                               -- Then (HsCmdCast co cmd) :: arg2 --> res
+                               --      wrap :: arg1 "->" arg2
+                               -- Then (HsCmdWrap wrap cmd) :: arg2 --> res
   deriving (Typeable)
 deriving instance (DataId id) => Data (HsCmd id)
 
@@ -994,7 +995,7 @@ ppr_cmd (HsCmdApp c e)
 ppr_cmd (HsCmdLam matches)
   = pprMatches (LambdaExpr :: HsMatchContext id) matches
 
-ppr_cmd (HsCmdCase expr matches)
+ppr_cmd (HsCmdCase expr matches _wrap)
   = sep [ sep [ptext (sLit "case"), nest 4 (ppr expr), ptext (sLit "of {")],
           nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
 
@@ -1014,8 +1015,7 @@ ppr_cmd (HsCmdLet binds cmd)
          hang (ptext (sLit "in"))  2 (ppr cmd)]
 
 ppr_cmd (HsCmdDo stmts _)  = pprDo ArrowExpr stmts
-ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
-                                 , ptext (sLit "|>") <+> ppr co ]
+ppr_cmd (HsCmdWrap w cmd)  = pprHsWrapper (ppr_cmd cmd) w
 
 ppr_cmd (HsCmdArrApp arrow arg _ HsFirstOrderApp True)
   = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]
index 9aba6c9..c1b85ca 100644 (file)
@@ -25,7 +25,7 @@ module HsUtils(
   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
   coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
-  mkLHsPar, mkHsCmdCast, isLHsTypeExpr_maybe, isLHsTypeExpr,
+  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
 
   nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
@@ -502,9 +502,12 @@ mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e
 mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id
 mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
 
-mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id
-mkHsCmdCast co cmd | isTcReflCo co = cmd
-                   | otherwise     = HsCmdCast co cmd
+mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
+mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
+                  | otherwise       = HsCmdWrap w cmd
+
+mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
+mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
 
 coToHsWrapper :: TcCoercion -> HsWrapper   -- A Nominal coercion
 coToHsWrapper co | isTcReflCo co = idHsWrapper
index 00a2cdf..e2ecdf6 100644 (file)
@@ -12,6 +12,7 @@ import NameSet
 import RdrName
 import Var
 import Coercion
+import TcEvidence ( HsWrapper )
 
 import Data.Data hiding ( Fixity )
 import BasicTypes       (Fixity)
@@ -59,6 +60,9 @@ placeHolderNames = PlaceHolder
 placeHolderNamesTc :: NameSet
 placeHolderNamesTc = emptyNameSet
 
+placeHolderHsWrapper :: PlaceHolder
+placeHolderHsWrapper = PlaceHolder
+
 {-
 
 Note [Pass sensitive types]
@@ -102,4 +106,5 @@ type DataId id =
 
   , Data (PostTc id Type)
   , Data (PostTc id Coercion)
+  , Data (PostTc id HsWrapper)
   )
index d7af65d..3cd4065 100644 (file)
@@ -1095,7 +1095,7 @@ checkCmd _ (HsLam mg) =
 checkCmd _ (HsPar e) =
     checkCommand e >>= (\c -> return $ HsCmdPar c)
 checkCmd _ (HsCase e mg) =
-    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg')
+    checkCmdMatchGroup mg >>= (\mg' -> return $ HsCmdCase e mg' placeHolderHsWrapper)
 checkCmd _ (HsIf cf ep et ee) = do
     pt <- checkCommand et
     pe <- checkCommand ee
index da0d387..4a48b06 100644 (file)
@@ -499,10 +499,10 @@ rnCmd (HsCmdPar e)
   = do  { (e', fvs_e) <- rnLCmd e
         ; return (HsCmdPar e', fvs_e) }
 
-rnCmd (HsCmdCase expr matches)
+rnCmd (HsCmdCase expr matches ph)
   = do { (new_expr, e_fvs) <- rnLExpr expr
        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches
-       ; return (HsCmdCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
+       ; return (HsCmdCase new_expr new_matches ph, e_fvs `plusFV` ms_fvs) }
 
 rnCmd (HsCmdIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -520,7 +520,7 @@ rnCmd (HsCmdDo stmts _)
   = do  { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
         ; return ( HsCmdDo stmts' placeHolderType, fvs ) }
 
-rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
+rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)
 
 ---------------------------------------------------
 type CmdNeeds = FreeVars        -- Only inhabitants are
@@ -537,7 +537,7 @@ methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsHigherOrderApp _rtl)
   = unitFV appAName
 methodNamesCmd (HsCmdArrForm {}) = emptyFVs
-methodNamesCmd (HsCmdCast _ cmd) = methodNamesCmd cmd
+methodNamesCmd (HsCmdWrap _ cmd) = methodNamesCmd cmd
 
 methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
 
@@ -549,7 +549,7 @@ methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
 methodNamesCmd (HsCmdApp c _)      = methodNamesLCmd c
 methodNamesCmd (HsCmdLam match)    = methodNamesMatch match
 
-methodNamesCmd (HsCmdCase _ matches)
+methodNamesCmd (HsCmdCase _ matches _)
   = methodNamesMatch matches `addOneFV` choiceAName
 
 --methodNamesCmd _ = emptyFVs
index 2eac549..9c2656a 100644 (file)
@@ -193,22 +193,26 @@ deeplySkolemise
   -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
 
 deeplySkolemise ty
-  | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
-  = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
-       ; (subst, tvs1) <- tcInstSkolTyVars tvs
-       ; ev_vars1 <- newEvVars (substTheta subst theta)
-       ; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
-       ; return ( mkWpLams ids1
-                   <.> mkWpTyLams tvs1
-                   <.> mkWpLams ev_vars1
-                   <.> wrap
-                   <.> mkWpEvVarApps ids1
-                , tvs1     ++ tvs2
-                , ev_vars1 ++ ev_vars2
-                , mkFunTys arg_tys rho ) }
-
-  | otherwise
-  = return (idHsWrapper, [], [], ty)
+  = do { ty <- zonkTcType ty
+       ; go ty }
+  where
+    go ty
+      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
+      = do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
+           ; (subst, tvs1) <- tcInstSkolTyVars tvs
+           ; ev_vars1 <- newEvVars (substTheta subst theta)
+           ; (wrap, tvs2, ev_vars2, rho) <- go (substTy subst ty')
+           ; return ( mkWpLams ids1
+                       <.> mkWpTyLams tvs1
+                       <.> mkWpLams ev_vars1
+                       <.> wrap
+                       <.> mkWpEvVarApps ids1
+                    , tvs1     ++ tvs2
+                    , ev_vars1 ++ ev_vars2
+                    , mkFunTys arg_tys rho ) }
+
+      | otherwise
+      = return (idHsWrapper, [], [], ty)
 
 -- | Instantiate all outer type variables
 -- and any context. Never looks through arrows.
index c92a6ef..e41ea6b 100644 (file)
@@ -142,11 +142,11 @@ tc_cmd env (HsCmdLet binds (L body_loc body)) res_ty
                              tc_cmd env body res_ty
         ; return (HsCmdLet binds' (L body_loc body')) }
 
-tc_cmd env in_cmd@(HsCmdCase scrut matches) (stk, res_ty)
+tc_cmd env in_cmd@(HsCmdCase scrut matches _) (stk, res_ty)
   = addErrCtxt (cmdCtxt in_cmd) $ do
       (scrut', scrut_ty) <- tcInferSigma scrut
-      matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
-      return (HsCmdCase scrut' matches')
+      (wrap, matches') <- tcMatchesCase match_ctxt scrut_ty matches res_ty
+      return (HsCmdCase scrut' matches' wrap)
   where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = mc_body }
@@ -250,7 +250,7 @@ tc_cmd env
               arg_tys = map hsLPatType pats'
               cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys
                                   , mg_res_ty = res_ty, mg_origin = origin })
-        ; return (mkHsCmdCast co cmd') }
+        ; return (mkHsCmdWrap (coToHsWrapper co) cmd') }
   where
     n_pats     = length pats
     match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?
@@ -272,7 +272,7 @@ tc_cmd env
 tc_cmd env (HsCmdDo stmts _) (cmd_stk, res_ty)
   = do  { co <- unifyType unitTy cmd_stk  -- Expecting empty argument stack
         ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty
-        ; return (mkHsCmdCast co (HsCmdDo stmts' res_ty)) }
+        ; return (mkHsCmdWrap (coToHsWrapper co) (HsCmdDo stmts' res_ty)) }
 
 
 -----------------------------------------------------------------
@@ -317,7 +317,7 @@ tc_cmd _ cmd _
                       ptext (sLit "was found where an arrow command was expected")])
 
 
-matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
+matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)
 matchExpectedCmdArgs 0 ty
   = return (mkTcNomReflCo ty, [], ty)
 matchExpectedCmdArgs n ty
index fda3bbb..f418f07 100644 (file)
@@ -15,7 +15,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
                  instTcTySig, instTcTySigFromId, findScopedTyVars,
                  badBootDeclErr, mkExport ) where
 
-import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
+import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun, tcMatchFun )
 import {-# SOURCE #-} TcExpr  ( tcMonoExpr )
 import {-# SOURCE #-} TcPatSyn ( tcInferPatSynDecl, tcCheckPatSynDecl, tcPatSynBuilderBind )
 import DynFlags
@@ -1270,9 +1270,10 @@ tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking pur
 tcMonoBinds is_rec sig_fn no_gen
            [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
                                 fun_matches = matches, bind_fvs = fvs })]
-                             -- Single function binding,
-  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS
-  , Nothing <- sig_fn name   -- ...with no type signature
+                               -- Single function binding,
+  | NonRecursive <- is_rec     -- ...binder isn't mentioned in RHS
+  , Nothing <- sig_fn name     -- ...with no type signature
+  , [match] <- mg_alts matches -- ...and only one clause
   =     -- In this very special case we infer the type of the
         -- right hand side first (it may have a higher-rank type)
         -- and *then* make the monomorphic Id for the LHS
@@ -1281,11 +1282,12 @@ tcMonoBinds is_rec sig_fn no_gen
     setSrcSpan b_loc    $
     do  { rhs_ty  <- newFlexiTyVarTy 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') <-
+              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
+              tcMatchFun name inf match (mg_origin matches) rhs_ty
 
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
index 032af20..79f65c1 100644 (file)
@@ -1526,7 +1526,7 @@ quickFlattenTy (TyConApp tc tys)
     | otherwise
     = do { let (funtys,resttys) = splitAt (tyConArity tc) tys
                 -- Ignore the arguments of the type family funtys
-         ; v <- newMetaTyVar (TauTv False) (typeKind (TyConApp tc funtys))
+         ; v <- newMetaTyVar (TauTv VanillaTau) (typeKind (TyConApp tc funtys))
          ; flat_resttys <- mapM quickFlattenTy resttys
          ; return (foldl AppTy (mkTyVarTy v) flat_resttys) }
 
index 3995f50..3f2cd2f 100644 (file)
@@ -197,10 +197,10 @@ tcExpr (HsLam match) res_ty
         ; return (mkHsWrap co_fn (HsLam match')) }
 
 tcExpr e@(HsLamCase _ matches) res_ty
-  = do {(wrap, [arg_ty], body_ty) <-
+  = do {(wrap1, [arg_ty], body_ty) <-
             matchExpectedFunTys Expected msg 1 res_ty
-       ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
-       ; return $ mkHsWrap wrap $ HsLamCase arg_ty matches' }
+       ; (wrap2, matches') <- tcMatchesCase match_ctxt arg_ty matches body_ty
+       ; return $ mkHsWrap (wrap1 <.> wrap2) $ HsLamCase arg_ty matches' }
   where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
                   , ptext (sLit "requires")]
         match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
@@ -446,17 +446,22 @@ tcExpr (HsCase scrut matches) exp_ty
           (scrut', scrut_ty) <- tcInferSigma scrut
 
         ; traceTc "HsCase" (ppr scrut_ty)
-        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
-        ; return (HsCase scrut' matches') }
+        ; (wrap, matches') <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
+        ; return $ mkHsWrap wrap $ HsCase scrut' matches' }
  where
     match_ctxt = MC { mc_what = CaseAlt,
                       mc_body = tcBody }
 
 tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do { pred' <- tcMonoExpr pred boolTy
-       ; b1' <- tcMonoExpr b1 res_ty
-       ; b2' <- tcMonoExpr b2 res_ty
-       ; return (HsIf Nothing pred' b1' b2') }
+            -- this forces the branches to be fully instantiated
+            -- (See #10619)
+       ; tau_ty <- newFlexiMonoTyVarTy openTypeKind
+       ; wrap   <- tcSubTypeHR tau_ty res_ty
+       ; tau_ty <- zonkTcType tau_ty
+       ; b1' <- tcMonoExpr b1 tau_ty
+       ; b2' <- tcMonoExpr b2 tau_ty
+       ; return $ mkHsWrap wrap $ HsIf Nothing pred' b1' b2' }
 
 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
   -- Note [Rebindable syntax for if]
index 1bdfe4f..f340907 100644 (file)
@@ -780,10 +780,10 @@ zonkCmd   :: ZonkEnv -> HsCmd TcId    -> TcM (HsCmd Id)
 
 zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd
 
-zonkCmd env (HsCmdCast co cmd)
-  = do { co' <- zonkTcCoToCo env co
-       ; cmd' <- zonkCmd env cmd
-       ; return (HsCmdCast co' cmd') }
+zonkCmd env (HsCmdWrap w cmd)
+  = do { (env1, w') <- zonkCoFn env w
+       ; cmd' <- zonkCmd env1 cmd
+       ; return (HsCmdWrap w' cmd') }
 zonkCmd env (HsCmdArrApp e1 e2 ty ho rl)
   = do new_e1 <- zonkLExpr env e1
        new_e2 <- zonkLExpr env e2
@@ -808,10 +808,11 @@ zonkCmd env (HsCmdPar c)
   = do new_c <- zonkLCmd env c
        return (HsCmdPar new_c)
 
-zonkCmd env (HsCmdCase expr ms)
-  = do new_expr <- zonkLExpr env expr
-       new_ms <- zonkMatchGroup env zonkLCmd ms
-       return (HsCmdCase new_expr new_ms)
+zonkCmd env (HsCmdCase expr ms wrap)
+  = do (env1, wrap') <- zonkCoFn env wrap
+       new_expr <- zonkLExpr env expr
+       new_ms <- zonkMatchGroup env1 zonkLCmd ms
+       return (HsCmdCase new_expr new_ms wrap')
 
 zonkCmd env (HsCmdIf eCond ePred cThen cElse)
   = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
index edb84d8..a9e8b0d 100644 (file)
@@ -19,6 +19,7 @@ module TcMType (
   newFlexiTyVar,
   newFlexiTyVarTy,              -- Kind -> TcM TcType
   newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]
+  newFlexiMonoTyVarTy,
   newReturnTyVar, newReturnTyVarTy,
   newMetaKindVar, newMetaKindVars,
   mkTcTyVarName, cloneMetaTyVar,
@@ -104,7 +105,7 @@ kind_var_occ = mkOccName tvName "k"
 
 newMetaKindVar :: TcM TcKind
 newMetaKindVar = do { uniq <- newUnique
-                    ; details <- newMetaDetails (TauTv False)
+                    ; details <- newMetaDetails (TauTv VanillaTau)
                     ; let kv = mkTcTyVar (mkKindName uniq) superKind details
                     ; return (mkTyVarTy kv) }
 
@@ -288,8 +289,9 @@ newMetaTyVar meta_info kind
         ; let name = mkTcTyVarName uniq s
               s = case meta_info of
                         ReturnTv    -> fsLit "r"
-                        TauTv True  -> fsLit "w"
-                        TauTv False -> fsLit "t"
+                        TauTv WildcardTau   -> fsLit "w"
+                        TauTv VanillaTau    -> fsLit "t"
+                        TauTv AlwaysMonoTau -> fsLit "m"
                         FlatMetaTv  -> fsLit "fmv"
                         SigTv       -> fsLit "a"
         ; details <- newMetaDetails meta_info
@@ -418,7 +420,7 @@ writeMetaTyVarRef tyvar ref ty
 -}
 
 newFlexiTyVar :: Kind -> TcM TcTyVar
-newFlexiTyVar kind = newMetaTyVar (TauTv False) kind
+newFlexiTyVar kind = newMetaTyVar (TauTv VanillaTau) kind
 
 newFlexiTyVarTy  :: Kind -> TcM TcType
 newFlexiTyVarTy kind = do
@@ -428,6 +430,11 @@ newFlexiTyVarTy kind = do
 newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
 newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
 
+-- | Creates a TyVarTy that absolutely cannot unify with polytypes
+newFlexiMonoTyVarTy :: Kind -> TcM TcType
+newFlexiMonoTyVarTy kind
+  = TyVarTy <$> newMetaTyVar (TauTv AlwaysMonoTau) kind
+
 newReturnTyVar :: Kind -> TcM TcTyVar
 newReturnTyVar kind = newMetaTyVar ReturnTv kind
 
@@ -449,7 +456,7 @@ tcInstTyVarX :: TvSubst -> TKVar -> TcM (TvSubst, TcTyVar)
 -- an existing TyVar. We substitute kind variables in the kind.
 tcInstTyVarX subst tyvar
   = do  { uniq <- newUnique
-        ; details <- newMetaDetails (TauTv False)
+        ; details <- newMetaDetails (TauTv VanillaTau)
         ; let name   = mkSystemName uniq (getOccName tyvar)
                        -- See Note [Name of an instantiated type variable]
               kind   = substTy subst (tyVarKind tyvar)
@@ -984,7 +991,7 @@ tidySkolemInfo env info = (env, info)
 -- to replace a wildcard in a type. Such a wildcard meta var can be
 -- distinguished from other meta vars with the 'isWildcardVar' function.
 newWildcardVar :: Name -> Kind -> TcM TcTyVar
-newWildcardVar name kind = newNamedMetaTyVar name (TauTv True) kind
+newWildcardVar name kind = newNamedMetaTyVar name (TauTv WildcardTau) kind
 
 -- | Create a new meta var (which can unify with a type of any kind). This
 -- meta var should be used to replace a wildcard in a type. Such a wildcard
@@ -997,5 +1004,5 @@ newWildcardVarMetaKind name = do kind <- newMetaKindVar
 -- | Return 'True' if the argument is a meta var created for a wildcard (by
 -- 'newWildcardVar' or 'newWildcardVarMetaKind').
 isWildcardVar :: TcTyVar -> Bool
-isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv True) _ _ <- tcTyVarDetails tv = True
+isWildcardVar tv | isTcTyVar tv, MetaTv (TauTv WildcardTau) _ _ <- tcTyVarDetails tv = True
 isWildcardVar _ = False
index 0018343..95fd878 100644 (file)
@@ -8,7 +8,8 @@ TcMatches: Typecheck some @Matches@
 
 {-# LANGUAGE CPP, RankNTypes #-}
 
-module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
+module TcMatches ( tcMatchesFun, tcMatchFun,
+                   tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
                    TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,
                    tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,
                    tcDoStmt, tcGuardStmt
@@ -78,19 +79,33 @@ 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, (wrap_tau, group)))
             <- tcSkolemise SkolemiseDeeply (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 <.> wrap_tau, group) }
   where
     arity = matchGroupArity matches
     herald = ptext (sLit "The equation(s) for")
              <+> quotes (ppr fun_name) <+> ptext (sLit "have")
     match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
 
+-- | Like 'tcMatchesFun', but handles the case where there is only one
+-- clause, and we want the ability to infer a polytype
+tcMatchFun :: Name -> Bool
+           -> LMatch Name (LHsExpr Name)
+           -> Origin       -- from the MatchGroup
+           -> TcRhoType     -- Expected type of function (just a TauTv)
+           -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+tcMatchFun fun_name inf match origin exp_ty
+  = tcMatch1 match_ctxt herald match origin exp_ty
+  where
+    herald = ptext (sLit "The equation(s) for")
+             <+> quotes (ppr fun_name) <+> ptext (sLit "have")
+    match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
+
 {-
 @tcMatchesCase@ doesn't do the argument-count check because the
 parser guarantees that each equation has exactly one argument.
@@ -101,29 +116,52 @@ tcMatchesCase :: (Outputable (body Name)) =>
               -> TcSigmaType                                  -- Type of scrutinee
               -> MatchGroup Name (Located (body Name))        -- The case alternatives
               -> TcRhoType                                    -- Type of whole case expressions
-              -> TcM (MatchGroup TcId (Located (body TcId)))  -- Translated alternatives
+              -> TcM (HsWrapper, MatchGroup TcId (Located (body TcId)))
+                 -- Translated alternatives
+                 -- wrapper goes from MatchGroup's ty to expected ty
 
 tcMatchesCase ctxt scrut_ty matches res_ty
   | isEmptyMatchGroup matches   -- Allow empty case expressions
-  = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty, mg_origin = mg_origin matches })
+  = return (idHsWrapper, MG { mg_alts = []
+                            , mg_arg_tys = [scrut_ty]
+                            , mg_res_ty = res_ty
+                            , mg_origin = mg_origin matches })
 
   | otherwise
   = tcMatches ctxt [scrut_ty] res_ty matches
 
 tcMatchLambda :: MatchGroup Name (LHsExpr Name) -> TcRhoType
               -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
-tcMatchLambda match res_ty
-  = matchFunTys herald n_pats res_ty  $ \ pat_tys rhs_ty ->
-    tcMatches match_ctxt pat_tys rhs_ty match
+tcMatchLambda (MG { mg_alts = [match], mg_origin = origin }) res_ty
+  = tcMatch1 match_ctxt herald match origin res_ty
   where
-    n_pats = matchGroupArity match
     herald = sep [ ptext (sLit "The lambda expression")
                          <+> quotes (pprSetDepth (PartWay 1) $
-                             pprMatches (LambdaExpr :: HsMatchContext Name) match),
+                             pprMatch (LambdaExpr :: HsMatchContext Name)
+                                      (unLoc match)),
                         -- The pprSetDepth makes the abstraction print briefly
                 ptext (sLit "has")]
     match_ctxt = MC { mc_what = LambdaExpr,
                       mc_body = tcBody }
+tcMatchLambda group _ = pprPanic "tcMatchLambda" $
+                        pprMatches (LambdaExpr :: HsMatchContext Name) group
+
+-- | Convenient wrapper for case with only one match
+tcMatch1 :: TcMatchCtxt HsExpr
+         -> SDoc                 -- ^ herald for 'matchFunTys'
+         -> LMatch Name (LHsExpr Name)
+         -> Origin               -- ^ from the 'MatchGroup'
+         -> TcRhoType
+         -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+tcMatch1 match_ctxt herald match origin res_ty
+  = matchFunTys herald arity res_ty $ \ pat_tys rhs_ty ->
+    do { match' <- tcMatch match_ctxt pat_tys rhs_ty match
+       ; return (MG { mg_alts    = [match']
+                    , mg_arg_tys = pat_tys
+                    , mg_res_ty  = rhs_ty
+                    , mg_origin  = origin }) }
+  where
+    arity = length (hsLMatchPats match)
 
 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
 
@@ -159,11 +197,14 @@ matchFunTys herald arity res_ty thing_inside
 ************************************************************************
 -}
 
+-- | Type-check a MatchGroup. This deeply instantiates the return
+-- type: it cannot be used to infer a polytype.
 tcMatches :: (Outputable (body Name)) => TcMatchCtxt body
           -> [TcSigmaType]      -- Expected pattern types
           -> TcRhoType          -- Expected result-type of the Match.
           -> MatchGroup Name (Located (body Name))
-          -> TcM (MatchGroup TcId (Located (body TcId)))
+          -> TcM (HsWrapper, MatchGroup TcId (Located (body TcId)))
+               -- wrapper goes from MatchGroup's ty to the expected ty
 
 data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
@@ -174,8 +215,14 @@ data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
 
 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin })
   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
-    do  { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
-        ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty, mg_origin = origin }) }
+    do  { tau_ty <- newFlexiMonoTyVarTy openTypeKind
+        ; wrap   <- tcSubTypeDS GenSigCtxt tau_ty rhs_ty
+        ; tau_ty <- zonkTcType tau_ty   -- seems more efficient to zonk just once
+        ; matches' <- mapM (tcMatch ctxt pat_tys tau_ty) matches
+        ; return (wrap, MG { mg_alts = matches'
+                           , mg_arg_tys = pat_tys
+                           , mg_res_ty = tau_ty
+                           , mg_origin = origin }) }
 
 -------------
 tcMatch :: (Outputable (body Name)) => TcMatchCtxt body
index 50bad30..1dd67dc 100644 (file)
@@ -1,5 +1,6 @@
 module TcMatches where
-import HsSyn    ( GRHSs, MatchGroup, LHsExpr )
+import HsSyn    ( GRHSs, MatchGroup, LHsExpr, LMatch )
+import BasicTypes ( Origin )
 import TcEvidence( HsWrapper )
 import Name     ( Name )
 import TcType   ( TcRhoType )
@@ -14,3 +15,9 @@ tcMatchesFun :: Name -> Bool
              -> MatchGroup Name (LHsExpr Name)
              -> TcRhoType
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
+
+tcMatchFun :: Name -> Bool
+           -> LMatch Name (LHsExpr Name)
+           -> Origin       -- from the MatchGroup
+           -> TcRhoType     -- Expected type of function (just a TauTv)
+           -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
index 8bcbe85..6650337 100644 (file)
@@ -18,7 +18,7 @@ module TcPat ( tcLetPat, TcSigFun, TcPragFun
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferRho )
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigma )
 
 import HsSyn
 import TcHsSyn
@@ -533,12 +533,9 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
 
 tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
   = do  {
-         -- Morally, expr must have type `forall a1...aN. OPT' -> B`
+         -- Expr must have type `forall a1...aN. OPT' -> B`
          -- where overall_pat_ty is an instance of OPT'.
-         -- Here, we infer a rho type for it,
-         -- which replaces the leading foralls and constraints
-         -- with fresh unification variables.
-        ; (expr',expr'_inferred) <- tcInferRho expr
+        ; (expr',expr'_inferred) <- tcInferSigma expr
 
          -- next, we check that expr is coercible to `overall_pat_ty -> pat_ty`
         ; (expr_wrap, pat_ty) <- tcInfer $ \ pat_ty ->
index a8e75c0..ccc10a1 100644 (file)
@@ -2650,7 +2650,7 @@ instFlexiTcS tvs = wrapTcS (mapAccumLM inst_one emptyTvSubst tvs)
 instFlexiTcSHelper :: Name -> Kind -> TcM TcType
 instFlexiTcSHelper tvname kind
   = do { uniq <- TcM.newUnique
-       ; details <- TcM.newMetaDetails (TauTv False)
+       ; details <- TcM.newMetaDetails (TauTv VanillaTau)
        ; let name = setNameUnique tvname uniq
        ; return (mkTyVarTy (mkTcTyVar name kind details)) }
 
index 0c036b9..6a140b1 100644 (file)
@@ -31,7 +31,7 @@ module TcType (
   -- MetaDetails
   UserTypeCtxt(..), pprUserTypeCtxt, pprSigCtxt,
   TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
-  MetaDetails(Flexi, Indirect), MetaInfo(..),
+  MetaDetails(Flexi, Indirect), MetaInfo(..), TauTvFlavour(..),
   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,
   isSigTyVar, isOverlappableTyVar,  isTyConableTyVar,
   isFskTyVar, isFmvTyVar, isFlattenTyVar, isReturnTyVar,
@@ -347,12 +347,17 @@ instance Outputable MetaDetails where
   ppr Flexi         = ptext (sLit "Flexi")
   ppr (Indirect ty) = ptext (sLit "Indirect") <+> ppr ty
 
+data TauTvFlavour
+  = VanillaTau     -- ^ This generally avoids unifying with polytypes, but
+                   -- if its kind is OpenKind, it will unify with a polytype.
+                   -- This is the most common flavour of TauTv
+                   -- See Note [OpenTypeKind accepts foralls]
+  | WildcardTau    -- ^ A tyvar that originates from a type wildcard.
+  | AlwaysMonoTau  -- ^ A tyvar that really can only unify with a monotype.
+
 data MetaInfo
-   = TauTv Bool    -- This MetaTv is an ordinary unification variable
-                   -- A TauTv is always filled in with a tau-type, which
-                   -- never contains any ForAlls.
-                   -- The boolean is true when the meta var originates
-                   -- from a wildcard.
+   = TauTv TauTvFlavour
+                   -- This MetaTv is an ordinary unification variable
 
    | ReturnTv      -- Can unify with *anything*. Used to convert a
                    -- type "checking" algorithm into a type inference algorithm.
@@ -533,8 +538,9 @@ pprTcTyVarDetails (MetaTv { mtv_info = info, mtv_tclvl = tclvl })
   where
     pp_info = case info of
                 ReturnTv    -> ptext (sLit "ret")
-                TauTv True  -> ptext (sLit "twc")
-                TauTv False -> ptext (sLit "tau")
+                TauTv WildcardTau   -> ptext (sLit "twc")
+                TauTv VanillaTau    -> ptext (sLit "tau")
+                TauTv AlwaysMonoTau -> ptext (sLit "mono")
                 SigTv       -> ptext (sLit "sig")
                 FlatMetaTv  -> ptext (sLit "fuv")
 
@@ -1298,8 +1304,9 @@ occurCheckExpand dflags tv ty
 canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> TcKind -> Bool
 canUnifyWithPolyType dflags details kind
   = case details of
-      MetaTv { mtv_info = ReturnTv } -> True      -- See Note [ReturnTv]
-      MetaTv { mtv_info = SigTv }    -> False
+      MetaTv { mtv_info = ReturnTv }            -> True   -- See Note [ReturnTv]
+      MetaTv { mtv_info = SigTv }               -> False
+      MetaTv { mtv_info = TauTv AlwaysMonoTau } -> False
       MetaTv { mtv_info = TauTv _ }  -> xopt Opt_ImpredicativeTypes dflags
                                      || isOpenTypeKind kind
                                           -- Note [OpenTypeKind accepts foralls]
index 482ed30..01f928e 100644 (file)
@@ -671,6 +671,7 @@ tc_sub_type_ds origin ctxt ty_actual ty_expected = go ty_actual ty_expected
                Filled ty_e'     -> tc_sub_type origin ctxt ty_a ty_e'
                Unfilled details
                  |  canUnifyWithPolyType dflags details (tyVarKind tv_e)
+                    && isMetaTyVar tv_e  -- don't want skolems here
                  -> coToHsWrapper <$> uType origin ty_a ty_e
 
      -- We've avoided instantiating ty_actual just in case ty_expected is