It compiles.
authorRichard Eisenberg <eir@cis.upenn.edu>
Tue, 30 Jun 2015 21:25:02 +0000 (17:25 -0400)
committerRichard Eisenberg <eir@cis.upenn.edu>
Tue, 30 Jun 2015 21:25:02 +0000 (17:25 -0400)
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsUtils.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcExpr.hs-boot
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcUnify.hs

index 9773fae..9b6b6c6 100644 (file)
@@ -1071,8 +1071,8 @@ patterns in each equation.
 
 data MatchGroup id body
   = MG { mg_alts    :: [LMatch id body]  -- The alternatives
-       , mg_arg_tys :: [PostTc id TcSigmaType]  -- Types of the arguments, t1..tn
-       , mg_res_ty  :: PostTc id TcSigmaType    -- Type of the result, tr
+       , mg_arg_tys :: [PostTc id Type]  -- Types of the arguments, t1..tn
+       , mg_res_ty  :: PostTc id Type    -- Type of the result, tr
        , mg_origin  :: Origin }
      -- The type is the type of the entire group
      --      t1 -> ... -> tn -> tr
@@ -1976,32 +1976,3 @@ pprStmtInCtxt ctxt stmt
     ppr_stmt (TransStmt { trS_by = by, trS_using = using
                         , trS_form = form }) = pprTransStmt by using form
     ppr_stmt stmt = pprStmt stmt
-
-{-
-************************************************************************
-*                                                                      *
-   WrappableThing
-*                                                                      *
-************************************************************************
-
-This class is used in one place, but it's quite hard to refactor away
-from using a class. The one place is in tcMatches, where we sometimes
-have an HsExpr and sometimes have a HsCmd. We need to wrap one of these
-things, but only if its an HsExpr. Suggestions for refactoring are
-welcome.
-
--}
-
--- | Can this be wrapped by an 'HsWrapper'?
-class WrappableThing thing where
-  wrapThing :: HsWrapper -> thing id -> thing id
-
-instance WrappableThing HsExpr where
-  wrapThing = mkHsWrap
-
--- So, this is a lie. But the whole arrow thing uses only tau-types, and wrappers
--- will come up only in higher-rank situations. So this is safe.
-instance WrappableThing HsCmd where
-  wrapThing wrap cmd
-    = ASSERT( isIdHsWrapper wrap )
-      cmd
index 2242d10..26fc8a6 100644 (file)
@@ -26,6 +26,7 @@ module HsUtils(
   coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams,
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdCast,
+  WrappableThing(..),
 
   nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
@@ -513,6 +514,35 @@ mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
 mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
 
 {-
+************************************************************************
+*                                                                      *
+   WrappableThing
+*                                                                      *
+************************************************************************
+
+This class is used in one place, but it's quite hard to refactor away
+from using a class. The one place is in tcMatches, where we sometimes
+have an HsExpr and sometimes have a HsCmd. We need to wrap one of these
+things, but only if its an HsExpr. Suggestions for refactoring are
+welcome.
+
+-}
+
+-- | Can this be wrapped by an 'HsWrapper'?
+class WrappableThing thing where
+  wrapThing :: HsWrapper -> thing id -> thing id
+
+instance WrappableThing HsExpr where
+  wrapThing = mkHsWrap
+
+-- So, this is a lie. But the whole arrow thing uses only tau-types, and wrappers
+-- will come up only in higher-rank situations. So this is safe.
+instance WrappableThing HsCmd where
+  wrapThing wrap cmd
+    = ASSERT( isIdHsWrapper wrap )
+      cmd
+
+{-
 l
 ************************************************************************
 *                                                                      *
index 95826a8..f6dd1ff 100644 (file)
@@ -15,7 +15,7 @@ module Inst (
        newWanted, newWanteds,
        emitWanted, emitWanteds,
 
-       newOverloadedLit, mkOverLit,
+       newNonTrivialOverloadedLit, mkOverLit,
 
        newClsInst,
        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
@@ -177,8 +177,7 @@ topSkolemise sigma
        ; let theta' = substTheta subst theta
              rho'   = substTy    subst rho
        ; ev_vars <- newEvVars theta'
-       ; (wrap, inner_tvs', inner_ev_vars, inner_rho) <-
-           topSkolemise skol_all rho'
+       ; (wrap, inner_tvs', inner_ev_vars, inner_rho) <- topSkolemise rho'
                -- This handles types like
                -- forall a. Num a => forall b. Ord b => ...
 
@@ -189,10 +188,6 @@ topSkolemise sigma
   where
     (tvs, theta, rho) = tcSplitSigmaTy sigma
 
-    should_skol
-      | skol_all  = const True
-      | otherwise = isInferredTv
-
 deeplySkolemise
   :: TcSigmaType
   -> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
@@ -223,7 +218,7 @@ topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 -- then  wrap e :: rho
 
 topInstantiate orig ty
-  | Just (tvs, theta, rho) <- tcSplitSigmaTy_maybe ty
+  | not (null tvs && null theta)
   = do { (subst, tvs') <- tcInstTyVars tvs
        ; let theta' = substTheta subst theta
        ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
@@ -236,6 +231,8 @@ topInstantiate orig ty
        ; return (wrap2 <.> wrap1, rho2) }
 
   | otherwise = return (idHsWrapper, ty)
+  where
+    (tvs, theta, rho) = tcSplitSigmaTy ty
 
 {-
 ************************************************************************
@@ -322,8 +319,8 @@ newNonTrivialOverloadedLit :: CtOrigin
                            -> TcSigmaType
                            -> TcM (HsOverLit TcId)
 newNonTrivialOverloadedLit orig
-  lit@(OverLit { ol_val = val, ol_rebindable = rebindalbe
-               , ol_witness = meth_name }) res_ty
+  lit@(OverLit { ol_val = val, ol_witness = meth_name
+               , ol_rebindable = rebindable }) res_ty
   = do  { hs_lit <- mkOverLit val
         ; let lit_ty = hsLitType hs_lit
         ; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
@@ -332,8 +329,8 @@ newNonTrivialOverloadedLit orig
                 -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
                 -- However this'll be picked up by tcSyntaxOp if necessary
         ; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
-        ; return (lit { ol_witness = witness, ol_type = res_ty
-                      , ol_rebindable = rebindable }) }
+        ; return (lit { ol_witness = witness, ol_type = res_ty,
+                        ol_rebindable = rebindable }) }
 
 ------------
 mkOverLit :: OverLitVal -> TcM HsLit
index 46e27ef..fc2c8f4 100644 (file)
@@ -319,9 +319,14 @@ matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercion, [TcType], TcType)
 matchExpectedCmdArgs 0 ty
   = return (mkTcNomReflCo ty, [], ty)
 matchExpectedCmdArgs n ty
-  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty
+  = do { (wrap1, [ty1, ty2]) <- matchExpectedTyConApp Expected pairTyCon ty
+       ; let co1 = unwrap_co wrap1 ty
        ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2
        ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }
+  where
+    unwrap_co WpHole      t = mkTcNomReflCo t
+    unwrap_co (WpCast co) _ = co
+    unwrap_co wrap        _ = pprPanic "matchExpectedCmdArgs" (ppr wrap)
 
 {-
 ************************************************************************
index fe98c63..e5aefb8 100644 (file)
@@ -11,7 +11,7 @@ c%
 module TcExpr ( tcPolyExpr, tcPolyExprNC,
                 tcInferSigma, tcInferSigmaNC,
                 tcSyntaxOp, tcCheckId,
-                addExprErrCtxt) where
+                addExprErrCtxt, tcSkolemiseExpr ) where
 
 #include "HsVersions.h"
 
@@ -141,7 +141,7 @@ tcExpr (HsUnboundVar v) res_ty = tcUnboundId v res_ty
 
 tcExpr (HsApp e1 e2) res_ty
   = do { (wrap, fun, args) <- tcApp Nothing AppOrigin e1 [e2] res_ty
-       ; return (mkHsWrap wrap $ foldl mkHsApp fun args) }
+       ; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args) }
 
 tcExpr (HsLit lit)   res_ty = do { let lit_ty = hsLitType lit
                                  ; tcWrapResult (HsLit lit) lit_ty res_ty }
@@ -162,7 +162,7 @@ tcExpr (HsCoreAnn src lbl expr) res_ty
         ; return (HsCoreAnn src lbl expr') }
 
 tcExpr (HsOverLit lit) res_ty
-  = do  { (wrap,  lit') <- newOverloadedLit (LiteralOrigin lit) lit res_ty
+  = do  { (wrap,  lit') <- newOverloadedLit Expected lit res_ty
         ; return (mkHsWrap wrap $ HsOverLit lit') }
 
 tcExpr (NegApp expr neg_expr) res_ty
@@ -305,7 +305,7 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
          -- So: arg1_ty = arg2_ty -> op_res_ty
          -- where arg2_sigma maybe polymorphic; that's the point
 
-       arg2' <- tcArg op (arg2, arg2_sigma, 2)
+       arg2' <- tcArg op (arg2, arg2_sigma, 2)
 
          -- Make sure that the argument type has kind '*'
          --    ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r
@@ -319,9 +319,8 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
        ; a2_tv <- newReturnTyVar liftedTypeKind
        ; let a2_ty = mkTyVarTy a2_tv
        ; co_a <- unifyType arg2_sigma a2_ty    -- arg2_sigma ~N a2_ty
-       ; return (arg2', a2_ty, co_a) }
 
-       ; wrap_res <- tcSubType op_res_ty res_ty    -- op_res -> res
+       ; wrap_res <- tcSubTypeHR 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))
@@ -355,7 +354,7 @@ tcExpr (SectionR op arg2) res_ty
   = 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 <- tcSubType GenSigCtxt (mkFunTy arg1_ty op_res_ty) res_ty
+       ; wrap_res <- tcSubTypeHR (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' }
@@ -368,8 +367,8 @@ tcExpr (SectionL arg1 op) res_ty
 
        ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
            <- matchExpectedFunTys (Actual SectionOrigin)
-                (mk_op_msg) n_reqd_args op_ty
-       ; wrap_res <- tcSubType (mkFunTys arg_tys op_res_ty) res_ty
+                (mk_op_msg op) n_reqd_args op_ty
+       ; wrap_res <- tcSubTypeHR (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') }
@@ -393,7 +392,7 @@ tcExpr (ExplicitTuple tup_args boxity) res_ty
                = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
                           (mkTyConApp tup_tc arg_tys)
 
-       ; wrap <- tcSubType actual_res_ty res_ty
+       ; wrap <- tcSubTypeHR actual_res_ty res_ty
 
        -- Handle tuple sections where
        ; tup_args1 <- tcTupArgs tup_args arg_tys
@@ -461,10 +460,11 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
             ; b2' <- tcPolyExpr b2 res_rho
             ; return $ HsIf Nothing pred' b1' b2' } }
 
-tcExpr (HsIf (Just fun) pred b1 b2) res_ty   -- Note [Rebindable syntax for if]
+tcExpr (HsIf (Just fun) pred b1 b2) res_ty
+  -- Note [Rebindable syntax for if]
   = do { (wrap, fun', [pred', b1', b2'])
-           <- tcApp (Just herald) IfOrigin fun [pred, b1, b2] res_ty
-       ; return $ mkHsWrap wrap $ (HsIf (Just 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') }
   where
     herald = text "Rebindable" <+> quotes (text "if") <+> text "takes"
 
@@ -479,7 +479,7 @@ tcExpr (HsDo do_or_lc stmts _) res_ty
 
 tcExpr (HsProc pat cmd) res_ty
   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
-        ; return $ mkHsWrapCo coi (HsProc pat' cmd') }
+        ; return $ mkHsWrap coi (HsProc pat' cmd') }
 
 tcExpr (HsStatic expr) res_ty
   = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
@@ -544,7 +544,7 @@ 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 <- tcSubType actual_res_ty res_ty
+        ; res_wrap <- tcSubTypeHR 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' }
@@ -734,7 +734,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 <- tcSubType rec_res_ty res_ty
+        ; wrap_res <- tcSubTypeHR rec_res_ty res_ty
 
         -- STEP 5
         -- Typecheck the thing to be updated, and the bindings
@@ -880,7 +880,7 @@ tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
         ; expr3' <- tcPolyExpr expr3 elt_ty
         ; eft <- newMethodFromName (ArithSeqOrigin seq)
                               enumFromThenToName elt_ty
-        ; return $ mkHsWrao coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
+        ; return $ mkHsWrap coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
 
 -----------------
 arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
@@ -916,7 +916,7 @@ tcApp m_herald orig (L _ (HsPar e)) args res_ty
   = tcApp m_herald orig e args res_ty
 
 tcApp m_herald orig (L _ (HsApp e1 e2)) args res_ty
-  = tcApp m_herald e1 (e2:args) res_ty   -- Accumulate the arguments
+  = tcApp m_herald orig e1 (e2:args) res_ty   -- Accumulate the arguments
 
 tcApp _ _ (L loc (HsVar fun)) args res_ty
   | fun `hasKey` tagToEnumKey
@@ -1246,7 +1246,7 @@ the users that complain.
 -}
 
 tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name
-      -> TcSigmaType -> TcM (HsExpr TcId)
+      -> TcSigmaType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
 -- (seq e1 e2) :: res_ty
 -- We need a special typing rule because res_ty can be unboxed
 tcSeq loc fun_name arg1 arg2 res_ty
@@ -1258,40 +1258,43 @@ tcSeq loc fun_name arg1 arg2 res_ty
         ; arg2' <- tcPolyExpr arg2 res_ty
         ; let fun'    = L loc (HsWrap ty_args (HsVar fun))
               ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
-        ; return (HsApp (L loc (HsApp fun' arg1')) arg2') }
+        ; return (idHsWrapper, fun', [arg1', arg2']) }
 
-tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcSigmaType -> TcM (HsExpr TcId)
+tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcSigmaType
+            -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
 -- tagToEnum# :: forall a. Int# -> a
 -- See Note [tagToEnum#]   Urgh!
 tcTagToEnum loc fun_name arg res_ty
     -- If SkolemiseTop and SkolemiseDeeply would do different things, then
     -- we clearly don't have an enumeration. Do the cheaper one.
-  = tcSkolemiseExpr SkolemiseTop res_ty $ \res_rho ->
-    do { fun <- tcLookupId fun_name
-       ; ty' <- zonkTcType res_rho
-
-       -- Check that the type is algebraic
-       ; let mb_tc_app = tcSplitTyConApp_maybe ty'
-             Just (tc, tc_args) = mb_tc_app
-       ; checkTc (isJust mb_tc_app)
-                 (mk_error ty' doc1)
-
-       -- Look through any type family
-       ; fam_envs <- tcGetFamInstEnvs
-       ; let (rep_tc, rep_args, coi)
-               = tcLookupDataFamInst fam_envs tc tc_args
-            -- coi :: tc tc_args ~R rep_tc rep_args
-
-       ; checkTc (isEnumerationTyCon rep_tc)
-                 (mk_error ty' doc2)
-
-       ; arg' <- tcPolyExpr arg intPrimTy
-       ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
-             rep_ty = mkTyConApp rep_tc rep_args
-
-       ; return (mkHsWrapCoR (mkTcSymCo $ TcCoercion coi) $
-                 HsApp fun' arg') }
-            -- coi is a Representational coercion
+  = do { (outer_wrap, (inner_wrap, fun, arg)) <-
+            tcSkolemise SkolemiseTop GenSigCtxt res_ty $ \_ res_rho ->
+            do { fun <- tcLookupId fun_name
+               ; ty' <- zonkTcType res_rho
+
+               -- Check that the type is algebraic
+               ; let mb_tc_app = tcSplitTyConApp_maybe ty'
+                     Just (tc, tc_args) = mb_tc_app
+               ; checkTc (isJust mb_tc_app)
+                         (mk_error ty' doc1)
+
+               -- Look through any type family
+               ; fam_envs <- tcGetFamInstEnvs
+               ; let (rep_tc, rep_args, coi)
+                       = tcLookupDataFamInst fam_envs tc tc_args
+                    -- coi :: tc tc_args ~R rep_tc rep_args
+
+               ; checkTc (isEnumerationTyCon rep_tc)
+                         (mk_error ty' doc2)
+
+               ; arg' <- tcPolyExpr arg intPrimTy
+               ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
+                     rep_ty = mkTyConApp rep_tc rep_args
+
+               ; return ( coToHsWrapperR (mkTcSymCo $ TcCoercion coi)
+                        , fun', arg' ) }
+                    -- coi is a Representational coercion
+       ; return (outer_wrap <.> inner_wrap, fun, [arg]) }
   where
     doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
                 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
index 09a0c2f..944ac4f 100644 (file)
@@ -1,7 +1,7 @@
 module TcExpr where
 import HsSyn    ( HsExpr, LHsExpr )
 import Name     ( Name )
-import TcType   ( TcType, TcRhoType, TcSigmaType )
+import TcType   ( TcType, TcSigmaType )
 import TcRnTypes( TcM, TcId, CtOrigin )
 
 tcPolyExpr, tcPolyExprNC ::
index 6e842e9..6abd101 100644 (file)
@@ -15,7 +15,7 @@ module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambd
        ) where
 
 import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma,
-                                tcCheckId, tcPolyExpr )
+                                tcCheckId, tcPolyExpr, tcPolyExprNC )
 
 import HsSyn
 import BasicTypes
@@ -166,7 +166,7 @@ data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin })
   | [match] <- matches
   = do { match' <- tcMatch ctxt pat_tys rhs_ty match
-         return (MG { mg_alts    = [match']
+       ; return (MG { mg_alts    = [match']
                     , mg_arg_tys = pat_tys
                     , mg_res_ty  = rhs_ty
                     , mg_origin  = origin }) }
@@ -193,8 +193,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin })
       = L loc (alt { m_grhss = wrap_grhss wrap (m_grhss alt) })
     wrap_grhss wrap grhss
       = grhss { grhssGRHSs = map (wrap_grhs wrap) (grhssGRHSs grhss) }
-    wrap_ghrs wrap (L loc (GRHS guards rhs))
-      = L loc (GRHS guards (wrapThing rhs))
+    wrap_grhs wrap (L loc (GRHS guards (L loc' rhs)))
+      = L loc (GRHS guards (L loc' (wrapThing wrap rhs)))
 
 -------------
 tcMatch :: (Outputable (body Name)) => TcMatchCtxt body
index f5bb118..702c0c8 100644 (file)
@@ -547,7 +547,8 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
          -- we will only be able to use view at one instantation in the
          -- rest of the view
         ; (expr_wrap, pat_ty) <- tcInfer $ \ pat_ty ->
-                tcSubTypeDS expr'_inferred (mkFunTy overall_pat_ty pat_ty)
+                tcSubTypeDS GenSigCtxt expr'_inferred
+                            (mkFunTy overall_pat_ty pat_ty)
 
          -- pattern must have pat_ty
         ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
@@ -590,7 +591,8 @@ 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
+        ; (coi, arg_tys) <- matchExpectedPatTy (flip matchExpectedTyConApp tc)
+                              pat_ty
         ; (pats', res) <- tc_lpats penv pats arg_tys thing_inside
 
         ; dflags <- getDynFlags
@@ -639,7 +641,7 @@ tc_pat _ (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside
                             do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
                                ; return (Just neg') }
         ; res <- thing_inside
-        ; return (NPat (L l (mkHsWrapPat wrap lit')) mb_neg' eq', res) }
+        ; return (mkHsWrapPat wrap (NPat (L l lit') mb_neg' eq') pat_ty, res) }
 
 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)
@@ -650,8 +652,11 @@ tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) ge minus) pat_ty thing_inside
         -- The '>=' and '-' parts are re-mappable syntax
         ; ge'    <- tcSyntaxOp orig ge    (mkFunTys [pat_ty', pat_ty'] boolTy)
         ; minus' <- tcSyntaxOp orig minus (mkFunTys [pat_ty', pat_ty'] pat_ty')
-        ; let pat' = NPlusKPat (L nm_loc bndr_id) (L loc (mkHsWrapPat wrap_lit lit'))
-                               ge' minus'
+        ; let pat' = mkHsWrapPat wrap_lit
+                                 (NPlusKPat (L nm_loc bndr_id)
+                                            (L loc lit')
+                                            ge' minus')
+                                 pat_ty
 
         -- The Report says that n+k patterns must be in Integral
         -- We may not want this when using re-mappable syntax, though (ToDo?)
index bb7ceae..4c76ccc 100644 (file)
@@ -65,6 +65,7 @@ import TcForeign
 import TcInstDcls
 import TcIface
 import TcMType
+import Inst   ( topInstantiate )
 import MkIface
 import TcSimplify
 import TcTyClsDecls
@@ -1796,7 +1797,7 @@ tcRnExpr hsc_env rdr_expr
     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
     ((_tc_expr, res_ty), tclvl, lie) <- pushLevelAndCaptureConstraints $
                                         tcInferSigma rn_expr ;
-    (_wrap , res_tau) <- topInstantiate GeneraliseOrigin res_ty
+    (_wrap, res_tau) <- topInstantiate GeneraliseOrigin res_ty ;
     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
                                       {-# SCC "simplifyInfer" #-}
                                       simplifyInfer tclvl
index 00116d4..5a6a247 100644 (file)
@@ -157,7 +157,6 @@ tcTypedBracket brack@(TExpBr expr) res_ty
 
        ; (_, expr_ty) <- topInstantiate ThBrackOrigin expr_ty
        ; meta_ty <- tcTExpTy expr_ty
-       ; wrap <- tcSubType meta_ty res_ty
        ; ps' <- readMutVar ps_ref
        ; texpco <- tcLookupId unsafeTExpCoerceName
        ; tcWrapResult (unLoc (mkHsApp (nlHsTyApp texpco [expr_ty])
@@ -417,7 +416,7 @@ When a variable is used, we compare
 tcSpliceExpr splice@(HsTypedSplice name expr) res_ty
   = addErrCtxt (spliceCtxtDoc splice) $
     setSrcSpan (getLoc expr)    $
-    tcSkolemiseExpr SkolemiseDeeply res_ty $ \ res_rho $ do
+    tcSkolemiseExpr SkolemiseDeeply res_ty $ \ res_rho -> do
     { stage <- getStage
     ; case stage of
         Splice {}            -> tcTopSplice expr res_rho
@@ -546,7 +545,7 @@ runAnnotation target expr = do
               ; let specialised_to_annotation_wrapper_expr
                       = L loc (HsWrap wrapper (HsVar to_annotation_wrapper_id))
               ; return (L loc (HsApp specialised_to_annotation_wrapper_expr $
-                                     mkHsWrap expr'_wrapper expr')) }
+                                     mkLHsWrap expr'_wrapper expr')) }
 
     -- Run the appropriately wrapped expression to get the value of
     -- the annotation and its dictionaries. The return value is of
index 5269d29..b78ab95 100644 (file)
@@ -6,12 +6,12 @@
 Type subsumption and unification
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, TupleSections #-}
 
 module TcUnify (
   -- Full-blown subsumption
   tcWrapResult, tcSkolemise, SkolemiseMode(..),
-  tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC,
+  tcSubTypeHR, tcSubType, tcSubType_NC, tcSubTypeDS, tcSubTypeDS_NC,
   checkConstraints,
 
   -- Various unifications
@@ -21,12 +21,14 @@ module TcUnify (
   --------------------------------
   -- Holes
   tcInfer,
+  ExpOrAct(..),
   matchExpectedListTy,
   matchExpectedPArrTy,
   matchExpectedTyConApp,
-  matchExpectedAppTy,
+  matchExpectedAppTys,
   matchExpectedFunTys,
   matchExpectedFunKind,
+  newOverloadedLit,
   wrapFunResCoercion
 
   ) where
@@ -38,9 +40,10 @@ import TypeRep
 import TcMType
 import TcRnMonad
 import TcType
+import TcHsSyn ( shortCutLit )
 import Type
 import TcEvidence
-import Name ( isSystemName )
+import Name ( Name, isSystemName )
 import Inst
 import Kind
 import TyCon
@@ -175,7 +178,7 @@ matchExpectedFunTys :: ExpOrAct
 -- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd
 -- hide the forall inside a meta-variable
 
-matchExpectedFunTys ea herald = go
+matchExpectedFunTys ea herald arity orig_ty = go arity orig_ty
   where
     -- If     go n ty = (co, [t1,..,tn], ty_r)
     -- then   Actual:   wrap : ty "->" (t1 -> .. -> tn -> ty_r)
@@ -199,7 +202,10 @@ matchExpectedFunTys ea herald = go
     go n_req (FunTy arg_ty res_ty)
       | not (isPredTy arg_ty)
       = do { (wrap_res, tys, ty_r) <- go (n_req-1) res_ty
-           ; return ( mkWpFun idHsWrapper wrap_res
+           ; let rhs_ty = case ea of
+                   Expected -> res_ty
+                   Actual _ -> mkFunTys tys ty_r
+           ; return ( mkWpFun idHsWrapper wrap_res arg_ty rhs_ty
                     , arg_ty:tys, ty_r ) }
 
     go n_req ty@(TyVarTy tv)
@@ -315,7 +321,7 @@ matchExpectedTyConApp ea tc orig_ty
        | Just ty' <- tcView ty
        = go ty'
 
-    go ty@(TyConApp tycon args)
+    go (TyConApp tycon args)
        | tc == tycon  -- Common case
        = return (idHsWrapper, args)
 
@@ -342,7 +348,7 @@ matchExpectedTyConApp ea tc orig_ty
             do { kappa_tys <- mapM (const newMetaKindVar) kvs
                ; let arg_kinds' = map (substKiWith kvs kappa_tys) arg_kinds
                ; tau_tys <- mapM newFlexiTyVarTy arg_kinds'
-               ; let arg_tys = kappa_tys ++ arg_tys
+               ; let arg_tys = kappa_tys ++ tau_tys
                      unif_ty = mkTyConApp tc arg_tys
                ; wrap <- matchUnificationType ea unif_ty orig_ty
                ; return (wrap, arg_tys) }
@@ -361,11 +367,12 @@ matchExpectedAppTys :: Arity
 -- Only runs in "Expected" mode, with skolemisation, never instantiation.
 
 matchExpectedAppTys n orig_ty
-  = do { (wrap, mb_stuff) <- exposeRhoType Expected orig_ty (go n)
+  = do { (wrap, mb_stuff) <- tcSkolemise SkolemiseTop GenSigCtxt orig_ty $
+                             \ _ rho -> go n rho
        ; case mb_stuff of
             Just (co, fun_ty, arg_tys) ->
               return (wrap <.> coToHsWrapper co, fun_ty, reverse arg_tys)
-            Nothing -> defer
+            Nothing -> defer }
   where
     go 0 ty = return (Just (mkTcNomReflCo ty, ty, []))
 
@@ -373,23 +380,26 @@ matchExpectedAppTys n orig_ty
       | Just ty' <- tcView ty = go n ty'
 
       | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
-      = do { (inner_co, inner_fun_ty, arg_tys) <- go (n-1) fun_ty
-           ; return $ Just ( mkTcAppCo inner_co (mkTcNomReflCo arg_ty)
-                           , inner_fun_ty, arg_ty : arg_tys ) }
-
-    go (TyVarTy tv)
+      = do { mb_stuff <- go (n-1) fun_ty
+           ; return $ case mb_stuff of
+               Just (inner_co, inner_fun_ty, arg_tys)
+                 -> Just ( mkTcAppCo inner_co (mkTcNomReflCo arg_ty)
+                         , inner_fun_ty, arg_ty : arg_tys )
+               Nothing -> Nothing }
+
+    go n (TyVarTy tv)
       | ASSERT( isTcTyVar tv) isMetaTyVar tv
       = do { cts <- readMetaTyVar tv
            ; case cts of
-               Indirect ty -> go ty
+               Indirect ty -> go ty
                Flexi       -> return Nothing }
 
-    go _ = return Nothing
+    go _ = return Nothing
 
     -- Defer splitting by generating an equality constraint
     defer = do { fun_ty  <- newFlexiTyVarTy fun_kind
                ; arg_tys <- newFlexiTyVarTys n liftedTypeKind
-               ; wrap <- tcSubType (mkAppTys fun_ty arg_tys) orig_ty
+               ; wrap <- tcSubTypeHR (mkAppTys fun_ty arg_tys) orig_ty
                ; return (wrap, fun_ty, arg_tys) }
 
     orig_kind = typeKind orig_ty
@@ -416,8 +426,7 @@ newOverloadedLit :: ExpOrAct
                  -> TcSigmaType
                  -> TcM (HsWrapper, HsOverLit TcId)
 newOverloadedLit ea
-  lit@(OverLit { ol_val = val, ol_rebindable = rebindable
-               , old_witness = meth_name }) res_ty
+  lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty
   | not rebindable
     -- all built-in overloaded lits are not higher-rank, so skolemise.
     -- this is necessary for shortCutLit.
@@ -430,11 +439,13 @@ newOverloadedLit ea
         --         which tcSimplify doesn't like
            Just expr -> return (lit { ol_witness = expr, ol_type = res_rho
                                     , ol_rebindable = False })
-           Nothing   -> newOverloadedLit' orig lit res_rho }
+           Nothing   -> newNonTrivialOverloadedLit orig lit res_rho }
 
   | otherwise
-  = do { lit' <- newNonTrivialOverloadedLit (LiteralOrigin lit) lit res_ty
+  = do { lit' <- newNonTrivialOverloadedLit orig lit res_ty
        ; return (idHsWrapper, lit') }
+  where
+    orig = LiteralOrigin lit
 
 
 {-
@@ -525,6 +536,10 @@ So it's important that we unify beta := forall a. a->a, rather than
 skolemising the type.
 -}
 
+-- | Use this wrapper for 'tcSubType' in higher-rank situations.
+tcSubTypeHR :: TcSigmaType -> TcSigmaType -> TcM HsWrapper
+tcSubTypeHR = tcSubType GenSigCtxt
+
 tcSubType :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper
 -- Checks that actual <= expected
 -- Returns HsWrapper :: actual ~ expected