Use NonEmpty lists to represent lists of duplicate elements
[ghc.git] / compiler / rename / RnExpr.hs
index ce22784..6eabc89 100644 (file)
@@ -13,6 +13,7 @@ free variables.
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module RnExpr (
         rnLExpr, rnExpr, rnStmts
@@ -56,6 +57,7 @@ import qualified GHC.LanguageExtensions as LangExt
 
 import Data.Ord
 import Data.Array
+import qualified Data.List.NonEmpty as NE
 
 {-
 ************************************************************************
@@ -65,7 +67,7 @@ import Data.Array
 ************************************************************************
 -}
 
-rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
+rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)
 rnExprs ls = rnExprs' ls emptyUniqSet
  where
   rnExprs' [] acc = return ([], acc)
@@ -79,12 +81,12 @@ rnExprs ls = rnExprs' ls emptyUniqSet
 
 -- Variables. We look up the variable and return the resulting name.
 
-rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
+rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)
 rnLExpr = wrapLocFstM rnExpr
 
-rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
+rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
 
-finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
+finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)
 -- Separated from rnExpr because it's also used
 -- when renaming infix expressions
 finishHsVar (L l name)
@@ -93,7 +95,7 @@ finishHsVar (L l name)
         checkThLocalName name
       ; return (HsVar (L l name), unitFV name) }
 
-rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
+rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)
 rnUnboundVar v
  = do { if isUnqual v
         then -- Treat this as a "hole"
@@ -121,12 +123,12 @@ rnExpr (HsVar (L l v))
 
               | otherwise
               -> finishHsVar (L l name) ;
-            Just (Right [f@(FieldOcc (L _ fn) s)]) ->
-                      return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s))
-                             , unitFV (selectorFieldOcc f)) ;
-           Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous (L l v)
-                                                        PlaceHolder)
-                                             , mkFVs (map selectorFieldOcc fs));
+            Just (Right [s]) ->
+              return ( HsRecFld (ambiguousFieldOcc (FieldOcc (L l v) s))
+                     , unitFV s) ;
+           Just (Right fs@(_:_:_)) ->
+              return ( HsRecFld (Ambiguous (L l v) PlaceHolder)
+                     , mkFVs fs);
            Just (Right [])         -> panic "runExpr/HsVar" } }
 
 rnExpr (HsIPVar v)
@@ -145,11 +147,11 @@ rnExpr (HsLit lit@(HsString src s))
             rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
          else do {
             ; rnLit lit
-            ; return (HsLit lit, emptyFVs) } }
+            ; return (HsLit (convertLit lit), emptyFVs) } }
 
 rnExpr (HsLit lit)
   = do { rnLit lit
-       ; return (HsLit lit, emptyFVs) }
+       ; return (HsLit (convertLit lit), emptyFVs) }
 
 rnExpr (HsOverLit lit)
   = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]
@@ -409,7 +411,7 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 hsHoleExpr :: HsExpr id
 hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_"))
 
-arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
+arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
 arrowFail e
   = do { addErr (vcat [ text "Arrow command found where an expression was expected:"
                       , nest 2 (ppr e) ])
@@ -419,7 +421,7 @@ arrowFail e
 
 ----------------------
 -- See Note [Parsing sections] in Parser.y
-rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
+rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)
 rnSection section@(SectionR op expr)
   = do  { (op', fvs_op)     <- rnLExpr op
         ; (expr', fvs_expr) <- rnLExpr expr
@@ -442,14 +444,14 @@ rnSection other = pprPanic "rnSection" (ppr other)
 ************************************************************************
 -}
 
-rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
+rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)
 rnCmdArgs [] = return ([], emptyFVs)
 rnCmdArgs (arg:args)
   = do { (arg',fvArg) <- rnCmdTop arg
        ; (args',fvArgs) <- rnCmdArgs args
        ; return (arg':args', fvArg `plusFV` fvArgs) }
 
-rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
+rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)
 rnCmdTop = wrapLocFstM rnCmdTop'
  where
   rnCmdTop' (HsCmdTop cmd _ _ _)
@@ -463,10 +465,10 @@ rnCmdTop = wrapLocFstM rnCmdTop'
                   (cmd_names `zip` cmd_names'),
                   fvCmd `plusFV` cmd_fvs) }
 
-rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars)
+rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)
 rnLCmd = wrapLocFstM rnCmd
 
-rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars)
+rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)
 
 rnCmd (HsCmdArrApp arrow arg _ ho rtl)
   = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)
@@ -541,10 +543,10 @@ type CmdNeeds = FreeVars        -- Only inhabitants are
                                 --      appAName, choiceAName, loopAName
 
 -- find what methods the Cmd needs (loop, choice, apply)
-methodNamesLCmd :: LHsCmd Name -> CmdNeeds
+methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds
 methodNamesLCmd = methodNamesCmd . unLoc
 
-methodNamesCmd :: HsCmd Name -> CmdNeeds
+methodNamesCmd :: HsCmd GhcRn -> CmdNeeds
 
 methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl)
   = emptyFVs
@@ -572,31 +574,31 @@ methodNamesCmd (HsCmdCase _ matches)
    -- The type checker will complain later
 
 ---------------------------------------------------
-methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
+methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars
 methodNamesMatch (MG { mg_alts = L _ ms })
   = plusFVs (map do_one ms)
  where
-    do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
+    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss
 
 -------------------------------------------------
 -- gaw 2004
-methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars
+methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars
 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
 
 -------------------------------------------------
 
-methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds
+methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds
 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
 
 ---------------------------------------------------
-methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars
+methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars
 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
 
 ---------------------------------------------------
-methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
+methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars
 methodNamesLStmt = methodNamesStmt . unLoc
 
-methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
+methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars
 methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd
 methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
 methodNamesStmt (BindStmt _ cmd _ _ _)           = methodNamesLCmd cmd
@@ -617,7 +619,7 @@ methodNamesStmt ApplicativeStmt{}            = emptyFVs
 ************************************************************************
 -}
 
-rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
+rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)
 rnArithSeq (From expr)
  = do { (expr', fvExpr) <- rnLExpr expr
       ; return (From expr', fvExpr) }
@@ -669,34 +671,34 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism.
 -}
 
 -- | Rename some Stmts
-rnStmts :: Outputable (body RdrName)
+rnStmts :: Outputable (body GhcPs)
         => HsStmtContext Name
-        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
            -- ^ How to rename the body of each statement (e.g. rnLExpr)
-        -> [LStmt RdrName (Located (body RdrName))]
+        -> [LStmt GhcPs (Located (body GhcPs))]
            -- ^ Statements
         -> ([Name] -> RnM (thing, FreeVars))
            -- ^ if these statements scope over something, this renames it
            -- and returns the result.
-        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
 rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
 
 -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
 rnStmtsWithPostProcessing
-        :: Outputable (body RdrName)
+        :: Outputable (body GhcPs)
         => HsStmtContext Name
-        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
            -- ^ How to rename the body of each statement (e.g. rnLExpr)
         -> (HsStmtContext Name
-              -> [(LStmt Name (Located (body Name)), FreeVars)]
-              -> RnM ([LStmt Name (Located (body Name))], FreeVars))
+              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))
            -- ^ postprocess the statements
-        -> [LStmt RdrName (Located (body RdrName))]
+        -> [LStmt GhcPs (Located (body GhcPs))]
            -- ^ Statements
         -> ([Name] -> RnM (thing, FreeVars))
            -- ^ if these statements scope over something, this renames it
            -- and returns the result.
-        -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
 rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
  = do { ((stmts', thing), fvs) <-
           rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
@@ -707,8 +709,8 @@ rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
 -- | maybe rearrange statements according to the ApplicativeDo transformation
 postProcessStmtsForApplicativeDo
   :: HsStmtContext Name
-  -> [(ExprLStmt Name, FreeVars)]
-  -> RnM ([ExprLStmt Name], FreeVars)
+  -> [(ExprLStmt GhcRn, FreeVars)]
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
 postProcessStmtsForApplicativeDo ctxt stmts
   = do {
        -- rearrange the statements using ApplicativeStmt if
@@ -724,17 +726,17 @@ postProcessStmtsForApplicativeDo ctxt stmts
 -- | strip the FreeVars annotations from statements
 noPostProcessStmts
   :: HsStmtContext Name
-  -> [(LStmt Name (Located (body Name)), FreeVars)]
-  -> RnM ([LStmt Name (Located (body Name))], FreeVars)
+  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)
 noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
 
 
-rnStmtsWithFreeVars :: Outputable (body RdrName)
+rnStmtsWithFreeVars :: Outputable (body GhcPs)
         => HsStmtContext Name
-        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-        -> [LStmt RdrName (Located (body RdrName))]
+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
+        -> [LStmt GhcPs (Located (body GhcPs))]
         -> ([Name] -> RnM (thing, FreeVars))
-        -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
+        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
                , FreeVars)
 -- Each Stmt body is annotated with its FreeVars, so that
 -- we can rearrange statements for ApplicativeDo.
@@ -792,15 +794,15 @@ exhaustive list). How we deal with pattern match failure is context-dependent.
 At one point we failed to make this distinction, leading to #11216.
 -}
 
-rnStmt :: Outputable (body RdrName)
+rnStmt :: Outputable (body GhcPs)
        => HsStmtContext Name
-       -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
           -- ^ How to rename the body of the statement
-       -> LStmt RdrName (Located (body RdrName))
+       -> LStmt GhcPs (Located (body GhcPs))
           -- ^ The statement
        -> ([Name] -> RnM (thing, FreeVars))
           -- ^ Rename the stuff that this statement scopes over
-       -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
+       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)
               , FreeVars)
 -- Variables bound by the Stmt, and mentioned in thing_inside,
 -- do not appear in the result FreeVars
@@ -833,7 +835,7 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _ _)) thing_inside
 
         ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
         ; let getFailFunction
-                -- If the pattern is irrefutible (e.g.: wildcard, tuple,
+                -- If the pattern is irrefutable (e.g.: wildcard, tuple,
                 -- ~pat, etc.) we should not need to fail.
                 | isIrrefutableHsPat pat
                                     = return (noSyntaxExpr, emptyFVs)
@@ -938,18 +940,18 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ =
   panic "rnStmt: ApplicativeStmt"
 
 rnParallelStmts :: forall thing. HsStmtContext Name
-                -> SyntaxExpr Name
-                -> [ParStmtBlock RdrName RdrName]
+                -> SyntaxExpr GhcRn
+                -> [ParStmtBlock GhcPs GhcPs]
                 -> ([Name] -> RnM (thing, FreeVars))
-                -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
+                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
 -- Note [Renaming parallel Stmts]
 rnParallelStmts ctxt return_op segs thing_inside
   = do { orig_lcl_env <- getLocalRdrEnv
        ; rn_segs orig_lcl_env [] segs }
   where
     rn_segs :: LocalRdrEnv
-            -> [Name] -> [ParStmtBlock RdrName RdrName]
-            -> RnM (([ParStmtBlock Name Name], thing), FreeVars)
+            -> [Name] -> [ParStmtBlock GhcPs GhcPs]
+            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)
     rn_segs _ bndrs_so_far []
       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
            ; mapM_ dupErr dups
@@ -969,9 +971,9 @@ rnParallelStmts ctxt return_op segs thing_inside
 
     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
     dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"
-                    <+> quotes (ppr (head vs)))
+                    <+> quotes (ppr (NE.head vs)))
 
-lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars)
+lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)
 -- Like lookupSyntaxName, but respects contexts
 lookupStmtName ctxt n
   | rebindableContext ctxt
@@ -979,7 +981,7 @@ lookupStmtName ctxt n
   | otherwise
   = return (mkRnSyntaxExpr n, emptyFVs)
 
-lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars)
+lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)
 lookupStmtNamePoly ctxt name
   | rebindableContext ctxt
   = do { rebindable_on <- xoptM LangExt.RebindableSyntax
@@ -1047,13 +1049,13 @@ type Segment stmts = (Defs,
 
 
 -- wrapper that does both the left- and right-hand sides
-rnRecStmtsAndThen :: Outputable (body RdrName) =>
-                     (Located (body RdrName)
-                  -> RnM (Located (body Name), FreeVars))
-                  -> [LStmt RdrName (Located (body RdrName))]
+rnRecStmtsAndThen :: Outputable (body GhcPs) =>
+                     (Located (body GhcPs)
+                  -> RnM (Located (body GhcRn), FreeVars))
+                  -> [LStmt GhcPs (Located (body GhcPs))]
                          -- assumes that the FreeVars returned includes
                          -- the FreeVars of the Segments
-                  -> ([Segment (LStmt Name (Located (body Name)))]
+                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]
                       -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 rnRecStmtsAndThen rnBody s cont
@@ -1077,7 +1079,7 @@ rnRecStmtsAndThen rnBody s cont
         ; return (res, fvs) }}
 
 -- get all the fixity decls in any Let stmt
-collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
+collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]
 collectRecStmtsFixities l =
     foldr (\ s -> \acc -> case s of
             (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
@@ -1089,11 +1091,11 @@ collectRecStmtsFixities l =
 -- left-hand sides
 
 rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
-                -> LStmt RdrName body
+                -> LStmt GhcPs body
                    -- rename LHS, and return its FVs
                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
                    -- so we don't bother to compute it accurately in the other cases
-                -> RnM [(LStmtLR Name RdrName body, FreeVars)]
+                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
 
 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
   = return [(L loc (BodyStmt body a b c), emptyFVs)]
@@ -1135,8 +1137,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 
 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
-                 -> [LStmt RdrName body]
-                 -> RnM [(LStmtLR Name RdrName body, FreeVars)]
+                 -> [LStmt GhcPs body]
+                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]
 rn_rec_stmts_lhs fix_env stmts
   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
        ; let boundNames = collectLStmtsBinders (map fst ls)
@@ -1149,11 +1151,11 @@ rn_rec_stmts_lhs fix_env stmts
 
 -- right-hand-sides
 
-rn_rec_stmt :: (Outputable (body RdrName)) =>
-               (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+rn_rec_stmt :: (Outputable (body GhcPs)) =>
+               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
             -> [Name]
-            -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars)
-            -> RnM [Segment (LStmt Name (Located (body Name)))]
+            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)
+            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
         -- Rename a Stmt that is inside a RecStmt (or mdo)
         -- Assumes all binders are already in scope
         -- Turns each stmt into a singleton Stmt
@@ -1209,20 +1211,20 @@ rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
 rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)
   = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)
 
-rn_rec_stmts :: Outputable (body RdrName) =>
-                (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+rn_rec_stmts :: Outputable (body GhcPs) =>
+                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))
              -> [Name]
-             -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)]
-             -> RnM [Segment (LStmt Name (Located (body Name)))]
+             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]
+             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]
 rn_rec_stmts rnBody bndrs stmts
   = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts
        ; return (concat segs_s) }
 
 ---------------------------------------------
 segmentRecStmts :: SrcSpan -> HsStmtContext Name
-                -> Stmt Name body
-                -> [Segment (LStmt Name body)] -> FreeVars
-                -> ([LStmt Name body], FreeVars)
+                -> Stmt GhcRn body
+                -> [Segment (LStmt GhcRn body)] -> FreeVars
+                -> ([LStmt GhcRn body], FreeVars)
 
 segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
   | null segs
@@ -1324,8 +1326,9 @@ glom it together with the first two groups
 -}
 
 glomSegments :: HsStmtContext Name
-             -> [Segment (LStmt Name body)]
-             -> [Segment [LStmt Name body]]  -- Each segment has a non-empty list of Stmts
+             -> [Segment (LStmt GhcRn body)]
+             -> [Segment [LStmt GhcRn body]]
+                                  -- Each segment has a non-empty list of Stmts
 -- See Note [Glomming segments]
 
 glomSegments _ [] = []
@@ -1354,10 +1357,12 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs)
           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 
 ----------------------------------------------------
-segsToStmts :: Stmt Name body                   -- A RecStmt with the SyntaxOps filled in
-            -> [Segment [LStmt Name body]]      -- Each Segment has a non-empty list of Stmts
-            -> FreeVars                         -- Free vars used 'later'
-            -> ([LStmt Name body], FreeVars)
+segsToStmts :: Stmt GhcRn body
+                                  -- A RecStmt with the SyntaxOps filled in
+            -> [Segment [LStmt GhcRn body]]
+                                  -- Each Segment has a non-empty list of Stmts
+            -> FreeVars           -- Free vars used 'later'
+            -> ([LStmt GhcRn body], FreeVars)
 
 segsToStmts _ [] fvs_later = ([], fvs_later)
 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
@@ -1499,8 +1504,8 @@ data MonadNames = MonadNames { return_name, pure_name :: Name }
 -- Note [ApplicativeDo].
 rearrangeForApplicativeDo
   :: HsStmtContext Name
-  -> [(ExprLStmt Name, FreeVars)]
-  -> RnM ([ExprLStmt Name], FreeVars)
+  -> [(ExprLStmt GhcRn, FreeVars)]
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
 
 rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
 rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)
@@ -1532,12 +1537,12 @@ flattenStmtTree t = go t []
   go (StmtTreeBind l r) as = go l (go r as)
   go (StmtTreeApplicative ts) as = foldr go as ts
 
-type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars)
+type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)
 type Cost = Int
 
 -- | Turn a sequence of statements into an ExprStmtTree using a
 -- heuristic algorithm.  /O(n^2)/
-mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
+mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
 mkStmtTreeHeuristic [one] = StmtTreeOne one
 mkStmtTreeHeuristic stmts =
   case segments stmts of
@@ -1551,7 +1556,7 @@ mkStmtTreeHeuristic stmts =
 
 -- | Turn a sequence of statements into an ExprStmtTree optimally,
 -- using dynamic programming.  /O(n^3)/
-mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree
+mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree
 mkStmtTreeOptimal stmts =
   ASSERT(not (null stmts)) -- the empty case is handled by the caller;
                            -- we don't support empty StmtTrees.
@@ -1601,7 +1606,7 @@ mkStmtTreeOptimal stmts =
               (StmtTreeOne (stmt_arr ! hi), 1))
            | left_cost < right_cost
            = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))
-           | otherwise -- left_cost > right_cost
+           | left_cost > right_cost
            = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))
            | otherwise = minimumBy (comparing cost) alternatives
            where
@@ -1618,9 +1623,9 @@ stmtTreeToStmts
   :: MonadNames
   -> HsStmtContext Name
   -> ExprStmtTree
-  -> [ExprLStmt Name]             -- ^ the "tail"
+  -> [ExprLStmt GhcRn]             -- ^ the "tail"
   -> FreeVars                     -- ^ free variables of the tail
-  -> RnM ( [ExprLStmt Name]       -- ( output statements,
+  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,
          , FreeVars )             -- , things we needed
 
 -- If we have a single bind, and we can do it without a join, transform
@@ -1631,12 +1636,8 @@ stmtTreeToStmts
 -- the bind form, which would give rise to a Monad constraint.
 stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt pat rhs _ _ _),_))
                 tail _tail_fvs
-  | isIrrefutableHsPat pat, (False,tail') <- needJoin monad_names tail
-    -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
-    --          to know which types have only one constructor.  So only
-    --          tuples come out as irrefutable; other single-constructor
-    --          types, and newtypes, will not.  See the code for
-    --          isIrrefuatableHsPat
+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail
+  -- See Note [ApplicativeDo and strict patterns]
   = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
 
 stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =
@@ -1679,8 +1680,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do
 -- | Divide a sequence of statements into segments, where no segment
 -- depends on any variables defined by a statement in another segment.
 segments
-  :: [(ExprLStmt Name, FreeVars)]
-  -> [[(ExprLStmt Name, FreeVars)]]
+  :: [(ExprLStmt GhcRn, FreeVars)]
+  -> [[(ExprLStmt GhcRn, FreeVars)]]
 segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
   where
     allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
@@ -1702,7 +1703,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
     -- the sequence from the back to the front, and keeping track of
     -- the set of free variables of the current segment.  Whenever
     -- this set of free variables is empty, we have a complete segment.
-    walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]]
+    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]
     walk [] = []
     walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
       where (seg,rest) = chunter fvs' stmts
@@ -1711,6 +1712,8 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
     chunter _ [] = ([], [])
     chunter vars ((stmt,fvs) : rest)
        | not (isEmptyNameSet vars)
+       || isStrictPatternBind stmt
+           -- See Note [ApplicativeDo and strict patterns]
        = ((stmt,fvs) : chunk, rest')
        where (chunk,rest') = chunter vars' rest
              (pvars, evars) = stmtRefs stmt fvs
@@ -1723,6 +1726,58 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
       where fvs' = fvs `intersectNameSet` allvars
             pvars = mkNameSet (collectStmtBinders (unLoc stmt))
 
+    isStrictPatternBind :: ExprLStmt GhcRn -> Bool
+    isStrictPatternBind (L _ (BindStmt pat _ _ _ _)) = isStrictPattern pat
+    isStrictPatternBind _ = False
+
+{-
+Note [ApplicativeDo and strict patterns]
+
+A strict pattern match is really a dependency.  For example,
+
+do
+  (x,y) <- A
+  z <- B
+  return C
+
+The pattern (_,_) must be matched strictly before we do B.  If we
+allowed this to be transformed into
+
+  (\(x,y) -> \z -> C) <$> A <*> B
+
+then it could be lazier than the standard desuraging using >>=.  See #13875
+for more examples.
+
+Thus, whenever we have a strict pattern match, we treat it as a
+dependency between that statement and the following one.  The
+dependency prevents those two statements from being performed "in
+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we
+can do with the rest of the statements in the same "do" expression.
+-}
+
+isStrictPattern :: LPat id -> Bool
+isStrictPattern (L _ pat) =
+  case pat of
+    WildPat{} -> False
+    VarPat{}  -> False
+    LazyPat{} -> False
+    AsPat _ p -> isStrictPattern p
+    ParPat p  -> isStrictPattern p
+    ViewPat _ p _ -> isStrictPattern p
+    SigPatIn p _ -> isStrictPattern p
+    SigPatOut p _ -> isStrictPattern p
+    BangPat{} -> True
+    TuplePat{} -> True
+    SumPat{} -> True
+    PArrPat{} -> True
+    ConPatIn{} -> True
+    ConPatOut{} -> True
+    LitPat{} -> True
+    NPat{} -> True
+    NPlusKPat{} -> True
+    SplicePat{} -> True
+    _otherwise -> panic "isStrictPattern"
+
 isLetStmt :: LStmt a b -> Bool
 isLetStmt (L _ LetStmt{}) = True
 isLetStmt _ = False
@@ -1732,9 +1787,9 @@ isLetStmt _ = False
 -- heuristic is to peel off the first group of independent statements
 -- and put the bind after those.
 splitSegment
-  :: [(ExprLStmt Name, FreeVars)]
-  -> ( [(ExprLStmt Name, FreeVars)]
-     , [(ExprLStmt Name, FreeVars)] )
+  :: [(ExprLStmt GhcRn, FreeVars)]
+  -> ( [(ExprLStmt GhcRn, FreeVars)]
+     , [(ExprLStmt GhcRn, FreeVars)] )
 splitSegment [one,two] = ([one],[two])
   -- there is no choice when there are only two statements; this just saves
   -- some work in a common case.
@@ -1749,10 +1804,10 @@ splitSegment stmts
       _other -> (stmts,[])
 
 slurpIndependentStmts
-   :: [(LStmt Name (Located (body Name)), FreeVars)]
-   -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts
-            , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts
-            , [(LStmt Name (Located (body Name)), FreeVars)] )
+   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]
+   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts
+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts
+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )
 slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
  where
   -- If we encounter a BindStmt that doesn't depend on a previous BindStmt
@@ -1789,10 +1844,10 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts
 -- typechecker and the desugarer (I tried it that way first!).
 mkApplicativeStmt
   :: HsStmtContext Name
-  -> [ApplicativeArg Name Name]         -- ^ The args
+  -> [ApplicativeArg GhcRn GhcRn]         -- ^ The args
   -> Bool                               -- ^ True <=> need a join
-  -> [ExprLStmt Name]        -- ^ The body statements
-  -> RnM ([ExprLStmt Name], FreeVars)
+  -> [ExprLStmt GhcRn]        -- ^ The body statements
+  -> RnM ([ExprLStmt GhcRn], FreeVars)
 mkApplicativeStmt ctxt args need_join body_stmts
   = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
        ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
@@ -1812,8 +1867,8 @@ mkApplicativeStmt ctxt args need_join body_stmts
 -- | Given the statements following an ApplicativeStmt, determine whether
 -- we need a @join@ or not, and remove the @return@ if necessary.
 needJoin :: MonadNames
-         -> [ExprLStmt Name]
-         -> (Bool, [ExprLStmt Name])
+         -> [ExprLStmt GhcRn]
+         -> (Bool, [ExprLStmt GhcRn])
 needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg
 needJoin monad_names  [L loc (LastStmt e _ t)]
  | Just arg <- isReturnApp monad_names e =
@@ -1823,8 +1878,8 @@ needJoin _monad_names stmts = (True, stmts)
 -- | @Just e@, if the expression is @return e@ or @return $ e@,
 -- otherwise @Nothing@
 isReturnApp :: MonadNames
-            -> LHsExpr Name
-            -> Maybe (LHsExpr Name)
+            -> LHsExpr GhcRn
+            -> Maybe (LHsExpr GhcRn)
 isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr
 isReturnApp monad_names (L _ e) = case e of
   OpApp l op _ r | is_return l, is_dollar op -> Just r
@@ -1864,9 +1919,9 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or '
 emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt
 
 ----------------------
-checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name
-              -> LStmt RdrName (Located (body RdrName))
-              -> RnM (LStmt RdrName (Located (body RdrName)))
+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name
+              -> LStmt GhcPs (Located (body GhcPs))
+              -> RnM (LStmt GhcPs (Located (body GhcPs)))
 checkLastStmt ctxt lstmt@(L loc stmt)
   = case ctxt of
       ListComp  -> check_comp
@@ -1896,7 +1951,7 @@ checkLastStmt ctxt lstmt@(L loc stmt)
 
 -- Checking when a particular Stmt is ok
 checkStmt :: HsStmtContext Name
-          -> LStmt RdrName (Located (body RdrName))
+          -> LStmt GhcPs (Located (body GhcPs))
           -> RnM ()
 checkStmt ctxt (L _ stmt)
   = do { dflags <- getDynFlags
@@ -1923,7 +1978,7 @@ emptyInvalid = NotValid Outputable.empty
 
 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
    :: DynFlags -> HsStmtContext Name
-   -> Stmt RdrName (Located (body RdrName)) -> Validity
+   -> Stmt GhcPs (Located (body GhcPs)) -> Validity
 -- Return Nothing if OK, (Just extra) if not ok
 -- The "extra" is an SDoc that is appended to an generic error message
 
@@ -1941,7 +1996,7 @@ okStmt dflags ctxt stmt
       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt
 
 -------------
-okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity
+okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity
 okPatGuardStmt stmt
   = case stmt of
       BodyStmt {} -> IsValid
@@ -1998,7 +2053,7 @@ okPArrStmt dflags _ stmt
        ApplicativeStmt {} -> emptyInvalid
 
 ---------
-checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
+checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()
 checkTupleSection args
   = do  { tuple_section <- xoptM LangExt.TupleSections
         ; checkErr (all tupArgPresent args || tuple_section) msg }
@@ -2006,12 +2061,12 @@ checkTupleSection args
     msg = text "Illegal tuple section: use TupleSections"
 
 ---------
-sectionErr :: HsExpr RdrName -> SDoc
+sectionErr :: HsExpr GhcPs -> SDoc
 sectionErr expr
   = hang (text "A section must be enclosed in parentheses")
        2 (text "thus:" <+> (parens (ppr expr)))
 
-patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars)
+patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars)
 patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:",
                                 nest 4 (ppr e)] $$
                                   explanation)