.gitlab-ci.yml

@@ -26,19 +26,18 @@ stages:
   - testing     # head.hackage correctness and compiler performance testing
   - deploy      # push documentation
 
-# N.B.Don't run on wip/ branches, instead on run on merge requests.
-.only-default: &only-default
-  only:
-    - master
-    - /ghc-[0-9]+\.[0-9]+/
-    - merge_requests
-    - tags
-    - web
+workflow:
+  # N.B.Don't run on wip/ branches, instead on run on merge requests.
+  rules:
+    - if: $CI_MERGE_REQUEST_ID
+    - if: $CI_COMMIT_TAG
+    - if: '$CI_COMMIT_BRANCH == "master"'
+    - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
+    - if: '$CI_PIPELINE_SOURCE == "web"'
 
 .nightly: &nightly
-  only:
-    variables:
-      - $NIGHTLY
+  rules:
+    - if: $NIGHTLY
   artifacts:
     when: always
     expire_in: 8 weeks
@@ -50,9 +49,8 @@ stages:
   artifacts:
     when: always
     expire_in: 1 year
-  only:
-    variables:
-      - $RELEASE == "yes"
+  rules:
+    - if: '$RELEASE == "yes"'
 
 ############################################################
 # Runner Tags
@@ -86,13 +84,11 @@ ghc-linters:
   dependencies: []
   tags:
     - lint
-  only:
-    refs:
-      - merge_requests
+  rules:
+    - if: $CI_MERGE_REQUEST_ID
 
 # Run mypy Python typechecker on linter scripts.
 lint-linters:
-  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
   script:
@@ -103,7 +99,6 @@ lint-linters:
 
 # Check that .T files all parse by listing broken tests.
 lint-testsuite:
-  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
   script:
@@ -114,7 +109,6 @@ lint-testsuite:
 
 # Run mypy Python typechecker on testsuite driver
 typecheck-testsuite:
-  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
   script:
@@ -127,7 +121,6 @@ typecheck-testsuite:
 # accommodate, e.g., haddock changes not yet upstream) but not on `master` or
 # Marge jobs.
 .lint-submods:
-  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
   script:
@@ -140,25 +133,14 @@ typecheck-testsuite:
   tags:
     - lint
 
-lint-submods-marge:
+lint-submods:
   extends: .lint-submods
-  only:
-    refs:
-      - merge_requests
-    variables:
-      - "$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/"
-
-lint-submods-mr:
-  extends: .lint-submods
-  # Allow failure since any necessary submodule patches may not be upstreamed
-  # yet.
-  allow_failure: true
-  only:
-    refs:
-      - merge_requests
-  except:
-    variables:
-      - "$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/"
+  # Allow failure on merge requests since any necessary submodule patches may
+  # not be upstreamed yet.
+  rules:
+    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*marge_bot_batch_merge_job.*/'
+      allow_failure: false
+    - allow_failure: true
 
 lint-submods-branch:
   extends: .lint-submods
@@ -166,13 +148,11 @@ lint-submods-branch:
     - "echo Linting submodule changes between $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA"
     - git submodule foreach git remote update
     - submodchecker . $(git rev-list $CI_COMMIT_BEFORE_SHA..$CI_COMMIT_SHA)
-  only:
-    refs:
-      - master
-      - /ghc-[0-9]+\.[0-9]+/
+  rules:
+    - if: '$CI_COMMIT_BRANCH == "master"'
+    - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
 
 .lint-changelogs:
-  <<: *only-default
   stage: lint
   image: "registry.gitlab.haskell.org/ghc/ci-images/linters:$DOCKER_REV"
   dependencies: []
@@ -185,15 +165,13 @@ lint-changelogs:
   extends: .lint-changelogs
   # Allow failure since this isn't a final release.
   allow_failure: true
-  only:
-    refs:
-      - /ghc-[0-9]+\.[0-9]+/
+  rules:
+    - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
 
 lint-release-changelogs:
   extends: .lint-changelogs
-  only:
-    refs:
-      - /ghc-[0-9]+\.[0-9]+\.[0-9]+-.*/
+  rules:
+    - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
 
 
 ############################################################
@@ -201,7 +179,6 @@ lint-release-changelogs:
 ############################################################
 
 .validate-hadrian:
-  <<: *only-default
   variables:
     FLAVOUR: "validate"
   script:
@@ -250,7 +227,6 @@ validate-x86_64-linux-deb9-unreg-hadrian:
     TEST_ENV: "x86_64-linux-deb9-unreg-hadrian"
 
 hadrian-ghc-in-ghci:
-  <<: *only-default
   stage: quick-build
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
   before_script:
@@ -283,7 +259,6 @@ hadrian-ghc-in-ghci:
 ############################################################
 
 .validate:
-  <<: *only-default
   variables:
     TEST_TYPE: test
     MAKE_ARGS: "-Werror"
@@ -317,8 +292,8 @@ hadrian-ghc-in-ghci:
     # porting guide [1].
     # [1] https://www.freebsd.org/doc/en/books/porters-handbook/using-iconv.html)
     CONFIGURE_ARGS: "--with-gmp-includes=/usr/local/include --with-gmp-libraries=/usr/local/lib --with-iconv-includes=/usr/local/include --with-iconv-libraries=/usr/local/lib"
-    GHC_VERSION: 8.6.3
-    CABAL_INSTALL_VERSION: 3.0.0.0
+    GHC_VERSION: 8.10.1
+    CABAL_INSTALL_VERSION: 3.2.0.0
     BIN_DIST_PREP_TAR_COMP: "ghc-x86_64-portbld-freebsd.tar.xz"
     TEST_ENV: "x86_64-freebsd"
     BUILD_FLAVOUR: "validate"
@@ -334,10 +309,12 @@ hadrian-ghc-in-ghci:
       - cabal-cache
       - toolchain
 
-# Disabled due to lack of builder capacity
-.validate-x86_64-freebsd:
+# Conditional due to lack of builder capacity
+validate-x86_64-freebsd:
   extends: .build-x86_64-freebsd
   stage: full-build
+  rules:
+    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*FreeBSD.*/'
 
 nightly-x86_64-freebsd:
   <<: *nightly
@@ -414,7 +391,6 @@ validate-x86_64-darwin:
 
 # Disabled because of OS X CI capacity
 .validate-x86_64-darwin-hadrian:
-  <<: *only-default
   stage: full-build
   tags:
     - x86_64-darwin
@@ -777,7 +753,6 @@ validate-x86_64-linux-fedora27:
 ############################################################
 
 .build-windows:
-  <<: *only-default
   # For the reasons given in #17777 this build isn't reliable.
   allow_failure: true
   before_script:
@@ -951,7 +926,6 @@ nightly-i386-windows:
 
 # See Note [Cleanup after shell executor]
 cleanup-darwin:
-  <<: *only-default
   stage: cleanup
   tags:
     - x86_64-darwin
@@ -973,7 +947,6 @@ cleanup-darwin:
 ############################################################
 
 doc-tarball:
-  <<: *only-default
   stage: packaging
   tags:
     - x86_64-linux
@@ -1013,10 +986,10 @@ source-tarball:
   tags:
     - x86_64-linux
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
-  when: always
   dependencies: []
-  only:
-    - tags
+  rules:
+    - if: $CI_COMMIT_TAG
+      when: always
   artifacts:
     paths:
       - ghc-*.tar.xz
@@ -1043,7 +1016,6 @@ source-tarball:
 # pipeline.
 
 .hackage:
-  <<: *only-default
   stage: testing
   image: ghcci/x86_64-linux-deb9:0.2
   tags:
@@ -1060,9 +1032,8 @@ hackage:
 
 hackage-label:
   extends: .hackage
-  only:
-    variables:
-      - $CI_MERGE_REQUEST_LABELS =~ /.*user-facing.*/
+  rules:
+    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*user-facing.*/'
 
 nightly-hackage:
   <<: *nightly
@@ -1077,11 +1048,10 @@ perf-nofib:
   dependencies:
     - validate-x86_64-linux-deb9-dwarf
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
-  only:
-    refs:
-      - merge_requests
-      - master
-      - /ghc-[0-9]+\.[0-9]+/
+  rules:
+    - if: $CI_MERGE_REQUEST_ID
+    - if: '$CI_COMMIT_BRANCH == "master"'
+    - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
   tags:
     - x86_64-linux
   script:
@@ -1130,8 +1100,8 @@ pages:
       <meta http-equiv="refresh" content="1; url=doc/">
       EOF
     - cp -f index.html public/doc
-  only:
-    - master
+  rules:
+    - if: '$CI_COMMIT_BRANCH == "master"'
   artifacts:
     paths:
       - public

.gitlab/ci.sh

@@ -139,12 +139,6 @@ function set_toolchain_paths() {
   export CABAL
   export HAPPY
   export ALEX
-
-  # FIXME: Temporarily use ghc from ports
-  case "$(uname)" in
-    FreeBSD) GHC="/usr/local/bin/ghc" ;;
-    *) ;;
-  esac
 }
 
 # Extract GHC toolchain

compiler/GHC/Core/Coercion/Opt.hs

@@ -559,8 +559,9 @@ opt_univ env sym prov role oty1 oty2
       PluginProv _       -> prov
 
 -------------
-opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
-opt_transList is = zipWith (opt_trans is)
+opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]
+opt_transList is = zipWithEqual "opt_transList" (opt_trans is)
+  -- The input lists must have identical length.
 
 opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo
 opt_trans is co1 co2
@@ -659,14 +660,12 @@ opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
 -- Eta rules
 opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
   | Just cos2 <- etaTyConAppCo_maybe tc co2
-  = ASSERT( cos1 `equalLength` cos2 )
-    fireTransRule "EtaCompL" co1 co2 $
+  = fireTransRule "EtaCompL" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
 opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
   | Just cos1 <- etaTyConAppCo_maybe tc co1
-  = ASSERT( cos1 `equalLength` cos2 )
-    fireTransRule "EtaCompR" co1 co2 $
+  = fireTransRule "EtaCompR" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
 opt_trans_rule is co1@(AppCo co1a co1b) co2

compiler/GHC/Core/Lint.hs

@@ -2030,21 +2030,21 @@ lintCoercion the_co@(LRCo lr co)
 lintCoercion (InstCo co arg)
   = do { co'  <- lintCoercion co
        ; arg' <- lintCoercion arg
-       ; let Pair t1' t2' = coercionKind co'
-             Pair s1  s2  = coercionKind arg
+       ; let Pair t1 t2 = coercionKind co'
+             Pair s1 s2 = coercionKind arg'
 
        ; lintRole arg Nominal (coercionRole arg')
 
-      ; case (splitForAllTy_ty_maybe t1', splitForAllTy_ty_maybe t2') of
+      ; case (splitForAllTy_ty_maybe t1, splitForAllTy_ty_maybe t2) of
          -- forall over tvar
          { (Just (tv1,_), Just (tv2,_))
              | typeKind s1 `eqType` tyVarKind tv1
              , typeKind s2 `eqType` tyVarKind tv2
              -> return (InstCo co' arg')
              | otherwise
-             -> failWithL (text "Kind mis-match in inst coercion")
+             -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co)
 
-         ; _ -> case (splitForAllTy_co_maybe t1', splitForAllTy_co_maybe t2') of
+         ; _ -> case (splitForAllTy_co_maybe t1, splitForAllTy_co_maybe t2) of
          -- forall over covar
          { (Just (cv1, _), Just (cv2, _))
              | typeKind s1 `eqType` varType cv1
@@ -2053,7 +2053,7 @@ lintCoercion (InstCo co arg)
              , CoercionTy _ <- s2
              -> return (InstCo co' arg')
              | otherwise
-             -> failWithL (text "Kind mis-match in inst coercion")
+             -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co)
 
          ; _ -> failWithL (text "Bad argument of inst") }}}
 

compiler/GHC/Core/Op/FloatIn.hs

@@ -169,7 +169,9 @@ fiExpr platform to_drop ann_expr@(_,AnnApp {})
   = wrapFloats drop_here $ wrapFloats extra_drop $
     mkTicks ticks $
     mkApps (fiExpr platform fun_drop ann_fun)
-           (zipWith (fiExpr platform) arg_drops ann_args)
+           (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)
+           -- use zipWithEqual, we should have
+           -- length ann_args = length arg_fvs = length arg_drops
   where
     (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr
     fun_ty  = exprType (deAnnotate ann_fun)
@@ -466,7 +468,8 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
   = wrapFloats drop_here1 $
     wrapFloats drop_here2 $
     Case (fiExpr platform scrut_drops scrut) case_bndr ty
-         (zipWith fi_alt alts_drops_s alts)
+         (zipWithEqual "fiExpr" fi_alt alts_drops_s alts)
+         -- use zipWithEqual, we should have length alts_drops_s = length alts
   where
         -- Float into the scrut and alts-considered-together just like App
     [drop_here1, scrut_drops, alts_drops]

compiler/GHC/Core/Op/OccurAnal.hs

@@ -1319,7 +1319,7 @@ mkLoopBreakerNodes :: OccEnv -> TopLevelFlag
 --   d) adjust each RHS's usage details according to
 --      the binder's (new) shotness and join-point-hood
 mkLoopBreakerNodes env lvl bndr_set body_uds details_s
-  = (final_uds, zipWith mk_lb_node details_s bndrs')
+  = (final_uds, zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')
   where
     (final_uds, bndrs')
        = tagRecBinders lvl body_uds

compiler/GHC/Core/Op/SpecConstr.hs

@@ -1311,7 +1311,9 @@ scExpr' env (Let (Rec prs) body)
                 -- See Note [Local recursive groups]
 
         ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]
-              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))
+              bind'   = Rec (concat (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))
+                        -- zipWithEqual: length of returned [SpecInfo]
+                        -- should be the same as incoming [RhsInfo]
 
         ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },
                   Let bind' body') }

compiler/GHC/Core/Op/WorkWrap/Lib.hs

@@ -653,8 +653,7 @@ nop_fn body = body
 addDataConStrictness :: DataCon -> [Demand] -> [Demand]
 -- See Note [Add demands for strict constructors]
 addDataConStrictness con ds
-  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )
-    zipWith add ds strs
+  = zipWithEqual "addDataConStrictness" add ds strs
   where
     strs = dataConRepStrictness con
     add dmd str | isMarkedStrict str = strictifyDmd dmd

compiler/GHC/Core/Ppr.hs

@@ -123,11 +123,13 @@ ppr_binding ann (val_bdr, expr)
          , pp_bind
          ]
   where
+    pp_val_bdr = pprPrefixOcc val_bdr
+
     pp_bind = case bndrIsJoin_maybe val_bdr of
                 Nothing -> pp_normal_bind
                 Just ar -> pp_join_bind ar
 
-    pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr)
+    pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
 
       -- For a join point of join arity n, we want to print j = \x1 ... xn -> e
       -- as "j x1 ... xn = e" to differentiate when a join point returns a
@@ -135,7 +137,7 @@ ppr_binding ann (val_bdr, expr)
       -- an n-argument function).
     pp_join_bind join_arity
       | bndrs `lengthAtLeast` join_arity
-      = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
+      = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
            2 (equals <+> pprCoreExpr rhs)
       | otherwise -- Yikes!  A join-binding with too few lambda
                   -- Lint will complain, but we don't want to crash
@@ -164,8 +166,10 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
         -- an atomic value (e.g. function args)
 
 ppr_expr add_par (Var name)
- | isJoinId name               = add_par ((text "jump") <+> ppr name)
- | otherwise                   = ppr name
+ | isJoinId name               = add_par ((text "jump") <+> pp_name)
+ | otherwise                   = pp_name
+ where
+   pp_name = pprPrefixOcc name
 ppr_expr add_par (Type ty)     = add_par (text "TYPE:" <+> ppr ty)       -- Weird
 ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
 ppr_expr add_par (Lit lit)     = pprLiteral add_par lit
@@ -429,7 +433,7 @@ pprKindedTyVarBndr tyvar
 -- pprIdBndr does *not* print the type
 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 pprIdBndr :: Id -> SDoc
-pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id)
 
 pprIdBndrInfo :: IdInfo -> SDoc
 pprIdBndrInfo info

compiler/GHC/Core/Type.hs

@@ -1856,14 +1856,16 @@ fun_kind_arg_flags = go emptyTCvSubst
                         -- something is ill-kinded. But this can happen
                         -- when printing errors. Assume everything is Required.
 
--- @isTauTy@ tests if a type has no foralls
+-- @isTauTy@ tests if a type has no foralls or (=>)
 isTauTy :: Type -> Bool
 isTauTy ty | Just ty' <- coreView ty = isTauTy ty'
 isTauTy (TyVarTy _)           = True
 isTauTy (LitTy {})            = True
 isTauTy (TyConApp tc tys)     = all isTauTy tys && isTauTyCon tc
 isTauTy (AppTy a b)           = isTauTy a && isTauTy b
-isTauTy (FunTy _ a b)         = isTauTy a && isTauTy b
+isTauTy (FunTy af a b)        = case af of
+                                  InvisArg -> False
+                                  VisArg   -> isTauTy a && isTauTy b
 isTauTy (ForAllTy {})         = False
 isTauTy (CastTy ty _)         = isTauTy ty
 isTauTy (CoercionTy _)        = False  -- Not sure about this

compiler/GHC/Driver/Main.hs

@@ -1440,7 +1440,7 @@ hscGenHardCode hsc_env cgguts location output_filename = do
 
             ------------------  Code output -----------------------
             rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
-                      lookupHook cmmToRawCmmHook
+                      lookupHook (\x -> cmmToRawCmmHook x)
                         (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms
 
             let dump a = do
@@ -1512,7 +1512,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
         unless (null cmmgroup) $
           dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"
             FormatCMM (ppr cmmgroup)
-        rawCmms <- lookupHook cmmToRawCmmHook
+        rawCmms <- lookupHook (\x -> cmmToRawCmmHook x)
                      (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup)
         _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
              rawCmms

compiler/GHC/Hs/Binds.hs

@@ -739,8 +739,9 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
   = sdocOption sdocPrintTypecheckerElaboration $ \case
       False -> pprLHsBinds val_binds
       True  -> -- Show extra information (bug number: #10662)
-               hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)
-                                             <+> brackets (interpp'SP dictvars))
+               hang (text "AbsBinds"
+                     <+> sep [ brackets (interpp'SP tyvars)
+                             , brackets (interpp'SP dictvars) ])
                   2 $ braces $ vcat
                [ text "Exports:" <+>
                    brackets (sep (punctuate comma (map ppr exports)))
@@ -752,7 +753,7 @@ ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
 
 instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
-    = vcat [ ppr gbl <+> text "<=" <+> ppr lcl
+    = vcat [ sep [ ppr gbl, nest 2 (text "<=" <+> ppr lcl) ]
            , nest 2 (pprTcSpecPrags prags)
            , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ]
 

compiler/GHC/Hs/Expr.hs

@@ -1828,16 +1828,14 @@ data StmtLR idL idR body -- body should always be (LHs**** idR)
             -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLarrow'
 
   -- For details on above see note [Api annotations] in ApiAnnotation
-  | BindStmt (XBindStmt idL idR body) -- Post typechecking,
-                                -- result type of the function passed to bind;
-                                -- that is, S in (>>=) :: Q -> (R -> S) -> T
+  | BindStmt (XBindStmt idL idR body)
+             -- ^ Post renaming has optional fail and bind / (>>=) operator.
+             -- Post typechecking, also has result type of the
+             -- function passed to bind; that is, S in (>>=)
+             -- :: Q -> (R -> S) -> T
+             -- See Note [The type of bind in Stmts]
              (LPat idL)
              body
-             (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind in Stmts]
-             (SyntaxExpr idR) -- The fail operator
-             -- The fail operator is noSyntaxExpr
-             -- if the pattern match can't fail
-             -- See Note [NoSyntaxExpr] (2)
 
   -- | 'ApplicativeStmt' represents an applicative expression built with
   -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the
@@ -1950,8 +1948,19 @@ data RecStmtTc =
 type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField
 
 type instance XBindStmt        (GhcPass _) GhcPs b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcRn b = NoExtField
-type instance XBindStmt        (GhcPass _) GhcTc b = Type
+type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn
+type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc
+
+data XBindStmtRn = XBindStmtRn
+  { xbsrn_bindOp :: SyntaxExpr GhcRn
+  , xbsrn_failOp :: FailOperator GhcRn
+  }
+
+data XBindStmtTc = XBindStmtTc
+  { xbstc_bindOp :: SyntaxExpr GhcTc
+  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S
+  , xbstc_failOp :: FailOperator GhcTc
+  }
 
 type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField
 type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField
@@ -1994,34 +2003,55 @@ data ParStmtBlock idL idR
 type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField
 type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon
 
+-- | The fail operator
+--
+-- This is used for `.. <-` "bind statments" in do notation, including
+-- non-monadic "binds" in applicative.
+--
+-- The fail operator is 'Just expr' if it potentially fail monadically. if the
+-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete
+-- pattern exception), it is 'Nothing'.
+--
+-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of
+-- expression in the 'Just' case, and why it is so.
+--
+-- See Note [Failing pattern matches in Stmts] for which contexts for
+-- '@BindStmt@'s should use the monadic fail and which shouldn't.
+type FailOperator id = Maybe (SyntaxExpr id)
+
 -- | Applicative Argument
 data ApplicativeArg idL
   = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)
-    { xarg_app_arg_one  :: (XApplicativeArgOne idL)
-    , app_arg_pattern   :: (LPat idL) -- WildPat if it was a BodyStmt (see below)
-    , arg_expr          :: (LHsExpr idL)
-    , is_body_stmt      :: Bool -- True <=> was a BodyStmt
-                              -- False <=> was a BindStmt
-                              -- See Note [Applicative BodyStmt]
-    , fail_operator     :: (SyntaxExpr idL) -- The fail operator
-                         -- The fail operator is needed if this is a BindStmt
-                         -- where the pattern can fail. E.g.:
-                         -- (Just a) <- stmt
-                         -- The fail operator will be invoked if the pattern
-                         -- match fails.
-                         -- The fail operator is noSyntaxExpr
-                         -- if the pattern match can't fail
-                         -- See Note [NoSyntaxExpr] (2)
+    { xarg_app_arg_one  :: XApplicativeArgOne idL
+      -- ^ The fail operator, after renaming
+      --
+      -- The fail operator is needed if this is a BindStmt
+      -- where the pattern can fail. E.g.:
+      -- (Just a) <- stmt
+      -- The fail operator will be invoked if the pattern
+      -- match fails.
+      -- It is also used for guards in MonadComprehensions.
+      -- The fail operator is Nothing
+      -- if the pattern match can't fail
+    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)
+    , arg_expr          :: LHsExpr idL
+    , is_body_stmt      :: Bool
+      -- ^ True <=> was a BodyStmt,
+      -- False <=> was a BindStmt.
+      -- See Note [Applicative BodyStmt]
     }
   | ApplicativeArgMany     -- do { stmts; return vars }
-    { xarg_app_arg_many :: (XApplicativeArgMany idL)
+    { xarg_app_arg_many :: XApplicativeArgMany idL
     , app_stmts         :: [ExprLStmt idL] -- stmts
-    , final_expr        :: (HsExpr idL)    -- return (v1,..,vn), or just (v1,..,vn)
-    , bv_pattern        :: (LPat idL)      -- (v1,...,vn)
+    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)
+    , bv_pattern        :: LPat idL      -- (v1,...,vn)
     }
   | XApplicativeArg !(XXApplicativeArg idL)
 
-type instance XApplicativeArgOne  (GhcPass _) = NoExtField
+type instance XApplicativeArgOne GhcPs = NoExtField
+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn
+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc
+
 type instance XApplicativeArgMany (GhcPass _) = NoExtField
 type instance XXApplicativeArg    (GhcPass _) = NoExtCon
 
@@ -2212,7 +2242,7 @@ pprStmt (LastStmt _ expr m_dollar_stripped _)
         Just False -> text "return"
         Nothing -> 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))
@@ -2247,13 +2277,12 @@ pprStmt (ApplicativeStmt _ args mb_join)
    flattenStmt stmt = [ppr stmt]
 
    flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]
-   flattenArg (_, ApplicativeArgOne _ pat expr isBody _)
+   flattenArg (_, ApplicativeArgOne _ pat expr isBody)
      | isBody =  -- See Note [Applicative BodyStmt]
      [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
              :: ExprStmt (GhcPass idL))]
      | otherwise =
-     [ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
-             :: ExprStmt (GhcPass idL))]
+     [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]
    flattenArg (_, ApplicativeArgMany _ stmts _ _) =
      concatMap flattenStmt stmts
 
@@ -2273,13 +2302,12 @@ instance (OutputableBndrId idL)
   ppr = pprArg
 
 pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc
-pprArg (ApplicativeArgOne _ pat expr isBody _)
+pprArg (ApplicativeArgOne _ pat expr isBody)
   | isBody =  -- See Note [Applicative BodyStmt]
     ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr
             :: ExprStmt (GhcPass idL))
   | otherwise =
-    ppr (BindStmt (panic "pprStmt") pat expr noSyntaxExpr noSyntaxExpr
-            :: ExprStmt (GhcPass idL))
+    ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))
 pprArg (ApplicativeArgMany _ stmts return pat) =
      ppr pat <+>
      text "<-" <+>

compiler/GHC/Hs/Instances.hs

@@ -334,6 +334,9 @@ deriving instance Data PendingTcSplice
 deriving instance Data SyntaxExprRn
 deriving instance Data SyntaxExprTc
 
+deriving instance Data XBindStmtRn
+deriving instance Data XBindStmtTc
+
 -- ---------------------------------------------------------------------
 -- Data derivations from GHC.Hs.Lit ------------------------------------
 

compiler/GHC/Hs/Types.hs

@@ -204,8 +204,8 @@ A wildcard in a type can be
   * An anonymous wildcard,
         written '_'
     In HsType this is represented by HsWildCardTy.
-    The renamer leaves it untouched, and it is later given fresh meta tyvars in
-    the typechecker.
+    The renamer leaves it untouched, and it is later given a fresh
+    meta tyvars in the typechecker.
 
   * A named wildcard,
         written '_a', '_foo', etc

compiler/GHC/Hs/Utils.hs

@@ -69,7 +69,8 @@ module GHC.Hs.Utils(
   nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
 
   -- * Stmts
-  mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
+  mkTransformStmt, mkTransformByStmt, mkBodyStmt,
+  mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,
   mkLastStmt,
   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
   emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
@@ -259,10 +260,10 @@ mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR))
            -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
 mkBodyStmt :: Located (bodyR GhcPs)
            -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
-mkBindStmt :: IsPass idR => (XBindStmt (GhcPass idL) (GhcPass idR)
-                         (Located (bodyR (GhcPass idR))) ~ NoExtField)
-           => LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
-           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
+mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs)
+             -> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
+mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn)
+             -> StmtLR GhcRn GhcRn (Located (bodyR GhcRn))
 mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
              -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
 
@@ -320,9 +321,9 @@ mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = s
 mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr
 mkBodyStmt body
   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr
-mkBindStmt pat body
-  = BindStmt noExtField pat body noSyntaxExpr noSyntaxExpr
-mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
+mkPsBindStmt pat body = BindStmt noExtField pat body
+mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body
+mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr, xbstc_boundResultType =unitTy, xbstc_failOp = Nothing }) pat body
   -- don't use placeHolderTypeTc above, because that panics during zonking
 
 emptyRecStmt' :: forall idL idR body. IsPass idR
@@ -1059,7 +1060,7 @@ collectLStmtBinders = collectStmtBinders . unLoc
 collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
                    -> [IdP (GhcPass 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 _  binds)      = collectLocalBinders (unLoc binds)
 collectStmtBinders (BodyStmt {})           = []
 collectStmtBinders (LastStmt {})           = []
@@ -1349,7 +1350,7 @@ lStmtsImplicits = hs_lstmts
 
     hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
             -> [(SrcSpan, [Name])]
-    hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
+    hs_stmt (BindStmt _ pat _) = lPatImplicits pat
     hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args
       where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat
             do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts

compiler/GHC/HsToCore/Arrows.hs

@@ -866,7 +866,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) 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)

compiler/GHC/HsToCore/Binds.hs

@@ -145,13 +145,14 @@ dsHsBind dflags (VarBind { var_id = var
                           else []
         ; return (force_var, [core_bind]) }
 
-dsHsBind dflags b@(FunBind { fun_id = L _ fun
+dsHsBind dflags b@(FunBind { fun_id = L loc fun
                            , fun_matches = matches
                            , fun_ext = co_fn
                            , fun_tick = tick })
- = do   { (args, body) <- matchWrapper
-                           (mkPrefixFunRhs (noLoc $ idName fun))
-                           Nothing matches
+ = do   { (args, body) <- -- addTyCsDs (hsWrapDictBinders co_fn) $
+                          -- Omitting; part of !3087
+                          matchWrapper (mkPrefixFunRhs (L loc (idName fun)))
+                                       Nothing matches
         ; core_wrap <- dsHsWrapper co_fn
         ; let body' = mkOptTickBox tick body
               rhs   = core_wrap (mkLams args body')

compiler/GHC/HsToCore/Coverage.hs

@@ -709,12 +709,16 @@ addTickStmt _isGuard (LastStmt x e noret ret) = do
                 (addTickLHsExpr e)
                 (pure noret)
                 (addTickSyntaxExpr hpcSrcSpan ret)
-addTickStmt _isGuard (BindStmt x pat e bind fail) = do
-        liftM4 (BindStmt x)
+addTickStmt _isGuard (BindStmt xbs pat e) = do
+        liftM4 (\b f -> BindStmt $ XBindStmtTc
+                    { xbstc_bindOp = b
+                    , xbstc_boundResultType = xbstc_boundResultType xbs
+                    , xbstc_failOp = f
+                    })
+                (addTickSyntaxExpr hpcSrcSpan (xbstc_bindOp xbs))
+                (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))
                 (addTickLPat pat)
                 (addTickLHsExprRHS e)
-                (addTickSyntaxExpr hpcSrcSpan bind)
-                (addTickSyntaxExpr hpcSrcSpan fail)
 addTickStmt isGuard (BodyStmt x e bind' guard') = do
         liftM3 (BodyStmt x)
                 (addTick isGuard e)
@@ -763,12 +767,12 @@ addTickApplicativeArg
 addTickApplicativeArg isGuard (op, arg) =
   liftM2 (,) (addTickSyntaxExpr hpcSrcSpan op) (addTickArg arg)
  where
-  addTickArg (ApplicativeArgOne x pat expr isBody fail) =
-    (ApplicativeArgOne x)
-      <$> addTickLPat pat
+  addTickArg (ApplicativeArgOne m_fail pat expr isBody) =
+    ApplicativeArgOne
+      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail
+      <*> addTickLPat pat
       <*> addTickLHsExpr expr
       <*> pure isBody
-      <*> addTickSyntaxExpr hpcSrcSpan fail
   addTickArg (ApplicativeArgMany x stmts ret pat) =
     (ApplicativeArgMany x)
       <$> addTickLStmts isGuard stmts
@@ -938,12 +942,10 @@ addTickLCmdStmts' lstmts res
         binders = collectLStmtsBinders lstmts
 
 addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))
-addTickCmdStmt (BindStmt x pat c bind fail) = do
-        liftM4 (BindStmt x)
+addTickCmdStmt (BindStmt x pat c) = do
+        liftM2 (BindStmt x)
                 (addTickLPat pat)
                 (addTickLHsCmd c)
-                (return bind)
-                (return fail)
 addTickCmdStmt (LastStmt x c noret ret) = do
         liftM3 (LastStmt x)
                 (addTickLHsCmd c)

compiler/GHC/HsToCore/Expr.hs

@@ -280,7 +280,9 @@ dsExpr hswrap@(XExpr (HsWrap co_fn e))
                  HsConLikeOut _ (RealDataCon dc) -> return $ varToCoreExpr (dataConWrapId dc)
                  XExpr (HsWrap _ _) -> pprPanic "dsExpr: HsWrap inside HsWrap" (ppr hswrap)
                  HsPar _ _ -> pprPanic "dsExpr: HsPar inside HsWrap" (ppr hswrap)
-                 _ -> dsExpr e
+                 _ -> -- addTyCsDs (hsWrapDictBinders co_fn) $
+                      -- Omitting; part of !3087
+                      dsExpr e
                -- See Note [Detecting forced eta expansion]
        ; wrap' <- dsHsWrapper co_fn
        ; dflags <- getDynFlags
@@ -788,7 +790,7 @@ dsSyntaxExpr (SyntaxExprTc { syn_expr      = expr
   = do { fun            <- dsExpr expr
        ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
        ; core_res_wrap  <- dsHsWrapper res_wrap
-       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs
+       ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs
        ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])
                       (\_ -> core_res_wrap (mkApps fun wrapped_args)) }
   where
@@ -933,24 +935,24 @@ dsDo stmts
       = do { rest <- goL stmts
            ; dsLocalBinds binds rest }
 
-    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts
+    go _ (BindStmt xbs pat rhs) stmts
       = do  { body     <- goL stmts
             ; rhs'     <- dsLExpr rhs
             ; var   <- selectSimpleMatchVarL pat
             ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat
-                                      res1_ty (cantFailMatchResult body)
-            ; match_code <- dsHandleMonadicFailure pat match fail_op
-            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }
+                         (xbstc_boundResultType xbs) (cantFailMatchResult body)
+            ; match_code <- dsHandleMonadicFailure pat match (xbstc_failOp xbs)
+            ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
 
     go _ (ApplicativeStmt body_ty args mb_join) stmts
       = do {
              let
                (pats, rhss) = unzip (map (do_arg . snd) args)
 
-               do_arg (ApplicativeArgOne _ pat expr _ fail_op) =
+               do_arg (ApplicativeArgOne fail_op pat expr _) =
                  ((pat, fail_op), dsLExpr expr)
                do_arg (ApplicativeArgMany _ stmts ret pat) =
-                 ((pat, noSyntaxExpr), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
+                 ((pat, Nothing), dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
 
            ; rhss' <- sequence rhss
 
@@ -981,9 +983,14 @@ dsDo stmts
                         , 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 bind_ty (mkBigLHsPatTupId later_pats)
-                                         mfix_app bind_op
-                                         noSyntaxExpr  -- Tuple cannot fail
+        new_bind_stmt = L loc $ BindStmt
+          XBindStmtTc
+            { xbstc_bindOp = bind_op
+            , xbstc_boundResultType = bind_ty
+            , xbstc_failOp = Nothing -- Tuple cannot fail
+            }
+          (mkBigLHsPatTupId later_pats)
+          mfix_app
 
         tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids
         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
@@ -1009,17 +1016,26 @@ dsDo stmts
     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"
     go _ (TransStmt {}) _ = panic "dsDo TransStmt"
 
-dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr
+dsHandleMonadicFailure :: LPat GhcTc -> MatchResult -> FailOperator GhcTc -> DsM CoreExpr
     -- In a do expression, pattern-match failure just calls
     -- the monadic 'fail' rather than throwing an exception
-dsHandleMonadicFailure pat match fail_op
-  | matchCanFail match
-  = do { dflags <- getDynFlags
-       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
-       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]
-       ; extractMatchResult match fail_expr }
-  | otherwise
-  = extractMatchResult match (error "It can't fail")
+dsHandleMonadicFailure pat match m_fail_op
+  | matchCanFail match = do
+    fail_op <- case m_fail_op of
+      -- Note that (non-monadic) list comprehension, pattern guards, etc could
+      -- have fallible bindings without an explicit failure op, but this is
+      -- handled elsewhere. See Note [Failing pattern matches in Stmts] the
+      -- breakdown of regular and special binds.
+      Nothing -> pprPanic "missing fail op" $
+        text "Pattern match:" <+> ppr pat <+>
+        text "is failable, and fail_expr was left unset"
+      Just fail_op -> pure fail_op
+    dflags <- getDynFlags
+    fail_msg <- mkStringExpr (mk_fail_msg dflags pat)
+    fail_expr <- dsSyntaxExpr fail_op [fail_msg]
+    extractMatchResult match fail_expr
+  | otherwise =
+    extractMatchResult match (error "It can't fail")
 
 mk_fail_msg :: DynFlags -> Located e -> String
 mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++