Make Applicative a superclass of Monad
authorAustin Seipp <austin@well-typed.com>
Tue, 22 Apr 2014 11:09:40 +0000 (06:09 -0500)
committerAustin Seipp <austin@well-typed.com>
Tue, 9 Sep 2014 13:13:27 +0000 (08:13 -0500)
Summary:
This includes pretty much all the changes needed to make `Applicative`
a superclass of `Monad` finally. There's mostly reshuffling in the
interests of avoid orphans and boot files, but luckily we can resolve
all of them, pretty much. The only catch was that
Alternative/MonadPlus also had to go into Prelude to avoid this.

As a result, we must update the hsc2hs and haddock submodules.

Signed-off-by: Austin Seipp <austin@well-typed.com>
Test Plan: Build things, they might not explode horribly.

Reviewers: hvr, simonmar

Subscribers: simonmar

Differential Revision: https://phabricator.haskell.org/D13

128 files changed:
aclocal.m4
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmLint.hs
compiler/cmm/PprC.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmExtCode.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CoreLint.lhs
compiler/deSugar/Coverage.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/MatchLit.lhs
compiler/ghci/ByteCodeAsm.lhs
compiler/ghci/ByteCodeGen.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsBinds.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/llvmGen/LlvmCodeGen/Base.hs
compiler/main/CmdLineParser.hs
compiler/main/DriverPipeline.hs
compiler/main/ErrUtils.lhs
compiler/main/Finder.lhs
compiler/main/HeaderInfo.hs
compiler/main/Packages.lhs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/NCGMonad.hs
compiler/nativeGen/RegAlloc/Linear/State.hs
compiler/parser/Lexer.x
compiler/parser/RdrHsSyn.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/profiling/SCCfinal.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnNames.lhs
compiler/simplCore/CoreMonad.lhs
compiler/specialise/Specialise.lhs
compiler/stgSyn/StgLint.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcForeign.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/typecheck/TcValidity.lhs
compiler/types/Unify.lhs
compiler/utils/IOEnv.hs
compiler/utils/Maybes.lhs
compiler/utils/Stream.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Type/Env.hs
ghc/GhciMonad.hs
ghc/InteractiveUI.hs
libraries/base/Control/Applicative.hs
libraries/base/Control/Arrow.hs
libraries/base/Control/Monad.hs
libraries/base/Control/Monad/ST/Lazy/Imp.hs
libraries/base/Data/Either.hs
libraries/base/Data/Maybe.hs
libraries/base/Data/Monoid.hs
libraries/base/Data/Proxy.hs
libraries/base/Foreign/Storable.hs
libraries/base/GHC/Base.lhs
libraries/base/GHC/Conc/Sync.lhs
libraries/base/GHC/Event/Array.hs
libraries/base/GHC/Event/EPoll.hsc
libraries/base/GHC/Event/Internal.hs
libraries/base/GHC/Event/Manager.hs
libraries/base/GHC/Event/Poll.hsc
libraries/base/GHC/Event/TimerManager.hs
libraries/base/GHC/GHCi.hs
libraries/base/GHC/ST.lhs
libraries/base/Prelude.hs
libraries/base/Text/ParserCombinators/ReadP.hs
libraries/base/Text/ParserCombinators/ReadPrec.hs
libraries/template-haskell/Language/Haskell/TH/PprLib.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
mk/validate-settings.mk
testsuite/tests/deriving/should_fail/T3621.hs
testsuite/tests/deriving/should_fail/T3621.stderr
testsuite/tests/deriving/should_run/drvrun019.hs
testsuite/tests/ghci/scripts/T4175.stdout
testsuite/tests/ghci/scripts/T7627.stdout
testsuite/tests/ghci/scripts/T8535.stdout
testsuite/tests/ghci/scripts/ghci011.stdout
testsuite/tests/ghci/scripts/ghci020.stdout
testsuite/tests/ghci/scripts/ghci025.stdout
testsuite/tests/ghci/scripts/ghci027.stdout
testsuite/tests/indexed-types/should_fail/T4485.hs
testsuite/tests/indexed-types/should_fail/T4485.stderr
testsuite/tests/indexed-types/should_fail/T7729.hs
testsuite/tests/indexed-types/should_fail/T7729.stderr
testsuite/tests/indexed-types/should_fail/T7729a.hs
testsuite/tests/indexed-types/should_fail/T7729a.stderr
testsuite/tests/mdo/should_compile/mdo002.hs
testsuite/tests/parser/should_compile/T7476/T7476.stdout
testsuite/tests/perf/compiler/all.T
testsuite/tests/perf/haddock/all.T
testsuite/tests/polykinds/MonoidsFD.hs
testsuite/tests/polykinds/MonoidsTF.hs
testsuite/tests/rebindable/rebindable2.hs
testsuite/tests/rename/should_compile/T1954.hs
testsuite/tests/rename/should_compile/T7145a.hs
testsuite/tests/rename/should_compile/T7145b.stderr
testsuite/tests/rename/should_fail/T2993.stderr
testsuite/tests/simplCore/should_compile/T8848.stderr
testsuite/tests/simplCore/should_compile/simpl017.hs
testsuite/tests/simplCore/should_compile/simpl017.stderr
testsuite/tests/simplCore/should_run/T3591.hs
testsuite/tests/typecheck/should_compile/T4524.hs
testsuite/tests/typecheck/should_compile/T4969.hs
testsuite/tests/typecheck/should_compile/tc213.hs
utils/ghc-pkg/Main.hs
utils/haddock
utils/hsc2hs

index 09300f1..0dda8af 100644 (file)
@@ -897,8 +897,8 @@ changequote([, ])dnl
 ])
 if test ! -f compiler/parser/Parser.hs || test ! -f compiler/cmm/CmmParse.hs
 then
-    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19],
-      [AC_MSG_ERROR([Happy version 1.19 or later is required to compile GHC.])])[]
+    FP_COMPARE_VERSIONS([$fptools_cv_happy_version],[-lt],[1.19.4],
+      [AC_MSG_ERROR([Happy version 1.19.4 or later is required to compile GHC.])])[]
 fi
 HappyVersion=$fptools_cv_happy_version;
 AC_SUBST(HappyVersion)
index c582b78..188233d 100644 (file)
@@ -33,6 +33,10 @@ import Data.Bits
 import Data.List (nub)
 import Control.Monad (liftM)
 
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding ((<*>))
+#endif
+
 #include "HsVersions.h"
 
 {- Note [Stack Layout]
index 970ce68..d329243 100644 (file)
@@ -5,7 +5,7 @@
 -- CmmLint: checking the correctness of Cmm statements and expressions
 --
 -----------------------------------------------------------------------------
-{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GADTs, CPP #-}
 module CmmLint (
     cmmLint, cmmLintGraph
   ) where
@@ -22,7 +22,9 @@ import DynFlags
 
 import Data.Maybe
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 
 -- Things to check:
 --     - invariant on CmmBlock in CmmExpr (see comment there)
index c25147c..9502d34 100644 (file)
@@ -54,7 +54,9 @@ import Data.Word
 import System.IO
 import qualified Data.Map as Map
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 
 import qualified Data.Array.Unsafe as U ( castSTUArray )
 import Data.Array.ST
index 4631b2d..444112f 100644 (file)
@@ -53,6 +53,10 @@ import DynFlags
 import Data.Maybe
 import Control.Monad
 
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding ((<*>))
+#endif
+
 ------------------------------------------------------------------------
 --              Top-level bindings
 ------------------------------------------------------------------------
index ad34b5b..b2b64f8 100644 (file)
@@ -48,6 +48,10 @@ import Outputable
 
 import Control.Monad (when,void)
 
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding ((<*>))
+#endif
+
 ------------------------------------------------------------------------
 --              cgExpr: the main function
 ------------------------------------------------------------------------
index 5f412b3..931b556 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 -- | Our extended FCode monad.
 
 -- We add a mapping from names to CmmExpr, to support local variable names in
@@ -49,8 +51,9 @@ import UniqFM
 import Unique
 
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
-
+#endif
 
 -- | The environment contains variable definitions or blockids.
 data Named
index 6937c85..eb1c7da 100644 (file)
@@ -41,7 +41,12 @@ import Outputable
 import BasicTypes
 
 import Control.Monad
+
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding( succ, (<*>) )
+#else
 import Prelude hiding( succ )
+#endif
 
 -----------------------------------------------------------------------------
 -- Code generation for Foreign Calls
index 7ac2c7a..eca118f 100644 (file)
@@ -47,6 +47,10 @@ import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
 
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding ((<*>))
+#endif
+
 import Control.Monad (when)
 import Data.Maybe (isJust)
 
index d62101f..af2d661 100644 (file)
@@ -25,6 +25,10 @@ module StgCmmLayout (
 
 #include "HsVersions.h"
 
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding ((<*>))
+#endif
+
 import StgCmmClosure
 import StgCmmEnv
 import StgCmmArgRep -- notably: ( slowCallPattern )
index 22c89d7..57120cf 100644 (file)
@@ -393,7 +393,7 @@ addCodeBlocksFrom :: CgState -> CgState -> CgState
 -- Add code blocks from the latter to the former
 -- (The cgs_stmts will often be empty, but not always; see codeOnly)
 s1 `addCodeBlocksFrom` s2
-  = s1 { cgs_stmts = cgs_stmts s1 <*> cgs_stmts s2,
+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,
          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }
 
 
@@ -697,7 +697,7 @@ newLabelC = do { u <- newUnique
 emit :: CmmAGraph -> FCode ()
 emit ag
   = do  { state <- getState
-        ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } }
+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }
 
 emitDecl :: CmmDecl -> FCode ()
 emitDecl decl
@@ -724,7 +724,7 @@ emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
 emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
   = do  { dflags <- getDynFlags
         ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args
-        ; emitProc_ mb_info lbl live (entry <*> blocks) offset True
+        ; emitProc_ mb_info lbl live (entry MkGraph.<*> blocks) offset True
         }
 emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
 
@@ -778,21 +778,21 @@ mkCmmIfThenElse e tbranch fbranch = do
   endif <- newLabelC
   tid   <- newLabelC
   fid   <- newLabelC
-  return $ mkCbranch e tid fid <*>
-            mkLabel tid <*> tbranch <*> mkBranch endif <*>
-            mkLabel fid <*> fbranch <*> mkLabel endif
+  return $ mkCbranch e tid fid MkGraph.<*>
+            mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkBranch endif MkGraph.<*>
+            mkLabel fid MkGraph.<*> fbranch MkGraph.<*> mkLabel endif
 
 mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph
 mkCmmIfGoto e tid = do
   endif <- newLabelC
-  return $ mkCbranch e tid endif <*> mkLabel endif
+  return $ mkCbranch e tid endif MkGraph.<*> mkLabel endif
 
 mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph
 mkCmmIfThen e tbranch = do
   endif <- newLabelC
   tid   <- newLabelC
-  return $ mkCbranch e tid endif <*>
-         mkLabel tid <*> tbranch <*> mkLabel endif
+  return $ mkCbranch e tid endif MkGraph.<*>
+         mkLabel tid MkGraph.<*> tbranch MkGraph.<*> mkLabel endif
 
 
 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
@@ -803,7 +803,7 @@ mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
   let area = Young k
       (off, _, copyin) = copyInOflow dflags retConv area results []
       copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
-  return (copyout <*> mkLabel k <*> copyin)
+  return (copyout MkGraph.<*> mkLabel k MkGraph.<*> copyin)
 
 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
           -> FCode CmmAGraph
index e6f4e48..a86caf1 100644 (file)
@@ -43,6 +43,10 @@ import FastString
 import Outputable
 import Util
 
+#if __GLASGOW_HASKELL__ >= 709
+import Prelude hiding ((<*>))
+#endif
+
 import Data.Bits ((.&.), bit)
 import Control.Monad (liftM, when)
 
index 985c6db..d47a016 100644 (file)
@@ -709,7 +709,7 @@ label_code :: BlockId -> CmmAGraph -> FCode BlockId
 -- and returns L
 label_code join_lbl code = do
     lbl <- newLabelC
-    emitOutOfLine lbl (code <*> mkBranch join_lbl)
+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl)
     return lbl
 
 --------------
index 21e0b5f..f6bb1a2 100644 (file)
@@ -1283,7 +1283,7 @@ dumpLoc (CasePat (con, args, _))
 dumpLoc (ImportedUnfolding locn)
   = (locn, brackets (ptext (sLit "in an imported unfolding")))
 dumpLoc TopLevelBindings
-  = (noSrcLoc, empty)
+  = (noSrcLoc, Outputable.empty)
 dumpLoc (InType ty)
   = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
 dumpLoc (InCo co)
index fae5f36..5e7289f 100644 (file)
@@ -1209,7 +1209,7 @@ static void hpc_init_Main(void)
 
 \begin{code}
 hpcInitCode :: Module -> HpcInfo -> SDoc
-hpcInitCode _ (NoHpcInfo {}) = empty
+hpcInitCode _ (NoHpcInfo {}) = Outputable.empty
 hpcInitCode this_mod (HpcInfo tickCount hashNo)
  = vcat
     [ text "static void hpc_init_" <> ppr this_mod
index 7b18b2e..6844f48 100644 (file)
@@ -426,7 +426,7 @@ dsExpr (RecordCon (L _ data_con_id) con_expr rbinds) = do
               (rhs:rhss) -> ASSERT( null rhss )
                             dsLExpr rhs
               []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr lbl)
-        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty empty
+        unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
 
         labels = dataConFieldLabels (idDataCon data_con_id)
         -- The data_con_id is guaranteed to be the wrapper id of the constructor
index 38ed3af..f404997 100644 (file)
@@ -186,7 +186,7 @@ warnAboutOverflowedLiterals dflags lit
             , i > 0
             , not (xopt Opt_NegativeLiterals dflags)
             = ptext (sLit "If you are trying to write a large negative literal, use NegativeLiterals")
-            | otherwise = empty
+            | otherwise = Outputable.empty
 \end{code}
 
 Note [Suggest NegativeLiterals]
index 52d6add..5a9cec2 100644 (file)
@@ -35,7 +35,9 @@ import Outputable
 import Platform
 import Util
 
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 import Control.Monad
 import Control.Monad.ST ( runST )
 import Control.Monad.Trans.Class
index 645a0d8..a6e80e5 100644 (file)
@@ -49,7 +49,9 @@ import Data.List
 import Foreign
 import Foreign.C
 
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 import Control.Monad
 import Data.Char
 
index 7b841d5..c7c9935 100644 (file)
@@ -7,6 +7,7 @@ This module converts Template Haskell syntax into HsSyn
 
 \begin{code}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE CPP #-}
 
 module Convert( convertToHsExpr, convertToPat, convertToHsDecls,
                 convertToHsType,
@@ -36,7 +37,9 @@ import Outputable
 
 import qualified Data.ByteString as BS
 import Control.Monad( unless, liftM, ap )
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 
 import Language.Haskell.TH as TH hiding (sigP)
 import Language.Haskell.TH.Syntax as TH
index e0176a5..5ebada6 100644 (file)
@@ -13,6 +13,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
 {-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 
 module HsBinds where
 
@@ -43,7 +44,11 @@ import Data.Ord
 import Data.Foldable ( Foldable(..) )
 import Data.Traversable ( Traversable(..) )
 import Data.Monoid ( mappend )
-import Control.Applicative ( (<$>), (<*>) )
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative hiding (empty)
+#else
+import Control.Applicative ((<$>))
+#endif
 \end{code}
 
 %************************************************************************
index 935b8ed..6fec398 100644 (file)
@@ -608,10 +608,10 @@ showAll = ShowSub { ss_how_much = ShowIface, ss_ppr_bndr = ppr }
 
 ppShowIface :: ShowSub -> SDoc -> SDoc
 ppShowIface (ShowSub { ss_how_much = ShowIface }) doc = doc
-ppShowIface _                                     _   = empty
+ppShowIface _                                     _   = Outputable.empty
 
 ppShowRhs :: ShowSub -> SDoc -> SDoc
-ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _   = empty
+ppShowRhs (ShowSub { ss_how_much = ShowHeader }) _   = Outputable.empty
 ppShowRhs _                                      doc = doc
 
 showSub :: HasOccName n => ShowSub -> n -> Bool
@@ -675,13 +675,13 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
                _          -> ptext (sLit "instance") <+> pprIfaceTyConParent parent
 
     pp_roles
-      | is_data_instance = empty
+      | is_data_instance = Outputable.empty
       | otherwise        = pprRoles (== Representational) (pprPrefixIfDeclBndr ss tycon) 
                                     tc_tyvars roles
             -- Don't display roles for data family instances (yet)
             -- See discussion on Trac #8672.
 
-    add_bars []     = empty
+    add_bars []     = Outputable.empty
     add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)
 
     ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
@@ -716,7 +716,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
     pp_extra = vcat [pprCType ctype, pprRec isrec, pp_prom]
 
     pp_prom | is_prom   = ptext (sLit "Promotable")
-            | otherwise = empty
+            | otherwise = Outputable.empty
 
 
 pprIfaceDecl ss (IfaceClass { ifATs = ats, ifSigs = sigs, ifRec = isrec
@@ -767,7 +767,7 @@ pprIfaceDecl ss (IfaceSyn { ifName = tycon, ifTyVars = tyvars
     pp_branches (IfaceClosedSynFamilyTyCon ax brs)
       = vcat (map (pprAxBranch (pprPrefixIfDeclBndr ss tycon)) brs)
         $$ ppShowIface ss (ptext (sLit "axiom") <+> ppr ax)
-    pp_branches _ = empty
+    pp_branches _ = Outputable.empty
 
 pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
                               ifPatIsInfix = is_infix,
@@ -806,7 +806,7 @@ pprIfaceDecl _ (IfaceAxiom { ifName = name, ifTyCon = tycon
 
 
 pprCType :: Maybe CType -> SDoc
-pprCType Nothing      = empty
+pprCType Nothing      = Outputable.empty
 pprCType (Just cType) = ptext (sLit "C type:") <+> ppr cType
 
 -- if, for each role, suppress_if role is True, then suppress the role
@@ -819,7 +819,7 @@ pprRoles suppress_if tyCon tyvars roles
          ptext (sLit "type role") <+> tyCon <+> hsep (map ppr froles)
 
 pprRec :: RecFlag -> SDoc
-pprRec NonRecursive = empty
+pprRec NonRecursive = Outputable.empty
 pprRec Recursive    = ptext (sLit "RecFlag: Recursive")
 
 pprInfixIfDeclBndr, pprPrefixIfDeclBndr :: ShowSub -> OccName -> SDoc
@@ -843,7 +843,7 @@ pprIfaceAT :: ShowSub -> IfaceAT -> SDoc
 pprIfaceAT ss (IfaceAT d mb_def)
   = vcat [ pprIfaceDecl ss d
          , case mb_def of
-              Nothing  -> empty
+              Nothing  -> Outputable.empty
               Just rhs -> nest 2 $
                           ptext (sLit "Default:") <+> ppr rhs ]
 
@@ -852,7 +852,7 @@ instance Outputable IfaceTyConParent where
 
 pprIfaceTyConParent :: IfaceTyConParent -> SDoc
 pprIfaceTyConParent IfNoParent
-  = empty
+  = Outputable.empty
 pprIfaceTyConParent (IfDataInstance _ tc tys)
   = sdocWithDynFlags $ \dflags ->
     let ftys = stripKindArgs dflags tys
@@ -1071,13 +1071,15 @@ instance Outputable IfaceConAlt where
 
 ------------------
 instance Outputable IfaceIdDetails where
-  ppr IfVanillaId       = empty
+  ppr IfVanillaId       = Outputable.empty
   ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc
-                          <+> if b then ptext (sLit "<naughty>") else empty
+                          <+> if b
+                                then ptext (sLit "<naughty>")
+                                else Outputable.empty
   ppr (IfDFunId ns)     = ptext (sLit "DFunId") <> brackets (int ns)
 
 instance Outputable IfaceIdInfo where
-  ppr NoInfo       = empty
+  ppr NoInfo       = Outputable.empty
   ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is
                      <+> ptext (sLit "-}")
 
@@ -1092,7 +1094,9 @@ instance Outputable IfaceInfoItem where
 
 instance Outputable IfaceUnfolding where
   ppr (IfCompulsory e)     = ptext (sLit "<compulsory>") <+> parens (ppr e)
-  ppr (IfCoreUnfold s e)   = (if s then ptext (sLit "<stable>") else empty)
+  ppr (IfCoreUnfold s e)   = (if s
+                                then ptext (sLit "<stable>")
+                                else Outputable.empty)
                               <+> parens (ppr e)
   ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule")
                                             <+> ppr (a,uok,bok),
@@ -1511,7 +1515,7 @@ instance Binary IfaceSynTyConRhs where
     put_ bh IfaceAbstractClosedSynFamilyTyCon = putByte bh 2
     put_ bh (IfaceSynonymTyCon ty)            = putByte bh 3 >> put_ bh ty
     put_ _ IfaceBuiltInSynFamTyCon
-        = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" empty
+        = pprPanic "Cannot serialize IfaceBuiltInSynFamTyCon, used for pretty-printing only" Outputable.empty
 
     get bh = do { h <- getByte bh
                 ; case h of
@@ -1906,4 +1910,4 @@ instance Binary IfaceTyConParent where
                 pr <- get bh
                 ty <- get bh
                 return $ IfDataInstance ax pr ty
-\end{code}
\ No newline at end of file
+\end{code}
index 2be6e9d..fa6f603 100644 (file)
@@ -549,7 +549,7 @@ findAndReadIface doc_str mod hi_boot_file
   = do traceIf (sep [hsep [ptext (sLit "Reading"), 
                            if hi_boot_file 
                              then ptext (sLit "[boot]") 
-                             else empty,
+                             else Outputable.empty,
                            ptext (sLit "interface for"), 
                            ppr mod <> semi],
                      nest 4 (ptext (sLit "reason:") <+> doc_str)])
@@ -736,9 +736,9 @@ pprModIface :: ModIface -> SDoc
 pprModIface iface
  = vcat [ ptext (sLit "interface")
                 <+> ppr (mi_module iface) <+> pp_boot
-                <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else empty)
-                <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else empty)
-                <+> (if mi_hpc    iface then ptext (sLit "[hpc]") else empty)
+                <+> (if mi_orphan iface then ptext (sLit "[orphan module]") else Outputable.empty)
+                <+> (if mi_finsts iface then ptext (sLit "[family instance module]") else Outputable.empty)
+                <+> (if mi_hpc    iface then ptext (sLit "[hpc]") else Outputable.empty)
                 <+> integer hiVersion
         , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))
         , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))
@@ -764,7 +764,7 @@ pprModIface iface
         ]
   where
     pp_boot | mi_boot iface = ptext (sLit "[boot]")
-            | otherwise     = empty
+            | otherwise     = Outputable.empty
 \end{code}
 
 When printing export lists, we print like this:
@@ -775,12 +775,12 @@ When printing export lists, we print like this:
 \begin{code}
 pprExport :: IfaceExport -> SDoc
 pprExport (Avail n)      = ppr n
-pprExport (AvailTC _ []) = empty
+pprExport (AvailTC _ []) = Outputable.empty
 pprExport (AvailTC n (n':ns)) 
   | n==n'     = ppr n <> pp_export ns
   | otherwise = ppr n <> char '|' <> pp_export (n':ns)
   where  
-    pp_export []    = empty
+    pp_export []    = Outputable.empty
     pp_export names = braces (hsep (map ppr names))
 
 pprUsage :: Usage -> SDoc
@@ -789,7 +789,7 @@ pprUsage usage@UsagePackageModule{}
 pprUsage usage@UsageHomeModule{}
   = pprUsageImport usage usg_mod_name $$
     nest 2 (
-        maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
         vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
         )
 pprUsage usage@UsageFile{}
@@ -815,12 +815,12 @@ pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
   where
     ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot
     ppr_pkg (pkg,trust_req)  = ppr pkg <>
-                               (if trust_req then text "*" else empty)
+                               (if trust_req then text "*" else Outputable.empty)
     ppr_boot True  = text "[boot]"
-    ppr_boot False = empty
+    ppr_boot False = Outputable.empty
 
 pprFixities :: [(OccName, Fixity)] -> SDoc
-pprFixities []    = empty
+pprFixities []    = Outputable.empty
 pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes
                   where
                     pprFix (occ,fix) = ppr fix <+> ppr occ 
@@ -850,7 +850,7 @@ instance Outputable Warnings where
     ppr = pprWarns
 
 pprWarns :: Warnings -> SDoc
-pprWarns NoWarnings         = empty
+pprWarns NoWarnings         = Outputable.empty
 pprWarns (WarnAll txt)  = ptext (sLit "Warn all") <+> ppr txt
 pprWarns (WarnSome prs) = ptext (sLit "Warnings")
                         <+> vcat (map pprWarning prs)
@@ -905,7 +905,7 @@ homeModError mod location
   = ptext (sLit "attempting to use module ") <> quotes (ppr mod)
     <> (case ml_hs_file location of
            Just file -> space <> parens (text file)
-           Nothing   -> empty)
+           Nothing   -> Outputable.empty)
     <+> ptext (sLit "which is not loaded")
 \end{code}
 
index 9b5886a..ec41f0d 100644 (file)
@@ -796,7 +796,7 @@ freeNamesIdExtras :: IfaceIdExtras -> NameSet
 freeNamesIdExtras (IdExtras _ rules _) = unionManyNameSets (map freeNamesIfRule rules)
 
 instance Outputable IfaceDeclExtras where
-  ppr IfaceOtherDeclExtras       = empty
+  ppr IfaceOtherDeclExtras       = Outputable.empty
   ppr (IfaceIdExtras  extras)    = ppr_id_extras extras
   ppr (IfaceSynExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]
   ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,
@@ -1047,7 +1047,7 @@ mk_mod_usage_info pit hsc_env this_mod direct_imports used_names
         (is_direct_import, imp_safe)
             = case lookupModuleEnv direct_imports mod of
                 Just ((_,_,_,safe):_xs) -> (True, safe)
-                Just _                  -> pprPanic "mkUsage: empty direct import" empty
+                Just _                  -> pprPanic "mkUsage: empty direct import" Outputable.empty
                 Nothing                 -> (False, safeImplicitImpsReq dflags)
                 -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn'
                 -- is used in the source code. We require them to be safe in Safe Haskell
index 50cd824..0d6e1ac 100644 (file)
@@ -57,7 +57,9 @@ import ErrUtils
 import qualified Stream
 
 import Control.Monad (ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 
 -- ----------------------------------------------------------------------------
 -- * Some Data Types
index 5ee7086..7d7bbfe 100644 (file)
@@ -33,8 +33,9 @@ import Data.Function
 import Data.List
 
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
-
+#endif
 
 --------------------------------------------------------
 --         The Flag and OptKind types
index 5a18e6e..0e17793 100644 (file)
@@ -1593,7 +1593,7 @@ mkExtraObjToLinkIntoBinary dflags = do
 
   where
     main
-      | gopt Opt_NoHsMain dflags = empty
+      | gopt Opt_NoHsMain dflags = Outputable.empty
       | otherwise = vcat [
              ptext (sLit "#include \"Rts.h\""),
              ptext (sLit "extern StgClosure ZCMain_main_closure;"),
@@ -1603,7 +1603,7 @@ mkExtraObjToLinkIntoBinary dflags = do
              ptext (sLit "    __conf.rts_opts_enabled = ")
                  <> text (show (rtsOptsEnabled dflags)) <> semi,
              case rtsOpts dflags of
-                Nothing   -> empty
+                Nothing   -> Outputable.empty
                 Just opts -> ptext (sLit "    __conf.rts_opts= ") <>
                                text (show opts) <> semi,
              ptext (sLit "    __conf.rts_hs_main = rtsTrue;"),
@@ -1639,7 +1639,7 @@ mkNoteObjsToLinkIntoBinary dflags dep_packages = do
           -- where we need to do this.
           (if platformHasGnuNonexecStack (targetPlatform dflags)
            then text ".section .note.GNU-stack,\"\",@progbits\n"
-           else empty)
+           else Outputable.empty)
 
            ]
           where
index c43064e..b06f5bc 100644 (file)
@@ -55,7 +55,11 @@ import qualified Data.Set as Set
 import Data.IORef
 import Data.Ord
 import Data.Time
+#if __GLASGOW_HASKELL__ >= 709
+import Control.Monad hiding (empty)
+#else
 import Control.Monad
+#endif
 import Control.Monad.IO.Class
 import System.IO
 
index b5ad08b..f56c173 100644 (file)
@@ -609,7 +609,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
          tried_these files
 
     tried_these files
-        | null files = empty
+        | null files = Outputable.empty
         | verbosity dflags < 3 =
               ptext (sLit "Use -v to see a list of the files searched for.")
         | otherwise =
@@ -628,14 +628,14 @@ cantFindErr cannot_find _ dflags mod_name find_result
            in ptext (sLit "Perhaps you need to add") <+>
               quotes (ppr (packageName pkg)) <+>
               ptext (sLit "to the build-depends in your .cabal file.")
-     | otherwise = empty
+     | otherwise = Outputable.empty
 
     mod_hidden pkg =
         ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg)
 
     pp_suggestions :: [ModuleSuggestion] -> SDoc
     pp_suggestions sugs
-      | null sugs = empty
+      | null sugs = Outputable.empty
       | otherwise = hang (ptext (sLit "Perhaps you meant"))
                        2 (vcat (map pp_sugg sugs))
 
@@ -643,7 +643,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
     -- package flags when making suggestions.  ToDo: if the original package
     -- also has a reexport, prefer that one
     pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o
-      where provenance ModHidden = empty
+      where provenance ModHidden = Outputable.empty
             provenance (ModOrigin{ fromOrigPackage = e,
                                    fromExposedReexport = res,
                                    fromPackageFlag = f })
@@ -657,9 +657,9 @@ cantFindErr cannot_find _ dflags mod_name find_result
               | f
                  = parens (ptext (sLit "defined via package flags to be")
                     <+> ppr mod)
-              | otherwise = empty
+              | otherwise = Outputable.empty
     pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o
-      where provenance ModHidden =  empty
+      where provenance ModHidden =  Outputable.empty
             provenance (ModOrigin{ fromOrigPackage = e,
                                    fromHiddenReexport = rhs })
               | Just False <- e
@@ -668,5 +668,5 @@ cantFindErr cannot_find _ dflags mod_name find_result
               | (pkg:_) <- rhs
                  = parens (ptext (sLit "needs flag -package-key")
                     <+> ppr (packageConfigId pkg))
-              | otherwise = empty
+              | otherwise = Outputable.empty
 \end{code}
index fcf235b..c6d72b2 100644 (file)
@@ -300,7 +300,7 @@ unsupportedExtnError dflags loc unsup =
   throw $ mkSrcErr $ unitBag $
     mkPlainErrMsg dflags loc $
         text "Unsupported extension: " <> text unsup $$
-        if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
+        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
   where
      suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 
index 01c75c0..c14c8cf 100644 (file)
@@ -589,7 +589,7 @@ packageFlagErr dflags (ExposePackage (PackageArg pkg) _) []
 packageFlagErr dflags flag reasons
   = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
   where err = text "cannot satisfy " <> pprFlag flag <>
-                (if null reasons then empty else text ": ") $$
+                (if null reasons then Outputable.empty else text ": ") $$
               nest 4 (ppr_reasons $$
                       -- ToDo: this admonition seems a bit dodgy
                       text "(use -v for more information)")
@@ -608,7 +608,7 @@ pprFlag flag = case flag of
                      PackageArg    p -> text "-package " <> text p
                      PackageIdArg  p -> text "-package-id " <> text p
                      PackageKeyArg p -> text "-package-key " <> text p
-        ppr_rns Nothing = empty
+        ppr_rns Nothing = Outputable.empty
         ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns))
                                       <> char ')'
         ppr_rn (orig, new) | orig == new = text orig
@@ -1374,7 +1374,7 @@ missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
 missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p
 
 missingDependencyMsg :: Maybe PackageKey -> SDoc
-missingDependencyMsg Nothing = empty
+missingDependencyMsg Nothing = Outputable.empty
 missingDependencyMsg (Just parent)
   = space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))
 
index 3c4a551..94d64b1 100644 (file)
@@ -81,7 +81,9 @@ import qualified Stream
 import Data.List
 import Data.Maybe
 import Control.Exception
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 import Control.Monad
 import System.IO
 
@@ -594,7 +596,7 @@ makeImportsDoc dflags imports
             -- There's a hack to make this work in PprMach.pprNatCmmDecl.
             (if platformHasSubsectionsViaSymbols platform
              then text ".subsections_via_symbols"
-             else empty)
+             else Outputable.empty)
             $$
                 -- On recent GNU ELF systems one can mark an object file
                 -- as not requiring an executable stack. If all objects
@@ -604,14 +606,14 @@ makeImportsDoc dflags imports
                 -- stack so add the note in:
             (if platformHasGnuNonexecStack platform
              then text ".section .note.GNU-stack,\"\",@progbits"
-             else empty)
+             else Outputable.empty)
             $$
                 -- And just because every other compiler does, let's stick in
                 -- an identifier directive: .ident "GHC x.y.z"
             (if platformHasIdentDirective platform
              then let compilerIdent = text "GHC" <+> text cProjectVersion
                    in text ".ident" <+> doubleQuotes compilerIdent
-             else empty)
+             else Outputable.empty)
 
  where
         platform = targetPlatform dflags
@@ -635,7 +637,7 @@ makeImportsDoc dflags imports
                         map doPpr $
                         imps
                 | otherwise
-                = empty
+                = Outputable.empty
 
         doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
         astyle = mkCodeStyle AsmStyle
index a4c9f74..f47a1ab 100644 (file)
@@ -44,7 +44,9 @@ import DynFlags
 import Module
 
 import Control.Monad    ( liftM, ap )
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ( Applicative(..) )
+#endif
 
 data NatM_State
         = NatM_State {
index 39b5777..287bdc6 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE CPP #-}
 
 -- | State monad for the linear register allocator.
 
@@ -43,8 +44,9 @@ import Unique
 import UniqSupply
 
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
-
+#endif
 
 -- | The register allocator monad type.
 newtype RegM freeRegs a
index cfe7955..8fd5bd9 100644 (file)
@@ -88,6 +88,7 @@ import Ctype
 import BasicTypes       ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) )
 import Util             ( readRational )
 
+import Control.Applicative
 import Control.Monad
 import Data.Bits
 import Data.ByteString (ByteString)
@@ -1680,6 +1681,13 @@ data ALRLayout = ALRLayoutLet
 
 newtype P a = P { unP :: PState -> ParseResult a }
 
+instance Functor P where
+  fmap = liftM
+
+instance Applicative P where
+  pure  = return
+  (<*>) = ap
+
 instance Monad P where
   return = returnP
   (>>=) = thenP
index 6cac513..b13251c 100644 (file)
@@ -87,7 +87,12 @@ import Maybes
 import Util
 
 import Control.Applicative ((<$>))
+#if __GLASGOW_HASKELL__ >= 709
+import Control.Monad hiding (empty, many)
+#else
 import Control.Monad
+#endif
+
 import Text.ParserCombinators.ReadP as ReadP
 import Data.Char
 
index ed6fa3f..a182e9b 100644 (file)
@@ -735,8 +735,8 @@ ap_RDR                  = nameRdrName apAName
 foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")
 foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")
 traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")
-mempty_RDR              = varQual_RDR dATA_MONOID         (fsLit "mempty")
-mappend_RDR             = varQual_RDR dATA_MONOID         (fsLit "mappend")
+mempty_RDR              = varQual_RDR gHC_BASE            (fsLit "mempty")
+mappend_RDR             = varQual_RDR gHC_BASE            (fsLit "mappend")
 
 ----------------------
 varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR
@@ -849,7 +849,7 @@ failMName          = varQual gHC_BASE (fsLit "fail")   failMClassOpKey
 
 -- Classes (Applicative, Foldable, Traversable)
 applicativeClassName, foldableClassName, traversableClassName :: Name
-applicativeClassName  = clsQual  cONTROL_APPLICATIVE (fsLit "Applicative") applicativeClassKey
+applicativeClassName  = clsQual  gHC_BASE            (fsLit "Applicative") applicativeClassKey
 foldableClassName     = clsQual  dATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey
 traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey
 
@@ -858,10 +858,10 @@ traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") trave
 -- AMP additions
 
 joinMName,  apAName, pureAName, alternativeClassName :: Name
-joinMName            = varQual mONAD               (fsLit "join")        joinMIdKey
-apAName              = varQual cONTROL_APPLICATIVE (fsLit "<*>")         apAClassOpKey
-pureAName            = varQual cONTROL_APPLICATIVE (fsLit "pure")        pureAClassOpKey
-alternativeClassName = clsQual cONTROL_APPLICATIVE (fsLit "Alternative") alternativeClassKey
+joinMName            = varQual gHC_BASE (fsLit "join")        joinMIdKey
+apAName              = varQual gHC_BASE (fsLit "<*>")         apAClassOpKey
+pureAName            = varQual gHC_BASE (fsLit "pure")        pureAClassOpKey
+alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey
 
 joinMIdKey, apAClassOpKey, pureAClassOpKey, alternativeClassKey :: Unique
 joinMIdKey          = mkPreludeMiscIdUnique 750
index d2e648f..a91d3f7 100644 (file)
@@ -48,7 +48,10 @@ import Platform
 import Util
 import Coercion     (mkUnbranchedAxInstCo,mkSymCo,Role(..))
 
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ( Applicative(..), Alternative(..) )
+#endif
+
 import Control.Monad
 import Data.Bits as Bits
 import qualified Data.ByteString as BS
index 4a6da24..f9dc4a3 100644 (file)
@@ -39,8 +39,9 @@ import SrcLoc
 import Util
 
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
-
+#endif
 
 stgMassageForProfiling
         :: DynFlags
index f333a23..b9bfcce 100644 (file)
@@ -796,7 +796,7 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_prov = Imported (imp_spec : _)
     name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name
     imp_mod  = importSpecModule imp_spec
     imp_msg  = ptext (sLit "imported from") <+> ppr imp_mod <> extra
-    extra | imp_mod == moduleName name_mod = empty
+    extra | imp_mod == moduleName name_mod = Outputable.empty
           | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod
 
     doc = ptext (sLit "The name") <+> quotes (ppr name) <+> ptext (sLit "is mentioned explicitly")
@@ -985,7 +985,7 @@ lookupBindGroupOcc ctxt what rdr_name
       = do { env <- getGlobalRdrEnv
            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
            ; case filter (keep_me . gre_name) all_gres of
-               [] | null all_gres -> bale_out_with empty
+               [] | null all_gres -> bale_out_with Outputable.empty
                   | otherwise -> bale_out_with local_msg
                (gre:_)
                   | ParentIs {} <- gre_par gre
@@ -1000,7 +1000,7 @@ lookupBindGroupOcc ctxt what rdr_name
                Just n
                  | n `elemNameSet` bound_names -> return (Right n)
                  | otherwise                   -> bale_out_with local_msg
-               Nothing                         -> bale_out_with empty }
+               Nothing                         -> bale_out_with Outputable.empty }
 
     bale_out_with msg
         = return (Left (sep [ ptext (sLit "The") <+> what
@@ -1416,7 +1416,7 @@ reportUnboundName :: RdrName -> RnM Name
 reportUnboundName rdr = unboundName WL_Any rdr
 
 unboundName :: WhereLooking -> RdrName -> RnM Name
-unboundName wl rdr = unboundNameX wl rdr empty
+unboundName wl rdr = unboundNameX wl rdr Outputable.empty
 
 unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name
 unboundNameX where_look rdr_name extra
@@ -1436,7 +1436,7 @@ unknownNameErr what rdr_name
          , extra ]
   where
     extra | rdr_name == forall_tv_RDR = perhapsForallMsg
-          | otherwise                 = empty
+          | otherwise                 = Outputable.empty
 
 type HowInScope = Either SrcSpan ImpDeclSpec
      -- Left loc    =>  locally bound at loc
@@ -1457,7 +1457,7 @@ unknownNameSuggestErr where_look tried_rdr_name
              suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities
              perhaps = ptext (sLit "Perhaps you meant")
              extra_err = case suggest of
-                           []  -> empty
+                           []  -> Outputable.empty
                            [p] -> perhaps <+> pp_item p
                            ps  -> sep [ perhaps <+> ptext (sLit "one of these:")
                                       , nest 2 (pprWithCommas pp_item ps) ]
@@ -1473,7 +1473,7 @@ unknownNameSuggestErr where_look tried_rdr_name
 
     pp_ns :: RdrName -> SDoc
     pp_ns rdr | ns /= tried_ns = pprNameSpace ns
-              | otherwise      = empty
+              | otherwise      = Outputable.empty
       where ns = rdrNameSpace rdr
 
     tried_occ     = rdrNameOcc tried_rdr_name
index 2872b48..79a944f 100644 (file)
@@ -1247,7 +1247,7 @@ pprStmtCat (ParStmt {})       = ptext (sLit "parallel")
 
 ------------
 emptyInvalid :: Validity  -- Payload is the empty document
-emptyInvalid = NotValid empty
+emptyInvalid = NotValid Outputable.empty
 
 okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt
    :: DynFlags -> HsStmtContext Name
index 5071828..cd43d8a 100644 (file)
@@ -1447,13 +1447,13 @@ warnUnusedImport (L loc decl, used, unused)
                  nest 2 (ptext (sLit "except perhaps to import instances from")
                                    <+> quotes pp_mod),
                  ptext (sLit "To import instances alone, use:")
-                                   <+> ptext (sLit "import") <+> pp_mod <> parens empty ]
+                                   <+> ptext (sLit "import") <+> pp_mod <> parens Outputable.empty ]
     msg2 = sep [pp_herald <+> quotes (pprWithCommas ppr unused),
                     text "from module" <+> quotes pp_mod <+> pp_not_used]
     pp_herald  = text "The" <+> pp_qual <+> text "import of"
     pp_qual
       | ideclQualified decl = text "qualified"
-      | otherwise           = empty
+      | otherwise           = Outputable.empty
     pp_mod      = ppr (unLoc (ideclName decl))
     pp_not_used = text "is redundant"
 \end{code}
@@ -1574,7 +1574,7 @@ badImportItemErrStd iface decl_spec ie
          ptext (sLit "does not export"), quotes (ppr ie)]
   where
     source_import | mi_boot iface = ptext (sLit "(hi-boot interface)")
-                  | otherwise     = empty
+                  | otherwise     = Outputable.empty
 
 badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc
 badImportItemErrDataCon dataType iface decl_spec ie
@@ -1597,7 +1597,7 @@ badImportItemErrDataCon dataType iface decl_spec ie
     datacon_occ = rdrNameOcc $ ieName ie
     datacon = parenSymOcc datacon_occ (ppr datacon_occ)
     source_import | mi_boot iface = ptext (sLit "(hi-boot interface)")
-                  | otherwise     = empty
+                  | otherwise     = Outputable.empty
     parens_sp d = parens (space <> d <> space)  -- T( f,g )
 
 badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc
index ad4a0e1..dcedfb4 100644 (file)
@@ -376,7 +376,7 @@ instance Outputable CoreToDo where
 pprPassDetails :: CoreToDo -> SDoc
 pprPassDetails (CoreDoSimplify n md) = vcat [ ptext (sLit "Max iterations =") <+> int n 
                                             , ppr md ]
-pprPassDetails _ = empty
+pprPassDetails _ = Outputable.empty
 \end{code}
 
 \begin{code}
@@ -633,7 +633,7 @@ pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })
                vcat [blankLine,
                      ptext (sLit "Log (most recent first)"),
                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]
-         else empty
+         else Outputable.empty
     ]
 
 pprTickCounts :: Map Tick Int -> SDoc
@@ -734,7 +734,7 @@ pprTickCts (PreInlineUnconditionally v)     = ppr v
 pprTickCts (PostInlineUnconditionally v)= ppr v
 pprTickCts (UnfoldingDone v)           = ppr v
 pprTickCts (RuleFired v)               = ppr v
-pprTickCts LetFloatFromLet             = empty
+pprTickCts LetFloatFromLet             = Outputable.empty
 pprTickCts (EtaExpansion v)            = ppr v
 pprTickCts (EtaReduction v)            = ppr v
 pprTickCts (BetaReduction v)           = ppr v
@@ -745,7 +745,7 @@ pprTickCts (AltMerge v)                     = ppr v
 pprTickCts (CaseElim v)                        = ppr v
 pprTickCts (CaseIdentity v)            = ppr v
 pprTickCts (FillInCaseDefault v)       = ppr v
-pprTickCts _                           = empty
+pprTickCts _                           = Outputable.empty
 
 cmpTick :: Tick -> Tick -> Ordering
 cmpTick a b = case (tickToTag a `compare` tickToTag b) of
index cbce63f..09acd70 100644 (file)
@@ -37,7 +37,9 @@ import Outputable
 import FastString
 import State
 
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
index ec9f6fa..93fc9cd 100644 (file)
@@ -27,7 +27,9 @@ import Util
 import SrcLoc
 import Outputable
 import FastString
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative ( Applicative(..) )
+#endif
 import Control.Monad
 import Data.Function
 
@@ -486,7 +488,7 @@ checkTys ty1 ty2 msg = LintM $ \loc _scope errs
 _mkCaseAltMsg :: [StgAlt] -> MsgDoc
 _mkCaseAltMsg _alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
-            (empty) -- LATER: ppr alts
+            (Outputable.empty) -- LATER: ppr alts
 
 mkDefltMsg :: Id -> TyCon -> MsgDoc
 mkDefltMsg bndr tc
index 6feab9e..c286d3b 100644 (file)
@@ -488,7 +488,7 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
     recoverM (recoveryCode binder_names sig_fn) $ do 
         -- Set up main recover; take advantage of any type sigs
 
-    { traceTc "------------------------------------------------" empty
+    { traceTc "------------------------------------------------" Outputable.empty
     ; traceTc "Bindings for {" (ppr binder_names)
     ; dflags   <- getDynFlags
     ; type_env <- getLclTypeEnv
index 6812ac7..a14d29e 100644 (file)
@@ -2176,7 +2176,7 @@ derivingThingErr newtype_deriving clas tys ty why
          nest 2 why]
   where
     extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
-          | otherwise        = empty
+          | otherwise        = Outputable.empty
     pred = mkClassPred clas (tys ++ [ty])
 
 derivingHiddenErr :: TyCon -> SDoc
index 7e6c495..6188842 100644 (file)
@@ -1496,15 +1496,15 @@ funResCtxt has_args fun fun_res_ty env_ty tidy_env
              (args_env, res_env) = tcSplitFunTys env'
              n_fun = length args_fun
              n_env = length args_env
-             info  | n_fun == n_env = empty
+             info  | n_fun == n_env = Outputable.empty
                    | n_fun > n_env
                    , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
                                        <+> ptext (sLit "is applied to too few arguments")
                    | has_args
                    , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun)
                                        <+> ptext (sLit "is applied to too many arguments")
-                   | otherwise       = empty  -- Never suggest that a naked variable is
-                                             -- applied to too many args!
+                   | otherwise       = Outputable.empty  -- Never suggest that a naked variable is
+                                                         -- applied to too many args!
        ; return (tidy_env, info) }
   where
     not_fun ty   -- ty is definitely not an arrow type,
@@ -1608,8 +1608,8 @@ missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
 missingStrictFields con fields
   = header <> rest
   where
-    rest | null fields = empty  -- Happens for non-record constructors
-                                -- with strict fields
+    rest | null fields = Outputable.empty  -- Happens for non-record constructors
+                                           -- with strict fields
          | otherwise   = colon <+> pprWithCommas ppr fields
 
     header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
index 303391f..9d1da3f 100644 (file)
@@ -268,7 +268,7 @@ tcCheckFIType arg_tys res_ty (CImport cconv safety mh l@(CLabel _))
   = do checkCg checkCOrAsmOrLlvmOrInterp
        -- NB check res_ty not sig_ty!
        --    In case sig_ty is (forall a. ForeignPtr a)
-       check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr empty)
+       check (isFFILabelTy (mkFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
        cconv' <- checkCConv cconv
        return (CImport cconv' safety mh l)
 
@@ -285,7 +285,7 @@ tcCheckFIType arg_tys res_ty (CImport cconv safety mh CWrapper) = do
                         checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty
                   where
                      (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty
-        _ -> addErrTc (illegalForeignTyErr empty (ptext (sLit "One argument expected")))
+        _ -> addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "One argument expected")))
     return (CImport cconv' safety mh CWrapper)
 
 tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
@@ -294,7 +294,7 @@ tcCheckFIType arg_tys res_ty idecl@(CImport cconv safety mh (CFunction target))
       cconv' <- checkCConv cconv
       case arg_tys of           -- The first arg must be Ptr or FunPtr
         []                -> 
-          addErrTc (illegalForeignTyErr empty (ptext (sLit "At least one argument expected")))
+          addErrTc (illegalForeignTyErr Outputable.empty (ptext (sLit "At least one argument expected")))
         (arg1_ty:arg_tys) -> do
           dflags <- getDynFlags
           let curried_res_ty = foldr FunTy res_ty arg_tys
index 2b123ff..f559dda 100644 (file)
@@ -400,7 +400,7 @@ tcInstDecls1 tycl_decls inst_decls deriv_decls
                         -- try the deriving stuff, because that may give
                         -- more errors still
 
-       ; traceTc "tcDeriving" empty
+       ; traceTc "tcDeriving" Outputable.empty
        ; th_stage <- getStage   -- See Note [Deriving inside TH brackets ]
        ; (gbl_env, deriv_inst_info, deriv_binds)
               <- if isBrackStage th_stage 
index cfc76d6..c052575 100644 (file)
@@ -826,7 +826,7 @@ tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside
         ; req_wrap <- instCall PatOrigin inst_tys req_theta'
         ; traceTc "instCall" (ppr req_wrap)
 
-        ; traceTc "checkConstraints {" empty
+        ; traceTc "checkConstraints {" Outputable.empty
         ; (ev_binds, (arg_pats', res))
              <- checkConstraints skol_info ex_tvs' prov_dicts' $
                 tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside
index 9898b46..4927684 100644 (file)
@@ -100,7 +100,11 @@ import Maybes
 import Util
 import Bag
 
+#if __GLASGOW_HASKELL__ >= 709
+import Control.Monad hiding (empty)
+#else
 import Control.Monad
+#endif
 
 #include "HsVersions.h"
 \end{code}
index 9dbc420..c3215b3 100644 (file)
@@ -968,10 +968,10 @@ addWarnTcM (env0, msg)
         add_warn msg err_info }
 
 addWarn :: MsgDoc -> TcRn ()
-addWarn msg = add_warn msg empty
+addWarn msg = add_warn msg Outputable.empty
 
 addWarnAt :: SrcSpan -> MsgDoc -> TcRn ()
-addWarnAt loc msg = add_warn_at loc msg empty
+addWarnAt loc msg = add_warn_at loc msg Outputable.empty
 
 add_warn :: MsgDoc -> MsgDoc -> TcRn ()
 add_warn msg extra_info 
@@ -1012,7 +1012,7 @@ mkErrInfo env ctxts
  = go 0 env ctxts
  where
    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
-   go _ _   [] = return empty
+   go _ _   [] = return Outputable.empty
    go n env ((is_landmark, ctxt) : ctxts)
      | is_landmark || n < mAX_CONTEXTS -- Too verbose || opt_PprStyle_Debug
      = do { (env', msg) <- ctxt env
index 3c6aedb..a4a7b29 100644 (file)
@@ -2252,7 +2252,7 @@ addTyThingCtxt thing
                 | isDataTyCon tc        -> ptext (sLit "data")
 
              _ -> pprTrace "addTyThingCtxt strange" (ppr thing)
-                  empty
+                  Outputable.empty
 
     ctxt = hsep [ ptext (sLit "In the"), flav
                 , ptext (sLit "declaration for"), quotes (ppr name) ]
index 262aa51..2360f7b 100644 (file)
@@ -49,7 +49,11 @@ import UniqSet
 import Util
 import Maybes
 import Data.List
+
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
+
 import Control.Monad
 \end{code}
 
index db3ae83..6c14b4b 100644 (file)
@@ -177,7 +177,9 @@ import ErrUtils( Validity(..), isValid )
 
 import Data.IORef
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 \end{code}
 
 %************************************************************************
index ef06ddd..f943ccd 100644 (file)
@@ -388,7 +388,7 @@ tcGen :: UserTypeCtxt -> TcType
 tcGen ctxt expected_ty thing_inside
    -- We expect expected_ty to be a forall-type
    -- If not, the call is a no-op
-  = do  { traceTc "tcGen" empty
+  = do  { traceTc "tcGen" Outputable.empty
         ; (wrap, tvs', given, rho') <- deeplySkolemise expected_ty
 
         ; when debugIsOn $
@@ -565,7 +565,7 @@ uType origin orig_ty1 orig_ty2
               , ppr origin]
        ; co <- go orig_ty1 orig_ty2
        ; if isTcReflCo co
-            then traceTc "u_tys yields no coercion" empty
+            then traceTc "u_tys yields no coercion" Outputable.empty
             else traceTc "u_tys yields coercion:" (ppr co)
        ; return co }
   where
index ad81623..8381533 100644 (file)
@@ -404,7 +404,7 @@ forAllTyErr rank ty
     suggestion = case rank of
                    LimitedRank {} -> ptext (sLit "Perhaps you intended to use RankNTypes or Rank2Types")
                    MonoType d     -> d
-                   _              -> empty      -- Polytype is always illegal
+                   _              -> Outputable.empty -- Polytype is always illegal
 
 unliftedArgErr, ubxArgTyErr :: Type -> SDoc
 unliftedArgErr  ty = sep [ptext (sLit "Illegal unlifted type:"), ppr ty]
index 1eb1c2b..709c0e5 100644 (file)
@@ -41,7 +41,9 @@ import TypeRep
 import Util
 
 import Control.Monad (liftM, ap)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 \end{code}
 
 
index 1db1553..8193beb 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable, UndecidableInstances #-}
+{-# LANGUAGE CPP #-}
 
 --
 -- (c) The University of Glasgow 2002-2006
@@ -43,7 +44,9 @@ import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
 import Control.Monad
 import MonadUtils
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Alternative(..))
+#endif
 
 ----------------------------------------------------------------------
 -- Defining the monad type
index d9e1762..8052b1d 100644 (file)
@@ -4,6 +4,7 @@
 %
 
 \begin{code}
+{-# LANGUAGE CPP #-}
 module Maybes (
         module Data.Maybe,
 
@@ -17,7 +18,9 @@ module Maybes (
 
         MaybeT(..)
     ) where
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative
+#endif
 import Control.Monad
 import Data.Maybe
 
index 47cdee0..edb0b0c 100644 (file)
@@ -5,14 +5,17 @@
 -- Monadic streams
 --
 -- -----------------------------------------------------------------------------
-
+{-# LANGUAGE CPP #-}
 module Stream (
     Stream(..), yield, liftIO,
     collect, fromList,
     Stream.map, Stream.mapM, Stream.mapAccumL
   ) where
 import Control.Monad
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative
+#endif
+
 
 -- |
 -- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence
index 6adb9ec..f975903 100644 (file)
@@ -415,11 +415,11 @@ vectExpr (_, AnnCase scrut bndr ty alts)
 
 vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
   = do
-    { traceVt "let binding (non-recursive)" empty
+    { traceVt "let binding (non-recursive)" Outputable.empty
     ; vrhs <- localV $ 
                 inBind bndr $ 
                   vectAnnPolyExpr False rhs
-    ; traceVt "let body (non-recursive)" empty
+    ; traceVt "let body (non-recursive)" Outputable.empty
     ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
     ; return $ vLet (vNonRec vbndr vrhs) vbody
     }
@@ -427,9 +427,9 @@ vectExpr (_, AnnLet (AnnNonRec bndr rhs) body)
 vectExpr (_, AnnLet (AnnRec bs) body)
   = do
     { (vbndrs, (vrhss, vbody)) <- vectBndrsIn bndrs $ do
-                                  { traceVt "let bindings (recursive)" empty
+                                  { traceVt "let bindings (recursive)" Outputable.empty
                                   ; vrhss <- zipWithM vect_rhs bndrs rhss
-                                  ; traceVt "let body (recursive)" empty
+                                  ; traceVt "let body (recursive)" Outputable.empty
                                   ; vbody <- vectExpr body
                                   ; return (vrhss, vbody) 
                                   }
@@ -830,28 +830,28 @@ vectAlgCase :: TyCon -> [Type] -> CoreExprWithVectInfo -> Var -> Type
             -> VM VExpr
 vectAlgCase _tycon _ty_args scrut bndr ty [(DEFAULT, [], body)]
   = do
-    { traceVt "scrutinee (DEFAULT only)" empty
+    { traceVt "scrutinee (DEFAULT only)" Outputable.empty
     ; vscrut         <- vectExpr scrut
     ; (vty, lty)     <- vectAndLiftType ty
-    ; traceVt "alternative body (DEFAULT only)" empty
+    ; traceVt "alternative body (DEFAULT only)" Outputable.empty
     ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
     ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody
     }
 vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt _, [], body)]
   = do
-    { traceVt "scrutinee (one shot w/o binders)" empty
+    { traceVt "scrutinee (one shot w/o binders)" Outputable.empty
     ; vscrut         <- vectExpr scrut
     ; (vty, lty)     <- vectAndLiftType ty
-    ; traceVt "alternative body (one shot w/o binders)" empty
+    ; traceVt "alternative body (one shot w/o binders)" Outputable.empty
     ; (vbndr, vbody) <- vectBndrIn bndr (vectExpr body)
     ; return $ vCaseDEFAULT vscrut vbndr vty lty vbody
     }
 vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
   = do
-    { traceVt "scrutinee (one shot w/ binders)" empty
+    { traceVt "scrutinee (one shot w/ binders)" Outputable.empty
     ; vexpr      <- vectExpr scrut
     ; (vty, lty) <- vectAndLiftType ty
-    ; traceVt "alternative body (one shot w/ binders)" empty
+    ; traceVt "alternative body (one shot w/ binders)" Outputable.empty
     ; (vbndr, (vbndrs, (vect_body, lift_body)))
         <- vect_scrut_bndr
          . vectBndrsIn bndrs
@@ -876,7 +876,7 @@ vectAlgCase _tycon _ty_args scrut bndr ty [(DataAlt dc, bndrs, body)]
 
 vectAlgCase tycon _ty_args scrut bndr ty alts
   = do
-    { traceVt "scrutinee (general case)" empty
+    { traceVt "scrutinee (general case)" Outputable.empty
     ; vexpr <- vectExpr scrut
 
     ; vect_tc     <- vectTyCon tycon
@@ -887,7 +887,7 @@ vectAlgCase tycon _ty_args scrut bndr ty alts
     ; sel_bndr <- newLocalVar (fsLit "sel") sel_ty
     ; let sel = Var sel_bndr
 
-    ; traceVt "alternatives' body (general case)" empty
+    ; traceVt "alternatives' body (general case)" Outputable.empty
     ; (vbndr, valts) <- vect_scrut_bndr
                       $ mapM (proc_alt arity sel vty lty) alts'
     ; let (vect_dcs, vect_bndrss, lift_bndrss, vbodies) = unzip4 valts
index 6ee5ca6..b73d094 100644 (file)
@@ -227,7 +227,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
        ; traceVt " VECT SCALAR    : " $ ppr (scalarTyConsNoRHS ++ map fst scalarTyConsWithRHS)
        ; traceVt " VECT [class]   : " $ ppr impVectTyCons
        ; traceVt " VECT with rhs  : " $ ppr (map fst (vectTyConsWithRHS ++ scalarTyConsWithRHS))
-       ; traceVt " -- after classification (local and VECT [class] tycons) --" empty
+       ; traceVt " -- after classification (local and VECT [class] tycons) --" Outputable.empty
        ; traceVt " reuse          : " $ ppr keep_tcs
        ; traceVt " convert        : " $ ppr conv_tcs
        
index 22109c4..89c2028 100644 (file)
@@ -48,7 +48,6 @@ import Data.IORef
 import System.CPUTime
 import System.Environment
 import System.IO
-import Control.Applicative (Applicative(..))
 import Control.Monad
 import GHC.Exts
 
@@ -57,6 +56,10 @@ import qualified System.Console.Haskeline as Haskeline
 import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
 
+#if __GLASGOW_HASKELL__ < 709
+import Control.Applicative (Applicative(..))
+#endif
+
 -----------------------------------------------------------------------------
 -- GHCi monad
 
@@ -138,7 +141,7 @@ prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $
 instance Outputable BreakLocation where
    ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
                 if null (onBreakCmd loc)
-                   then empty
+                   then Outputable.empty
                    else doubleQuotes (text (onBreakCmd loc))
 
 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
index 070932c..ea90280 100644 (file)
@@ -63,8 +63,9 @@ import Util
 -- Haskell Libraries
 import System.Console.Haskeline as Haskeline
 
+import Control.Monad as Monad hiding (empty)
+
 import Control.Applicative hiding (empty)
-import Control.Monad as Monad
 import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
 
index 81ce513..41049c6 100644 (file)
@@ -48,191 +48,15 @@ module Control.Applicative (
 
 import Prelude hiding (id,(.))
 
+import GHC.Base (liftA, liftA2, liftA3, (<**>))
 import Control.Category
 import Control.Arrow
-import Control.Monad (liftM, ap, MonadPlus(..))
-import Control.Monad.ST.Safe (ST)
-import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)
+import Control.Monad (liftM, ap, MonadPlus(..), Alternative(..))
 import Data.Functor ((<$>), (<$))
-import Data.Monoid (Monoid(..), First(..), Last(..))
-import Data.Proxy
+import Data.Monoid (Monoid(..))
 
-import Text.ParserCombinators.ReadP (ReadP)
-import Text.ParserCombinators.ReadPrec (ReadPrec)
-
-import GHC.Conc (STM, retry, orElse)
 import GHC.Generics
 
-infixl 3 <|>
-infixl 4 <*>, <*, *>, <**>
-
--- | A functor with application, providing operations to
---
--- * embed pure expressions ('pure'), and
---
--- * sequence computations and combine their results ('<*>').
---
--- A minimal complete definition must include implementations of these
--- functions satisfying the following laws:
---
--- [/identity/]
---
---      @'pure' 'id' '<*>' v = v@
---
--- [/composition/]
---
---      @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
---
--- [/homomorphism/]
---
---      @'pure' f '<*>' 'pure' x = 'pure' (f x)@
---
--- [/interchange/]
---
---      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
---
--- The other methods have the following default definitions, which may
--- be overridden with equivalent specialized implementations:
---
---   * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
---
---   * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
---
--- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
---
---   * @'fmap' f x = 'pure' f '<*>' x@
---
--- If @f@ is also a 'Monad', it should satisfy
---
---   * @'pure' = 'return'@
---
---   * @('<*>') = 'ap'@
---
--- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
-
-class Functor f => Applicative f where
-    -- | Lift a value.
-    pure :: a -> f a
-
-    -- | Sequential application.
-    (<*>) :: f (a -> b) -> f a -> f b
-
-    -- | Sequence actions, discarding the value of the first argument.
-    (*>) :: f a -> f b -> f b
-    (*>) = liftA2 (const id)
-
-    -- | Sequence actions, discarding the value of the second argument.
-    (<*) :: f a -> f b -> f a
-    (<*) = liftA2 const
-
--- | A monoid on applicative functors.
---
--- Minimal complete definition: 'empty' and '<|>'.
---
--- If defined, 'some' and 'many' should be the least solutions
--- of the equations:
---
--- * @some v = (:) '<$>' v '<*>' many v@
---
--- * @many v = some v '<|>' 'pure' []@
-class Applicative f => Alternative f where
-    -- | The identity of '<|>'
-    empty :: f a
-    -- | An associative binary operation
-    (<|>) :: f a -> f a -> f a
-
-    -- | One or more.
-    some :: f a -> f [a]
-    some v = some_v
-      where
-        many_v = some_v <|> pure []
-        some_v = (:) <$> v <*> many_v
-
-    -- | Zero or more.
-    many :: f a -> f [a]
-    many v = many_v
-      where
-        many_v = some_v <|> pure []
-        some_v = (:) <$> v <*> many_v
-
--- instances for Prelude types
-
-instance Applicative Maybe where
-    pure = return
-    (<*>) = ap
-
-instance Alternative Maybe where
-    empty = Nothing
-    Nothing <|> r = r
-    l       <|> _ = l
-
-instance Applicative [] where
-    pure = return
-    (<*>) = ap
-
-instance Alternative [] where
-    empty = []
-    (<|>) = (++)
-
-instance Applicative IO where
-    pure = return
-    (<*>) = ap
-
-instance Applicative (ST s) where
-    pure = return
-    (<*>) = ap
-
-instance Applicative (Lazy.ST s) where
-    pure = return
-    (<*>) = ap
-
-instance Applicative STM where
-    pure = return
-    (<*>) = ap
-
-instance Alternative STM where
-    empty = retry
-    (<|>) = orElse
-
-instance Applicative ((->) a) where
-    pure = const
-    (<*>) f g x = f x (g x)
-
-instance Monoid a => Applicative ((,) a) where
-    pure x = (mempty, x)
-    (u, f) <*> (v, x) = (u `mappend` v, f x)
-
-instance Applicative (Either e) where
-    pure          = Right
-    Left  e <*> _ = Left e
-    Right f <*> r = fmap f r
-
-instance Applicative ReadP where
-    pure = return
-    (<*>) = ap
-
-instance Alternative ReadP where
-    empty = mzero
-    (<|>) = mplus
-
-instance Applicative ReadPrec where
-    pure = return
-    (<*>) = ap
-
-instance Alternative ReadPrec where
-    empty = mzero
-    (<|>) = mplus
-
-instance Arrow a => Applicative (ArrowMonad a) where
-   pure x = ArrowMonad (arr (const x))
-   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
-
-instance ArrowPlus a => Alternative (ArrowMonad a) where
-   empty = ArrowMonad zeroArrow
-   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
-
--- new instances
-
 newtype Const a b = Const { getConst :: a }
                   deriving (Generic, Generic1)
 
@@ -281,15 +105,6 @@ instance (ArrowZero a, ArrowPlus a) => Alternative (WrappedArrow a b) where
     empty = WrapArrow zeroArrow
     WrapArrow u <|> WrapArrow v = WrapArrow (u <+> v)
 
--- Added in base-4.8.0.0
-instance Applicative First where
-        pure x = First (Just x)
-        First x <*> First y = First (x <*> y)
-
-instance Applicative Last where
-        pure x = Last (Just x)
-        Last x <*> Last y = Last (x <*> y)
-
 -- | Lists, but with an 'Applicative' functor based on zipping, so that
 --
 -- @f '<$>' 'ZipList' xs1 '<*>' ... '<*>' 'ZipList' xsn = 'ZipList' (zipWithn f xs1 ... xsn)@
@@ -304,31 +119,8 @@ instance Applicative ZipList where
     pure x = ZipList (repeat x)
     ZipList fs <*> ZipList xs = ZipList (zipWith id fs xs)
 
-instance Applicative Proxy where
-    pure _ = Proxy
-    {-# INLINE pure #-}
-    _ <*> _ = Proxy
-    {-# INLINE (<*>) #-}
-
 -- extra functions
 
--- | A variant of '<*>' with the arguments reversed.
-(<**>) :: Applicative f => f a -> f (a -> b) -> f b
-(<**>) = liftA2 (flip ($))
-
--- | Lift a function to actions.
--- This function may be used as a value for `fmap` in a `Functor` instance.
-liftA :: Applicative f => (a -> b) -> f a -> f b
-liftA f a = pure f <*> a
-
--- | Lift a binary function to actions.
-liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
-liftA2 f a b = f <$> a <*> b
-
--- | Lift a ternary function to actions.
-liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
-liftA3 f a b c = f <$> a <*> b <*> c
-
 -- | One or none.
 optional :: Alternative f => f a -> f (Maybe a)
 optional v = Just <$> v <|> pure Nothing
index b723dd4..f6067a0 100644 (file)
@@ -304,11 +304,19 @@ newtype ArrowMonad a b = ArrowMonad (a () b)
 instance Arrow a => Functor (ArrowMonad a) where
     fmap f (ArrowMonad m) = ArrowMonad $ m >>> arr f
 
+instance Arrow a => Applicative (ArrowMonad a) where
+   pure x = ArrowMonad (arr (const x))
+   ArrowMonad f <*> ArrowMonad x = ArrowMonad (f &&& x >>> arr (uncurry id))
+
 instance ArrowApply a => Monad (ArrowMonad a) where
     return x = ArrowMonad (arr (\_ -> x))
     ArrowMonad m >>= f = ArrowMonad $
         m >>> arr (\x -> let ArrowMonad h = f x in (h, ())) >>> app
 
+instance ArrowPlus a => Alternative (ArrowMonad a) where
+   empty = ArrowMonad zeroArrow
+   ArrowMonad x <|> ArrowMonad y = ArrowMonad (x <+> y)
+
 instance (ArrowApply a, ArrowPlus a) => MonadPlus (ArrowMonad a) where
    mzero = ArrowMonad zeroArrow
    ArrowMonad x `mplus` ArrowMonad y = ArrowMonad (x <+> y)
index 4a8060f..bfadd7c 100644 (file)
@@ -6,7 +6,7 @@
 -- Module      :  Control.Monad
 -- Copyright   :  (c) The University of Glasgow 2001
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
--- 
+--
 -- Maintainer  :  libraries@haskell.org
 -- Stability   :  provisional
 -- Portability :  portable
@@ -20,11 +20,8 @@ module Control.Monad
 
       Functor(fmap)
     , Monad((>>=), (>>), return, fail)
-
-    , MonadPlus (
-          mzero
-        , mplus
-        )
+    , Alternative(empty, (<|>), some, many)
+    , MonadPlus(mzero, mplus)
     -- * Functions
 
     -- ** Naming conventions
@@ -85,6 +82,7 @@ import GHC.List
 import GHC.Base
 
 infixr 1 =<<
+infixl 3 <|>
 
 -- -----------------------------------------------------------------------------
 -- Prelude monad functions
@@ -104,7 +102,7 @@ sequence ms = foldr k (return []) ms
 
 -- | Evaluate each action in the sequence from left to right,
 -- and ignore the results.
-sequence_        :: Monad m => [m a] -> m () 
+sequence_        :: Monad m => [m a] -> m ()
 {-# INLINE sequence_ #-}
 sequence_ ms     =  foldr (>>) (return ()) ms
 
@@ -119,18 +117,64 @@ mapM_           :: Monad m => (a -> m b) -> [a] -> m ()
 mapM_ f as      =  sequence_ (map f as)
 
 -- -----------------------------------------------------------------------------
+-- The Alternative class definition
+
+-- | A monoid on applicative functors.
+--
+-- Minimal complete definition: 'empty' and '<|>'.
+--
+-- If defined, 'some' and 'many' should be the least solutions
+-- of the equations:
+--
+-- * @some v = (:) '<$>' v '<*>' many v@
+--
+-- * @many v = some v '<|>' 'pure' []@
+class Applicative f => Alternative f where
+    -- | The identity of '<|>'
+    empty :: f a
+    -- | An associative binary operation
+    (<|>) :: f a -> f a -> f a
+
+    -- | One or more.
+    some :: f a -> f [a]
+    some v = some_v
+      where
+        many_v = some_v <|> pure []
+        some_v = (fmap (:) v) <*> many_v
+
+    -- | Zero or more.
+    many :: f a -> f [a]
+    many v = many_v
+      where
+        many_v = some_v <|> pure []
+        some_v = (fmap (:) v) <*> many_v
+
+instance Alternative Maybe where
+    empty = Nothing
+    Nothing <|> r = r
+    l       <|> _ = l
+
+instance Alternative [] where
+    empty = []
+    (<|>) = (++)
+
+
+-- -----------------------------------------------------------------------------
 -- The MonadPlus class definition
 
 -- | Monads that also support choice and failure.
-class Monad m => MonadPlus m where
+class (Alternative m, Monad m) => MonadPlus m where
    -- | the identity of 'mplus'.  It should also satisfy the equations
    --
    -- > mzero >>= f  =  mzero
    -- > v >> mzero   =  mzero
    --
-   mzero :: m a 
+   mzero :: m a
+   mzero = empty
+
    -- | an associative operation
    mplus :: m a -> m a -> m a
+   mplus = (<|>)
 
 instance MonadPlus [] where
    mzero = []
@@ -200,12 +244,6 @@ void = fmap (const ())
 -- -----------------------------------------------------------------------------
 -- Other monad functions
 
--- | The 'join' function is the conventional monad join operator. It is used to
--- remove one level of monadic structure, projecting its bound argument into the
--- outer level.
-join              :: (Monad m) => m (m a) -> m a
-join x            =  x >>= id
-
 -- | The 'mapAndUnzipM' function maps its first argument over a list, returning
 -- the result as a pair of lists. This function is mainly used with complicated
 -- data structures or a state-transforming monad.
@@ -293,64 +331,6 @@ unless            :: (Monad m) => Bool -> m () -> m ()
 {-# SPECIALISE unless :: Bool -> Maybe () -> Maybe () #-}
 unless p s        =  if p then return () else s
 
--- | Promote a function to a monad.
-liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
-liftM f m1              = do { x1 <- m1; return (f x1) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right.  For example,
---
--- >    liftM2 (+) [0,1] [0,2] = [0,2,1,3]
--- >    liftM2 (+) (Just 1) Nothing = Nothing
---
-liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
-liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM3  :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
-liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM4  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
-liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
-
--- | Promote a function to a monad, scanning the monadic arguments from
--- left to right (cf. 'liftM2').
-liftM5  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
-liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
-
-{-# INLINEABLE liftM #-}
-{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-}
-{-# SPECIALISE liftM :: (a1->r) -> Maybe a1 -> Maybe r #-}
-{-# INLINEABLE liftM2 #-}
-{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
-{-# SPECIALISE liftM2 :: (a1->a2->r) -> Maybe a1 -> Maybe a2 -> Maybe r #-}
-{-# INLINEABLE liftM3 #-}
-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
-{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe r #-}
-{-# INLINEABLE liftM4 #-}
-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-}
-{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe r #-}
-{-# INLINEABLE liftM5 #-}
-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-}
-{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> Maybe a1 -> Maybe a2 -> Maybe a3 -> Maybe a4 -> Maybe a5 -> Maybe r #-}
-
-{- | In many situations, the 'liftM' operations can be replaced by uses of
-'ap', which promotes function application. 
-
->       return f `ap` x1 `ap` ... `ap` xn
-
-is equivalent to 
-
->       liftMn f x1 x2 ... xn
-
--}
-
-ap                :: (Monad m) => m (a -> b) -> m a -> m b
-ap                =  liftM2 id
-
 infixl 4 <$!>
 
 -- | Strict version of 'Data.Functor.<$>'.
index 19e8974..3fdd541 100644 (file)
@@ -66,12 +66,16 @@ data State s = S# (State# s)
 
 instance Functor (ST s) where
     fmap f m = ST $ \ s ->
-      let 
+      let
        ST m_a = m
        (r,new_s) = m_a s
       in
       (f r,new_s)
 
+instance Applicative (ST s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (ST s) where
 
         return a = ST $ \ s -> (a,s)
index 9abb205..efa9328 100644 (file)
@@ -56,6 +56,11 @@ instance Functor (Either a) where
     fmap _ (Left x) = Left x
     fmap f (Right y) = Right (f y)
 
+instance Applicative (Either e) where
+    pure          = Right
+    Left  e <*> _ = Left e
+    Right f <*> r = fmap f r
+
 instance Monad (Either e) where
     return = Right
     Left  l >>= _ = Left l
index fe2a0ab..de8eadc 100644 (file)
@@ -49,10 +49,26 @@ import GHC.Base
 data  Maybe a  =  Nothing | Just a
   deriving (Eq, Ord)
 
+-- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
+-- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
+-- turned into a monoid simply by adjoining an element @e@ not in @S@
+-- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
+-- there is no \"Semigroup\" typeclass providing just 'mappend', we
+-- use 'Monoid' instead.
+instance Monoid a => Monoid (Maybe a) where
+  mempty = Nothing
+  Nothing `mappend` m = m
+  m `mappend` Nothing = m
+  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
+
 instance  Functor Maybe  where
     fmap _ Nothing       = Nothing
     fmap f (Just a)      = Just (f a)
 
+instance Applicative Maybe where
+    pure = return
+    (<*>) = ap
+
 instance  Monad Maybe  where
     (Just x) >>= k      = k x
     Nothing  >>= _      = Nothing
index 2100518..6b393b1 100644 (file)
@@ -47,7 +47,6 @@ import GHC.Read
 import GHC.Show
 import GHC.Generics
 import Data.Maybe
-import Data.Proxy
 
 {-
 -- just for testing
@@ -55,42 +54,6 @@ import Data.Maybe
 import Test.QuickCheck
 -- -}
 
--- ---------------------------------------------------------------------------
--- | The class of monoids (types with an associative binary operation that
--- has an identity).  Instances should satisfy the following laws:
---
---  * @mappend mempty x = x@
---
---  * @mappend x mempty = x@
---
---  * @mappend x (mappend y z) = mappend (mappend x y) z@
---
---  * @mconcat = 'foldr' mappend mempty@
---
--- The method names refer to the monoid of lists under concatenation,
--- but there are many other instances.
---
--- Minimal complete definition: 'mempty' and 'mappend'.
---
--- Some types can be viewed as a monoid in more than one way,
--- e.g. both addition and multiplication on numbers.
--- In such cases we often define @newtype@s and make those instances
--- of 'Monoid', e.g. 'Sum' and 'Product'.
-
-class Monoid a where
-        mempty  :: a
-        -- ^ Identity of 'mappend'
-        mappend :: a -> a -> a
-        -- ^ An associative operation
-        mconcat :: [a] -> a
-
-        -- ^ Fold a list using the monoid.
-        -- For most types, the default definition for 'mconcat' will be
-        -- used, but the function is included in the class definition so
-        -- that an optimized version can be provided for specific types.
-
-        mconcat = foldr mappend mempty
-
 infixr 6 <>
 
 -- | An infix synonym for 'mappend'.
@@ -102,55 +65,6 @@ infixr 6 <>
 
 -- Monoid instances.
 
-instance Monoid [a] where
-        mempty  = []
-        mappend = (++)
-
-instance Monoid b => Monoid (a -> b) where
-        mempty _ = mempty
-        mappend f g x = f x `mappend` g x
-
-instance Monoid () where
-        -- Should it be strict?
-        mempty        = ()
-        _ `mappend` _ = ()
-        mconcat _     = ()
-
-instance (Monoid a, Monoid b) => Monoid (a,b) where
-        mempty = (mempty, mempty)
-        (a1,b1) `mappend` (a2,b2) =
-                (a1 `mappend` a2, b1 `mappend` b2)
-
-instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
-        mempty = (mempty, mempty, mempty)
-        (a1,b1,c1) `mappend` (a2,b2,c2) =
-                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
-
-instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
-        mempty = (mempty, mempty, mempty, mempty)
-        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
-                (a1 `mappend` a2, b1 `mappend` b2,
-                 c1 `mappend` c2, d1 `mappend` d2)
-
-instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
-                Monoid (a,b,c,d,e) where
-        mempty = (mempty, mempty, mempty, mempty, mempty)
-        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
-                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
-                 d1 `mappend` d2, e1 `mappend` e2)
-
--- lexicographical ordering
-instance Monoid Ordering where
-        mempty         = EQ
-        LT `mappend` _ = LT
-        EQ `mappend` y = y
-        GT `mappend` _ = GT
-
-instance Monoid (Proxy s) where
-    mempty = Proxy
-    mappend _ _ = Proxy
-    mconcat _ = Proxy
-
 -- | The dual of a monoid, obtained by swapping the arguments of 'mappend'.
 newtype Dual a = Dual { getDual :: a }
         deriving (Eq, Ord, Read, Show, Bounded, Generic, Generic1)
@@ -230,18 +144,6 @@ instance Num a => Monoid (Product a) where
 --      Just (combine key value oldValue))
 -- @
 
--- | Lift a semigroup into 'Maybe' forming a 'Monoid' according to
--- <http://en.wikipedia.org/wiki/Monoid>: \"Any semigroup @S@ may be
--- turned into a monoid simply by adjoining an element @e@ not in @S@
--- and defining @e*e = e@ and @e*s = s = s*e@ for all @s ∈ S@.\" Since
--- there is no \"Semigroup\" typeclass providing just 'mappend', we
--- use 'Monoid' instead.
-instance Monoid a => Monoid (Maybe a) where
-  mempty = Nothing
-  Nothing `mappend` m = m
-  m `mappend` Nothing = m
-  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
-
 
 -- | Maybe monoid returning the leftmost non-Nothing value.
 newtype First a = First { getFirst :: Maybe a }
@@ -255,6 +157,10 @@ instance Monoid (First a) where
 instance Functor First where
         fmap f (First x) = First (fmap f x)
 
+instance Applicative First where
+        pure x = First (Just x)
+        First x <*> First y = First (x <*> y)
+
 instance Monad First where
         return x = First (Just x)
         First x >>= m = First (x >>= getFirst . m)
@@ -271,6 +177,10 @@ instance Monoid (Last a) where
 instance Functor Last where
         fmap f (Last x) = Last (fmap f x)
 
+instance Applicative Last where
+        pure x = Last (Just x)
+        Last x <*> Last y = Last (x <*> y)
+
 instance Monad Last where
         return x = Last (Just x)
         Last x >>= m = Last (x >>= getLast . m)
index ab89066..38a43b0 100644 (file)
@@ -69,10 +69,21 @@ instance Bounded (Proxy s) where
     minBound = Proxy
     maxBound = Proxy
 
+instance Monoid (Proxy s) where
+    mempty = Proxy
+    mappend _ _ = Proxy
+    mconcat _ = Proxy
+
 instance Functor Proxy where
     fmap _ _ = Proxy
     {-# INLINE fmap #-}
 
+instance Applicative Proxy where
+    pure _ = Proxy
+    {-# INLINE pure #-}
+    _ <*> _ = Proxy
+    {-# INLINE (<*>) #-}
+
 instance Monad Proxy where
     return _ = Proxy
     {-# INLINE return #-}
index 7441741..41e2420 100644 (file)
@@ -32,8 +32,6 @@ module Foreign.Storable
         ) where
 
 
-import Control.Monad            ( liftM )
-
 #include "MachDeps.h"
 #include "HsBaseConfig.h"
 
index 6a089ee..3ee533d 100644 (file)
@@ -123,6 +123,8 @@ infixl 4  <$
 infixl 1  >>, >>=
 infixr 0  $
 
+infixl 4 <*>, <*, *>, <**>
+
 default ()              -- Double isn't available yet
 \end{code}
 
@@ -183,10 +185,102 @@ foldr = error "urk"
 -}
 \end{code}
 
+%*********************************************************
+%*                                                      *
+\subsection{Monoids}
+%*                                                      *
+%*********************************************************
+\begin{code}
+
+-- ---------------------------------------------------------------------------
+-- | The class of monoids (types with an associative binary operation that
+-- has an identity).  Instances should satisfy the following laws:
+--
+--  * @mappend mempty x = x@
+--
+--  * @mappend x mempty = x@
+--
+--  * @mappend x (mappend y z) = mappend (mappend x y) z@
+--
+--  * @mconcat = 'foldr' mappend mempty@
+--
+-- The method names refer to the monoid of lists under concatenation,
+-- but there are many other instances.
+--
+-- Minimal complete definition: 'mempty' and 'mappend'.
+--
+-- Some types can be viewed as a monoid in more than one way,
+-- e.g. both addition and multiplication on numbers.
+-- In such cases we often define @newtype@s and make those instances
+-- of 'Monoid', e.g. 'Sum' and 'Product'.
+
+class Monoid a where
+        mempty  :: a
+        -- ^ Identity of 'mappend'
+        mappend :: a -> a -> a
+        -- ^ An associative operation
+        mconcat :: [a] -> a
+
+        -- ^ Fold a list using the monoid.
+        -- For most types, the default definition for 'mconcat' will be
+        -- used, but the function is included in the class definition so
+        -- that an optimized version can be provided for specific types.
+
+        mconcat = foldr mappend mempty
+
+instance Monoid [a] where
+        mempty  = []
+        mappend = (++)
+
+instance Monoid b => Monoid (a -> b) where
+        mempty _ = mempty
+        mappend f g x = f x `mappend` g x
+
+instance Monoid () where
+        -- Should it be strict?
+        mempty        = ()
+        _ `mappend` _ = ()
+        mconcat _     = ()
+
+instance (Monoid a, Monoid b) => Monoid (a,b) where
+        mempty = (mempty, mempty)
+        (a1,b1) `mappend` (a2,b2) =
+                (a1 `mappend` a2, b1 `mappend` b2)
+
+instance (Monoid a, Monoid b, Monoid c) => Monoid (a,b,c) where
+        mempty = (mempty, mempty, mempty)
+        (a1,b1,c1) `mappend` (a2,b2,c2) =
+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d) => Monoid (a,b,c,d) where
+        mempty = (mempty, mempty, mempty, mempty)
+        (a1,b1,c1,d1) `mappend` (a2,b2,c2,d2) =
+                (a1 `mappend` a2, b1 `mappend` b2,
+                 c1 `mappend` c2, d1 `mappend` d2)
+
+instance (Monoid a, Monoid b, Monoid c, Monoid d, Monoid e) =>
+                Monoid (a,b,c,d,e) where
+        mempty = (mempty, mempty, mempty, mempty, mempty)
+        (a1,b1,c1,d1,e1) `mappend` (a2,b2,c2,d2,e2) =
+                (a1 `mappend` a2, b1 `mappend` b2, c1 `mappend` c2,
+                 d1 `mappend` d2, e1 `mappend` e2)
+
+-- lexicographical ordering
+instance Monoid Ordering where
+        mempty         = EQ
+        LT `mappend` _ = LT
+        EQ `mappend` y = y
+        GT `mappend` _ = GT
+
+instance Monoid a => Applicative ((,) a) where
+    pure x = (mempty, x)
+    (u, f) <*> (v, x) = (u `mappend` v, f x)
+\end{code}
+
 
 %*********************************************************
 %*                                                      *
-\subsection{Monadic classes @Functor@, @Monad@ }
+\subsection{Monadic classes @Functor@, @Applicative@, @Monad@ }
 %*                                                      *
 %*********************************************************
 
@@ -210,6 +304,82 @@ class  Functor f  where
     (<$)        :: a -> f b -> f a
     (<$)        =  fmap . const
 
+-- | A functor with application, providing operations to
+--
+-- * embed pure expressions ('pure'), and
+--
+-- * sequence computations and combine their results ('<*>').
+--
+-- A minimal complete definition must include implementations of these
+-- functions satisfying the following laws:
+--
+-- [/identity/]
+--
+--      @'pure' 'id' '<*>' v = v@
+--
+-- [/composition/]
+--
+--      @'pure' (.) '<*>' u '<*>' v '<*>' w = u '<*>' (v '<*>' w)@
+--
+-- [/homomorphism/]
+--
+--      @'pure' f '<*>' 'pure' x = 'pure' (f x)@
+--
+-- [/interchange/]
+--
+--      @u '<*>' 'pure' y = 'pure' ('$' y) '<*>' u@
+--
+-- The other methods have the following default definitions, which may
+-- be overridden with equivalent specialized implementations:
+--
+--   * @u '*>' v = 'pure' ('const' 'id') '<*>' u '<*>' v@
+--
+--   * @u '<*' v = 'pure' 'const' '<*>' u '<*>' v@
+--
+-- As a consequence of these laws, the 'Functor' instance for @f@ will satisfy
+--
+--   * @'fmap' f x = 'pure' f '<*>' x@
+--
+-- If @f@ is also a 'Monad', it should satisfy
+--
+--   * @'pure' = 'return'@
+--
+--   * @('<*>') = 'ap'@
+--
+-- (which implies that 'pure' and '<*>' satisfy the applicative functor laws).
+
+class Functor f => Applicative f where
+    -- | Lift a value.
+    pure :: a -> f a
+
+    -- | Sequential application.
+    (<*>) :: f (a -> b) -> f a -> f b
+
+    -- | Sequence actions, discarding the value of the first argument.
+    (*>) :: f a -> f b -> f b
+    (*>) = liftA2 (const id)
+
+    -- | Sequence actions, discarding the value of the second argument.
+    (<*) :: f a -> f b -> f a
+    (<*) = liftA2 const
+
+-- | A variant of '<*>' with the arguments reversed.
+(<**>) :: Applicative f => f a -> f (a -> b) -> f b
+(<**>) = liftA2 (flip ($))
+
+-- | Lift a function to actions.
+-- This function may be used as a value for `fmap` in a `Functor` instance.
+liftA :: Applicative f => (a -> b) -> f a -> f b
+liftA f a = pure f <*> a
+
+-- | Lift a binary function to actions.
+liftA2 :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
+liftA2 f a b = (fmap f a) <*> b
+
+-- | Lift a ternary function to actions.
+liftA3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
+liftA3 f a b c = (fmap f a) <*> b <*> c
+
 {- | The 'Monad' class defines the basic operations over a /monad/,
 a concept from a branch of mathematics known as /category theory/.
 From the perspective of a Haskell programmer, however, it is best to
@@ -233,37 +403,103 @@ The instances of 'Monad' for lists, 'Data.Maybe.Maybe' and 'System.IO.IO'
 defined in the "Prelude" satisfy these laws.
 -}
 
-class  Monad m  where
+-- | The 'join' function is the conventional monad join operator. It
+-- is used to remove one level of monadic structure, projecting its
+-- bound argument into the outer level.
+join              :: (Monad m) => m (m a) -> m a
+join x            =  x >>= id
+
+class Applicative m => Monad m where
     -- | Sequentially compose two actions, passing any value produced
     -- by the first as an argument to the second.
     (>>=)       :: forall a b. m a -> (a -> m b) -> m b
+    m >>= f = join (fmap f m)
+
     -- | Sequentially compose two actions, discarding any value produced
     -- by the first, like sequencing operators (such as the semicolon)
     -- in imperative languages.
     (>>)        :: forall a b. m a -> m b -> m b
-        -- Explicit for-alls so that we know what order to
-        -- give type arguments when desugaring
+    m >> k = m >>= \_ -> k
+    {-# INLINE (>>) #-}
 
     -- | Inject a value into the monadic type.
     return      :: a -> m a
+
     -- | Fail with a message.  This operation is not part of the
     -- mathematical definition of a monad, but is invoked on pattern-match
     -- failure in a @do@ expression.
     fail        :: String -> m a
-
-    {-# INLINE (>>) #-}
-    m >> k      = m >>= \_ -> k
     fail s      = error s
 
+-- | Promote a function to a monad.
+liftM   :: (Monad m) => (a1 -> r) -> m a1 -> m r
+liftM f m1              = do { x1 <- m1; return (f x1) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right.  For example,
+--
+-- >    liftM2 (+) [0,1] [0,2] = [0,2,1,3]
+-- >    liftM2 (+) (Just 1) Nothing = Nothing
+--
+liftM2  :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
+liftM2 f m1 m2          = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right (cf. 'liftM2').
+liftM3  :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
+liftM3 f m1 m2 m3       = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right (cf. 'liftM2').
+liftM4  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
+liftM4 f m1 m2 m3 m4    = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
+
+-- | Promote a function to a monad, scanning the monadic arguments from
+-- left to right (cf. 'liftM2').
+liftM5  :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
+
+{-# INLINEABLE liftM #-}
+{-# SPECIALISE liftM :: (a1->r) -> IO a1 -> IO r #-}
+{-# INLINEABLE liftM2 #-}
+{-# SPECIALISE liftM2 :: (a1->a2->r) -> IO a1 -> IO a2 -> IO r #-}
+{-# INLINEABLE liftM3 #-}
+{-# SPECIALISE liftM3 :: (a1->a2->a3->r) -> IO a1 -> IO a2 -> IO a3 -> IO r #-}
+{-# INLINEABLE liftM4 #-}
+{-# SPECIALISE liftM4 :: (a1->a2->a3->a4->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO r #-}
+{-# INLINEABLE liftM5 #-}
+{-# SPECIALISE liftM5 :: (a1->a2->a3->a4->a5->r) -> IO a1 -> IO a2 -> IO a3 -> IO a4 -> IO a5 -> IO r #-}
+
+{- | In many situations, the 'liftM' operations can be replaced by uses of
+'ap', which promotes function application. 
+
+>       return f `ap` x1 `ap` ... `ap` xn
+
+is equivalent to 
+
+>       liftMn f x1 x2 ... xn
+
+-}
+
+ap                :: (Monad m) => m (a -> b) -> m a -> m b
+ap                =  liftM2 id
+
+-- instances for Prelude types
+
 instance Functor ((->) r) where
     fmap = (.)
 
+instance Applicative ((->) a) where
+    pure = const
+    (<*>) f g x = f x (g x)
+
 instance Monad ((->) r) where
     return = const
     f >>= k = \ r -> k (f r) r
 
 instance Functor ((,) a) where
     fmap f (x,y) = (x, f y)
+
 \end{code}
 
 
@@ -277,6 +513,10 @@ instance Functor ((,) a) where
 instance Functor [] where
     fmap = map
 
+instance Applicative [] where
+    pure = return
+    (<*>) = ap
+
 instance  Monad []  where
     m >>= k             = foldr ((++) . k) [] m
     m >> k              = foldr ((++) . (\ _ -> k)) [] m
@@ -625,6 +865,10 @@ asTypeOf                =  const
 instance  Functor IO where
    fmap f x = x >>= (return . f)
 
+instance Applicative IO where
+    pure = return
+    (<*>) = ap
+
 instance  Monad IO  where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
index bd60ebd..391d072 100644 (file)
@@ -552,6 +552,10 @@ unSTM (STM a) = a
 instance  Functor STM where
    fmap f x = x >>= (return . f)
 
+instance Applicative STM where
+  pure = return
+  (<*>) = ap
+
 instance  Monad STM  where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
@@ -575,9 +579,13 @@ thenSTM (STM m) k = STM ( \s ->
 returnSTM :: a -> STM a
 returnSTM x = STM (\s -> (# s, x #))
 
+instance Alternative STM where
+  empty = retry
+  (<|>) = orElse
+
 instance MonadPlus STM where
-  mzero = retry
-  mplus = orElse
+  mzero = empty
+  mplus = (<|>)
 
 -- | Unsafely performs IO in the STM monad.  Beware: this is a highly
 -- dangerous thing to do.
index 30dbd77..3626387 100644 (file)
@@ -24,7 +24,7 @@ module GHC.Event.Array
     , useAsPtr
     ) where
 
-import Control.Monad hiding (forM_)
+import Control.Monad hiding (forM_, empty)
 import Data.Bits ((.|.), shiftR)
 import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)
 import Data.Maybe
index b808b21..298f450 100644 (file)
@@ -41,7 +41,6 @@ available = False
 import Control.Monad (when)
 import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
 import Data.Word (Word32)
 import Foreign.C.Error (eNOENT, getErrno, throwErrno,
                         throwErrnoIfMinus1, throwErrnoIfMinus1_)
index a4c2e10..fcd7886 100644 (file)
@@ -25,7 +25,6 @@ module GHC.Event.Internal
 import Data.Bits ((.|.), (.&.))
 import Data.List (foldl', intercalate)
 import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
 import Foreign.C.Error (eINTR, getErrno, throwErrno)
 import System.Posix.Types (Fd)
 import GHC.Base
index d55d5b1..1dbe036 100644 (file)
@@ -51,12 +51,11 @@ module GHC.Event.Manager
 import Control.Concurrent.MVar (MVar, newMVar, readMVar, putMVar,
                                 tryPutMVar, takeMVar, withMVar)
 import Control.Exception (onException)
-import Control.Monad ((=<<), forM_, liftM, when, replicateM, void)
+import Control.Monad ((=<<), forM_, when, replicateM, void)
 import Data.Bits ((.&.))
 import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..), maybe)
-import Data.Monoid (mappend, mconcat, mempty)
 import GHC.Arr (Array, (!), listArray)
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
index 2ed25be..ad2a96f 100644 (file)
@@ -26,10 +26,9 @@ available = False
 #include <poll.h>
 
 import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
-import Control.Monad ((=<<), liftM, liftM2, unless)
+import Control.Monad ((=<<), unless)
 import Data.Bits (Bits, FiniteBits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
 import Data.Word
 import Foreign.C.Types (CInt(..), CShort(..))
 import Foreign.Ptr (Ptr)
index f581330..7ba2aea 100644 (file)
@@ -38,11 +38,10 @@ module GHC.Event.TimerManager
 -- Imports
 
 import Control.Exception (finally)
-import Control.Monad ((=<<), liftM, sequence_, when)
+import Control.Monad ((=<<), sequence_, when)
 import Data.IORef (IORef, atomicModifyIORef', mkWeakIORef, newIORef, readIORef,
                    writeIORef)
 import Data.Maybe (Maybe(..))
-import Data.Monoid (mempty)
 import GHC.Base
 import GHC.Conc.Signal (runHandlers)
 import GHC.Num (Num(..))
index f66d540..c118635 100644 (file)
@@ -21,7 +21,7 @@ module GHC.GHCi {-# WARNING "This is an unstable interface." #-} (
         GHCiSandboxIO(..), NoIO()
     ) where
 
-import GHC.Base (IO(), Monad, (>>=), return, id, (.))
+import GHC.Base (IO(), Monad, Functor(fmap), Applicative(..), (>>=), return, id, (.), ap)
 
 -- | A monad that can execute GHCi statements by lifting them out of
 -- m into the IO monad. (e.g state monads)
@@ -34,6 +34,13 @@ instance GHCiSandboxIO IO where
 -- | A monad that doesn't allow any IO.
 newtype NoIO a = NoIO { noio :: IO a }
 
+instance Functor NoIO where
+  fmap f (NoIO a) = NoIO (fmap f a)
+
+instance Applicative NoIO where
+  pure  = return
+  (<*>) = ap
+
 instance Monad NoIO where
     return a  = NoIO (return a)
     (>>=) k f = NoIO (noio k >>= noio . f)
index 5da8b0a..6e922c0 100644 (file)
@@ -65,6 +65,10 @@ instance Functor (ST s) where
       case (m s) of { (# new_s, r #) ->
       (# new_s, f r #) }
 
+instance Applicative (ST s) where
+    pure = return
+    (<*>) = ap
+
 instance Monad (ST s) where
     {-# INLINE return #-}
     {-# INLINE (>>)   #-}
index 687dcc6..12fe189 100644 (file)
@@ -67,8 +67,9 @@ module Prelude (
     fromIntegral, realToFrac,
 
     -- ** Monads and functors
-    Monad((>>=), (>>), return, fail),
     Functor(fmap),
+    Applicative(pure, (<*>), (*>), (<*)),
+    Monad((>>=), (>>), return, fail),
     mapM, mapM_, sequence, sequence_, (=<<),
 
     -- ** Miscellaneous functions
index a0e6e22..afdaba5 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE MagicHash #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -60,20 +61,19 @@ module Text.ParserCombinators.ReadP
   chainl1,
   chainr1,
   manyTill,
-  
+
   -- * Running a parser
   ReadS,
   readP_to_S,
   readS_to_P,
-  
+
   -- * Properties
   -- $properties
   )
  where
 
-import Control.Monad( MonadPlus(..), sequence, liftM2 )
-
-import {-# SOURCE #-} GHC.Unicode ( isSpace  )
+import Control.Monad ( Alternative(empty, (<|>)), MonadPlus(..), sequence )
+import {-# SOURCE #-} GHC.Unicode ( isSpace )
 import GHC.List ( replicate, null )
 import GHC.Base
 
@@ -99,48 +99,57 @@ data P a
   | Fail
   | Result a (P a)
   | Final [(a,String)] -- invariant: list is non-empty!
+  deriving Functor
 
 -- Monad, MonadPlus
 
+instance Applicative P where
+  pure  = return
+  (<*>) = ap
+
+instance MonadPlus P where
+  mzero = empty
+  mplus = (<|>)
+
 instance Monad P where
   return x = Result x Fail
 
   (Get f)      >>= k = Get (\c -> f c >>= k)
   (Look f)     >>= k = Look (\s -> f s >>= k)
   Fail         >>= _ = Fail
-  (Result x p) >>= k = k x `mplus` (p >>= k)
+  (Result x p) >>= k = k x <|> (p >>= k)
   (Final r)    >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
 
   fail _ = Fail
 
-instance MonadPlus P where
-  mzero = Fail
+instance Alternative P where
+  empty = Fail
 
   -- most common case: two gets are combined
-  Get f1     `mplus` Get f2     = Get (\c -> f1 c `mplus` f2 c)
-  
+  Get f1     <|> Get f2     = Get (\c -> f1 c <|> f2 c)
+
   -- results are delivered as soon as possible
-  Result x p `mplus` q          = Result x (p `mplus` q)
-  p          `mplus` Result x q = Result x (p `mplus` q)
+  Result x p <|> q          = Result x (p <|> q)
+  p          <|> Result x q = Result x (p <|> q)
 
   -- fail disappears
-  Fail       `mplus` p          = p
-  p          `mplus` Fail       = p
+  Fail       <|> p          = p
+  p          <|> Fail       = p
 
   -- two finals are combined
   -- final + look becomes one look and one final (=optimization)
   -- final + sthg else becomes one look and one final
-  Final r    `mplus` Final t    = Final (r ++ t)
-  Final r    `mplus` Look f     = Look (\s -> Final (r ++ run (f s) s))
-  Final r    `mplus` p          = Look (\s -> Final (r ++ run p s))
-  Look f     `mplus` Final r    = Look (\s -> Final (run (f s) s ++ r))
-  p          `mplus` Final r    = Look (\s -> Final (run p s ++ r))
+  Final r    <|> Final t    = Final (r ++ t)
+  Final r    <|> Look f     = Look (\s -> Final (r ++ run (f s) s))
+  Final r    <|> p          = Look (\s -> Final (r ++ run p s))
+  Look f     <|> Final r    = Look (\s -> Final (run (f s) s ++ r))
+  p          <|> Final r    = Look (\s -> Final (run p s ++ r))
 
   -- two looks are combined (=optimization)
   -- look + sthg else floats upwards
-  Look f     `mplus` Look g     = Look (\s -> f s `mplus` g s)
-  Look f     `mplus` p          = Look (\s -> f s `mplus` p)
-  p          `mplus` Look f     = Look (\s -> p `mplus` f s)
+  Look f     <|> Look g     = Look (\s -> f s <|> g s)
+  Look f     <|> p          = Look (\s -> f s <|> p)
+  p          <|> Look f     = Look (\s -> p <|> f s)
 
 -- ---------------------------------------------------------------------------
 -- The ReadP type
@@ -152,11 +161,19 @@ newtype ReadP a = R (forall b . (a -> P b) -> P b)
 instance Functor ReadP where
   fmap h (R f) = R (\k -> f (k . h))
 
+instance Applicative ReadP where
+    pure = return
+    (<*>) = ap
+
 instance Monad ReadP where
   return x  = R (\k -> k x)
   fail _    = R (\_ -> Fail)
   R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
 
+instance Alternative ReadP where
+    empty = mzero
+    (<|>) = mplus
+
 instance MonadPlus ReadP where
   mzero = pfail
   mplus = (+++)
@@ -195,7 +212,7 @@ pfail = R (\_ -> Fail)
 
 (+++) :: ReadP a -> ReadP a -> ReadP a
 -- ^ Symmetric choice.
-R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
+R f1 +++ R f2 = R (\k -> f1 k <|> f2 k)
 
 (<++) :: ReadP a -> ReadP a -> ReadP a
 -- ^ Local, exclusive, left-biased choice: If left parser
@@ -226,7 +243,7 @@ gather (R m)
   gath l (Get f)      = Get (\c -> gath (l.(c:)) (f c))
   gath _ Fail         = Fail
   gath l (Look f)     = Look (\s -> gath l (f s))
-  gath l (Result k p) = k (l []) `mplus` gath l p
+  gath l (Result k p) = k (l []) <|> gath l p
   gath _ (Final _)    = error "do not use readS_to_P in gather!"
 
 -- ---------------------------------------------------------------------------
index 235436c..7098b50 100644 (file)
@@ -16,9 +16,9 @@
 -----------------------------------------------------------------------------
 
 module Text.ParserCombinators.ReadPrec
-  ( 
+  (
   ReadPrec,
-  
+
   -- * Precedences
   Prec,
   minPrec,
@@ -61,7 +61,7 @@ import qualified Text.ParserCombinators.ReadP as ReadP
   , pfail
   )
 
-import Control.Monad( MonadPlus(..) )
+import Control.Monad( MonadPlus(..), Alternative(..) )
 import GHC.Num( Num(..) )
 import GHC.Base
 
@@ -75,17 +75,24 @@ newtype ReadPrec a = P (Prec -> ReadP a)
 instance Functor ReadPrec where
   fmap h (P f) = P (\n -> fmap h (f n))
 
+instance Applicative ReadPrec where
+    pure = return
+    (<*>) = ap
+
 instance Monad ReadPrec where
   return x  = P (\_ -> return x)
   fail s    = P (\_ -> fail s)
   P f >>= k = P (\n -> do a <- f n; let P f' = k a in f' n)
-  
+
 instance MonadPlus ReadPrec where
   mzero = pfail
   mplus = (+++)
 
+instance Alternative ReadPrec where
+    empty = mzero
+    (<|>) = mplus
+
 -- precedences
-  
 type Prec = Int
 
 minPrec :: Prec
index c4b0b77..22b336a 100644 (file)
@@ -38,7 +38,6 @@ module Language.Haskell.TH.PprLib (
 import Language.Haskell.TH.Syntax
     (Name(..), showName', NameFlavour(..), NameIs(..))
 import qualified Text.PrettyPrint as HPJ
-import Control.Applicative (Applicative(..))
 import Control.Monad (liftM, liftM2, ap)
 import Language.Haskell.TH.Lib.Map ( Map )
 import qualified Language.Haskell.TH.Lib.Map as Map ( lookup, insert, empty )
index 3172cbb..6504108 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, PolymorphicComponents, RoleAnnotations, UnboxedTuples #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -19,7 +19,9 @@ module Language.Haskell.TH.Syntax where
 import GHC.Exts
 import Data.Data (Data(..), Typeable, mkConstr, mkDataType, constrIndex)
 import qualified Data.Data as Data
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative( Applicative(..) )
+#endif
 import Data.IORef
 import System.IO.Unsafe        ( unsafePerformIO )
 import Control.Monad (liftM)
index bd3e3bc..fad83c9 100644 (file)
@@ -96,8 +96,14 @@ libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-incomplete-patterns
 # Temporarily turn off pointless-pragma warnings for containers
 libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-pointless-pragmas
 
-# Temporarily turn off unused-imports warnings for containers
+# Turn off import warnings for bad unused imports
 libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
+libraries/hoopl_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
+libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
+utils/haddock_dist_EXTRA_HC_OPTS += -fno-warn-unused-imports
+libraries/stm_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
+libraries/parallel_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
+libraries/vector_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports
 
 # bytestring has identities at the moment
 libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-identities
index cd574ea..36ac195 100644 (file)
@@ -14,11 +14,13 @@ newtype T = MkT S deriving( C a )
 class (Monad m) => MonadState s m | m -> s where
 
 newtype State s a = State { runState :: s -> (a, s) }
+instance Functor (State s) where {}
+instance Applicative (State s) where {}
 instance Monad (State s) where {}
 instance MonadState s (State s) where {}
 
 newtype WrappedState s a = WS { runWS :: State s a }
-   deriving (Monad, MonadState state)
+   deriving (Functor, Applicative, Monad, MonadState state)
 --   deriving (Monad)
 
 deriving instance (MonadState state (State s))
index b70fc33..67b949e 100644 (file)
@@ -1,5 +1,5 @@
 
-T3621.hs:21:21:
+T3621.hs:23:43:
     No instance for (MonadState state (State s))
       arising from the 'deriving' clause of a data type declaration
     Possible fix:
index 3fd8ccf..663fb38 100644 (file)
@@ -6,7 +6,7 @@
 module Main where\r
 \r
 newtype Wrap m a = Wrap { unWrap :: m a } \r
-    deriving (Monad, Eq)\r
+    deriving (Functor, Applicative, Monad, Eq)\r
 \r
 foo :: Int -> Wrap IO a -> Wrap IO ()\r
 foo 0 a = return ()\r
index 29bca02..0cf5e9b 100644 (file)
@@ -35,6 +35,7 @@ instance Functor Maybe -- Defined in ‘Data.Maybe’
 instance Ord a => Ord (Maybe a) -- Defined in ‘Data.Maybe’
 instance Read a => Read (Maybe a) -- Defined in ‘GHC.Read’
 instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
+instance Applicative Maybe -- Defined in ‘Data.Maybe’
 type instance A (Maybe a) a = a        -- Defined at T4175.hs:9:1
 data Int = I# Int#     -- Defined in ‘GHC.Types’
 instance C Int -- Defined at T4175.hs:18:10
index 46935eb..9177bbd 100644 (file)
@@ -18,6 +18,8 @@ instance Functor ((,) a) -- Defined in ‘GHC.Base’
 instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’
 instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’
 instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’
+instance GHC.Base.Monoid a => Applicative ((,) a)
+  -- Defined in ‘GHC.Base’
 data (#,#) (a :: OpenKind) (b :: OpenKind) = (#,#) a b
        -- Defined in ‘GHC.Prim’
 (,) :: a -> b -> (a, b)
index 69efa29..749a244 100644 (file)
@@ -1,4 +1,5 @@
 data (->) a b  -- Defined in ‘GHC.Prim’
 instance Monad ((->) r) -- Defined in ‘GHC.Base’
 instance Functor ((->) r) -- Defined in ‘GHC.Base’
-instance Monoid b => Monoid (a -> b) -- Defined in ‘Data.Monoid’
+instance Applicative ((->) a) -- Defined in ‘GHC.Base’
+instance Monoid b => Monoid (a -> b) -- Defined in ‘GHC.Base’
index 239ec07..6b807f6 100644 (file)
@@ -5,6 +5,7 @@ instance Functor [] -- Defined in ‘GHC.Base’
 instance Ord a => Ord [a] -- Defined in ‘GHC.Classes’
 instance Read a => Read [a] -- Defined in ‘GHC.Read’
 instance Show a => Show [a] -- Defined in ‘GHC.Show’
+instance Applicative [] -- Defined in ‘GHC.Base’
 data () = ()   -- Defined in ‘GHC.Tuple’
 instance Bounded () -- Defined in ‘GHC.Enum’
 instance Enum () -- Defined in ‘GHC.Enum’
@@ -20,3 +21,5 @@ instance Functor ((,) a) -- Defined in ‘GHC.Base’
 instance (Ord a, Ord b) => Ord (a, b) -- Defined in ‘GHC.Classes’
 instance (Read a, Read b) => Read (a, b) -- Defined in ‘GHC.Read’
 instance (Show a, Show b) => Show (a, b) -- Defined in ‘GHC.Show’
+instance GHC.Base.Monoid a => Applicative ((,) a)
+  -- Defined in ‘GHC.Base’
index 700a212..bd3a045 100644 (file)
@@ -1,3 +1,4 @@
 data (->) a b  -- Defined in ‘GHC.Prim’
 instance Monad ((->) r) -- Defined in ‘GHC.Base’
 instance Functor ((->) r) -- Defined in ‘GHC.Base’
+instance Applicative ((->) a) -- Defined in ‘GHC.Base’
index 0d794be..c1356de 100644 (file)
@@ -14,7 +14,8 @@ c2 :: (C a b, N b, S b) => a -> b
 c3 :: C a b => forall a. a -> b
 c4 :: C a b => forall a1. a1 -> b
 -- imported via Control.Monad
-class Monad m => MonadPlus (m :: * -> *) where
+class (Control.Monad.Alternative m, Monad m) =>
+      MonadPlus (m :: * -> *) where
   mzero :: m a
   mplus :: m a -> m a -> m a
 mplus :: MonadPlus m => forall a. m a -> m a -> m a
@@ -25,7 +26,7 @@ mzero :: MonadPlus m => forall a. m a
 fail :: Monad m => forall a. GHC.Base.String -> m a
 return :: Monad m => forall a. a -> m a
 -- imported via Control.Monad, Prelude, T
-class Monad (m :: * -> *) where
+class GHC.Base.Applicative m => Monad (m :: * -> *) where
   (>>=) :: m a -> (a -> m b) -> m b
   (>>) :: m a -> m b -> m b
   return :: a -> m a
index 0d722c9..47ec533 100644 (file)
@@ -1,8 +1,8 @@
-class GHC.Base.Monad m =>
+class (Control.Monad.Alternative m, GHC.Base.Monad m) =>
       Control.Monad.MonadPlus (m :: * -> *) where
   ...
   mplus :: m a -> m a -> m a
-class GHC.Base.Monad m =>
+class (Control.Monad.Alternative m, GHC.Base.Monad m) =>
       Control.Monad.MonadPlus (m :: * -> *) where
   ...
   Control.Monad.mplus :: m a -> m a -> m a
index d7d4730..afea7e6 100644 (file)
@@ -15,7 +15,7 @@
 module XMLGenerator where
 
 newtype XMLGenT m a = XMLGenT (m a)
-   deriving (Functor, Monad)
+   deriving (Functor, Applicative, Monad)
 
 class Monad m => XMLGen m where
  type XML m
@@ -31,11 +31,15 @@ instance {-# OVERLAPPABLE #-} (XMLGen m,  XML m ~ x) => EmbedAsChild m x
 
 data Xml = Xml
 data IdentityT m a = IdentityT (m a)
+instance Functor (IdentityT m)
+instance Applicative (IdentityT m)
 instance Monad (IdentityT m)
 instance XMLGen (IdentityT m) where
     type XML (IdentityT m) = Xml
 
 data Identity a = Identity a
+instance Functor Identity
+instance Applicative Identity
 instance Monad Identity
 
 instance {-# OVERLAPPING #-} EmbedAsChild (IdentityT IO) (XMLGenT Identity ())
index 760cdf9..320d9a5 100644 (file)
@@ -1,5 +1,5 @@
 
-T4485.hs:46:15:
+T4485.hs:50:15:
     Overlapping instances for EmbedAsChild
                                 (IdentityT IO) (XMLGenT m0 (XML m0))
       arising from a use of ‘asChild’
@@ -9,7 +9,7 @@ T4485.hs:46:15:
         -- Defined at T4485.hs:28:30
       instance [overlapping] EmbedAsChild
                                (IdentityT IO) (XMLGenT Identity ())
-        -- Defined at T4485.hs:41:30
+        -- Defined at T4485.hs:45:30
     (The choice depends on the instantiation of ‘m0’
      To pick the first instance above, use IncoherentInstances
      when compiling the other instance declarations)
@@ -18,11 +18,11 @@ T4485.hs:46:15:
     In an equation for ‘asChild’:
         asChild b = asChild $ (genElement "foo")
 
-T4485.hs:46:26:
+T4485.hs:50:26:
     No instance for (XMLGen m0) arising from a use of ‘genElement’
     The type variable ‘m0’ is ambiguous
     Note: there is a potential instance available:
-      instance XMLGen (IdentityT m) -- Defined at T4485.hs:35:10
+      instance XMLGen (IdentityT m) -- Defined at T4485.hs:37:10
     In the second argument of ‘($)’, namely ‘(genElement "foo")’
     In the expression: asChild $ (genElement "foo")
     In an equation for ‘asChild’:
index c542cf0..bce63cd 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts, TypeFamilies #-}
 module T7729 where
+import Control.Monad
 
 class Monad m => PrimMonad m where
   type PrimState m
@@ -16,6 +17,13 @@ newtype Rand m a = Rand {
   runRand :: Maybe (m ()) -> m a
   }
 
+instance Monad m => Functor (Rand m) where
+  fmap = liftM
+
+instance Monad m => Applicative (Rand m) where
+  pure = return
+  (<*>) = ap
+
 instance (Monad m) => Monad (Rand m) where
   return           = Rand . const . return
   (Rand rnd) >>= f = Rand $ \g -> (\x -> runRand (f x) g) =<< rnd g
@@ -25,4 +33,4 @@ instance MonadTrans Rand where
 
 instance MonadPrim m => MonadPrim (Rand m) where
   type BasePrimMonad (Rand m) = BasePrimMonad m
-  liftPrim = liftPrim . lift
\ No newline at end of file
+  liftPrim = liftPrim . lift
index bb5a900..c8814a4 100644 (file)
@@ -1,16 +1,16 @@
 
-T7729.hs:28:14:
+T7729.hs:36:14:
     Could not deduce (BasePrimMonad (Rand m)
                       ~ t0 (BasePrimMonad (Rand m)))
     from the context (PrimMonad (BasePrimMonad (Rand m)),
                       Monad (Rand m),
                       MonadPrim m)
-      bound by the instance declaration at T7729.hs:26:10-42
+      bound by the instance declaration at T7729.hs:34:10-42
     The type variable ‘t0’ is ambiguous
     Expected type: t0 (BasePrimMonad (Rand m)) a -> Rand m a
       Actual type: BasePrimMonad (Rand m) a -> Rand m a
     Relevant bindings include
       liftPrim :: BasePrimMonad (Rand m) a -> Rand m a
-        (bound at T7729.hs:28:3)
+        (bound at T7729.hs:36:3)
     In the first argument of ‘(.)’, namely ‘liftPrim’
     In the expression: liftPrim . lift
index 53c1639..ea36e32 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE FlexibleContexts, TypeFamilies #-}
 module T7729a where
+import Control.Monad
 
 class Monad m => PrimMonad m where
   type PrimState m
@@ -16,6 +17,13 @@ newtype Rand m a = Rand {
   runRand :: Maybe (m ()) -> m a
   }
 
+instance Monad m => Functor (Rand m) where
+  fmap = liftM
+
+instance Monad m => Applicative (Rand m) where
+  pure  = return
+  (<*>) = ap
+
 instance (Monad m) => Monad (Rand m) where
   return           = Rand . const . return
   (Rand rnd) >>= f = Rand $ \g -> (\x -> runRand (f x) g) =<< rnd g
@@ -25,4 +33,4 @@ instance MonadTrans Rand where
 
 instance MonadPrim m => MonadPrim (Rand m) where
   type BasePrimMonad (Rand m) = BasePrimMonad m
-  liftPrim x = liftPrim (lift x)   -- This line changed from T7729
\ No newline at end of file
+  liftPrim x = liftPrim (lift x)   -- This line changed from T7729
index f90db0c..907eb1d 100644 (file)
@@ -1,17 +1,17 @@
 
-T7729a.hs:28:26:
+T7729a.hs:36:26:
     Could not deduce (BasePrimMonad (Rand m)
                       ~ t0 (BasePrimMonad (Rand m)))
     from the context (PrimMonad (BasePrimMonad (Rand m)),
                       Monad (Rand m),
                       MonadPrim m)
-      bound by the instance declaration at T7729a.hs:26:10-42
+      bound by the instance declaration at T7729a.hs:34:10-42
     The type variable ‘t0’ is ambiguous
     Expected type: BasePrimMonad (Rand m) a
       Actual type: t0 (BasePrimMonad (Rand m)) a
     Relevant bindings include
-      x :: BasePrimMonad (Rand m) a (bound at T7729a.hs:28:12)
+      x :: BasePrimMonad (Rand m) a (bound at T7729a.hs:36:12)
       liftPrim :: BasePrimMonad (Rand m) a -> Rand m a
-        (bound at T7729a.hs:28:3)
+        (bound at T7729a.hs:36:3)
     In the first argument of ‘liftPrim’, namely ‘(lift x)’
     In the expression: liftPrim (lift x)
index dc33595..4328257 100644 (file)
@@ -4,10 +4,18 @@
 
 module Main (main) where
 
+import Control.Monad
 import Control.Monad.Fix
 
 data X a = X a deriving Show
 
+instance Functor X where
+  fmap f (X a) = X (f a)
+
+instance Applicative X where
+  pure  = return
+  (<*>) = ap
+
 instance Monad X where
   return      = X
   (X a) >>= f = f a
index 16ab036..e5964a1 100644 (file)
@@ -73,7 +73,7 @@ test('T1969',
              # 2013-02-10 322937684 (x86/OSX)
              # 2014-01-22 316103268 (x86/Linux)
              # 2014-06-29 303300692 (x86/Linux)
-           (wordsize(64), 625525224, 5)]),
+           (wordsize(64), 651626680, 5)]),
              # 17/11/2009 434845560 (amd64/Linux)
              # 08/12/2009 459776680 (amd64/Linux)
              # 17/05/2010 519377728 (amd64/Linux)
@@ -90,7 +90,6 @@ test('T1969',
              # 18/10/2013 698612512 (x86_64/Linux) fix for #8456
              # 10/02/2014 660922376 (x86_64/Linux) call arity analysis
              # 17/07/2014 651626680 (x86_64/Linux) roundabout update
-
       only_ways(['normal']),
 
       extra_hc_opts('-dcore-lint -static')
@@ -221,7 +220,7 @@ test('T3064',
             # expected value: 14 (x86/Linux 28-06-2012):
             # 2013-11-13:     18 (x86/Windows, 64bit machine)
             # 2014-01-22:     23 (x86/Linux)
-           (wordsize(64), 42, 20)]),
+           (wordsize(64), 52, 20)]),
             # (amd64/Linux):            18
             # (amd64/Linux) 2012-02-07: 26
             # (amd64/Linux) 2013-02-12: 23; increased range to 10%
@@ -230,6 +229,7 @@ test('T3064',
             # Increased range to 20%.  peak-usage varies from 22 to 26,
             #  depending on whether the old .hi file exists
             # (amd64/Linux) 2013-09-11: 37; better arity analysis (weird)
+            # (amd64/Linux) (09/09/2014): 42, AMP changes (larger interfaces, more loading)
 
       compiler_stats_num_field('bytes allocated',
           [(wordsize(32), 162457940, 10),
@@ -237,7 +237,7 @@ test('T3064',
             # 2012-10-30: 111189536 (x86/Windows)
             # 2013-11-13: 146626504 (x86/Windows, 64bit machine)
             # 2014-01-22: 162457940 (x86/Linux)
-           (wordsize(64), 313638592, 5)]),
+           (wordsize(64), 407416464, 5)]),
             # (amd64/Linux) (28/06/2011):  73259544
             # (amd64/Linux) (07/02/2013): 224798696
             # (amd64/Linux) (02/08/2013): 236404384, increase from roles
@@ -248,6 +248,7 @@ test('T3064',
             # (amd64/Linux) (23/05/2014): 324022680, unknown cause
             # (amd64/Linux) (2014-07-17): 332702112, general round of updates
             # (amd64/Linux) (2014-08-29): 313638592, w/w for INLINABLE things
+            # (amd64/Linux) (09/09/2014): 407416464, AMP changes (larger interfaces, more loading)
 
       compiler_stats_num_field('max_bytes_used',
           [(wordsize(32), 11202304, 20),
@@ -255,7 +256,7 @@ test('T3064',
             #(some date):  5511604
             # 2013-11-13:  7218200 (x86/Windows, 64bit machine)
             # 2014-04-04: 11202304 (x86/Windows, 64bit machine)
-           (wordsize(64), 19821544, 20)]),
+           (wordsize(64), 24357392, 20)]),
             # (amd64/Linux, intree) (28/06/2011):  4032024
             # (amd64/Linux, intree) (07/02/2013):  9819288
             # (amd64/Linux)         (14/02/2013):  8687360
@@ -266,6 +267,7 @@ test('T3064',
             #                                     933cdf15a2d85229d3df04b437da31fdfbf4961f
             # (amd64/Linux)         (22/11/2013): 16266992, GND via Coercible and counters for constraints solving
             # (amd64/Linux)         (12/12/2013): 19821544, better One shot analysis
+            # (amd64/Linux)         (09/09/2014): 24357392, AMP changes (larger interfaces, more loading)
        only_ways(['normal'])
       ],
      compile,
@@ -305,10 +307,11 @@ test('T5631',
           [(wordsize(32), 346389856, 10),
         # expected value: 392904228 (x86/Linux)
         # 2014-04-04:     346389856 (x86 Windows, 64 bit machine)
-           (wordsize(64), 690742040, 5)]),
+           (wordsize(64), 739704712, 5)]),
         # expected value: 774595008 (amd64/Linux):
         # expected value: 735486328 (amd64/Linux) 2012/12/12:
         # expected value: 690742040 (amd64/Linux) Call Arity improvements
+        # 2014-09-09:     739704712 (amd64/Linux) AMP changes
        only_ways(['normal'])
       ],
      compile,
@@ -403,7 +406,7 @@ test('T5642',
                      # sample from x86/Linux
             # prev:        650000000
             # 2014-09-03:  753045568 
-            (wordsize(64), 1402242360, 10)])
+            (wordsize(64), 1452688392, 10)])
             # prev:        1300000000
             # 2014-07-17:  1358833928 (general round of updates)
             # 2014-08-07:  1402242360 (caused by 1fc60ea)
index d4dad1d..46cad30 100644 (file)
@@ -5,7 +5,7 @@
 test('haddock.base',
      [unless(in_tree_compiler(), skip)
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 7946284944,  5)
+          [(wordsize(64), 8354439016,  5)
             # 2012-08-14: 5920822352 (amd64/Linux)
             # 2012-09-20: 5829972376 (amd64/Linux)
             # 2012-10-08: 5902601224 (amd64/Linux)
@@ -18,6 +18,7 @@ test('haddock.base',
             # 2014-06-12: 7498123680 (x86_64/Linux)
             # 2014-08-05: 7992757384 (x86_64/Linux - bugfix for #314, Haddock now parses more URLs)
             # 2014-08-08: 7946284944 (x86_64/Linux - Haddock updates to attoparsec-0.12.1.0)
+            # 2014-09-09: 8354439016 (x86_64/Linux - Applicative/Monad changes)
           ,(platform('i386-unknown-mingw32'), 3746792812, 5)
             # 2013-02-10:                     3358693084 (x86/Windows)
             # 2013-11-13:                     3097751052 (x86/Windows, 64bit machine)
@@ -38,7 +39,7 @@ test('haddock.base',
 test('haddock.Cabal',
      [unless(in_tree_compiler(), skip)
      ,stats_num_field('bytes allocated',
-          [(wordsize(64), 4267311856, 5)
+          [(wordsize(64), 4660249216, 5)
             # 2012-08-14: 3255435248 (amd64/Linux)
             # 2012-08-29: 3324606664 (amd64/Linux, new codegen)
             # 2012-10-08: 3373401360 (amd64/Linux)
@@ -52,6 +53,7 @@ test('haddock.Cabal',
             # 2014-06-29: 4200993768 (amd64/Linux)
             # 2014-08-05: 4493770224 (x86_64/Linux - bugfix for #314, Haddock now parses more URLs)
             # 2014-08-29: 4267311856 (x86_64/Linux - w/w for INLINABLE things)
+            # 2014-09-09: 4660249216 (x86_64/Linux - Applicative/Monad changes)
 
           ,(platform('i386-unknown-mingw32'), 2052220292, 5)
             # 2012-10-30:                     1733638168 (x86/Windows)
index 7cf9a59..f093d77 100644 (file)
@@ -13,7 +13,7 @@
 {-# LANGUAGE UnicodeSyntax #-}
 
 module Main where
-import Control.Monad (Monad(..), join)
+import Control.Monad (Monad(..), join, ap)
 import Data.Monoid (Monoid(..))
 
 -- First we define the type class Monoidy:
@@ -85,6 +85,10 @@ instance Monoidy (→) (,) () m ⇒ Monoid m where
   mempty = munit ()
   mappend = curry mjoin
 
+instance Applicative Wrapper where
+  pure  = return
+  (<*>) = ap
+
 -- instance (Functor m, Monoidy NT FC Id m) ⇒ Monad m where
 instance Monad Wrapper where
    return x = runNT munit $ Id x
index f289912..9097e53 100644 (file)
@@ -12,7 +12,7 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Main where
-import Control.Monad (Monad(..), join)
+import Control.Monad (Monad(..), join, ap, liftM)
 import Data.Monoid (Monoid(..))
 
 -- First we define the type class Monoidy:
@@ -96,6 +96,10 @@ instance (MId (→) m ~ (), MComp (→) m ~ (,), Monoidy (→) m)
   mempty = munit ()
   mappend = curry mjoin
 
+instance Applicative Wrapper where
+  pure  = return
+  (<*>) = ap
+
 instance Monad Wrapper where
   return x = runNT munit $ Id x
   x >>= f = runNT mjoin $ FC (f `fmap` x)
index 7b62658..2f69ac8 100644 (file)
@@ -7,16 +7,26 @@ module Main where
        import Prelude(String,undefined,Maybe(..),IO,putStrLn,
                Integer,(++),Rational, (==), (>=) );
        
-       import Prelude(Monad(..));
+       import Prelude(Monad(..),Applicative(..),Functor(..));
+        import Control.Monad(ap, liftM);
 
        debugFunc :: String -> IO a -> IO a;
        debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>>
-               (ioa Prelude.>>= (\a -> 
+               (ioa Prelude.>>= (\a ->
                        (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a)
                ));
 
        newtype TM a = MkTM {unTM :: IO a};
 
+        instance (Functor TM) where
+          {
+            fmap = liftM;
+          };
+        instance (Applicative TM) where
+          {
+            pure  = return;
+            (<*>) = ap;
+          };
        instance (Monad TM) where
                {
                return a = MkTM (debugFunc "return" (Prelude.return a));
index dfcb551..210be39 100644 (file)
@@ -2,7 +2,5 @@
 {-# OPTIONS_GHC -Wall -Werror #-}
 module Bug(P) where
 
-import Control.Applicative (Applicative)
-
 newtype P a = P (IO a) deriving (Functor, Applicative, Monad)
 
index 501915f..8870689 100644 (file)
@@ -1,3 +1,2 @@
 module T7145a ( Applicative(pure) ) where
 
-import Control.Applicative ( Applicative(pure) )
index ed2333e..d5f7c08 100644 (file)
@@ -1,2 +1,2 @@
 
-T7145b.hs:7:1: Warning: Defined but not used: ‘pure’
+T7145b.hs:7:1: Warning: Defined but not used: ‘T7145b.pure’
index 00679dd..907a034 100644 (file)
@@ -1,2 +1,4 @@
 
-T2993.hs:7:13: Not in scope: ‘<$>’
+T2993.hs:7:13:
+    Not in scope: ‘<$>’
+    Perhaps you meant ‘<*>’ (imported from Prelude)
index ba72af4..ba77c46 100644 (file)
@@ -17,14 +17,12 @@ Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired:
-    SPEC/main@main:T8848 Control.Applicative.liftA2 _ _ _ @ (T8848.Shape
-                                                           'T8848.Z)
+    SPEC/main@main:T8848 GHC.Base.liftA2 _ _ _ @ (T8848.Shape 'T8848.Z)
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
 Rule fired:
-    SPEC/main@main:T8848 Control.Applicative.liftA2 _ _ _ @ (T8848.Shape
-                                                           'T8848.Z)
+    SPEC/main@main:T8848 GHC.Base.liftA2 _ _ _ @ (T8848.Shape 'T8848.Z)
 Rule fired: Class op $p1Applicative
 Rule fired: Class op fmap
 Rule fired: Class op <*>
index 8c801a4..31ba751 100644 (file)
@@ -7,6 +7,7 @@
 
 module M(foo) where
 
+import Control.Monad
 import Control.Monad.ST
 import Data.Array.ST
 
@@ -25,6 +26,16 @@ runE :: E' v m a -> m a
 runE (E t) = t
 runE (V t _) = t
 
+instance Monad m => Functor (E' RValue m) where
+    {-# INLINE fmap #-}
+    fmap f x = liftM f x
+
+instance Monad m => Applicative (E' RValue m) where
+    {-# INLINE pure #-}
+    pure x = return x
+    {-# INLINE (<*>) #-}
+    (<*>) = ap
+
 instance (Monad m) => Monad (E' RValue m) where
     {-# INLINE return #-}
     return x = E $ return x
index 18b0a69..5d4dc58 100644 (file)
@@ -1,37 +1,37 @@
 
-simpl017.hs:44:12:
+simpl017.hs:55:12:
     Couldn't match expected type ‘forall v. [E m i] -> E' v m a’
                 with actual type ‘[E m i] -> E' v0 m a’
     Relevant bindings include
-      f :: [E m i] -> E' v0 m a (bound at simpl017.hs:43:9)
-      ix :: [E m i] -> m i (bound at simpl017.hs:41:9)
-      a :: arr i a (bound at simpl017.hs:39:11)
+      f :: [E m i] -> E' v0 m a (bound at simpl017.hs:54:9)
+      ix :: [E m i] -> m i (bound at simpl017.hs:52:9)
+      a :: arr i a (bound at simpl017.hs:50:11)
       liftArray :: arr i a -> E m (forall v. [E m i] -> E' v m a)
-        (bound at simpl017.hs:39:1)
+        (bound at simpl017.hs:50:1)
     In the first argument of ‘return’, namely ‘f’
     In a stmt of a 'do' block: return f
 
-simpl017.hs:63:5:
+simpl017.hs:74:5:
     Couldn't match expected type ‘[E (ST t0) Int] -> E (ST s) Int’
                 with actual type ‘forall v. [E (ST s) Int] -> E' v (ST s) Int’
     Relevant bindings include
       a :: forall v. [E (ST s) Int] -> E' v (ST s) Int
-        (bound at simpl017.hs:60:5)
-      ma :: STArray s Int Int (bound at simpl017.hs:59:5)
-      foo :: STArray s Int Int -> ST s Int (bound at simpl017.hs:59:1)
+        (bound at simpl017.hs:71:5)
+      ma :: STArray s Int Int (bound at simpl017.hs:70:5)
+      foo :: STArray s Int Int -> ST s Int (bound at simpl017.hs:70:1)
     The function ‘a’ is applied to one argument,
     but its type ‘forall v. [E (ST s) Int] -> E' v (ST s) Int’ has none
     In the first argument of ‘plus’, namely ‘a [one]’
     In a stmt of a 'do' block: a [one] `plus` a [one]
 
-simpl017.hs:63:19:
+simpl017.hs:74:19:
     Couldn't match expected type ‘[E (ST t1) Int] -> E (ST s) Int’
                 with actual type ‘forall v. [E (ST s) Int] -> E' v (ST s) Int’
     Relevant bindings include
       a :: forall v. [E (ST s) Int] -> E' v (ST s) Int
-        (bound at simpl017.hs:60:5)
-      ma :: STArray s Int Int (bound at simpl017.hs:59:5)
-      foo :: STArray s Int Int -> ST s Int (bound at simpl017.hs:59:1)
+        (bound at simpl017.hs:71:5)
+      ma :: STArray s Int Int (bound at simpl017.hs:70:5)
+      foo :: STArray s Int Int -> ST s Int (bound at simpl017.hs:70:1)
     The function ‘a’ is applied to one argument,
     but its type ‘forall v. [E (ST s) Int] -> E' v (ST s) Int’ has none
     In the second argument of ‘plus’, namely ‘a [one]’
index 491ba5f..6ec51a1 100644 (file)
@@ -43,7 +43,7 @@
 
 module Main where
 
-import Control.Monad (liftM, liftM2, when)
+import Control.Monad (liftM, liftM2, when, ap)
 -- import Control.Monad.Identity
 
 import Debug.Trace (trace)
@@ -66,11 +66,16 @@ instance ( Functor a
       => AncestorFunctor a d where
    liftFunctor = LeftF . (trace "liftFunctor other" . liftFunctor :: a x -> d' x)
 
+-------------
+newtype Identity a = Identity { runIdentity :: a }
 
+instance Functor Identity where
+    fmap = liftM
 
+instance Applicative Identity where
+    pure  = return
+    (<*>) = ap
 
--------------
-newtype Identity a = Identity { runIdentity :: a }
 instance Monad Identity where
     return a = Identity a
     m >>= k  = k (runIdentity m)
@@ -78,6 +83,13 @@ instance Monad Identity where
 newtype Trampoline m s r = Trampoline {bounce :: m (TrampolineState m s r)}
 data TrampolineState m s r = Done r | Suspend! (s (Trampoline m s r))
 
+instance (Monad m, Functor s) => Functor (Trampoline m s) where
+  fmap = liftM
+
+instance (Monad m, Functor s) => Applicative (Trampoline m s) where
+  pure  = return
+  (<*>) = ap
+
 instance (Monad m, Functor s) => Monad (Trampoline m s) where
    return x = Trampoline (return (Done x))
    t >>= f = Trampoline (bounce t >>= apply f)
index c59ad08..0b2e538 100644 (file)
@@ -28,7 +28,7 @@
 module T4524 where
 
 import Data.Maybe ( mapMaybe )
-import Control.Monad ( MonadPlus, mplus, msum, mzero )
+import Control.Monad (Alternative(..), MonadPlus(..), msum, ap, liftM )
 import Unsafe.Coerce (unsafeCoerce)
 
 newtype FileName = FN FilePath deriving ( Eq, Ord )
@@ -157,6 +157,13 @@ unsafeCoerceP1 = unsafeCoerce
 
 data Perhaps a = Unknown | Failed | Succeeded a
 
+instance Functor Perhaps where
+  fmap = liftM
+
+instance Applicative Perhaps where
+  pure  = return
+  (<*>) = ap
+
 instance  Monad Perhaps where
     (Succeeded x) >>= k =  k x
     Failed   >>= _      =  Failed
@@ -167,6 +174,10 @@ instance  Monad Perhaps where
     return              =  Succeeded
     fail _              =  Unknown
 
+instance Alternative Perhaps where
+  (<|>) = mplus
+  empty = mzero
+
 instance  MonadPlus Perhaps where
     mzero                 = Unknown
     Unknown `mplus` ys    = ys
index ce2e820..2bdd4a7 100644 (file)
@@ -8,7 +8,7 @@
 
 module Q where
 
-import Control.Monad (foldM)
+import Control.Monad (foldM, liftM, ap)
 
 data NameId = NameId
 data Named name a = Named
@@ -79,6 +79,13 @@ instance Monad m => MonadState TCState (TCMT m) where
 instance Monad m => MonadTCM (TCMT m) where
     liftTCM = undefined
 
+instance Functor (TCMT m) where
+  fmap = liftM
+
+instance Applicative (TCMT m) where
+  pure  = return
+  (<*>) = ap
+
 instance Monad (TCMT m) where
     return = undefined
     (>>=) = undefined
index 1f0b464..8034606 100644 (file)
@@ -5,7 +5,7 @@
 -- type signature in t1 and t2
 
 module Foo7 where
-import Control.Monad
+import Control.Monad hiding (empty)
 import Control.Monad.ST
 import Data.Array.MArray
 import Data.Array.ST
index ac958da..45c6e8b 100644 (file)
@@ -42,7 +42,9 @@ import qualified Data.Set as Set
 
 import Data.Char ( isSpace, toLower )
 import Data.Ord (comparing)
+#if __GLASGOW_HASKELL__ < 709
 import Control.Applicative (Applicative(..))
+#endif
 import Control.Monad
 import System.Directory ( doesDirectoryExist, getDirectoryContents,
                           doesFileExist, renameFile, removeFile,
index aacaa91..0cc5bc8 160000 (submodule)
@@ -1 +1 @@
-Subproject commit aacaa91951b16f22e3ad54412974b81c32230a8c
+Subproject commit 0cc5bc85e9fca92ab712b68a2ba2c0dd9d3d79f4
index 4a0f677..af92e43 160000 (submodule)
@@ -1 +1 @@
-Subproject commit 4a0f67704d89712f8493a0c7eccffa9243d6ef09
+Subproject commit af92e439369b7a3bb7d0476243af9b5622b7a48f