Expose enabled language extensions to TH
[ghc.git] / compiler / rename / RnExpr.hs
index 4cebafc..c520732 100644 (file)
@@ -10,7 +10,8 @@ general, all of these functions return a renamed thing, and a set of
 free variables.
 -}
 
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module RnExpr (
         rnLExpr, rnExpr, rnStmts
@@ -18,8 +19,6 @@ module RnExpr (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
-
 import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
                    rnMatchGroup, rnGRHS, makeMiniFixityEnv)
 import HsSyn
@@ -30,9 +29,9 @@ import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )
 import RnTypes
 import RnPat
 import DynFlags
-import BasicTypes       ( FixityDirection(..) )
 import PrelNames
 
+import BasicTypes
 import Name
 import NameSet
 import RdrName
@@ -46,6 +45,7 @@ import SrcLoc
 import FastString
 import Control.Monad
 import TysWiredIn       ( nilDataConName )
+import qualified GHC.LanguageExtensions as LangExt
 
 {-
 ************************************************************************
@@ -74,34 +74,53 @@ rnLExpr = wrapLocFstM rnExpr
 
 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 
-finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
+finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
 -- Separated from rnExpr because it's also used
 -- when renaming infix expressions
-finishHsVar name
+finishHsVar (L l name)
  = do { this_mod <- getModule
       ; when (nameIsLocalOrFrom this_mod name) $
         checkThLocalName name
-      ; return (HsVar name, unitFV name) }
-
-rnExpr (HsVar v)
-  = do { mb_name <- lookupOccRn_maybe v
+      ; return (HsVar (L l name), unitFV name) }
+
+rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
+rnUnboundVar v
+ = do { if isUnqual v
+        then -- Treat this as a "hole"
+             -- Do not fail right now; instead, return HsUnboundVar
+             -- and let the type checker report the error
+             return (HsUnboundVar (rdrNameOcc v), emptyFVs)
+
+        else -- Fail immediately (qualified name)
+             do { n <- reportUnboundName v
+                ; return (HsVar (noLoc n), emptyFVs) } }
+
+rnExpr (HsVar (L l v))
+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
        ; case mb_name of {
-           Nothing -> do { if startsWithUnderscore (rdrNameOcc v)
-                           then return (HsUnboundVar v, emptyFVs)
-                           else do { n <- reportUnboundName v; finishHsVar n } } ;
-           Just name
+           Nothing -> rnUnboundVar v ;
+           Just (Left name)
               | name == nilDataConName -- Treat [] as an ExplicitList, so that
                                        -- OverloadedLists works correctly
               -> rnExpr (ExplicitList placeHolderType Nothing [])
 
               | otherwise
-              -> finishHsVar name }}
+              -> finishHsVar (L l name) ;
+           Just (Right [f])        -> return (HsRecFld (ambiguousFieldOcc f)
+                                             , unitFV (selectorFieldOcc f)) ;
+           Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
+                                             , mkFVs (map selectorFieldOcc fs));
+           Just (Right [])         -> error "runExpr/HsVar" } }
 
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
 
+rnExpr (HsOverLabel v)
+  = return (HsOverLabel v, emptyFVs)
+
 rnExpr (HsLit lit@(HsString src s))
-  = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
        ; if opt_OverloadedStrings then
             rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
          else do {
@@ -121,25 +140,24 @@ rnExpr (HsApp fun arg)
        ; (arg',fvArg) <- rnLExpr arg
        ; return (HsApp fun' arg', fvFun `plusFV` fvArg) }
 
-rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
+rnExpr (OpApp e1 op  _ e2)
   = do  { (e1', fv_e1) <- rnLExpr e1
         ; (e2', fv_e2) <- rnLExpr e2
-        ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
-        ; (op', fv_op) <- finishHsVar op_name
-                -- NB: op' is usually just a variable, but might be
-                --     an applicatoin (assert "Foo.hs:47")
+        ; (op', fv_op) <- rnLExpr op
+
         -- Deal with fixity
         -- When renaming code synthesised from "deriving" declarations
         -- we used to avoid fixity stuff, but we can't easily tell any
         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
         -- should prevent bad things happening.
-        ; fixity <- lookupFixityRn op_name
-        ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
+        ; fixity <- case op' of
+                      L _ (HsVar (L _ n)) -> lookupFixityRn n
+                      L _ (HsRecFld f)    -> lookupFieldFixityRn f
+                      _ -> return (Fixity minPrecedence InfixL)
+                           -- c.f. lookupFixity for unbound
+
+        ; final_e <- mkOpAppRn e1' op' fixity e2'
         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
-rnExpr (OpApp _ other_op _ _)
-  = failWith (vcat [ hang (ptext (sLit "Infix application with a non-variable operator:"))
-                        2 (ppr other_op)
-                   , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
 
 rnExpr (NegApp e _)
   = do { (e', fv_e)         <- rnLExpr e
@@ -153,14 +171,7 @@ rnExpr (NegApp e _)
 -- (not with an rnExpr crash) in a stage-1 compiler.
 rnExpr e@(HsBracket br_body) = rnBracket e br_body
 
-rnExpr (HsSpliceE is_typed splice) = rnSpliceExpr is_typed splice
-
-
-rnExpr (HsQuasiQuoteE qq)
-  = do { lexpr' <- runQuasiQuoteExpr qq
-         -- Wrap the result of the quasi-quoter in parens so that we don't
-         -- lose the outermost location set by runQuasiQuote (#7918)
-       ; rnExpr (HsPar lexpr') }
+rnExpr (HsSpliceE splice) = rnSpliceExpr splice
 
 ---------------------------------------------
 --      Sections
@@ -208,17 +219,20 @@ rnExpr (HsCase expr matches)
        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches
        ; return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) }
 
-rnExpr (HsLet binds expr)
-  = rnLocalBindsAndThen binds $ \binds' -> do
+rnExpr (HsLet (L l binds) expr)
+  = rnLocalBindsAndThen binds $ \binds' -> do
       { (expr',fvExpr) <- rnLExpr expr
-      ; return (HsLet binds' expr', fvExpr) }
+      ; return (HsLet (L l binds') expr', fvExpr) }
 
-rnExpr (HsDo do_or_lc stmts _)
-  = do  { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs))
-        ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
+rnExpr (HsDo do_or_lc (L l stmts) _)
+  = do  { ((stmts', _), fvs) <-
+           rnStmtsWithPostProcessing do_or_lc rnLExpr
+             postProcessStmtsForApplicativeDo stmts
+             (\ _ -> return ((), emptyFVs))
+        ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
 
 rnExpr (ExplicitList _ _  exps)
-  = do  { opt_OverloadedLists <- xoptM Opt_OverloadedLists
+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
         ; (exps', fvs) <- rnExprs exps
         ; if opt_OverloadedLists
            then do {
@@ -243,25 +257,33 @@ rnExpr (ExplicitTuple tup_args boxity)
     rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
                                         , emptyFVs)
 
-rnExpr (RecordCon con_id _ rbinds)
-  = do  { conname <- lookupLocatedOccRn con_id
-        ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
-        ; return (RecordCon conname noPostTcExpr rbinds',
-                  fvRbinds `addOneFV` unLoc conname) }
+rnExpr (RecordCon { rcon_con_name = con_id
+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
+       ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
+                           , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
+  where
+    mk_hs_var l n = HsVar (L l n)
+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
 
-rnExpr (RecordUpd expr rbinds _ _ _)
+rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
   = do  { (expr', fvExpr) <- rnLExpr expr
-        ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
-        ; return (RecordUpd expr' rbinds' [] [] [],
-                  fvExpr `plusFV` fvRbinds) }
-
-rnExpr (ExprWithTySig expr pty PlaceHolder)
-  = do  { (wcs, pty') <- extractWildcards pty
-        ; bindLocatedLocalsFV wcs $ \wcs_new -> do {
-          (pty'', fvTy) <- rnLHsType ExprWithTySigCtx pty'
-        ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty'') $
+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds
+        ; return (RecordUpd { rupd_expr = expr', rupd_flds = rbinds'
+                            , rupd_cons    = PlaceHolder, rupd_in_tys = PlaceHolder
+                            , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }
+                 , fvExpr `plusFV` fvRbinds) }
+
+rnExpr (ExprWithTySig expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
                              rnLExpr expr
-        ; return (ExprWithTySig expr' pty'' wcs_new, fvExpr `plusFV` fvTy) } }
+        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -280,7 +302,7 @@ rnExpr (HsType a)
        ; return (HsType t, fvT) }
 
 rnExpr (ArithSeq _ _ seq)
-  = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
        ; (new_seq, fvs) <- rnArithSeq seq
        ; if opt_OverloadedLists
            then do {
@@ -299,7 +321,7 @@ Since all the symbols are reservedops we can simply reject them.
 We return a (bogus) EWildPat in each case.
 -}
 
-rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)
+rnExpr EWildPat        = return (hsHoleExpr, emptyFVs)   -- "_" is just a hole
 rnExpr e@(EAsPat {})   = patSynErr e
 rnExpr e@(EViewPat {}) = patSynErr e
 rnExpr e@(ELazyPat {}) = patSynErr e
@@ -339,7 +361,9 @@ rnExpr e@(HsStatic expr) = do
              ]
       _ -> do
        let isTopLevelName n = isExternalName n || isWiredInName n
-       case nameSetElems $ filterNameSet (not . isTopLevelName) fvExpr of
+       case nameSetElems $ filterNameSet
+                             (\n -> not (isTopLevelName n || isUnboundName n))
+                             fvExpr                                           of
          [] -> return ()
          fvNonGlobal -> addErr $ cat
              [ text $ "Only identifiers of top-level bindings can "
@@ -371,8 +395,8 @@ rnExpr e@(HsArrForm {}) = arrowFail e
 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
         -- HsWrap
 
-hsHoleExpr :: HsExpr Name
-hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_"))
+hsHoleExpr :: HsExpr id
+hsHoleExpr = HsUnboundVar (mkVarOcc "_")
 
 arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 arrowFail e
@@ -402,25 +426,6 @@ rnSection other = pprPanic "rnSection" (ppr other)
 {-
 ************************************************************************
 *                                                                      *
-        Records
-*                                                                      *
-************************************************************************
--}
-
-rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
-             -> RnM (HsRecordBinds Name, FreeVars)
-rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
-  = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
-       ; (flds', fvss) <- mapAndUnzipM rn_field flds
-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
-                 fvs `plusFV` plusFVs fvss) }
-  where
-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
-
-{-
-************************************************************************
-*                                                                      *
         Arrow commands
 *                                                                      *
 ************************************************************************
@@ -470,7 +475,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
 -- infix form
 rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
-       ; let L _ (HsVar op_name) = op'
+       ; let L _ (HsVar (L _ op_name)) = op'
        ; (arg1',fv_arg1) <- rnCmdTop arg1
        ; (arg2',fv_arg2) <- rnCmdTop arg2
         -- Deal with fixity
@@ -508,14 +513,15 @@ rnCmd (HsCmdIf _ p b1 b2)
        ; (mb_ite, fvITE) <- lookupIfThenElse
        ; return (HsCmdIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }
 
-rnCmd (HsCmdLet binds cmd)
-  = rnLocalBindsAndThen binds $ \ binds' -> do
+rnCmd (HsCmdLet (L l binds) cmd)
+  = rnLocalBindsAndThen binds $ \ binds' -> do
       { (cmd',fvExpr) <- rnLCmd cmd
-      ; return (HsCmdLet binds' cmd', fvExpr) }
+      ; return (HsCmdLet (L l binds') cmd', fvExpr) }
 
-rnCmd (HsCmdDo stmts _)
-  = do  { ((stmts', _), fvs) <- rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
-        ; return ( HsCmdDo stmts' placeHolderType, fvs ) }
+rnCmd (HsCmdDo (L l stmts) _)
+  = do  { ((stmts', _), fvs) <-
+            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))
+        ; return ( HsCmdDo (L l stmts') placeHolderType, fvs ) }
 
 rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd)
 
@@ -541,10 +547,10 @@ methodNamesCmd (HsCmdPar c) = methodNamesLCmd c
 methodNamesCmd (HsCmdIf _ _ c1 c2)
   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 
-methodNamesCmd (HsCmdLet _ c)      = methodNamesLCmd c
-methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts
-methodNamesCmd (HsCmdApp c _)      = methodNamesLCmd c
-methodNamesCmd (HsCmdLam match)    = methodNamesMatch match
+methodNamesCmd (HsCmdLet _ c)          = methodNamesLCmd c
+methodNamesCmd (HsCmdDo (L _ stmts) _) = methodNamesStmts stmts
+methodNamesCmd (HsCmdApp c _)          = methodNamesLCmd c
+methodNamesCmd (HsCmdLam match)        = methodNamesMatch match
 
 methodNamesCmd (HsCmdCase _ matches)
   = methodNamesMatch matches `addOneFV` choiceAName
@@ -556,7 +562,7 @@ methodNamesCmd (HsCmdCase _ matches)
 
 ---------------------------------------------------
 methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars
-methodNamesMatch (MG { mg_alts = ms })
+methodNamesMatch (MG { mg_alts = L _ ms })
   = plusFVs (map do_one ms)
  where
     do_one (L _ (Match _ _ _ grhss)) = methodNamesGRHSs grhss
@@ -580,15 +586,17 @@ methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars
 methodNamesLStmt = methodNamesStmt . unLoc
 
 methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars
-methodNamesStmt (LastStmt cmd _)                 = methodNamesLCmd cmd
+methodNamesStmt (LastStmt cmd _ _)               = methodNamesLCmd cmd
 methodNamesStmt (BodyStmt cmd _ _ _)             = methodNamesLCmd cmd
 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
-methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
+methodNamesStmt (RecStmt { recS_stmts = stmts }) =
+  methodNamesStmts stmts `addOneFV` loopAName
 methodNamesStmt (LetStmt {})                     = emptyFVs
 methodNamesStmt (ParStmt {})                     = emptyFVs
 methodNamesStmt (TransStmt {})                   = emptyFVs
-   -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error
-   -- here so we just do what's convenient
+methodNamesStmt ApplicativeStmt{}            = emptyFVs
+   -- ParStmt and TransStmt can't occur in commands, but it's not
+   -- convenient to error here so we just do what's convenient
 
 {-
 ************************************************************************
@@ -628,20 +636,86 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 ************************************************************************
 -}
 
-rnStmts :: Outputable (body RdrName) => HsStmtContext Name
+-- | Rename some Stmts
+rnStmts :: Outputable (body RdrName)
+        => HsStmtContext Name
+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+           -- ^ How to rename the body of each statement (e.g. rnLExpr)
+        -> [LStmt RdrName (Located (body RdrName))]
+           -- ^ 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)
+rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts
+
+-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts
+rnStmtsWithPostProcessing
+        :: Outputable (body RdrName)
+        => HsStmtContext Name
         -> (Located (body RdrName) -> RnM (Located (body Name), 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))
+           -- ^ postprocess the statements
         -> [LStmt RdrName (Located (body RdrName))]
+           -- ^ 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)
+rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside
+ = do { ((stmts', thing), fvs) <-
+          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside
+      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'
+      ; return ((pp_stmts, thing), fvs `plusFV` fvs')
+      }
+
+-- | maybe rearrange statements according to the ApplicativeDo transformation
+postProcessStmtsForApplicativeDo
+  :: HsStmtContext Name
+  -> [(LStmt Name (LHsExpr Name), FreeVars)]
+  -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
+postProcessStmtsForApplicativeDo ctxt stmts
+  = do {
+       -- rearrange the statements using ApplicativeStmt if
+       -- -XApplicativeDo is on.  Also strip out the FreeVars attached
+       -- to each Stmt body.
+         ado_is_on <- xoptM LangExt.ApplicativeDo
+       ; let is_do_expr | DoExpr <- ctxt = True
+                        | otherwise = False
+       ; if ado_is_on && is_do_expr
+            then rearrangeForApplicativeDo ctxt stmts
+            else noPostProcessStmts ctxt stmts }
+
+-- | strip the FreeVars annotations from statements
+noPostProcessStmts
+  :: HsStmtContext Name
+  -> [(LStmt Name (Located (body Name)), FreeVars)]
+  -> RnM ([LStmt Name (Located (body Name))], FreeVars)
+noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)
+
+
+rnStmtsWithFreeVars :: Outputable (body RdrName)
+        => HsStmtContext Name
+        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+        -> [LStmt RdrName (Located (body RdrName))]
+        -> ([Name] -> RnM (thing, FreeVars))
+        -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
+               , FreeVars)
+-- Each Stmt body is annotated with its FreeVars, so that
+-- we can rearrange statements for ApplicativeDo.
+--
 -- Variables bound by the Stmts, and mentioned in thing_inside,
 -- do not appear in the result FreeVars
 
-rnStmts ctxt _ [] thing_inside
+rnStmtsWithFreeVars ctxt _ [] thing_inside
   = do { checkEmptyStmts ctxt
        ; (thing, fvs) <- thing_inside []
        ; return (([], thing), fvs) }
 
-rnStmts MDoExpr rnBody stmts thing_inside    -- Deal with mdo
+rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo
   = -- Behave like do { rec { ...all but last... }; last }
     do { ((stmts1, (stmts2, thing)), fvs)
            <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->
@@ -651,7 +725,7 @@ rnStmts MDoExpr rnBody stmts thing_inside    -- Deal with mdo
   where
     Just (all_but_last, last_stmt) = snocView stmts
 
-rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
+rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
   | null lstmts
   = setSrcSpan loc $
     do { lstmt' <- checkLastStmt ctxt lstmt
@@ -662,24 +736,29 @@ rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside
             <- setSrcSpan loc                         $
                do { checkStmt ctxt lstmt
                   ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->
-                    rnStmts ctxt rnBody lstmts  $ \ bndrs2 ->
+                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->
                     thing_inside (bndrs1 ++ bndrs2) }
         ; return (((stmts1 ++ stmts2), thing), fvs) }
 
 ----------------------
-rnStmt :: Outputable (body RdrName) => HsStmtContext Name
+rnStmt :: Outputable (body RdrName)
+       => HsStmtContext Name
        -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
+          -- ^ How to rename the body of the statement
        -> LStmt RdrName (Located (body RdrName))
+          -- ^ The statement
        -> ([Name] -> RnM (thing, FreeVars))
-       -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars)
+          -- ^ Rename the stuff that this statement scopes over
+       -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing)
+              , FreeVars)
 -- Variables bound by the Stmt, and mentioned in thing_inside,
 -- do not appear in the result FreeVars
 
-rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside
+rnStmt ctxt rnBody (L loc (LastStmt body noret _)) thing_inside
   = do  { (body', fv_expr) <- rnBody body
         ; (ret_op, fvs1)   <- lookupStmtName ctxt returnMName
         ; (thing,  fvs3)   <- thing_inside []
-        ; return (([L loc (LastStmt body' ret_op)], thing),
+        ; return (([(L loc (LastStmt body' noret ret_op), fv_expr)], thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs3) }
 
 rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
@@ -692,25 +771,32 @@ rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside
                               -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]
                               -- Here "gd" is a guard
         ; (thing, fvs3)    <- thing_inside []
-        ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing),
+        ; return (([(L loc (BodyStmt body'
+                     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
   = do  { (body', fv_expr) <- rnBody body
                 -- The binders do not scope over the expression
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
-        ; (fail_op, fvs2) <- lookupStmtName ctxt failMName
+
+        ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
+        ; let failFunction | xMonadFailEnabled = failMName
+                           | otherwise         = failMName_preMFP
+        ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+
         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
-        ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing),
+        ; return (( [(L loc (BindStmt pat' body' bind_op fail_op), fv_expr)]
+                  , thing),
                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
         -- but it does not matter because the names are unique
 
-rnStmt _ _ (L loc (LetStmt binds)) thing_inside
-  = do  { rnLocalBindsAndThen binds $ \binds' -> do
+rnStmt _ _ (L loc (LetStmt (L l binds))) thing_inside
+  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do
         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
-        ; return (([L loc (LetStmt binds')], thing), fvs) }  }
+        ; return (([(L loc (LetStmt (L l binds')), bind_fvs)], thing), fvs) }  }
 
 rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
   = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName
@@ -734,14 +820,17 @@ rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside
                                             emptyNameSet segs
         ; (thing, fvs_later) <- thing_inside bndrs
         ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
-        ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
+        -- We aren't going to try to group RecStmts with
+        -- ApplicativeDo, so attaching empty FVs is fine.
+        ; 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
         ; (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)], thing)
+        ; return ( ([(L loc (ParStmt segs' mzip_op bind_op), fvs4)], thing)
                  , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
 
 rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form
@@ -757,7 +846,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
                    ; (thing, fvs_thing) <- thing_inside bndrs
                    ; let fvs = fvs_by `plusFV` fvs_thing
                          used_bndrs = filter (`elemNameSet` fvs) bndrs
-                         -- The paper (Fig 5) has a bug here; we must treat any free varaible
+                         -- The paper (Fig 5) has a bug here; we must treat any free variable
                          -- of the "thing inside", **or of the by-expression**, as used
                    ; return ((by', used_bndrs, thing), fvs) }
 
@@ -774,10 +863,13 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for
              -- See Note [TransStmt binder map] in HsExpr
 
        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
-       ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map
+       ; 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_fmap = fmap_op })], thing), all_fvs) }
+                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }
+
+rnStmt _ _ (L _ ApplicativeStmt{}) _ =
+  panic "rnStmt: ApplicativeStmt"
 
 rnParallelStmts :: forall thing. HsStmtContext Name
                 -> SyntaxExpr Name
@@ -832,7 +924,7 @@ lookupStmtName ctxt n
       TransStmtCtxt c -> lookupStmtName c n     -- the parent context
   where
     rebindable     = lookupSyntaxName n
-    not_rebindable = return (HsVar n, emptyFVs)
+    not_rebindable = return (HsVar (noLoc n), emptyFVs)
 
 {-
 Note [Renaming parallel Stmts]
@@ -841,8 +933,9 @@ Renaming parallel statements is painful.  Given, say
      [ a+c | a <- as, bs <- bss
            | c <- bs, a <- ds ]
 Note that
-  (a) In order to report "Defined by not used" about 'bs', we must rename
-      each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
+  (a) In order to report "Defined but not used" about 'bs', we must
+      rename each group of Stmts with a thing_inside whose FreeVars
+      include at least {a,c}
 
   (b) We want to report that 'a' is illegally bound in both branches
 
@@ -871,11 +964,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))
+                     (Located (body RdrName)
+                  -> RnM (Located (body Name), FreeVars))
                   -> [LStmt RdrName (Located (body RdrName))]
                          -- assumes that the FreeVars returned includes
                          -- the FreeVars of the Segments
-                  -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars))
+                  -> ([Segment (LStmt Name (Located (body Name)))]
+                      -> RnM (a, FreeVars))
                   -> RnM (a, FreeVars)
 rnRecStmtsAndThen rnBody s cont
   = do  { -- (A) Make the mini fixity env for all of the stmts
@@ -901,11 +996,11 @@ rnRecStmtsAndThen rnBody s cont
 collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName]
 collectRecStmtsFixities l =
     foldr (\ s -> \acc -> case s of
-                            (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
-                                foldr (\ sig -> \ acc -> case sig of
-                                                           (L loc (FixSig s)) -> (L loc s) : acc
-                                                           _ -> acc) acc sigs
-                            _ -> acc) [] l
+            (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) ->
+                foldr (\ sig -> \ acc -> case sig of
+                                           (L loc (FixSig s)) -> (L loc s) : acc
+                                           _ -> acc) acc sigs
+            _ -> acc) [] l
 
 -- left-hand sides
 
@@ -919,8 +1014,8 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv
 rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c))
   = return [(L loc (BodyStmt body a b c), emptyFVs)]
 
-rn_rec_stmt_lhs _ (L loc (LastStmt body a))
-  = return [(L loc (LastStmt body a), emptyFVs)]
+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))
   = do
@@ -929,12 +1024,12 @@ rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b))
       return [(L loc (BindStmt pat' body a b),
                fv_pat)]
 
-rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
+rn_rec_stmt_lhs _ (L _ (LetStmt (L _ binds@(HsIPBinds _))))
   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
-rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
+rn_rec_stmt_lhs fix_env (L loc (LetStmt (L l(HsValBinds binds))))
     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
-         return [(L loc (LetStmt (HsValBinds binds')),
+         return [(L loc (LetStmt (L l (HsValBinds binds'))),
                  -- Warning: this is bogus; see function invariant
                  emptyFVs
                  )]
@@ -949,7 +1044,10 @@ rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo
 rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt" (ppr stmt)
 
-rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
+rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet
+  = pprPanic "rn_rec_stmt" (ppr stmt)
+
+rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds)))
   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 
 rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv
@@ -975,11 +1073,11 @@ rn_rec_stmt :: (Outputable (body RdrName)) =>
         -- Rename a Stmt that is inside a RecStmt (or mdo)
         -- Assumes all binders are already in scope
         -- Turns each stmt into a singleton Stmt
-rn_rec_stmt rnBody _ (L loc (LastStmt body _), _)
+rn_rec_stmt rnBody _ (L loc (LastStmt body noret _), _)
   = do  { (body', fv_expr) <- rnBody body
         ; (ret_op, fvs1)   <- lookupSyntaxName returnMName
         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,
-                   L loc (LastStmt body' ret_op))] }
+                   L loc (LastStmt body' noret ret_op))] }
 
 rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
   = do { (body', fvs) <- rnBody body
@@ -990,20 +1088,26 @@ rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _), _)
 rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
-       ; (fail_op, fvs2) <- lookupSyntaxName failMName
+
+       ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
+       ; let failFunction | xMonadFailEnabled = failMName
+                          | otherwise         = failMName_preMFP
+       ; (fail_op, fvs2) <- lookupSyntaxName failFunction
+
        ; 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))] }
 
-rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _)), _)
+rn_rec_stmt _ _ (L _ (LetStmt (L _ binds@(HsIPBinds _))), _)
   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 
-rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds')), _)
+rn_rec_stmt _ all_bndrs (L loc (LetStmt (L l (HsValBinds binds'))), _)
   = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
            -- fixities and unused are handled above in rnRecStmtsAndThen
-       ; return [(duDefs du_binds, allUses du_binds,
-                  emptyNameSet, L loc (LetStmt (HsValBinds binds')))] }
+       ; let fvs = allUses du_binds
+       ; return [(duDefs du_binds, fvs, emptyNameSet,
+                 L loc (LetStmt (L l (HsValBinds binds'))))] }
 
 -- no RecStmt case because they get flattened above when doing the LHSes
 rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)
@@ -1015,9 +1119,12 @@ rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo
 rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo
   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)
 
-rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds), _)
+rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _)
   = panic "rn_rec_stmt: LetStmt 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))
              -> [Name]
@@ -1039,7 +1146,7 @@ segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later
 
   | MDoExpr <- ctxt
   = segsToStmts empty_rec_stmt grouped_segs fvs_later
-                -- Step 4: Turn the segments into Stmts
+               -- Step 4: Turn the segments into Stmts
                 --         Use RecStmt when and only when there are fwd refs
                 --         Also gather up the uses from the end towards the
                 --         start, so we can tell the RecStmt which things are
@@ -1183,6 +1290,365 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
 {-
 ************************************************************************
 *                                                                      *
+ApplicativeDo
+*                                                                      *
+************************************************************************
+
+Note [ApplicativeDo]
+
+= Example =
+
+For a sequence of statements
+
+ do
+     x <- A
+     y <- B x
+     z <- C
+     return (f x y z)
+
+We want to transform this to
+
+  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C
+
+It would be easy to notice that "y <- B x" and "z <- C" are
+independent and do something like this:
+
+ do
+     x <- A
+     (y,z) <- (,) <$> B x <*> C
+     return (f x y z)
+
+But this isn't enough! A and C were also independent, and this
+transformation loses the ability to do A and C in parallel.
+
+The algorithm works by first splitting the sequence of statements into
+independent "segments", and a separate "tail" (the final statement). In
+our example above, the segements would be
+
+     [ x <- A
+     , y <- B x ]
+
+     [ z <- C ]
+
+and the tail is:
+
+     return (f x y z)
+
+Then we take these segments and make an Applicative expression from them:
+
+     (\(x,y) z -> return (f x y z))
+       <$> do { x <- A; y <- B x; return (x,y) }
+       <*> C
+
+Finally, we recursively apply the transformation to each segment, to
+discover any nested parallelism.
+
+= Syntax & spec =
+
+  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...
+
+  stmt ::= pat <- expr
+         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1
+         | ...                    -- other kinds of statement (e.g. let)
+
+  arg ::= pat <- expr
+        | {stmt_1; ..; stmt_n} {var_1..var_n}
+
+(note that in the actual implementation,the expr in a do statement is
+represented by a LastStmt as the final stmt, this is just a
+representational issue and may change later.)
+
+== Transformation to introduce applicative stmts ==
+
+ado {} tail = tail
+ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'
+ado {one} tail = one : tail
+ado stmts tail
+  | n == 1 = ado before (ado after tail)
+    where (before,after) = split(stmts_1)
+  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail
+  where
+    {stmts_1 .. stmts_n} = segments(stmts)
+
+segments(stmts) =
+  -- divide stmts into segments with no interdependencies
+
+mkArg({pat <- expr}) = (pat <- expr)
+mkArg({stmt_1; ...; stmt_n}) =
+  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}
+
+split({stmt_1; ..; stmt_n) =
+  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})
+  -- 1 <= i <= n
+  -- i is a good place to insert a bind
+
+== Desugaring for do ==
+
+dsDo {} expr = expr
+
+dsDo {pat <- rhs; stmts} expr =
+   rhs >>= \pat -> dsDo stmts expr
+
+dsDo {(arg_1 | ... | arg_n)} (return expr) =
+  (\argpat (arg_1) .. argpat(arg_n) -> expr)
+     <$> argexpr(arg_1)
+     <*> ...
+     <*> argexpr(arg_n)
+
+dsDo {(arg_1 | ... | arg_n); stmts} expr =
+  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)
+     <$> argexpr(arg_1)
+     <*> ...
+     <*> argexpr(arg_n)
+
+-}
+
+-- | rearrange a list of statements using ApplicativeDoStmt.  See
+-- Note [ApplicativeDo].
+rearrangeForApplicativeDo
+  :: HsStmtContext Name
+  -> [(LStmt Name (LHsExpr Name), FreeVars)]
+  -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
+
+rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)
+rearrangeForApplicativeDo ctxt stmts0 = do
+  (stmts', fvs) <- ado ctxt stmts [last] last_fvs
+  return (stmts', fvs)
+  where (stmts,(last,last_fvs)) = findLast stmts0
+        findLast [] = error "findLast"
+        findLast [last] = ([],last)
+        findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs
+
+-- | The ApplicativeDo transformation.
+ado
+  :: HsStmtContext Name
+  -> [(LStmt Name (LHsExpr Name), FreeVars)] -- ^ input statements
+  -> [LStmt Name (LHsExpr Name)]             -- ^ the "tail"
+  -> FreeVars                                -- ^ free variables of the tail
+  -> RnM ( [LStmt Name (LHsExpr Name)]       -- ( output statements,
+         , FreeVars )                        -- , things we needed
+                                             --    e.g. <$>, <*>, join )
+
+ado _ctxt []        tail _ = return (tail, emptyNameSet)
+
+-- If we have a single bind, and we can do it without a join, transform
+-- to an ApplicativeStmt.  This corresponds to the rule
+--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs
+-- 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 _
+  | 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
+    --          tuples come out as irrefutable; other single-constructor
+    --          types, and newtypes, will not.  See the code for
+    --          isIrrefuatableHsPat
+  = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
+
+ado _ctxt [(one,_)] tail _ = return (one:tail, emptyNameSet)
+
+ado ctxt stmts tail tail_fvs =
+  case segments stmts of  -- chop into segments
+    [] -> panic "ado"
+    [one] ->
+      -- one indivisible segment, divide it by adding a bind
+      adoSegment ctxt one tail tail_fvs
+    segs ->
+      -- multiple segments; recursively transform the segments, and
+      -- combine into an ApplicativeStmt
+      do { pairs <- mapM (adoSegmentArg ctxt tail_fvs) segs
+         ; let (stmts', fvss) = unzip pairs
+         ; let (need_join, tail') = needJoin tail
+         ; (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'
+         ; return (stmts, unionNameSets (fvs:fvss)) }
+
+-- | Deal with an indivisible segment.  We pick a place to insert a
+-- bind (it will actually be a join), and recursively transform the
+-- two halves.
+adoSegment
+  :: HsStmtContext Name
+  -> [(LStmt Name (LHsExpr Name), FreeVars)]
+  -> [LStmt Name (LHsExpr Name)]
+  -> FreeVars
+  -> RnM ( [LStmt Name (LHsExpr Name)], FreeVars )
+adoSegment ctxt stmts tail tail_fvs
+ = do {  -- choose somewhere to put a bind
+        let (before,after) = splitSegment stmts
+      ; (stmts1, fvs1) <- ado ctxt after tail tail_fvs
+      ; let tail1_fvs = unionNameSets (tail_fvs : map snd after)
+      ; (stmts2, fvs2) <- ado ctxt before stmts1 tail1_fvs
+      ; return (stmts2, fvs1 `plusFV` fvs2) }
+
+-- | Given a segment, make an ApplicativeArg.  Here we recursively
+-- call adoSegment on the segment's contents to extract any further
+-- available parallelism.
+adoSegmentArg
+  :: HsStmtContext Name
+  -> FreeVars
+  -> [(LStmt Name (LHsExpr Name), FreeVars)]
+  -> RnM (ApplicativeArg Name Name, FreeVars)
+adoSegmentArg _ _ [(L _ (BindStmt pat exp _ _),_)] =
+  return (ApplicativeArgOne pat exp, emptyFVs)
+adoSegmentArg ctxt tail_fvs stmts =
+  do { let pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
+                      `intersectNameSet` tail_fvs
+           pvars = nameSetElems pvarset
+           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)
+     ; return ( ApplicativeArgMany stmts' mb_ret pat
+              , fvs1 `plusFV` fvs2) }
+
+-- | Divide a sequence of statements into segments, where no segment
+-- depends on any variables defined by a statement in another segment.
+segments
+  :: [(LStmt Name (LHsExpr Name), FreeVars)]
+  -> [[(LStmt Name (LHsExpr Name), FreeVars)]]
+segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)
+  where
+    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)
+
+    -- We would rather not have a segment that just has LetStmts in
+    -- it, so combine those with an adjacent segment where possible.
+    merge [] = []
+    merge (seg : segs)
+       = case rest of
+          [] -> [(seg,all_lets)]
+          ((s,s_lets):ss) | all_lets || s_lets
+               -> (seg ++ s, all_lets && s_lets) : ss
+          _otherwise -> (seg,all_lets) : rest
+      where
+        rest = merge segs
+        all_lets = all (not . isBindStmt . fst) seg
+
+    walk [] = []
+    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest
+      where (seg,rest) = chunter (fvs `intersectNameSet` allvars) stmts
+
+    chunter _ [] = ([], [])
+    chunter vars ((stmt,fvs) : rest)
+       | not (isEmptyNameSet vars)
+       = ((stmt,fvs) : chunk, rest')
+       where (chunk,rest') = chunter vars' rest
+             evars = fvs `intersectNameSet` allvars
+             pvars = mkNameSet (collectStmtBinders (unLoc stmt))
+             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars
+    chunter _ rest = ([], rest)
+
+    isBindStmt (L _ BindStmt{}) = True
+    isBindStmt _ = False
+
+-- | Find a "good" place to insert a bind in an indivisible segment.
+-- This is the only place where we use heuristics.  The current
+-- heuristic is to peel off the first group of independent statements
+-- and put the bind after those.
+splitSegment
+  :: [(LStmt Name (LHsExpr Name), FreeVars)]
+  -> ( [(LStmt Name (LHsExpr Name), FreeVars)]
+     , [(LStmt Name (LHsExpr Name), FreeVars)] )
+splitSegment stmts
+  | Just (lets,binds,rest) <- slurpIndependentStmts stmts
+  =  if not (null lets)
+       then (lets, binds++rest)
+       else (lets++binds, rest)
+  | otherwise
+  = case stmts of
+      (x:xs) -> ([x],xs)
+      _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)] )
+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)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)
+    = go lets ((L loc (BindStmt pat body bind_op fail_op), 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
+  -- group, then move it to the beginning, so that it doesn't interfere with
+  -- grouping more BindStmts.
+  -- TODO: perhaps we shouldn't do this if there are any strict bindings,
+  -- because we might be moving evaluation earlier.
+  go lets indep bndrs ((L loc (LetStmt binds), fvs) : rest)
+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)
+    = go ((L loc (LetStmt binds), fvs) : lets) indep bndrs rest
+  go _ []  _ _ = Nothing
+  go _ [_] _ _ = Nothing
+  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)
+
+-- | Build an ApplicativeStmt, and strip the "return" from the tail
+-- if necessary.
+--
+-- For example, if we start with
+--   do x <- E1; y <- E2; return (f x y)
+-- then we get
+--   do (E1[x] | E2[y]); f x y
+--
+-- the LastStmt in this case has the return removed, but we set the
+-- flag on the LastStmt to indicate this, so that we can print out the
+-- original statement correctly in error messages.  It is easier to do
+-- it this way rather than try to ignore the return later in both the
+-- typechecker and the desugarer (I tried it that way first!).
+mkApplicativeStmt
+  :: HsStmtContext Name
+  -> [ApplicativeArg Name Name]         -- ^ The args
+  -> Bool                               -- ^ True <=> need a join
+  -> [LStmt Name (LHsExpr Name)]        -- ^ The body statements
+  -> RnM ([LStmt Name (LHsExpr Name)], FreeVars)
+mkApplicativeStmt ctxt args need_join body_stmts
+  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName
+       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName
+       ; (mb_join, fvs3) <-
+           if need_join then
+             do { (join_op, fvs) <- lookupStmtName ctxt joinMName
+                ; return (Just join_op, fvs) }
+           else
+             return (Nothing, emptyNameSet)
+       ; let applicative_stmt = noLoc $ ApplicativeStmt
+               (zip (fmap_op : repeat ap_op) args)
+               mb_join
+               placeHolderType
+       ; return ( applicative_stmt : body_stmts
+                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }
+
+-- | Given the statements following an ApplicativeStmt, determine whether
+-- we need a @join@ or not, and remove the @return@ if necessary.
+needJoin :: [LStmt Name (LHsExpr Name)] -> (Bool, [LStmt Name (LHsExpr Name)])
+needJoin [] = (False, [])  -- we're in an ApplicativeArg
+needJoin [L loc (LastStmt e _ t)]
+ | Just arg <- isReturnApp e = (False, [L loc (LastStmt arg True t)])
+needJoin stmts = (True, stmts)
+
+-- | @Just e@, if the expression is @return e@, otherwise @Nothing@
+isReturnApp :: LHsExpr Name -> Maybe (LHsExpr Name)
+isReturnApp (L _ (HsPar expr)) = isReturnApp expr
+isReturnApp (L _ (HsApp f arg))
+  | is_return f = Just arg
+  | otherwise = Nothing
+ where
+  is_return (L _ (HsPar e)) = is_return e
+  is_return (L _ (HsVar (L _ r))) = r == returnMName
+       -- TODO: I don't know how to get this right for rebindable syntax
+  is_return _ = False
+isReturnApp _ = Nothing
+
+
+{-
+************************************************************************
+*                                                                      *
 \subsubsection{Errors}
 *                                                                      *
 ************************************************************************
@@ -1254,6 +1720,7 @@ pprStmtCat (BindStmt {})      = ptext (sLit "binding")
 pprStmtCat (LetStmt {})       = ptext (sLit "let")
 pprStmtCat (RecStmt {})       = ptext (sLit "rec")
 pprStmtCat (ParStmt {})       = ptext (sLit "parallel")
+pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"
 
 ------------
 emptyInvalid :: Validity  -- Payload is the empty document
@@ -1290,14 +1757,14 @@ okPatGuardStmt stmt
 -------------
 okParStmt dflags ctxt stmt
   = case stmt of
-      LetStmt (HsIPBinds {}) -> emptyInvalid
-      _                      -> okStmt dflags ctxt stmt
+      LetStmt (L _ (HsIPBinds {})) -> emptyInvalid
+      _                            -> okStmt dflags ctxt stmt
 
 ----------------
 okDoStmt dflags ctxt stmt
   = case stmt of
        RecStmt {}
-         | Opt_RecursiveDo `xopt` dflags -> IsValid
+         | LangExt.RecursiveDo `xopt` dflags -> IsValid
          | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
          | otherwise         -> NotValid (ptext (sLit "Use RecursiveDo"))
        BindStmt {} -> IsValid
@@ -1312,13 +1779,14 @@ okCompStmt dflags _ stmt
        LetStmt {}  -> IsValid
        BodyStmt {} -> IsValid
        ParStmt {}
-         | Opt_ParallelListComp `xopt` dflags -> IsValid
+         | LangExt.ParallelListComp `xopt` dflags -> IsValid
          | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
        TransStmt {}
-         | Opt_TransformListComp `xopt` dflags -> IsValid
+         | LangExt.TransformListComp `xopt` dflags -> IsValid
          | otherwise -> NotValid (ptext (sLit "Use TransformListComp"))
        RecStmt {}  -> emptyInvalid
        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
+       ApplicativeStmt {} -> emptyInvalid
 
 ----------------
 okPArrStmt dflags _ stmt
@@ -1327,16 +1795,17 @@ okPArrStmt dflags _ stmt
        LetStmt {}  -> IsValid
        BodyStmt {} -> IsValid
        ParStmt {}
-         | Opt_ParallelListComp `xopt` dflags -> IsValid
+         | LangExt.ParallelListComp `xopt` dflags -> IsValid
          | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
        TransStmt {} -> emptyInvalid
        RecStmt {}   -> emptyInvalid
        LastStmt {}  -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
+       ApplicativeStmt {} -> emptyInvalid
 
 ---------
 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
 checkTupleSection args
-  = do  { tuple_section <- xoptM Opt_TupleSections
+  = do  { tuple_section <- xoptM LangExt.TupleSections
         ; checkErr (all tupArgPresent args || tuple_section) msg }
   where
     msg = ptext (sLit "Illegal tuple section: use TupleSections")