diff options
| author | Austin Seipp <austin@well-typed.com> | 2014-04-22 06:09:40 -0500 |
|---|---|---|
| committer | Austin Seipp <austin@well-typed.com> | 2014-09-09 08:13:27 -0500 |
| commit | d94de87252d0fe2ae97341d186b03a2fbe136b04 (patch) | |
| tree | 1cac19f2786b1d8a1626886cd6373946a3a276b0 | |
| parent | fdfe6c0e50001add357475a1a3a7627243a28a70 (diff) | |
| download | haskell-d94de87252d0fe2ae97341d186b03a2fbe136b04.tar.gz | |
Make Applicative a superclass of Monad
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, 860 insertions, 633 deletions
diff --git a/aclocal.m4 b/aclocal.m4 index 09300f1a07..0dda8af655 100644 --- a/aclocal.m4 +++ b/aclocal.m4 @@ -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) diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs index c582b783f2..188233d1ea 100644 --- a/compiler/cmm/CmmLayoutStack.hs +++ b/compiler/cmm/CmmLayoutStack.hs @@ -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] diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 970ce68149..d329243ad7 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -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) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index c25147cd82..9502d34378 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -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 diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 4631b2dc14..444112f967 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -53,6 +53,10 @@ import DynFlags import Data.Maybe import Control.Monad +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + ------------------------------------------------------------------------ -- Top-level bindings ------------------------------------------------------------------------ diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index ad34b5ba19..b2b64f8650 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -48,6 +48,10 @@ import Outputable import Control.Monad (when,void) +#if __GLASGOW_HASKELL__ >= 709 +import Prelude hiding ((<*>)) +#endif + ------------------------------------------------------------------------ -- cgExpr: the main function ------------------------------------------------------------------------ diff --git a/compiler/codeGen/StgCmmExtCode.hs b/compiler/codeGen/StgCmmExtCode.hs index 5f412b3cf8..931b55624b 100644 --- a/compiler/codeGen/StgCmmExtCode.hs +++ b/compiler/codeGen/StgCmmExtCode.hs @@ -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 diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 6937c85d01..eb1c7da76d 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -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 diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 7ac2c7a0bd..eca118fd25 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -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) diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index d62101f27e..af2d6619ea 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -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 ) diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 22c89d7e05..57120cf5ce 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -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 diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index e6f4e48425..a86caf1a9d 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -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) diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 985c6db900..d47a01661a 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -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 -------------- diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index 21e0b5fefd..f6bb1a280e 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -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) diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index fae5f36426..5e7289f00c 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -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 diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index 7b18b2e2b3..6844f48970 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -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 diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index 38ed3af44f..f404997c9f 100644 --- a/compiler/deSugar/MatchLit.lhs +++ b/compiler/deSugar/MatchLit.lhs @@ -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] diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs index 52d6adde86..5a9cec2587 100644 --- a/compiler/ghci/ByteCodeAsm.lhs +++ b/compiler/ghci/ByteCodeAsm.lhs @@ -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 diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs index 645a0d8118..a6e80e5820 100644 --- a/compiler/ghci/ByteCodeGen.lhs +++ b/compiler/ghci/ByteCodeGen.lhs @@ -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 diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 7b841d5edc..c7c993503e 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -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 diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e0176a52a0..5ebada6e9c 100644 --- a/compiler/hsSyn/HsBinds.lhs +++ b/compiler/hsSyn/HsBinds.lhs @@ -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} %************************************************************************ diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 935b8eda93..6fec398582 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -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} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 2be6e9d4d8..fa6f603d8e 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -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} diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 9b5886a7f2..ec41f0ddd2 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -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 diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 50cd824b24..0d6e1ac04c 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -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 diff --git a/compiler/main/CmdLineParser.hs b/compiler/main/CmdLineParser.hs index 5ee7086cbc..7d7bbfe95e 100644 --- a/compiler/main/CmdLineParser.hs +++ b/compiler/main/CmdLineParser.hs @@ -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 diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 5a18e6e7bf..0e17793e07 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -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 diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs index c43064e7f1..b06f5bcb9c 100644 --- a/compiler/main/ErrUtils.lhs +++ b/compiler/main/ErrUtils.lhs @@ -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 diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index b5ad08b425..f56c173662 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -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} diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index fcf235bd23..c6d72b2cc9 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -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 diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 01c75c02d8..c14c8cf7f8 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -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)) diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 3c4a551df3..94d64b1073 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -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 diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index a4c9f74df7..f47a1ab434 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -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 { diff --git a/compiler/nativeGen/RegAlloc/Linear/State.hs b/compiler/nativeGen/RegAlloc/Linear/State.hs index 39b5777ef3..287bdc65e4 100644 --- a/compiler/nativeGen/RegAlloc/Linear/State.hs +++ b/compiler/nativeGen/RegAlloc/Linear/State.hs @@ -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 diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index cfe795585b..8fd5bd93db 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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 diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 6cac513b13..b13251c1e6 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index ed6fa3f791..a182e9b0fb 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -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 diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs index d2e648f382..a91d3f7d9e 100644 --- a/compiler/prelude/PrelRules.lhs +++ b/compiler/prelude/PrelRules.lhs @@ -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 diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index 4a6da2417e..f9dc4a359f 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -39,8 +39,9 @@ import SrcLoc import Util import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) - +#endif stgMassageForProfiling :: DynFlags diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index f333a239a1..b9bfcce531 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -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 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 2872b480c2..79a944fb2f 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -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 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 5071828e4d..cd43d8a866 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -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 diff --git a/compiler/simplCore/CoreMonad.lhs b/compiler/simplCore/CoreMonad.lhs index ad4a0e1a1b..dcedfb4523 100644 --- a/compiler/simplCore/CoreMonad.lhs +++ b/compiler/simplCore/CoreMonad.lhs @@ -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 diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs index cbce63f2cf..09acd70e74 100644 --- a/compiler/specialise/Specialise.lhs +++ b/compiler/specialise/Specialise.lhs @@ -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 diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs index ec9f6fa9d6..93fc9cd71e 100644 --- a/compiler/stgSyn/StgLint.lhs +++ b/compiler/stgSyn/StgLint.lhs @@ -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 diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 6feab9e728..c286d3bcc1 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -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 diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 6812ac7387..a14d29eee5 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -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 diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index 7e6c495506..6188842b72 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -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) <+> diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 303391fcdd..9d1da3fc48 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -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 diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 2b123ffab6..f559dda17f 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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 diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index cfc76d6538..c052575c12 100644 --- a/compiler/typecheck/TcPat.lhs +++ b/compiler/typecheck/TcPat.lhs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 9898b46066..49276848ff 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -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} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 9dbc4206a5..c3215b3f6f 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -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 diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs index 3c6aedb429..a4a7b293d9 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -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) ] diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index 262aa519b3..2360f7b726 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -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} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index db3ae8315f..6c14b4b7bc 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -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} %************************************************************************ diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs index ef06ddd263..f943ccd663 100644 --- a/compiler/typecheck/TcUnify.lhs +++ b/compiler/typecheck/TcUnify.lhs @@ -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 diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index ad81623c67..8381533a28 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -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] diff --git a/compiler/types/Unify.lhs b/compiler/types/Unify.lhs index 1eb1c2b872..709c0e5ecc 100644 --- a/compiler/types/Unify.lhs +++ b/compiler/types/Unify.lhs @@ -41,7 +41,9 @@ import TypeRep import Util import Control.Monad (liftM, ap) +#if __GLASGOW_HASKELL__ < 709 import Control.Applicative (Applicative(..)) +#endif \end{code} diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index 1db15537c7..8193beb87f 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -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 diff --git a/compiler/utils/Maybes.lhs b/compiler/utils/Maybes.lhs index d9e1762a2f..8052b1d848 100644 --- a/compiler/utils/Maybes.lhs +++ b/compiler/utils/Maybes.lhs @@ -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 diff --git a/compiler/utils/Stream.hs b/compiler/utils/Stream.hs index 47cdee0789..edb0b0c558 100644 --- a/compiler/utils/Stream.hs +++ b/compiler/utils/Stream.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Exp.hs b/compiler/vectorise/Vectorise/Exp.hs index 6adb9ec435..f9759039dc 100644 --- a/compiler/vectorise/Vectorise/Exp.hs +++ b/compiler/vectorise/Vectorise/Exp.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 6ee5ca6cd9..b73d094a65 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -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 diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 22109c428d..89c2028960 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -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) diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index 070932cefc..ea90280b06 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -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 diff --git a/libraries/base/Control/Applicative.hs b/libraries/base/Control/Applicative.hs index 81ce513a58..41049c6a9f 100644 --- a/libraries/base/Control/Applicative.hs +++ b/libraries/base/Control/Applicative.hs @@ -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 diff --git a/libraries/base/Control/Arrow.hs b/libraries/base/Control/Arrow.hs index b723dd4722..f6067a01c3 100644 --- a/libraries/base/Control/Arrow.hs +++ b/libraries/base/Control/Arrow.hs @@ -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) diff --git a/libraries/base/Control/Monad.hs b/libraries/base/Control/Monad.hs index 4a8060f87c..bfadd7ce1a 100644 --- a/libraries/base/Control/Monad.hs +++ b/libraries/base/Control/Monad.hs @@ -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.<$>'. diff --git a/libraries/base/Control/Monad/ST/Lazy/Imp.hs b/libraries/base/Control/Monad/ST/Lazy/Imp.hs index 19e8974807..3fdd541047 100644 --- a/libraries/base/Control/Monad/ST/Lazy/Imp.hs +++ b/libraries/base/Control/Monad/ST/Lazy/Imp.hs @@ -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) diff --git a/libraries/base/Data/Either.hs b/libraries/base/Data/Either.hs index 9abb20522c..efa9328f3e 100644 --- a/libraries/base/Data/Either.hs +++ b/libraries/base/Data/Either.hs @@ -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 diff --git a/libraries/base/Data/Maybe.hs b/libraries/base/Data/Maybe.hs index fe2a0abc1e..de8eadcd6e 100644 --- a/libraries/base/Data/Maybe.hs +++ b/libraries/base/Data/Maybe.hs @@ -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 diff --git a/libraries/base/Data/Monoid.hs b/libraries/base/Data/Monoid.hs index 2100518e3a..6b393b173e 100644 --- a/libraries/base/Data/Monoid.hs +++ b/libraries/base/Data/Monoid.hs @@ -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) diff --git a/libraries/base/Data/Proxy.hs b/libraries/base/Data/Proxy.hs index ab89066cfa..38a43b0b0f 100644 --- a/libraries/base/Data/Proxy.hs +++ b/libraries/base/Data/Proxy.hs @@ -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 #-} diff --git a/libraries/base/Foreign/Storable.hs b/libraries/base/Foreign/Storable.hs index 74417413f2..41e2420380 100644 --- a/libraries/base/Foreign/Storable.hs +++ b/libraries/base/Foreign/Storable.hs @@ -32,8 +32,6 @@ module Foreign.Storable ) where -import Control.Monad ( liftM ) - #include "MachDeps.h" #include "HsBaseConfig.h" diff --git a/libraries/base/GHC/Base.lhs b/libraries/base/GHC/Base.lhs index 6a089ee432..3ee533d02a 100644 --- a/libraries/base/GHC/Base.lhs +++ b/libraries/base/GHC/Base.lhs @@ -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 (>>) #-} diff --git a/libraries/base/GHC/Conc/Sync.lhs b/libraries/base/GHC/Conc/Sync.lhs index bd60ebd8fc..391d072a78 100644 --- a/libraries/base/GHC/Conc/Sync.lhs +++ b/libraries/base/GHC/Conc/Sync.lhs @@ -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. diff --git a/libraries/base/GHC/Event/Array.hs b/libraries/base/GHC/Event/Array.hs index 30dbd77f5b..3626387669 100644 --- a/libraries/base/GHC/Event/Array.hs +++ b/libraries/base/GHC/Event/Array.hs @@ -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 diff --git a/libraries/base/GHC/Event/EPoll.hsc b/libraries/base/GHC/Event/EPoll.hsc index b808b21e96..298f450096 100644 --- a/libraries/base/GHC/Event/EPoll.hsc +++ b/libraries/base/GHC/Event/EPoll.hsc @@ -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_) diff --git a/libraries/base/GHC/Event/Internal.hs b/libraries/base/GHC/Event/Internal.hs index a4c2e10d32..fcd7886a20 100644 --- a/libraries/base/GHC/Event/Internal.hs +++ b/libraries/base/GHC/Event/Internal.hs @@ -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 diff --git a/libraries/base/GHC/Event/Manager.hs b/libraries/base/GHC/Event/Manager.hs index d55d5b1193..1dbe036e0e 100644 --- a/libraries/base/GHC/Event/Manager.hs +++ b/libraries/base/GHC/Event/Manager.hs @@ -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) diff --git a/libraries/base/GHC/Event/Poll.hsc b/libraries/base/GHC/Event/Poll.hsc index 2ed25bec8b..ad2a96f56f 100644 --- a/libraries/base/GHC/Event/Poll.hsc +++ b/libraries/base/GHC/Event/Poll.hsc @@ -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) diff --git a/libraries/base/GHC/Event/TimerManager.hs b/libraries/base/GHC/Event/TimerManager.hs index f581330e25..7ba2aea8ff 100644 --- a/libraries/base/GHC/Event/TimerManager.hs +++ b/libraries/base/GHC/Event/TimerManager.hs @@ -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(..)) diff --git a/libraries/base/GHC/GHCi.hs b/libraries/base/GHC/GHCi.hs index f66d540574..c11863520c 100644 --- a/libraries/base/GHC/GHCi.hs +++ b/libraries/base/GHC/GHCi.hs @@ -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) diff --git a/libraries/base/GHC/ST.lhs b/libraries/base/GHC/ST.lhs index 5da8b0afed..6e922c0652 100644 --- a/libraries/base/GHC/ST.lhs +++ b/libraries/base/GHC/ST.lhs @@ -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 (>>) #-} diff --git a/libraries/base/Prelude.hs b/libraries/base/Prelude.hs index 687dcc6854..12fe189a8b 100644 --- a/libraries/base/Prelude.hs +++ b/libraries/base/Prelude.hs @@ -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 diff --git a/libraries/base/Text/ParserCombinators/ReadP.hs b/libraries/base/Text/ParserCombinators/ReadP.hs index a0e6e22062..afdaba5fbe 100644 --- a/libraries/base/Text/ParserCombinators/ReadP.hs +++ b/libraries/base/Text/ParserCombinators/ReadP.hs @@ -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!" -- --------------------------------------------------------------------------- diff --git a/libraries/base/Text/ParserCombinators/ReadPrec.hs b/libraries/base/Text/ParserCombinators/ReadPrec.hs index 235436c4d6..7098b50531 100644 --- a/libraries/base/Text/ParserCombinators/ReadPrec.hs +++ b/libraries/base/Text/ParserCombinators/ReadPrec.hs @@ -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 diff --git a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs index c4b0b77430..22b336ae81 100644 --- a/libraries/template-haskell/Language/Haskell/TH/PprLib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/PprLib.hs @@ -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 ) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 3172cbbced..650410841e 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -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) diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index bd3e3bc937..fad83c9c4b 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -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 diff --git a/testsuite/tests/deriving/should_fail/T3621.hs b/testsuite/tests/deriving/should_fail/T3621.hs index cd574eab81..36ac195f2b 100644 --- a/testsuite/tests/deriving/should_fail/T3621.hs +++ b/testsuite/tests/deriving/should_fail/T3621.hs @@ -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)) diff --git a/testsuite/tests/deriving/should_fail/T3621.stderr b/testsuite/tests/deriving/should_fail/T3621.stderr index b70fc33bda..67b949e754 100644 --- a/testsuite/tests/deriving/should_fail/T3621.stderr +++ b/testsuite/tests/deriving/should_fail/T3621.stderr @@ -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: diff --git a/testsuite/tests/deriving/should_run/drvrun019.hs b/testsuite/tests/deriving/should_run/drvrun019.hs index 3fd8ccf025..663fb38cd4 100644 --- a/testsuite/tests/deriving/should_run/drvrun019.hs +++ b/testsuite/tests/deriving/should_run/drvrun019.hs @@ -6,7 +6,7 @@ module Main where
newtype Wrap m a = Wrap { unWrap :: m a }
- deriving (Monad, Eq)
+ deriving (Functor, Applicative, Monad, Eq)
foo :: Int -> Wrap IO a -> Wrap IO ()
foo 0 a = return ()
diff --git a/testsuite/tests/ghci/scripts/T4175.stdout b/testsuite/tests/ghci/scripts/T4175.stdout index 29bca027ce..0cf5e9b5c0 100644 --- a/testsuite/tests/ghci/scripts/T4175.stdout +++ b/testsuite/tests/ghci/scripts/T4175.stdout @@ -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 diff --git a/testsuite/tests/ghci/scripts/T7627.stdout b/testsuite/tests/ghci/scripts/T7627.stdout index 46935eb0ea..9177bbd1e1 100644 --- a/testsuite/tests/ghci/scripts/T7627.stdout +++ b/testsuite/tests/ghci/scripts/T7627.stdout @@ -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) diff --git a/testsuite/tests/ghci/scripts/T8535.stdout b/testsuite/tests/ghci/scripts/T8535.stdout index 69efa29fc0..749a244f1f 100644 --- a/testsuite/tests/ghci/scripts/T8535.stdout +++ b/testsuite/tests/ghci/scripts/T8535.stdout @@ -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’ diff --git a/testsuite/tests/ghci/scripts/ghci011.stdout b/testsuite/tests/ghci/scripts/ghci011.stdout index 239ec07800..6b807f65c2 100644 --- a/testsuite/tests/ghci/scripts/ghci011.stdout +++ b/testsuite/tests/ghci/scripts/ghci011.stdout @@ -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’ diff --git a/testsuite/tests/ghci/scripts/ghci020.stdout b/testsuite/tests/ghci/scripts/ghci020.stdout index 700a212651..bd3a045871 100644 --- a/testsuite/tests/ghci/scripts/ghci020.stdout +++ b/testsuite/tests/ghci/scripts/ghci020.stdout @@ -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’ diff --git a/testsuite/tests/ghci/scripts/ghci025.stdout b/testsuite/tests/ghci/scripts/ghci025.stdout index 0d794be549..c1356de953 100644 --- a/testsuite/tests/ghci/scripts/ghci025.stdout +++ b/testsuite/tests/ghci/scripts/ghci025.stdout @@ -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 diff --git a/testsuite/tests/ghci/scripts/ghci027.stdout b/testsuite/tests/ghci/scripts/ghci027.stdout index 0d722c9d8c..47ec533084 100644 --- a/testsuite/tests/ghci/scripts/ghci027.stdout +++ b/testsuite/tests/ghci/scripts/ghci027.stdout @@ -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 diff --git a/testsuite/tests/indexed-types/should_fail/T4485.hs b/testsuite/tests/indexed-types/should_fail/T4485.hs index d7d4730362..afea7e6c41 100644 --- a/testsuite/tests/indexed-types/should_fail/T4485.hs +++ b/testsuite/tests/indexed-types/should_fail/T4485.hs @@ -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 ()) diff --git a/testsuite/tests/indexed-types/should_fail/T4485.stderr b/testsuite/tests/indexed-types/should_fail/T4485.stderr index 760cdf912d..320d9a5195 100644 --- a/testsuite/tests/indexed-types/should_fail/T4485.stderr +++ b/testsuite/tests/indexed-types/should_fail/T4485.stderr @@ -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’: diff --git a/testsuite/tests/indexed-types/should_fail/T7729.hs b/testsuite/tests/indexed-types/should_fail/T7729.hs index c542cf0550..bce63cd6e1 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729.hs +++ b/testsuite/tests/indexed-types/should_fail/T7729.hs @@ -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 diff --git a/testsuite/tests/indexed-types/should_fail/T7729.stderr b/testsuite/tests/indexed-types/should_fail/T7729.stderr index bb5a900c4c..c8814a412d 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7729.stderr @@ -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 diff --git a/testsuite/tests/indexed-types/should_fail/T7729a.hs b/testsuite/tests/indexed-types/should_fail/T7729a.hs index 53c163992b..ea36e32bd6 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729a.hs +++ b/testsuite/tests/indexed-types/should_fail/T7729a.hs @@ -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 diff --git a/testsuite/tests/indexed-types/should_fail/T7729a.stderr b/testsuite/tests/indexed-types/should_fail/T7729a.stderr index f90db0c491..907eb1d3b1 100644 --- a/testsuite/tests/indexed-types/should_fail/T7729a.stderr +++ b/testsuite/tests/indexed-types/should_fail/T7729a.stderr @@ -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) diff --git a/testsuite/tests/mdo/should_compile/mdo002.hs b/testsuite/tests/mdo/should_compile/mdo002.hs index dc33595590..432825749d 100644 --- a/testsuite/tests/mdo/should_compile/mdo002.hs +++ b/testsuite/tests/mdo/should_compile/mdo002.hs @@ -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 diff --git a/testsuite/tests/parser/should_compile/T7476/T7476.stdout b/testsuite/tests/parser/should_compile/T7476/T7476.stdout index d3ac31ba0d..f6e15d592e 100644 --- a/testsuite/tests/parser/should_compile/T7476/T7476.stdout +++ b/testsuite/tests/parser/should_compile/T7476/T7476.stdout @@ -1 +1 @@ -import Control.Applicative ( Applicative(pure), (<$>) ) +import Control.Applicative ( (<$>) ) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 16ab036882..e5964a1a8e 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -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) diff --git a/testsuite/tests/perf/haddock/all.T b/testsuite/tests/perf/haddock/all.T index d4dad1dbcb..46cad30564 100644 --- a/testsuite/tests/perf/haddock/all.T +++ b/testsuite/tests/perf/haddock/all.T @@ -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) diff --git a/testsuite/tests/polykinds/MonoidsFD.hs b/testsuite/tests/polykinds/MonoidsFD.hs index 7cf9a599dd..f093d77663 100644 --- a/testsuite/tests/polykinds/MonoidsFD.hs +++ b/testsuite/tests/polykinds/MonoidsFD.hs @@ -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 diff --git a/testsuite/tests/polykinds/MonoidsTF.hs b/testsuite/tests/polykinds/MonoidsTF.hs index f289912ec6..9097e53af2 100644 --- a/testsuite/tests/polykinds/MonoidsTF.hs +++ b/testsuite/tests/polykinds/MonoidsTF.hs @@ -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) diff --git a/testsuite/tests/rebindable/rebindable2.hs b/testsuite/tests/rebindable/rebindable2.hs index 7b626585ba..2f69ac8f3f 100644 --- a/testsuite/tests/rebindable/rebindable2.hs +++ b/testsuite/tests/rebindable/rebindable2.hs @@ -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)); diff --git a/testsuite/tests/rename/should_compile/T1954.hs b/testsuite/tests/rename/should_compile/T1954.hs index dfcb551830..210be399df 100644 --- a/testsuite/tests/rename/should_compile/T1954.hs +++ b/testsuite/tests/rename/should_compile/T1954.hs @@ -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) diff --git a/testsuite/tests/rename/should_compile/T7145a.hs b/testsuite/tests/rename/should_compile/T7145a.hs index 501915fcc5..8870689687 100644 --- a/testsuite/tests/rename/should_compile/T7145a.hs +++ b/testsuite/tests/rename/should_compile/T7145a.hs @@ -1,3 +1,2 @@ module T7145a ( Applicative(pure) ) where -import Control.Applicative ( Applicative(pure) ) diff --git a/testsuite/tests/rename/should_compile/T7145b.stderr b/testsuite/tests/rename/should_compile/T7145b.stderr index ed2333e8c4..d5f7c08558 100644 --- a/testsuite/tests/rename/should_compile/T7145b.stderr +++ b/testsuite/tests/rename/should_compile/T7145b.stderr @@ -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’ diff --git a/testsuite/tests/rename/should_fail/T2993.stderr b/testsuite/tests/rename/should_fail/T2993.stderr index 00679dd1a5..907a03447b 100644 --- a/testsuite/tests/rename/should_fail/T2993.stderr +++ b/testsuite/tests/rename/should_fail/T2993.stderr @@ -1,2 +1,4 @@ -T2993.hs:7:13: Not in scope: ‘<$>’ +T2993.hs:7:13: + Not in scope: ‘<$>’ + Perhaps you meant ‘<*>’ (imported from Prelude) diff --git a/testsuite/tests/simplCore/should_compile/T8848.stderr b/testsuite/tests/simplCore/should_compile/T8848.stderr index ba72af4566..ba77c4695e 100644 --- a/testsuite/tests/simplCore/should_compile/T8848.stderr +++ b/testsuite/tests/simplCore/should_compile/T8848.stderr @@ -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 <*> diff --git a/testsuite/tests/simplCore/should_compile/simpl017.hs b/testsuite/tests/simplCore/should_compile/simpl017.hs index 8c801a44f3..31ba7510d4 100644 --- a/testsuite/tests/simplCore/should_compile/simpl017.hs +++ b/testsuite/tests/simplCore/should_compile/simpl017.hs @@ -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 diff --git a/testsuite/tests/simplCore/should_compile/simpl017.stderr b/testsuite/tests/simplCore/should_compile/simpl017.stderr index 18b0a692ce..5d4dc582e6 100644 --- a/testsuite/tests/simplCore/should_compile/simpl017.stderr +++ b/testsuite/tests/simplCore/should_compile/simpl017.stderr @@ -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]’ diff --git a/testsuite/tests/simplCore/should_run/T3591.hs b/testsuite/tests/simplCore/should_run/T3591.hs index 491ba5fa17..6ec51a14d5 100644 --- a/testsuite/tests/simplCore/should_run/T3591.hs +++ b/testsuite/tests/simplCore/should_run/T3591.hs @@ -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) diff --git a/testsuite/tests/typecheck/should_compile/T4524.hs b/testsuite/tests/typecheck/should_compile/T4524.hs index c59ad08b0a..0b2e5387c5 100644 --- a/testsuite/tests/typecheck/should_compile/T4524.hs +++ b/testsuite/tests/typecheck/should_compile/T4524.hs @@ -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 diff --git a/testsuite/tests/typecheck/should_compile/T4969.hs b/testsuite/tests/typecheck/should_compile/T4969.hs index ce2e820f22..2bdd4a7e98 100644 --- a/testsuite/tests/typecheck/should_compile/T4969.hs +++ b/testsuite/tests/typecheck/should_compile/T4969.hs @@ -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 diff --git a/testsuite/tests/typecheck/should_compile/tc213.hs b/testsuite/tests/typecheck/should_compile/tc213.hs index 1f0b46449a..8034606cfb 100644 --- a/testsuite/tests/typecheck/should_compile/tc213.hs +++ b/testsuite/tests/typecheck/should_compile/tc213.hs @@ -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 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index ac958da73e..45c6e8b9c4 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -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, diff --git a/utils/haddock b/utils/haddock -Subproject aacaa91951b16f22e3ad54412974b81c32230a8 +Subproject 0cc5bc85e9fca92ab712b68a2ba2c0dd9d3d79f diff --git a/utils/hsc2hs b/utils/hsc2hs -Subproject 4a0f67704d89712f8493a0c7eccffa9243d6ef0 +Subproject af92e439369b7a3bb7d0476243af9b5622b7a48 |