Commit d4fd273b authored by Oleg Grenrus's avatar Oleg Grenrus

Make cabal-install compilable with NoImplicitPrelude

I.e. find out where we don't yet
used `Distribution.Client.Compat.Prelude`.

- If the module is small I added direct `Prelude` imports.
- Add Exception, deepseq stuff to Cabal Prelude
- Add Parsec, Pretty and Verbosity to Client Prelude
- use for, for_, traverse and traverse_ (removes need for Control.Monad)
parent a4f20826
......@@ -43,11 +43,8 @@ import Distribution.Utils.LogProgress
import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Traversable
( mapM )
import Distribution.Pretty (pretty)
import Text.PrettyPrint
import Data.Either
import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes)
-- | A linked component is a component that has been mix-in linked, at
-- which point we have determined how all the dependencies of the
......@@ -187,19 +184,19 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
m_u <- convertModule (OpenModule this_uid m)
return (Map.singleton m [WithSource (from m) m_u], Map.empty)
-- Handle 'exposed-modules'
exposed_mod_shapes_u <- mapM (convertMod FromExposedModules) src_provs
exposed_mod_shapes_u <- traverse (convertMod FromExposedModules) src_provs
-- Handle 'other-modules'
other_mod_shapes_u <- mapM (convertMod FromOtherModules) src_hidden
other_mod_shapes_u <- traverse (convertMod FromOtherModules) src_hidden
-- Handle 'signatures'
let convertReq :: ModuleName -> UnifyM s (ModuleScopeU s)
convertReq req = do
req_u <- convertModule (OpenModuleVar req)
return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])
req_shapes_u <- mapM convertReq src_reqs
req_shapes_u <- traverse convertReq src_reqs
-- Handle 'mixins'
(incl_shapes_u, all_includes_u) <- fmap unzip (mapM convertInclude unlinked_includes)
(incl_shapes_u, all_includes_u) <- fmap unzip (traverse convertInclude unlinked_includes)
failIfErrs -- Prevent error cascade
-- Mix-in link everything! mixLink is the real workhorse.
......@@ -208,7 +205,7 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
++ req_shapes_u
++ incl_shapes_u
-- src_reqs_u <- mapM convertReq src_reqs
-- src_reqs_u <- traverse convertReq src_reqs
-- Read out all the final results by converting back
-- into a pure representation.
let convertIncludeU (ComponentInclude dep_aid rns i) = do
......@@ -220,8 +217,8 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
})
shape <- convertModuleScopeU shape_u
let (includes_u, sig_includes_u) = partitionEithers all_includes_u
incls <- mapM convertIncludeU includes_u
sig_incls <- mapM convertIncludeU sig_includes_u
incls <- traverse convertIncludeU includes_u
sig_incls <- traverse convertIncludeU sig_includes_u
return (shape, incls, sig_incls)
let isNotLib (CLib _) = False
......
......@@ -39,9 +39,6 @@ import Distribution.ModuleName
import Distribution.Package
import Distribution.Simple.Utils
import qualified Control.Applicative as A
import qualified Data.Traversable as T
import Control.Monad
import Text.PrettyPrint
import qualified Data.Map as Map
......@@ -198,14 +195,14 @@ instance Functor InstM where
fmap f (InstM m) = InstM $ \s -> let (x, s') = m s
in (f x, s')
instance A.Applicative InstM where
instance Applicative InstM where
pure a = InstM $ \s -> (a, s)
InstM f <*> InstM x = InstM $ \s -> let (f', s') = f s
(x', s'') = x s'
in (f' x', s'')
instance Monad InstM where
return = A.pure
return = pure
InstM m >>= f = InstM $ \s -> let (x, s') = m s
in runInstM (f x) s'
......@@ -259,20 +256,20 @@ toReadyComponents pid_map subst0 comps
-> InstM (Maybe ReadyComponent)
instantiateComponent uid cid insts
| Just lc <- Map.lookup cid cmap = do
provides <- T.mapM (substModule insts) (modShapeProvides (lc_shape lc))
provides <- traverse (substModule insts) (modShapeProvides (lc_shape lc))
-- NB: lc_sig_includes is omitted here, because we don't
-- need them to build
includes <- forM (lc_includes lc) $ \ci -> do
uid' <- substUnitId insts (ci_id ci)
return ci { ci_ann_id = fmap (const uid') (ci_ann_id ci) }
exe_deps <- mapM (substExeDep insts) (lc_exe_deps lc)
exe_deps <- traverse (substExeDep insts) (lc_exe_deps lc)
s <- InstM $ \s -> (s, s)
let getDep (Module dep_def_uid _)
| let dep_uid = unDefUnitId dep_def_uid
-- Lose DefUnitId invariant for rc_depends
= [(dep_uid,
fromMaybe err_pid $
Map.lookup dep_uid pid_map A.<|>
Map.lookup dep_uid pid_map <|>
fmap rc_munged_id (join (Map.lookup dep_uid s)))]
where
err_pid = MungedPackageId
......@@ -313,7 +310,7 @@ toReadyComponents pid_map subst0 comps
substSubst :: Map ModuleName Module
-> Map ModuleName OpenModule
-> InstM (Map ModuleName Module)
substSubst subst insts = T.mapM (substModule subst) insts
substSubst subst insts = traverse (substModule subst) insts
substModule :: Map ModuleName Module -> OpenModule -> InstM Module
substModule subst (OpenModuleVar mod_name)
......@@ -346,7 +343,7 @@ toReadyComponents pid_map subst0 comps
then do uid' <- substUnitId Map.empty (ci_id ci)
return $ ci { ci_ann_id = fmap (const (DefiniteUnitId uid')) (ci_ann_id ci) }
else return ci
exe_deps <- mapM (substExeDep Map.empty) (lc_exe_deps lc)
exe_deps <- traverse (substExeDep Map.empty) (lc_exe_deps lc)
let indefc = IndefiniteComponent {
indefc_requires = map fst (lc_insts lc),
indefc_provides = modShapeProvides (lc_shape lc),
......
......@@ -70,7 +70,6 @@ import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.Traversable as T
import Text.PrettyPrint
-- TODO: more detailed trace output on high verbosity would probably
......@@ -321,7 +320,7 @@ convertUnitId' _ (DefiniteUnitId uid) =
convertUnitId' stk (IndefFullUnitId cid insts) = do
fs <- fmap unify_uniq getUnifEnv
x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later
insts_u <- T.forM insts $ convertModule' (extendMuEnv stk x)
insts_u <- for insts $ convertModule' (extendMuEnv stk x)
u <- readUnifRef fs
writeUnifRef fs (u+1)
y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)
......@@ -359,11 +358,11 @@ type ModuleSubstU s = Map ModuleName (ModuleU s)
-- | Conversion of 'ModuleSubst' to 'ModuleSubstU'
convertModuleSubst :: Map ModuleName OpenModule -> UnifyM s (Map ModuleName (ModuleU s))
convertModuleSubst = T.mapM convertModule
convertModuleSubst = traverse convertModule
-- | Conversion of 'ModuleSubstU' to 'ModuleSubst'
convertModuleSubstU :: ModuleSubstU s -> UnifyM s OpenModuleSubst
convertModuleSubstU = T.mapM convertModuleU
convertModuleSubstU = traverse convertModuleU
-----------------------------------------------------------------------
-- Conversion from the unifiable data types
......@@ -400,7 +399,7 @@ convertUnitIdU' stk uid_u = do
failWith (text "Unsupported mutually recursive unit identifier")
-- return (UnitIdVar i)
Nothing -> do
insts <- T.forM insts_u $ convertModuleU' (extendMooEnv stk u)
insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)
return (IndefFullUnitId cid insts)
convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
......@@ -615,11 +614,11 @@ convertModuleScopeU (provs_u, reqs_u) = do
-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'
convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
convertModuleProvides = T.mapM (mapM (T.mapM convertModule))
convertModuleProvides = traverse (traverse (traverse convertModule))
-- | Convert a 'ModuleProvidesU' to a 'ModuleProvides'
convertModuleProvidesU :: ModuleProvidesU s -> UnifyM s ModuleProvides
convertModuleProvidesU = T.mapM (mapM (T.mapM convertModuleU))
convertModuleProvidesU = traverse (traverse (traverse convertModuleU))
convertModuleRequires :: ModuleRequires -> UnifyM s (ModuleRequiresU s)
convertModuleRequires = convertModuleProvides
......
......@@ -14,13 +14,11 @@ module Distribution.Compat.CopyFile (
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Exception
#ifndef mingw32_HOST_OS
import Distribution.Compat.Internal.TempFile
import Control.Exception
( bracketOnError, throwIO )
( bracketOnError )
import qualified Data.ByteString.Lazy as BSL
import System.IO.Error
( ioeSetLocation )
......@@ -43,8 +41,6 @@ import Foreign.C
#else /* else mingw32_HOST_OS */
import Control.Exception
( throwIO )
import qualified Data.ByteString.Lazy as BSL
import System.IO.Error
( ioeSetLocation )
......
......@@ -6,22 +6,32 @@ module Distribution.Compat.Exception (
displayException,
) where
#ifdef MIN_VERSION_base
#define MINVER_base_48 MIN_VERSION_base(4,8,0)
#else
#define MINVER_base_48 (__GLASGOW_HASKELL__ >= 710)
#endif
import System.Exit
import qualified Control.Exception as Exception
#if __GLASGOW_HASKELL__ >= 710
#if MINVER_base_48
import Control.Exception (displayException)
#endif
-- | Try 'IOException'.
tryIO :: IO a -> IO (Either Exception.IOException a)
tryIO = Exception.try
-- | Catch 'IOException'.
catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
catchIO = Exception.catch
-- | Catch 'ExitCode'
catchExit :: IO a -> (ExitCode -> IO a) -> IO a
catchExit = Exception.catch
#if __GLASGOW_HASKELL__ < 710
#if !MINVER_base_48
displayException :: Exception.Exception e => e -> String
displayException = show
#endif
......@@ -88,7 +88,6 @@ import Distribution.Compat.Prelude hiding (empty, lookup, null, toList)
import Prelude ()
import Data.Array ((!))
import Data.Either (partitionEithers)
import Data.Graph (SCC (..))
import Distribution.Utils.Structured (Structure (..), Structured (..))
......
......@@ -50,7 +50,6 @@ module Distribution.Compat.Lens (
import Prelude()
import Distribution.Compat.Prelude
import Control.Applicative (Const (..))
import Control.Monad.State.Class (MonadState (..), gets, modify)
import qualified Distribution.Compat.DList as DList
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
#ifdef MIN_VERSION_base
#define MINVER_base_411 MIN_VERSION_base(4,11,0)
......@@ -50,8 +50,12 @@ module Distribution.Compat.Prelude (
NonEmptySet,
Identity (..),
Proxy (..),
Const (..),
Void,
-- * Data.Either
partitionEithers,
-- * Data.Maybe
catMaybes, mapMaybe,
fromMaybe,
......@@ -64,6 +68,7 @@ module Distribution.Compat.Prelude (
intercalate, intersperse,
sort, sortBy,
nub, nubBy,
partition,
-- * Data.List.NonEmpty
NonEmpty((:|)), foldl1, foldr1,
......@@ -81,6 +86,12 @@ module Distribution.Compat.Prelude (
Traversable, traverse, sequenceA,
for,
-- * Data.Function
on,
-- * Data.Ord
comparing,
-- * Control.Arrow
first,
......@@ -89,6 +100,18 @@ module Distribution.Compat.Prelude (
unless, when,
ap, void,
foldM, filterM,
join, guard,
-- * Control.Exception
catch, throwIO, evaluate,
Exception (..), IOException, SomeException (..),
#if !MINVER_base_48
displayException,
#endif
tryIO, catchIO, catchExit,
-- * Control.DeepSeq
deepseq, force,
-- * Data.Char
isSpace, isDigit, isUpper, isAlpha, isAlphaNum,
......@@ -104,11 +127,19 @@ module Distribution.Compat.Prelude (
Int8, Int16, Int32, Int64,
-- * Text.PrettyPrint
(<<>>),
(<<>>), (Disp.<+>),
-- * System.Exit
ExitCode (..),
exitWith, exitSuccess, exitFailure,
-- * Text.Read
readMaybe,
-- * Debug.Trace (as deprecated functions)
traceShow, traceShowId,
) where
-- We also could hide few partial function
import Prelude as BasePrelude hiding
( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init
......@@ -128,51 +159,57 @@ import Prelude as BasePrelude hiding
#endif
)
-- AMP
#if !MINVER_base_48
import Control.Applicative (Applicative (..), (<$), (<$>))
import Distribution.Compat.Semigroup (Monoid (..))
import Data.Foldable (toList)
import Distribution.Compat.Semigroup (Monoid (..))
#else
import Data.Foldable (length, null, Foldable(toList))
import Data.Foldable (Foldable (toList), length, null)
#endif
import Data.Foldable (Foldable (foldMap, foldr), find, foldl', for_, traverse_, any, all)
import Data.Traversable (Traversable (traverse, sequenceA), for)
import Data.Foldable (Foldable (foldMap, foldr), all, any, find, foldl', for_, traverse_)
import Data.Traversable (Traversable (sequenceA, traverse), for)
import qualified Data.Foldable
-- Extra exports
import Control.Applicative (Alternative (..))
import Control.DeepSeq (NFData (..))
import Control.Applicative (Const (..))
import Control.Arrow (first)
import Control.DeepSeq (NFData (..), deepseq, force)
import Control.Exception (Exception (..), IOException, SomeException (..), catch, evaluate, throwIO)
import Control.Monad (MonadPlus (..), ap, filterM, foldM, guard, join, liftM, liftM2, unless, void, when)
import Data.Char (chr, isAlpha, isAlphaNum, isDigit, isSpace, isUpper, ord, toLower, toUpper)
import Data.Data (Data)
import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep)
import Distribution.Compat.Binary (Binary (..))
import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty)
import GHC.Generics (Generic, Rep(..),
V1, U1(U1), K1(unK1), M1(unM1),
(:*:)((:*:)), (:+:)(L1,R1))
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Functor.Identity (Identity (..))
import Data.Int (Int16, Int32, Int64, Int8)
import Data.List (intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr)
import Data.List.NonEmpty (NonEmpty ((:|)), head, init, last, tail)
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe, maybeToList)
import Data.Ord (comparing)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Control.Arrow (first)
import Control.Monad hiding (mapM)
import Data.Char
import Data.List (intercalate, intersperse, isPrefixOf,
isSuffixOf, nub, nubBy, sort, sortBy,
unfoldr)
import Data.List.NonEmpty (NonEmpty((:|)), head, tail, init, last)
import Data.Maybe
import Data.String (IsString (..))
import Data.Int
import Data.Word
import Data.Void (Void, absurd, vacuous)
import Data.Word (Word, Word16, Word32, Word64, Word8)
import Distribution.Compat.Binary (Binary (..))
import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty)
import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep)
import GHC.Generics ((:*:) ((:*:)), (:+:) (L1, R1), Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1)
import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith)
import Text.Read (readMaybe)
import qualified Text.PrettyPrint as Disp
import Distribution.Utils.Structured (Structured)
import Distribution.Compat.Exception
import Distribution.Compat.NonEmptySet (NonEmptySet)
import Distribution.Utils.Structured (Structured)
import qualified Debug.Trace
-- | New name for 'Text.PrettyPrint.<>'
(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc
......@@ -258,3 +295,18 @@ foldr1 = Data.Foldable.foldr1
{-# INLINE foldl1 #-}
foldl1 :: (a -> a -> a) -> NonEmpty a -> a
foldl1 = Data.Foldable.foldl1
-------------------------------------------------------------------------------
-- Trace
-------------------------------------------------------------------------------
-- Functions from Debug.Trace
-- but with DEPRECATED pragma, so -Werror will scream on them.
traceShowId :: Show a => a -> a
traceShowId x = Debug.Trace.traceShow x x
{-# DEPRECATED traceShowId "Don't leave me in the code" #-}
traceShow :: Show a => a -> b -> b
traceShow = Debug.Trace.traceShow
{-# DEPRECATED traceShow "Don't leave me in the code" #-}
{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}
-- Compatibility layer for GHC.ResponseFile
-- Implementation from base 4.12.0 is used.
-- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE
module Distribution.Compat.ResponseFile (expandResponse) where
import Prelude (mapM)
import Distribution.Compat.Prelude
import System.Exit
import System.FilePath
import System.IO (hPutStrLn, stderr)
import System.IO.Error
#if MIN_VERSION_base(4,12,0)
import GHC.ResponseFile (unescapeArgs)
#else
unescapeArgs :: String -> [String]
unescapeArgs = filter (not . null) . unescape
data Quoting = NoneQ | SngQ | DblQ
unescape :: String -> [String]
unescape args = reverse . map reverse $ go args NoneQ False [] []
where
-- n.b., the order of these cases matters; these are cribbed from gcc
-- case 1: end of input
go [] _q _bs a as = a:as
-- case 2: back-slash escape in progress
go (c:cs) q True a as = go cs q False (c:a) as
-- case 3: no back-slash escape in progress, but got a back-slash
go (c:cs) q False a as
| '\\' == c = go cs q True a as
-- case 4: single-quote escaping in progress
go (c:cs) SngQ False a as
| '\'' == c = go cs NoneQ False a as
| otherwise = go cs SngQ False (c:a) as
-- case 5: double-quote escaping in progress
go (c:cs) DblQ False a as
| '"' == c = go cs NoneQ False a as
| otherwise = go cs DblQ False (c:a) as
-- case 6: no escaping is in progress
go (c:cs) NoneQ False a as
| isSpace c = go cs NoneQ False [] (a:as)
| '\'' == c = go cs SngQ False a as
| '"' == c = go cs DblQ False a as
| otherwise = go cs NoneQ False (c:a) as
#endif
expandResponse :: [String] -> IO [String]
expandResponse = go recursionLimit "."
where
recursionLimit = 100
go :: Int -> FilePath -> [String] -> IO [String]
go n dir
| n >= 0 = fmap concat . mapM (expand n dir)
| otherwise = const $ hPutStrLn stderr "Error: response file recursion limit exceeded." >> exitFailure
expand :: Int -> FilePath -> String -> IO [String]
expand n dir arg@('@':f) = readRecursively n (dir </> f) `catchIOError` (const $ print "?" >> return [arg])
expand _n _dir x = return [x]
readRecursively :: Int -> FilePath -> IO [String]
readRecursively n f = go (n - 1) (takeDirectory f) =<< unescapeArgs <$> readFile f
{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}
-- Compatibility layer for GHC.ResponseFile
-- Implementation from base 4.12.0 is used.
-- http://hackage.haskell.org/package/base-4.12.0.0/src/LICENSE
module Distribution.Compat.ResponseFile (expandResponse) where
import Distribution.Compat.Prelude
import Prelude ()
import System.FilePath
import System.IO (hPutStrLn, stderr)
import System.IO.Error
#if MIN_VERSION_base(4,12,0)
import GHC.ResponseFile (unescapeArgs)
#else
unescapeArgs :: String -> [String]
unescapeArgs = filter (not . null) . unescape
data Quoting = NoneQ | SngQ | DblQ
unescape :: String -> [String]
unescape args = reverse . map reverse $ go args NoneQ False [] []
where
-- n.b., the order of these cases matters; these are cribbed from gcc
-- case 1: end of input
go [] _q _bs a as = a:as
-- case 2: back-slash escape in progress
go (c:cs) q True a as = go cs q False (c:a) as
-- case 3: no back-slash escape in progress, but got a back-slash