Commit 1bfff7c3 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

CPP-reducing refactoring

This refactoring allows to drop `{-# LANGUAGE CPP #-}` from a couple of
modules again.
parent fada4c87
......@@ -263,7 +263,9 @@ library
Distribution.Compat.Binary.Generic
default-language: Haskell98
default-extensions: CPP
-- starting with GHC 7.0, rely on {-# LANGUAGE CPP #-} instead
if !impl(ghc >= 7.0)
default-extensions: CPP
-- Small, fast running tests.
test-suite unit-tests
......
{-# LANGUAGE CPP, FlexibleContexts #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DefaultSignatures #-}
-----------------------------------------------------------------------------
......@@ -53,13 +53,8 @@ import Data.Array.Unboxed
import GHC.Generics
--
-- This isn't available in older Hugs or older GHC
--
#if __GLASGOW_HASKELL__ >= 606
import qualified Data.Sequence as Seq
import qualified Data.Foldable as Fold
#endif
------------------------------------------------------------------------
......@@ -467,11 +462,6 @@ instance (Binary e) => Binary (IntMap.IntMap e) where
------------------------------------------------------------------------
-- Queues and Sequences
#if __GLASGOW_HASKELL__ >= 606
--
-- This is valid Hugs, but you need the most recent Hugs
--
instance (Binary e) => Binary (Seq.Seq e) where
put s = put (Seq.length s) >> Fold.mapM_ put s
get = do n <- get :: Get Int
......@@ -481,8 +471,6 @@ instance (Binary e) => Binary (Seq.Seq e) where
x <- g
rep (xs Seq.|> x) (n-1) g
#endif
------------------------------------------------------------------------
-- Floating point
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.ReadP
......@@ -72,10 +71,7 @@ module Distribution.Compat.ReadP
import Control.Monad( MonadPlus(..), liftM, liftM2, replicateM, ap, (>=>) )
import Data.Char (isSpace)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative (Alternative(empty, (<|>)))
import Control.Applicative as AP (Applicative(..), Alternative(empty, (<|>)))
infixr 5 +++, <++
......@@ -96,11 +92,11 @@ instance Functor (P s) where
fmap = liftM
instance Applicative (P s) where
pure = return
pure x = Result x Fail
(<*>) = ap
instance Monad (P s) where
return x = Result x Fail
return = AP.pure
(Get f) >>= k = Get (f >=> k)
(Look f) >>= k = Look (f >=> k)
......@@ -155,11 +151,11 @@ instance Functor (Parser r s) where
fmap h (R f) = R (\k -> f (k . h))
instance Applicative (Parser r s) where
pure = return
pure x = R (\k -> k x)
(<*>) = ap
instance Monad (Parser r s) where
return x = R (\k -> k x)
return = AP.pure
fail _ = R (const Fail)
R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
......@@ -15,9 +14,7 @@ module Distribution.Lex (
) where
import Data.Char (isSpace)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Monoid as Mon
newtype DList a = DList ([a] -> [a])
......@@ -27,7 +24,7 @@ runDList (DList run) = run []
singleton :: a -> DList a
singleton a = DList (a:)
instance Monoid (DList a) where
instance Mon.Monoid (DList a) where
mempty = DList id
DList a `mappend` DList b = DList (a . b)
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
......@@ -115,14 +114,11 @@ import Data.Data (Data)
import Data.Foldable (traverse_)
import Data.List (nub, intercalate)
import Data.Maybe (fromMaybe, maybeToList)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative((<*>), pure))
import Data.Monoid (Monoid(mempty, mappend))
import Data.Foldable (Foldable(foldMap))
import Data.Traversable (Traversable(traverse))
#endif
import Data.Monoid as Mon (Monoid(..))
import Data.Foldable as Fold (Foldable(foldMap))
import Data.Traversable as Trav (Traversable(traverse))
import Data.Typeable ( Typeable )
import Control.Applicative (Alternative(..))
import Control.Applicative as AP (Alternative(..), Applicative(..))
import Control.Monad (MonadPlus(mplus,mzero), ap)
import GHC.Generics (Generic)
import Text.PrettyPrint as Disp
......@@ -324,7 +320,7 @@ instance Binary SetupBuildInfo
instance Monoid SetupBuildInfo where
mempty = SetupBuildInfo {
setupDepends = mempty
setupDepends = Mon.mempty
}
mappend a b = SetupBuildInfo {
setupDepends = combine setupDepends
......@@ -1193,23 +1189,23 @@ instance Functor Condition where
instance Foldable Condition where
f `foldMap` Var c = f c
_ `foldMap` Lit _ = mempty
f `foldMap` CNot c = foldMap f c
f `foldMap` CNot c = Fold.foldMap f c
f `foldMap` COr c d = foldMap f c `mappend` foldMap f d
f `foldMap` CAnd c d = foldMap f c `mappend` foldMap f d
instance Traversable Condition where
f `traverse` Var c = Var `fmap` f c
_ `traverse` Lit c = pure $ Lit c
f `traverse` CNot c = CNot `fmap` traverse f c
f `traverse` CNot c = CNot `fmap` Trav.traverse f c
f `traverse` COr c d = COr `fmap` traverse f c <*> traverse f d
f `traverse` CAnd c d = CAnd `fmap` traverse f c <*> traverse f d
instance Applicative Condition where
pure = return
pure = Var
(<*>) = ap
instance Monad Condition where
return = Var
return = AP.pure
-- Terminating cases
(>>=) (Lit x) _ = Lit x
(>>=) (Var x) f = f x
......
{-# LANGUAGE CPP #-}
-- -fno-warn-deprecations for use of Map.foldWithKey
{-# OPTIONS_GHC -fno-warn-deprecations #-}
-----------------------------------------------------------------------------
......@@ -60,9 +59,7 @@ import Data.Char ( isAlphaNum )
import Data.Maybe ( mapMaybe, maybeToList )
import Data.Map ( Map, fromListWith, toList )
import qualified Data.Map as Map
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Monoid as Mon
------------------------------------------------------------------------------
......@@ -185,7 +182,7 @@ mapTreeData f = mapCondTree f id id
-- clarity.
data DepTestRslt d = DepOk | MissingDeps d
instance Monoid d => Monoid (DepTestRslt d) where
instance Monoid d => Mon.Monoid (DepTestRslt d) where
mempty = DepOk
mappend DepOk x = x
mappend x DepOk = x
......
......@@ -640,12 +640,14 @@ instance (Monad m) => Applicative (StT s m) where
#else
instance (Monad m, Functor m) => Applicative (StT s m) where
#endif
pure = return
pure a = StT (\s -> return (a,s))
(<*>) = ap
instance Monad m => Monad (StT s m) where
#if __GLASGOW_HASKELL__ < 710
return a = StT (\s -> return (a,s))
#endif
StT f >>= g = StT $ \s -> do
(a,s') <- f s
runStT (g a) s'
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.PackageDescription.PrettyPrint
......@@ -18,9 +17,7 @@ module Distribution.PackageDescription.PrettyPrint (
showGenericPackageDescription,
) where
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(mempty))
#endif
import Data.Monoid as Mon (Monoid(mempty))
import Distribution.PackageDescription
( Benchmark(..), BenchmarkInterface(..), benchmarkType
, TestSuite(..), TestSuiteInterface(..), testType
......@@ -236,9 +233,9 @@ ppIf' :: a -> (a -> Maybe a -> Doc)
-> Condition ConfVar
-> CondTree ConfVar [Dependency] a
-> Doc
ppIf' it ppIt c thenTree =
ppIf' it ppIt c thenTree =
if isEmpty thenDoc
then mempty
then Mon.mempty
else ppIfCondition c $$ nest indentWith thenDoc
where thenDoc = ppCondTree thenTree (if simplifiedPrinting then (Just it) else Nothing) ppIt
......@@ -249,7 +246,7 @@ ppIfElse :: a -> (a -> Maybe a -> Doc)
-> Doc
ppIfElse it ppIt c thenTree elseTree =
case (isEmpty thenDoc, isEmpty elseDoc) of
(True, True) -> mempty
(True, True) -> Mon.mempty
(False, True) -> ppIfCondition c $$ nest indentWith thenDoc
(True, False) -> ppIfCondition (cNot c) $$ nest indentWith elseDoc
(False, False) -> (ppIfCondition c $$ nest indentWith thenDoc)
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.ParseUtils
......@@ -62,9 +61,7 @@ import Data.Maybe (fromMaybe)
import Data.Tree as Tree (Tree(..), flatten)
import qualified Data.Map as Map
import Control.Monad (foldM, ap)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative as AP (Applicative(..))
import System.FilePath (normalise)
import Data.List (sortBy)
......@@ -98,12 +95,12 @@ instance Functor ParseResult where
fmap f (ParseOk ws x) = ParseOk ws $ f x
instance Applicative ParseResult where
pure = return
pure = ParseOk []
(<*>) = ap
instance Monad ParseResult where
return = ParseOk []
return = AP.pure
ParseFailed err >>= _ = ParseFailed err
ParseOk ws x >>= f = case f x of
ParseFailed err -> ParseFailed err
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.BuildTargets
......@@ -56,10 +55,7 @@ import Data.Either
( partitionEithers )
import qualified Data.Map as Map
import Control.Monad
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif
import Control.Applicative (Alternative(..))
import Control.Applicative as AP (Alternative(..), Applicative(..))
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
......@@ -798,11 +794,12 @@ instance Functor Match where
fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)
instance Applicative Match where
pure = return
pure a = ExactMatch 0 [a]
(<*>) = ap
instance Monad Match where
return a = ExactMatch 0 [a]
return = AP.pure
NoMatch d ms >>= _ = NoMatch d ms
ExactMatch d xs >>= f = addDepth d
$ foldr matchPlus matchZero (map f xs)
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.CCompiler
......@@ -47,10 +46,9 @@ module Distribution.Simple.CCompiler (
filenameCDialect
) where
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
import Data.Monoid as Mon
( Monoid(..) )
#endif
import System.FilePath
( takeExtension )
......@@ -64,7 +62,7 @@ data CDialect = C
| ObjectiveCPlusPlus
deriving (Eq, Show)
instance Monoid CDialect where
instance Mon.Monoid CDialect where
mempty = C
mappend C anything = anything
......
{-# LANGUAGE CPP, ExistentialQuantification #-}
{-# LANGUAGE ExistentialQuantification #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Command
......@@ -69,9 +69,7 @@ import Control.Monad
import Data.Char (isAlpha, toLower)
import Data.List (sortBy)
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Monoid as Mon
import qualified Distribution.GetOpt as GetOpt
import Distribution.Text
( Text(disp, parse) )
......@@ -176,7 +174,7 @@ reqArg' ad mkflag showflag =
reqArg ad (succeedReadE mkflag) showflag
-- | (String -> a) variant of "optArg"
optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
optArg' :: Mon.Monoid b => ArgPlaceHolder -> (Maybe String -> b)
-> (b -> [Maybe String])
-> MkOptDescr (a -> b) (b -> a -> a) a
optArg' ad mkflag showflag =
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.GHC
......@@ -108,9 +107,7 @@ import Data.Char ( isDigit, isSpace )
import Data.List
import qualified Data.Map as M ( fromList )
import Data.Maybe ( catMaybes )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
#endif
import Data.Monoid as Mon ( Monoid(..) )
import Data.Version ( showVersion )
import System.Directory
( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing )
......@@ -463,7 +460,7 @@ buildOrReplLib forRepl verbosity numJobs pkg_descr lbi lib clbi = do
cname = display $ PD.package $ localPkgDescr lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| forRepl = mempty -- HPC is not supported in ghci
| forRepl = Mon.mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname
| otherwise = mempty
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
-----------------------------------------------------------------------------
-- |
......@@ -70,9 +69,7 @@ import qualified Data.Map as M
import Data.Char ( isSpace )
import Data.Maybe ( fromMaybe, maybeToList, isJust )
import Control.Monad ( unless, when )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
#endif
import Data.Monoid as Mon ( Monoid(..) )
import System.Directory ( getDirectoryContents, getTemporaryDirectory )
import System.Environment ( getEnv )
import System.FilePath ( (</>), (<.>), takeExtension, takeDirectory )
......@@ -375,7 +372,7 @@ componentGhcOptions verbosity lbi bi clbi odir =
ghcOptCabal = toFlag True,
ghcOptComponentId = case clbi of
LibComponentLocalBuildInfo { componentCompatPackageKey = pk } -> toFlag pk
_ -> mempty,
_ -> Mon.mempty,
ghcOptSigOf = hole_insts,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
......
{-# LANGUAGE CPP #-}
module Distribution.Simple.GHCJS (
configure, getInstalledPackages, getPackageDBContents,
buildLib, buildExe,
......@@ -72,9 +71,7 @@ import Language.Haskell.Extension ( Extension(..)
import Control.Monad ( unless, when )
import Data.Char ( isSpace )
import qualified Data.Map as M ( fromList )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
#endif
import Data.Monoid as Mon ( Monoid(..) )
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>), takeExtension,
takeDirectory, replaceExtension,
......@@ -332,7 +329,7 @@ buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname
| otherwise = mempty
| otherwise = Mon.mempty
createDirectoryIfMissingVerbose verbosity True libTargetDir
-- TODO: do we need to put hs-boot files into place for mutually recursive
......
{-# LANGUAGE CPP #-}
module Distribution.Simple.HaskellSuite where
import Control.Monad
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Data.Maybe
import Data.Version
import qualified Data.Map as M (empty)
......@@ -106,7 +102,7 @@ getCompilerVersion verbosity prog = do
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)]
getExtensions verbosity prog = do
extStrs <-
lines <$>
lines `fmap`
rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]
return
[ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ]
......@@ -114,7 +110,7 @@ getExtensions verbosity prog = do
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)]
getLanguages verbosity prog = do
langStrs <-
lines <$>
lines `fmap`
rawSystemStdout verbosity (programPath prog) ["--supported-languages"]
return
[ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ]
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.LHC
......@@ -87,12 +86,10 @@ import Language.Haskell.Extension
( Language(Haskell98), Extension(..), KnownExtension(..) )
import Control.Monad ( unless, when )
import Data.Monoid as Mon
import Data.List
import qualified Data.Map as M ( empty )
import Data.Maybe ( catMaybes )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
#endif
import System.Directory ( removeFile, renameFile,
getDirectoryContents, doesFileExist,
getTemporaryDirectory )
......@@ -230,7 +227,7 @@ getInstalledPackages verbosity packagedbs conf = do
pkgss <- getInstalledPackages' lhcPkg verbosity packagedbs conf
let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)
| (_, pkgs) <- pkgss ]
return $! (mconcat indexes)
return $! (Mon.mconcat indexes)
where
-- On Windows, various fields have $topdir/foo rather than full
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
......@@ -70,9 +69,7 @@ import qualified Data.Graph as Graph
import Data.List as List
( null, foldl', sort
, groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid(..))
#endif
import Data.Monoid as Mon (Monoid(..))
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (isNothing, fromMaybe)
......@@ -132,7 +129,7 @@ instance HasComponentId a => Monoid (PackageIndex a) where
mempty = PackageIndex Map.empty Map.empty
mappend = merge
--save one mappend with empty in the common case:
mconcat [] = mempty
mconcat [] = Mon.mempty
mconcat xs = foldr1 mappend xs
invariant :: HasComponentId a => PackageIndex a -> Bool
......
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Simple.Program.Db
......@@ -74,9 +72,6 @@ import Distribution.Verbosity
( Verbosity )
import Distribution.Compat.Binary (Binary(..))
#if __GLASGOW_HASKELL__ < 710
import Data.Functor ((<$>))
#endif
import Data.List
( foldl' )
import Data.Maybe
......@@ -466,5 +461,5 @@ requireProgramVersion :: Verbosity -> Program -> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion verbosity prog range programDb =
join $ either die return <$>
join $ either die return `fmap`
lookupProgramVersion verbosity prog range programDb
{-# LANGUAGE CPP #-}
module Distribution.Simple.Program.GHC (
GhcOptions(..),
GhcMode(..),
......@@ -28,9 +27,7 @@ import Distribution.Utils.NubList ( NubListR, fromNubListR )
import Language.Haskell.Extension ( Language(..), Extension(..) )
import qualified Data.Map as M
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.Monoid as Mon
import Data.List ( intercalate )
-- | A structured set of GHC options/flags
......@@ -494,7 +491,7 @@ packageDbArgs implInfo
instance Monoid GhcOptions where
mempty = GhcOptions {
ghcOptMode = mempty,
ghcOptMode = Mon.mempty,
ghcOptExtra = mempty,
ghcOptExtraDefault = mempty,
ghcOptInputFiles = mempty,
......@@ -503,7 +500,7 @@ instance Monoid GhcOptions where
ghcOptOutputDynFile = mempty,
ghcOptSourcePathClear = mempty,
ghcOptSourcePath = mempty,
ghcOptComponentId = mempty,
ghcOptComponentId = mempty,
ghcOptPackageDBs = mempty,
ghcOptPackages = mempty,
ghcOptHideAllPackages = mempty,
......
......@@ -30,8 +30,6 @@
-- read and written from files. This would allow us to save configure flags in
-- config files.
{-# LANGUAGE CPP #-}
module Distribution.Simple.Setup (
GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
......
{-# LANGUAGE CPP #-}
module Distribution.Utils.NubList
( NubList -- opaque
, toNubList -- smart construtor
......@@ -12,9 +11,8 @@ module Distribution.Utils.NubList
) where
import Distribution.Compat.Binary
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Prelude
import Distribution.Simple.Utils (ordNub, listUnion, ordNubRight, listUnionRight)
......