Commit d94de872 authored by Austin Seipp's avatar Austin Seipp
Browse files

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: default avatarAustin 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
parent fdfe6c0e
......@@ -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)
......
......@@ -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]
......
......@@ -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)
......
......@@ -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
......
......@@ -53,6 +53,10 @@ import DynFlags
import Data.Maybe
import Control.Monad
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<*>))
#endif
------------------------------------------------------------------------
-- Top-level bindings
------------------------------------------------------------------------
......
......@@ -48,6 +48,10 @@ import Outputable
import Control.Monad (when,void)
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding ((<*>))
#endif
------------------------------------------------------------------------
-- cgExpr: the main function
------------------------------------------------------------------------
......
{-# 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
......
......@@ -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
......
......@@ -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)
......
......@@ -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 )
......
......@@ -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
......
......@@ -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)
......
......@@ -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
--------------
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment