Refactor the typechecker to use ExpTypes.
authorRichard Eisenberg <eir@cis.upenn.edu>
Thu, 14 Jan 2016 04:29:17 +0000 (23:29 -0500)
committerRichard Eisenberg <eir@cis.upenn.edu>
Wed, 27 Jan 2016 14:33:26 +0000 (09:33 -0500)
The idea here is described in [wiki:Typechecker]. Briefly,
this refactor keeps solid track of "synthesis" mode vs
"checking" in GHC's bidirectional type-checking algorithm.
When in synthesis mode, the expected type is just an IORef
to write to.

In addition, this patch does a significant reworking of
RebindableSyntax, allowing much more freedom in the types
of the rebindable operators. For example, we can now have
`negate :: Int -> Bool` and
`(>>=) :: m a -> (forall x. a x -> m b) -> m b`. The magic
is in tcSyntaxOp.

This addresses tickets #11397, #11452, and #11458.

Tests:
  typecheck/should_compile/{RebindHR,RebindNegate,T11397,T11458}
  th/T11452

128 files changed:
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsArrows.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/DsExpr.hs-boot
compiler/deSugar/DsGRHSs.hs
compiler/deSugar/DsListComp.hs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsUtils.hs
compiler/deSugar/Match.hs
compiler/deSugar/MatchLit.hs
compiler/deSugar/PmExpr.hs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/Convert.hs
compiler/hsSyn/HsExpr.hs
compiler/hsSyn/HsExpr.hs-boot
compiler/hsSyn/HsLit.hs
compiler/hsSyn/HsPat.hs
compiler/hsSyn/HsUtils.hs
compiler/hsSyn/PlaceHolder.hs
compiler/parser/Parser.y
compiler/parser/RdrHsSyn.hs
compiler/rename/RnEnv.hs
compiler/rename/RnExpr.hs
compiler/rename/RnPat.hs
compiler/typecheck/Inst.hs
compiler/typecheck/TcArrows.hs
compiler/typecheck/TcBinds.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcEvidence.hs
compiler/typecheck/TcExpr.hs
compiler/typecheck/TcExpr.hs-boot
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcHsSyn.hs
compiler/typecheck/TcHsType.hs
compiler/typecheck/TcInstDcls.hs
compiler/typecheck/TcMType.hs
compiler/typecheck/TcMatches.hs
compiler/typecheck/TcMatches.hs-boot
compiler/typecheck/TcPat.hs
compiler/typecheck/TcPatSyn.hs
compiler/typecheck/TcRnDriver.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcRules.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcSplice.hs-boot
compiler/typecheck/TcType.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/utils/MonadUtils.hs
testsuite/tests/ado/ado004.stderr
testsuite/tests/annotations/should_fail/annfail10.stderr
testsuite/tests/deSugar/should_run/dsrun017.hs
testsuite/tests/determinism/typecheck/A.hs
testsuite/tests/gadt/gadt-escape1.stderr
testsuite/tests/gadt/gadt13.stderr
testsuite/tests/gadt/gadt7.stderr
testsuite/tests/ghc-api/annotations-literals/parsed.stdout
testsuite/tests/ghci.debugger/scripts/break003.stderr
testsuite/tests/ghci.debugger/scripts/break003.stdout
testsuite/tests/ghci.debugger/scripts/break005.stdout
testsuite/tests/ghci.debugger/scripts/break006.stderr
testsuite/tests/ghci.debugger/scripts/break006.stdout
testsuite/tests/ghci.debugger/scripts/break012.stdout
testsuite/tests/ghci.debugger/scripts/hist001.stdout
testsuite/tests/ghci.debugger/scripts/print022.stdout
testsuite/tests/ghci/scripts/T2182ghci.stderr
testsuite/tests/ghci/scripts/T8959.script
testsuite/tests/ghci/scripts/T8959.stderr
testsuite/tests/ghci/scripts/T8959.stdout
testsuite/tests/indexed-types/should_compile/T3484.hs
testsuite/tests/indexed-types/should_compile/T4120.hs
testsuite/tests/indexed-types/should_compile/T4494.hs
testsuite/tests/indexed-types/should_compile/T9090.hs
testsuite/tests/indexed-types/should_compile/T9316.hs
testsuite/tests/indexed-types/should_fail/T3330a.hs
testsuite/tests/indexed-types/should_fail/T5934.stderr
testsuite/tests/indexed-types/should_fail/T7788.stderr
testsuite/tests/indexed-types/should_fail/T8518.stderr
testsuite/tests/module/mod71.stderr
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.hs
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail03.stderr
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.hs
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail05.stderr
testsuite/tests/parser/should_compile/read014.stderr
testsuite/tests/parser/should_fail/T7848.stderr
testsuite/tests/partial-sigs/should_compile/T10438.stderr
testsuite/tests/partial-sigs/should_compile/T11192.stderr
testsuite/tests/perf/compiler/all.T
testsuite/tests/polykinds/T7438.stderr
testsuite/tests/rebindable/rebindable6.hs
testsuite/tests/rebindable/rebindable6.stderr
testsuite/tests/rename/should_compile/T3103/GHC/Num.hs [new file with mode: 0644]
testsuite/tests/rename/should_compile/T3103/GHC/Word.hs
testsuite/tests/th/T11452.hs [new file with mode: 0644]
testsuite/tests/th/T11452.stderr [new file with mode: 0644]
testsuite/tests/th/T2222.stderr
testsuite/tests/th/all.T
testsuite/tests/typecheck/should_compile/RebindHR.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/RebindNegate.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T11397.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T11458.hs [new file with mode: 0644]
testsuite/tests/typecheck/should_compile/T2683.hs
testsuite/tests/typecheck/should_compile/T7888.hs
testsuite/tests/typecheck/should_compile/all.T
testsuite/tests/typecheck/should_compile/tc141.stderr
testsuite/tests/typecheck/should_compile/tc158.hs
testsuite/tests/typecheck/should_compile/twins.hs
testsuite/tests/typecheck/should_fail/FDsFromGivens2.hs
testsuite/tests/typecheck/should_fail/FDsFromGivens2.stderr
testsuite/tests/typecheck/should_fail/T10619.stderr
testsuite/tests/typecheck/should_fail/T3613.stderr
testsuite/tests/typecheck/should_fail/T5570.stderr
testsuite/tests/typecheck/should_fail/T7453.stderr
testsuite/tests/typecheck/should_fail/T7734.stderr
testsuite/tests/typecheck/should_fail/T8603.stderr
testsuite/tests/typecheck/should_fail/T9109.stderr
testsuite/tests/typecheck/should_fail/VtaFail.stderr
testsuite/tests/typecheck/should_fail/tcfail014.stderr
testsuite/tests/typecheck/should_fail/tcfail016.stderr
testsuite/tests/typecheck/should_fail/tcfail032.stderr
testsuite/tests/typecheck/should_fail/tcfail099.stderr
testsuite/tests/typecheck/should_fail/tcfail104.stderr
testsuite/tests/typecheck/should_fail/tcfail140.stderr
testsuite/tests/typecheck/should_fail/tcfail159.stderr
testsuite/tests/typecheck/should_fail/tcfail181.stderr
utils/ghctags/Main.hs

index 38626a4..73f0177 100644 (file)
@@ -31,6 +31,7 @@ import Id
 import ConLike
 import DataCon
 import Name
+import FamInstEnv
 import TysWiredIn
 import TyCon
 import SrcLoc
@@ -148,7 +149,8 @@ type PmResult = ( [[LPat Id]]
 checkSingle :: Id -> Pat Id -> DsM PmResult
 checkSingle var p = do
   let lp = [noLoc p]
-  vec <- liftUs (translatePat p)
+  fam_insts <- dsGetFamInstEnvs
+  vec <- liftUs (translatePat fam_insts p)
   vsa <- initial_uncovered [var]
   (c,d,us') <- patVectProc False (vec,[]) vsa -- no guards
   us <- pruneVSA us'
@@ -171,7 +173,8 @@ checkMatches oversimplify vars matches
       return ([], [], missing')
 
     go (m:ms) missing = do
-      clause        <- liftUs (translateMatch m)
+      fam_insts     <- dsGetFamInstEnvs
+      clause        <- liftUs (translateMatch fam_insts m)
       (c,  d,  us ) <- patVectProc oversimplify clause missing
       (rs, is, us') <- go ms us
       return $ case (c,d) of
@@ -209,7 +212,8 @@ noFailingGuards clauses = sum [ countPatVecs gvs | (_, gvs) <- clauses ]
 
 computeNoGuards :: [LMatch Id (LHsExpr Id)] -> PmM Int
 computeNoGuards matches = do
-  matches' <- mapM (liftUs . translateMatch) matches
+  fam_insts <- dsGetFamInstEnvs
+  matches' <- mapM (liftUs . translateMatch fam_insts) matches
   return (noFailingGuards matches')
 
 maximum_failing_guards :: Int
@@ -264,46 +268,47 @@ mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }
 -- -----------------------------------------------------------------------
 -- * Transform (Pat Id) into of (PmPat Id)
 
-translatePat :: Pat Id -> UniqSM PatVec
-translatePat pat = case pat of
+translatePat :: FamInstEnvs -> Pat Id -> UniqSM PatVec
+translatePat fam_insts pat = case pat of
   WildPat ty  -> mkPmVarsSM [ty]
   VarPat  id  -> return [PmVar (unLoc id)]
-  ParPat p    -> translatePat (unLoc p)
+  ParPat p    -> translatePat fam_insts (unLoc p)
   LazyPat _   -> mkPmVarsSM [hsPatType pat] -- like a variable
 
   -- ignore strictness annotations for now
-  BangPat p   -> translatePat (unLoc p)
+  BangPat p   -> translatePat fam_insts (unLoc p)
 
   AsPat lid p -> do
      -- Note [Translating As Patterns]
-    ps <- translatePat (unLoc p)
+    ps <- translatePat fam_insts (unLoc p)
     let [e] = map valAbsToPmExpr (coercePatVec ps)
         g   = PmGrd [PmVar (unLoc lid)] e
     return (ps ++ [g])
 
-  SigPatOut p _ty -> translatePat (unLoc p)
+  SigPatOut p _ty -> translatePat fam_insts (unLoc p)
 
   -- See Note [Translate CoPats]
   CoPat wrapper p ty
-    | isIdHsWrapper wrapper                   -> translatePat p
-    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat p
+    | isIdHsWrapper wrapper                   -> translatePat fam_insts p
+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p
     | otherwise -> do
-        ps      <- translatePat p
+        ps      <- translatePat fam_insts p
         (xp,xe) <- mkPmId2FormsSM ty
         let g = mkGuard ps (HsWrap wrapper (unLoc xe))
         return [xp,g]
 
   -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)
-  NPlusKPat (L _ n) k ge minus -> do
-    (xp, xe) <- mkPmId2FormsSM (idType n)
-    let ke = L (getLoc k) (HsOverLit (unLoc k))
-        g1 = mkGuard [truePattern] (OpApp xe (noLoc ge)    no_fixity ke)
-        g2 = mkGuard [PmVar n]     (OpApp xe (noLoc minus) no_fixity ke)
+  NPlusKPat (L _ n) k1 k2 ge minus ty -> do
+    (xp, xe) <- mkPmId2FormsSM ty
+    let ke1 = L (getLoc k1) (HsOverLit (unLoc k1))
+        ke2 = L (getLoc k1) (HsOverLit k2)
+        g1 = mkGuard [truePattern] (unLoc $ nlHsSyntaxApps ge    [xe, ke1])
+        g2 = mkGuard [PmVar n]     (unLoc $ nlHsSyntaxApps minus [xe, ke2])
     return [xp, g1, g2]
 
   -- (fun -> pat)   ===>   x (pat <- fun x)
   ViewPat lexpr lpat arg_ty -> do
-    ps <- translatePat (unLoc lpat)
+    ps <- translatePat fam_insts (unLoc lpat)
     -- See Note [Guards and Approximation]
     case all cantFailPattern ps of
       True  -> do
@@ -316,15 +321,18 @@ translatePat pat = case pat of
 
   -- list
   ListPat ps ty Nothing -> do
-    foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec (map unLoc ps)
+    foldr (mkListPatVec ty) [nilPattern ty] <$> translatePatVec fam_insts (map unLoc ps)
 
   -- overloaded list
   ListPat lpats elem_ty (Just (pat_ty, _to_list))
-    | Just e_ty <- splitListTyConApp_maybe pat_ty, elem_ty `eqType` e_ty ->
+    | Just e_ty <- splitListTyConApp_maybe pat_ty
+    , (_, norm_elem_ty) <- normaliseType fam_insts Nominal elem_ty
+         -- elem_ty is frequently something like `Item [Int]`, but we prefer `Int`
+    , norm_elem_ty `eqType` e_ty ->
         -- We have to ensure that the element types are exactly the same.
         -- Otherwise, one may give an instance IsList [Int] (more specific than
         -- the default IsList [a]) with a different implementation for `toList'
-        translatePat (ListPat lpats e_ty Nothing)
+        translatePat fam_insts (ListPat lpats e_ty Nothing)
     | otherwise -> do
         -- See Note [Guards and Approximation]
         var <- mkPmVarSM pat_ty
@@ -345,29 +353,29 @@ translatePat pat = case pat of
             , pat_tvs     = ex_tvs
             , pat_dicts   = dicts
             , pat_args    = ps } -> do
-    args <- translateConPatVec arg_tys ex_tvs con ps
+    args <- translateConPatVec fam_insts arg_tys ex_tvs con ps
     return [PmCon { pm_con_con     = con
                   , pm_con_arg_tys = arg_tys
                   , pm_con_tvs     = ex_tvs
                   , pm_con_dicts   = dicts
                   , pm_con_args    = args }]
 
-  NPat (L _ ol) mb_neg _eq -> translateNPat ol mb_neg
+  NPat (L _ ol) mb_neg _eq ty -> translateNPat fam_insts ol mb_neg ty
 
   LitPat lit
       -- If it is a string then convert it to a list of characters
     | HsString src s <- lit ->
         foldr (mkListPatVec charTy) [nilPattern charTy] <$>
-          translatePatVec (map (LitPat . HsChar src) (unpackFS s))
+          translatePatVec fam_insts (map (LitPat . HsChar src) (unpackFS s))
     | otherwise -> return [mkLitPattern lit]
 
   PArrPat ps ty -> do
-    tidy_ps <- translatePatVec (map unLoc ps)
+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)
     let fake_con = parrFakeCon (length ps)
     return [vanillaConPattern fake_con [ty] (concat tidy_ps)]
 
   TuplePat ps boxity tys -> do
-    tidy_ps <- translatePatVec (map unLoc ps)
+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)
     let tuple_con = tupleDataCon boxity (length ps)
     return [vanillaConPattern tuple_con tys (concat tidy_ps)]
 
@@ -378,33 +386,35 @@ translatePat pat = case pat of
   SigPatIn  {} -> panic "Check.translatePat: SigPatIn"
 
 -- | Translate an overloaded literal (see `tidyNPat' in deSugar/MatchLit.hs)
-translateNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> UniqSM PatVec
-translateNPat (OverLit val False _ ty) mb_neg
-  | isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
-  = translatePat (LitPat (HsString src s))
-  | isIntTy    ty, HsIntegral src i <- val
-  = translatePat (mk_num_lit HsInt src i)
-  | isWordTy   ty, HsIntegral src i <- val
-  = translatePat (mk_num_lit HsWordPrim src i)
+translateNPat :: FamInstEnvs
+              -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> Type -> UniqSM PatVec
+translateNPat fam_insts (OverLit val False _ ty) mb_neg outer_ty
+  | not type_change, isStringTy ty, HsIsString src s <- val, Nothing <- mb_neg
+  = translatePat fam_insts (LitPat (HsString src s))
+  | not type_change, isIntTy    ty, HsIntegral src i <- val
+  = translatePat fam_insts (mk_num_lit HsInt src i)
+  | not type_change, isWordTy   ty, HsIntegral src i <- val
+  = translatePat fam_insts (mk_num_lit HsWordPrim src i)
   where
+    type_change = not (outer_ty `eqType` ty)
     mk_num_lit c src i = LitPat $ case mb_neg of
       Nothing -> c src i
       Just _  -> c src (-i)
-translateNPat ol mb_neg
+translateNPat _ ol mb_neg _
   = return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) ol }]
 
 -- | Translate a list of patterns (Note: each pattern is translated
 -- to a pattern vector but we do not concatenate the results).
-translatePatVec :: [Pat Id] -> UniqSM [PatVec]
-translatePatVec pats = mapM translatePat pats
+translatePatVec :: FamInstEnvs -> [Pat Id] -> UniqSM [PatVec]
+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats
 
-translateConPatVec :: [Type] -> [TyVar]
+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]
                    -> DataCon -> HsConPatDetails Id -> UniqSM PatVec
-translateConPatVec _univ_tys _ex_tvs _ (PrefixCon ps)
-  = concat <$> translatePatVec (map unLoc ps)
-translateConPatVec _univ_tys _ex_tvs _ (InfixCon p1 p2)
-  = concat <$> translatePatVec (map unLoc [p1,p2])
-translateConPatVec  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)
+  = concat <$> translatePatVec fam_insts (map unLoc ps)
+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)
+  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])
+translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
     -- Nothing matched. Make up some fresh term variables
   | null fs        = mkPmVarsSM arg_tys
     -- The data constructor was not defined using record syntax. For the
@@ -417,7 +427,7 @@ translateConPatVec  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
   | matched_lbls `subsetOf` orig_lbls
   = ASSERT(length orig_lbls == length arg_tys)
       let translateOne (lbl, ty) = case lookup lbl matched_pats of
-            Just p  -> translatePat p
+            Just p  -> translatePat fam_insts p
             Nothing -> mkPmVarsSM [ty]
       in  concatMapM translateOne (zip orig_lbls arg_tys)
     -- The fields that appear are not in the correct order. Make up fresh
@@ -426,7 +436,7 @@ translateConPatVec  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
   | otherwise = do
       arg_var_pats    <- mkPmVarsSM arg_tys
       translated_pats <- forM matched_pats $ \(x,pat) -> do
-        pvec <- translatePat pat
+        pvec <- translatePat fam_insts pat
         return (x, pvec)
 
       let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]
@@ -453,10 +463,10 @@ translateConPatVec  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
       | x == y    = subsetOf    xs  ys
       | otherwise = subsetOf (x:xs) ys
 
-translateMatch :: LMatch Id (LHsExpr Id) -> UniqSM (PatVec,[PatVec])
-translateMatch (L _ (Match _ lpats _ grhss)) = do
-  pats'   <- concat <$> translatePatVec pats
-  guards' <- mapM translateGuards guards
+translateMatch :: FamInstEnvs -> LMatch Id (LHsExpr Id) -> UniqSM (PatVec,[PatVec])
+translateMatch fam_insts (L _ (Match _ lpats _ grhss)) = do
+  pats'   <- concat <$> translatePatVec fam_insts pats
+  guards' <- mapM (translateGuards fam_insts) guards
   return (pats', guards')
   where
     extractGuards :: LGRHS Id (LHsExpr Id) -> [GuardStmt Id]
@@ -469,9 +479,9 @@ translateMatch (L _ (Match _ lpats _ grhss)) = do
 -- * Transform source guards (GuardStmt Id) to PmPats (Pattern)
 
 -- | Translate a list of guard statements to a pattern vector
-translateGuards :: [GuardStmt Id] -> UniqSM PatVec
-translateGuards guards = do
-  all_guards <- concat <$> mapM translateGuard guards
+translateGuards :: FamInstEnvs -> [GuardStmt Id] -> UniqSM PatVec
+translateGuards fam_insts guards = do
+  all_guards <- concat <$> mapM (translateGuard fam_insts) guards
   return (replace_unhandled all_guards)
   -- It should have been (return $ all_guards) but it is too expressive.
   -- Since the term oracle does not handle all constraints we generate,
@@ -509,24 +519,24 @@ cantFailPattern (PmGrd pv _e)
 cantFailPattern _ = False
 
 -- | Translate a guard statement to Pattern
-translateGuard :: GuardStmt Id -> UniqSM PatVec
-translateGuard (BodyStmt   e _ _ _) = translateBoolGuard e
-translateGuard (LetStmt      binds) = translateLet (unLoc binds)
-translateGuard (BindStmt   p e _ _) = translateBind p e
-translateGuard (LastStmt        {}) = panic "translateGuard LastStmt"
-translateGuard (ParStmt         {}) = panic "translateGuard ParStmt"
-translateGuard (TransStmt       {}) = panic "translateGuard TransStmt"
-translateGuard (RecStmt         {}) = panic "translateGuard RecStmt"
-translateGuard (ApplicativeStmt {}) = panic "translateGuard ApplicativeLastStmt"
+translateGuard :: FamInstEnvs -> GuardStmt Id -> UniqSM PatVec
+translateGuard _         (BodyStmt   e _ _ _) = translateBoolGuard e
+translateGuard _         (LetStmt      binds) = translateLet (unLoc binds)
+translateGuard fam_insts (BindStmt p e _ _ _) = translateBind fam_insts p e
+translateGuard _         (LastStmt        {}) = panic "translateGuard LastStmt"
+translateGuard _         (ParStmt         {}) = panic "translateGuard ParStmt"
+translateGuard _         (TransStmt       {}) = panic "translateGuard TransStmt"
+translateGuard _         (RecStmt         {}) = panic "translateGuard RecStmt"
+translateGuard _         (ApplicativeStmt {}) = panic "translateGuard ApplicativeLastStmt"
 
 -- | Translate let-bindings
 translateLet :: HsLocalBinds Id -> UniqSM PatVec
 translateLet _binds = return []
 
 -- | Translate a pattern guard
-translateBind :: LPat Id -> LHsExpr Id -> UniqSM PatVec
-translateBind (L _ p) e = do
-  ps <- translatePat p
+translateBind :: FamInstEnvs -> LPat Id -> LHsExpr Id -> UniqSM PatVec
+translateBind fam_insts (L _ p) e = do
+  ps <- translatePat fam_insts p
   return [mkGuard ps (unLoc e)]
 
 -- | Translate a boolean guard
@@ -600,7 +610,8 @@ below is the *right thing to do*:
 The case with literals is a bit different. a literal @l@ should be translated
 to @x (True <- x == from l)@. Since we want to have better warnings for
 overloaded literals as it is a very common feature, we treat them differently.
-They are mainly covered in Note [Undecidable Equality on Overloaded Literals].
+They are mainly covered in Note [Undecidable Equality on Overloaded Literals]
+in PmExpr.
 
 4. N+K Patterns & Pattern Synonyms
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -845,9 +856,6 @@ coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys
            , pm_con_args = coercePatVec args }]
 coercePmPat (PmGrd {}) = [] -- drop the guards
 
-no_fixity :: a -- TODO: Can we retrieve the fixity from the operator name?
-no_fixity = panic "Check: no fixity"
-
 -- Get all constructors in the family (including given)
 allConstructors :: DataCon -> [DataCon]
 allConstructors = tyConDataCons . dataConTyCon
@@ -1101,7 +1109,7 @@ cMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
 
 -- CLitLit
 cMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of
-  -- See Note [Undecidable Equality for Overloaded Literals]
+  -- See Note [Undecidable Equality for Overloaded Literals] in PmExpr
   True  -> va `mkCons` covered us gvsa ps vsa -- match
   False -> Empty                              -- mismatch
 
@@ -1172,7 +1180,7 @@ uMatcher us gvsa ( p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
 
 -- ULitLit
 uMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of
-  -- See Note [Undecidable Equality for Overloaded Literals]
+  -- See Note [Undecidable Equality for Overloaded Literals] in PmExpr
   True  -> va `mkCons` uncovered us gvsa ps vsa -- match
   False -> va `mkCons` vsa                      -- mismatch
 
@@ -1256,7 +1264,7 @@ dMatcher us gvsa (p@(PmCon { pm_con_con = c1, pm_con_args = args1 })) ps
 
 -- DLitLit
 dMatcher us gvsa (PmLit l1) ps (va@(PmLit l2)) vsa = case eqPmLit l1 l2 of
-  -- See Note [Undecidable Equality for Overloaded Literals]
+  -- See Note [Undecidable Equality for Overloaded Literals] in PmExpr
   True  -> va `mkCons` divergent us gvsa ps vsa -- match
   False -> Empty                                -- mismatch
 
@@ -1331,10 +1339,12 @@ genCaseTmCs2 :: Maybe (LHsExpr Id) -- Scrutinee
              -> [Id]               -- MatchVars (should have length 1)
              -> DsM (Bag SimpleEq)
 genCaseTmCs2 Nothing _ _ = return emptyBag
-genCaseTmCs2 (Just scr) [p] [var] = liftUs $ do
-  [e] <- map valAbsToPmExpr . coercePatVec <$> translatePat p
-  let scr_e = lhsExprToPmExpr scr
-  return $ listToBag [(var, e), (var, scr_e)]
+genCaseTmCs2 (Just scr) [p] [var] = do
+  fam_insts <- dsGetFamInstEnvs
+  liftUs $ do
+    [e] <- map valAbsToPmExpr . coercePatVec <$> translatePat fam_insts p
+    let scr_e = lhsExprToPmExpr scr
+    return $ listToBag [(var, e), (var, scr_e)]
 genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"
 
 -- | Generate a simple equality when checking a case expression:
index a5faef0..9b7c873 100644 (file)
@@ -592,8 +592,9 @@ addTickHsExpr (ExplicitList ty wit es) =
                 (addTickWit wit)
                 (mapM (addTickLHsExpr) es)
              where addTickWit Nothing = return Nothing
-                   addTickWit (Just fln) = do fln' <- addTickHsExpr fln
-                                              return (Just fln')
+                   addTickWit (Just fln)
+                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln
+                          return (Just fln')
 addTickHsExpr (ExplicitPArr ty es) =
         liftM2 ExplicitPArr
                 (return ty)
@@ -621,7 +622,7 @@ addTickHsExpr (ArithSeq  ty wit arith_seq) =
                 (addTickWit wit)
                 (addTickArithSeqInfo arith_seq)
              where addTickWit Nothing = return Nothing
-                   addTickWit (Just fl) = do fl' <- addTickHsExpr fl
+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl
                                              return (Just fl')
 
 -- We might encounter existing ticks (multiple Coverage passes)
@@ -732,12 +733,13 @@ addTickStmt _isGuard (LastStmt e noret ret) = do
                 (addTickLHsExpr e)
                 (pure noret)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt pat e bind fail) = do
-        liftM4 BindStmt
+addTickStmt _isGuard (BindStmt pat e bind fail ty) = do
+        liftM5 BindStmt
                 (addTickLPat pat)
                 (addTickLHsExprRHS e)
                 (addTickSyntaxExpr hpcSrcSpan bind)
                 (addTickSyntaxExpr hpcSrcSpan fail)
+                (return ty)
 addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
         liftM4 BodyStmt
                 (addTick isGuard e)
@@ -747,11 +749,12 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
 addTickStmt _isGuard (LetStmt (L l binds)) = do
         liftM (LetStmt . L l)
                 (addTickHsLocalBinds binds)
-addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
-    liftM3 ParStmt
+addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr ty) = do
+    liftM4 ParStmt
         (mapM (addTickStmtAndBinders isGuard) pairs)
-        (addTickSyntaxExpr hpcSrcSpan mzipExpr)
+        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))
         (addTickSyntaxExpr hpcSrcSpan bindExpr)
+        (return ty)
 addTickStmt isGuard (ApplicativeStmt args mb_join body_ty) = do
     args' <- mapM (addTickApplicativeArg isGuard) args
     return (ApplicativeStmt args' mb_join body_ty)
@@ -765,7 +768,7 @@ addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts
     t_u <- addTickLHsExprRHS using
     t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr
     t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr
-    t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr
+    L _ t_m <- addTickLHsExpr (L hpcSrcSpan liftMExpr)
     return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u
                   , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }
 
@@ -792,7 +795,7 @@ addTickApplicativeArg isGuard (op, arg) =
   addTickArg (ApplicativeArgMany stmts ret pat) =
     ApplicativeArgMany
       <$> addTickLStmts isGuard stmts
-      <*> addTickSyntaxExpr hpcSrcSpan ret
+      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))
       <*> addTickLPat pat
 
 addTickStmtAndBinders :: Maybe (Bool -> BoxLabel) -> ParStmtBlock Id Id
@@ -837,9 +840,9 @@ addTickIPBind (IPBind nm e) =
 
 -- There is no location here, so we might need to use a context location??
 addTickSyntaxExpr :: SrcSpan -> SyntaxExpr Id -> TM (SyntaxExpr Id)
-addTickSyntaxExpr pos x = do
+addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do
         L _ x' <- addTickLHsExpr (L pos x)
-        return $ x'
+        return $ syn { syn_expr = x' }
 -- we do not walk into patterns.
 addTickLPat :: LPat Id -> TM (LPat Id)
 addTickLPat pat = return pat
@@ -951,12 +954,13 @@ addTickLCmdStmts' lstmts res
         binders = collectLStmtsBinders lstmts
 
 addTickCmdStmt :: Stmt Id (LHsCmd Id) -> TM (Stmt Id (LHsCmd Id))
-addTickCmdStmt (BindStmt pat c bind fail) = do
-        liftM4 BindStmt
+addTickCmdStmt (BindStmt pat c bind fail ty) = do
+        liftM5 BindStmt
                 (addTickLPat pat)
                 (addTickLHsCmd c)
                 (return bind)
                 (return fail)
+                (return ty)
 addTickCmdStmt (LastStmt c noret ret) = do
         liftM3 LastStmt
                 (addTickLHsCmd c)
index 3691afb..1738a5d 100644 (file)
@@ -25,7 +25,7 @@ import qualified HsUtils
 --     So WATCH OUT; check each use of split*Ty functions.
 -- Sigh.  This is a pain.
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )
 
 import TcType
 import TcEvidence
@@ -465,9 +465,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdIf mb_fun cond then_cmd else_cmd)
         core_right = mk_right_expr then_ty else_ty (buildEnvStack else_ids stack_id)
 
     core_if <- case mb_fun of
-       Just fun -> do { core_fun <- dsExpr fun
-                      ; matchEnvStack env_ids stack_id $
-                        mkCoreApps core_fun [core_cond, core_left, core_right] }
+       Just fun -> do { fun_apps <- dsSyntaxExpr fun [core_cond, core_left, core_right]
+                      ; matchEnvStack env_ids stack_id fun_apps }
        Nothing  -> matchEnvStack env_ids stack_id $
                    mkIfThenElse core_cond core_left core_right
 
@@ -782,7 +781,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt cmd _ _ c_ty) env_ids = do
 -- It would be simpler and more consistent to do this using second,
 -- but that's likely to be defined in terms of first.
 
-dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
+dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _ _) env_ids = do
     let pat_ty = hsLPatType pat
     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
     let pat_vars = mkVarSet (collectPatBinders pat)
@@ -1142,8 +1141,8 @@ collectl (L _ pat) bndrs
                                     collectEvBinders ds
                                     ++ foldr collectl bndrs (hsConPatArgs ps)
     go (LitPat _)                 = bndrs
-    go (NPat _ _ _)               = bndrs
-    go (NPlusKPat (L _ n) _ _ _ = n : bndrs
+    go (NPat {})                  = bndrs
+    go (NPlusKPat (L _ n) _ _ _ _ _) = n : bndrs
 
     go (SigPatIn pat _)           = collectl pat bndrs
     go (SigPatOut pat _)          = collectl pat bndrs
index a3b8f1a..dce8f2f 100644 (file)
@@ -8,7 +8,8 @@ Desugaring exporessions.
 
 {-# LANGUAGE CPP #-}
 
-module DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsValBinds, dsLit ) where
+module DsExpr ( dsExpr, dsLExpr, dsLocalBinds
+              , dsValBinds, dsLit, dsSyntaxExpr ) where
 
 #include "HsVersions.h"
 
@@ -221,7 +222,8 @@ dsExpr (HsWrap co_fn e)
        ; return wrapped_e }
 
 dsExpr (NegApp expr neg_expr)
-  = App <$> dsExpr neg_expr <*> dsLExpr expr
+  = do { expr' <- dsLExpr expr
+       ; dsSyntaxExpr neg_expr [expr'] }
 
 dsExpr (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
@@ -354,8 +356,7 @@ dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
        ; b1 <- dsLExpr then_expr
        ; b2 <- dsLExpr else_expr
        ; case mb_fun of
-           Just fun -> do { core_fun <- dsExpr fun
-                          ; return (mkCoreApps core_fun [pred,b1,b2]) }
+           Just fun -> dsSyntaxExpr fun [pred, b1, b2]
            Nothing  -> return $ mkIfThenElse pred b1 b2 }
 
 dsExpr (HsMultiIf res_ty alts)
@@ -398,10 +399,8 @@ dsExpr (ExplicitPArr ty xs) = do
 dsExpr (ArithSeq expr witness seq)
   = case witness of
      Nothing -> dsArithSeq expr seq
-     Just fl -> do {
-       ; fl' <- dsExpr fl
-       ; newArithSeq <- dsArithSeq expr seq
-       ; return (App fl' newArithSeq)}
+     Just fl -> do { newArithSeq <- dsArithSeq expr seq
+                   ; dsSyntaxExpr fl [newArithSeq] }
 
 dsExpr (PArrSeq expr (FromTo from to))
   = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, to]
@@ -741,6 +740,16 @@ dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
 dsExpr (HsTypeOut {})
   = panic "dsExpr: tried to desugar a naked type application argument (HsTypeOut)"
 
+------------------------------
+dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
+dsSyntaxExpr (SyntaxExpr { syn_expr      = expr
+                         , syn_arg_wraps = arg_wraps
+                         , syn_res_wrap  = res_wrap })
+             arg_exprs
+  = do { args <- zipWithM dsHsWrapper arg_wraps arg_exprs
+       ; fun  <- dsExpr expr
+       ; dsHsWrapper res_wrap $ mkApps fun args }
+
 findField :: [LHsRecField Id arg] -> Name -> [arg]
 findField rbinds sel
   = [hsRecFieldArg fld | L _ fld <- rbinds
@@ -832,10 +841,9 @@ dsExplicitList elt_ty Nothing xs
            ; return (foldr (App . App (Var c)) folded_suffix prefix) }
 
 dsExplicitList elt_ty (Just fln) xs
-  = do { fln' <- dsExpr fln
-       ; list <- dsExplicitList elt_ty Nothing xs
+  = do { list <- dsExplicitList elt_ty Nothing xs
        ; dflags <- getDynFlags
-       ; return (App (App fln' (mkIntExprInt dflags (length xs))) list) }
+       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }
 
 spanTail :: (a -> Bool) -> [a] -> ([a], [a])
 spanTail f xs = (reverse rejected, reverse satisfying)
@@ -882,25 +890,21 @@ dsDo stmts
     go _ (BodyStmt rhs then_expr _ _) stmts
       = do { rhs2 <- dsLExpr rhs
            ; warnDiscardedDoBindings rhs (exprType rhs2)
-           ; then_expr2 <- dsExpr then_expr
            ; rest <- goL stmts
-           ; return (mkApps then_expr2 [rhs2, rest]) }
+           ; dsSyntaxExpr then_expr [rhs2, rest] }
 
     go _ (LetStmt (L _ binds)) stmts
       = do { rest <- goL stmts
            ; dsLocalBinds binds rest }
 
-    go _ (BindStmt pat rhs bind_op fail_op) stmts
+    go _ (BindStmt pat rhs bind_op fail_op res1_ty) stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
-            ; bind_op' <- dsExpr bind_op
             ; var   <- selectSimpleMatchVarL pat
-            ; let bind_ty = exprType bind_op'   -- rhs -> (pat -> res1) -> res2
-                  res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
             ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
                                       res1_ty (cantFailMatchResult body)
             ; match_code <- handle_failure pat match fail_op
-            ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
     go _ (ApplicativeStmt args mb_join body_ty) stmts
       = do {
@@ -915,7 +919,6 @@ dsDo stmts
                arg_tys = map hsLPatType pats
 
            ; rhss' <- sequence rhss
-           ; ops' <- mapM dsExpr (map fst args)
 
            ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
 
@@ -926,30 +929,30 @@ dsDo stmts
                       , mg_origin = Generated }
 
            ; fun' <- dsLExpr fun
-           ; let mk_ap_call l (op,r) = mkApps op [l,r]
-                 expr = foldl mk_ap_call fun' (zip ops' rhss')
+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
            ; case mb_join of
                Nothing -> return expr
-               Just join_op ->
-                 do { join_op' <- dsExpr join_op
-                    ; return (App join_op' expr) } }
+               Just join_op -> dsSyntaxExpr join_op [expr] }
 
     go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids
                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op
                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
+                    , recS_bind_ty = bind_ty
                     , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts
       = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }
       where
         new_bind_stmt = L loc $ BindStmt (mkBigLHsPatTupId later_pats)
                                          mfix_app bind_op
                                          noSyntaxExpr  -- Tuple cannot fail
+                                         bind_ty
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
         rec_tup_pats = map nlVarPat tup_ids
         later_pats   = rec_tup_pats
         rets         = map noLoc rec_rets
-        mfix_app     = nlHsApp (noLoc mfix_op) mfix_arg
+        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]
         mfix_arg     = noLoc $ HsLam
                            (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body]
                                , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
@@ -957,7 +960,7 @@ dsDo stmts
         mfix_pat     = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
         body         = noLoc $ HsDo
                                 DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
-        ret_app      = nlHsApp (noLoc return_op) (mkBigLHsTupId rets)
+        ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
         ret_stmt     = noLoc $ mkLastStmt ret_app
                      -- This LastStmt will be desugared with dsDo,
                      -- which ignores the return_op in the LastStmt,
@@ -971,10 +974,10 @@ handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr
     -- the monadic 'fail' rather than throwing an exception
 handle_failure pat match fail_op
   | matchCanFail match
-  = do { fail_op' <- dsExpr fail_op
-       ; dflags <- getDynFlags
+  = do { dflags <- getDynFlags
        ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-       ; extractMatchResult match (App fail_op' fail_msg) }
+       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+       ; extractMatchResult match fail_expr }
   | otherwise
   = extractMatchResult match (error "It can't fail")
 
index 129185d..cc8b7ea 100644 (file)
@@ -1,9 +1,10 @@
 module DsExpr where
-import HsSyn    ( HsExpr, LHsExpr, HsLocalBinds )
+import HsSyn    ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr )
 import Var      ( Id )
 import DsMonad  ( DsM )
 import CoreSyn  ( CoreExpr )
 
 dsExpr  :: HsExpr  Id -> DsM CoreExpr
 dsLExpr :: LHsExpr Id -> DsM CoreExpr
+dsSyntaxExpr :: SyntaxExpr Id -> [CoreExpr] -> DsM CoreExpr
 dsLocalBinds :: HsLocalBinds Id -> CoreExpr -> DsM CoreExpr
index 6b1b342..d08bd55 100644 (file)
@@ -114,7 +114,7 @@ matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do
         --         so we can't desugar the bindings without the
         --         body expression in hand
 
-matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
+matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do
     match_result <- matchGuards stmts ctx rhs rhs_ty
     core_rhs <- dsLExpr bind_rhs
     matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result
index f6c2b60..45320cc 100644 (file)
@@ -12,7 +12,7 @@ module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds, dsSyntaxExpr )
 
 import HsSyn
 import TcHsSyn
@@ -233,11 +233,11 @@ deListComp (stmt@(TransStmt {}) : quals) list = do
     (inner_list_expr, pat) <- dsTransStmt stmt
     deBindComp pat inner_list_expr quals list
 
-deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
+deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above
     core_list1 <- dsLExpr list1
     deBindComp pat core_list1 quals core_list2
 
-deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list
+deListComp (ParStmt stmtss_w_bndrs _ _ : quals) list
   = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs
        ; let (exps, qual_tys) = unzip exps_and_qual_tys
 
@@ -339,7 +339,7 @@ dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do
     -- Anyway, we bind the newly grouped list via the generic binding function
     dfBindComp c_id n_id (pat, inner_list_expr) quals
 
-dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
+dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do
     -- evaluate the two lists
     core_list1 <- dsLExpr list1
 
@@ -476,7 +476,7 @@ dsPArrComp :: [ExprStmt Id]
             -> DsM CoreExpr
 
 -- Special case for parallel comprehension
-dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals
+dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals
 
 -- Special case for simple generators:
 --
@@ -487,7 +487,7 @@ dsPArrComp (ParStmt qss _ _ : quals) = dePArrParComp qss quals
 --  <<[:e' | p <- e, qs:]>> =
 --    <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e)
 --
-dsPArrComp (BindStmt p e _ _ : qs) = do
+dsPArrComp (BindStmt p e _ _ : qs) = do
     filterP <- dsDPHBuiltin filterPVar
     ce <- dsLExpr e
     let ety'ce  = parrElemType ce
@@ -546,7 +546,7 @@ dePArrComp (BodyStmt b _ _ _ : qs) pa cea = do
 --    in
 --    <<[:e' | qs:]>> (pa, p) (crossMapP ea ef)
 --
-dePArrComp (BindStmt p e _ _ : qs) pa cea = do
+dePArrComp (BindStmt p e _ _ : qs) pa cea = do
     filterP <- dsDPHBuiltin filterPVar
     crossMapP <- dsDPHBuiltin crossMapPVar
     ce <- dsLExpr e
@@ -679,8 +679,7 @@ dsMcStmt :: ExprStmt Id -> [ExprLStmt Id] -> DsM CoreExpr
 dsMcStmt (LastStmt body _ ret_op) stmts
   = ASSERT( null stmts )
     do { body' <- dsLExpr body
-       ; ret_op' <- dsExpr ret_op
-       ; return (App ret_op' body') }
+       ; dsSyntaxExpr ret_op [body'] }
 
 --   [ .. | let binds, stmts ]
 dsMcStmt (LetStmt (L _ binds)) stmts
@@ -688,9 +687,9 @@ dsMcStmt (LetStmt (L _ binds)) stmts
        ; dsLocalBinds binds rest }
 
 --   [ .. | a <- m, stmts ]
-dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
+dsMcStmt (BindStmt pat rhs bind_op fail_op bind_ty) stmts
   = do { rhs' <- dsLExpr rhs
-       ; dsMcBindStmt pat rhs' bind_op fail_op stmts }
+       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }
 
 -- Apply `guard` to the `exp` expression
 --
@@ -698,11 +697,9 @@ dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts
 --
 dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
   = do { exp'       <- dsLExpr exp
-       ; guard_exp' <- dsExpr guard_exp
-       ; then_exp'  <- dsExpr then_exp
        ; rest       <- dsMcStmts stmts
-       ; return $ mkApps then_exp' [ mkApps guard_exp' [exp']
-                                   , rest ] }
+       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']
+       ; dsSyntaxExpr then_exp [guard_exp', rest] }
 
 -- Group statements desugar like this:
 --
@@ -721,6 +718,7 @@ dsMcStmt (BodyStmt exp then_exp guard_exp _) stmts
 dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
                     , trS_by = by, trS_using = using
                     , trS_ret = return_op, trS_bind = bind_op
+                    , trS_bind_arg_ty = n_tup_ty'  -- n (a,b,c)
                     , trS_fmap = fmap_op, trS_form = form }) stmts_rest
   = do { let (from_bndrs, to_bndrs) = unzip bndrs
 
@@ -742,10 +740,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
        -- Generate the expressions to build the grouped list
        -- Build a pattern that ensures the consumer binds into the NEW binders,
        -- which hold monads rather than single values
-       ; bind_op' <- dsExpr bind_op
-       ; let bind_ty'  = exprType bind_op'    -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2
-             n_tup_ty' = funArgTy $ funArgTy $ funResultTy bind_ty'   -- n (a,b,c)
-             tup_n_ty' = mkBigCoreVarTupTy to_bndrs
+       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs
 
        ; body        <- dsMcStmts stmts_rest
        ; n_tup_var'  <- newSysLocalDs n_tup_ty'
@@ -755,7 +750,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
        ; let rhs'  = mkApps usingExpr' usingArgs'
              body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'
 
-       ; return (mkApps bind_op' [rhs', Lam n_tup_var' body']) }
+       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }
 
 -- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel
 -- statements, for example:
@@ -768,7 +763,7 @@ dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs
 --   mzip :: forall a b. m a -> m b -> m (a,b)
 -- NB: we need a polymorphic mzip because we call it several times
 
-dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest
+dsMcStmt (ParStmt blocks mzip_op bind_op bind_ty) stmts_rest
  = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)
        ; mzip_op'    <- dsExpr mzip_op
 
@@ -782,7 +777,7 @@ dsMcStmt (ParStmt blocks mzip_op bind_op) stmts_rest
                                   mkBoxedTupleTy [t1,t2]))
                                exps_w_tys
 
-       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest }
+       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }
   where
     ds_inner (ParStmtBlock stmts bndrs return_op)
        = do { exp <- dsInnerMonadComp stmts bndrs return_op
@@ -806,28 +801,26 @@ dsMcBindStmt :: LPat Id
              -> CoreExpr        -- ^ the desugared rhs of the bind statement
              -> SyntaxExpr Id
              -> SyntaxExpr Id
+             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T
              -> [ExprLStmt Id]
              -> DsM CoreExpr
-dsMcBindStmt pat rhs' bind_op fail_op stmts
+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts
   = do  { body     <- dsMcStmts stmts
-        ; bind_op' <- dsExpr bind_op
         ; var      <- selectSimpleMatchVarL pat
-        ; let bind_ty = exprType bind_op'       -- rhs -> (pat -> res1) -> res2
-              res1_ty = funResultTy (funArgTy (funResultTy bind_ty))
         ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
                                   res1_ty (cantFailMatchResult body)
         ; match_code <- handle_failure pat match fail_op
-        ; return (mkApps bind_op' [rhs', Lam var match_code]) }
+        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
 
   where
     -- In a monad comprehension expression, pattern-match failure just calls
     -- the monadic `fail` rather than throwing an exception
     handle_failure pat match fail_op
       | matchCanFail match
-        = do { fail_op' <- dsExpr fail_op
-             ; dflags <- getDynFlags
+        = do { dflags <- getDynFlags
              ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-             ; extractMatchResult match (App fail_op' fail_msg) }
+             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+             ; extractMatchResult match fail_expr }
       | otherwise
         = extractMatchResult match (error "It can't fail")
 
@@ -842,8 +835,8 @@ dsMcBindStmt pat rhs' bind_op fail_op stmts
 --       [ (a,b,c) | quals ]
 
 dsInnerMonadComp :: [ExprLStmt Id]
-                 -> [Id]        -- Return a tuple of these variables
-                 -> HsExpr Id   -- The monomorphic "return" operator
+                 -> [Id]            -- Return a tuple of these variables
+                 -> SyntaxExpr Id   -- The monomorphic "return" operator
                  -> DsM CoreExpr
 dsInnerMonadComp stmts bndrs ret_op
   = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTupId bndrs) False ret_op)])
@@ -860,7 +853,7 @@ dsInnerMonadComp stmts bndrs ret_op
 --       , fmap (selN2 :: (t1, t2) -> t2) ys )
 
 mkMcUnzipM :: TransForm
-           -> SyntaxExpr TcId   -- fmap
+           -> HsExpr TcId       -- fmap
            -> Id                -- Of type n (a,b,c)
            -> [Type]            -- [a,b,c]
            -> DsM CoreExpr      -- Of type (n a, n b, n c)
index ca427a4..7a8de3c 100644 (file)
@@ -1279,7 +1279,7 @@ repLSts :: [LStmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
 repLSts stmts = repSts (map unLoc stmts)
 
 repSts :: [Stmt Name (LHsExpr Name)] -> DsM ([GenSymBind], [Core TH.StmtQ])
-repSts (BindStmt p e _ _ : ss) =
+repSts (BindStmt p e _ _ : ss) =
    do { e2 <- repLE e
       ; ss1 <- mkGenSyms (collectPatBinders p)
       ; addBinds ss1 $ do {
@@ -1297,7 +1297,7 @@ repSts (BodyStmt e _ _ _ : ss) =
       ; z <- repNoBindSt e2
       ; (ss2,zs) <- repSts ss
       ; return (ss2, z : zs) }
-repSts (ParStmt stmt_blocks _ _ : ss) =
+repSts (ParStmt stmt_blocks _ _ : ss) =
    do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks
       ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1
             ss1 = concat ss_s
@@ -1463,7 +1463,7 @@ repP (BangPat p)       = do { p1 <- repLP p; repPbang p1 }
 repP (AsPat x p)       = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 }
 repP (ParPat p)        = repLP p
 repP (ListPat ps _ Nothing)    = do { qs <- repLPs ps; repPlist qs }
-repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE e; repPview e' p}
+repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p}
 repP (TuplePat ps boxed _)
   | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }
   | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }
@@ -1483,9 +1483,9 @@ repP (ConPatIn dc details)
                           ; MkC p <- repLP (hsRecFieldArg fld)
                           ; rep2 fieldPatName [v,p] }
 
-repP (NPat (L _ l) Nothing _ = do { a <- repOverloadedLiteral l; repPlit a }
+repP (NPat (L _ l) Nothing _ _) = do { a <- repOverloadedLiteral l; repPlit a }
 repP (ViewPat e p _) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }
-repP p@(NPat _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)
+repP p@(NPat _ (Just _) _ _) = notHandled "Negative overloaded patterns" (ppr p)
 repP p@(SigPatIn {})  = notHandled "Type signatures in patterns" (ppr p)
         -- The problem is to do with scoped type variables.
         -- To implement them, we have to implement the scoping rules
index a90c8e6..b96b3eb 100644 (file)
@@ -239,11 +239,11 @@ seqVar var body = Case (Var var) var (exprType body)
 mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult
 mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)
 
--- (mkViewMatchResult var' viewExpr var mr) makes the expression
--- let var' = viewExpr var in mr
-mkViewMatchResult :: Id -> CoreExpr -> Id -> MatchResult -> MatchResult
-mkViewMatchResult var' viewExpr var =
-    adjustMatchResult (mkCoreLet (NonRec var' (mkCoreAppDs (text "mkView" <+> ppr var') viewExpr (Var var))))
+-- (mkViewMatchResult var' viewExpr mr) makes the expression
+-- let var' = viewExpr in mr
+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult
+mkViewMatchResult var' viewExpr =
+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))
 
 mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult
 mkEvalMatchResult var ty
index af07e5b..0128488 100644 (file)
@@ -12,7 +12,7 @@ module Match ( match, matchEquations, matchWrapper, matchSimply, matchSinglePat
 
 #include "HsVersions.h"
 
-import {-#SOURCE#-} DsExpr (dsLExpr, dsExpr)
+import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)
 
 import DynFlags
 import HsSyn
@@ -269,7 +269,9 @@ matchView (var:vars) ty (eqns@(eqn1:_))
                           map (decomposeFirstPat getViewPat) eqns
          -- compile the view expressions
         ; viewExpr' <- dsLExpr viewExpr
-        ; return (mkViewMatchResult var' viewExpr' var match_result) }
+        ; return (mkViewMatchResult var'
+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))
+                    match_result) }
 matchView _ _ _ = panic "matchView"
 
 matchOverloadedList :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
@@ -280,8 +282,8 @@ matchOverloadedList (var:vars) ty (eqns@(eqn1:_))
        ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand
        ; match_result <- match (var':vars) ty $
                             map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern
-       ; e' <- dsExpr e
-       ; return (mkViewMatchResult var' e' var match_result) }
+       ; e' <- dsSyntaxExpr e [Var var]
+       ; return (mkViewMatchResult var' e' match_result) }
 matchOverloadedList _ _ _ = panic "matchOverloadedList"
 
 -- decompose the first pattern and leave the rest alone
@@ -457,8 +459,8 @@ tidy1 _ (LitPat lit)
   = return (idDsWrapper, tidyLitPat lit)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
-tidy1 _ (NPat (L _ lit) mb_neg eq)
-  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq)
+tidy1 _ (NPat (L _ lit) mb_neg eq ty)
+  = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq ty)
 
 -- Everything else goes through unchanged...
 
@@ -939,7 +941,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     -- to ignore them?
     exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
         lexp l l' && lexp o o' && lexp ri ri'
-    exp (NegApp e n) (NegApp e' n') = lexp e e' && exp n n'
+    exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
     exp (SectionL e1 e2) (SectionL e1' e2') =
         lexp e1 e1' && lexp e2 e2'
     exp (SectionR e1 e2) (SectionR e1' e2') =
@@ -956,6 +958,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     exp _ _  = False
 
     ---------
+    syn_exp :: SyntaxExpr Id -> SyntaxExpr Id -> Bool
+    syn_exp (SyntaxExpr { syn_expr      = expr1
+                        , syn_arg_wraps = arg_wraps1
+                        , syn_res_wrap  = res_wrap1 })
+            (SyntaxExpr { syn_expr      = expr2
+                        , syn_arg_wraps = arg_wraps2
+                        , syn_res_wrap  = res_wrap2 })
+      = exp expr1 expr2 &&
+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&
+        wrap res_wrap1 res_wrap2
+
+    ---------
     tup_arg (L _ (Present e1)) (L _ (Present e2)) = lexp e1 e2
     tup_arg (L _ (Missing t1)) (L _ (Missing t2)) = eqType t1 t2
     tup_arg _ _ = False
@@ -998,8 +1012,8 @@ patGroup _ (ConPatOut { pat_con = L _ con
  | PatSynCon psyn <- con                = PgSyn psyn tys
 patGroup _ (WildPat {})                 = PgAny
 patGroup _ (BangPat {})                 = PgBang
-patGroup _ (NPat (L _ olit) mb_neg _)   = PgN   (hsOverLitKey olit (isJust mb_neg))
-patGroup _ (NPlusKPat _ (L _ olit) _ _= PgNpK (hsOverLitKey olit False)
+patGroup _ (NPat (L _ olit) mb_neg _ _) = PgN   (hsOverLitKey olit (isJust mb_neg))
+patGroup _ (NPlusKPat _ (L _ olit) _ _ _ _)= PgNpK (hsOverLitKey olit False)
 patGroup _ (CoPat _ p _)                = PgCo  (hsPatType p) -- Type of innelexp pattern
 patGroup _ (ViewPat expr p _)           = PgView expr (hsPatType (unLoc p))
 patGroup _ (ListPat _ _ (Just _))       = PgOverloadedList
index 2fab875..b1c82cc 100644 (file)
@@ -17,7 +17,7 @@ module MatchLit ( dsLit, dsOverLit, hsLitKey, hsOverLitKey
 #include "HsVersions.h"
 
 import {-# SOURCE #-} Match  ( match )
-import {-# SOURCE #-} DsExpr ( dsExpr )
+import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )
 
 import DsMonad
 import DsUtils
@@ -105,7 +105,7 @@ dsOverLit lit = do { dflags <- getDynFlags
                    ; dsOverLit' dflags lit }
 
 dsOverLit' :: DynFlags -> HsOverLit Id -> DsM CoreExpr
--- Post-typechecker, the SyntaxExpr field of an OverLit contains
+-- Post-typechecker, the HsExpr field of an OverLit contains
 -- (an expression for) the literal value itself
 dsOverLit' dflags (OverLit { ol_val = val, ol_rebindable = rebindable
                            , ol_witness = witness, ol_type = ty })
@@ -276,9 +276,9 @@ tidyNPat :: (HsLit -> Pat Id)   -- How to tidy a LitPat
                  -- both by Match and by Check, but they tidy LitPats
                  -- slightly differently; and we must desugar
                  -- literals consistently (see Trac #5117)
-         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id
+         -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Type
          -> Pat Id
-tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
+tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _eq outer_ty
         -- False: Take short cuts only if the literal is not using rebindable syntax
         --
         -- Once that is settled, look for cases where the type of the
@@ -287,20 +287,25 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
         -- NB: Watch out for weird cases like Trac #3382
         --        f :: Int -> Int
         --        f "blah" = 4
-        --     which might be ok if we hvae 'instance IsString Int'
+        --     which might be ok if we have 'instance IsString Int'
         --
-
-  | isIntTy ty,    Just int_lit <- mb_int_lit
+  | not type_change, isIntTy ty,    Just int_lit <- mb_int_lit
                             = mk_con_pat intDataCon    (HsIntPrim    "" int_lit)
-  | isWordTy ty,   Just int_lit <- mb_int_lit
+  | not type_change, isWordTy ty,   Just int_lit <- mb_int_lit
                             = mk_con_pat wordDataCon   (HsWordPrim   "" int_lit)
-  | isStringTy ty, Just str_lit <- mb_str_lit
+  | not type_change, isStringTy ty, Just str_lit <- mb_str_lit
                             = tidy_lit_pat (HsString "" str_lit)
      -- NB: do /not/ convert Float or Double literals to F# 3.8 or D# 5.3
      -- If we do convert to the constructor form, we'll generate a case
      -- expression on a Float# or Double# and that's not allowed in Core; see
      -- Trac #9238 and Note [Rules for floating-point comparisons] in PrelRules
   where
+    -- Sometimes (like in test case
+    -- overloadedlists/should_run/overloadedlistsrun04), the SyntaxExprs include
+    -- type-changing wrappers (for example, from Id Int to Int, for the identity
+    -- type family Id). In these cases, we can't do the short-cut.
+    type_change = not (outer_ty `eqType` ty)
+
     mk_con_pat :: DataCon -> HsLit -> Pat Id
     mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] [])
 
@@ -315,8 +320,8 @@ tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _
                    (Nothing, HsIsString _ s) -> Just s
                    _ -> Nothing
 
-tidyNPat _ over_lit mb_neg eq
-  = NPat (noLoc over_lit) mb_neg eq
+tidyNPat _ over_lit mb_neg eq outer_ty
+  = NPat (noLoc over_lit) mb_neg eq outer_ty
 
 {-
 ************************************************************************
@@ -409,14 +414,12 @@ litValKey (HsIsString _ s) neg   = ASSERT( not neg) MachStr
 
 matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal
-  = do  { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1
+  = do  { let NPat (L _ lit) mb_neg eq_chk = firstPat eqn1
         ; lit_expr <- dsOverLit lit
         ; neg_lit <- case mb_neg of
-                            Nothing -> return lit_expr
-                            Just neg -> do { neg_expr <- dsExpr neg
-                                           ; return (App neg_expr lit_expr) }
-        ; eq_expr <- dsExpr eq_chk
-        ; let pred_expr = mkApps eq_expr [Var var, neg_lit]
+                            Nothing  -> return lit_expr
+                            Just neg -> dsSyntaxExpr neg [lit_expr]
+        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]
         ; match_result <- match vars ty (shiftEqns (eqn1:eqns))
         ; return (mkGuardedMatchResult pred_expr match_result) }
 matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))
@@ -442,20 +445,19 @@ We generate:
 matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- All NPlusKPats, for the *same* literal k
 matchNPlusKPats (var:vars) ty (eqn1:eqns)
-  = do  { let NPlusKPat (L _ n1) (L _ lit) ge minus = firstPat eqn1
-        ; ge_expr     <- dsExpr ge
-        ; minus_expr  <- dsExpr minus
-        ; lit_expr    <- dsOverLit lit
-        ; let pred_expr   = mkApps ge_expr [Var var, lit_expr]
-              minusk_expr = mkApps minus_expr [Var var, lit_expr]
-              (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
+  = do  { let NPlusKPat (L _ n1) (L _ lit1) lit2 ge minus _ = firstPat eqn1
+        ; lit1_expr   <- dsOverLit lit1
+        ; lit2_expr   <- dsOverLit lit2
+        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]
+        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]
+        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)
         ; match_result <- match vars ty eqns'
         ; return  (mkGuardedMatchResult pred_expr               $
                    mkCoLetMatchResult (NonRec n1 minusk_expr)   $
                    adjustMatchResult (foldr1 (.) wraps)         $
                    match_result) }
   where
-    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ : pats })
+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat (L _ n) _ _ _ _ _ : pats })
         = (wrapBind n n1, eqn { eqn_pats = pats })
         -- The wrapBind is a no-op for the first equation
     shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)
index 3c5fe28..f1f59c1 100644 (file)
@@ -229,7 +229,7 @@ hsExprToPmExpr (HsOverLit  olit) = PmExprLit (PmOLit False olit)
 hsExprToPmExpr (HsLit       lit) = PmExprLit (PmSLit lit)
 
 hsExprToPmExpr e@(NegApp _ neg_e)
-  | PmExprLit (PmOLit False ol) <- hsExprToPmExpr neg_e
+  | PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
   = PmExprLit (PmOLit True ol)
   | otherwise = PmExprOther e
 hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
@@ -270,6 +270,9 @@ hsExprToPmExpr (ExprWithTySigOut  e _) = lhsExprToPmExpr e
 hsExprToPmExpr (HsWrap            _ e) =  hsExprToPmExpr e
 hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
 
+synExprToPmExpr :: SyntaxExpr Id -> PmExpr
+synExprToPmExpr = hsExprToPmExpr . syn_expr  -- ignore the wrappers
+
 {-
 %************************************************************************
 %*                                                                      *
index e6d703b..2dca546 100644 (file)
@@ -1275,10 +1275,6 @@ quantifyType ty = ( filter isTyVar $
   where
     (_tvs, rho) = tcSplitForAllTys ty
 
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM condM acc = condM >>= \c -> unless c acc
-
-
 -- Strict application of f at index i
 appArr :: Ix i => (e -> a) -> Array i e -> Int -> a
 appArr f a@(Array _ _ _ ptrs#) i@(I# i#)
index 5b0b1a4..213c4f5 100644 (file)
@@ -908,7 +908,7 @@ cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
 cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
 cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds
                             ; returnL $ LetStmt (noLoc ds') }
-cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noExpr noSyntaxExpr placeHolderType }
                        where
                          cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
 
index 62b6a68..cfc373e 100644 (file)
@@ -27,6 +27,7 @@ import HsBinds
 import TcEvidence
 import CoreSyn
 import Var
+import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
 import Name
 import BasicTypes
 import ConLike
@@ -78,15 +79,54 @@ noPostTcTable = []
 -- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for
 --      @(>>=)@, and then instantiated by the type checker with its type args
 --      etc
+--
+-- This should desugar to
+--
+-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)
+-- >                         (syn_arg_wraps[1] arg1) ...
+--
+-- where the actual arguments come from elsewhere in the AST.
+-- This could be defined using @PostRn@ and @PostTc@ and such, but it's
+-- harder to get it all to work out that way. ('noSyntaxExpr' is hard to
+-- write, for example.)
+data SyntaxExpr id = SyntaxExpr { syn_expr      :: HsExpr id
+                                , syn_arg_wraps :: [HsWrapper]
+                                , syn_res_wrap  :: HsWrapper }
+  deriving (Typeable)
+deriving instance (DataId id) => Data (SyntaxExpr id)
 
-type SyntaxExpr id = HsExpr id
+-- | This is used for rebindable-syntax pieces that are too polymorphic
+-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)
+noExpr :: HsExpr id
+noExpr = HsLit (HsString "" (fsLit "noExpr"))
 
 noSyntaxExpr :: SyntaxExpr id -- Before renaming, and sometimes after,
                               -- (if the syntax slot makes no sense)
-noSyntaxExpr = HsLit (HsString "" (fsLit "noSyntaxExpr"))
-
-
-type CmdSyntaxTable id = [(Name, SyntaxExpr id)]
+noSyntaxExpr = SyntaxExpr { syn_expr      = HsLit (HsString "" (fsLit "noSyntaxExpr"))
+                          , syn_arg_wraps = []
+                          , syn_res_wrap  = WpHole }
+
+-- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the
+-- renamer), missing its HsWrappers.
+mkRnSyntaxExpr :: Name -> SyntaxExpr Name
+mkRnSyntaxExpr name = SyntaxExpr { syn_expr      = HsVar $ noLoc name
+                                 , syn_arg_wraps = []
+                                 , syn_res_wrap  = WpHole }
+  -- don't care about filling in syn_arg_wraps because we're clearly
+  -- not past the typechecker
+
+instance OutputableBndr id => Outputable (SyntaxExpr id) where
+  ppr (SyntaxExpr { syn_expr      = expr
+                  , syn_arg_wraps = arg_wraps
+                  , syn_res_wrap  = res_wrap })
+    = sdocWithDynFlags $ \ dflags ->
+      getPprStyle $ \s ->
+      if debugStyle s || gopt Opt_PrintExplicitCoercions dflags
+      then ppr expr <> braces (pprWithCommas (pprHsWrapper (text "<>")) arg_wraps)
+                    <> braces (pprHsWrapper (text "<>") res_wrap)
+      else ppr expr
+
+type CmdSyntaxTable id = [(Name, HsExpr id)]
 -- See Note [CmdSyntaxTable]
 
 {-
@@ -1368,6 +1408,9 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
              -- The fail operator is noSyntaxExpr
              -- if the pattern match can't fail
 
+             (PostTc idR Type)  -- result type of the function passed to bind;
+                                -- that is, S in (>>=) :: Q -> (R -> S) -> T
+
   -- | 'ApplicativeStmt' represents an applicative expression built with
   -- <$> and <*>.  It is generated by the renamer, and is desugared into the
   -- appropriate applicative expression by the desugarer, but it is intended
@@ -1396,9 +1439,10 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
 
   -- ParStmts only occur in a list/monad comprehension
   | ParStmt  [ParStmtBlock idL idR]
-             (SyntaxExpr idR)           -- Polymorphic `mzip` for monad comprehensions
+             (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions
              (SyntaxExpr idR)           -- The `>>=` operator
                                         -- See notes [Monad Comprehensions]
+             (PostTc idR Type)          -- S in (>>=) :: Q -> (R -> S) -> T
             -- After renaming, the ids are the binders
             -- bound by the stmts and used after themp
 
@@ -1416,8 +1460,11 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
       trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for
                                       -- the inner monad comprehensions
       trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator
-      trS_fmap :: SyntaxExpr idR      -- The polymorphic 'fmap' function for desugaring
+      trS_bind_arg_ty :: PostTc idR Type,  -- R in (>>=) :: Q -> (R -> S) -> T
+      trS_fmap :: HsExpr idR          -- The polymorphic 'fmap' function for desugaring
                                       -- Only for 'group' forms
+                                      -- Just a simple HsExpr, because it's
+                                      -- too polymorphic for tcSyntaxOp
     }                                 -- See Note [Monad Comprehensions]
 
   -- Recursive statement (see Note [How RecStmt works] below)
@@ -1442,6 +1489,7 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
      , recS_bind_fn :: SyntaxExpr idR -- The bind function
      , recS_ret_fn  :: SyntaxExpr idR -- The return function
      , recS_mfix_fn :: SyntaxExpr idR -- The mfix function
+     , recS_bind_ty :: PostTc idR Type  -- S in (>>=) :: Q -> (R -> S) -> T
 
         -- These fields are only valid after typechecking
      , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)
@@ -1482,7 +1530,7 @@ data ApplicativeArg idL idR
       (LHsExpr idL)
   | ApplicativeArgMany           -- do { stmts; return vars }
       [ExprLStmt idL]            -- stmts
-      (SyntaxExpr idL)           -- return (v1,..,vn), or just (v1,..,vn)
+      (HsExpr idL)               -- return (v1,..,vn), or just (v1,..,vn)
       (LPat idL)                 -- (v1,...,vn)
   deriving( Typeable )
 deriving instance (DataId idL, DataId idR) => Data (ApplicativeArg idL idR)
@@ -1638,10 +1686,10 @@ pprStmt (LastStmt expr ret_stripped _)
   = ifPprDebug (text "[last]") <+>
        (if ret_stripped then text "return" else empty) <+>
        ppr expr
-pprStmt (BindStmt pat expr _ _)   = hsep [ppr pat, larrow, ppr expr]
+pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr]
 pprStmt (LetStmt (L _ binds))     = hsep [text "let", pprBinds binds]
 pprStmt (BodyStmt expr _ _ _)     = ppr expr
-pprStmt (ParStmt stmtss _ _)      = sep (punctuate (text " | ") (map ppr stmtss))
+pprStmt (ParStmt stmtss _ _ _)    = sep (punctuate (text " | ") (map ppr stmtss))
 
 pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form })
   = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])
@@ -1672,7 +1720,8 @@ pprStmt (ApplicativeStmt args mb_join _)
    flattenStmt stmt = [ppr stmt]
 
    flattenArg (_, ApplicativeArgOne pat expr) =
-     [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL)]
+     [ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
+             :: ExprStmt idL)]
    flattenArg (_, ApplicativeArgMany stmts _ _) =
      concatMap flattenStmt stmts
 
@@ -1685,7 +1734,8 @@ pprStmt (ApplicativeStmt args mb_join _)
           else text "join" <+> parens ap_expr
 
    pp_arg (_, ApplicativeArgOne pat expr) =
-     ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr :: ExprStmt idL)
+     ppr (BindStmt pat expr noSyntaxExpr noSyntaxExpr (panic "pprStmt")
+            :: ExprStmt idL)
    pp_arg (_, ApplicativeArgMany stmts return pat) =
      ppr pat <+>
      text "<-" <+>
index bb5142f..7eeddd4 100644 (file)
@@ -18,28 +18,31 @@ type role HsCmd nominal
 type role MatchGroup nominal representational
 type role GRHSs nominal representational
 type role HsSplice nominal
+type role SyntaxExpr nominal
 data HsExpr (i :: *)
 data HsCmd  (i :: *)
 data HsSplice (i :: *)
 data MatchGroup (a :: *) (body :: *)
 data GRHSs (a :: *) (body :: *)
+data SyntaxExpr (i :: *)
 
 instance Typeable HsSplice
 instance Typeable HsExpr
 instance Typeable MatchGroup
 instance Typeable GRHSs
+instance Typeable SyntaxExpr
 
 instance (DataId id) => Data (HsSplice id)
 instance (DataId id) => Data (HsExpr id)
 instance (DataId id) => Data (HsCmd id)
 instance (Data body,DataId id) => Data (MatchGroup id body)
 instance (Data body,DataId id) => Data (GRHSs id body)
+instance (DataId id) => Data (SyntaxExpr id)
 
 instance OutputableBndr id => Outputable (HsExpr id)
 instance OutputableBndr id => Outputable (HsCmd id)
 
 type LHsExpr a = Located (HsExpr a)
-type SyntaxExpr a = HsExpr a
 
 pprLExpr :: (OutputableBndr i) =>
         LHsExpr i -> SDoc
index b929f86..4686077 100644 (file)
@@ -18,7 +18,7 @@ module HsLit where
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr )
+import {-# SOURCE #-} HsExpr( HsExpr, pprExpr )
 import BasicTypes ( FractionalLit(..),SourceText )
 import Type       ( Type )
 import Outputable
@@ -79,7 +79,7 @@ data HsOverLit id       -- An overloaded literal
   = OverLit {
         ol_val :: OverLitVal,
         ol_rebindable :: PostRn id Bool, -- Note [ol_rebindable]
-        ol_witness :: SyntaxExpr id,     -- Note [Overloaded literal witnesses]
+        ol_witness :: HsExpr id,     -- Note [Overloaded literal witnesses]
         ol_type :: PostTc id Type }
   deriving (Typeable)
 deriving instance (DataId id) => Data (HsOverLit id)
@@ -111,7 +111,7 @@ Equivalently it's True if
 
 Note [Overloaded literal witnesses]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-*Before* type checking, the SyntaxExpr in an HsOverLit is the
+*Before* type checking, the HsExpr in an HsOverLit is the
 name of the coercion function, 'fromInteger' or 'fromRational'.
 *After* type checking, it is a witness for the literal, such as
         (fromInteger 3) or lit_78
index 9bb91d2..e1ccd63 100644 (file)
@@ -190,14 +190,22 @@ data Pat id
                     (Maybe (SyntaxExpr id))     -- Just (Name of 'negate') for negative
                                                 -- patterns, Nothing otherwise
                     (SyntaxExpr id)             -- Equality checker, of type t->t->Bool
+                    (PostTc id Type)            -- Overall type of pattern. Might be
+                                                -- different than the literal's type
+                                                -- if (==) or negate changes the type
 
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnVal' @'+'@
 
   -- For details on above see note [Api annotations] in ApiAnnotation
   | NPlusKPat       (Located id)        -- n+k pattern
                     (Located (HsOverLit id)) -- It'll always be an HsIntegral
-                    (SyntaxExpr id)     -- (>=) function, of type t->t->Bool
+                    (HsOverLit id)      -- See Note [NPlusK patterns] in TcPat
+                     -- NB: This could be (PostTc ...), but that induced a
+                     -- a new hs-boot file. Not worth it.
+
+                    (SyntaxExpr id)     -- (>=) function, of type t1->t2->Bool
                     (SyntaxExpr id)     -- Name of '-' (see RnEnv.lookupSyntaxName)
+                    (PostTc id Type)    -- Type of overall pattern
 
         ------------ Pattern type signatures ---------------
   -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon'
@@ -391,9 +399,9 @@ pprPat (AsPat name pat)       = hcat [pprPrefixOcc (unLoc name), char '@', pprPa
 pprPat (ViewPat expr pat _)   = hcat [pprLExpr expr, text " -> ", ppr pat]
 pprPat (ParPat pat)           = parens (ppr pat)
 pprPat (LitPat s)             = ppr s
-pprPat (NPat l Nothing  _)    = ppr l
-pprPat (NPat l (Just _) _)    = char '-' <> ppr l
-pprPat (NPlusKPat n k _ _)    = hcat [ppr n, char '+', ppr k]
+pprPat (NPat l Nothing  _ _)  = ppr l
+pprPat (NPat l (Just _) _ _)  = char '-' <> ppr l
+pprPat (NPlusKPat n k _ _ _ _)= hcat [ppr n, char '+', ppr k]
 pprPat (SplicePat splice)     = pprSplice splice
 pprPat (CoPat co pat _)       = pprHsWrapper (ppr pat) co
 pprPat (SigPatIn pat ty)      = ppr pat <+> dcolon <+> ppr ty
index 43f3de6..abd7a4b 100644 (file)
@@ -16,6 +16,7 @@ which deal with the instantiated versions are located elsewhere:
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module HsUtils(
   -- Terms
@@ -27,7 +28,8 @@ module HsUtils(
   mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap, isLHsTypeExpr_maybe, isLHsTypeExpr,
 
-  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
+  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
+  nlHsIntLit, nlHsVarApps,
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
   toLHsSigWcType,
@@ -58,7 +60,8 @@ module HsUtils(
   getLHsInstDeclClass_maybe,
 
   -- Stmts
-  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkLastStmt,
+  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
+  mkLastStmt,
   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
   emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
 
@@ -99,6 +102,7 @@ import RdrName
 import Var
 import TyCoRep
 import Type   ( filterOutInvisibleTypes )
+import TysWiredIn ( unitTy )
 import TcType
 import DataCon
 import Name
@@ -223,13 +227,16 @@ mkHsDo         :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
 mkHsComp       :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
                -> HsExpr RdrName
 
-mkNPat      :: Located (HsOverLit id) -> Maybe (SyntaxExpr id) -> Pat id
-mkNPlusKPat :: Located id -> Located (HsOverLit id) -> Pat id
+mkNPat      :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName
+mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName
 
 mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
 mkBodyStmt :: Located (bodyR RdrName)
            -> StmtLR idL RdrName (Located (bodyR RdrName))
-mkBindStmt :: LPat idL -> Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
+mkBindStmt :: (PostTc idR Type ~ PlaceHolder)
+           => LPat idL -> Located (bodyR idR)
+           -> StmtLR idL idR (Located (bodyR idR))
+mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id))
 
 emptyRecStmt     :: StmtLR idL  RdrName bodyR
 emptyRecStmtName :: StmtLR Name Name    bodyR
@@ -237,9 +244,9 @@ emptyRecStmtId   :: StmtLR Id   Id      bodyR
 mkRecStmt    :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
 
 
-mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noSyntaxExpr
-mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noSyntaxExpr
-mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noSyntaxExpr
+mkHsIntegral src i  = OverLit (HsIntegral   src i) noRebindableInfo noExpr
+mkHsFractional   f  = OverLit (HsFractional     f) noRebindableInfo noExpr
+mkHsIsString src s  = OverLit (HsIsString   src s) noRebindableInfo noExpr
 
 noRebindableInfo :: PlaceHolder
 noRebindableInfo = PlaceHolder -- Just another placeholder;
@@ -252,24 +259,29 @@ mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
 mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id
 mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b
 
-mkNPat lit neg     = NPat lit neg noSyntaxExpr
-mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr
+mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType
+mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
 
-mkTransformStmt    :: [ExprLStmt idL] -> LHsExpr idR
+mkTransformStmt    :: (PostTc idR Type ~ PlaceHolder)
+                   => [ExprLStmt idL] -> LHsExpr idR
                    -> StmtLR idL idR (LHsExpr idL)
-mkTransformByStmt  :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
+mkTransformByStmt  :: (PostTc idR Type ~ PlaceHolder)
+                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
                    -> StmtLR idL idR (LHsExpr idL)
-mkGroupUsingStmt   :: [ExprLStmt idL]                -> LHsExpr idR
+mkGroupUsingStmt   :: (PostTc idR Type ~ PlaceHolder)
+                   => [ExprLStmt idL]                -> LHsExpr idR
                    -> StmtLR idL idR (LHsExpr idL)
-mkGroupByUsingStmt :: [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
+mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder)
+                   => [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
                    -> StmtLR idL idR (LHsExpr idL)
 
-emptyTransStmt :: StmtLR idL idR (LHsExpr idR)
+emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR)
 emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
                            , trS_stmts = [], trS_bndrs = []
-                           , trS_by = Nothing, trS_using = noLoc noSyntaxExpr
+                           , trS_by = Nothing, trS_using = noLoc noExpr
                            , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
-                           , trS_fmap = noSyntaxExpr }
+                           , trS_bind_arg_ty = PlaceHolder
+                           , trS_fmap = noExpr }
 mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }
 mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }
 mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
@@ -277,8 +289,9 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
 
 mkLastStmt body     = LastStmt body False noSyntaxExpr
 mkBodyStmt body     = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
-mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr
-
+mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
+mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
+  -- don't use placeHolderTypeTc above, because that panics during zonking
 
 emptyRecStmt' :: forall idL idR body.
                        PostTc idR Type -> StmtLR idL idR body
@@ -288,12 +301,13 @@ emptyRecStmt' tyVal =
      , recS_rec_ids = []
      , recS_ret_fn = noSyntaxExpr
      , recS_mfix_fn = noSyntaxExpr
-     , recS_bind_fn = noSyntaxExpr, recS_later_rets = []
+     , recS_bind_fn = noSyntaxExpr, recS_bind_ty = tyVal
+     , recS_later_rets = []
      , recS_rec_rets = [], recS_ret_ty = tyVal }
 
 emptyRecStmt     = emptyRecStmt' placeHolderType
 emptyRecStmtName = emptyRecStmt' placeHolderType
-emptyRecStmtId   = emptyRecStmt' placeHolderTypeTc
+emptyRecStmtId   = emptyRecStmt' unitTy -- a panic might trigger during zonking
 mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }
 
 -------------------------------
@@ -366,6 +380,18 @@ nlLitPat l = noLoc (LitPat l)
 nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
 nlHsApp f x = noLoc (HsApp f x)
 
+nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr id
+nlHsSyntaxApps (SyntaxExpr { syn_expr      = fun
+                           , syn_arg_wraps = arg_wraps
+                           , syn_res_wrap  = res_wrap }) args
+  | [] <- arg_wraps   -- in the noSyntaxExpr case
+  = ASSERT( isIdHsWrapper res_wrap )
+    foldl nlHsApp (noLoc fun) args
+
+  | otherwise
+  = mkLHsWrap res_wrap (foldl nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
+                                                     mkLHsWrap arg_wraps args))
+
 nlHsIntLit :: Integer -> LHsExpr id
 nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
 
@@ -797,11 +823,11 @@ collectLStmtBinders = collectStmtBinders . unLoc
 
 collectStmtBinders :: StmtLR idL idR body -> [idL]
   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?
-collectStmtBinders (BindStmt pat _ _ _)  = collectPatBinders pat
+collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
 collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
 collectStmtBinders (BodyStmt {})         = []
 collectStmtBinders (LastStmt {})         = []
-collectStmtBinders (ParStmt xs _ _)   = collectLStmtsBinders
+collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders
                                       $ [s | ParStmtBlock ss _ _ <- xs, s <- ss]
 collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
 collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss
@@ -836,8 +862,8 @@ collect_lpat (L _ pat) bndrs
     go (ConPatOut {pat_args=ps})  = foldr collect_lpat bndrs (hsConPatArgs ps)
         -- See Note [Dictionary binders in ConPatOut]
     go (LitPat _)                 = bndrs
-    go (NPat _ _ _)               = bndrs
-    go (NPlusKPat (L _ n) _ _ _)  = n : bndrs
+    go (NPat {})                  = bndrs
+    go (NPlusKPat (L _ n) _ _ _ _ _)= n : bndrs
 
     go (SigPatIn pat _)           = collect_lpat pat bndrs
     go (SigPatOut pat _)          = collect_lpat pat bndrs
@@ -1054,14 +1080,14 @@ lStmtsImplicits = hs_lstmts
     hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
 
     hs_stmt :: StmtLR Name idR (Located (body idR)) -> NameSet
-    hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat
+    hs_stmt (BindStmt pat _ _ _ _) = lPatImplicits pat
     hs_stmt (ApplicativeStmt args _ _) = unionNameSets (map do_arg args)
       where do_arg (_, ApplicativeArgOne pat _) = lPatImplicits pat
             do_arg (_, ApplicativeArgMany stmts _ _) = hs_lstmts stmts
     hs_stmt (LetStmt binds)      = hs_local_binds (unLoc binds)
     hs_stmt (BodyStmt {})        = emptyNameSet
     hs_stmt (LastStmt {})        = emptyNameSet
-    hs_stmt (ParStmt xs _ _)     = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
+    hs_stmt (ParStmt xs _ _ _)   = hs_lstmts [s | ParStmtBlock ss _ _ <- xs, s <- ss]
     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
     hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss
 
index 87736ac..b4e109f 100644 (file)
@@ -3,7 +3,6 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module PlaceHolder where
 
@@ -14,7 +13,7 @@ import NameSet
 import RdrName
 import Var
 import Coercion
-import {-# SOURCE #-} ConLike (ConLike)
+import ConLike (ConLike)
 import FieldLabel
 import SrcLoc (Located)
 import TcEvidence ( HsWrapper )
@@ -31,18 +30,21 @@ import BasicTypes       (Fixity)
 %************************************************************************
 -}
 
+-- NB: These are intentionally open, allowing API consumers (like Haddock)
+-- to declare new instances
+
 -- | used as place holder in PostTc and PostRn values
 data PlaceHolder = PlaceHolder
   deriving (Data,Typeable)
 
 -- | Types that are not defined until after type checking
-type family PostTc it ty :: * -- Note [Pass sensitive types]
+type family PostTc id ty  -- Note [Pass sensitive types]
 type instance PostTc Id      ty = ty
 type instance PostTc Name    ty = PlaceHolder
 type instance PostTc RdrName ty = PlaceHolder
 
 -- | Types that are not defined until after renaming
-type family PostRn id ty :: * -- Note [Pass sensitive types]
+type family PostRn id ty  -- Note [Pass sensitive types]
 type instance PostRn Id      ty = ty
 type instance PostRn Name    ty = ty
 type instance PostRn RdrName ty = PlaceHolder
@@ -86,10 +88,6 @@ pass-specific data types, implemented as a pair of open type families,
 one for PostTc and one for PostRn. These are then explicitly populated
 with a PlaceHolder value when they do not yet have meaning.
 
-Since the required bootstrap compiler at this stage does not have
-closed type families, an open type family had to be used, which
-unfortunately forces the requirement for UndecidableInstances.
-
 In terms of actual usage, we have the following
 
   PostTc id Kind
index 477ef88..0c17cde 100644 (file)
@@ -2446,7 +2446,7 @@ flattenedpquals :: { Located [LStmt RdrName (LHsExpr RdrName)] }
 
                     qss -> sL1 $1 [sL1 $1 $ ParStmt [ParStmtBlock qs [] noSyntaxExpr |
                                             qs <- qss]
-                                            noSyntaxExpr noSyntaxExpr]
+                                            noExpr noSyntaxExpr placeHolderType]
                     -- We actually found some actual parallel lists so
                     -- we wrap them into as a ParStmt
                 }
index 78ab50d..372874a 100644 (file)
@@ -1162,8 +1162,8 @@ checkCmdLStmt = locMap checkCmdStmt
 checkCmdStmt :: SrcSpan -> ExprStmt RdrName -> P (CmdStmt RdrName)
 checkCmdStmt _ (LastStmt e s r) =
     checkCommand e >>= (\c -> return $ LastStmt c s r)
-checkCmdStmt _ (BindStmt pat e b f) =
-    checkCommand e >>= (\c -> return $ BindStmt pat c b f)
+checkCmdStmt _ (BindStmt pat e b f t) =
+    checkCommand e >>= (\c -> return $ BindStmt pat c b f t)
 checkCmdStmt _ (BodyStmt e t g ty) =
     checkCommand e >>= (\c -> return $ BodyStmt c t g ty)
 checkCmdStmt _ (LetStmt bnds) = return $ LetStmt bnds
index d1ec1de..868712b 100644 (file)
@@ -1562,21 +1562,23 @@ lookupIfThenElse
        ; if not rebindable_on
          then return (Nothing, emptyFVs)
          else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))
-                 ; return (Just (HsVar (noLoc ite)), unitFV ite) } }
+                 ; return ( Just (mkRnSyntaxExpr ite)
+                          , unitFV ite ) } }
 
 lookupSyntaxName :: Name                                -- The standard name
                  -> RnM (SyntaxExpr Name, FreeVars)     -- Possibly a non-standard name
 lookupSyntaxName std_name
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on then
-           return (HsVar (noLoc std_name), emptyFVs)
+           return (mkRnSyntaxExpr std_name, emptyFVs)
          else
             -- Get the similarly named thing from the local environment
            do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))
-              ; return (HsVar (noLoc usr_name), unitFV usr_name) } }
+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }
 
 lookupSyntaxNames :: [Name]                          -- Standard names
                   -> RnM ([HsExpr Name], FreeVars)   -- See comments with HsExpr.ReboundNames
+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs
 lookupSyntaxNames std_names
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
        ; if not rebindable_on then
index 66703df..e88f1e0 100644 (file)
@@ -12,6 +12,7 @@ free variables.
 
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module RnExpr (
         rnLExpr, rnExpr, rnStmts
@@ -589,7 +590,7 @@ methodNamesLStmt = methodNamesStmt . unLoc
 methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
 methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd
 methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
-methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
+methodNamesStmt (BindStmt _ cmd _ _ _)           = methodNamesLCmd cmd
 methodNamesStmt (RecStmt { recS_stmts = stmts }) =
   methodNamesStmts stmts `addOneFV` loopAName
 methodNamesStmt (LetStmt {})                     = emptyFVs
@@ -776,7 +777,7 @@ rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
                      then_op guard_op placeHolderType), fv_expr)], thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }
 
-rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
+rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
   = do  { (body', fv_expr) <- rnBody body
                 -- The binders do not scope over the expression
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
@@ -788,7 +789,8 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
 
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
-        ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
+        ; return (( [( L loc (BindStmt pat' body' bind_op fail_op PlaceHolder)
+                     , fv_expr )]
                   , thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
@@ -826,12 +828,12 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)
                  , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 
-rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside
-  = do  { (mzip_op, fvs1)   <- lookupStmtName ctxt mzipName
+rnStmt ctxt _ (L loc (ParStmt segs _ _ _)) thing_inside
+  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName
         ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName
         ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
         ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside
-        ; return ( ([(L loc (ParStmt segs' mzip_op bind_op), fvs4)], thing)
+        ; return ( ([(L loc (ParStmt segs' mzip_op bind_op placeHolderType), fvs4)], thing)
                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 
 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
@@ -855,8 +857,8 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName
        ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName
        ; (fmap_op,   fvs5) <- case form of
-                                ThenForm -> return (noSyntaxExpr, emptyFVs)
-                                _        -> lookupStmtName ctxt fmapName
+                                ThenForm -> return (noExpr, emptyFVs)
+                                _        -> lookupStmtNamePoly ctxt fmapName
 
        ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3
                              `plusFV` fvs4 `plusFV` fvs5
@@ -867,6 +869,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
        ; return (([(L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
                                     , trS_by = by', trS_using = using', trS_form = form
                                     , trS_ret = return_op, trS_bind = bind_op
+                                    , trS_bind_arg_ty = PlaceHolder
                                     , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
 
 rnStmt _ _ (L _ ApplicativeStmt{}) _ =
@@ -906,26 +909,44 @@ rnParallelStmts ctxt return_op segs thing_inside
     dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
                     <+> quotes (ppr (head vs)))
 
-lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
--- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable
--- Neither is ArrowExpr, which has its own desugarer in DsArrows
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars)
+-- Like lookupSyntaxName, but respects contexts
 lookupStmtName ctxt n
-  = case ctxt of
-      ListComp        -> not_rebindable
-      PArrComp        -> not_rebindable
-      ArrowExpr       -> not_rebindable
-      PatGuard {}     -> not_rebindable
-
-      DoExpr          -> rebindable
-      MDoExpr         -> rebindable
-      MonadComp       -> rebindable
-      GhciStmtCtxt    -> rebindable   -- I suppose?
-
-      ParStmtCtxt   c -> lookupStmtName c n     -- Look inside to
-      TransStmtCtxt c -> lookupStmtName c n     -- the parent context
+  | rebindableContext ctxt
+  = lookupSyntaxName n
+  | otherwise
+  = return (mkRnSyntaxExpr n, emptyFVs)
+
+lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
+lookupStmtNamePoly ctxt name
+  | rebindableContext ctxt
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if rebindable_on
+         then do { fm <- lookupOccRn (nameRdrName name)
+                 ; return (HsVar (noLoc fm), unitFV fm) }
+         else not_rebindable }
+  | otherwise
+  = not_rebindable
   where
-    rebindable     = lookupSyntaxName n
-    not_rebindable = return (HsVar (noLoc n), emptyFVs)
+    not_rebindable = return (HsVar (noLoc name), emptyFVs)
+
+-- | Is this a context where we respect RebindableSyntax?
+-- but ListComp/PArrComp are never rebindable
+-- Neither is ArrowExpr, which has its own desugarer in DsArrows
+rebindableContext :: HsStmtContext Name -> Bool
+rebindableContext ctxt = case ctxt of
+  ListComp        -> False
+  PArrComp        -> False
+  ArrowExpr       -> False
+  PatGuard {}     -> False
+
+  DoExpr          -> True
+  MDoExpr         -> True
+  MonadComp       -> True
+  GhciStmtCtxt    -> True   -- I suppose?
+
+  ParStmtCtxt   c -> rebindableContext c     -- Look inside to
+  TransStmtCtxt c -> rebindableContext c     -- the parent context
 
 {-
 Note [Renaming parallel Stmts]
@@ -1018,11 +1039,11 @@ rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
 rn_rec_stmt_lhs _ (L loc (LastStmt body noret a))
   = return [(L loc (LastStmt body noret a), emptyFVs)]
 
-rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b))
+rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b t))
   = do
       -- should the ctxt be MDo instead?
       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
-      return [(L loc (BindStmt pat' body a b),
+      return [(L loc (BindStmt pat' body a b t),
                fv_pat)]
 
 rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
@@ -1086,7 +1107,7 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
        ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
                  L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] }
 
-rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
+rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _ _), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 
@@ -1098,7 +1119,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
        ; let bndrs = mkNameSet (collectPatBinders pat')
              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
-                  L loc (BindStmt pat' body' bind_op fail_op))] }
+                  L loc (BindStmt pat' body' bind_op fail_op PlaceHolder))] }
 
 rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
   = failWith (badIpBinds (text "an mdo expression") binds)
@@ -1438,7 +1459,7 @@ ado _ctxt []        tail _ = return (tail, emptyNameSet)
 -- In the spec, but we do it here rather than in the desugarer,
 -- because we need the typechecker to typecheck the <$> form rather than
 -- the bind form, which would give rise to a Monad constraint.
-ado ctxt [(L _ (BindStmt pat rhs _ _),_)] tail _
+ado ctxt [(L _ (BindStmt pat rhs _ _ _),_)] tail _
   | isIrrefutableHsPat pat, (False,tail') <- needJoin tail
     -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
     --          to know which types have only one constructor.  So only
@@ -1489,7 +1510,7 @@ adoSegmentArg
   -> FreeVars
   -> [(LStmt Name (LHsExpr Name), FreeVars)]
   -> RnM (ApplicativeArg Name Name, FreeVars)
-adoSegmentArg _ _ [(L _ (BindStmt pat exp _ _),_)] =
+adoSegmentArg _ _ [(L _ (BindStmt pat exp _ _ _),_)] =
   return (ApplicativeArgOne pat exp, emptyFVs)
 adoSegmentArg ctxt tail_fvs stmts =
   do { let pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1498,12 +1519,12 @@ adoSegmentArg ctxt tail_fvs stmts =
            pat = mkBigLHsVarPatTup pvars
            tup = mkBigLHsVarTup pvars
      ; (stmts',fvs2) <- adoSegment ctxt stmts [] pvarset
-     ; (mb_ret, fvs1) <- case () of
-          _ | L _ ApplicativeStmt{} <- last stmts' ->
-              return (unLoc tup, emptyNameSet)
-            | otherwise -> do
-              (ret,fvs) <- lookupStmtName ctxt returnMName
-              return (HsApp (noLoc ret) tup, fvs)
+     ; (mb_ret, fvs1) <-
+          if | L _ ApplicativeStmt{} <- last stmts' ->
+               return (unLoc tup, emptyNameSet)
+             | otherwise -> do
+               (ret,fvs) <- lookupStmtNamePoly ctxt returnMName
+               return (HsApp (noLoc ret) tup, fvs)
      ; return ( ApplicativeArgMany stmts' mb_ret pat
               , fvs1 `plusFV` fvs2) }
 
@@ -1573,9 +1594,9 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
  where
   -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
   -- in this group, then add it to the group.
-  go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op), fvs) : rest)
+  go lets indep bndrs ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : rest)
     | isEmptyNameSet (bndrs `intersectNameSet` fvs)
-    = go lets ((L loc (BindStmt pat body bind_op fail_op), fvs) : indep)
+    = go lets ((L loc (BindStmt pat body bind_op fail_op ty), fvs) : indep)
          bndrs' rest
     where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)
   -- If we encounter a LetStmt that doesn't depend on a BindStmt in this
index bb82e8f..eab3090 100644 (file)
@@ -385,22 +385,22 @@ rnPatAndThen mk (LitPat lit)
   where
     normal_lit = do { liftCps (rnLit lit); return (LitPat lit) }
 
-rnPatAndThen _ (NPat (L l lit) mb_neg _eq)
+rnPatAndThen _ (NPat (L l lit) mb_neg _eq _)
   = do { lit'    <- liftCpsFV $ rnOverLit lit
        ; mb_neg' <- liftCpsFV $ case mb_neg of
                       Nothing -> return (Nothing, emptyFVs)
                       Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
                                     ; return (Just neg, fvs) }
        ; eq' <- liftCpsFV $ lookupSyntaxName eqName
-       ; return (NPat (L l lit') mb_neg' eq') }
+       ; return (NPat (L l lit') mb_neg' eq' placeHolderType) }
 
-rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _)
+rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _)
   = do { new_name <- newPatName mk rdr
        ; lit'  <- liftCpsFV $ rnOverLit lit
        ; minus <- liftCpsFV $ lookupSyntaxName minusName
        ; ge    <- liftCpsFV $ lookupSyntaxName geName
        ; return (NPlusKPat (L (nameSrcSpan new_name) new_name)
-                           (L l lit') ge minus) }
+                           (L l lit') lit' ge minus placeHolderType) }
                 -- The Report says that n+k patterns must be in Integral
 
 rnPatAndThen mk (AsPat rdr pat)
@@ -784,7 +784,8 @@ rnOverLit origLit
             | otherwise       = origLit
           }
         ; let std_name = hsOverLitName val
-        ; (from_thing_name, fvs) <- lookupSyntaxName std_name
+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs)
+            <- lookupSyntaxName std_name
         ; let rebindable = case from_thing_name of
                                 HsVar (L _ v) -> v /= std_name
                                 _             -> panic "rnOverLit"
index 43cbb48..fe17d52 100644 (file)
@@ -14,7 +14,7 @@ module Inst (
        instCall, instDFunType, instStupidTheta,
        newWanted, newWanteds,
 
-       newOverloadedLit, newNonTrivialOverloadedLit, mkOverLit,
+       newOverloadedLit, mkOverLit,
 
        newClsInst,
        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
@@ -156,7 +156,7 @@ deeplySkolemise ty
 topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 -- if    topInstantiate ty = (wrap, rho)
 -- and   e :: ty
--- then  wrap e :: rho
+-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)
 topInstantiate = top_instantiate True
 
 -- | Instantiate all outer 'Invisible' binders
@@ -216,6 +216,7 @@ deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 -- if    deeplyInstantiate ty = (wrap, rho)
 -- and   e :: ty
 -- then  wrap e :: rho
+-- That is, wrap :: ty "->" rho
 
 deeplyInstantiate orig ty
   | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
@@ -342,31 +343,27 @@ cases (the rest are caught in lookupInst).
 -}
 
 newOverloadedLit :: HsOverLit Name
-                 -> TcSigmaType  -- if nec'y, this type is instantiated...
-                 -> CtOrigin     -- ... using this CtOrigin
-                 -> TcM (HsWrapper, HsOverLit TcId)
-                   -- wrapper :: input type "->" type of result
+                 -> ExpRhoType
+                 -> TcM (HsOverLit TcId)
 newOverloadedLit
-  lit@(OverLit { ol_val = val, ol_rebindable = rebindable }) res_ty res_orig
+  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.
-  = do { (wrap, insted_ty) <- deeplyInstantiate res_orig res_ty
+    -- all built-in overloaded lits are tau-types, so we can just
+    -- tauify the ExpType
+  = do { res_ty <- expTypeToType res_ty
        ; dflags <- getDynFlags
-       ; case shortCutLit dflags val insted_ty of
+       ; case shortCutLit dflags val res_ty of
         -- Do not generate a LitInst for rebindable syntax.
         -- Reason: If we do, tcSimplify will call lookupInst, which
         --         will call tcSyntaxName, which does unification,
         --         which tcSimplify doesn't like
-           Just expr -> return ( wrap
-                               , lit { ol_witness = expr, ol_type = insted_ty
-                                     , ol_rebindable = False } )
-           Nothing   -> (wrap, ) <$>
-                        newNonTrivialOverloadedLit orig lit insted_ty }
+           Just expr -> return (lit { ol_witness = expr, ol_type = res_ty
+                                    , ol_rebindable = False })
+           Nothing   -> newNonTrivialOverloadedLit orig lit
+                                                   (mkCheckExpType res_ty) }
 
   | otherwise
-  = do { lit' <- newNonTrivialOverloadedLit orig lit res_ty
-       ; return (idHsWrapper, lit') }
+  = newNonTrivialOverloadedLit orig lit res_ty
   where
     orig = LiteralOrigin lit
 
@@ -374,21 +371,23 @@ newOverloadedLit
 -- newOverloadedLit in TcUnify
 newNonTrivialOverloadedLit :: CtOrigin
                            -> HsOverLit Name
-                           -> TcSigmaType
+                           -> ExpRhoType
                            -> TcM (HsOverLit TcId)
 newNonTrivialOverloadedLit orig
-  lit@(OverLit { ol_val = val, ol_witness = meth_name
+  lit@(OverLit { ol_val = val, ol_witness = HsVar (L _ 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)
-                -- Overloaded literals must have liftedTypeKind, because
-                -- we're instantiating an overloaded function here,
-                -- 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 }) }
+        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)
+                                      [synKnownType lit_ty] res_ty $
+                      \_ -> return ()
+        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]
+        ; res_ty <- readExpType res_ty
+        ; return (lit { ol_witness = witness
+                      , ol_type = res_ty
+                      , ol_rebindable = rebindable }) }
+newNonTrivialOverloadedLit _ lit _
+  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)
 
 ------------
 mkOverLit :: OverLitVal -> TcM HsLit
index a781c03..052c49c 100644 (file)
@@ -77,15 +77,16 @@ Note that
 -}
 
 tcProc :: InPat Name -> LHsCmdTop Name          -- proc pat -> expr
-       -> TcRhoType                             -- Expected type of whole proc expression
+       -> ExpRhoType                            -- Expected type of whole proc expression
        -> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion)
 
 tcProc pat cmd exp_ty
   = newArrowScope $
-    do  { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
+    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows
+        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }
-        ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
+        ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $
                           tcCmdTop cmd_env cmd (unitTy, res_ty)
         ; let res_co = mkTcTransCo co
                          (mkTcAppCo co1 (mkTcNomReflCo res_ty))
@@ -144,15 +145,16 @@ tc_cmd env (HsCmdLet (L l 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) <- tcInferRho scrut
-      matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
+      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)
       return (HsCmdCase scrut' matches')
   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' = do { res_ty' <- expTypeToType res_ty'
+                              ; tcCmd env body (stk, res_ty') }
 
 tc_cmd env (HsCmdIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
-  = do  { pred' <- tcMonoExpr pred boolTy
+  = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
         ; return (HsCmdIf Nothing pred' b1' b2')
@@ -165,11 +167,13 @@ tc_cmd env (HsCmdIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if
         -- the return value.
         ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]
         ; let r_ty = mkTyVarTy r_tv
-        ; let if_ty = mkFunTys [pred_ty, r_ty, r_ty] r_ty
         ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))
                   (text "Predicate type of `ifThenElse' depends on result type")
-        ; fun'  <- tcSyntaxOp IfOrigin fun if_ty
-        ; pred' <- tcMonoExpr pred pred_ty
+        ; (pred', fun')
+            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])
+                                       (mkCheckExpType r_ty) $ \ _ ->
+               tcMonoExpr pred (mkCheckExpType pred_ty)
+
         ; b1'   <- tcCmd env b1 res_ty
         ; b2'   <- tcCmd env b2 res_ty
         ; return (HsCmdIf (Just fun') pred' b1' b2')
@@ -195,9 +199,9 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newOpenFlexiTyVarTy
         ; let fun_ty = mkCmdArrTy env arg_ty res_ty
-        ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty)
+        ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))
 
-        ; arg' <- tcMonoExpr arg arg_ty
+        ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)
 
         ; return (HsCmdArrApp fun' arg' fun_ty ho_app lr) }
   where
@@ -222,7 +226,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
   = addErrCtxt (cmdCtxt cmd)    $
     do  { arg_ty <- newOpenFlexiTyVarTy
         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)
-        ; arg'   <- tcMonoExpr arg arg_ty
+        ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)
         ; return (HsCmdApp fun' arg') }
 
 -------------------------------------------
@@ -241,9 +245,9 @@ tc_cmd env
     do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
 
                 -- Check the patterns, and the GRHSs inside
-        ; (pats', grhss') <- setSrcSpan mtch_loc                $
-                             tcPats LambdaExpr pats arg_tys     $
-                             tc_grhss grhss cmd_stk' res_ty
+        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $
+                             tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $
+                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)
 
         ; let match' = L mtch_loc (Match NonFunBindMatch pats' Nothing grhss')
               arg_tys = map hsLPatType pats'
@@ -262,7 +266,8 @@ tc_cmd env
 
     tc_grhs stk_ty res_ty (GRHS guards body)
         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $
-                                  \ res_ty -> tcCmd env body (stk_ty, res_ty)
+                                  \ res_ty -> tcCmd env body
+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)
              ; return (GRHS guards' rhs') }
 
 -------------------------------------------
@@ -350,11 +355,11 @@ tcArrDoStmt env _ (BodyStmt rhs _ _ _) res_ty thing_inside
         ; thing          <- thing_inside res_ty
         ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) }
 
-tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcArrDoStmt env ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside
   = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs
-        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                             thing_inside res_ty
-        ; return (mkBindStmt pat' rhs', thing) }
+        ; return (mkTcBindStmt pat' rhs', thing) }
 
 tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
                             , recS_rec_ids = rec_names }) res_ty thing_inside
@@ -365,7 +370,7 @@ tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
         { (stmts', tup_rets)
                 <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->
                         -- ToDo: res_ty not really right
-                   zipWithM tcCheckId tup_names tup_elt_tys
+                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)
 
         ; thing <- thing_inside res_ty
                 -- NB:  The rec_ids for the recursive things
index 1107710..2d5372d 100644 (file)
@@ -252,7 +252,7 @@ tcLocalBinds (HsIPBinds (IPBinds ip_binds _)) thing_inside
        = do { ty <- newOpenFlexiTyVarTy
             ; let p = mkStrLitTy $ hsIPNameFS ip
             ; ip_id <- newDict ipClass [ p, ty ]
-            ; expr' <- tcMonoExpr expr ty
+            ; expr' <- tcMonoExpr expr (mkCheckExpType ty)
             ; let d = toDict ipClass p ty `fmap` expr'
             ; return (ip_id, (IPBind (Right ip_id) d)) }
     tc_ip_bind _ (IPBind (Right {}) _) = panic "tc_ip_bind"
@@ -585,7 +585,7 @@ tcPolyCheck rec_tc prag_fn
                       , sig_loc   = loc })
             bind
   = do { ev_vars <- newEvVars theta
-       ; let skol_info = SigSkol ctxt (mkPhiTy theta tau)
+       ; let skol_info = SigSkol ctxt (mkCheckExpType $ mkPhiTy theta tau)
              prag_sigs = lookupPragEnv prag_fn name
              skol_tvs  = map snd skol_prs
                  -- Find the location of the original source type sig, if
@@ -780,7 +780,7 @@ mkExport prag_fn qtvs theta
                                            -- an ambiguouse type and have AllowAmbiguousType
                                            -- e..g infer  x :: forall a. F a -> Int
                   else addErrCtxtM (mk_impedence_match_msg mono_info sel_poly_ty poly_ty) $
-                       tcSubType_NC sig_ctxt sel_poly_ty poly_ty
+                       tcSubType_NC sig_ctxt sel_poly_ty (mkCheckExpType poly_ty)
 
         ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs
         ; when warn_missing_sigs $ localSigWarn poly_id mb_sig
@@ -1473,17 +1473,17 @@ tcMonoBinds is_rec sig_fn no_gen
         -- e.g.         f = \(x::forall a. a->a) -> <body>
         --      We want to infer a higher-rank type for f
     setSrcSpan b_loc    $
-    do  { (rhs_tv, _) <- newOpenReturnTyVar
-                         -- use ReturnTv to allow impredicativity
-        ; let rhs_ty = mkTyVarTy rhs_tv
-        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
+    do  { rhs_ty <- newOpenInferExpType
         ; (co_fn, matches')
-            <- tcExtendIdBndrs [TcIdBndr mono_id NotTopLevel] $
+            <- tcExtendIdBndrs [TcIdBndr_ExpType name rhs_ty 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 matches rhs_ty
 
+        ; rhs_ty  <- readExpType rhs_ty
+        ; mono_id <- newNoSigLetBndr no_gen name rhs_ty
+
         ; return (unitBag $ L b_loc $
                      FunBind { fun_id = L nm_loc mono_id,
                                fun_matches = matches', bind_fvs = fvs,
@@ -1603,7 +1603,7 @@ tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })
     tcExtendTyVarEnvForRhs mb_sig       $
     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))
         ; (co_fn, matches') <- tcMatchesFun (idName mono_id)
-                                 matches (idType mono_id)
+                                 matches (mkCheckExpType $ idType mono_id)
         ; return ( FunBind { fun_id = L loc mono_id
                            , fun_matches = matches'
                            , fun_co_fn = co_fn
index 8a2b0ad..6634415 100644 (file)
@@ -1001,25 +1001,28 @@ mkEqErr1 ctxt ct
             where
               t_or_k = ctLocTypeOrKind_maybe loc
 
-          KindEqOrigin cty1 cty2 sub_o sub_t_or_k
+          KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k
             -> (True, Nothing, msg1 $$ msg2)
             where
               sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"
                                             _              -> text "types"
               msg1 = sdocWithDynFlags $ \dflags ->
-                     if not (gopt Opt_PrintExplicitCoercions dflags) &&
-                        (cty1 `pickyEqType` cty2)
-                     then text "When matching the kind of" <+> quotes (ppr cty1)
-                     else
-                     hang (text "When matching" <+> sub_what)
-                        2 (vcat [ ppr cty1 <+> dcolon <+> ppr (typeKind cty1)
-                                , ppr cty2 <+> dcolon <+> ppr (typeKind cty2) ])
+                     case mb_cty2 of
+                       Just cty2
+                         |  gopt Opt_PrintExplicitCoercions dflags
+                         || not (cty1 `pickyEqType` cty2)
+                         -> hang (text "When matching" <+> sub_what)
+                               2 (vcat [ ppr cty1 <+> dcolon <+>
+                                         ppr (typeKind cty1)
+                                       , ppr cty2 <+> dcolon <+>
+                                         ppr (typeKind cty2) ])
+                       _ -> text "When matching the kind of" <+> quotes (ppr cty1)
               msg2 = case sub_o of
-                       TypeEqOrigin {} ->
+                       TypeEqOrigin {}
+                         | Just cty2 <- mb_cty2 ->
                          thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k
                                                      expandSyns)
-                       _ ->
-                         empty
+                       _ -> empty
           _ -> (True, Nothing, empty)
 
 -- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint
@@ -1392,7 +1395,8 @@ mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool
                     -> (Bool, Maybe SwapFlag, SDoc)
 -- NotSwapped means (actual, expected), IsSwapped is the reverse
 -- First return val is whether or not to print a herald above this msg
-mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act, uo_expected = exp
+mkExpectedActualMsg ty1 ty2 (TypeEqOrigin { uo_actual = act
+                                          , uo_expected = Check exp
                                           , uo_thing = maybe_thing })
                     m_level printExpanded
   | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)
@@ -2110,7 +2114,9 @@ pprSkol implics tv
   = case skol_info of
       UnkSkol         -> pp_tv <+> text "is an unknown type variable"
       SigSkol ctxt ty -> ppr_rigid (pprSigSkolInfo ctxt
-                                      (mkSpecForAllTys skol_tvs ty))
+                                      (mkCheckExpType $
+                                       mkSpecForAllTys skol_tvs
+                                         (checkingExpType "pprSkol" ty)))
       _               -> ppr_rigid (pprSkolInfo skol_info)
   where
     pp_tv = quotes (ppr tv)
@@ -2160,14 +2166,17 @@ relevantBindings want_filtering ctxt ct
              -- For *kind* errors, report the relevant bindings of the
              -- enclosing *type* equality, because that's more useful for the programmer
              extra_tvs = case tidy_orig of
-                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]
-                             _                      -> emptyVarSet
+                             KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $
+                                                         t1 : maybeToList m_t2
+                             _                        -> emptyVarSet
        ; traceTc "relevantBindings" $
            vcat [ ppr ct
                 , pprCtOrigin (ctLocOrigin loc)
                 , ppr ct_tvs
                 , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)
-                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ] ]
+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]
+                , pprWithCommas id
+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]
 
        ; (tidy_env', docs, discards)
               <- go env1 ct_tvs (maxRelevantBinds dflags)
@@ -2204,34 +2213,49 @@ relevantBindings want_filtering ctxt ct
        -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out
                                         -- because of lack of fuel
     go tidy_env _ _ _ docs discards []
-       = return (tidy_env, reverse docs, discards)
-    go tidy_env ct_tvs n_left tvs_seen docs discards (TcIdBndr id top_lvl : tc_bndrs)
-       = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env (idType id)
-            ; traceTc "relevantBindings 1" (ppr id <+> dcolon <+> ppr tidy_ty)
-            ; let id_tvs = tyCoVarsOfType tidy_ty
-                  doc = sep [ pprPrefixOcc id <+> dcolon <+> ppr tidy_ty
-                            , nest 2 (parens (text "bound at"
-                                 <+> ppr (getSrcLoc id)))]
-                  new_seen = tvs_seen `unionVarSet` id_tvs
-
-            ; if (want_filtering && not opt_PprStyle_Debug
-                                 && id_tvs `disjointVarSet` ct_tvs)
-                       -- We want to filter out this binding anyway
-                       -- so discard it silently
-              then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
-
-              else if isTopLevel top_lvl && not (isNothing n_left)
-                       -- It's a top-level binding and we have not specified
-                       -- -fno-max-relevant-bindings, so discard it silently
-              then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
-
-              else if run_out n_left && id_tvs `subVarSet` tvs_seen
-                       -- We've run out of n_left fuel and this binding only
-                       -- mentions aleady-seen type variables, so discard it
-              then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
-
-                       -- Keep this binding, decrement fuel
-              else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
+      = return (tidy_env, reverse docs, discards)
+    go tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)
+      = case tc_bndr of
+          TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl
+          TcIdBndr_ExpType name et top_lvl ->
+            do { mb_ty <- readExpType_maybe et
+                   -- et really should be filled in by now. But there's a chance
+                   -- it hasn't, if, say, we're reporting a kind error en route to
+                   -- checking a term. See test indexed-types/should_fail/T8129
+               ; ty <- case mb_ty of
+                   Just ty -> return ty
+                   Nothing -> do { traceTc "Defaulting an ExpType in relevantBindings"
+                                     (ppr et)
+                                 ; expTypeToType et }
+               ; go2 name ty top_lvl }
+      where
+        go2 id_name id_type top_lvl
+          = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type
+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)
+               ; let id_tvs = tyCoVarsOfType tidy_ty
+                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty
+                               , nest 2 (parens (text "bound at"
+                                    <+> ppr (getSrcLoc id_name)))]
+                     new_seen = tvs_seen `unionVarSet` id_tvs
+
+               ; if (want_filtering && not opt_PprStyle_Debug
+                                    && id_tvs `disjointVarSet` ct_tvs)
+                          -- We want to filter out this binding anyway
+                          -- so discard it silently
+                 then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
+
+                 else if isTopLevel top_lvl && not (isNothing n_left)
+                          -- It's a top-level binding and we have not specified
+                          -- -fno-max-relevant-bindings, so discard it silently
+                 then go tidy_env ct_tvs n_left tvs_seen docs discards tc_bndrs
+
+                 else if run_out n_left && id_tvs `subVarSet` tvs_seen
+                          -- We've run out of n_left fuel and this binding only
+                          -- mentions aleady-seen type variables, so discard it
+                 then go tidy_env ct_tvs n_left tvs_seen docs True tc_bndrs
+
+                          -- Keep this binding, decrement fuel
+                 else go tidy_env' ct_tvs (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
 
 discardMsg :: SDoc
 discardMsg = text "(Some bindings suppressed;" <+>
index 517e724..5dfc7ac 100644 (file)
@@ -9,7 +9,6 @@ module TcEvidence (
   (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
   mkWpLams, mkWpLet, mkWpCastN, mkWpCastR,
   mkWpFun, mkWpFuns, idHsWrapper, isIdHsWrapper, pprHsWrapper,
-  symWrapper_maybe,
 
   -- Evidence bindings
   TcEvBinds(..), EvBindsVar(..),
@@ -199,21 +198,25 @@ mkWpFun :: HsWrapper -> HsWrapper
         -> TcType    -- either type of the second wrapper (used only when the
                      -- second wrapper is the identity)
         -> HsWrapper
-        -- NB: These optimisations are important, because we need
-        -- symWrapper_maybe to work in TcUnify.matchExpectedFunTys
-        -- See that function for more info.
 mkWpFun WpHole       WpHole       _  _  = WpHole
 mkWpFun WpHole       (WpCast co2) t1 _  = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)
 mkWpFun (WpCast co1) WpHole       _  t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))
 mkWpFun (WpCast co1) (WpCast co2) _  _  = WpCast (mkTcFunCo Representational (mkTcSymCo co1) co2)
 mkWpFun co1          co2          t1 _  = WpFun co1 co2 t1
 
--- | @mkWpFuns arg_tys wrap@, where @wrap :: a "->" b@, gives a wrapper from
--- @arg_tys -> a@ to @arg_tys -> b@.
-mkWpFuns :: [TcType] -> HsWrapper -> HsWrapper
-mkWpFuns []                 res_wrap = res_wrap
-mkWpFuns (arg_ty : arg_tys) res_wrap
-  = WpFun idHsWrapper (mkWpFuns arg_tys res_wrap) arg_ty
+-- | @mkWpFuns [(ty1, wrap1), (ty2, wrap2)] ty_res wrap_res@,
+-- where @wrap1 :: ty1 "->" ty1'@ and @wrap2 :: ty2 "->" ty2'@,
+-- @wrap3 :: ty3 "->" ty3'@ and @ty_res@ is /either/ @ty3@ or @ty3'@,
+-- gives a wrapper @(ty1' -> ty2' -> ty3) "->" (ty1 -> ty2 -> ty3')@.
+-- Notice that the result wrapper goes the other way round to all
+-- the others. This is a result of sub-typing contravariance.
+mkWpFuns :: [(TcType, HsWrapper)] -> TcType -> HsWrapper -> HsWrapper
+mkWpFuns args res_ty res_wrap = snd $ go args res_ty res_wrap
+  where
+    go [] res_ty res_wrap = (res_ty, res_wrap)
+    go ((arg_ty, arg_wrap) : args) res_ty res_wrap
+      = let (tail_ty, tail_wrap) = go args res_ty res_wrap in
+        (arg_ty `mkFunTy` tail_ty, mkWpFun arg_wrap tail_wrap arg_ty tail_ty)
 
 mkWpCastR :: TcCoercionR -> HsWrapper
 mkWpCastR co
@@ -228,21 +231,6 @@ mkWpCastN co
                     WpCast (mkTcSubCo co)
     -- The mkTcSubCo converts Nominal to Representational
 
--- | In a few limited cases, it is possible to reverse the direction
--- of an HsWrapper. This tries to do so.
-symWrapper_maybe :: HsWrapper -> Maybe HsWrapper
-symWrapper_maybe = go
-  where
-    go WpHole              = return WpHole
-    go (WpCompose wp1 wp2) = WpCompose <$> go wp2 <*> go wp1
-    go (WpFun {})          = Nothing
-    go (WpCast co)         = return (WpCast (mkTcSymCo co))
-    go (WpEvLam {})        = Nothing
-    go (WpEvApp {})        = Nothing
-    go (WpTyLam {})        = Nothing
-    go (WpTyApp {})        = Nothing
-    go (WpLet {})          = Nothing
-
 mkWpTyApps :: [Type] -> HsWrapper
 mkWpTyApps tys = mk_co_app_fn WpTyApp tys
 
index ad49631..8d7ac41 100644 (file)
@@ -8,9 +8,10 @@
 
 {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
 
-module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
+module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,
                 tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,
-                tcSyntaxOp, tcCheckId,
+                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
+                tcCheckId,
                 addExprErrCtxt,
                 getFixedTyVars ) where
 
@@ -83,23 +84,28 @@ import qualified Data.Set as Set
 -}
 
 tcPolyExpr, tcPolyExprNC
-         :: LHsExpr Name        -- Expression to type check
-         -> TcSigmaType         -- Expected type (could be a polytype)
-         -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
+  :: LHsExpr Name        -- Expression to type check
+  -> TcSigmaType         -- Expected type (could be a polytype)
+  -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
 
 -- tcPolyExpr is a convenient place (frequent but not too frequent)
 -- place to add context information.
 -- The NC version does not do so, usually because the caller wants
 -- to do so himself.
 
-tcPolyExpr expr res_ty
+tcPolyExpr   expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)
+tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)
+
+-- these versions take an ExpType
+tc_poly_expr, tc_poly_expr_nc :: LHsExpr Name -> ExpSigmaType -> TcM (LHsExpr TcId)
+tc_poly_expr expr res_ty
   = addExprErrCtxt expr $
-    do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
+    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }
 
-tcPolyExprNC (L loc expr) res_ty
-  = do { traceTc "tcPolyExprNC_O" (ppr res_ty)
+tc_poly_expr_nc (L loc expr) res_ty
+  = do { traceTc "tcPolyExprNC" (ppr res_ty)
        ; (wrap, expr')
-           <- tcSkolemise GenSigCtxt res_ty $ \ _ res_ty ->
+           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
               setSrcSpan loc $
                 -- NB: setSrcSpan *after* skolemising, so we get better
                 -- skolem locations
@@ -109,7 +115,7 @@ tcPolyExprNC (L loc expr) res_ty
 ---------------
 tcMonoExpr, tcMonoExprNC
     :: LHsExpr Name      -- Expression to type check
-    -> TcRhoType         -- Expected type (could be a type variable)
+    -> ExpRhoType        -- Expected type
                          -- Definitely no foralls at the top
     -> TcM (LHsExpr TcId)
 
@@ -118,8 +124,7 @@ tcMonoExpr expr res_ty
     tcMonoExprNC expr res_ty
 
 tcMonoExprNC (L loc expr) res_ty
-  = ASSERT( not (isSigmaTy res_ty) )
-    setSrcSpan loc $
+  = setSrcSpan loc $
     do  { expr' <- tcExpr expr res_ty
         ; return (L loc expr') }
 
@@ -154,7 +159,7 @@ tcInferRhoNC expr
 NB: The res_ty is always deeply skolemised.
 -}
 
-tcExpr :: HsExpr Name -> TcRhoType -> TcM (HsExpr TcId)
+tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId)
 tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty
 tcExpr (HsUnboundVar v)   res_ty = tcUnboundId v res_ty
 
@@ -181,15 +186,14 @@ tcExpr (HsCoreAnn src lbl expr) res_ty
         ; return (HsCoreAnn src lbl expr') }
 
 tcExpr (HsOverLit lit) res_ty
-  = do  { (_wrap,  lit') <- newOverloadedLit lit res_ty
-                                            (Shouldn'tHappenOrigin "HsOverLit")
-        ; MASSERT( isIdHsWrapper _wrap )
+  = do  { lit' <- newOverloadedLit lit res_ty
         ; return (HsOverLit lit') }
 
 tcExpr (NegApp expr neg_expr) res_ty
-  = do  { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
-                                  (mkFunTy res_ty res_ty)
-        ; expr' <- tcMonoExpr expr res_ty
+  = do  { (expr', neg_expr')
+            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
+               \[arg_ty] ->
+               tcMonoExpr expr (mkCheckExpType arg_ty)
         ; return (NegApp expr' neg_expr') }
 
 tcExpr e@(HsIPVar x) res_ty
@@ -330,9 +334,11 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
   | (L loc (HsVar (L lv op_name))) <- op
   , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]
   = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
-       ; let arg2_ty = res_ty
-       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
-       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
+       ; let arg2_exp_ty = res_ty
+       ; arg1' <- tcArg op arg1 arg1_ty 1
+       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $
+                  tc_poly_expr_nc arg2 arg2_exp_ty
+       ; arg2_ty <- readExpType arg2_exp_ty
        ; op_id <- tcLookupId op_name
        ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty])
                                  (HsVar (L lv op_id)))
@@ -346,50 +352,46 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
        ; let doc   = text "The first argument of ($) takes"
              orig1 = exprCtOrigin (unLoc arg1)
        ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
-           matchActualFunTys doc orig1 1 arg1_ty
+           matchActualFunTys doc orig1 (Just arg1) 1 arg1_ty
 
          -- We have (arg1 $ arg2)
          -- 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 (v:Levity) (a:*) (b:TYPE v). (a->b) -> a -> b
        -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
        --    (which gives a seg fault)
-       -- We do this by unifying with a MetaTv; but of course
-       -- it must allow foralls in the type it unifies with (hence ReturnTv)!
        --
        -- The *result* type can have any kind (Trac #8739),
        -- so we don't need to check anything for that
-       ; a2_tv <- newReturnTyVar liftedTypeKind
-       ; let a2_ty = mkTyVarTy a2_tv
-       ; co_a <- unifyType (Just arg2) arg2_sigma a2_ty    -- arg2_sigma ~N a2_ty
+       ; _ <- unifyKind (Just arg2_sigma) (typeKind arg2_sigma) liftedTypeKind
+           -- ignore the evidence. arg2_sigma must have type * or #,
+           -- because we know arg2_sigma -> or_res_ty is well-kinded
+           -- (because otherwise matchActualFunTys would fail)
+           -- There's no possibility here of, say, a kind family reducing to *.
 
        ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty
                        -- op_res -> res
 
        ; op_id  <- tcLookupId op_name
+       ; res_ty <- readExpType res_ty
        ; let op' = L loc (HsWrap (mkWpTyApps [ getLevity "tcExpr ($)" res_ty
-                                             , a2_ty
+                                             , arg2_sigma
                                              , res_ty])
                                  (HsVar (L lv op_id)))
              -- arg1' :: arg1_ty
              -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
              -- wrap_res :: op_res_ty "->" res_ty
-             -- co_a :: arg2_sigma ~N a2_ty
              -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
 
-             -- wrap1 :: arg1_ty "->" (a2_ty -> res_ty)
-             wrap1 = mkWpFun (mkWpCastN (mkTcSymCo co_a))
-                       wrap_res a2_ty res_ty <.> wrap_arg1
+             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
+             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
+                     <.> wrap_arg1
 
-             -- 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 arg2') }
 
   | (L loc (HsRecFld (Ambiguous lbl _))) <- op
   , Just sig_ty <- obviousSig (unLoc arg1)
@@ -413,10 +415,10 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty
 tcExpr expr@(SectionR op arg2) res_ty
   = do { (op', op_ty) <- tcInferFun op
        ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
-           matchActualFunTys (mk_op_msg op) SectionOrigin 2 op_ty
+           matchActualFunTys (mk_op_msg op) SectionOrigin (Just op) 2 op_ty
        ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                  (mkFunTy arg1_ty op_res_ty) res_ty
-       ; arg2' <- tcArg op (arg2, arg2_ty, 2)
+       ; arg2' <- tcArg op arg2 arg2_ty 2
        ; return ( mkHsWrap wrap_res $
                   SectionR (mkLHsWrap wrap_fun op') arg2' ) }
 
@@ -427,10 +429,11 @@ tcExpr expr@(SectionL arg1 op) res_ty
                          | otherwise                            = 2
 
        ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
-           <- matchActualFunTys (mk_op_msg op) SectionOrigin n_reqd_args op_ty
+           <- matchActualFunTys (mk_op_msg op) SectionOrigin (Just op)
+                                n_reqd_args op_ty
        ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)
                                  (mkFunTys arg_tys op_res_ty) res_ty
-       ; arg1' <- tcArg op (arg1, arg1_ty, 1)
+       ; arg1' <- tcArg op arg1 arg1_ty 1
        ; return ( mkHsWrap wrap_res $
                   SectionL arg1' (mkLHsWrap wrap_fn op') ) }
 
@@ -438,6 +441,7 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
   | all tupArgPresent tup_args
   = do { let arity  = length tup_args
              tup_tc = tupleTyCon boxity arity
+       ; res_ty <- expTypeToType res_ty
        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
                            -- Unboxed tuples have levity vars, which we
                            -- don't care about here
@@ -469,21 +473,26 @@ tcExpr expr@(ExplicitTuple tup_args boxity) res_ty
 
 tcExpr (ExplicitList _ witness exprs) res_ty
   = case witness of
-      Nothing   -> do  { (coi, elt_ty) <- matchExpectedListTy res_ty
+      Nothing   -> do  { res_ty <- expTypeToType res_ty
+                       ; (coi, elt_ty) <- matchExpectedListTy res_ty
                        ; exprs' <- mapM (tc_elt elt_ty) exprs
                        ; return $
                          mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }
 
-      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' }
+      Just fln -> do { ((exprs', elt_ty), fln')
+                         <- tcSyntaxOp ListOrigin fln
+                                       [synKnownType intTy, SynList] res_ty $
+                            \ [elt_ty] ->
+                            do { exprs' <-
+                                    mapM (tc_elt elt_ty) exprs
+                               ; return (exprs', elt_ty) }
+
+                     ; return $ 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
+  = do  { res_ty <- expTypeToType res_ty
+        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
         ; exprs' <- mapM (tc_elt elt_ty) exprs
         ; return $
           mkHsWrapCo coi $ ExplicitPArr elt_ty exprs' }
@@ -503,7 +512,7 @@ tcExpr (HsLet (L l binds) expr) res_ty
                              tcMonoExpr expr res_ty
         ; return (HsLet (L l binds') expr') }
 
-tcExpr (HsCase scrut matches) exp_ty
+tcExpr (HsCase scrut matches) res_ty
   = do  {  -- We used to typecheck the case alternatives first.
            -- The case patterns tend to give good type info to use
            -- when typechecking the scrutinee.  For example
@@ -516,32 +525,39 @@ tcExpr (HsCase scrut matches) exp_ty
           (scrut', scrut_ty) <- tcInferRho scrut
 
         ; traceTc "HsCase" (ppr scrut_ty)
-        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
+        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
         ; return (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
+  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)
             -- this forces the branches to be fully instantiated
             -- (See #10619)
-       ; res_ty <- tauTvForReturnTv res_ty
+       ; res_ty <- mkCheckExpType <$> expTypeToType res_ty
        ; b1' <- tcMonoExpr b1 res_ty
        ; b2' <- tcMonoExpr b2 res_ty
        ; return (HsIf Nothing pred' b1' b2') }
 
 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
-  -- Note [Rebindable syntax for if]
-  = do { (wrap, fun', [pred', b1', b2'])
-           <- tcApp (Just herald) (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"
+  = do { ((pred', b1', b2'), fun')
+           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $
+              \ [pred_ty, b1_ty, b2_ty] ->
+              do { pred' <- tcPolyExpr pred pred_ty
+                 ; b1'   <- tcPolyExpr b1   b1_ty
+                 ; b2'   <- tcPolyExpr b2   b2_ty
+                 ; return (pred', b1', b2') }
+       ; return (HsIf (Just fun') pred' b1' b2') }
 
 tcExpr (HsMultiIf _ alts) res_ty
-  = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+  = do { res_ty <- if isSingleton alts
+                   then return res_ty
+                   else mkCheckExpType <$> expTypeToType res_ty
+        -- Just like Note [Case branches must never infer a non-tau type]
+        -- in TcMatches
+       ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
+       ; res_ty <- readExpType res_ty
        ; return (HsMultiIf res_ty alts') }
   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
 
@@ -555,6 +571,7 @@ tcExpr (HsProc pat cmd) res_ty
 
 tcExpr (HsStatic expr) res_ty
   = do  { staticPtrTyCon  <- tcLookupTyCon staticPtrTyConName
+        ; res_ty          <- expTypeToType res_ty
         ; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
         ; (expr', lie)    <- captureConstraints $
             addErrCtxt (hang (text "In the body of a static form:")
@@ -576,23 +593,6 @@ tcExpr (HsStatic expr) res_ty
         }
 
 {-
-Note [Rebindable syntax for if]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The rebindable syntax for 'if' uses the most flexible possible type
-for conditionals:
-  ifThenElse :: p -> b1 -> b2 -> res
-to support expressions like this:
-
- ifThenElse :: Maybe a -> (a -> b) -> b -> b
- ifThenElse (Just a) f _ = f a
- ifThenElse Nothing  _ e = e
-
- example :: String
- example = if Just 2
-              then \v -> show v
-              else "No value"
-
-
 ************************************************************************
 *                                                                      *
                 Record construction and update
@@ -930,7 +930,8 @@ tcExpr (ArithSeq _ witness seq) res_ty
   = tcArithSeq witness seq res_ty
 
 tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
-  = do  { (coi, elt_ty) <- matchExpectedPArrTy res_ty
+  = do  { res_ty <- expTypeToType res_ty
+        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
         ; expr1' <- tcPolyExpr expr1 elt_ty
         ; expr2' <- tcPolyExpr expr2 elt_ty
         ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
@@ -940,7 +941,8 @@ tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
           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
+  = do  { res_ty <- expTypeToType res_ty
+        ; (coi, elt_ty) <- matchExpectedPArrTy res_ty
         ; expr1' <- tcPolyExpr expr1 elt_ty
         ; expr2' <- tcPolyExpr expr2 elt_ty
         ; expr3' <- tcPolyExpr expr3 elt_ty
@@ -991,52 +993,57 @@ tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 ************************************************************************
 -}
 
-tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
+tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> ExpRhoType
            -> TcM (HsExpr TcId)
 
 tcArithSeq witness seq@(From expr) res_ty
-  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
        ; expr' <- tcPolyExpr expr elt_ty
        ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
                               enumFromName elt_ty
-       ; return $ mkHsWrapCo coi (ArithSeq enum_from wit' (From expr')) }
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from wit' (From expr') }
 
 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
-  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
                               enumFromThenName elt_ty
-       ; return $ mkHsWrapCo coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
 
 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
-  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
        ; expr1' <- tcPolyExpr expr1 elt_ty
        ; expr2' <- tcPolyExpr expr2 elt_ty
        ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
                               enumFromToName elt_ty
-       ; return $ mkHsWrapCo coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }
+       ; return $ mkHsWrap wrap $
+         ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
 
 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
-  = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty
         ; expr1' <- tcPolyExpr expr1 elt_ty
         ; expr2' <- tcPolyExpr expr2 elt_ty
         ; expr3' <- tcPolyExpr expr3 elt_ty
         ; eft <- newMethodFromName (ArithSeqOrigin seq)
                               enumFromThenToName elt_ty
-        ; return $ mkHsWrapCo coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
+        ; return $ mkHsWrap wrap $
+          ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
 
 -----------------
-arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
-                -> TcM (TcCoercionN, TcType, Maybe (SyntaxExpr Id))
+arithSeqEltType :: Maybe (SyntaxExpr Name) -> ExpRhoType
+                -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id))
 arithSeqEltType Nothing res_ty
-  = do { (coi, elt_ty) <- matchExpectedListTy res_ty
-       ; return (coi, elt_ty, Nothing) }
+  = do { res_ty <- expTypeToType res_ty
+       ; (coi, elt_ty) <- matchExpectedListTy res_ty
+       ; return (mkWpCastN coi, elt_ty, Nothing) }
 arithSeqEltType (Just fl) res_ty
-  = do { list_ty <- newFlexiTyVarTy liftedTypeKind
-       ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
-       ; (coi, elt_ty) <- matchExpectedListTy list_ty
-       ; return (coi, elt_ty, Just fl') }
+  = do { (elt_ty, fl')
+           <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
+              \ [elt_ty] -> return elt_ty
+       ; return (idHsWrapper, elt_ty, Just fl') }
 
 {-
 ************************************************************************
@@ -1049,7 +1056,7 @@ arithSeqEltType (Just fl) res_ty
 tcApp :: Maybe SDoc  -- like "The function `f' is applied to"
                      -- or leave out to get exactly that message
       -> LHsExpr Name -> [LHsExpr Name] -- Function and args
-      -> TcRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
            -- (wrap, fun, args). For an ordinary function application,
            -- these should be assembled as (wrap (fun args)).
            -- But OpApp is slightly different, so that's why the caller
@@ -1165,10 +1172,10 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
 
       | otherwise   -- not a type application.
       = do { (wrap, [arg_ty], res_ty)
-               <- matchActualFunTysPart herald fun_orig 1 fun_ty
+               <- matchActualFunTysPart herald fun_orig (Just fun) 1 fun_ty
                                         acc_args orig_arity
                -- wrap :: fun_ty "->" arg_ty -> res_ty
-           ; arg' <- tcArg fun (arg, arg_ty, n)
+           ; arg' <- tcArg fun arg arg_ty n
            ; (inner_wrap, args', inner_res_ty)
                <- go (arg_ty : acc_args) (n+1) res_ty args
                -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
@@ -1183,11 +1190,13 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
                text "to a visible type argument" <+> quotes (ppr arg) }
 
 ----------------
-tcArg :: LHsExpr Name                           -- The function (for error messages)
-       -> (LHsExpr Name, TcSigmaType, Int)      -- Actual argument and expected arg type
-       -> TcM (LHsExpr TcId)                    -- Resulting argument
-tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
-                                         (tcPolyExprNC arg ty)
+tcArg :: LHsExpr Name                    -- The function (for error messages)
+      -> LHsExpr Name                    -- Actual arguments
+      -> TcRhoType                       -- expected arg type
+      -> Int                             -- # of arugment
+      -> TcM (LHsExpr TcId)             -- Resulting argument
+tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $
+                          tcPolyExprNC arg ty
 
 ----------------
 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
@@ -1199,15 +1208,172 @@ tcTupArgs args tys
                                          ; return (L l (Present expr')) }
 
 ---------------------------
-tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
--- Typecheck a syntax operator, checking that it has the specified type
+-- See TcType.SyntaxOpType also for commentary
+tcSyntaxOp :: CtOrigin
+           -> SyntaxExpr Name
+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
+           -> ExpType                  -- ^ overall result type
+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
+           -> TcM (a, SyntaxExpr TcId)
+-- ^ Typecheck a syntax operator
 -- The operator is always a variable at this stage (i.e. renamer output)
--- This version assumes res_ty is a monotype
-tcSyntaxOp orig (HsVar (L _ op)) res_ty
-  = do { (expr, rho) <- tcInferId op
-       ; tcWrapResultO orig expr rho res_ty }
+tcSyntaxOp orig expr arg_tys res_ty
+  = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
+
+-- | Slightly more general version of 'tcSyntaxOp' that allows the caller
+-- to specify the shape of the result of the syntax operator
+tcSyntaxOpGen :: CtOrigin
+              -> SyntaxExpr Name
+              -> [SyntaxOpType]
+              -> SyntaxOpType
+              -> ([TcSigmaType] -> TcM a)
+              -> TcM (a, SyntaxExpr TcId)
+tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) })
+              arg_tys res_ty thing_inside
+  = do { (expr, sigma) <- tcInferId op
+       ; (result, expr_wrap, arg_wraps, res_wrap)
+           <- tcSynArgA orig sigma arg_tys res_ty $
+              thing_inside
+       ; return (result, SyntaxExpr { syn_expr      = mkHsWrap expr_wrap expr
+                                    , syn_arg_wraps = arg_wraps
+                                    , syn_res_wrap  = res_wrap }) }
+
+tcSyntaxOpGen _ other _ _ _ = pprPanic "tcSyntaxOp" (ppr other)
 
-tcSyntaxOp _ other         _      = pprPanic "tcSyntaxOp" (ppr other)
+{-
+Note [tcSynArg]
+~~~~~~~~~~~~~~~
+Because of the rich structure of SyntaxOpType, we must do the
+contra-/covariant thing when working down arrows, to get the
+instantiation vs. skolemisation decisions correct (and, more
+obviously, the orientation of the HsWrappers). We thus have
+two tcSynArgs.
+-}
+
+-- works on "expected" types, skolemising where necessary
+-- See Note [tcSynArg]
+tcSynArgE :: CtOrigin
+          -> TcSigmaType
+          -> SyntaxOpType                -- ^ shape it is expected to have
+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments
+          -> TcM (a, HsWrapper)
+           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
+tcSynArgE orig sigma_ty syn_ty thing_inside
+  = do { (skol_wrap, (result, ty_wrapper))
+           <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->
+              go rho_ty syn_ty
+       ; return (result, skol_wrap <.> ty_wrapper) }
+    where
+    go rho_ty SynAny
+      = do { result <- thing_inside [rho_ty]
+           ; return (result, idHsWrapper) }
+
+    go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly
+      = do { result <- thing_inside [rho_ty]
+           ; return (result, idHsWrapper) }
+
+    go rho_ty SynList
+      = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
+           ; result <- thing_inside [elt_ty]
+           ; return (result, mkWpCastN list_co) }
+
+    go rho_ty (SynFun arg_shape res_shape)
+      = do { ( ( ( (result, arg_ty, res_ty)
+                 , res_wrapper )                   -- :: res_ty_out "->" res_ty
+               , arg_wrapper1, [], arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out
+             , match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty
+               <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $
+                  \ [arg_ty] res_ty ->
+                  do { arg_tc_ty <- expTypeToType arg_ty
+                     ; res_tc_ty <- expTypeToType res_ty
+
+                         -- another nested arrow is too much for now,
+                         -- but I bet we'll never need this
+                     ; MASSERT2( case arg_shape of
+                                   SynFun {} -> False;
+                                   _         -> True
+                               , text "Too many nested arrows in SyntaxOpType" $$
+                                 pprCtOrigin orig )
+
+                     ; tcSynArgA orig arg_tc_ty [] arg_shape $
+                       \ arg_results ->
+                       tcSynArgE orig res_tc_ty res_shape $
+                       \ res_results ->
+                       do { result <- thing_inside (arg_results ++ res_results)
+                          ; return (result, arg_tc_ty, res_tc_ty) }}
+
+           ; return ( result
+                    , match_wrapper <.>
+                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
+                              arg_ty res_ty ) }
+      where
+        herald = text "This rebindable syntax expects a function with"
+
+    go rho_ty (SynType the_ty)
+      = do { wrap   <- tcSubTypeET orig the_ty rho_ty
+           ; result <- thing_inside []
+           ; return (result, wrap) }
+
+-- works on "actual" types, instantiating where necessary
+-- See Note [tcSynArg]
+tcSynArgA :: CtOrigin
+          -> TcSigmaType
+          -> [SyntaxOpType]              -- ^ argument shapes
+          -> SyntaxOpType                -- ^ result shape
+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments
+          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
+            -- ^ returns a wrapper to be applied to the original function,
+            -- wrappers to be applied to arguments
+            -- and a wrapper to be applied to the overall expression
+tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
+  = do { (match_wrapper, arg_tys, res_ty)
+           <- matchActualFunTys herald orig noThing (length arg_shapes) sigma_ty
+              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
+       ; ((result, res_wrapper), arg_wrappers)
+           <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->
+              tc_syn_arg    res_ty  res_shape  $ \ res_results ->
+              thing_inside (arg_results ++ res_results)
+       ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
+  where
+    herald = text "This rebindable syntax expects a function with"
+
+    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
+                  -> ([TcSigmaType] -> TcM a)
+                  -> TcM (a, [HsWrapper])
+                    -- the wrappers are for arguments
+    tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
+      = do { ((result, arg_wraps), arg_wrap)
+               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results ->
+                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results ->
+                  thing_inside (arg1_results ++ args_results)
+           ; return (result, arg_wrap : arg_wraps) }
+    tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []
+
+    tc_syn_arg :: TcSigmaType -> SyntaxOpType
+               -> ([TcSigmaType] -> TcM a)
+               -> TcM (a, HsWrapper)
+                  -- the wrapper applies to the overall result
+    tc_syn_arg res_ty SynAny thing_inside
+      = do { result <- thing_inside [res_ty]
+           ; return (result, idHsWrapper) }
+    tc_syn_arg res_ty SynRho thing_inside
+      = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty
+               -- inst_wrap :: res_ty "->" rho_ty
+           ; result <- thing_inside [rho_ty]
+           ; return (result, inst_wrap) }
+    tc_syn_arg res_ty SynList thing_inside
+      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
+               -- inst_wrap :: res_ty "->" rho_ty
+           ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
+               -- list_co :: [elt_ty] ~N rho_ty
+           ; result <- thing_inside [elt_ty]
+           ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
+    tc_syn_arg _ (SynFun {}) _
+      = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
+    tc_syn_arg res_ty (SynType the_ty) thing_inside
+      = do { wrap   <- tcSubTypeO orig GenSigCtxt res_ty the_ty
+           ; result <- thing_inside []
+           ; return (result, wrap) }
 
 {-
 Note [Push result type in]
@@ -1280,7 +1446,8 @@ tcExprSig expr sig@(TISI { sig_bndr  = s_bndr
                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer
                                           -- an ambiguouse type and have AllowAmbiguousType
                                           -- e..g infer  x :: forall a. F a -> Int
-                 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma
+                 else tcSubType_NC ExprSigCtxt inferred_sigma
+                                   (mkCheckExpType my_sigma)
 
        ; let poly_wrap = wrap
                          <.> mkWpTyLams qtvs
@@ -1290,7 +1457,7 @@ tcExprSig expr sig@(TISI { sig_bndr  = s_bndr
 
   | otherwise = panic "tcExprSig"   -- Can't happen
   where
-    skol_info = SigSkol ExprSigCtxt (mkPhiTy theta tau)
+    skol_info = SigSkol ExprSigCtxt (mkCheckExpType $ mkPhiTy theta tau)
     skol_tvs = map snd skol_prs
 
 {- *********************************************************************
@@ -1299,20 +1466,20 @@ tcExprSig expr sig@(TISI { sig_bndr  = s_bndr
 *                                                                      *
 ********************************************************************* -}
 
-tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
 tcCheckId name res_ty
   = do { (expr, actual_res_ty) <- tcInferId name
        ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
        ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $
          tcWrapResultO (OccurrenceOf name)  expr actual_res_ty res_ty }
 
-tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId)
 tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty
   = do { (expr, actual_res_ty) <- tcInferRecSelId f
        ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $
          tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty }
 tcCheckRecSelId (Ambiguous lbl _) res_ty
-  = case tcSplitFunTy_maybe res_ty of
+  = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of
       Nothing       -> ambiguousSelector lbl
       Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
                           ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
@@ -1404,7 +1571,7 @@ tc_infer_id lbl id_name
       | otherwise                  = return ()
 
 
-tcUnboundId :: OccName -> TcRhoType -> TcM (HsExpr TcId)
+tcUnboundId :: OccName -> ExpRhoType -> TcM (HsExpr TcId)
 -- Typechedk an occurrence of an unbound Id
 --
 -- Some of these started life as a true hole "_".  Others might simply
@@ -1478,7 +1645,7 @@ the users that complain.
 -}
 
 tcSeq :: SrcSpan -> Name -> [LHsExpr Name]
-      -> TcRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
 -- (seq e1 e2) :: res_ty
 -- We need a special typing rule because res_ty can be unboxed
 -- See Note [Typing rule for seq]
@@ -1493,21 +1660,20 @@ tcSeq loc fun_name args res_ty
             _ -> do { arg_ty1 <- newFlexiTyVarTy liftedTypeKind
                     ; return (arg_ty1, args) }
 
-        ; (arg1, arg2) <- case args1 of
+        ; (arg1, arg2, arg2_exp_ty) <- case args1 of
             [ty_arg_expr2, term_arg1, term_arg2]
               | Just hs_ty_arg2 <- isLHsTypeExpr_maybe ty_arg_expr2
               -> do { lev_ty <- newFlexiTyVarTy levityTy
                     ; ty_arg2 <- tcHsTypeApp hs_ty_arg2 (tYPE lev_ty)
                                    -- see Note [Typing rule for seq]
-                    ; _ <- unifyType noThing ty_arg2 res_ty
-                    ; return (term_arg1, term_arg2) }
-            [term_arg1, term_arg2] -> return (term_arg1, term_arg2)
+                    ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg2 res_ty
+                    ; return (term_arg1, term_arg2, mkCheckExpType ty_arg2) }
+            [term_arg1, term_arg2] -> return (term_arg1, term_arg2, res_ty)
             _ -> too_many_args
 
-        ; arg1' <- tcMonoExpr arg1 arg1_ty
-        ; res_ty <- zonkTcType res_ty   -- just in case we learned something
-                                        -- interesting about it
-        ; arg2' <- tcMonoExpr arg2 res_ty
+        ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty)
+        ; arg2' <- tcMonoExpr arg2 arg2_exp_ty
+        ; res_ty <- readExpType res_ty  -- by now, it's surely filled in
         ; let fun'    = L loc (HsWrap ty_args (HsVar (L loc fun)))
               ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
         ; return (idHsWrapper, fun', [arg1', arg2']) }
@@ -1519,7 +1685,7 @@ tcSeq loc fun_name args res_ty
            2 (sep (map pprParendExpr args))
 
 
-tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> TcRhoType
+tcTagToEnum :: SrcSpan -> Name -> [LHsExpr Name] -> ExpRhoType
             -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
 -- tagToEnum# :: forall a. Int# -> a
 -- See Note [tagToEnum#]   Urgh!
@@ -1530,15 +1696,17 @@ tcTagToEnum loc fun_name args res_ty
            [ty_arg_expr, term_arg]
              | Just hs_ty_arg <- isLHsTypeExpr_maybe ty_arg_expr
              -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind
-                   ; _ <- unifyType noThing ty_arg res_ty
+                   ; _ <- tcSubTypeDS GenSigCtxt noThing ty_arg res_ty
                      -- other than influencing res_ty, we just
                      -- don't care about a type arg passed in.
                      -- So drop the evidence.
                    ; return term_arg }
-           [term_arg] -> return term_arg
+           [term_arg] -> do { _ <- expTypeToType res_ty
+                            ; return term_arg }
            _          -> too_many_args
 
-       ; ty' <- zonkTcType res_ty
+       ; res_ty <- readExpType res_ty
+       ; ty'    <- zonkTcType res_ty
 
        -- Check that the type is algebraic
        ; let mb_tc_app = tcSplitTyConApp_maybe ty'
@@ -1555,7 +1723,7 @@ tcTagToEnum loc fun_name args res_ty
        ; checkTc (isEnumerationTyCon rep_tc)
                  (mk_error ty' doc2)
 
-       ; arg' <- tcMonoExpr arg intPrimTy
+       ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)
        ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun)))
              rep_ty = mkTyConApp rep_tc rep_args
 
@@ -1819,7 +1987,7 @@ ambiguousSelector (L _ rdr)
 -- Disambiguate the fields in a record update.
 -- See Note [Disambiguating record fields]
 disambiguateRecordBinds :: LHsExpr Name -> TcRhoType
-                        -> [LHsRecUpdField Name] -> Type
+                        -> [LHsRecUpdField Name] -> ExpRhoType
                         -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
 disambiguateRecordBinds record_expr record_rho rbnds res_ty
     -- Are all the fields unambiguous?
@@ -1864,7 +2032,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
 
         -- Multiple possible parents: try harder to disambiguate
         -- Can we get a parent TyCon from the pushed-in type?
-        _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p)
+        _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)
 
         -- Does the expression being updated have a type signature?
         -- If so, try to extract a parent TyCon from it
@@ -1914,15 +2082,19 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty
 
 -- Extract the outermost TyCon of a type, if there is one; for
 -- data families this is the representation tycon (because that's
--- where the fields live).  Look inside sigma-types, so that
---   tyConOf _ (forall a. Q => T a) = T
-tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
-tyConOf fam_inst_envs ty0 = case tcSplitTyConApp_maybe ty of
-  Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
-  Nothing        -> Nothing
+-- where the fields live).
+tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
+tyConOf fam_inst_envs ty0
+  = case tcSplitTyConApp_maybe ty of
+      Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
+      Nothing        -> Nothing
   where
     (_, _, ty) = tcSplitSigmaTy ty0
 
+-- Variant of tyConOf that works for ExpTypes
+tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
+tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
+
 -- For an ambiguous record field, find all the candidate record
 -- selectors (as GlobalRdrElts) and their parents.
 lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
@@ -2098,7 +2270,7 @@ fieldCtxt field_name
   = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
 
 addFunResCtxt :: Bool  -- There is at least one argument
-              -> HsExpr Name -> TcType -> TcType
+              -> HsExpr Name -> TcType -> ExpRhoType
               -> TcM a -> TcM a
 -- When we have a mis-match in the return type of a function
 -- try to give a helpful message about too many/few arguments
@@ -2110,8 +2282,16 @@ addFunResCtxt has_args fun fun_res_ty env_ty
       -- doesn't suppress some more useful context
   where
     mk_msg
-      = do { fun_res' <- zonkTcType fun_res_ty
-           ; env'     <- zonkTcType env_ty
+      = do { mb_env_ty <- readExpType_maybe env_ty
+                     -- by the time the message is rendered, the ExpType
+                     -- will be filled in (except if we're debugging)
+           ; fun_res' <- zonkTcType fun_res_ty
+           ; env'     <- case mb_env_ty of
+                           Just env_ty -> zonkTcType env_ty
+                           Nothing     ->
+                             do { dumping <- doptM Opt_D_dump_tc_trace
+                                ; MASSERT( dumping )
+                                ; newFlexiTyVarTy liftedTypeKind }
            ; let (_, _, fun_tau) = tcSplitSigmaTy fun_res'
                  (_, _, env_tau) = tcSplitSigmaTy env'
                  (args_fun, res_fun) = tcSplitFunTys fun_tau
index 8d60ba4..78b8bc1 100644 (file)
@@ -1,7 +1,7 @@
 module TcExpr where
-import HsSyn    ( HsExpr, LHsExpr )
+import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )
 import Name     ( Name )
-import TcType   ( TcType, TcRhoType, TcSigmaType )
+import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )
 import TcRnTypes( TcM, TcId, CtOrigin )
 
 tcPolyExpr ::
@@ -11,7 +11,7 @@ tcPolyExpr ::
 
 tcMonoExpr, tcMonoExprNC ::
           LHsExpr Name
-       -> TcRhoType
+       -> ExpRhoType
        -> TcM (LHsExpr TcId)
 
 tcInferSigma, tcInferSigmaNC ::
@@ -23,8 +23,18 @@ tcInferRho ::
        -> TcM (LHsExpr TcId, TcRhoType)
 
 tcSyntaxOp :: CtOrigin
-           -> HsExpr Name
-           -> TcType
-           -> TcM (HsExpr TcId)
+           -> SyntaxExpr Name
+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
+           -> ExpType                  -- ^ overall result type
+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments
+           -> TcM (a, SyntaxExpr TcId)
 
-tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
+tcSyntaxOpGen :: CtOrigin
+              -> SyntaxExpr Name
+              -> [SyntaxOpType]
+              -> SyntaxOpType
+              -> ([TcSigmaType] -> TcM a)
+              -> TcM (a, SyntaxExpr TcId)
+
+
+tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId)
index caa327e..285a4db 100644 (file)
@@ -1322,7 +1322,7 @@ gen_Data_binds dflags loc rep_tc
            | otherwise = prefix_RDR
 
         ------------ gfoldl
-    gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
+    gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
 
     gfoldl_eqn con
       = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
@@ -1334,10 +1334,10 @@ gen_Data_binds dflags loc rep_tc
                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
 
         ------------ gunfold
-    gunfold_bind = mk_FunBind loc
-                              gunfold_RDR
-                              [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
-                                gunfold_rhs)]
+    gunfold_bind = mk_HRFunBind 2 loc
+                     gunfold_RDR
+                     [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
+                       gunfold_rhs)]
 
     gunfold_rhs
         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
@@ -2143,13 +2143,26 @@ mkParentType tc
 mk_FunBind :: SrcSpan -> RdrName
            -> [([LPat RdrName], LHsExpr RdrName)]
            -> LHsBind RdrName
-mk_FunBind loc fun pats_and_exprs
-  = mkRdrFunBind (L loc fun) matches
+mk_FunBind = mk_HRFunBind 0   -- by using mk_FunBind and not mk_HRFunBind,
+                              -- the caller says that the Void case needs no
+                              -- patterns
+
+-- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
+-- the "=" in the empty-data-decl case. This is necessary if the function
+-- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
+mk_HRFunBind :: Arity -> SrcSpan -> RdrName
+             -> [([LPat RdrName], LHsExpr RdrName)]
+             -> LHsBind RdrName
+mk_HRFunBind arity loc fun pats_and_exprs
+  = mkHRRdrFunBind arity (L loc fun) matches
   where
     matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
 
 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
-mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
+mkRdrFunBind = mkHRRdrFunBind 0
+
+mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
+mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
  where
    -- Catch-all eqn looks like
    --     fmap = error "Void fmap"
@@ -2157,7 +2170,8 @@ mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
    -- which can happen with -XEmptyDataDecls
    -- See Trac #4302
    matches' = if null matches
-              then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)]
+              then [mkMatch (replicate arity nlWildPat)
+                            (error_Expr str) (noLoc emptyLocalBinds)]
               else matches
    str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
 
index f055197..4289035 100644 (file)
@@ -60,6 +60,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Data.List  ( partition )
+import Control.Arrow ( second )
 
 {-
 ************************************************************************
@@ -91,8 +92,8 @@ hsPatType (TuplePat _ bx tys)         = mkTupleTy bx tys
 hsPatType (ConPatOut { pat_con = L _ con, pat_arg_tys = tys })
                                       = conLikeResTy con tys
 hsPatType (SigPatOut _ ty)            = ty
-hsPatType (NPat (L _ lit) _ _)        = overLitType lit
-hsPatType (NPlusKPat id _ _ _)        = idType (unLoc id)
+hsPatType (NPat _ _ _ ty)             = ty
+hsPatType (NPlusKPat _ _ _ _ _ ty)    = ty
 hsPatType (CoPat _ _ ty)              = ty
 hsPatType p                           = pprPanic "hsPatType" (ppr p)
 
@@ -613,8 +614,8 @@ zonkExpr env (OpApp e1 op fixity e2)
        return (OpApp new_e1 new_op fixity new_e2)
 
 zonkExpr env (NegApp expr op)
-  = do new_expr <- zonkLExpr env expr
-       new_op <- zonkExpr env op
+  = do (env', new_op) <- zonkSyntaxExpr env op
+       new_expr <- zonkLExpr env' expr
        return (NegApp new_expr new_op)
 
 zonkExpr env (HsPar e)
@@ -645,12 +646,18 @@ zonkExpr env (HsCase expr ms)
        new_ms <- zonkMatchGroup env zonkLExpr ms
        return (HsCase new_expr new_ms)
 
-zonkExpr env (HsIf e0 e1 e2 e3)
-  = do { new_e0 <- fmapMaybeM (zonkExpr env) e0
-       ; new_e1 <- zonkLExpr env e1
-       ; new_e2 <- zonkLExpr env e2
-       ; new_e3 <- zonkLExpr env e3
-       ; return (HsIf new_e0 new_e1 new_e2 new_e3) }
+zonkExpr env (HsIf Nothing e1 e2 e3)
+  = do new_e1 <- zonkLExpr env e1
+       new_e2 <- zonkLExpr env e2
+       new_e3 <- zonkLExpr env e3
+       return (HsIf Nothing new_e1 new_e2 new_e3)
+
+zonkExpr env (HsIf (Just fun) e1 e2 e3)
+  = do (env1, new_fun) <- zonkSyntaxExpr env fun
+       new_e1 <- zonkLExpr env1 e1
+       new_e2 <- zonkLExpr env1 e2
+       new_e3 <- zonkLExpr env1 e3
+       return (HsIf (Just new_fun) new_e1 new_e2 new_e3)
 
 zonkExpr env (HsMultiIf ty alts)
   = do { alts' <- mapM (wrapLocM zonk_alt) alts
@@ -672,13 +679,12 @@ zonkExpr env (HsDo do_or_lc (L l stmts) ty)
        return (HsDo do_or_lc (L l new_stmts) new_ty)
 
 zonkExpr env (ExplicitList ty wit exprs)
-  = do new_ty <- zonkTcTypeToType env ty
-       new_wit <- zonkWit env wit
-       new_exprs <- zonkLExprs env exprs
+  = do (env1, new_wit) <- zonkWit env wit
+       new_ty <- zonkTcTypeToType env1 ty
+       new_exprs <- zonkLExprs env1 exprs
        return (ExplicitList new_ty new_wit new_exprs)
-   where zonkWit _ Nothing = return Nothing
-         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
-                                     return (Just new_fln)
+   where zonkWit env Nothing    = return (env, Nothing)
+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
 
 zonkExpr env (ExplicitPArr ty exprs)
   = do new_ty <- zonkTcTypeToType env ty
@@ -708,13 +714,12 @@ zonkExpr env (ExprWithTySigOut e ty)
        ; return (ExprWithTySigOut e' ty) }
 
 zonkExpr env (ArithSeq expr wit info)
-  = do new_expr <- zonkExpr env expr
-       new_wit <- zonkWit env wit
-       new_info <- zonkArithSeq env info
+  = do (env1, new_wit) <- zonkWit env wit
+       new_expr <- zonkExpr env expr
+       new_info <- zonkArithSeq env1 info
        return (ArithSeq new_expr new_wit new_info)
-   where zonkWit _ Nothing = return Nothing
-         zonkWit env (Just fln) = do new_fln <- zonkExpr env fln
-                                     return (Just new_fln)
+   where zonkWit env Nothing    = return (env, Nothing)
+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln
 
 zonkExpr env (PArrSeq expr info)
   = do new_expr <- zonkExpr env expr
@@ -758,6 +763,40 @@ zonkExpr _ e@(HsTypeOut {}) = return e
 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
 -------------------------------------------------------------------------
+{-
+Note [Skolems in zonkSyntaxExpr]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider rebindable syntax with something like
+
+  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''
+
+The x and y become skolems that are in scope when type-checking the
+arguments to the bind. This means that we must extend the ZonkEnv with
+these skolems when zonking the arguments to the bind. But the skolems
+are different between the two arguments, and so we should theoretically
+carry around different environments to use for the different arguments.
+
+However, this becomes a logistical nightmare, especially in dealing with
+the more exotic Stmt forms. So, we simplify by making the critical
+assumption that the uniques of the skolems are different. (This assumption
+is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)
+Now, we can safely just extend one environment.
+-}
+
+-- See Note [Skolems in zonkSyntaxExpr]
+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr TcId
+               -> TcM (ZonkEnv, SyntaxExpr Id)
+zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr
+                               , syn_arg_wraps = arg_wraps
+                               , syn_res_wrap  = res_wrap })
+  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap
+       ; expr'              <- zonkExpr env0 expr
+       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps
+       ; return (env1, SyntaxExpr { syn_expr      = expr'
+                                  , syn_arg_wraps = arg_wraps'
+                                  , syn_res_wrap  = res_wrap' }) }
+
+-------------------------------------------------------------------------
 
 zonkLCmd  :: ZonkEnv -> LHsCmd TcId   -> TcM (LHsCmd Id)
 zonkCmd   :: ZonkEnv -> HsCmd TcId    -> TcM (HsCmd Id)
@@ -798,11 +837,14 @@ zonkCmd env (HsCmdCase expr ms)
        return (HsCmdCase new_expr new_ms)
 
 zonkCmd env (HsCmdIf eCond ePred cThen cElse)
-  = do { new_eCond <- fmapMaybeM (zonkExpr env) eCond
-       ; new_ePred <- zonkLExpr env ePred
-       ; new_cThen <- zonkLCmd env cThen
-       ; new_cElse <- zonkLCmd env cElse
+  = do { (env1, new_eCond) <- zonkWit env eCond
+       ; new_ePred <- zonkLExpr env1 ePred
+       ; new_cThen <- zonkLCmd env1 cThen
+       ; new_cElse <- zonkLCmd env1 cElse
        ; return (HsCmdIf new_eCond new_ePred new_cThen new_cElse) }
+  where
+    zonkWit env Nothing  = return (env, Nothing)
+    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w
 
 zonkCmd env (HsCmdLet (L l binds) cmd)
   = do (new_env, new_binds) <- zonkLocalBinds env binds
@@ -896,70 +938,81 @@ zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody
 zonkStmt :: ZonkEnv
          -> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
          -> Stmt TcId (Located (body TcId)) -> TcM (ZonkEnv, Stmt Id (Located (body Id)))
-zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op)
-  = do { new_stmts_w_bndrs <- mapM zonk_branch stmts_w_bndrs
+zonkStmt env _ (ParStmt stmts_w_bndrs mzip_op bind_op bind_ty)
+  = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op
+       ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
+       ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs
        ; let new_binders = [b | ParStmtBlock _ bs _ <- new_stmts_w_bndrs, b <- bs]
-             env1 = extendIdZonkEnvRec env new_binders
-       ; new_mzip <- zonkExpr env1 mzip_op
-       ; new_bind <- zonkExpr env1 bind_op
-       ; return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind) }
+             env2 = extendIdZonkEnvRec env1 new_binders
+       ; new_mzip <- zonkExpr env2 mzip_op
+       ; return (env2, ParStmt new_stmts_w_bndrs new_mzip new_bind_op new_bind_ty) }
   where
-    zonk_branch (ParStmtBlock stmts bndrs return_op)
-       = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
-            ; new_return <- zonkExpr env1 return_op
-            ; return (ParStmtBlock new_stmts (zonkIdOccs env1 bndrs) new_return) }
+    zonk_branch env1 (ParStmtBlock stmts bndrs return_op)
+       = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts
+            ; (env3, new_return) <- zonkSyntaxExpr env2 return_op
+            ; return (ParStmtBlock new_stmts (zonkIdOccs env3 bndrs) new_return) }
 
 zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs
-                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id
+                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id
+                            , recS_bind_fn = bind_id, recS_bind_ty = bind_ty
                             , recS_later_rets = later_rets, recS_rec_rets = rec_rets
                             , recS_ret_ty = ret_ty })
-  = do { new_rvs <- zonkIdBndrs env rvs
-       ; new_lvs <- zonkIdBndrs env lvs
-       ; new_ret_ty  <- zonkTcTypeToType env ret_ty
-       ; new_ret_id  <- zonkExpr env ret_id
-       ; new_mfix_id <- zonkExpr env mfix_id
-       ; new_bind_id <- zonkExpr env bind_id
-       ; let env1 = extendIdZonkEnvRec env new_rvs
-       ; (env2, new_segStmts) <- zonkStmts env1 zBody segStmts
+  = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id
+       ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id
+       ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id
+       ; new_bind_ty <- zonkTcTypeToType env3 bind_ty
+       ; new_rvs <- zonkIdBndrs env3 rvs
+       ; new_lvs <- zonkIdBndrs env3 lvs
+       ; new_ret_ty  <- zonkTcTypeToType env3 ret_ty
+       ; let env4 = extendIdZonkEnvRec env3 new_rvs
+       ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts
         -- Zonk the ret-expressions in an envt that
         -- has the polymorphic bindings in the envt
-       ; new_later_rets <- mapM (zonkExpr env2) later_rets
-       ; new_rec_rets <- mapM (zonkExpr env2) rec_rets
-       ; return (extendIdZonkEnvRec env new_lvs,     -- Only the lvs are needed
+       ; new_later_rets <- mapM (zonkExpr env5) later_rets
+       ; new_rec_rets <- mapM (zonkExpr env5) rec_rets
+       ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed
                  RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs
                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id
                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id
+                         , recS_bind_ty = new_bind_ty
                          , recS_later_rets = new_later_rets
                          , recS_rec_rets = new_rec_rets, recS_ret_ty = new_ret_ty }) }
 
 zonkStmt env zBody (BodyStmt body then_op guard_op ty)
-  = do new_body <- zBody env body
-       new_then <- zonkExpr env then_op
-       new_guard <- zonkExpr env guard_op
-       new_ty <- zonkTcTypeToType env ty
-       return (env, BodyStmt new_body new_then new_guard new_ty)
+  = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op
+       (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op
+       new_body <- zBody env2 body
+       new_ty   <- zonkTcTypeToType env2 ty
+       return (env2, BodyStmt new_body new_then_op new_guard_op new_ty)
 
 zonkStmt env zBody (LastStmt body noret ret_op)
-  = do new_body <- zBody env body
-       new_ret <- zonkExpr env ret_op
+  = do (env1, new_ret) <- zonkSyntaxExpr env ret_op
+       new_body <- zBody env1 body
        return (env, LastStmt new_body noret new_ret)
 
 zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap
-                              , trS_by = by, trS_form = form, trS_using = using
-                              , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op })
-  = do { (env', stmts') <- zonkStmts env zonkLExpr stmts
-    ; binderMap' <- mapM (zonkBinderMapEntry env') binderMap
-    ; by'        <- fmapMaybeM (zonkLExpr env') by
-    ; using'     <- zonkLExpr env using
-    ; return_op' <- zonkExpr env' return_op
-    ; bind_op'   <- zonkExpr env' bind_op
-    ; liftM_op'  <- zonkExpr env' liftM_op
-    ; let env'' = extendIdZonkEnvRec env' (map snd binderMap')
-    ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
+                          , trS_by = by, trS_form = form, trS_using = using
+                          , trS_ret = return_op, trS_bind = bind_op
+                          , trS_bind_arg_ty = bind_arg_ty
+                          , trS_fmap = liftM_op })
+  = do {
+    ; (env1, bind_op') <- zonkSyntaxExpr env bind_op
+    ; bind_arg_ty' <- zonkTcTypeToType env1 bind_arg_ty
+    ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts
+    ; by'        <- fmapMaybeM (zonkLExpr env2) by
+    ; using'     <- zonkLExpr env2 using
+
+    ; (env3, return_op') <- zonkSyntaxExpr env2 return_op
+    ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap
+    ; liftM_op'  <- zonkExpr env3 liftM_op
+    ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')
+    ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'
                                , trS_by = by', trS_form = form, trS_using = using'
-                               , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) }
+                               , trS_ret = return_op', trS_bind = bind_op'
+                               , trS_bind_arg_ty = bind_arg_ty'
+                               , trS_fmap = liftM_op' }) }
   where
-    zonkBinderMapEntry env (oldBinder, newBinder) = do
+    zonkBinderMapEntry env  (oldBinder, newBinder) = do
         let oldBinder' = zonkIdOcc env oldBinder
         newBinder' <- zonkIdBndr env newBinder
         return (oldBinder', newBinder')
@@ -968,35 +1021,55 @@ zonkStmt env _ (LetStmt (L l binds))
   = do (env1, new_binds) <- zonkLocalBinds env binds
        return (env1, LetStmt (L l new_binds))
 
-zonkStmt env zBody (BindStmt pat body bind_op fail_op)
-  = do  { new_body <- zBody env body
-        ; (env1, new_pat) <- zonkPat env pat
-        ; new_bind <- zonkExpr env bind_op
-        ; new_fail <- zonkExpr env fail_op
-        ; return (env1, BindStmt new_pat new_body new_bind new_fail) }
+zonkStmt env zBody (BindStmt pat body bind_op fail_op bind_ty)
+  = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op
+        ; new_bind_ty <- zonkTcTypeToType env1 bind_ty
+        ; new_body <- zBody env1 body
+        ; (env2, new_pat) <- zonkPat env1 pat
+        ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op
+        ; return (env2, BindStmt new_pat new_body new_bind new_fail new_bind_ty) }
 
+-- Scopes: join > ops (in reverse order) > pats (in forward order)
+--              > rest of stmts
 zonkStmt env _zBody (ApplicativeStmt args mb_join body_ty)
-  = do  { (env', args') <- zonk_args env args
-        ; new_mb_join <- traverse (zonkExpr env) mb_join
-        ; new_body_ty <- zonkTcTypeToType env' body_ty
-        ; return (env', ApplicativeStmt args' new_mb_join new_body_ty) }
+  = do  { (env1, new_mb_join)   <- zonk_join env mb_join
+        ; (env2, new_args)      <- zonk_args env1 args
+        ; new_body_ty           <- zonkTcTypeToType env2 body_ty
+        ; return (env2, ApplicativeStmt new_args new_mb_join new_body_ty) }
   where
-   zonk_args env [] = return (env, [])
-   zonk_args env ((op, arg) : groups)
-      = do { (env1, arg') <- zonk_arg env arg
-           ; op' <- zonkExpr env1 op
-           ; (env2, ss) <- zonk_args env1 groups
-           ; return (env2, (op', arg') : ss) }
-
-   zonk_arg env (ApplicativeArgOne pat expr)
-     = do { (env1, new_pat) <- zonkPat env pat
-          ; new_expr <- zonkLExpr env expr
-          ; return (env1, ApplicativeArgOne new_pat new_expr) }
-   zonk_arg env (ApplicativeArgMany stmts ret pat)
-     = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
-          ; new_ret <- zonkExpr env1 ret
-          ; (env2, new_pat) <- zonkPat env pat
-          ; return (env2, ApplicativeArgMany new_stmts new_ret new_pat) }
+    zonk_join env Nothing  = return (env, Nothing)
+    zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j
+
+    get_pat (_, ApplicativeArgOne pat _)    = pat
+    get_pat (_, ApplicativeArgMany _ _ pat) = pat
+
+    replace_pat pat (op, ApplicativeArgOne _ a)
+      = (op, ApplicativeArgOne pat a)
+    replace_pat pat (op, ApplicativeArgMany a b _)
+      = (op, ApplicativeArgMany a b pat)
+
+    zonk_args env args
+      = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)
+           ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)
+           ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }
+
+     -- these need to go backward, because if any operators are higher-rank,
+     -- later operators may introduce skolems that are in scope for earlier
+     -- arguments
+    zonk_args_rev env ((op, arg) : args)
+      = do { (env1, new_op)         <- zonkSyntaxExpr env op
+           ; new_arg                <- zonk_arg env1 arg
+           ; (env2, new_args)       <- zonk_args_rev env1 args
+           ; return (env2, (new_op, new_arg) : new_args) }
+    zonk_args_rev env [] = return (env, [])
+
+    zonk_arg env (ApplicativeArgOne pat expr)
+      = do { new_expr <- zonkLExpr env expr
+           ; return (ApplicativeArgOne pat new_expr) }
+    zonk_arg env (ApplicativeArgMany stmts ret pat)
+      = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts
+           ; new_ret           <- zonkExpr env1 ret
+           ; return (ApplicativeArgMany new_stmts new_ret pat) }
 
 -------------------------------------------------------------------------
 zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId)
@@ -1078,11 +1151,11 @@ zonk_pat env (ListPat pats ty Nothing)
         ; return (env', ListPat pats' ty' Nothing) }
 
 zonk_pat env (ListPat pats ty (Just (ty2,wit)))
-  = do  { wit' <- zonkExpr env wit
-        ; ty2' <- zonkTcTypeToType env ty2
-        ; ty' <- zonkTcTypeToType env ty
-        ; (env', pats') <- zonkPats env pats
-        ; return (env', ListPat pats' ty' (Just (ty2',wit'))) }
+  = do  { (env', wit') <- zonkSyntaxExpr env wit
+        ; ty2' <- zonkTcTypeToType env' ty2
+        ; ty' <- zonkTcTypeToType env' ty
+        ; (env'', pats') <- zonkPats env' pats
+        ; return (env'', ListPat pats' ty' (Just (ty2',wit'))) }
 
 zonk_pat env (PArrPat pats ty)
   = do  { ty' <- zonkTcTypeToType env ty
@@ -1121,19 +1194,25 @@ zonk_pat env (SigPatOut pat ty)
         ; (env', pat') <- zonkPat env pat
         ; return (env', SigPatOut pat' ty') }
 
-zonk_pat env (NPat (L l lit) mb_neg eq_expr)
-  = do  { lit' <- zonkOverLit env lit
-        ; mb_neg' <- fmapMaybeM (zonkExpr env) mb_neg
-        ; eq_expr' <- zonkExpr env eq_expr
-        ; return (env, NPat (L l lit') mb_neg' eq_expr') }
-
-zonk_pat env (NPlusKPat (L loc n) (L l lit) e1 e2)
-  = do  { n' <- zonkIdBndr env n
-        ; lit' <- zonkOverLit env lit
-        ; e1' <- zonkExpr env e1
-        ; e2' <- zonkExpr env e2
-        ; return (extendIdZonkEnv1 env n',
-                  NPlusKPat (L loc n') (L l lit') e1' e2') }
+zonk_pat env (NPat (L l lit) mb_neg eq_expr ty)
+  = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr
+        ; (env2, mb_neg') <- case mb_neg of
+            Nothing -> return (env1, Nothing)
+            Just n  -> second Just <$> zonkSyntaxExpr env1 n
+
+        ; lit' <- zonkOverLit env2 lit
+        ; ty' <- zonkTcTypeToType env2 ty
+        ; return (env2, NPat (L l lit') mb_neg' eq_expr' ty') }
+
+zonk_pat env (NPlusKPat (L loc n) (L l lit1) lit2 e1 e2 ty)
+  = do  { (env1, e1') <- zonkSyntaxExpr env  e1
+        ; (env2, e2') <- zonkSyntaxExpr env1 e2
+        ; n' <- zonkIdBndr env2 n
+        ; lit1' <- zonkOverLit env2 lit1
+        ; lit2' <- zonkOverLit env2 lit2
+        ; ty' <- zonkTcTypeToType env2 ty
+        ; return (extendIdZonkEnv1 env2 n',
+                  NPlusKPat (L loc n') (L l lit1') lit2' e1' e2' ty') }
 
 zonk_pat env (CoPat co_fn pat ty)
   = do { (env', co_fn') <- zonkCoFn env co_fn
index c752dba..e438df5 100644 (file)
@@ -854,7 +854,7 @@ tcInstBinderX mb_kind_info subst binder
      -- This is the *only* constraint currently handled in types.
   | Just (mk, role, k1, k2) <- get_pred_tys_maybe substed_ty
   = do { let origin = TypeEqOrigin { uo_actual   = k1
-                                   , uo_expected = k2
+                                   , uo_expected = mkCheckExpType k2
                                    , uo_thing    = Nothing }
        ; co <- case role of
                  Nominal          -> unifyKind noThing k1 k2
@@ -938,7 +938,7 @@ checkExpectedKind :: TcType               -- the type whose kind we're checking
 checkExpectedKind ty act_kind exp_kind
  = do { (ty', act_kind') <- instantiate ty act_kind exp_kind
       ; let origin = TypeEqOrigin { uo_actual   = act_kind'
-                                  , uo_expected = exp_kind
+                                  , uo_expected = mkCheckExpType exp_kind
                                   , uo_thing    = Just $ mkTypeErrorThing ty'
                                   }
       ; co_k <- uType origin KindLevel act_kind' exp_kind
@@ -2011,7 +2011,7 @@ tcHsPatSigType ctxt sig_ty
 
 tcPatSig :: Bool                    -- True <=> pattern binding
          -> LHsSigWcType Name
-         -> TcSigmaType
+         -> ExpSigmaType
          -> TcM (TcType,            -- The type to use for "inside" the signature
                  [TcTyVar],         -- The new bit of type environment, binding
                                     -- the scoped type variables
@@ -2027,7 +2027,7 @@ tcPatSig in_pat_bind sig res_ty
         ; if null sig_tvs then do {
                 -- Just do the subsumption check and return
                   wrap <- addErrCtxtM (mk_msg sig_ty) $
-                          tcSubType_NC PatSigCtxt res_ty sig_ty
+                          tcSubTypeET_NC PatSigCtxt res_ty sig_ty
                 ; return (sig_ty, [], sig_wcs, wrap)
         } else do
                 -- Type signature binds at least one scoped type variable
@@ -2050,7 +2050,7 @@ tcPatSig in_pat_bind sig res_ty
 
         -- Now do a subsumption check of the pattern signature against res_ty
         ; wrap <- addErrCtxtM (mk_msg sig_ty) $
-                  tcSubType_NC PatSigCtxt res_ty sig_ty
+                  tcSubTypeET_NC PatSigCtxt res_ty sig_ty
 
         -- Phew!
         ; return (sig_ty, sig_tvs, sig_wcs, wrap)
@@ -2058,6 +2058,7 @@ tcPatSig in_pat_bind sig res_ty
   where
     mk_msg sig_ty tidy_env
        = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty
+            ; res_ty <- readExpType res_ty   -- should be filled in by now
             ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty
             ; let msg = vcat [ hang (text "When checking that the pattern signature:")
                                   4 (ppr sig_ty)
index 241e1f1..50850ae 100644 (file)
@@ -1379,7 +1379,8 @@ tcMethodBody clas tyvars dfun_ev_vars inst_tys
                              meth_ty = idType local_meth_id
                        ; tc_sig  <- instTcTySig ctxt lhs_ty sig_ty (idName local_meth_id)
                        ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty meth_ty) $
-                                    tcSubType ctxt (Just global_meth_id) sig_ty meth_ty
+                                    tcSubType ctxt (Just global_meth_id) sig_ty
+                                              (mkCheckExpType meth_ty)
                        ; return (tc_sig, hs_wrap) }
                    ; Nothing ->
                      do { tc_sig <- instTcTySigFromId local_meth_id
index b7fe68c..3d9e57c 100644 (file)
@@ -20,17 +20,20 @@ module TcMType (
   newFlexiTyVarTy,              -- Kind -> TcM TcType
   newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]
   newOpenFlexiTyVarTy,
-  newReturnTyVar, newReturnTyVarTy,
-  newOpenReturnTyVar,
   newMetaKindVar, newMetaKindVars,
   cloneMetaTyVar,
   newFmvTyVar, newFskTyVar,
-  tauTvForReturnTv,
 
   readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
   newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar,
 
   --------------------------------
+  -- Expected types
+  ExpType(..), ExpSigmaType, ExpRhoType,
+  mkCheckExpType, newOpenInferExpType, readExpType, readExpType_maybe,
+  writeExpType, expTypeToType, checkingExpType_maybe, checkingExpType,
+
+  --------------------------------
   -- Creating fresh type variables for pm checking
   genInstSkolTyVarsX,
 
@@ -105,6 +108,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import Control.Monad
 import Maybes
 import Data.List        ( mapAccumL, partition )
+import Control.Arrow    ( second )
 
 {-
 ************************************************************************
@@ -271,6 +275,137 @@ checkCoercionHole co h r t1 t2
   | otherwise
   = return co
 
+{-
+************************************************************************
+*
+    Expected types
+*
+************************************************************************
+
+Note [ExpType]
+~~~~~~~~~~~~~~
+
+An ExpType is used as the "expected type" when type-checking an expression.
+An ExpType can hold a "hole" that can be filled in by the type-checker.
+This allows us to have one tcExpr that works in both checking mode and
+synthesis mode (that is, bidirectional type-checking). Previously, this
+was achieved by using ordinary unification variables, but we don't need
+or want that generality. (For example, #11397 was caused by doing the
+wrong thing with unification variables.) Instead, we observe that these
+holes should
+
+1. never be nested
+2. never appear as the type of a variable
+3. be used linearly (never be duplicated)
+
+By defining ExpType, separately from Type, we can achieve goals 1 and 2
+statically.
+
+See also [wiki:Typechecking]
+
+Note [TcLevel of ExpType]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+
+  data G a where
+    MkG :: G Bool
+
+  foo MkG = True
+
+This is a classic untouchable-variable / ambiguous GADT return type
+scenario. But, with ExpTypes, we'll be inferring the type of the RHS.
+And, because there is only one branch of the case, we won't trigger
+Note [Case branches must never infer a non-tau type] of TcMatches.
+We thus must track a TcLevel in an Inferring ExpType. If we try to
+fill the ExpType and find that the TcLevels don't work out, we
+fill the ExpType with a tau-tv at the low TcLevel, hopefully to
+be worked out later by some means. This is triggered in
+test gadt/gadt-escape1.
+
+-}
+
+-- actual data definition is in TcType
+
+-- | Make an 'ExpType' suitable for inferring a type of kind * or #.
+newOpenInferExpType :: TcM ExpType
+newOpenInferExpType
+  = do { lev <- newFlexiTyVarTy levityTy
+       ; u <- newUnique
+       ; tclvl <- getTcLevel
+       ; let ki = tYPE lev
+       ; traceTc "newOpenInferExpType" (ppr u <+> dcolon <+> ppr ki)
+       ; ref <- newMutVar Nothing
+       ; return (Infer u tclvl ki ref) }
+
+-- | Extract a type out of an ExpType, if one exists. But one should always
+-- exist. Unless you're quite sure you know what you're doing.
+readExpType_maybe :: ExpType -> TcM (Maybe TcType)
+readExpType_maybe (Check ty)        = return (Just ty)
+readExpType_maybe (Infer _ _ _ ref) = readMutVar ref
+
+-- | Extract a type out of an ExpType. Otherwise, panics.
+readExpType :: ExpType -> TcM TcType
+readExpType exp_ty
+  = do { mb_ty <- readExpType_maybe exp_ty
+       ; case mb_ty of
+           Just ty -> return ty
+           Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }
+
+-- | Write into an 'ExpType'. It must be an 'Infer'.
+writeExpType :: ExpType -> TcType -> TcM ()
+writeExpType (Infer u tc_lvl ki ref) ty
+  | debugIsOn
+  = do { ki1 <- zonkTcType (typeKind ty)
+       ; ki2 <- zonkTcType ki
+       ; MASSERT2( ki1 `eqType` ki2, ppr ki1 $$ ppr ki2 $$ ppr u )
+       ; lvl_now <- getTcLevel
+       ; MASSERT2( tc_lvl == lvl_now, ppr u $$ ppr tc_lvl $$ ppr lvl_now )
+       ; cts <- readTcRef ref
+       ; case cts of
+           Just already_there -> pprPanic "writeExpType"
+                                   (vcat [ ppr u
+                                         , ppr ty
+                                         , ppr already_there ])
+           Nothing -> write }
+  | otherwise
+  = write
+  where
+    write = do { traceTc "Filling ExpType" $
+                   ppr u <+> text ":=" <+> ppr ty
+               ; writeTcRef ref (Just ty) }
+writeExpType (Check ty1) ty2 = pprPanic "writeExpType" (ppr ty1 $$ ppr ty2)
+
+-- | Returns the expected type when in checking mode.
+checkingExpType_maybe :: ExpType -> Maybe TcType
+checkingExpType_maybe (Check ty) = Just ty
+checkingExpType_maybe _          = Nothing
+
+-- | Returns the expected type when in checking mode. Panics if in inference
+-- mode.
+checkingExpType :: String -> ExpType -> TcType
+checkingExpType _   (Check ty) = ty
+checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)
+
+-- | Extracts the expected type if there is one, or generates a new
+-- TauTv if there isn't.
+expTypeToType :: ExpType -> TcM TcType
+expTypeToType (Check ty) = return ty
+expTypeToType (Infer u tc_lvl ki ref)
+  = do { uniq <- newUnique
+       ; tv_ref <- newMutVar Flexi
+       ; let details = MetaTv { mtv_info = TauTv
+                              , mtv_ref  = tv_ref
+                              , mtv_tclvl = tc_lvl }
+             name   = mkMetaTyVarName uniq (fsLit "t")
+             tau_tv = mkTcTyVar name ki details
+             tau    = mkTyVarTy tau_tv
+             -- can't use newFlexiTyVarTy because we need to set the tc_lvl
+             -- See also Note [TcLevel of ExpType]
+
+       ; writeMutVar ref (Just tau)
+       ; traceTc "Forcing ExpType to be monomorphic:"
+                 (ppr u <+> dcolon <+> ppr ki <+> text ":=" <+> ppr tau)
+       ; return tau }
 
 {-
 ************************************************************************
@@ -391,7 +526,8 @@ instSkolTyCoVarsX mk_tcv = mapAccumLM (instSkolTyCoVarX mk_tcv)
 instSkolTyCoVarX :: (Unique -> Name -> Kind -> TyCoVar)
                  -> TCvSubst -> TyCoVar -> TcRnIf gbl lcl (TCvSubst, TyCoVar)
 instSkolTyCoVarX mk_tcv subst tycovar
-  = do  { uniq <- newUnique
+  = do  { uniq <- newUnique  -- using a new unique is critical. See
+                             -- Note [Skolems in zonkSyntaxExpr] in TcHsSyn
         ; let new_tv = mk_tcv uniq old_name kind
         ; return (extendTCvSubst (extendTCvInScope subst new_tv) tycovar
                    (mk_ty_co new_tv)
@@ -575,23 +711,6 @@ genInstSkolTyVarsX loc subst tvs = instSkolTyCoVarsX (mkTcSkolTyVar loc False) s
 *                                                                      *
 ************************************************************************
 
-Note [Sort-polymorphic tyvars accept foralls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is a common paradigm:
-   foo :: (forall a. a -> a) -> Int
-   foo = error "urk"
-To make this work we need to instantiate 'error' with a polytype.
-A similar case is
-   bar :: Bool -> (forall a. a->a) -> Int
-   bar True = \x. (x 3)
-   bar False = error "urk"
-Here we need to instantiate 'error' with a polytype.
-
-But 'error' has an sort-polymorphic type variable, precisely so that
-we can instantiate it with Int#.  So we also allow such type variables
-to be instantiate with foralls.  It's a bit of a hack, but seems
-straightforward.
-
 Note [Never need to instantiate coercion variables]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 With coercion variables sloshing around in types, it might seem that we
@@ -612,7 +731,6 @@ newAnonMetaTyVar meta_info kind
   = do  { uniq <- newUnique
         ; let name = mkMetaTyVarName uniq s
               s = case meta_info of
-                        ReturnTv    -> fsLit "r"
                         TauTv       -> fsLit "t"
                         FlatMetaTv  -> fsLit "fmv"
                         SigTv       -> fsLit "a"
@@ -630,43 +748,12 @@ newFlexiTyVarTy kind = do
 newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]
 newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind)
 
-newReturnTyVar :: Kind -> TcM TcTyVar
-newReturnTyVar kind = newAnonMetaTyVar ReturnTv kind
-
-newReturnTyVarTy :: Kind -> TcM TcType
-newReturnTyVarTy kind = mkTyVarTy <$> newReturnTyVar kind
-
 -- | Create a tyvar that can be a lifted or unlifted type.
 newOpenFlexiTyVarTy :: TcM TcType
 newOpenFlexiTyVarTy
   = do { lev <- newFlexiTyVarTy levityTy
        ; newFlexiTyVarTy (tYPE lev) }
 
--- | Create a *return* tyvar that can be a lifted or unlifted type.
-newOpenReturnTyVar :: TcM (TcTyVar, TcKind)
-newOpenReturnTyVar
-  = do { lev <- newFlexiTyVarTy levityTy  -- this doesn't need ReturnTv
-       ; let k = tYPE lev
-       ; tv <- newReturnTyVar k
-       ; return (tv, k) }
-
--- | If the type is a ReturnTv, fill it with a new meta-TauTv. Otherwise,
--- no change. This function can look through ReturnTvs and returns a partially
--- zonked type as an optimisation.
-tauTvForReturnTv :: TcType -> TcM TcType
-tauTvForReturnTv ty
-  | Just tv <- tcGetTyVar_maybe ty
-  , isReturnTyVar tv
-  = do { contents <- readMetaTyVar tv
-       ; case contents of
-           Flexi -> do { tau_ty <- newFlexiTyVarTy (tyVarKind tv)
-                       ; writeMetaTyVar tv tau_ty
-                       ; return tau_ty }
-           Indirect ty -> tauTvForReturnTv ty }
-  | otherwise
-  = ASSERT( all (not . isReturnTyVar) (tyCoVarsOfTypeList ty) )
-    return ty
-
 newMetaSigTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
 newMetaSigTyVars = mapAccumLM newMetaSigTyVarX emptyTCvSubst
 
@@ -685,10 +772,7 @@ newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)
 -- an existing TyVar. We substitute kind variables in the kind.
 newMetaTyVarX subst tyvar
   = do  { uniq <- newUnique
-               -- See Note [Levity polymorphic variables accept foralls]
-        ; let info | isLevityPolymorphic (tyVarKind tyvar) = ReturnTv
-                   | otherwise                             = TauTv
-        ; details <- newMetaDetails info
+        ; details <- newMetaDetails TauTv
         ; let name   = mkSystemName uniq (getOccName tyvar)
                        -- See Note [Name of an instantiated type variable]
               kind   = substTyUnchecked subst (tyVarKind tyvar)
@@ -715,23 +799,6 @@ newMetaSigTyVarX subst tyvar
 At the moment we give a unification variable a System Name, which
 influences the way it is tidied; see TypeRep.tidyTyVarBndr.
 
-Note [Levity polymorphic variables accept foralls]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Here is a common paradigm:
-   foo :: (forall a. a -> a) -> Int
-   foo = error "urk"
-To make this work we need to instantiate 'error' with a polytype.
-A similar case is
-   bar :: Bool -> (forall a. a->a) -> Int
-   bar True = \x. (x 3)
-   bar False = error "urk"
-Here we need to instantiate 'error' with a polytype.
-
-But 'error' has a levity polymorphic type variable, precisely so that
-we can instantiate it with Int#.  So we also allow such type variables
-to be instantiated with foralls.  It's a bit of a hack, but seems
-straightforward.
-
 ************************************************************************
 *                                                                      *
              Quantification
@@ -1103,8 +1170,9 @@ zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })
        ; return (ctev { ctev_pred = pred' }) }
 
 zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo
-zonkSkolemInfo (SigSkol cx ty)  = do { ty' <- zonkTcType ty
-                                     ; return (SigSkol cx ty') }
+zonkSkolemInfo (SigSkol cx ty)  = do { ty  <- readExpType ty
+                                     ; ty' <- zonkTcType ty
+                                     ; return (SigSkol cx (mkCheckExpType ty')) }
 zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys
                                      ; return (InferSkol ntys') }
   where
@@ -1222,16 +1290,22 @@ zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act
                                       , uo_expected = exp
                                       , uo_thing    = m_thing })
   = do { (env1, act') <- zonkTidyTcType env  act
-       ; (env2, exp') <- zonkTidyTcType env1 exp
+       ; mb_exp <- readExpType_maybe exp  -- it really should be filled in.
+                                          -- unless we're debugging.
+       ; (env2, exp') <- case mb_exp of
+           Just ty -> second mkCheckExpType <$> zonkTidyTcType env1 ty
+           Nothing -> return (env1, exp)
        ; (env3, m_thing') <- zonkTidyErrorThing env2 m_thing
        ; return ( env3, orig { uo_actual   = act'
                              , uo_expected = exp'
                              , uo_thing    = m_thing' }) }
-zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k)
-  = do { (env1, ty1') <- zonkTidyTcType env  ty1
-       ; (env2, ty2') <- zonkTidyTcType env1 ty2
-       ; (env3, orig') <- zonkTidyOrigin env2 orig
-       ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) }
+zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)
+  = do { (env1, ty1')   <- zonkTidyTcType env  ty1
+       ; (env2, m_ty2') <- case m_ty2 of
+                             Just ty2 -> second Just <$> zonkTidyTcType env1 ty2
+                             Nothing  -> return (env1, Nothing)
+       ; (env3, orig')  <- zonkTidyOrigin env2 orig
+       ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }
 zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)
   = do { (env1, p1') <- zonkTidyTcType env  p1
        ; (env2, p2') <- zonkTidyTcType env1 p2
@@ -1278,7 +1352,9 @@ tidyEvVar env var = setVarType var (tidyType env (varType var))
 ----------------
 tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
 tidySkolemInfo env (DerivSkol ty)       = DerivSkol (tidyType env ty)
-tidySkolemInfo env (SigSkol cx ty)      = SigSkol cx (tidyType env ty)
+tidySkolemInfo env (SigSkol cx ty)      = SigSkol cx (mkCheckExpType $
+                                                      tidyType env $
+                                                      checkingExpType "tidySkolemInfo" ty)
 tidySkolemInfo env (InferSkol ids)      = InferSkol (mapSnd (tidyType env) ids)
 tidySkolemInfo env (UnifyForAllSkol ty) = UnifyForAllSkol (tidyType env ty)
 tidySkolemInfo _   info                 = info
index f4d2e12..e7da8ad 100644 (file)
@@ -45,6 +45,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import MkCore
 
 import Control.Monad
+import Control.Arrow ( second )
 
 #include "HsVersions.h"
 
@@ -69,7 +70,7 @@ See Note [sig_tau may be polymorphic] in TcPat.
 
 tcMatchesFun :: Name
              -> MatchGroup Name (LHsExpr Name)
-             -> TcSigmaType     -- Expected type of function
+             -> ExpRhoType     -- Expected type of function
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
                                 -- Returns type of body
 tcMatchesFun fun_name matches exp_ty
@@ -82,13 +83,17 @@ tcMatchesFun fun_name matches exp_ty
           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
         ; checkArgs fun_name matches
 
-        ; exp_ty <- tauifyMultipleMatches matches exp_ty
         ; (wrap_gen, (wrap_fun, group))
-            <- tcSkolemise (FunSigCtxt fun_name True) exp_ty $ \ _ exp_rho ->
+            <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->
                   -- Note [Polymorphic expected type for tcMatchesFun]
-               do { (wrap_fun, pat_tys, rhs_ty)
-                       <- matchExpectedFunTys herald arity exp_rho
-                  ; matches' <- tcMatches match_ctxt pat_tys rhs_ty matches
+               do { (matches', wrap_fun)
+                       <- matchExpectedFunTys herald arity exp_rho $
+                          \ pat_tys rhs_ty ->
+                     -- See Note [Case branches must never infer a non-tau type]
+                     do { rhs_ty : pat_tys
+                            <- mapM (tauifyMultipleMatches matches)
+                                    (rhs_ty : pat_tys)
+                        ; tcMatches match_ctxt pat_tys rhs_ty matches }
                   ; return (wrap_fun, matches') }
         ; return (wrap_gen <.> wrap_fun, group) }
   where
@@ -106,25 +111,30 @@ tcMatchesCase :: (Outputable (body Name)) =>
                  TcMatchCtxt body                             -- Case context
               -> TcSigmaType                                  -- Type of scrutinee
               -> MatchGroup Name (Located (body Name))        -- The case alternatives
-              -> TcRhoType                                    -- Type of whole case expressions
+              -> ExpRhoType                                   -- Type of whole case expressions
               -> TcM (MatchGroup TcId (Located (body TcId)))
                  -- Translated alternatives
                  -- wrapper goes from MatchGroup's ty to expected ty
 
 tcMatchesCase ctxt scrut_ty matches res_ty
   = do { res_ty <- tauifyMultipleMatches matches res_ty
-       ; tcMatches ctxt [scrut_ty] res_ty matches }
+       ; tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches }
 
 tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
               -> TcMatchCtxt HsExpr
               -> MatchGroup Name (LHsExpr Name)
-              -> TcRhoType   -- deeply skolemised
+              -> ExpRhoType   -- deeply skolemised
               -> TcM (HsWrapper, [TcSigmaType], MatchGroup TcId (LHsExpr TcId))
                      -- also returns the argument types
 tcMatchLambda herald match_ctxt match res_ty
-  = do { res_ty <- tauifyMultipleMatches match res_ty
-       ; (wrap, pat_tys, rhs_ty) <- matchExpectedFunTys herald n_pats res_ty
-       ; match' <- tcMatches match_ctxt pat_tys rhs_ty match
+  = do { ((match', pat_tys), wrap)
+           <- matchExpectedFunTys herald n_pats res_ty $
+              \ pat_tys rhs_ty ->
+              do { rhs_ty : pat_tys <- mapM (tauifyMultipleMatches match)
+                                            (rhs_ty : pat_tys)
+                 ; match' <- tcMatches match_ctxt pat_tys rhs_ty match
+                 ; pat_tys <- mapM readExpType pat_tys
+                 ; return (match', pat_tys) }
        ; return (wrap, pat_tys, match') }
   where
     n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
@@ -135,7 +145,7 @@ tcMatchLambda herald match_ctxt match res_ty
 tcGRHSsPat :: GRHSs Name (LHsExpr Name) -> TcRhoType
            -> TcM (GRHSs TcId (LHsExpr TcId))
 -- Used for pattern bindings
-tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
+tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)
   where
     match_ctxt = MC { mc_what = PatBindRhs,
                       mc_body = tcBody }
@@ -147,8 +157,8 @@ tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
 *                                                                      *
 ************************************************************************
 
-Note [Case branches must be taus]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Case branches must never infer a non-tau type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
 
   case ... of
@@ -159,16 +169,17 @@ Should that type-check? The problem is that, if we check the second branch
 first, then we'll get a type (b -> b) for the branches, which won't unify
 with the polytype in the first branch. If we check the first branch first,
 then everything is OK. This order-dependency is terrible. So we want only
-proper tau-types in branches. This is what tauTvForReturnsTv ensures:
-it gets rid of those pesky ReturnTvs that might unify with polytypes.
+proper tau-types in branches (unless a sigma-type is pushed down).
+This is what expTypeToType ensures: it replaces an Infer with a fresh
+tau-type.
 
 An even trickier case looks like
 
   f x True  = x undefined
   f x False = x ()
 
-Here, we see that the arguments must also be non-ReturnTvs. Thus, we must
-tauify before calling matchFunTys.
+Here, we see that the arguments must also be non-Infer. Thus, we must
+use expTypeToType on the output of matchExpectedFunTys, not the input.
 
 But we make a special case for a one-branch case. This is so that
 
@@ -177,25 +188,28 @@ But we make a special case for a one-branch case. This is so that
 still gets assigned a polytype.
 -}
 
--- | When the MatchGroup has multiple RHSs, convert any ReturnTvs in the
+-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
 -- expected type into TauTvs.
--- See Note [Case branches must be taus]
+-- See Note [Case branches must never infer a non-tau type]
 tauifyMultipleMatches :: MatchGroup id body
-                      -> TcType
-                      -> TcM TcType
+                      -> ExpType
+                      -> TcM ExpType
 tauifyMultipleMatches group exp_ty
   | isSingletonMatchGroup group
   = return exp_ty
 
   | otherwise
-  = tauTvForReturnTv exp_ty
+  = mkCheckExpType <$> expTypeToType exp_ty
+      -- NB: This also ensures that an empty match still fills in the
+      -- ExpType
 
 -- | Type-check a MatchGroup. If there are multiple RHSs, the expected type
--- must already be tauified. See Note [Case branches must be taus] and
--- tauifyMultipleMatches
+-- must already be tauified.
+-- See Note [Case branches must never infer a non-tau type]
+-- about tauifyMultipleMatches
 tcMatches :: (Outputable (body Name)) => TcMatchCtxt body
-          -> [TcSigmaType]      -- Expected pattern types
-          -> TcRhoType          -- Expected result-type of the Match.
+          -> [ExpSigmaType]      -- Expected pattern types
+          -> ExpRhoType          -- Expected result-type of the Match.
           -> MatchGroup Name (Located (body Name))
           -> TcM (MatchGroup TcId (Located (body TcId)))
 
@@ -203,12 +217,14 @@ data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
   = MC { mc_what :: HsMatchContext Name,        -- What kind of thing this is
          mc_body :: Located (body Name)         -- Type checker for a body of
                                                 -- an alternative
-                 -> TcRhoType
+                 -> ExpRhoType
                  -> TcM (Located (body TcId)) }
 
 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
                                   , mg_origin = origin })
   = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
+       ; pat_tys  <- mapM readExpType pat_tys
+       ; rhs_ty   <- readExpType rhs_ty
        ; return (MG { mg_alts = L l matches'
                     , mg_arg_tys = pat_tys
                     , mg_res_ty = rhs_ty
@@ -216,8 +232,8 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
 
 -------------
 tcMatch :: (Outputable (body Name)) => TcMatchCtxt body
-        -> [TcSigmaType]        -- Expected pattern types
-        -> TcRhoType            -- Expected result-type of the Match.
+        -> [ExpSigmaType]        -- Expected pattern types
+        -> ExpRhoType            -- Expected result-type of the Match.
         -> LMatch Name (Located (body Name))
         -> TcM (LMatch TcId (Located (body TcId)))
 
@@ -245,7 +261,7 @@ tcMatch ctxt pat_tys rhs_ty match
             m_ctxt     -> addErrCtxt (pprMatchInCtxt m_ctxt match) thing_inside
 
 -------------
-tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> TcRhoType
+tcGRHSs :: TcMatchCtxt body -> GRHSs Name (Located (body Name)) -> ExpRhoType
         -> TcM (GRHSs TcId (Located (body TcId)))
 
 -- Notice that we pass in the full res_ty, so that we get
@@ -262,7 +278,7 @@ tcGRHSs ctxt (GRHSs grhss (L l binds)) res_ty
         ; return (GRHSs grhss' (L l binds')) }
 
 -------------
-tcGRHS :: TcMatchCtxt body -> TcRhoType -> GRHS Name (Located (body Name))
+tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS Name (Located (body Name))
        -> TcM (GRHS TcId (Located (body TcId)))
 
 tcGRHS ctxt res_ty (GRHS guards rhs)
@@ -283,35 +299,42 @@ tcGRHS ctxt res_ty (GRHS guards rhs)
 
 tcDoStmts :: HsStmtContext Name
           -> Located [LStmt Name (LHsExpr Name)]
-          -> TcRhoType
+          -> ExpRhoType
           -> TcM (HsExpr TcId)          -- Returns a HsDo
 tcDoStmts ListComp (L l stmts) res_ty
-  = do  { (co, elt_ty) <- matchExpectedListTy res_ty
+  = do  { res_ty <- expTypeToType res_ty
+        ; (co, elt_ty) <- matchExpectedListTy res_ty
         ; let list_ty = mkListTy elt_ty
-        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty
+        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts
+                            (mkCheckExpType elt_ty)
         ; return $ mkHsWrapCo co (HsDo ListComp (L l stmts') list_ty) }
 
 tcDoStmts PArrComp (L l stmts) res_ty
-  = do  { (co, elt_ty) <- matchExpectedPArrTy res_ty
+  = do  { res_ty <- expTypeToType res_ty
+        ; (co, elt_ty) <- matchExpectedPArrTy res_ty
         ; let parr_ty = mkPArrTy elt_ty
-        ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty
+        ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
+                            (mkCheckExpType elt_ty)
         ; return $ mkHsWrapCo co (HsDo PArrComp (L l stmts') parr_ty) }
 
 tcDoStmts DoExpr (L l stmts) res_ty
   = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
         ; return (HsDo DoExpr (L l stmts') res_ty) }
 
 tcDoStmts MDoExpr (L l stmts) res_ty
   = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
         ; return (HsDo MDoExpr (L l stmts') res_ty) }
 
 tcDoStmts MonadComp (L l stmts) res_ty
   = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty
+        ; res_ty <- readExpType res_ty
         ; return (HsDo MonadComp (L l stmts') res_ty) }
 
 tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)
 
-tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
+tcBody :: LHsExpr Name -> ExpRhoType -> TcM (LHsExpr TcId)
 tcBody body res_ty
   = do  { traceTc "tcBody" (ppr res_ty)
         ; tcMonoExpr body res_ty
@@ -325,20 +348,20 @@ tcBody body res_ty
 ************************************************************************
 -}
 
-type TcExprStmtChecker = TcStmtChecker HsExpr
-type TcCmdStmtChecker  = TcStmtChecker HsCmd
+type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
+type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
 
-type TcStmtChecker body
+type TcStmtChecker body rho_type
   =  forall thing. HsStmtContext Name
                 -> Stmt Name (Located (body Name))
-                -> TcRhoType                    -- Result type for comprehension
-                -> (TcRhoType -> TcM thing)     -- Checker for what follows the stmt
+                -> rho_type                 -- Result type for comprehension
+                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
                 -> TcM (Stmt TcId (Located (body TcId)), thing)
 
 tcStmts :: (Outputable (body Name)) => HsStmtContext Name
-        -> TcStmtChecker body   -- NB: higher-rank type
+        -> TcStmtChecker body rho_type   -- NB: higher-rank type
         -> [LStmt Name (Located (body Name))]
-        -> TcRhoType
+        -> rho_type
         -> TcM [LStmt TcId (Located (body TcId))]
 tcStmts ctxt stmt_chk stmts res_ty
   = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
@@ -346,10 +369,10 @@ tcStmts ctxt stmt_chk stmts res_ty
        ; return stmts' }
 
 tcStmtsAndThen :: (Outputable (body Name)) => HsStmtContext Name
-               -> TcStmtChecker body    -- NB: higher-rank type
+               -> TcStmtChecker body rho_type    -- NB: higher-rank type
                -> [LStmt Name (Located (body Name))]
-               -> TcRhoType
-               -> (TcRhoType -> TcM thing)
+               -> rho_type
+               -> (rho_type -> TcM thing)
                -> TcM ([LStmt TcId (Located (body TcId))], thing)
 
 -- Note the higher-rank type.  stmt_chk is applied at different
@@ -394,17 +417,17 @@ tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
 
 tcGuardStmt :: TcExprStmtChecker
 tcGuardStmt _ (BodyStmt guard _ _ _) res_ty thing_inside
-  = do  { guard' <- tcMonoExpr guard boolTy
+  = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)
         ; thing  <- thing_inside res_ty
         ; return (BodyStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 
-tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
+tcGuardStmt ctxt (BindStmt pat rhs _ _ _) res_ty thing_inside
   = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs
                                    -- Stmt has a context already
         ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (exprCtOrigin (unLoc rhs))
-                                    pat rhs_ty $
+                                    pat (mkCheckExpType rhs_ty) $
                             thing_inside res_ty
-        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+        ; return (mkTcBindStmt pat' rhs', thing) }
 
 tcGuardStmt _ stmt _ _
   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
@@ -433,23 +456,23 @@ tcLcStmt _ _ (LastStmt body noret _) elt_ty thing_inside
        ; return (LastStmt body' noret noSyntaxExpr, thing) }
 
 -- A generator, pat <- rhs
-tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (BindStmt pat rhs _ _ _) elt_ty thing_inside
  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
-        ; rhs'   <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty])
-        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat pat_ty $
+        ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])
+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                             thing_inside elt_ty
-        ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
+        ; return (mkTcBindStmt pat' rhs', thing) }
 
 -- A boolean guard
 tcLcStmt _ _ (BodyStmt rhs _ _ _) elt_ty thing_inside
-  = do  { rhs'  <- tcMonoExpr rhs boolTy
+  = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)
         ; thing <- thing_inside elt_ty
         ; return (BodyStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) }
 
 -- ParStmt: See notes with tcMcStmt
-tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _) elt_ty thing_inside
+tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside
   = do  { (pairs', thing) <- loop bndr_stmts_s
-        ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr, thing) }
+        ; return (ParStmt pairs' noExpr noSyntaxExpr unitTy, thing) }
   where
     -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
     loop [] = do { thing <- thing_inside elt_ty
@@ -518,9 +541,13 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
        -- these new binders and return the result
        ; 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_form = form }, thing) }
+       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
+                           , trS_by = fmap fst by', trS_using = final_using
+                           , trS_ret = noSyntaxExpr
+                           , trS_bind = noSyntaxExpr
+                           , trS_fmap = noExpr
+                           , trS_bind_arg_ty = unitTy
+                           , trS_form = form }, thing) }
 
 tcLcStmt _ _ stmt _ _
   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
@@ -534,10 +561,10 @@ tcLcStmt _ _ stmt _ _
 tcMcStmt :: TcExprStmtChecker
 
 tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
-  = do  { a_ty       <- newFlexiTyVarTy liftedTypeKind
-        ; return_op' <- tcSyntaxOp MCompOrigin return_op
-                                   (a_ty `mkFunTy` res_ty)
-        ; body'      <- tcMonoExprNC body a_ty
+  = do  { (body', return_op')
+            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
+               \ [a_ty] ->
+               tcMonoExprNC body (mkCheckExpType a_ty)
         ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
         ; return (LastStmt body' noret return_op', thing) }
 
@@ -547,24 +574,22 @@ tcMcStmt _ (LastStmt body noret return_op) res_ty thing_inside
 --                            q   ::   a
 --
 
-tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
- = do   { rhs_ty     <- newFlexiTyVarTy liftedTypeKind
-        ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
-        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-
+tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
-        ; bind_op'   <- tcSyntaxOp MCompOrigin bind_op
-                             (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
-
-        ; rhs' <- tcMonoExprNC rhs rhs_ty
-
-        ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
-                           thing_inside new_res_ty
+  = do  { ((rhs', pat', thing, new_res_ty), bind_op')
+            <- tcSyntaxOp MCompOrigin bind_op
+                          [SynRho, SynFun SynAny SynRho] res_ty $
+               \ [rhs_ty, pat_ty, new_res_ty] ->
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                  ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
+                                           (mkCheckExpType pat_ty) $
+                                     thing_inside (mkCheckExpType new_res_ty)
+                  ; return (rhs', pat', thing, new_res_ty) }
 
         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
         ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty
 
-        ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+        ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
 
 -- Boolean expressions.
 --
@@ -575,15 +600,16 @@ tcMcStmt _ (BodyStmt rhs then_op guard_op _) res_ty thing_inside
           --    guard_op :: test_ty -> rhs_ty
           --    then_op  :: rhs_ty -> new_res_ty -> res_ty
           -- Where test_ty is, for example, Bool
-          test_ty    <- newFlexiTyVarTy liftedTypeKind
-        ; rhs_ty     <- newFlexiTyVarTy liftedTypeKind
-        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; rhs'       <- tcMonoExpr rhs test_ty
-        ; guard_op'  <- tcSyntaxOp MCompOrigin guard_op
-                                   (mkFunTy test_ty rhs_ty)
-        ; then_op'   <- tcSyntaxOp MCompOrigin then_op
-                                   (mkFunTys [rhs_ty, new_res_ty] res_ty)
-        ; thing      <- thing_inside new_res_ty
+        ; ((thing, rhs', rhs_ty, guard_op'), then_op')
+            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
+               \ [rhs_ty, new_res_ty] ->
+               do { (rhs', guard_op')
+                      <- tcSyntaxOp MCompOrigin guard_op [SynAny]
+                                    (mkCheckExpType rhs_ty) $
+                         \ [test_ty] ->
+                         tcMonoExpr rhs (mkCheckExpType test_ty)
+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (thing, rhs', rhs_ty, guard_op') }
         ; return (BodyStmt rhs' then_op' guard_op' rhs_ty, thing) }
 
 -- Grouping statements
@@ -638,31 +664,36 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
              -- We don't know what tuple_ty is yet, so we use a variable
        ; let (bndr_names, n_bndr_names) = unzip bindersMap
        ; (stmts', (bndr_ids, by', return_op')) <-
-            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do
+            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
+                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do
                 { by' <- case by of
                            Nothing -> return Nothing
-                           Just e  -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') }
+                           Just e  -> do { e' <- tcMonoExpr e
+                                                   (mkCheckExpType by_e_ty)
+                                         ; return (Just e') }
 
                 -- Find the Ids (and hence types) of all old binders
                 ; bndr_ids <- tcLookupLocalIds bndr_names
 
                 -- 'return' is only used for the binders, so we know its type.
                 --   return :: (a,b,c,..) -> m (a,b,c,..)
-                ; return_op' <- tcSyntaxOp MCompOrigin return_op $
-                                (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty'
+                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
+                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]
+                                       res_ty' $ \ _ -> return ()
 
                 ; return (bndr_ids, by', return_op') }
 
        --------------- Typecheck the 'bind' function -------------
        -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-       ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
-                                using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty)
-                                             `mkFunTy` res_ty
+       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op
+                             [ synKnownType using_res_ty
+                             , synKnownType (n_app tup_ty `mkFunTy` new_res_ty) ]
+                             res_ty $ \ _ -> return ()
 
        --------------- Typecheck the 'fmap' function -------------
        ; fmap_op' <- case form of
-                       ThenForm -> return noSyntaxExpr
+                       ThenForm -> return noExpr
                        _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $
                             mkNamedForAllTy alphaTyVar Invisible $
                             mkNamedForAllTy betaTyVar  Invisible $
@@ -688,11 +719,13 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
 
        -- Type check the thing in the environment with
        -- these new binders and return the result
-       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty)
+       ; thing <- tcExtendIdEnv n_bndr_ids $
+                  thing_inside (mkCheckExpType new_res_ty)
 
        ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
                            , trS_by = by', trS_using = final_using
                            , trS_ret = return_op', trS_bind = bind_op'
+                           , trS_bind_arg_ty = n_app tup_ty
                            , trS_fmap = fmap_op', trS_form = form }, thing) }
 
 -- A parallel set of comprehensions
@@ -724,7 +757,7 @@ tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
 --        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
 --        -> m (st1, (st2, st3))
 --
-tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside
+tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op _) res_ty thing_inside
   = do { let star_star_kind = liftedTypeKind `mkFunTy` liftedTypeKind
        ; m_ty   <- newFlexiTyVarTy star_star_kind
 
@@ -736,41 +769,53 @@ tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op) res_ty thing_inside
                         (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
        ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty
 
-       ; (blocks', thing) <- loop m_ty bndr_stmts_s
+        -- type dummies since we don't know all binder types yet
+       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
+                       [ names | ParStmtBlock _ names _ <- bndr_stmts_s ]
 
        -- Typecheck bind:
-       ; let tys      = [ mkBigCoreVarTupTy bs | ParStmtBlock _ bs _ <- blocks']
-             tuple_ty = mk_tuple_ty tys
+       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
+             tuple_ty = mk_tuple_ty tup_tys
 
-       ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $
-                        (m_ty `mkAppTy` tuple_ty)
-                        `mkFunTy` (tuple_ty `mkFunTy` res_ty)
-                        `mkFunTy` res_ty
+       ; (((blocks', thing), inner_res_ty), bind_op')
+           <- tcSyntaxOp MCompOrigin bind_op
+                         [ synKnownType (m_ty `mkAppTy` tuple_ty)
+                         , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
+              \ [inner_res_ty] ->
+              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
+                                 tup_tys bndr_stmts_s
+                 ; return (stuff, inner_res_ty) }
 
-       ; return (ParStmt blocks' mzip_op' bind_op', thing) }
+       ; return (ParStmt blocks' mzip_op' bind_op' inner_res_ty, thing) }
 
   where
     mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
 
        -- loop :: Type                                  -- m_ty
-       --      -> [([LStmt Name], [Name])]
+       --      -> ExpRhoType                            -- inner_res_ty
+       --      -> [TcType]                              -- tup_tys
+       --      -> [ParStmtBlock Name]
        --      -> TcM ([([LStmt TcId], [TcId])], thing)
-    loop _ [] = do { thing <- thing_inside res_ty
-                   ; return ([], thing) }           -- matching in the branches
+    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
+                                   ; return ([], thing) }
+                                   -- matching in the branches
 
-    loop m_ty (ParStmtBlock stmts names return_op : pairs)
-      = do { -- type dummy since we don't know all binder types yet
-             id_tys <- mapM (const (newFlexiTyVarTy liftedTypeKind)) names
-           ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreTupTy id_tys
+    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
+                           (ParStmtBlock stmts names return_op : pairs)
+      = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
            ; (stmts', (ids, return_op', pairs', thing))
-                <- tcStmtsAndThen ctxt tcMcStmt stmts m_tup_ty $ \m_tup_ty' ->
+                <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
+                   \m_tup_ty' ->
                    do { ids <- tcLookupLocalIds names
                       ; let tup_ty = mkBigCoreVarTupTy ids
-                      ; return_op' <- tcSyntaxOp MCompOrigin return_op
-                                          (tup_ty `mkFunTy` m_tup_ty')
-                      ; (pairs', thing) <- loop m_ty pairs
+                      ; (_, return_op') <-
+                          tcSyntaxOp MCompOrigin return_op
+                                     [synKnownType tup_ty] m_tup_ty' $
+                                     \ _ -> return ()
+                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
                       ; return (ids, return_op', pairs', thing) }
            ; return (ParStmtBlock stmts' ids return_op' : pairs', thing) }
+    loop _ _ _ _ = panic "tcMcStmt.loop"
 
 tcMcStmt _ stmt _ _
   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
@@ -788,58 +833,47 @@ tcDoStmt _ (LastStmt body noret _) res_ty thing_inside
        ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
        ; return (LastStmt body' noret noSyntaxExpr, thing) }
 
-tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
+tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op _) res_ty thing_inside
   = do  {       -- Deal with rebindable syntax:
                 --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
                 -- This level of generality is needed for using do-notation
                 -- in full generality; see Trac #1537
 
-                -- I'd like to put this *after* the tcSyntaxOp
-                -- (see Note [Treat rebindable syntax first], but that breaks
-                -- the rigidity info for GADTs.  When we move to the new story
-                -- for GADTs, we can move this after tcSyntaxOp
-          rhs_ty     <- newFlexiTyVarTy liftedTypeKind
-        ; pat_ty     <- newFlexiTyVarTy liftedTypeKind
-        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; bind_op'   <- tcSyntaxOp DoOrigin bind_op
-                             (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty)
-
-        ; rhs' <- tcMonoExprNC rhs rhs_ty
-
-        ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $
-                           thing_inside new_res_ty
+          ((rhs', pat', new_res_ty, thing), bind_op')
+            <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $
+                \ [rhs_ty, pat_ty, new_res_ty] ->
+                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                   ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat
+                                            (mkCheckExpType pat_ty) $
+                                      thing_inside (mkCheckExpType new_res_ty)
+                   ; return (rhs', pat', new_res_ty, thing) }
 
         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
         ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty
 
-        ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
+        ; return (BindStmt pat' rhs' bind_op' fail_op' new_res_ty, thing) }
 
 tcDoStmt ctxt (ApplicativeStmt pairs mb_join _) res_ty thing_inside
-  = do  {
-        ; (mb_join', rhs_ty) <- case mb_join of
-            Nothing -> return (Nothing, res_ty)
+  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
+                                thing_inside . mkCheckExpType
+        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
+            Nothing -> (, Nothing) <$> tc_app_stmts res_ty
             Just join_op ->
-              do { rhs_ty <- newFlexiTyVarTy liftedTypeKind
-                 ; join_op' <- tcSyntaxOp DoOrigin join_op
-                     (mkFunTy rhs_ty res_ty)
-                 ; return (Just join_op', rhs_ty) }
-
-        ; (pairs', body_ty, thing) <-
-            tcApplicativeStmts ctxt pairs rhs_ty thing_inside
+              second Just <$>
+              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
+               \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))
 
         ; return (ApplicativeStmt pairs' mb_join' body_ty, thing) }
 
 tcDoStmt _ (BodyStmt rhs then_op _ _) res_ty thing_inside
   = do  {       -- Deal with rebindable syntax;
                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
-                -- See also Note [Treat rebindable syntax first]
-          rhs_ty     <- newFlexiTyVarTy liftedTypeKind
-        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; then_op' <- tcSyntaxOp DoOrigin then_op
-                           (mkFunTys [rhs_ty, new_res_ty] res_ty)
-
-        ; rhs' <- tcMonoExprNC rhs rhs_ty
-        ; thing <- thing_inside new_res_ty
+        ; ((rhs', rhs_ty, thing), then_op')
+            <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
+               \ [rhs_ty, new_res_ty] ->
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)
+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (rhs', rhs_ty, thing) }
         ; return (BodyStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) }
 
 tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
@@ -852,24 +886,35 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
               tup_ty  = mkBigCoreTupTy tup_elt_tys
 
         ; tcExtendIdEnv tup_ids $ do
-        { stmts_ty <- newFlexiTyVarTy liftedTypeKind
+        { stmts_ty <- newOpenInferExpType
         ; (stmts', (ret_op', tup_rets))
-                <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty   $ \ inner_res_ty ->
-                   do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys
+                <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty   $
+                   \ inner_res_ty ->
+                   do { tup_rets <- zipWithM tcCheckId tup_names
+                                      (map mkCheckExpType tup_elt_tys)
                              -- Unify the types of the "final" Ids (which may
                              -- be polymorphic) with those of "knot-tied" Ids
-                      ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty)
+                      ; (_, ret_op')
+                          <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
+                                        inner_res_ty $ \_ -> return ()
                       ; return (ret_op', tup_rets) }
-
-        ; mfix_res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; mfix_op' <- tcSyntaxOp DoOrigin mfix_op
-                                 (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty)
-
-        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
-        ; bind_op' <- tcSyntaxOp DoOrigin bind_op
-                                 (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty)
-
-        ; thing <- thing_inside new_res_ty
+        ; stmts_ty <- readExpType stmts_ty
+
+        ; mfix_res_ty <- newOpenInferExpType
+        ; (_, mfix_op')
+            <- tcSyntaxOp DoOrigin mfix_op
+                          [synKnownType (mkFunTy tup_ty stmts_ty)] mfix_res_ty $
+               \ _ -> return ()
+        ; mfix_res_ty <- readExpType mfix_res_ty
+
+        ; ((thing, new_res_ty), bind_op')
+            <- tcSyntaxOp DoOrigin bind_op
+                          [ synKnownType mfix_res_ty
+                          , synKnownType tup_ty `SynFun` SynRho ]
+                          res_ty $
+               \ [new_res_ty] ->
+               do { thing <- thing_inside (mkCheckExpType new_res_ty)
+                  ; return (thing, new_res_ty) }
 
         ; let rec_ids = takeList rec_names tup_ids
         ; later_ids <- tcLookupLocalIds later_names
@@ -878,6 +923,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names
         ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids
                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
+                          , recS_bind_ty = new_res_ty
                           , recS_later_rets = [], recS_rec_rets = tup_rets
                           , recS_ret_ty = stmts_ty }, thing)
         }}
@@ -887,20 +933,6 @@ tcDoStmt _ stmt _ _
 
 
 
-{-
-Note [Treat rebindable syntax first]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-When typechecking
-        do { bar; ... } :: IO ()
-we want to typecheck 'bar' in the knowledge that it should be an IO thing,
-pushing info from the context into the RHS.  To do this, we check the
-rebindable syntax first, and push that information into (tcMonoExprNC rhs).
-Otherwise the error shows up when cheking the rebindable syntax, and
-the expected/inferred stuff is back to front (see Trac #3613).
--}
-
-
-
 ---------------------------------------------------
 -- MonadFail Proposal warnings
 ---------------------------------------------------
@@ -912,9 +944,9 @@ the expected/inferred stuff is back to front (see Trac #3613).
 
 tcMonadFailOp :: CtOrigin
               -> LPat TcId
-              -> HsExpr Name         -- The fail op
+              -> SyntaxExpr Name     -- The fail op
               -> TcType              -- Type of the whole do-expression
-              -> TcRn (HsExpr TcId)  -- Typechecked fail op
+              -> TcRn (SyntaxExpr TcId)  -- Typechecked fail op
 -- Get a 'fail' operator expression, to use if the pattern
 -- match fails. If the pattern is irrefutatable, just return
 -- noSyntaxExpr; it won't be used
@@ -935,7 +967,8 @@ tcMonadFailOp orig pat fail_op res_ty
               -> return ()
 
         -- Get the fail op itself
-        ; tcSyntaxOp orig fail_op (mkFunTy stringTy res_ty) }
+        ; snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
+                             (mkCheckExpType res_ty) $ \_ -> return ()) }
 
 emitMonadFailConstraint :: LPat TcId -> TcType -> TcRn ()
 emitMonadFailConstraint pat res_ty
@@ -959,6 +992,16 @@ warnRebindableClash pattern = addWarnAt (getLoc pattern)
              text "compile with -Wno-missing-monadfail-instances."))
 
 {-
+Note [Treat rebindable syntax first]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When typechecking
+        do { bar; ... } :: IO ()
+we want to typecheck 'bar' in the knowledge that it should be an IO thing,
+pushing info from the context into the RHS.  To do this, we check the
+rebindable syntax first, and push that information into (tcMonoExprNC rhs).
+Otherwise the error shows up when cheking the rebindable syntax, and
+the expected/inferred stuff is back to front (see Trac #3613).
+
 Note [typechecking ApplicativeStmt]
 
 join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
@@ -978,15 +1021,15 @@ join :: tn -> res_ty
 -}
 tcApplicativeStmts
   :: HsStmtContext Name
-  -> [(HsExpr Name, ApplicativeArg Name Name)]
-  -> Type                               -- rhs_ty
-  -> (Type -> TcM t)                    -- thing_inside
-  -> TcM ([(HsExpr TcId, ApplicativeArg TcId TcId)], Type, t)
+  -> [(SyntaxExpr Name, ApplicativeArg Name Name)]
+  -> ExpRhoType                         -- rhs_ty
+  -> (TcRhoType -> TcM t)               -- thing_inside
+  -> TcM ([(SyntaxExpr TcId, ApplicativeArg TcId TcId)], Type, t)
 
 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
  = do { body_ty <- newFlexiTyVarTy liftedTypeKind
       ; let arity = length pairs
-      ; ts <- replicateM (arity-1) $ newFlexiTyVarTy liftedTypeKind
+      ; ts <- replicateM (arity-1) $ newOpenInferExpType
       ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
       ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
       ; let fun_ty = mkFunTys pat_tys body_ty
@@ -1003,7 +1046,11 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
   where
     goOps _ [] = return []
     goOps t_left ((op,t_i,exp_ty) : ops)
-      = do { op' <- tcSyntaxOp DoOrigin op (mkFunTys [t_left, exp_ty] t_i)
+      = do { (_, op')
+               <- tcSyntaxOp DoOrigin op
+                             [synKnownType t_left, synKnownType exp_ty] t_i $
+                   \ _ -> return ()
+           ; t_i <- readExpType t_i
            ; ops' <- goOps t_i ops
            ; return (op' : ops') }
 
@@ -1018,12 +1065,12 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
            }
     goArgs ((ApplicativeArgOne pat rhs, pat_ty, exp_ty) : rest) thing_inside
       = do { let stmt :: ExprStmt Name
-                 stmt = BindStmt pat rhs noSyntaxExpr noSyntaxExpr
+                 stmt = mkBindStmt pat rhs
            ; setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $
              addErrCtxt (pprStmtInCtxt ctxt stmt) $
-               do { rhs' <- tcMonoExprNC rhs exp_ty
+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)
                   ; (pat',(pairs, thing)) <-
-                      tcPat (StmtCtxt ctxt) pat pat_ty $
+                      tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                       popErrCtxt $
                       goArgs rest thing_inside
                   ; return (ApplicativeArgOne pat' rhs' : pairs, thing) } }
@@ -1031,10 +1078,11 @@ tcApplicativeStmts ctxt pairs rhs_ty thing_inside
     goArgs ((ApplicativeArgMany stmts ret pat, pat_ty, exp_ty) : rest)
             thing_inside
       = do { (stmts', (ret',pat',rest',thing))  <-
-                tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \res_ty  -> do
+                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $
+                \res_ty  -> do
                   { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty
                   ; (pat',(rest', thing)) <-
-                      tcPat (StmtCtxt ctxt) pat pat_ty $
+                      tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $
                         goArgs rest thing_inside
                   ; return (ret', pat', rest', thing)
                   }
index 5fea21d..a45cbbe 100644 (file)
@@ -2,7 +2,7 @@ module TcMatches where
 import HsSyn    ( GRHSs, MatchGroup, LHsExpr )
 import TcEvidence( HsWrapper )
 import Name     ( Name )
-import TcType   ( TcRhoType )
+import TcType   ( ExpRhoType, TcRhoType )
 import TcRnTypes( TcM, TcId )
 --import SrcLoc   ( Located )
 
@@ -12,5 +12,5 @@ tcGRHSsPat    :: GRHSs Name (LHsExpr Name)
 
 tcMatchesFun :: Name
              -> MatchGroup Name (LHsExpr Name)
-             -> TcRhoType
+             -> ExpRhoType
              -> TcM (HsWrapper, MatchGroup TcId (LHsExpr TcId))
index 440691d..ce2d16a 100644 (file)
@@ -6,7 +6,7 @@
 TcPat: Typechecking patterns
 -}
 
-{-# LANGUAGE CPP, RankNTypes #-}
+{-# LANGUAGE CPP, RankNTypes, TupleSections #-}
 
 module TcPat ( tcLetPat
              , TcPragEnv, lookupPragEnv, emptyPragEnv
@@ -16,7 +16,7 @@ module TcPat ( tcLetPat
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigma )
+import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )
 
 import HsSyn
 import TcHsSyn
@@ -49,6 +49,7 @@ import Outputable
 import Maybes( orElse )
 import qualified GHC.LanguageExtensions as LangExt
 import Control.Monad
+import Control.Arrow  ( second )
 
 {-
 ************************************************************************
@@ -59,7 +60,7 @@ import Control.Monad
 -}
 
 tcLetPat :: TcSigFun -> LetBndrSpec
-         -> LPat Name -> TcSigmaType
+         -> LPat Name -> ExpSigmaType
          -> TcM a
          -> TcM (LPat TcId, a)
 tcLetPat sig_fn no_gen pat pat_ty thing_inside
@@ -72,7 +73,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
 -----------------
 tcPats :: HsMatchContext Name
        -> [LPat Name]            -- Patterns,
-       -> [TcSigmaType]          --   and their types
+       -> [ExpSigmaType]         --   and their types
        -> TcM a                  --   and the checker for the body
        -> TcM ([LPat TcId], a)
 
@@ -93,7 +94,7 @@ tcPats ctxt pats pat_tys thing_inside
     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }
 
 tcPat :: HsMatchContext Name
-      -> LPat Name -> TcSigmaType
+      -> LPat Name -> ExpSigmaType
       -> TcM a                     -- Checker for body
       -> TcM (LPat TcId, a)
 tcPat ctxt = tcPat_O ctxt PatOrigin
@@ -101,7 +102,7 @@ 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
+        -> LPat Name -> ExpSigmaType
         -> TcM a                 -- Checker for body
         -> TcM (LPat TcId, a)
 tcPat_O ctxt orig pat pat_ty thing_inside
@@ -157,7 +158,7 @@ lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []
 *                                                                      *
 ********************************************************************* -}
 
-tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (TcCoercionN, TcId)
+tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (TcCoercionN, TcId)
 -- (coi, xp) = tcPatBndr penv x pat_ty
 -- Then coi : pat_ty ~ typeof(xp)
 --
@@ -172,12 +173,14 @@ tcPatBndr (PE { pe_ctxt = LetPat lookup_sig no_gen}) bndr_name pat_ty
        ; return (co, bndr_id) }
 
   | otherwise
-  = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
+  = do { pat_ty <- expTypeToType pat_ty
+       ; bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty
        ; traceTc "tcPatBndr(no-sig)" (ppr bndr_id $$ ppr (idType bndr_id))
        ; return (mkTcNomReflCo pat_ty, bndr_id) }
 
 tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty
-  = return (mkTcNomReflCo pat_ty, mkLocalId bndr_name pat_ty)
+  = do { pat_ty <- expTypeToType pat_ty
+       ; return (mkTcNomReflCo pat_ty, mkLocalId bndr_name pat_ty) }
                -- whether or not there is a sig is irrelevant, as this
                -- is local
 
@@ -298,7 +301,7 @@ tcMultiple tc_pat args penv thing_inside
 
 --------------------
 tc_lpat :: LPat Name
-        -> TcSigmaType
+        -> ExpSigmaType
         -> PatEnv
         -> TcM a
         -> TcM (LPat TcId, a)
@@ -309,7 +312,7 @@ tc_lpat (L span pat) pat_ty penv thing_inside
         ; return (L span pat', res) }
 
 tc_lpats :: PatEnv
-         -> [LPat Name] -> [TcSigmaType]
+         -> [LPat Name] -> [ExpSigmaType]
          -> TcM a
          -> TcM ([LPat TcId], a)
 tc_lpats penv pats tys thing_inside
@@ -321,7 +324,7 @@ tc_lpats penv pats tys thing_inside
 --------------------
 tc_pat  :: PatEnv
         -> Pat Name
-        -> TcSigmaType  -- Fully refined result type
+        -> ExpSigmaType  -- Fully refined result type
         -> TcM a                -- Thing inside
         -> TcM (Pat TcId,       -- Translated pattern
                 a)              -- Result of thing inside
@@ -329,6 +332,7 @@ tc_pat  :: PatEnv
 tc_pat penv (VarPat (L l name)) pat_ty thing_inside
   = do  { (co, id) <- tcPatBndr penv name pat_ty
         ; res <- tcExtendIdEnv1 name id thing_inside
+        ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPatCo co (VarPat (L l id)) pat_ty, res) }
 
 tc_pat penv (ParPat pat) pat_ty thing_inside
@@ -354,19 +358,21 @@ tc_pat penv lpat@(LazyPat pat) pat_ty thing_inside
                lazyUnliftedPatErr lpat
 
         -- Check that the expected pattern type is itself lifted
-        ; pat_ty' <- newFlexiTyVarTy liftedTypeKind
-        ; _ <- unifyType noThing pat_ty pat_ty'
+        ; pat_ty <- readExpType pat_ty
+        ; _ <- unifyType noThing (typeKind pat_ty) liftedTypeKind
 
         ; return (LazyPat pat', res) }
 
 tc_pat _ (WildPat _) pat_ty thing_inside
   = do  { res <- thing_inside
+        ; pat_ty <- expTypeToType pat_ty
         ; return (WildPat pat_ty, res) }
 
 tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
   = do  { (co, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)
         ; (pat', res) <- tcExtendIdEnv1 name bndr_id $
-                         tc_lpat pat (idType bndr_id) penv thing_inside
+                         tc_lpat pat (mkCheckExpType $ idType bndr_id)
+                                 penv thing_inside
             -- NB: if we do inference on:
             --          \ (y@(x::forall a. a->a)) = e
             -- we'll fail.  The as-pattern infers a monotype for 'y', which then
@@ -374,6 +380,7 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside
             -- perhaps be fixed, but only with a bit more work.
             --
             -- If you fix it, don't forget the bindInstsOfPatIds!
+        ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPatCo co (AsPat (L nm_loc bndr_id) pat') pat_ty, res) }
 
 tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
@@ -382,15 +389,27 @@ tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside
          -- where overall_pat_ty is an instance of OPT'.
         ; (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 ->
-                tcSubTypeDS_O (exprCtOrigin (unLoc expr)) GenSigCtxt (Just expr)
-                              expr'_inferred
-                              (mkFunTy overall_pat_ty pat_ty)
-
-         -- pattern must have pat_ty
-        ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside
-
+         -- expression must be a function
+        ; let expr_orig = exprCtOrigin (unLoc expr)
+              herald    = text "A view pattern expression expects"
+        ; (expr_wrap1, [inf_arg_ty], inf_res_ty)
+            <- matchActualFunTys herald expr_orig (Just expr) 1 expr'_inferred
+            -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)
+
+         -- check that overall pattern is more polymorphic than arg type
+        ; let pat_origin = GivenOrigin (SigSkol GenSigCtxt overall_pat_ty)
+        ; expr_wrap2 <- tcSubTypeET pat_origin overall_pat_ty inf_arg_ty
+            -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty
+
+         -- pattern must have inf_res_ty
+        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside
+
+        ; overall_pat_ty <- readExpType overall_pat_ty
+        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper
+                                    overall_pat_ty inf_res_ty
+               -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"
+               --                (overall_pat_ty -> inf_res_ty)
+              expr_wrap = expr_wrap2' <.> expr_wrap1
         ; return (ViewPat (mkLHsWrap expr_wrap expr') pat' overall_pat_ty, res) }
 
 -- Type signatures in patterns
@@ -400,31 +419,37 @@ tc_pat penv (SigPatIn pat sig_ty) pat_ty thing_inside
                                                             sig_ty pat_ty
         ; (pat', res) <- tcExtendTyVarEnv2 wcs      $
                          tcExtendTyVarEnv  tv_binds $
-                         tc_lpat pat inner_ty penv thing_inside
+                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside
+        ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) }
 
 ------------------------
 -- Lists, tuples, arrays
 tc_pat penv (ListPat pats _ Nothing) pat_ty thing_inside
   = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty
-        ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
                                      pats penv thing_inside
+        ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat coi (ListPat pats' elt_ty Nothing) pat_ty, res)
         }
 
 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 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)
+  = do  { tau_pat_ty <- expTypeToType pat_ty
+        ; ((pats', res, elt_ty), e')
+            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]
+                                          SynList $
+                 \ [elt_ty] ->
+                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
+                                                 pats penv thing_inside
+                    ; return (pats', res, elt_ty) }
+        ; return (ListPat pats' elt_ty (Just (tau_pat_ty,e')), res)
         }
 
 tc_pat penv (PArrPat pats _) pat_ty thing_inside
   = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedPArrTy penv pat_ty
-        ; (pats', res) <- tcMultiple (\p -> tc_lpat p elt_ty)
+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))
                                      pats penv thing_inside
+        ; pat_ty <- readExpType pat_ty
         ; return (mkHsWrapPat coi (PArrPat pats' elt_ty) pat_ty, res)
         }
 
@@ -437,7 +462,8 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
                      -- See Note [Unboxed tuple levity vars] in TyCon
         ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys
                                            Boxed   -> arg_tys
-        ; (pats', res) <- tc_lpats penv pats con_arg_tys thing_inside
+        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)
+                                   thing_inside
 
         ; dflags <- getDynFlags
 
@@ -453,6 +479,7 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
                   isBoxed boxity            = LazyPat (noLoc unmangled_result)
                 | otherwise                 = unmangled_result
 
+        ; pat_ty <- readExpType pat_ty
         ; ASSERT( length con_arg_tys == length pats ) -- Syntactically enforced
           return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
         }
@@ -469,58 +496,120 @@ tc_pat _ (LitPat simple_lit) pat_ty thing_inside
         ; co <- unifyPatType simple_lit lit_ty pat_ty
                 -- coi is of kind: pat_ty ~ lit_ty
         ; res <- thing_inside
+        ; pat_ty <- readExpType pat_ty
         ; return ( mkHsWrapPatCo co (LitPat simple_lit) pat_ty
                  , res) }
 
 ------------------------
 -- Overloaded patterns: n, and n+k
-tc_pat (PE { pe_orig = pat_orig })
-       (NPat (L l over_lit) mb_neg eq) pat_ty thing_inside
+
+-- In the case of a negative literal (the more complicated case),
+-- we get
+--
+--   case v of (-5) -> blah
+--
+-- becoming
+--
+--   if v == (negate (fromInteger 5)) then blah else ...
+--
+-- There are two bits of rebindable syntax:
+--   (==)   :: pat_ty -> neg_lit_ty -> Bool
+--   negate :: lit_ty -> neg_lit_ty
+-- where lit_ty is the type of the overloaded literal 5.
+--
+-- When there is no negation, neg_lit_ty and lit_ty are the same
+tc_pat _ (NPat (L l over_lit) mb_neg eq _) pat_ty thing_inside
   = do  { let orig = LiteralOrigin over_lit
-        ; (wrap, lit') <- newOverloadedLit over_lit pat_ty pat_orig
-        ; eq'     <- tcSyntaxOp orig eq (mkFunTys [pat_ty, pat_ty] boolTy)
-        ; mb_neg' <- case mb_neg of
-                        Nothing  -> return Nothing      -- Positive literal
-                        Just neg ->     -- Negative literal
-                                        -- The 'negate' is re-mappable syntax
-                            do { neg' <- tcSyntaxOp orig neg (mkFunTy pat_ty pat_ty)
-                               ; return (Just neg') }
+        ; ((lit', mb_neg'), eq')
+            <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]
+                          (mkCheckExpType boolTy) $
+               \ [neg_lit_ty] ->
+               let new_over_lit lit_ty = newOverloadedLit over_lit
+                                           (mkCheckExpType lit_ty)
+               in case mb_neg of
+                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty
+                 Just neg -> -- Negative literal
+                             -- The 'negate' is re-mappable syntax
+                   second Just <$>
+                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $
+                    \ [lit_ty] -> new_over_lit lit_ty)
+
         ; res <- thing_inside
-        ; return (mkHsWrapPat wrap (NPat (L l lit') mb_neg' eq') pat_ty, res) }
+        ; pat_ty <- readExpType pat_ty
+        ; return (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)
-        ; let pat_ty' = idType bndr_id
-              orig    = LiteralOrigin lit
-        ; (wrap_lit, lit') <- newOverloadedLit lit pat_ty' (pe_orig penv)
-
-        -- 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' = mkHsWrapPat wrap_lit
-                                 (NPlusKPat (L nm_loc bndr_id)
-                                            (L loc lit')
-                                            ge' minus')
-                                 pat_ty
+{-
+Note [NPlusK patterns]
+~~~~~~~~~~~~~~~~~~~~~~
+From
+
+  case v of x + 5 -> blah
+
+we get
+
+  if v >= 5 then (\x -> blah) (v - 5) else ...
+
+There are two bits of rebindable syntax:
+  (>=) :: pat_ty -> lit1_ty -> Bool
+  (-)  :: pat_ty -> lit2_ty -> var_ty
+
+lit1_ty and lit2_ty could conceivably be different.
+var_ty is the type inferred for x, the variable in the pattern.
+
+If the pushed-down pattern type isn't a tau-type, the two pat_ty's above
+could conceivably be different specializations. But this is very much
+like the situation in Note [Case branches must be taus] in TcMatches.
+So we tauify the pat_ty before proceeding.
+
+Note that we need to type-check the literal twice, because it is used
+twice, and may be used at different types. The second HsOverLit stored in the
+AST is used for the subtraction operation.
+-}
+
+-- See Note [NPlusK patterns]
+tc_pat penv (NPlusKPat (L nm_loc name) (L loc lit) _ ge minus _) pat_ty thing_inside
+  = do  { pat_ty <- expTypeToType pat_ty
+        ; let orig = LiteralOrigin lit
+        ; (lit1', ge')
+            <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]
+                                  (mkCheckExpType boolTy) $
+               \ [lit1_ty] ->
+               newOverloadedLit lit (mkCheckExpType lit1_ty)
+        ; ((lit2', minus_wrap, bndr_id), minus')
+            <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $
+               \ [lit2_ty, var_ty] ->
+               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)
+                  ; (co, bndr_id) <- setSrcSpan nm_loc $
+                                     tcPatBndr penv name (mkCheckExpType var_ty)
+                           -- co :: var_ty ~ idType bndr_id
+
+                           -- minus_wrap is applicable to minus'
+                  ; return (lit2', mkWpCastN co, bndr_id) }
 
         -- The Report says that n+k patterns must be in Integral
-        -- We may not want this when using re-mappable syntax, though (ToDo?)
-        ; icls <- tcLookupClass integralClassName
-        ; instStupidTheta orig [mkClassPred icls [pat_ty']]
+        -- but it's silly to insist on this in the RebindableSyntax case
+        ; unlessM (xoptM LangExt.RebindableSyntax) $
+          do { icls <- tcLookupClass integralClassName
+             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }
 
         ; res <- tcExtendIdEnv1 name bndr_id thing_inside
-        ; return (mkHsWrapPatCo co pat' pat_ty, res) }
+
+        ; let minus'' = minus' { syn_res_wrap