diff --git a/Cabal-syntax/Setup.hs b/Cabal-syntax/Setup.hs
index b55cb1695392fd9cdb3d8e148e455bc4cfbeb3e2..00bfe1fe44155953e866958b155c10612bb88a76 100644
--- a/Cabal-syntax/Setup.hs
+++ b/Cabal-syntax/Setup.hs
@@ -1,3 +1,4 @@
import Distribution.Simple
+
main :: IO ()
main = defaultMain
diff --git a/Cabal-syntax/src/Distribution/Backpack.hs b/Cabal-syntax/src/Distribution/Backpack.hs
index 2a2837ae7e6df2ea6524ea08eaddc5042ec30533..b30028bc41cbe513ece27aeee1d523a95666960a 100644
--- a/Cabal-syntax/src/Distribution/Backpack.hs
+++ b/Cabal-syntax/src/Distribution/Backpack.hs
@@ -1,51 +1,50 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE PatternGuards #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
-- | This module defines the core data types for Backpack. For more
-- details, see:
--
-- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-
-module Distribution.Backpack (
- -- * OpenUnitId
- OpenUnitId(..),
- openUnitIdFreeHoles,
- mkOpenUnitId,
+module Distribution.Backpack
+ ( -- * OpenUnitId
+ OpenUnitId (..)
+ , openUnitIdFreeHoles
+ , mkOpenUnitId
-- * DefUnitId
- DefUnitId,
- unDefUnitId,
- mkDefUnitId,
+ , DefUnitId
+ , unDefUnitId
+ , mkDefUnitId
-- * OpenModule
- OpenModule(..),
- openModuleFreeHoles,
+ , OpenModule (..)
+ , openModuleFreeHoles
-- * OpenModuleSubst
- OpenModuleSubst,
- dispOpenModuleSubst,
- dispOpenModuleSubstEntry,
- parsecOpenModuleSubst,
- parsecOpenModuleSubstEntry,
- openModuleSubstFreeHoles,
+ , OpenModuleSubst
+ , dispOpenModuleSubst
+ , dispOpenModuleSubstEntry
+ , parsecOpenModuleSubst
+ , parsecOpenModuleSubstEntry
+ , openModuleSubstFreeHoles
-- * Conversions to 'UnitId'
- abstractUnitId,
- hashModuleSubst,
-) where
+ , abstractUnitId
+ , hashModuleSubst
+ ) where
import Distribution.Compat.Prelude hiding (mod)
import Distribution.Parsec
import Distribution.Pretty
+import Text.PrettyPrint (hcat)
import Prelude ()
-import Text.PrettyPrint (hcat)
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
import Distribution.ModuleName
import Distribution.Types.ComponentId
@@ -81,52 +80,53 @@ import qualified Data.Set as Set
--
-- For more details see the Backpack spec
-- <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
---
-
data OpenUnitId
- -- | Identifies a component which may have some unfilled holes;
+ = -- | Identifies a component which may have some unfilled holes;
-- specifying its 'ComponentId' and its 'OpenModuleSubst'.
-- TODO: Invariant that 'OpenModuleSubst' is non-empty?
-- See also the Text instance.
- = IndefFullUnitId ComponentId OpenModuleSubst
- -- | Identifies a fully instantiated component, which has
+ IndefFullUnitId ComponentId OpenModuleSubst
+ | -- | Identifies a fully instantiated component, which has
-- been compiled and abbreviated as a hash. The embedded 'UnitId'
-- MUST NOT be for an indefinite component; an 'OpenUnitId'
-- is guaranteed not to have any holes.
- | DefiniteUnitId DefUnitId
+ DefiniteUnitId DefUnitId
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+
-- TODO: cache holes?
instance Binary OpenUnitId
instance Structured OpenUnitId
instance NFData OpenUnitId where
- rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
- rnf (DefiniteUnitId uid) = rnf uid
+ rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
+ rnf (DefiniteUnitId uid) = rnf uid
instance Pretty OpenUnitId where
- pretty (IndefFullUnitId cid insts)
- -- TODO: arguably a smart constructor to enforce invariant would be
- -- better
- | Map.null insts = pretty cid
- | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts)
- pretty (DefiniteUnitId uid) = pretty uid
+ pretty (IndefFullUnitId cid insts)
+ -- TODO: arguably a smart constructor to enforce invariant would be
+ -- better
+ | Map.null insts = pretty cid
+ | otherwise = pretty cid <<>> Disp.brackets (dispOpenModuleSubst insts)
+ pretty (DefiniteUnitId uid) = pretty uid
-- |
--
-- >>> eitherParsec "foobar" :: Either String OpenUnitId
---Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))
+-- Right (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "foobar"}))
--
-- >>> eitherParsec "foo[Str=text-1.2.3:Data.Text.Text]" :: Either String OpenUnitId
-- Right (IndefFullUnitId (ComponentId "foo") (fromList [(ModuleName "Str",OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "text-1.2.3"})) (ModuleName "Data.Text.Text"))]))
---
instance Parsec OpenUnitId where
- parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec
- where
- parseOpenUnitId = do
- cid <- parsec
- insts <- P.between (P.char '[') (P.char ']')
- parsecOpenModuleSubst
- return (IndefFullUnitId cid insts)
+ parsec = P.try parseOpenUnitId <|> fmap DefiniteUnitId parsec
+ where
+ parseOpenUnitId = do
+ cid <- parsec
+ insts <-
+ P.between
+ (P.char '[')
+ (P.char ']')
+ parsecOpenModuleSubst
+ return (IndefFullUnitId cid insts)
-- | Get the set of holes ('ModuleVar') embedded in a 'UnitId'.
openUnitIdFreeHoles :: OpenUnitId -> Set ModuleName
@@ -137,9 +137,9 @@ openUnitIdFreeHoles _ = Set.empty
-- is if the instantiation is provided.
mkOpenUnitId :: UnitId -> ComponentId -> OpenModuleSubst -> OpenUnitId
mkOpenUnitId uid cid insts =
- if Set.null (openModuleSubstFreeHoles insts)
- then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!
- else IndefFullUnitId cid insts
+ if Set.null (openModuleSubstFreeHoles insts)
+ then DefiniteUnitId (unsafeMkDefUnitId uid) -- invariant holds!
+ else IndefFullUnitId cid insts
-----------------------------------------------------------------------
-- DefUnitId
@@ -148,9 +148,12 @@ mkOpenUnitId uid cid insts =
-- with no holes.
mkDefUnitId :: ComponentId -> Map ModuleName Module -> DefUnitId
mkDefUnitId cid insts =
- unsafeMkDefUnitId (mkUnitId
- (unComponentId cid ++ maybe "" ("+"++) (hashModuleSubst insts)))
- -- impose invariant!
+ unsafeMkDefUnitId
+ ( mkUnitId
+ (unComponentId cid ++ maybe "" ("+" ++) (hashModuleSubst insts))
+ )
+
+-- impose invariant!
-----------------------------------------------------------------------
-- OpenModule
@@ -160,42 +163,41 @@ mkDefUnitId cid insts =
-- hole that needs to be filled in. Substitutions are over
-- module variables.
data OpenModule
- = OpenModule OpenUnitId ModuleName
- | OpenModuleVar ModuleName
+ = OpenModule OpenUnitId ModuleName
+ | OpenModuleVar ModuleName
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary OpenModule
instance Structured OpenModule
instance NFData OpenModule where
- rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
- rnf (OpenModuleVar mod_name) = rnf mod_name
+ rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
+ rnf (OpenModuleVar mod_name) = rnf mod_name
instance Pretty OpenModule where
- pretty (OpenModule uid mod_name) =
- hcat [pretty uid, Disp.text ":", pretty mod_name]
- pretty (OpenModuleVar mod_name) =
- hcat [Disp.char '<', pretty mod_name, Disp.char '>']
+ pretty (OpenModule uid mod_name) =
+ hcat [pretty uid, Disp.text ":", pretty mod_name]
+ pretty (OpenModuleVar mod_name) =
+ hcat [Disp.char '<', pretty mod_name, Disp.char '>']
-- |
--
-- >>> eitherParsec "Includes2-0.1.0.0-inplace-mysql:Database.MySQL" :: Either String OpenModule
-- Right (OpenModule (DefiniteUnitId (DefUnitId {unDefUnitId = UnitId "Includes2-0.1.0.0-inplace-mysql"})) (ModuleName "Database.MySQL"))
---
instance Parsec OpenModule where
- parsec = parsecModuleVar <|> parsecOpenModule
- where
- parsecOpenModule = do
- uid <- parsec
- _ <- P.char ':'
- mod_name <- parsec
- return (OpenModule uid mod_name)
-
- parsecModuleVar = do
- _ <- P.char '<'
- mod_name <- parsec
- _ <- P.char '>'
- return (OpenModuleVar mod_name)
+ parsec = parsecModuleVar <|> parsecOpenModule
+ where
+ parsecOpenModule = do
+ uid <- parsec
+ _ <- P.char ':'
+ mod_name <- parsec
+ return (OpenModule uid mod_name)
+
+ parsecModuleVar = do
+ _ <- P.char '<'
+ mod_name <- parsec
+ _ <- P.char '>'
+ return (OpenModuleVar mod_name)
-- | Get the set of holes ('ModuleVar') embedded in a 'Module'.
openModuleFreeHoles :: OpenModule -> Set ModuleName
@@ -214,8 +216,8 @@ type OpenModuleSubst = Map ModuleName OpenModule
-- | Pretty-print the entries of a module substitution, suitable
-- for embedding into a 'OpenUnitId' or passing to GHC via @--instantiate-with@.
dispOpenModuleSubst :: OpenModuleSubst -> Disp.Doc
-dispOpenModuleSubst subst
- = Disp.hcat
+dispOpenModuleSubst subst =
+ Disp.hcat
. Disp.punctuate Disp.comma
$ map dispOpenModuleSubstEntry (Map.toAscList subst)
@@ -227,19 +229,21 @@ dispOpenModuleSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v
--
-- @since 2.2
parsecOpenModuleSubst :: CabalParsing m => m OpenModuleSubst
-parsecOpenModuleSubst = fmap Map.fromList
- . flip P.sepBy (P.char ',')
- $ parsecOpenModuleSubstEntry
+parsecOpenModuleSubst =
+ fmap Map.fromList
+ . flip P.sepBy (P.char ',')
+ $ parsecOpenModuleSubstEntry
-- | Inverse to 'dispModSubstEntry'.
--
-- @since 2.2
parsecOpenModuleSubstEntry :: CabalParsing m => m (ModuleName, OpenModule)
parsecOpenModuleSubstEntry =
- do k <- parsec
- _ <- P.char '='
- v <- parsec
- return (k, v)
+ do
+ k <- parsec
+ _ <- P.char '='
+ v <- parsec
+ return (k, v)
-- | Get the set of holes ('ModuleVar') embedded in a 'OpenModuleSubst'.
-- This is NOT the domain of the substitution.
@@ -265,5 +269,7 @@ hashModuleSubst subst
| Map.null subst = Nothing
| otherwise =
Just . hashToBase62 $
- concat [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"
- | (mod_name, m) <- Map.toList subst]
+ concat
+ [ prettyShow mod_name ++ "=" ++ prettyShow m ++ "\n"
+ | (mod_name, m) <- Map.toList subst
+ ]
diff --git a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs
index a307bb4b0f3ac6548eea032e2de635af46fab85b..6290fa9166eb3f677356e011bf8c024fe6d4e81f 100644
--- a/Cabal-syntax/src/Distribution/CabalSpecVersion.hs
+++ b/Cabal-syntax/src/Distribution/CabalSpecVersion.hs
@@ -1,36 +1,38 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.CabalSpecVersion where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- | Different Cabal-the-spec versions.
--
-- We branch based on this at least in the parser.
---
data CabalSpecVersion
- = CabalSpecV1_0 -- ^ this is older than 'CabalSpecV1_2'
- | CabalSpecV1_2 -- ^ new syntax (sections)
- | CabalSpecV1_4
- | CabalSpecV1_6
- | CabalSpecV1_8
- | CabalSpecV1_10
- | CabalSpecV1_12
- -- 1.16 -- 1.14: no changes
- | CabalSpecV1_18
- | CabalSpecV1_20
- | CabalSpecV1_22
- | CabalSpecV1_24
- | CabalSpecV2_0
- | CabalSpecV2_2
- | CabalSpecV2_4
- | CabalSpecV3_0
- -- 3.2: no changes
- | CabalSpecV3_4
- | CabalSpecV3_6
- | CabalSpecV3_8
- -- 3.10: no changes
+ = -- | this is older than 'CabalSpecV1_2'
+ CabalSpecV1_0
+ | -- | new syntax (sections)
+ CabalSpecV1_2
+ | CabalSpecV1_4
+ | CabalSpecV1_6
+ | CabalSpecV1_8
+ | CabalSpecV1_10
+ | CabalSpecV1_12
+ | -- 1.16 -- 1.14: no changes
+ CabalSpecV1_18
+ | CabalSpecV1_20
+ | CabalSpecV1_22
+ | CabalSpecV1_24
+ | CabalSpecV2_0
+ | CabalSpecV2_2
+ | CabalSpecV2_4
+ | CabalSpecV3_0
+ | -- 3.2: no changes
+ CabalSpecV3_4
+ | CabalSpecV3_6
+ | CabalSpecV3_8
+ -- 3.10: no changes
deriving (Eq, Ord, Show, Read, Enum, Bounded, Typeable, Data, Generic)
instance Binary CabalSpecVersion
@@ -41,24 +43,24 @@ instance NFData CabalSpecVersion where rnf = genericRnf
--
-- @since 3.0.0.0
showCabalSpecVersion :: CabalSpecVersion -> String
-showCabalSpecVersion CabalSpecV3_8 = "3.8"
-showCabalSpecVersion CabalSpecV3_6 = "3.6"
-showCabalSpecVersion CabalSpecV3_4 = "3.4"
-showCabalSpecVersion CabalSpecV3_0 = "3.0"
-showCabalSpecVersion CabalSpecV2_4 = "2.4"
-showCabalSpecVersion CabalSpecV2_2 = "2.2"
-showCabalSpecVersion CabalSpecV2_0 = "2.0"
+showCabalSpecVersion CabalSpecV3_8 = "3.8"
+showCabalSpecVersion CabalSpecV3_6 = "3.6"
+showCabalSpecVersion CabalSpecV3_4 = "3.4"
+showCabalSpecVersion CabalSpecV3_0 = "3.0"
+showCabalSpecVersion CabalSpecV2_4 = "2.4"
+showCabalSpecVersion CabalSpecV2_2 = "2.2"
+showCabalSpecVersion CabalSpecV2_0 = "2.0"
showCabalSpecVersion CabalSpecV1_24 = "1.24"
showCabalSpecVersion CabalSpecV1_22 = "1.22"
showCabalSpecVersion CabalSpecV1_20 = "1.20"
showCabalSpecVersion CabalSpecV1_18 = "1.18"
showCabalSpecVersion CabalSpecV1_12 = "1.12"
showCabalSpecVersion CabalSpecV1_10 = "1.10"
-showCabalSpecVersion CabalSpecV1_8 = "1.8"
-showCabalSpecVersion CabalSpecV1_6 = "1.6"
-showCabalSpecVersion CabalSpecV1_4 = "1.4"
-showCabalSpecVersion CabalSpecV1_2 = "1.2"
-showCabalSpecVersion CabalSpecV1_0 = "1.0"
+showCabalSpecVersion CabalSpecV1_8 = "1.8"
+showCabalSpecVersion CabalSpecV1_6 = "1.6"
+showCabalSpecVersion CabalSpecV1_4 = "1.4"
+showCabalSpecVersion CabalSpecV1_2 = "1.2"
+showCabalSpecVersion CabalSpecV1_0 = "1.0"
cabalSpecLatest :: CabalSpecVersion
cabalSpecLatest = CabalSpecV3_8
@@ -66,49 +68,48 @@ cabalSpecLatest = CabalSpecV3_8
-- | Parse 'CabalSpecVersion' from version digits.
--
-- It may fail if for recent versions the version is not exact.
---
cabalSpecFromVersionDigits :: [Int] -> Maybe CabalSpecVersion
cabalSpecFromVersionDigits v
- | v == [3,8] = Just CabalSpecV3_8
- | v == [3,6] = Just CabalSpecV3_6
- | v == [3,4] = Just CabalSpecV3_4
- | v == [3,0] = Just CabalSpecV3_0
- | v == [2,4] = Just CabalSpecV2_4
- | v == [2,2] = Just CabalSpecV2_2
- | v == [2,0] = Just CabalSpecV2_0
- | v >= [1,25] = Nothing
- | v >= [1,23] = Just CabalSpecV1_24
- | v >= [1,21] = Just CabalSpecV1_22
- | v >= [1,19] = Just CabalSpecV1_20
- | v >= [1,17] = Just CabalSpecV1_18
- | v >= [1,11] = Just CabalSpecV1_12
- | v >= [1,9] = Just CabalSpecV1_10
- | v >= [1,7] = Just CabalSpecV1_8
- | v >= [1,5] = Just CabalSpecV1_6
- | v >= [1,3] = Just CabalSpecV1_4
- | v >= [1,1] = Just CabalSpecV1_2
- | otherwise = Just CabalSpecV1_0
+ | v == [3, 8] = Just CabalSpecV3_8
+ | v == [3, 6] = Just CabalSpecV3_6
+ | v == [3, 4] = Just CabalSpecV3_4
+ | v == [3, 0] = Just CabalSpecV3_0
+ | v == [2, 4] = Just CabalSpecV2_4
+ | v == [2, 2] = Just CabalSpecV2_2
+ | v == [2, 0] = Just CabalSpecV2_0
+ | v >= [1, 25] = Nothing
+ | v >= [1, 23] = Just CabalSpecV1_24
+ | v >= [1, 21] = Just CabalSpecV1_22
+ | v >= [1, 19] = Just CabalSpecV1_20
+ | v >= [1, 17] = Just CabalSpecV1_18
+ | v >= [1, 11] = Just CabalSpecV1_12
+ | v >= [1, 9] = Just CabalSpecV1_10
+ | v >= [1, 7] = Just CabalSpecV1_8
+ | v >= [1, 5] = Just CabalSpecV1_6
+ | v >= [1, 3] = Just CabalSpecV1_4
+ | v >= [1, 1] = Just CabalSpecV1_2
+ | otherwise = Just CabalSpecV1_0
-- | @since 3.4.0.0
cabalSpecToVersionDigits :: CabalSpecVersion -> [Int]
-cabalSpecToVersionDigits CabalSpecV3_8 = [3,8]
-cabalSpecToVersionDigits CabalSpecV3_6 = [3,6]
-cabalSpecToVersionDigits CabalSpecV3_4 = [3,4]
-cabalSpecToVersionDigits CabalSpecV3_0 = [3,0]
-cabalSpecToVersionDigits CabalSpecV2_4 = [2,4]
-cabalSpecToVersionDigits CabalSpecV2_2 = [2,2]
-cabalSpecToVersionDigits CabalSpecV2_0 = [2,0]
-cabalSpecToVersionDigits CabalSpecV1_24 = [1,24]
-cabalSpecToVersionDigits CabalSpecV1_22 = [1,22]
-cabalSpecToVersionDigits CabalSpecV1_20 = [1,20]
-cabalSpecToVersionDigits CabalSpecV1_18 = [1,18]
-cabalSpecToVersionDigits CabalSpecV1_12 = [1,12]
-cabalSpecToVersionDigits CabalSpecV1_10 = [1,10]
-cabalSpecToVersionDigits CabalSpecV1_8 = [1,8]
-cabalSpecToVersionDigits CabalSpecV1_6 = [1,6]
-cabalSpecToVersionDigits CabalSpecV1_4 = [1,4]
-cabalSpecToVersionDigits CabalSpecV1_2 = [1,2]
-cabalSpecToVersionDigits CabalSpecV1_0 = [1,0]
+cabalSpecToVersionDigits CabalSpecV3_8 = [3, 8]
+cabalSpecToVersionDigits CabalSpecV3_6 = [3, 6]
+cabalSpecToVersionDigits CabalSpecV3_4 = [3, 4]
+cabalSpecToVersionDigits CabalSpecV3_0 = [3, 0]
+cabalSpecToVersionDigits CabalSpecV2_4 = [2, 4]
+cabalSpecToVersionDigits CabalSpecV2_2 = [2, 2]
+cabalSpecToVersionDigits CabalSpecV2_0 = [2, 0]
+cabalSpecToVersionDigits CabalSpecV1_24 = [1, 24]
+cabalSpecToVersionDigits CabalSpecV1_22 = [1, 22]
+cabalSpecToVersionDigits CabalSpecV1_20 = [1, 20]
+cabalSpecToVersionDigits CabalSpecV1_18 = [1, 18]
+cabalSpecToVersionDigits CabalSpecV1_12 = [1, 12]
+cabalSpecToVersionDigits CabalSpecV1_10 = [1, 10]
+cabalSpecToVersionDigits CabalSpecV1_8 = [1, 8]
+cabalSpecToVersionDigits CabalSpecV1_6 = [1, 6]
+cabalSpecToVersionDigits CabalSpecV1_4 = [1, 4]
+cabalSpecToVersionDigits CabalSpecV1_2 = [1, 2]
+cabalSpecToVersionDigits CabalSpecV1_0 = [1, 0]
-- | What is the minimum Cabal library version which knows how handle
-- this spec version.
@@ -124,20 +125,20 @@ cabalSpecToVersionDigits CabalSpecV1_0 = [1,0]
--
-- @since 3.4.0.0
cabalSpecMinimumLibraryVersion :: CabalSpecVersion -> [Int]
-cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1,0]
+cabalSpecMinimumLibraryVersion CabalSpecV1_0 = [1, 0]
cabalSpecMinimumLibraryVersion csv = case cabalSpecToVersionDigits (pred csv) of
- [x,y] -> [x, y+1]
- xs -> xs
+ [x, y] -> [x, y + 1]
+ xs -> xs
specHasCommonStanzas :: CabalSpecVersion -> HasCommonStanzas
specHasCommonStanzas v =
- if v >= CabalSpecV2_2
+ if v >= CabalSpecV2_2
then HasCommonStanzas
else NoCommonStanzas
specHasElif :: CabalSpecVersion -> HasElif
specHasElif v =
- if v >= CabalSpecV2_2
+ if v >= CabalSpecV2_2
then HasElif
else NoElif
diff --git a/Cabal-syntax/src/Distribution/Compat/Binary.hs b/Cabal-syntax/src/Distribution/Compat/Binary.hs
index 919d72bebe587977a8f6d077dd68661a1d3b6791..8849fc13b1001729538f3d14f090d8247280c838 100644
--- a/Cabal-syntax/src/Distribution/Compat/Binary.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Binary.hs
@@ -2,10 +2,10 @@
{-# LANGUAGE PatternSynonyms #-}
module Distribution.Compat.Binary
- ( decodeOrFailIO
- , decodeFileOrFail'
- , module Data.Binary
- ) where
+ ( decodeOrFailIO
+ , decodeFileOrFail'
+ , module Data.Binary
+ ) where
import Control.Exception (ErrorCall (..), catch, evaluate)
import Data.ByteString.Lazy (ByteString)
@@ -18,6 +18,6 @@ decodeFileOrFail' f = either (Left . snd) Right `fmap` decodeFileOrFail f
decodeOrFailIO :: Binary a => ByteString -> IO (Either String a)
decodeOrFailIO bs =
- catch (evaluate (decode bs) >>= return . Right) handler
+ catch (evaluate (decode bs) >>= return . Right) handler
where
handler (ErrorCallWithLocation str _) = return $ Left str
diff --git a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs
index ebe771192496922d2b773b58243248264c643aba..3f0d44b0a0addbc8c453e235ffad87b5cdb00113 100644
--- a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs
+++ b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs
@@ -1,8 +1,12 @@
-{-# LANGUAGE GADTs #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fspec-constr -fspec-constr-count=8 #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compat.CharParsing
-- Copyright : (c) Edward Kmett 2011
@@ -15,28 +19,27 @@
-- Parsers for character streams
--
-- Originally in @parsers@ package.
---
------------------------------------------------------------------------------
module Distribution.Compat.CharParsing
- (
- -- * Combinators
- oneOf -- :: CharParsing m => [Char] -> m Char
- , noneOf -- :: CharParsing m => [Char] -> m Char
- , spaces -- :: CharParsing m => m ()
- , space -- :: CharParsing m => m Char
- , newline -- :: CharParsing m => m Char
- , tab -- :: CharParsing m => m Char
- , upper -- :: CharParsing m => m Char
- , lower -- :: CharParsing m => m Char
- , alphaNum -- :: CharParsing m => m Char
- , letter -- :: CharParsing m => m Char
- , digit -- :: CharParsing m => m Char
- , hexDigit -- :: CharParsing m => m Char
- , octDigit -- :: CharParsing m => m Char
+ ( -- * Combinators
+ oneOf -- :: CharParsing m => [Char] -> m Char
+ , noneOf -- :: CharParsing m => [Char] -> m Char
+ , spaces -- :: CharParsing m => m ()
+ , space -- :: CharParsing m => m Char
+ , newline -- :: CharParsing m => m Char
+ , tab -- :: CharParsing m => m Char
+ , upper -- :: CharParsing m => m Char
+ , lower -- :: CharParsing m => m Char
+ , alphaNum -- :: CharParsing m => m Char
+ , letter -- :: CharParsing m => m Char
+ , digit -- :: CharParsing m => m Char
+ , hexDigit -- :: CharParsing m => m Char
+ , octDigit -- :: CharParsing m => m Char
, satisfyRange -- :: CharParsing m => Char -> Char -> m Char
- -- * Class
- , CharParsing(..)
- -- * Cabal additions
+
+ -- * Class
+ , CharParsing (..)
+
+ -- * Cabal additions
, integral
, signedIntegral
, munch1
@@ -45,18 +48,18 @@ module Distribution.Compat.CharParsing
, module Distribution.Compat.Parsing
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Identity (IdentityT (..))
+import Control.Monad.Trans.RWS.Lazy as Lazy
+import Control.Monad.Trans.RWS.Strict as Strict
+import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
-import Control.Monad.Trans.RWS.Lazy as Lazy
-import Control.Monad.Trans.RWS.Strict as Strict
-import Control.Monad.Trans.Reader (ReaderT (..))
-import Control.Monad.Trans.Identity (IdentityT (..))
import Data.Char
import Data.Text (Text, unpack)
@@ -194,13 +197,13 @@ class Parsing m => CharParsing m where
instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -208,13 +211,13 @@ instance (CharParsing m, MonadPlus m) => CharParsing (Lazy.StateT s m) where
instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -222,13 +225,13 @@ instance (CharParsing m, MonadPlus m) => CharParsing (Strict.StateT s m) where
instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -236,13 +239,13 @@ instance (CharParsing m, MonadPlus m) => CharParsing (ReaderT e m) where
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -250,13 +253,13 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.WriterT w
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -264,13 +267,13 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.WriterT w m
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -278,13 +281,13 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Lazy.RWST r w s
instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w s m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
@@ -292,23 +295,23 @@ instance (CharParsing m, MonadPlus m, Monoid w) => CharParsing (Strict.RWST r w
instance (CharParsing m, MonadPlus m) => CharParsing (IdentityT m) where
satisfy = lift . satisfy
{-# INLINE satisfy #-}
- char = lift . char
+ char = lift . char
{-# INLINE char #-}
notChar = lift . notChar
{-# INLINE notChar #-}
anyChar = lift anyChar
{-# INLINE anyChar #-}
- string = lift . string
+ string = lift . string
{-# INLINE string #-}
text = lift . text
{-# INLINE text #-}
instance Parsec.Stream s m Char => CharParsing (Parsec.ParsecT s u m) where
- satisfy = Parsec.satisfy
- char = Parsec.char
+ satisfy = Parsec.satisfy
+ char = Parsec.char
notChar c = Parsec.satisfy (/= c)
- anyChar = Parsec.anyChar
- string = Parsec.string
+ anyChar = Parsec.anyChar
+ string = Parsec.string
-------------------------------------------------------------------------------
-- Our additions
@@ -329,7 +332,7 @@ integral = toNumber <$> some d <?> "integral"
f '7' = 7
f '8' = 8
f '9' = 9
- f _ = error "panic! integral"
+ f _ = error "panic! integral"
{-# INLINE integral #-}
-- | Accepts negative (starting with @-@) and positive (without sign) integral
diff --git a/Cabal-syntax/src/Distribution/Compat/DList.hs b/Cabal-syntax/src/Distribution/Compat/DList.hs
index 29cd1bb73c1f3a8ca4e9b1f17ce1cd1a115a8dae..e4168debf09ebc17b570496912e798f58277b276 100644
--- a/Cabal-syntax/src/Distribution/Compat/DList.hs
+++ b/Cabal-syntax/src/Distribution/Compat/DList.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compat.DList
-- Copyright : (c) Ben Gamari 2015-2019
@@ -9,18 +10,18 @@
-- Portability : portable
--
-- A very simple difference list.
-module Distribution.Compat.DList (
- DList,
- runDList,
- empty,
- singleton,
- fromList,
- toList,
- snoc,
-) where
-
+module Distribution.Compat.DList
+ ( DList
+ , runDList
+ , empty
+ , singleton
+ , fromList
+ , toList
+ , snoc
+ ) where
+
+import Distribution.Compat.Prelude hiding (empty, toList)
import Prelude ()
-import Distribution.Compat.Prelude hiding (toList, empty)
-- | Difference list.
newtype DList a = DList ([a] -> [a])
@@ -30,7 +31,7 @@ runDList (DList run) = run []
-- | Make 'DList' containing single element.
singleton :: a -> DList a
-singleton a = DList (a:)
+singleton a = DList (a :)
-- | @since 3.4.0.0
empty :: DList a
@@ -46,7 +47,7 @@ snoc :: DList a -> a -> DList a
snoc xs x = xs <> singleton x
instance Monoid (DList a) where
- mempty = empty
+ mempty = empty
mappend = (<>)
instance Semigroup (DList a) where
diff --git a/Cabal-syntax/src/Distribution/Compat/Exception.hs b/Cabal-syntax/src/Distribution/Compat/Exception.hs
index f274c35cd32f8696fb0e87dd87df397c2cbe46c8..e2a9419e5a5455fc56bbcf41af089be57b13e9fb 100644
--- a/Cabal-syntax/src/Distribution/Compat/Exception.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Exception.hs
@@ -1,14 +1,15 @@
{-# LANGUAGE CPP #-}
-module Distribution.Compat.Exception (
- catchIO,
- catchExit,
- tryIO,
- displayException,
+
+module Distribution.Compat.Exception
+ ( catchIO
+ , catchExit
+ , tryIO
+ , displayException
) where
-import System.Exit
-import qualified Control.Exception as Exception
import Control.Exception (displayException)
+import qualified Control.Exception as Exception
+import System.Exit
-- | Try 'IOException'.
tryIO :: IO a -> IO (Either Exception.IOException a)
diff --git a/Cabal-syntax/src/Distribution/Compat/Graph.hs b/Cabal-syntax/src/Distribution/Compat/Graph.hs
index 248c021585dc8566ab32a28c643846a4ddd6e1d0..c01f3162b2dfc59ecdd004f4c9ee11799ccd731a 100644
--- a/Cabal-syntax/src/Distribution/Compat/Graph.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Graph.hs
@@ -1,12 +1,16 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compat.Graph
-- Copyright : (c) Edward Z. Yang 2016
@@ -38,81 +42,87 @@
-- vertices of a graph using 'broken' (and should, e.g., to ensure that
-- a closure of a graph is well-formed.) It's possible to take a closed
-- subset of a broken graph and get a well-formed graph.
---
------------------------------------------------------------------------------
+module Distribution.Compat.Graph
+ ( -- * Graph type
+ Graph
+ , IsNode (..)
-module Distribution.Compat.Graph (
- -- * Graph type
- Graph,
- IsNode(..),
-- * Query
- null,
- size,
- member,
- lookup,
+ , null
+ , size
+ , member
+ , lookup
+
-- * Construction
- empty,
- insert,
- deleteKey,
- deleteLookup,
+ , empty
+ , insert
+ , deleteKey
+ , deleteLookup
+
-- * Combine
- unionLeft,
- unionRight,
+ , unionLeft
+ , unionRight
+
-- * Graph algorithms
- stronglyConnComp,
- SCC(..),
- cycles,
- broken,
- neighbors,
- revNeighbors,
- closure,
- revClosure,
- topSort,
- revTopSort,
+ , stronglyConnComp
+ , SCC (..)
+ , cycles
+ , broken
+ , neighbors
+ , revNeighbors
+ , closure
+ , revClosure
+ , topSort
+ , revTopSort
+
-- * Conversions
+
-- ** Maps
- toMap,
+ , toMap
+
-- ** Lists
- fromDistinctList,
- toList,
- keys,
+ , fromDistinctList
+ , toList
+ , keys
+
-- ** Sets
- keysSet,
+ , keysSet
+
-- ** Graphs
- toGraph,
+ , toGraph
+
-- * Node type
- Node(..),
- nodeValue,
-) where
+ , Node (..)
+ , nodeValue
+ ) where
import Distribution.Compat.Prelude hiding (empty, lookup, null, toList)
import Prelude ()
-import Data.Array ((!))
-import Data.Graph (SCC (..))
+import Data.Array ((!))
+import Data.Graph (SCC (..))
import Distribution.Utils.Structured (Structure (..), Structured (..))
-import qualified Data.Array as Array
-import qualified Data.Foldable as Foldable
-import qualified Data.Graph as G
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified Data.Tree as Tree
+import qualified Data.Array as Array
+import qualified Data.Foldable as Foldable
+import qualified Data.Graph as G
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Data.Tree as Tree
import qualified Distribution.Compat.Prelude as Prelude
-- | A graph of nodes @a@. The nodes are expected to have instance
-- of class 'IsNode'.
-data Graph a
- = Graph {
- graphMap :: !(Map (Key a) a),
- -- Lazily cached graph representation
- graphForward :: G.Graph,
- graphAdjoint :: G.Graph,
- graphVertexToNode :: G.Vertex -> a,
- graphKeyToVertex :: Key a -> Maybe G.Vertex,
- graphBroken :: [(a, [Key a])]
- }
- deriving (Typeable)
+data Graph a = Graph
+ { graphMap :: !(Map (Key a) a)
+ , -- Lazily cached graph representation
+ graphForward :: G.Graph
+ , graphAdjoint :: G.Graph
+ , graphVertexToNode :: G.Vertex -> a
+ , graphKeyToVertex :: Key a -> Maybe G.Vertex
+ , graphBroken :: [(a, [Key a])]
+ }
+ deriving (Typeable)
-- NB: Not a Functor! (or Traversable), because you need
-- to restrict Key a ~ Key b. We provide our own mapping
@@ -122,50 +132,51 @@ data Graph a
-- Map representation.
instance Show a => Show (Graph a) where
- show = show . toList
+ show = show . toList
instance (IsNode a, Read a, Show (Key a)) => Read (Graph a) where
- readsPrec d s = map (\(a,r) -> (fromDistinctList a, r)) (readsPrec d s)
+ readsPrec d s = map (\(a, r) -> (fromDistinctList a, r)) (readsPrec d s)
instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where
- put x = put (toList x)
- get = fmap fromDistinctList get
+ put x = put (toList x)
+ get = fmap fromDistinctList get
instance Structured a => Structured (Graph a) where
- structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)]
+ structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)]
instance (Eq (Key a), Eq a) => Eq (Graph a) where
- g1 == g2 = graphMap g1 == graphMap g2
+ g1 == g2 = graphMap g1 == graphMap g2
instance Foldable.Foldable Graph where
- fold = Foldable.fold . graphMap
- foldr f z = Foldable.foldr f z . graphMap
- foldl f z = Foldable.foldl f z . graphMap
- foldMap f = Foldable.foldMap f . graphMap
- foldl' f z = Foldable.foldl' f z . graphMap
- foldr' f z = Foldable.foldr' f z . graphMap
+ fold = Foldable.fold . graphMap
+ foldr f z = Foldable.foldr f z . graphMap
+ foldl f z = Foldable.foldl f z . graphMap
+ foldMap f = Foldable.foldMap f . graphMap
+ foldl' f z = Foldable.foldl' f z . graphMap
+ foldr' f z = Foldable.foldr' f z . graphMap
#ifdef MIN_VERSION_base
#if MIN_VERSION_base(4,8,0)
- length = Foldable.length . graphMap
- null = Foldable.null . graphMap
- toList = Foldable.toList . graphMap
- elem x = Foldable.elem x . graphMap
- maximum = Foldable.maximum . graphMap
- minimum = Foldable.minimum . graphMap
- sum = Foldable.sum . graphMap
- product = Foldable.product . graphMap
+ length = Foldable.length . graphMap
+ null = Foldable.null . graphMap
+ toList = Foldable.toList . graphMap
+ elem x = Foldable.elem x . graphMap
+ maximum = Foldable.maximum . graphMap
+ minimum = Foldable.minimum . graphMap
+ sum = Foldable.sum . graphMap
+ product = Foldable.product . graphMap
#endif
#endif
instance (NFData a, NFData (Key a)) => NFData (Graph a) where
- rnf Graph {
- graphMap = m,
- graphForward = gf,
- graphAdjoint = ga,
- graphVertexToNode = vtn,
- graphKeyToVertex = ktv,
- graphBroken = b
- } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m
+ rnf
+ Graph
+ { graphMap = m
+ , graphForward = gf
+ , graphAdjoint = ga
+ , graphVertexToNode = vtn
+ , graphKeyToVertex = ktv
+ , graphBroken = b
+ } = gf `seq` ga `seq` vtn `seq` ktv `seq` b `seq` rnf m
-- TODO: Data instance?
@@ -174,32 +185,32 @@ instance (NFData a, NFData (Key a)) => NFData (Graph a) where
-- type @'Key' a@; given a node we can determine its key ('nodeKey')
-- and the keys of its neighbors ('nodeNeighbors').
class Ord (Key a) => IsNode a where
- type Key a
- nodeKey :: a -> Key a
- nodeNeighbors :: a -> [Key a]
+ type Key a
+ nodeKey :: a -> Key a
+ nodeNeighbors :: a -> [Key a]
instance (IsNode a, IsNode b, Key a ~ Key b) => IsNode (Either a b) where
- type Key (Either a b) = Key a
- nodeKey (Left x) = nodeKey x
- nodeKey (Right x) = nodeKey x
- nodeNeighbors (Left x) = nodeNeighbors x
- nodeNeighbors (Right x) = nodeNeighbors x
+ type Key (Either a b) = Key a
+ nodeKey (Left x) = nodeKey x
+ nodeKey (Right x) = nodeKey x
+ nodeNeighbors (Left x) = nodeNeighbors x
+ nodeNeighbors (Right x) = nodeNeighbors x
-- | A simple, trivial data type which admits an 'IsNode' instance.
data Node k a = N a k [k]
- deriving (Show, Eq)
+ deriving (Show, Eq)
-- | Get the value from a 'Node'.
nodeValue :: Node k a -> a
nodeValue (N a _ _) = a
instance Functor (Node k) where
- fmap f (N a k ks) = N (f a) k ks
+ fmap f (N a k ks) = N (f a) k ks
instance Ord k => IsNode (Node k a) where
- type Key (Node k a) = k
- nodeKey (N _ k _) = k
- nodeNeighbors (N _ _ ks) = ks
+ type Key (Node k a) = k
+ nodeKey (N _ k _) = k
+ nodeNeighbors (N _ _ ks) = ks
-- TODO: Maybe introduce a typeclass for items which just
-- keys (so, Key associated type, and nodeKey method). But
@@ -241,8 +252,8 @@ deleteKey k g = fromMap (Map.delete k (toMap g))
-- value if it existed.
deleteLookup :: IsNode a => Key a -> Graph a -> (Maybe a, Graph a)
deleteLookup k g =
- let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g)
- in (r, fromMap m')
+ let (r, m') = Map.updateLookupWithKey (\_ _ -> Nothing) k (toMap g)
+ in (r, fromMap m')
-- Combining
@@ -266,18 +277,20 @@ stronglyConnComp g = map decode forest
where
forest = G.scc (graphForward g)
decode (Tree.Node v [])
- | mentions_itself v = CyclicSCC [graphVertexToNode g v]
- | otherwise = AcyclicSCC (graphVertexToNode g v)
+ | mentions_itself v = CyclicSCC [graphVertexToNode g v]
+ | otherwise = AcyclicSCC (graphVertexToNode g v)
decode other = CyclicSCC (dec other [])
- where dec (Tree.Node v ts) vs
- = graphVertexToNode g v : foldr dec vs ts
+ where
+ dec (Tree.Node v ts) vs =
+ graphVertexToNode g v : foldr dec vs ts
mentions_itself v = v `elem` (graphForward g ! v)
+
-- Implementation copied from 'stronglyConnCompR' in 'Data.Graph'.
-- | /Ω(V + E)/. Compute the cycles of a graph.
-- Requires amortized construction of graph.
cycles :: Graph a -> [[a]]
-cycles g = [ vs | CyclicSCC vs <- stronglyConnComp g ]
+cycles g = [vs | CyclicSCC vs <- stronglyConnComp g]
-- | /O(1)/. Return a list of nodes paired with their broken
-- neighbors (i.e., neighbor keys which are not in the graph).
@@ -289,15 +302,15 @@ broken g = graphBroken g
-- Requires amortized construction of graph.
neighbors :: Graph a -> Key a -> Maybe [a]
neighbors g k = do
- v <- graphKeyToVertex g k
- return (map (graphVertexToNode g) (graphForward g ! v))
+ v <- graphKeyToVertex g k
+ return (map (graphVertexToNode g) (graphForward g ! v))
-- | Lookup the immediate reverse neighbors from a key in the graph.
-- Requires amortized construction of graph.
revNeighbors :: Graph a -> Key a -> Maybe [a]
revNeighbors g k = do
- v <- graphKeyToVertex g k
- return (map (graphVertexToNode g) (graphAdjoint g ! v))
+ v <- graphKeyToVertex g k
+ return (map (graphVertexToNode g) (graphAdjoint g ! v))
-- | Compute the subgraph which is the closure of some set of keys.
-- Returns @Nothing@ if one (or more) keys are not present in
@@ -305,8 +318,8 @@ revNeighbors g k = do
-- Requires amortized construction of graph.
closure :: Graph a -> [Key a] -> Maybe [a]
closure g ks = do
- vs <- traverse (graphKeyToVertex g) ks
- return (decodeVertexForest g (G.dfs (graphForward g) vs))
+ vs <- traverse (graphKeyToVertex g) ks
+ return (decodeVertexForest g (G.dfs (graphForward g) vs))
-- | Compute the reverse closure of a graph from some set
-- of keys. Returns @Nothing@ if one (or more) keys are not present in
@@ -314,8 +327,8 @@ closure g ks = do
-- Requires amortized construction of graph.
revClosure :: Graph a -> [Key a] -> Maybe [a]
revClosure g ks = do
- vs <- traverse (graphKeyToVertex g) ks
- return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))
+ vs <- traverse (graphKeyToVertex g) ks
+ return (decodeVertexForest g (G.dfs (graphAdjoint g) vs))
flattenForest :: Tree.Forest a -> [a]
flattenForest = concatMap Tree.flatten
@@ -342,44 +355,49 @@ revTopSort g = map (graphVertexToNode g) $ G.topSort (graphAdjoint g)
-- instead. The values of the map are assumed to already
-- be in WHNF.
fromMap :: IsNode a => Map (Key a) a -> Graph a
-fromMap m
- = Graph { graphMap = m
- -- These are lazily computed!
- , graphForward = g
- , graphAdjoint = G.transposeG g
- , graphVertexToNode = vertex_to_node
- , graphKeyToVertex = key_to_vertex
- , graphBroken = broke
- }
+fromMap m =
+ Graph
+ { graphMap = m
+ , -- These are lazily computed!
+ graphForward = g
+ , graphAdjoint = G.transposeG g
+ , graphVertexToNode = vertex_to_node
+ , graphKeyToVertex = key_to_vertex
+ , graphBroken = broke
+ }
where
try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)
- (brokenEdges, edges)
- = unzip
- $ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
- | n <- ns ]
+ (brokenEdges, edges) =
+ unzip $
+ [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
+ | n <- ns
+ ]
broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)
g = Array.listArray bounds edges
- ns = Map.elems m -- sorted ascending
- vertices = zip (map nodeKey ns) [0..]
- vertex_map = Map.fromAscList vertices
+ ns = Map.elems m -- sorted ascending
+ vertices = zip (map nodeKey ns) [0 ..]
+ vertex_map = Map.fromAscList vertices
key_to_vertex k = Map.lookup k vertex_map
vertex_to_node vertex = nodeTable ! vertex
- nodeTable = Array.listArray bounds ns
+ nodeTable = Array.listArray bounds ns
bounds = (0, Map.size m - 1)
-- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
-fromDistinctList = fromMap
- . Map.fromListWith (\_ -> duplicateError)
- . map (\n -> n `seq` (nodeKey n, n))
+fromDistinctList =
+ fromMap
+ . Map.fromListWith (\_ -> duplicateError)
+ . map (\n -> n `seq` (nodeKey n, n))
where
- duplicateError n = error $ "Graph.fromDistinctList: duplicate key: "
- ++ show (nodeKey n)
+ duplicateError n =
+ error $
+ "Graph.fromDistinctList: duplicate key: "
+ ++ show (nodeKey n)
-- Map-like operations
diff --git a/Cabal-syntax/src/Distribution/Compat/Lens.hs b/Cabal-syntax/src/Distribution/Compat/Lens.hs
index 2320ab978a3b2c18a8eba95b54ec278bd04c6fb9..d31c9198889a963e84f07e041a1b38977f10d735 100644
--- a/Cabal-syntax/src/Distribution/Compat/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Lens.hs
@@ -1,78 +1,95 @@
{-# LANGUAGE RankNTypes #-}
+
-- | This module provides very basic lens functionality, without extra dependencies.
--
-- For the documentation of the combinators see <http://hackage.haskell.org/package/lens lens> package.
-- This module uses the same vocabulary.
-module Distribution.Compat.Lens (
- -- * Types
- Lens,
- Lens',
- Traversal,
- Traversal',
+module Distribution.Compat.Lens
+ ( -- * Types
+ Lens
+ , Lens'
+ , Traversal
+ , Traversal'
+
-- ** LensLike
- LensLike,
- LensLike',
+ , LensLike
+ , LensLike'
+
-- ** rank-1 types
- Getting,
- AGetter,
- ASetter,
- ALens,
- ALens',
+ , Getting
+ , AGetter
+ , ASetter
+ , ALens
+ , ALens'
+
-- * Getter
- view,
- use,
- getting,
+ , view
+ , use
+ , getting
+
-- * Setter
- set,
- over,
+ , set
+ , over
+
-- * Fold
- toDListOf,
- toListOf,
- toSetOf,
+ , toDListOf
+ , toListOf
+ , toSetOf
+
-- * Lens
- cloneLens,
- aview,
+ , cloneLens
+ , aview
+
-- * Common lenses
- _1, _2,
+ , _1
+ , _2
+
-- * Operators
- (&),
- (^.),
- (.~), (?~), (%~),
- (.=), (?=), (%=),
- (^#),
- (#~), (#%~),
+ , (&)
+ , (^.)
+ , (.~)
+ , (?~)
+ , (%~)
+ , (.=)
+ , (?=)
+ , (%=)
+ , (^#)
+ , (#~)
+ , (#%~)
+
-- * Internal Comonads
- Pretext (..),
+ , Pretext (..)
+
-- * Cabal developer info
-- $development
- ) where
+ ) where
-import Prelude()
import Distribution.Compat.Prelude
+import Prelude ()
import Control.Monad.State.Class (MonadState (..), gets, modify)
-import qualified Distribution.Compat.DList as DList
import qualified Data.Set as Set
+import qualified Distribution.Compat.DList as DList
-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------
-type LensLike f s t a b = (a -> f b) -> s -> f t
-type LensLike' f s a = (a -> f a) -> s -> f s
+type LensLike f s t a b = (a -> f b) -> s -> f t
+type LensLike' f s a = (a -> f a) -> s -> f s
-type Lens s t a b = forall f. Functor f => LensLike f s t a b
+type Lens s t a b = forall f. Functor f => LensLike f s t a b
type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
-type Lens' s a = Lens s s a a
+type Lens' s a = Lens s s a a
type Traversal' s a = Traversal s s a a
type Getting r s a = LensLike (Const r) s s a a
-type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens'
-type ASetter s t a b = LensLike Identity s t a b
-type ALens s t a b = LensLike (Pretext a b) s t a b
+type AGetter s a = LensLike (Const a) s s a a -- this doesn't exist in 'lens'
+type ASetter s t a b = LensLike Identity s t a b
+type ALens s t a b = LensLike (Pretext a b) s t a b
type ALens' s a = ALens s s a a
@@ -80,7 +97,7 @@ type ALens' s a = ALens s s a a
-- Getter
-------------------------------------------------------------------------------
-view :: Getting a s a -> s -> a
+view :: Getting a s a -> s -> a
view l s = getConst (l Const s)
{-# INLINE view #-}
@@ -100,7 +117,7 @@ getting k f = Const . getConst . f . k
-- Setter
-------------------------------------------------------------------------------
-set :: ASetter s t a b -> b -> s -> t
+set :: ASetter s t a b -> b -> s -> t
set l x = over l (const x)
over :: ASetter s t a b -> (a -> b) -> s -> t
@@ -116,7 +133,7 @@ toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s)
toListOf :: Getting (DList.DList a) s a -> s -> [a]
toListOf l = DList.runDList . toDListOf l
-toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a
+toSetOf :: Getting (Set.Set a) s a -> s -> Set.Set a
toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)
-------------------------------------------------------------------------------
@@ -124,7 +141,7 @@ toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)
-------------------------------------------------------------------------------
aview :: ALens s t a b -> s -> a
-aview l = pretextPos . l pretextSell
+aview l = pretextPos . l pretextSell
{-# INLINE aview #-}
{-
@@ -136,10 +153,10 @@ lens sa sbt afb s = sbt s <$> afb (sa s)
-- Common
-------------------------------------------------------------------------------
-_1 :: Lens (a, c) (b, c) a b
+_1 :: Lens (a, c) (b, c) a b
_1 f (a, c) = flip (,) c <$> f a
-_2 :: Lens (c, a) (c, b) a b
+_2 :: Lens (c, a) (c, b) a b
_2 f (c, a) = (,) c <$> f a
-------------------------------------------------------------------------------
@@ -150,6 +167,7 @@ _2 f (c, a) = (,) c <$> f a
(&) :: a -> (a -> b) -> b
(&) = flip ($)
{-# INLINE (&) #-}
+
infixl 1 &
infixl 8 ^., ^#
@@ -221,10 +239,10 @@ cloneLens l f s = runPretext (l pretextSell s) f
-------------------------------------------------------------------------------
-- | @lens@ variant is also parametrised by profunctor.
-data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t }
+data Pretext a b t = Pretext {runPretext :: forall f. Functor f => (a -> f b) -> f t}
instance Functor (Pretext a b) where
- fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb))
+ fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb))
-------------------------------------------------------------------------------
-- Documentation
diff --git a/Cabal-syntax/src/Distribution/Compat/MonadFail.hs b/Cabal-syntax/src/Distribution/Compat/MonadFail.hs
index f4da211a43d86706f9b0fca00f95b65ed5b856d7..3516aef7e77f73933b92f694aab540ea0238fecc 100644
--- a/Cabal-syntax/src/Distribution/Compat/MonadFail.hs
+++ b/Cabal-syntax/src/Distribution/Compat/MonadFail.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
-- | Compatibility layer for "Control.Monad.Fail"
-module Distribution.Compat.MonadFail ( Control.Monad.Fail.MonadFail(fail) ) where
+module Distribution.Compat.MonadFail (Control.Monad.Fail.MonadFail (fail)) where
+
import Control.Monad.Fail
diff --git a/Cabal-syntax/src/Distribution/Compat/Newtype.hs b/Cabal-syntax/src/Distribution/Compat/Newtype.hs
index 904e2e5d4b3dd11095b69a5a0bc59ae3366eb250..00da1e835426a72795153ce435cc350a6cd7885c 100644
--- a/Cabal-syntax/src/Distribution/Compat/Newtype.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Newtype.hs
@@ -1,20 +1,21 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
+
-- | Per Conor McBride, the 'Newtype' typeclass represents the packing and
-- unpacking of a newtype, and allows you to operate under that newtype with
-- functions such as 'ala'.
-module Distribution.Compat.Newtype (
- Newtype (..),
- ala,
- alaf,
- pack',
- unpack',
- ) where
+module Distribution.Compat.Newtype
+ ( Newtype (..)
+ , ala
+ , alaf
+ , pack'
+ , unpack'
+ ) where
import Data.Functor.Identity (Identity (..))
-import Data.Monoid (Sum (..), Product (..), Endo (..))
+import Data.Monoid (Endo (..), Product (..), Sum (..))
#if MIN_VERSION_base(4,7,0)
import Data.Coerce (coerce, Coercible)
@@ -36,25 +37,26 @@ import Unsafe.Coerce (unsafeCoerce)
-- Another approach would be to use @TypeFamilies@ (and possibly
-- compute inner type using "GHC.Generics"), but we think @FunctionalDependencies@
-- version gives cleaner type signatures.
---
+{- FOURMOLU_DISABLE -}
class Newtype o n | n -> o where
- pack :: o -> n
+ pack :: o -> n
#if MIN_VERSION_base(4,7,0)
- default pack :: Coercible o n => o -> n
- pack = coerce
+ default pack :: Coercible o n => o -> n
+ pack = coerce
#else
- default pack :: o -> n
- pack = unsafeCoerce
+ default pack :: o -> n
+ pack = unsafeCoerce
#endif
- unpack :: n -> o
+ unpack :: n -> o
#if MIN_VERSION_base(4,7,0)
- default unpack :: Coercible n o => n -> o
- unpack = coerce
+ default unpack :: Coercible n o => n -> o
+ unpack = coerce
#else
- default unpack :: n -> o
- unpack = unsafeCoerce
+ default unpack :: n -> o
+ unpack = unsafeCoerce
#endif
+{- FOURMOLU_ENABLE -}
instance Newtype a (Identity a)
instance Newtype a (Sum a)
diff --git a/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs b/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs
index 54a4ecef5f21ab095a7ebb93ebdf68e0abf10669..034da7ee90ce3494947fda153914ebe7d6f8a291 100644
--- a/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs
+++ b/Cabal-syntax/src/Distribution/Compat/NonEmptySet.hs
@@ -1,36 +1,43 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-module Distribution.Compat.NonEmptySet (
- NonEmptySet,
+
+module Distribution.Compat.NonEmptySet
+ ( NonEmptySet
+
-- * Construction
- singleton,
+ , singleton
+
-- * Insertion
- insert,
+ , insert
+
-- * Deletion
- delete,
+ , delete
+
-- * Conversions
- toNonEmpty,
- fromNonEmpty,
- toList,
- toSet,
+ , toNonEmpty
+ , fromNonEmpty
+ , toList
+ , toSet
+
-- * Query
- member,
+ , member
+
-- * Map
- map,
-) where
+ , map
+ ) where
import Prelude (Bool (..), Eq, Maybe (..), Ord (..), Read, Show (..), String, error, otherwise, return, showParen, showString, ($), (++), (.))
-import Control.DeepSeq (NFData (..))
-import Data.Data (Data)
+import Control.DeepSeq (NFData (..))
+import Data.Data (Data)
import Data.List.NonEmpty (NonEmpty (..))
-import Data.Semigroup (Semigroup (..))
-import Data.Typeable (Typeable)
+import Data.Semigroup (Semigroup (..))
+import Data.Typeable (Typeable)
import qualified Data.Foldable as F
-import qualified Data.Set as Set
+import qualified Data.Set as Set
-import Distribution.Compat.Binary (Binary (..))
+import Distribution.Compat.Binary (Binary (..))
import Distribution.Utils.Structured
#if MIN_VERSION_binary(0,6,0)
@@ -48,40 +55,43 @@ newtype NonEmptySet a = NES (Set.Set a)
-------------------------------------------------------------------------------
instance Show a => Show (NonEmptySet a) where
- showsPrec d s = showParen (d > 10)
- $ showString "fromNonEmpty "
+ showsPrec d s =
+ showParen (d > 10) $
+ showString "fromNonEmpty "
. showsPrec 11 (toNonEmpty s)
+{- FOURMOLU_DISABLE -}
instance Binary a => Binary (NonEmptySet a) where
- put (NES s) = put s
- get = do
- xs <- get
- if Set.null xs
+ put (NES s) = put s
+ get = do
+ xs <- get
+ if Set.null xs
#if MIN_VERSION_binary(0,6,0)
- then empty
+ then empty
#else
- then fail "NonEmptySet: empty"
+ then fail "NonEmptySet: empty"
#endif
- else return (NES xs)
+ else return (NES xs)
+{- FOURMOLU_ENABLE -}
instance Structured a => Structured (NonEmptySet a) where
- structure = containerStructure
+ structure = containerStructure
instance NFData a => NFData (NonEmptySet a) where
- rnf (NES x) = rnf x
+ rnf (NES x) = rnf x
-- | Note: there aren't @Monoid@ instance.
instance Ord a => Semigroup (NonEmptySet a) where
- NES x <> NES y = NES (Set.union x y)
+ NES x <> NES y = NES (Set.union x y)
instance F.Foldable NonEmptySet where
- foldMap f (NES s) = F.foldMap f s
- foldr f z (NES s) = F.foldr f z s
+ foldMap f (NES s) = F.foldMap f s
+ foldr f z (NES s) = F.foldr f z s
#if MIN_VERSION_base(4,8,0)
- toList = toList
- null _ = False
- length (NES s) = F.length s
+ toList = toList
+ null _ = False
+ length (NES s) = F.length s
#endif
-------------------------------------------------------------------------------
@@ -104,8 +114,8 @@ insert x (NES xs) = NES (Set.insert x xs)
delete :: Ord a => a -> NonEmptySet a -> Maybe (NonEmptySet a)
delete x (NES xs)
- | Set.null res = Nothing
- | otherwise = Just (NES xs)
+ | Set.null res = Nothing
+ | otherwise = Just (NES xs)
where
res = Set.delete x xs
@@ -118,8 +128,8 @@ fromNonEmpty (x :| xs) = NES (Set.fromList (x : xs))
toNonEmpty :: NonEmptySet a -> NonEmpty a
toNonEmpty (NES s) = case Set.toList s of
- [] -> panic "toNonEmpty"
- x:xs -> x :| xs
+ [] -> panic "toNonEmpty"
+ x : xs -> x :| xs
toList :: NonEmptySet a -> [a]
toList (NES s) = Set.toList s
@@ -138,6 +148,7 @@ member x (NES xs) = Set.member x xs
-- Map
-------------------------------------------------------------------------------
+{- FOURMOLU_DISABLE -}
map
:: ( Ord b
#if !MIN_VERSION_containers(0,5,2)
@@ -146,6 +157,7 @@ map
)
=> (a -> b) -> NonEmptySet a -> NonEmptySet b
map f (NES x) = NES (Set.map f x)
+{- FOURMOLU_ENABLE -}
-------------------------------------------------------------------------------
-- Internal
diff --git a/Cabal-syntax/src/Distribution/Compat/Parsing.hs b/Cabal-syntax/src/Distribution/Compat/Parsing.hs
index cc4abd220a2c54e21b428b8fe3a91195b39bdbb6..4cb8c9bca1886546af6ef34c393276062f585c38 100644
--- a/Cabal-syntax/src/Distribution/Compat/Parsing.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Parsing.hs
@@ -1,5 +1,10 @@
-{-# LANGUAGE GADTs, UndecidableInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compat.Parsing
-- Copyright : (c) Edward Kmett 2011-2012
@@ -12,18 +17,15 @@
-- Alternative parser combinators.
--
-- Originally in @parsers@ package.
---
------------------------------------------------------------------------------
module Distribution.Compat.Parsing
- (
- -- * Parsing Combinators
+ ( -- * Parsing Combinators
choice
, option
, optional -- from Control.Applicative, parsec optionMaybe
, skipOptional -- parsec optional
, between
- , some -- from Control.Applicative, parsec many1
- , many -- from Control.Applicative
+ , some -- from Control.Applicative, parsec many1
+ , many -- from Control.Applicative
, sepBy
, sepByNonEmpty
, sepEndByNonEmpty
@@ -36,23 +38,24 @@ module Distribution.Compat.Parsing
, chainl1
, chainr1
, manyTill
- -- * Parsing Class
- , Parsing(..)
+
+ -- * Parsing Class
+ , Parsing (..)
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Control.Applicative ((<**>), optional)
+import Control.Applicative (optional, (<**>))
import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Identity (IdentityT (..))
+import Control.Monad.Trans.RWS.Lazy as Lazy
+import Control.Monad.Trans.RWS.Strict as Strict
+import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.State.Lazy as Lazy
import Control.Monad.Trans.State.Strict as Strict
import Control.Monad.Trans.Writer.Lazy as Lazy
import Control.Monad.Trans.Writer.Strict as Strict
-import Control.Monad.Trans.RWS.Lazy as Lazy
-import Control.Monad.Trans.RWS.Strict as Strict
-import Control.Monad.Trans.Reader (ReaderT (..))
-import Control.Monad.Trans.Identity (IdentityT (..))
import Data.Foldable (asum)
import qualified Data.List.NonEmpty as NE
@@ -136,8 +139,9 @@ endBy p sep = many (p <* sep)
-- equal to zero, the parser equals to @return []@. Returns a list of
-- @n@ values returned by @p@.
count :: Applicative m => Int -> m a -> m [a]
-count n p | n <= 0 = pure []
- | otherwise = sequenceA (replicate n p)
+count n p
+ | n <= 0 = pure []
+ | otherwise = sequenceA (replicate n p)
{-# INLINE count #-}
-- | @chainr p op x@ parses /zero/ or more occurrences of @p@,
@@ -174,9 +178,10 @@ chainl p op x = chainl1 p op <|> pure x
-- > addop = (+) <$ symbol "+"
-- > <|> (-) <$ symbol "-"
chainl1 :: Alternative m => m a -> m (a -> a -> a) -> m a
-chainl1 p op = scan where
- scan = p <**> rst
- rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id
+chainl1 p op = scan
+ where
+ scan = p <**> rst
+ rst = (\f y g x -> g (f x y)) <$> op <*> p <*> rst <|> pure id
{-# INLINE chainl1 #-}
-- | @chainr1 p op x@ parses /one/ or more occurrences of @p@,
@@ -184,9 +189,10 @@ chainl1 p op = scan where
-- application of all functions returned by @op@ to the values returned
-- by @p@.
chainr1 :: Alternative m => m a -> m (a -> a -> a) -> m a
-chainr1 p op = scan where
- scan = p <**> rst
- rst = (flip <$> op <*> scan) <|> pure id
+chainr1 p op = scan
+ where
+ scan = p <**> rst
+ rst = (flip <$> op <*> scan) <|> pure id
{-# INLINE chainr1 #-}
-- | @manyTill p end@ applies parser @p@ /zero/ or more times until
@@ -255,8 +261,8 @@ instance (Parsing m, MonadPlus m) => Parsing (Lazy.StateT s m) where
{-# INLINE unexpected #-}
eof = lift eof
{-# INLINE eof #-}
- notFollowedBy (Lazy.StateT m) = Lazy.StateT
- $ \s -> notFollowedBy (fst <$> m s) >> return ((),s)
+ notFollowedBy (Lazy.StateT m) = Lazy.StateT $
+ \s -> notFollowedBy (fst <$> m s) >> return ((), s)
{-# INLINE notFollowedBy #-}
instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where
@@ -268,8 +274,8 @@ instance (Parsing m, MonadPlus m) => Parsing (Strict.StateT s m) where
{-# INLINE unexpected #-}
eof = lift eof
{-# INLINE eof #-}
- notFollowedBy (Strict.StateT m) = Strict.StateT
- $ \s -> notFollowedBy (fst <$> m s) >> return ((),s)
+ notFollowedBy (Strict.StateT m) = Strict.StateT $
+ \s -> notFollowedBy (fst <$> m s) >> return ((), s)
{-# INLINE notFollowedBy #-}
instance (Parsing m, MonadPlus m) => Parsing (ReaderT e m) where
@@ -295,8 +301,9 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.WriterT w m) wher
{-# INLINE unexpected #-}
eof = lift eof
{-# INLINE eof #-}
- notFollowedBy (Strict.WriterT m) = Strict.WriterT
- $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)
+ notFollowedBy (Strict.WriterT m) =
+ Strict.WriterT $
+ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)
{-# INLINE notFollowedBy #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where
@@ -308,8 +315,9 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.WriterT w m) where
{-# INLINE unexpected #-}
eof = lift eof
{-# INLINE eof #-}
- notFollowedBy (Lazy.WriterT m) = Lazy.WriterT
- $ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)
+ notFollowedBy (Lazy.WriterT m) =
+ Lazy.WriterT $
+ notFollowedBy (fst <$> m) >>= \x -> return (x, mempty)
{-# INLINE notFollowedBy #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where
@@ -321,8 +329,8 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Lazy.RWST r w s m) where
{-# INLINE unexpected #-}
eof = lift eof
{-# INLINE eof #-}
- notFollowedBy (Lazy.RWST m) = Lazy.RWST
- $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty)
+ notFollowedBy (Lazy.RWST m) = Lazy.RWST $
+ \r s -> notFollowedBy ((\(a, _, _) -> a) <$> m r s) >>= \x -> return (x, s, mempty)
{-# INLINE notFollowedBy #-}
instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) where
@@ -334,8 +342,8 @@ instance (Parsing m, MonadPlus m, Monoid w) => Parsing (Strict.RWST r w s m) whe
{-# INLINE unexpected #-}
eof = lift eof
{-# INLINE eof #-}
- notFollowedBy (Strict.RWST m) = Strict.RWST
- $ \r s -> notFollowedBy ((\(a,_,_) -> a) <$> m r s) >>= \x -> return (x, s, mempty)
+ notFollowedBy (Strict.RWST m) = Strict.RWST $
+ \r s -> notFollowedBy ((\(a, _, _) -> a) <$> m r s) >>= \x -> return (x, s, mempty)
{-# INLINE notFollowedBy #-}
instance (Parsing m, Monad m) => Parsing (IdentityT m) where
@@ -353,10 +361,10 @@ instance (Parsing m, Monad m) => Parsing (IdentityT m) where
{-# INLINE notFollowedBy #-}
instance (Parsec.Stream s m t, Show t) => Parsing (Parsec.ParsecT s u m) where
- try = Parsec.try
- (<?>) = (Parsec.<?>)
- skipMany = Parsec.skipMany
- skipSome = Parsec.skipMany1
- unexpected = Parsec.unexpected
- eof = Parsec.eof
+ try = Parsec.try
+ (<?>) = (Parsec.<?>)
+ skipMany = Parsec.skipMany
+ skipSome = Parsec.skipMany1
+ unexpected = Parsec.unexpected
+ eof = Parsec.eof
notFollowedBy = Parsec.notFollowedBy
diff --git a/Cabal-syntax/src/Distribution/Compat/Prelude.hs b/Cabal-syntax/src/Distribution/Compat/Prelude.hs
index 8c79d27d9a773c9e0b2106294c3169980cbc96b6..3ff51e2d8bbbad03cba4598d52aadfa8aad222bd 100644
--- a/Cabal-syntax/src/Distribution/Compat/Prelude.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Prelude.hs
@@ -1,134 +1,195 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE TypeOperators #-}
+{- FOURMOLU_DISABLE -}
#ifdef MIN_VERSION_base
#define MINVER_base_411 MIN_VERSION_base(4,11,0)
#else
#define MINVER_base_411 (__GLASGOW_HASKELL__ >= 804)
#endif
+{- FOURMOLU_ENABLE -}
-- | This module does two things:
--
-- * Acts as a compatibility layer, like @base-compat@.
--
-- * Provides commonly used imports.
-module Distribution.Compat.Prelude (
- -- * Prelude
- --
- -- Prelude is re-exported, following is hidden:
- module BasePrelude,
+module Distribution.Compat.Prelude
+ ( -- * Prelude
+
+ --
+ -- Prelude is re-exported, following is hidden:
+ module BasePrelude
-- * Common type-classes
- Semigroup (..),
- gmappend, gmempty,
- Typeable, TypeRep, typeRep,
- Data,
- Generic,
- NFData (..), genericRnf,
- Binary (..),
- Structured,
- Alternative (..),
- MonadPlus (..),
- IsString (..),
+ , Semigroup (..)
+ , gmappend
+ , gmempty
+ , Typeable
+ , TypeRep
+ , typeRep
+ , Data
+ , Generic
+ , NFData (..)
+ , genericRnf
+ , Binary (..)
+ , Structured
+ , Alternative (..)
+ , MonadPlus (..)
+ , IsString (..)
-- * Some types
- Map,
- Set,
- NonEmptySet,
- Identity (..),
- Proxy (..),
- Const (..),
- Void,
+ , Map
+ , Set
+ , NonEmptySet
+ , Identity (..)
+ , Proxy (..)
+ , Const (..)
+ , Void
-- * Data.Either
- partitionEithers,
+ , partitionEithers
-- * Data.Maybe
- catMaybes, mapMaybe,
- fromMaybe,
- maybeToList, listToMaybe,
- isNothing, isJust,
+ , catMaybes
+ , mapMaybe
+ , fromMaybe
+ , maybeToList
+ , listToMaybe
+ , isNothing
+ , isJust
-- * Data.List
- unfoldr,
- isPrefixOf, isSuffixOf,
- intercalate, intersperse,
- sort, sortBy,
- nub, nubBy,
- partition,
- dropWhileEnd,
+ , unfoldr
+ , isPrefixOf
+ , isSuffixOf
+ , intercalate
+ , intersperse
+ , sort
+ , sortBy
+ , nub
+ , nubBy
+ , partition
+ , dropWhileEnd
-- * Data.List.NonEmpty
- NonEmpty((:|)), nonEmpty, foldl1, foldr1,
- head, tail, last, init,
+ , NonEmpty ((:|))
+ , nonEmpty
+ , foldl1
+ , foldr1
+ , head
+ , tail
+ , last
+ , init
-- * Data.Foldable
- Foldable, foldMap, foldr,
- null, length,
- find, foldl',
- traverse_, for_,
- any, all,
- toList,
+ , Foldable
+ , foldMap
+ , foldr
+ , null
+ , length
+ , find
+ , foldl'
+ , traverse_
+ , for_
+ , any
+ , all
+ , toList
-- * Data.Traversable
- Traversable, traverse, sequenceA,
- for,
+ , Traversable
+ , traverse
+ , sequenceA
+ , for
-- * Data.Function
- on,
+ , on
-- * Data.Ord
- comparing,
+ , comparing
-- * Control.Arrow
- first,
+ , first
-- * Control.Monad
- liftM, liftM2,
- unless, when,
- ap, void,
- foldM, filterM,
- join, guard,
+ , liftM
+ , liftM2
+ , unless
+ , when
+ , ap
+ , void
+ , foldM
+ , filterM
+ , join
+ , guard
-- * Control.Exception
- catch, throwIO, evaluate,
- Exception (..), IOException, SomeException (..),
- tryIO, catchIO, catchExit,
+ , catch
+ , throwIO
+ , evaluate
+ , Exception (..)
+ , IOException
+ , SomeException (..)
+ , tryIO
+ , catchIO
+ , catchExit
-- * Control.DeepSeq
- deepseq, force,
+ , deepseq
+ , force
-- * Data.Char
- isSpace, isDigit, isUpper, isAlpha, isAlphaNum,
- chr, ord,
- toLower, toUpper,
+ , isSpace
+ , isDigit
+ , isUpper
+ , isAlpha
+ , isAlphaNum
+ , chr
+ , ord
+ , toLower
+ , toUpper
-- * Data.Void
- absurd, vacuous,
+ , absurd
+ , vacuous
-- * Data.Word & Data.Int
- Word,
- Word8, Word16, Word32, Word64,
- Int8, Int16, Int32, Int64,
+ , Word
+ , Word8
+ , Word16
+ , Word32
+ , Word64
+ , Int8
+ , Int16
+ , Int32
+ , Int64
-- * Text.PrettyPrint
- (<<>>), (Disp.<+>),
+ , (<<>>)
+ , (Disp.<+>)
-- * System.Exit
- ExitCode (..),
- exitWith, exitSuccess, exitFailure,
+ , ExitCode (..)
+ , exitWith
+ , exitSuccess
+ , exitFailure
-- * Text.Read
- readMaybe,
+ , readMaybe
-- * Debug.Trace (as deprecated functions)
- trace, traceShow, traceShowId, traceM, traceShowM
- ) where
+ , trace
+ , traceShow
+ , traceShowId
+ , traceM
+ , traceShowM
+ ) where
-- We also could hide few partial function
+{- FOURMOLU_DISABLE -}
import Prelude as BasePrelude hiding
( mapM, mapM_, sequence, null, length, foldr, any, all, head, tail, last, init
-- partial functions
@@ -144,57 +205,58 @@ import Prelude as BasePrelude hiding
, Traversable, traverse, sequenceA
, Foldable, foldMap
)
+{- FOURMOLU_ENABLE -}
-- AMP
import Data.Foldable
- ( Foldable(toList),
- length,
- null,
- Foldable(foldMap, foldr),
- all,
- any,
- find,
- foldl',
- for_,
- traverse_ )
+ ( Foldable (foldMap, foldr, toList)
+ , all
+ , any
+ , find
+ , foldl'
+ , for_
+ , length
+ , null
+ , traverse_
+ )
import Data.Traversable (Traversable (sequenceA, traverse), for)
import qualified Data.Foldable
-- Extra exports
-import Control.Applicative (Alternative (..), 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 Data.Either (partitionEithers)
-import Data.Function (on)
-import Data.Functor.Identity (Identity (..))
-import Data.Int (Int16, Int32, Int64, Int8)
-import Data.List (dropWhileEnd, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr)
-import Data.List.NonEmpty (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 Data.String (IsString (..))
-import Data.Void (Void, absurd, vacuous)
-import Data.Word (Word, Word16, Word32, Word64, Word8)
-import Distribution.Compat.Binary (Binary (..))
+import Control.Applicative (Alternative (..), 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 Data.Either (partitionEithers)
+import Data.Function (on)
+import Data.Functor.Identity (Identity (..))
+import Data.Int (Int16, Int32, Int64, Int8)
+import Data.List (dropWhileEnd, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, nubBy, partition, sort, sortBy, unfoldr)
+import Data.List.NonEmpty (NonEmpty ((:|)), head, init, last, nonEmpty, 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 Data.String (IsString (..))
+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 Distribution.Compat.Typeable (TypeRep, Typeable, typeRep)
+import GHC.Generics (Generic, K1 (unK1), M1 (unM1), Rep (..), U1 (U1), V1, (:*:) ((:*:)), (:+:) (L1, R1))
+import System.Exit (ExitCode (..), exitFailure, exitSuccess, exitWith)
+import Text.Read (readMaybe)
import qualified Text.PrettyPrint as Disp
import Distribution.Compat.Exception
import Distribution.Compat.NonEmptySet (NonEmptySet)
-import Distribution.Utils.Structured (Structured)
+import Distribution.Utils.Structured (Structured)
import qualified Debug.Trace
@@ -243,7 +305,6 @@ instance (GNFData a, GNFData b) => GNFData (a :+: b) where
grnf (R1 x) = grnf x
{-# INLINEABLE grnf #-}
-
-- TODO: if we want foldr1/foldl1 to work on more than NonEmpty, we
-- can define a local typeclass 'Foldable1', e.g.
--
diff --git a/Cabal-syntax/src/Distribution/Compat/Semigroup.hs b/Cabal-syntax/src/Distribution/Compat/Semigroup.hs
index 947eaa50e82a24997a777f3615dcb0ff46b20b15..9db9f6ebe982def74d711cbb0e05e8ffa7c0a8cb 100644
--- a/Cabal-syntax/src/Distribution/Compat/Semigroup.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Semigroup.hs
@@ -1,46 +1,44 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeOperators #-}
-- | Compatibility layer for "Data.Semigroup"
module Distribution.Compat.Semigroup
- ( Semigroup((<>))
- , Mon.Monoid(..)
- , All(..)
- , Any(..)
-
- , First'(..)
- , Last'(..)
-
- , Option'(..)
-
- , gmappend
- , gmempty
- ) where
+ ( Semigroup ((<>))
+ , Mon.Monoid (..)
+ , All (..)
+ , Any (..)
+ , First' (..)
+ , Last' (..)
+ , Option' (..)
+ , gmappend
+ , gmempty
+ ) where
+import Data.Typeable (Typeable)
import Distribution.Compat.Binary (Binary)
import Distribution.Utils.Structured (Structured)
-import Data.Typeable (Typeable)
import GHC.Generics
+
-- Data.Semigroup is available since GHC 8.0/base-4.9 in `base`
-- for older GHC/base, it's provided by `semigroups`
-import Data.Semigroup
-import qualified Data.Monoid as Mon
+import qualified Data.Monoid as Mon
+import Data.Semigroup
-- | A copy of 'Data.Semigroup.First'.
-newtype First' a = First' { getFirst' :: a }
+newtype First' a = First' {getFirst' :: a}
deriving (Eq, Ord, Show)
instance Semigroup (First' a) where
a <> _ = a
-- | A copy of 'Data.Semigroup.Last'.
-newtype Last' a = Last' { getLast' :: a }
+newtype Last' a = Last' {getLast' :: a}
deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable)
instance Structured a => Structured (Last' a)
@@ -53,15 +51,15 @@ instance Functor Last' where
-- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances
-- implemented for 'Maybe' since @base-4.11@.
-newtype Option' a = Option' { getOption' :: Maybe a }
+newtype Option' a = Option' {getOption' :: Maybe a}
deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable)
instance Structured a => Structured (Option' a)
instance Semigroup a => Semigroup (Option' a) where
Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b))
- Option' Nothing <> b = b
- a <> Option' Nothing = a
+ Option' Nothing <> b = b
+ a <> Option' Nothing = a
instance Semigroup a => Monoid (Option' a) where
mempty = Option' Nothing
@@ -83,16 +81,16 @@ gmappend :: (Generic a, GSemigroup (Rep a)) => a -> a -> a
gmappend x y = to (gmappend' (from x) (from y))
class GSemigroup f where
- gmappend' :: f p -> f p -> f p
+ gmappend' :: f p -> f p -> f p
instance Semigroup a => GSemigroup (K1 i a) where
- gmappend' (K1 x) (K1 y) = K1 (x <> y)
+ gmappend' (K1 x) (K1 y) = K1 (x <> y)
instance GSemigroup f => GSemigroup (M1 i c f) where
- gmappend' (M1 x) (M1 y) = M1 (gmappend' x y)
+ gmappend' (M1 x) (M1 y) = M1 (gmappend' x y)
instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where
- gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2
+ gmappend' (x1 :*: x2) (y1 :*: y2) = gmappend' x1 y1 :*: gmappend' x2 y2
-- | Generically generate a 'Monoid' 'mempty' for any product-like type
-- implementing 'Generic'.
@@ -102,18 +100,17 @@ instance (GSemigroup f, GSemigroup g) => GSemigroup (f :*: g) where
-- @
-- 'gmappend' 'gmempty' a = a = 'gmappend' a 'gmempty'
-- @
-
gmempty :: (Generic a, GMonoid (Rep a)) => a
gmempty = to gmempty'
class GSemigroup f => GMonoid f where
- gmempty' :: f p
+ gmempty' :: f p
instance (Semigroup a, Monoid a) => GMonoid (K1 i a) where
- gmempty' = K1 mempty
+ gmempty' = K1 mempty
instance GMonoid f => GMonoid (M1 i c f) where
- gmempty' = M1 gmempty'
+ gmempty' = M1 gmempty'
instance (GMonoid f, GMonoid g) => GMonoid (f :*: g) where
- gmempty' = gmempty' :*: gmempty'
+ gmempty' = gmempty' :*: gmempty'
diff --git a/Cabal-syntax/src/Distribution/Compat/Typeable.hs b/Cabal-syntax/src/Distribution/Compat/Typeable.hs
index 808d04472f6c827ed71ec26eb5dbd082e57272ed..161f868a823087b45111d3d52c36f4965dbe8011 100644
--- a/Cabal-syntax/src/Distribution/Compat/Typeable.hs
+++ b/Cabal-syntax/src/Distribution/Compat/Typeable.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Compat.Typeable (
- Typeable,
- TypeRep,
- typeRep,
- ) where
+
+module Distribution.Compat.Typeable
+ ( Typeable
+ , TypeRep
+ , typeRep
+ ) where
#if MIN_VERSION_base(4,7,0)
import Data.Typeable (Typeable, TypeRep, typeRep)
diff --git a/Cabal-syntax/src/Distribution/Compiler.hs b/Cabal-syntax/src/Distribution/Compiler.hs
index 4f6ce1b97e928d5cf062956a2a4f1205d9e7e94a..8fb3f88851efcc84fb22158a4694b2c386d0adeb 100644
--- a/Cabal-syntax/src/Distribution/Compiler.hs
+++ b/Cabal-syntax/src/Distribution/Compiler.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compiler
-- Copyright : Isaac Jones 2003-2004
@@ -26,44 +27,54 @@
-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the
-- moment we just have to live with this deficiency. If you're interested, see
-- ticket #57.
-
-module Distribution.Compiler (
- -- * Compiler flavor
- CompilerFlavor(..),
- buildCompilerId,
- buildCompilerFlavor,
- defaultCompilerFlavor,
- classifyCompilerFlavor,
- knownCompilerFlavors,
-
- -- * Per compiler flavor
- PerCompilerFlavor (..),
- perCompilerFlavorToList,
-
- -- * Compiler id
- CompilerId(..),
-
- -- * Compiler info
- CompilerInfo(..),
- unknownCompilerInfo,
- AbiTag(..), abiTagString
+module Distribution.Compiler
+ ( -- * Compiler flavor
+ CompilerFlavor (..)
+ , buildCompilerId
+ , buildCompilerFlavor
+ , defaultCompilerFlavor
+ , classifyCompilerFlavor
+ , knownCompilerFlavors
+
+ -- * Per compiler flavor
+ , PerCompilerFlavor (..)
+ , perCompilerFlavorToList
+
+ -- * Compiler id
+ , CompilerId (..)
+
+ -- * Compiler info
+ , CompilerInfo (..)
+ , unknownCompilerInfo
+ , AbiTag (..)
+ , abiTagString
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Language.Haskell.Extension
import Distribution.Version (Version, mkVersion', nullVersion)
-import qualified System.Info (compilerName, compilerVersion)
+import qualified Distribution.Compat.CharParsing as P
import Distribution.Parsec (Parsec (..))
import Distribution.Pretty (Pretty (..), prettyShow)
-import qualified Distribution.Compat.CharParsing as P
+import qualified System.Info (compilerName, compilerVersion)
import qualified Text.PrettyPrint as Disp
-data CompilerFlavor =
- GHC | GHCJS | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC | Eta
+data CompilerFlavor
+ = GHC
+ | GHCJS
+ | NHC
+ | YHC
+ | Hugs
+ | HBC
+ | Helium
+ | JHC
+ | LHC
+ | UHC
+ | Eta
| HaskellSuite String -- string is the id of the actual compiler
| OtherCompiler String
deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
@@ -78,23 +89,25 @@ knownCompilerFlavors =
instance Pretty CompilerFlavor where
pretty (OtherCompiler name) = Disp.text name
- pretty (HaskellSuite name) = Disp.text name
- pretty NHC = Disp.text "nhc98"
- pretty other = Disp.text (lowercase (show other))
+ pretty (HaskellSuite name) = Disp.text name
+ pretty NHC = Disp.text "nhc98"
+ pretty other = Disp.text (lowercase (show other))
instance Parsec CompilerFlavor where
- parsec = classifyCompilerFlavor <$> component
- where
- component = do
- cs <- P.munch1 isAlphaNum
- if all isDigit cs then fail "all digits compiler name" else return cs
+ parsec = classifyCompilerFlavor <$> component
+ where
+ component = do
+ cs <- P.munch1 isAlphaNum
+ if all isDigit cs then fail "all digits compiler name" else return cs
classifyCompilerFlavor :: String -> CompilerFlavor
classifyCompilerFlavor s =
fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap
where
- compilerMap = [ (lowercase (prettyShow compiler), compiler)
- | compiler <- knownCompilerFlavors ]
+ compilerMap =
+ [ (lowercase (prettyShow compiler), compiler)
+ | compiler <- knownCompilerFlavors
+ ]
buildCompilerFlavor :: CompilerFlavor
buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName
@@ -110,11 +123,10 @@ buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion
--
-- However if it's not a recognised compiler then it's 'Nothing' and the user
-- will have to specify which compiler they want.
---
defaultCompilerFlavor :: Maybe CompilerFlavor
defaultCompilerFlavor = case buildCompilerFlavor of
OtherCompiler _ -> Nothing
- _ -> Just buildCompilerFlavor
+ _ -> Just buildCompilerFlavor
-------------------------------------------------------------------------------
-- Per compiler data
@@ -123,10 +135,19 @@ defaultCompilerFlavor = case buildCompilerFlavor of
-- | 'PerCompilerFlavor' carries only info per GHC and GHCJS
--
-- Cabal parses only @ghc-options@ and @ghcjs-options@, others are omitted.
---
data PerCompilerFlavor v = PerCompilerFlavor v v
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data, Functor, Foldable
- , Traversable)
+ deriving
+ ( Generic
+ , Show
+ , Read
+ , Eq
+ , Ord
+ , Typeable
+ , Data
+ , Functor
+ , Foldable
+ , Traversable
+ )
instance Binary a => Binary (PerCompilerFlavor a)
instance Structured a => Structured (PerCompilerFlavor a)
@@ -136,15 +157,19 @@ perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)]
perCompilerFlavorToList (PerCompilerFlavor a b) = [(GHC, a), (GHCJS, b)]
instance Semigroup a => Semigroup (PerCompilerFlavor a) where
- PerCompilerFlavor a b <> PerCompilerFlavor a' b' = PerCompilerFlavor
- (a <> a') (b <> b')
+ PerCompilerFlavor a b <> PerCompilerFlavor a' b' =
+ PerCompilerFlavor
+ (a <> a')
+ (b <> b')
instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where
- mempty = PerCompilerFlavor mempty mempty
- mappend = (<>)
+ mempty = PerCompilerFlavor mempty mempty
+ mappend = (<>)
-- ------------------------------------------------------------
+
-- * Compiler Id
+
-- ------------------------------------------------------------
data CompilerId = CompilerId CompilerFlavor Version
@@ -157,7 +182,7 @@ instance NFData CompilerId where rnf = genericRnf
instance Pretty CompilerId where
pretty (CompilerId f v)
| v == nullVersion = pretty f
- | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v
+ | otherwise = pretty f <<>> Disp.char '-' <<>> pretty v
instance Parsec CompilerId where
parsec = do
@@ -169,28 +194,29 @@ lowercase :: String -> String
lowercase = map toLower
-- ------------------------------------------------------------
+
-- * Compiler Info
+
-- ------------------------------------------------------------
-- | Compiler information used for resolving configurations. Some
-- fields can be set to Nothing to indicate that the information is
-- unknown.
-
-data CompilerInfo = CompilerInfo {
- compilerInfoId :: CompilerId,
- -- ^ Compiler flavour and version.
- compilerInfoAbiTag :: AbiTag,
- -- ^ Tag for distinguishing incompatible ABI's on the same
- -- architecture/os.
- compilerInfoCompat :: Maybe [CompilerId],
- -- ^ Other implementations that this compiler claims to be
- -- compatible with, if known.
- compilerInfoLanguages :: Maybe [Language],
- -- ^ Supported language standards, if known.
- compilerInfoExtensions :: Maybe [Extension]
- -- ^ Supported extensions, if known.
- }
- deriving (Generic, Show, Read)
+data CompilerInfo = CompilerInfo
+ { compilerInfoId :: CompilerId
+ -- ^ Compiler flavour and version.
+ , compilerInfoAbiTag :: AbiTag
+ -- ^ Tag for distinguishing incompatible ABI's on the same
+ -- architecture/os.
+ , compilerInfoCompat :: Maybe [CompilerId]
+ -- ^ Other implementations that this compiler claims to be
+ -- compatible with, if known.
+ , compilerInfoLanguages :: Maybe [Language]
+ -- ^ Supported language standards, if known.
+ , compilerInfoExtensions :: Maybe [Extension]
+ -- ^ Supported extensions, if known.
+ }
+ deriving (Generic, Show, Read)
instance Binary CompilerInfo
@@ -203,7 +229,7 @@ instance Binary AbiTag
instance Structured AbiTag
instance Pretty AbiTag where
- pretty NoAbiTag = Disp.empty
+ pretty NoAbiTag = Disp.empty
pretty (AbiTag tag) = Disp.text tag
instance Parsec AbiTag where
@@ -212,7 +238,7 @@ instance Parsec AbiTag where
if null tag then return NoAbiTag else return (AbiTag tag)
abiTagString :: AbiTag -> String
-abiTagString NoAbiTag = ""
+abiTagString NoAbiTag = ""
abiTagString (AbiTag tag) = tag
-- | Make a CompilerInfo of which only the known information is its CompilerId,
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs
index f75cea2a5e0a5ea00a192f9da583ae9d33dedf67..e41dd6350c2a8ebcff171c6707b8a8fbb0762a24 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs
@@ -1,34 +1,38 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
-- | This module provides a way to specify a grammar of @.cabal@ -like files.
-module Distribution.FieldGrammar (
- -- * Field grammar type
- FieldGrammar (..),
- uniqueField,
- optionalField,
- optionalFieldDef,
- monoidalField,
+module Distribution.FieldGrammar
+ ( -- * Field grammar type
+ FieldGrammar (..)
+ , uniqueField
+ , optionalField
+ , optionalFieldDef
+ , monoidalField
+
-- * Concrete grammar implementations
- ParsecFieldGrammar,
- ParsecFieldGrammar',
- parseFieldGrammar,
- fieldGrammarKnownFieldList,
- PrettyFieldGrammar,
- PrettyFieldGrammar',
- prettyFieldGrammar,
+ , ParsecFieldGrammar
+ , ParsecFieldGrammar'
+ , parseFieldGrammar
+ , fieldGrammarKnownFieldList
+ , PrettyFieldGrammar
+ , PrettyFieldGrammar'
+ , prettyFieldGrammar
+
-- * Auxiliary
- (^^^),
- Section(..),
- Fields,
- partitionFields,
- takeFields,
- runFieldParser,
- runFieldParser',
- defaultFreeTextFieldDefST,
+ , (^^^)
+ , Section (..)
+ , Fields
+ , partitionFields
+ , takeFields
+ , runFieldParser
+ , runFieldParser'
+ , defaultFreeTextFieldDefST
+
-- * Newtypes
- module Distribution.FieldGrammar.Newtypes,
- ) where
+ , module Distribution.FieldGrammar.Newtypes
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -40,7 +44,7 @@ import Distribution.FieldGrammar.Newtypes
import Distribution.FieldGrammar.Parsec
import Distribution.FieldGrammar.Pretty
import Distribution.Fields.Field
-import Distribution.Utils.Generic (spanMaybe)
+import Distribution.Utils.Generic (spanMaybe)
type ParsecFieldGrammar' a = ParsecFieldGrammar a a
type PrettyFieldGrammar' a = PrettyFieldGrammar a a
@@ -66,17 +70,18 @@ partitionFields = finalize . foldl' f (PS mempty mempty mempty)
where
finalize :: PS ann -> (Fields ann, [[Section ann]])
finalize (PS fs s ss)
- | null s = (fs, reverse ss)
- | otherwise = (fs, reverse (reverse s : ss))
+ | null s = (fs, reverse ss)
+ | otherwise = (fs, reverse (reverse s : ss))
f :: PS ann -> Field ann -> PS ann
f (PS fs s ss) (Field (Name ann name) fss) =
- PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
+ PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
where
- ss' | null s = ss
- | otherwise = reverse s : ss
+ ss'
+ | null s = ss
+ | otherwise = reverse s : ss
f (PS fs s ss) (Section name sargs sfields) =
- PS fs (MkSection name sargs sfields : s) ss
+ PS fs (MkSection name sargs sfields : s) ss
-- | Take all fields from the front.
takeFields :: [Field ann] -> (Fields ann, [Field ann])
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs
index 9d8dbf3a647785c1ce48986adf6e8c645cdbcc21..df8b69414f2d5d932bdb3812826421a254673e99 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs
@@ -1,24 +1,25 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableSuperClasses #-}
-module Distribution.FieldGrammar.Class (
- FieldGrammar (..),
- uniqueField,
- optionalField,
- optionalFieldDef,
- monoidalField,
- defaultFreeTextFieldDefST,
-) where
+
+module Distribution.FieldGrammar.Class
+ ( FieldGrammar (..)
+ , uniqueField
+ , optionalField
+ , optionalFieldDef
+ , monoidalField
+ , defaultFreeTextFieldDefST
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.CabalSpecVersion (CabalSpecVersion)
-import Distribution.Compat.Newtype (Newtype)
+import Distribution.CabalSpecVersion (CabalSpecVersion)
+import Distribution.Compat.Newtype (Newtype)
import Distribution.FieldGrammar.Newtypes
import Distribution.Fields.Field
import Distribution.Utils.ShortText
@@ -31,171 +32,213 @@ import Distribution.Utils.ShortText
-- * @a@ type of the field.
--
-- /Note:/ We'd like to have @forall s. Applicative (f s)@ context.
---
class
- ( c SpecVersion, c TestedWith, c SpecLicense, c Token, c Token', c FilePathNT
- )
- => FieldGrammar c g | g -> c
+ ( c SpecVersion
+ , c TestedWith
+ , c SpecLicense
+ , c Token
+ , c Token'
+ , c FilePathNT
+ ) =>
+ FieldGrammar c g
+ | g -> c
where
- -- | Unfocus, zoom out, /blur/ 'FieldGrammar'.
- blurFieldGrammar :: ALens' a b -> g b d -> g a d
-
- -- | Field which should be defined, exactly once.
- uniqueFieldAla
- :: (c b, Newtype a b)
- => FieldName -- ^ field name
- -> (a -> b) -- ^ 'Newtype' pack
- -> ALens' s a -- ^ lens into the field
- -> g s a
-
- -- | Boolean field with a default value.
- booleanFieldDef
- :: FieldName -- ^ field name
- -> ALens' s Bool -- ^ lens into the field
- -> Bool -- ^ default
- -> g s Bool
-
- -- | Optional field.
- optionalFieldAla
- :: (c b, Newtype a b)
- => FieldName -- ^ field name
- -> (a -> b) -- ^ 'pack'
- -> ALens' s (Maybe a) -- ^ lens into the field
- -> g s (Maybe a)
-
- -- | Optional field with default value.
- optionalFieldDefAla
- :: (c b, Newtype a b, Eq a)
- => FieldName -- ^ field name
- -> (a -> b) -- ^ 'Newtype' pack
- -> ALens' s a -- ^ @'Lens'' s a@: lens into the field
- -> a -- ^ default value
- -> g s a
-
- -- | Free text field is essentially 'optionalFieldDefAla` with @""@
- -- as the default and "accept everything" parser.
- --
- -- @since 3.0.0.0
- freeTextField
- :: FieldName
- -> ALens' s (Maybe String) -- ^ lens into the field
- -> g s (Maybe String)
-
- -- | Free text field is essentially 'optionalFieldDefAla` with @""@
- -- as the default and "accept everything" parser.
- --
- -- @since 3.0.0.0
- freeTextFieldDef
- :: FieldName
- -> ALens' s String -- ^ lens into the field
- -> g s String
-
- -- | @since 3.2.0.0
- freeTextFieldDefST
- :: FieldName
- -> ALens' s ShortText -- ^ lens into the field
- -> g s ShortText
-
- -- | Monoidal field.
- --
- -- Values are combined with 'mappend'.
- --
- -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
- --
- monoidalFieldAla
- :: (c b, Monoid a, Newtype a b)
- => FieldName -- ^ field name
- -> (a -> b) -- ^ 'pack'
- -> ALens' s a -- ^ lens into the field
- -> g s a
-
- -- | Parser matching all fields with a name starting with a prefix.
- prefixedFields
- :: FieldName -- ^ field name prefix
- -> ALens' s [(String, String)] -- ^ lens into the field
- -> g s [(String, String)]
-
- -- | Known field, which we don't parse, nor pretty print.
- knownField :: FieldName -> g s ()
-
- -- | Field which is parsed but not pretty printed.
- hiddenField :: g s a -> g s a
-
- -- | Deprecated since
- deprecatedSince
- :: CabalSpecVersion -- ^ version
- -> String -- ^ deprecation message
- -> g s a
- -> g s a
-
- -- | Removed in. If we encounter removed field, parsing fails.
- removedIn
- :: CabalSpecVersion -- ^ version
- -> String -- ^ removal message
- -> g s a
- -> g s a
-
- -- | Annotate field with since spec-version.
- availableSince
- :: CabalSpecVersion -- ^ spec version
- -> a -- ^ default value
- -> g s a
- -> g s a
-
- -- | Annotate field with since spec-version.
- -- This is used to recognise, but warn about the field.
- -- It is used to process @other-extensions@ field.
- --
- -- Default implementation is to not warn.
- --
- -- @since 3.4.0.0
- availableSinceWarn
- :: CabalSpecVersion -- ^ spec version
- -> g s a
- -> g s a
- availableSinceWarn _ = id
+ -- | Unfocus, zoom out, /blur/ 'FieldGrammar'.
+ blurFieldGrammar :: ALens' a b -> g b d -> g a d
+
+ -- | Field which should be defined, exactly once.
+ uniqueFieldAla
+ :: (c b, Newtype a b)
+ => FieldName
+ -- ^ field name
+ -> (a -> b)
+ -- ^ 'Newtype' pack
+ -> ALens' s a
+ -- ^ lens into the field
+ -> g s a
+
+ -- | Boolean field with a default value.
+ booleanFieldDef
+ :: FieldName
+ -- ^ field name
+ -> ALens' s Bool
+ -- ^ lens into the field
+ -> Bool
+ -- ^ default
+ -> g s Bool
+
+ -- | Optional field.
+ optionalFieldAla
+ :: (c b, Newtype a b)
+ => FieldName
+ -- ^ field name
+ -> (a -> b)
+ -- ^ 'pack'
+ -> ALens' s (Maybe a)
+ -- ^ lens into the field
+ -> g s (Maybe a)
+
+ -- | Optional field with default value.
+ optionalFieldDefAla
+ :: (c b, Newtype a b, Eq a)
+ => FieldName
+ -- ^ field name
+ -> (a -> b)
+ -- ^ 'Newtype' pack
+ -> ALens' s a
+ -- ^ @'Lens'' s a@: lens into the field
+ -> a
+ -- ^ default value
+ -> g s a
+
+ -- | Free text field is essentially 'optionalFieldDefAla` with @""@
+ -- as the default and "accept everything" parser.
+ --
+ -- @since 3.0.0.0
+ freeTextField
+ :: FieldName
+ -> ALens' s (Maybe String)
+ -- ^ lens into the field
+ -> g s (Maybe String)
+
+ -- | Free text field is essentially 'optionalFieldDefAla` with @""@
+ -- as the default and "accept everything" parser.
+ --
+ -- @since 3.0.0.0
+ freeTextFieldDef
+ :: FieldName
+ -> ALens' s String
+ -- ^ lens into the field
+ -> g s String
+
+ -- | @since 3.2.0.0
+ freeTextFieldDefST
+ :: FieldName
+ -> ALens' s ShortText
+ -- ^ lens into the field
+ -> g s ShortText
+
+ -- | Monoidal field.
+ --
+ -- Values are combined with 'mappend'.
+ --
+ -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
+ monoidalFieldAla
+ :: (c b, Monoid a, Newtype a b)
+ => FieldName
+ -- ^ field name
+ -> (a -> b)
+ -- ^ 'pack'
+ -> ALens' s a
+ -- ^ lens into the field
+ -> g s a
+
+ -- | Parser matching all fields with a name starting with a prefix.
+ prefixedFields
+ :: FieldName
+ -- ^ field name prefix
+ -> ALens' s [(String, String)]
+ -- ^ lens into the field
+ -> g s [(String, String)]
+
+ -- | Known field, which we don't parse, nor pretty print.
+ knownField :: FieldName -> g s ()
+
+ -- | Field which is parsed but not pretty printed.
+ hiddenField :: g s a -> g s a
+
+ -- | Deprecated since
+ deprecatedSince
+ :: CabalSpecVersion
+ -- ^ version
+ -> String
+ -- ^ deprecation message
+ -> g s a
+ -> g s a
+
+ -- | Removed in. If we encounter removed field, parsing fails.
+ removedIn
+ :: CabalSpecVersion
+ -- ^ version
+ -> String
+ -- ^ removal message
+ -> g s a
+ -> g s a
+
+ -- | Annotate field with since spec-version.
+ availableSince
+ :: CabalSpecVersion
+ -- ^ spec version
+ -> a
+ -- ^ default value
+ -> g s a
+ -> g s a
+
+ -- | Annotate field with since spec-version.
+ -- This is used to recognise, but warn about the field.
+ -- It is used to process @other-extensions@ field.
+ --
+ -- Default implementation is to not warn.
+ --
+ -- @since 3.4.0.0
+ availableSinceWarn
+ :: CabalSpecVersion
+ -- ^ spec version
+ -> g s a
+ -> g s a
+ availableSinceWarn _ = id
-- | Field which can be defined at most once.
uniqueField
- :: (FieldGrammar c g, c (Identity a))
- => FieldName -- ^ field name
- -> ALens' s a -- ^ lens into the field
- -> g s a
+ :: (FieldGrammar c g, c (Identity a))
+ => FieldName
+ -- ^ field name
+ -> ALens' s a
+ -- ^ lens into the field
+ -> g s a
uniqueField fn l = uniqueFieldAla fn Identity l
-- | Field which can be defined at most once.
optionalField
- :: (FieldGrammar c g, c (Identity a))
- => FieldName -- ^ field name
- -> ALens' s (Maybe a) -- ^ lens into the field
- -> g s (Maybe a)
+ :: (FieldGrammar c g, c (Identity a))
+ => FieldName
+ -- ^ field name
+ -> ALens' s (Maybe a)
+ -- ^ lens into the field
+ -> g s (Maybe a)
optionalField fn l = optionalFieldAla fn Identity l
-- | Optional field with default value.
optionalFieldDef
- :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a)
- => FieldName -- ^ field name
- -> ALens' s a -- ^ @'Lens'' s a@: lens into the field
- -> a -- ^ default value
- -> g s a
+ :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a)
+ => FieldName
+ -- ^ field name
+ -> ALens' s a
+ -- ^ @'Lens'' s a@: lens into the field
+ -> a
+ -- ^ default value
+ -> g s a
optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x
-- | Field which can be define multiple times, and the results are @mappend@ed.
monoidalField
- :: (FieldGrammar c g, c (Identity a), Monoid a)
- => FieldName -- ^ field name
- -> ALens' s a -- ^ lens into the field
- -> g s a
+ :: (FieldGrammar c g, c (Identity a), Monoid a)
+ => FieldName
+ -- ^ field name
+ -> ALens' s a
+ -- ^ lens into the field
+ -> g s a
monoidalField fn l = monoidalFieldAla fn Identity l
-- | Default implementation for 'freeTextFieldDefST'.
defaultFreeTextFieldDefST
- :: (Functor (g s), FieldGrammar c g)
- => FieldName
- -> ALens' s ShortText -- ^ lens into the field
- -> g s ShortText
+ :: (Functor (g s), FieldGrammar c g)
+ => FieldName
+ -> ALens' s ShortText
+ -- ^ lens into the field
+ -> g s ShortText
defaultFreeTextFieldDefST fn l =
- toShortText <$> freeTextFieldDef fn (cloneLens l . st)
+ toShortText <$> freeTextFieldDef fn (cloneLens l . st)
where
st :: Lens' ShortText String
st f s = toShortText <$> f (fromShortText s)
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs
index efb6d368f95c58b7edc0b76f854a7b255ec6342f..e03ae749570f38a4db902c258387d8179919f828 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs
@@ -1,43 +1,44 @@
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE UndecidableInstances #-}
-module Distribution.FieldGrammar.FieldDescrs (
- FieldDescrs,
- fieldDescrPretty,
- fieldDescrParse,
- fieldDescrsToList,
- ) where
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Distribution.FieldGrammar.FieldDescrs
+ ( FieldDescrs
+ , fieldDescrPretty
+ , fieldDescrParse
+ , fieldDescrsToList
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Compat.Lens (aview, cloneLens)
-import Distribution.Utils.String (trim)
+import Distribution.Compat.Lens (aview, cloneLens)
import Distribution.Compat.Newtype
import Distribution.FieldGrammar
-import Distribution.Pretty (Pretty (..), showFreeText)
+import Distribution.Pretty (Pretty (..), showFreeText)
+import Distribution.Utils.String (trim)
-import qualified Data.Map as Map
+import qualified Data.Map as Map
import qualified Distribution.Compat.CharParsing as C
-import qualified Distribution.Fields as P
-import qualified Distribution.Parsec as P
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.Fields as P
+import qualified Distribution.Parsec as P
+import qualified Text.PrettyPrint as Disp
-- strict pair
data SP s = SP
- { pPretty :: !(s -> Disp.Doc)
- , pParse :: !(forall m. P.CabalParsing m => s -> m s)
- }
+ { pPretty :: !(s -> Disp.Doc)
+ , pParse :: !(forall m. P.CabalParsing m => s -> m s)
+ }
-- | A collection of field parsers and pretty-printers.
-newtype FieldDescrs s a = F { runF :: Map P.FieldName (SP s) }
+newtype FieldDescrs s a = F {runF :: Map P.FieldName (SP s)}
deriving (Functor)
instance Applicative (FieldDescrs s) where
- pure _ = F mempty
- f <*> x = F (mappend (runF f) (runF x))
+ pure _ = F mempty
+ f <*> x = F (mappend (runF f) (runF x))
singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a
singletonF fn f g = F $ Map.singleton fn (SP f g)
@@ -51,54 +52,64 @@ fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (
fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m
fieldDescrsToList
- :: P.CabalParsing m
- => FieldDescrs s a
- -> [(P.FieldName, s -> Disp.Doc, s -> m s)]
-fieldDescrsToList = map mk . Map.toList . runF where
+ :: P.CabalParsing m
+ => FieldDescrs s a
+ -> [(P.FieldName, s -> Disp.Doc, s -> m s)]
+fieldDescrsToList = map mk . Map.toList . runF
+ where
mk (name, SP ppr parse) = (name, ppr, parse)
-- | /Note:/ default values are printed.
instance FieldGrammar ParsecPretty FieldDescrs where
- blurFieldGrammar l (F m) = F (fmap blur m) where
- blur (SP f g) = SP (f . aview l) (cloneLens l g)
-
- booleanFieldDef fn l _def = singletonF fn f g where
- f s = Disp.text (show (aview l s))
- g s = cloneLens l (const P.parsec) s
- -- Note: eta expansion is needed for RankNTypes type-checking to work.
-
- uniqueFieldAla fn _pack l = singletonF fn f g where
- f s = pretty (pack' _pack (aview l s))
- g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
-
- optionalFieldAla fn _pack l = singletonF fn f g where
- f s = maybe mempty (pretty . pack' _pack) (aview l s)
- g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s
-
- optionalFieldDefAla fn _pack l _def = singletonF fn f g where
- f s = pretty (pack' _pack (aview l s))
- g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
-
- freeTextField fn l = singletonF fn f g where
- f s = maybe mempty showFreeText (aview l s)
- g s = cloneLens l (const (Just <$> parsecFreeText)) s
-
- freeTextFieldDef fn l = singletonF fn f g where
- f s = showFreeText (aview l s)
- g s = cloneLens l (const parsecFreeText) s
-
- freeTextFieldDefST = defaultFreeTextFieldDefST
-
- monoidalFieldAla fn _pack l = singletonF fn f g where
- f s = pretty (pack' _pack (aview l s))
- g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s
-
- prefixedFields _fnPfx _l = F mempty
- knownField _ = pure ()
- deprecatedSince _ _ x = x
- removedIn _ _ x = x
- availableSince _ _ = id
- hiddenField _ = F mempty
+ blurFieldGrammar l (F m) = F (fmap blur m)
+ where
+ blur (SP f g) = SP (f . aview l) (cloneLens l g)
+
+ booleanFieldDef fn l _def = singletonF fn f g
+ where
+ f s = Disp.text (show (aview l s))
+ g s = cloneLens l (const P.parsec) s
+
+ -- Note: eta expansion is needed for RankNTypes type-checking to work.
+
+ uniqueFieldAla fn _pack l = singletonF fn f g
+ where
+ f s = pretty (pack' _pack (aview l s))
+ g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
+
+ optionalFieldAla fn _pack l = singletonF fn f g
+ where
+ f s = maybe mempty (pretty . pack' _pack) (aview l s)
+ g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s
+
+ optionalFieldDefAla fn _pack l _def = singletonF fn f g
+ where
+ f s = pretty (pack' _pack (aview l s))
+ g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
+
+ freeTextField fn l = singletonF fn f g
+ where
+ f s = maybe mempty showFreeText (aview l s)
+ g s = cloneLens l (const (Just <$> parsecFreeText)) s
+
+ freeTextFieldDef fn l = singletonF fn f g
+ where
+ f s = showFreeText (aview l s)
+ g s = cloneLens l (const parsecFreeText) s
+
+ freeTextFieldDefST = defaultFreeTextFieldDefST
+
+ monoidalFieldAla fn _pack l = singletonF fn f g
+ where
+ f s = pretty (pack' _pack (aview l s))
+ g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s
+
+ prefixedFields _fnPfx _l = F mempty
+ knownField _ = pure ()
+ deprecatedSince _ _ x = x
+ removedIn _ _ x = x
+ availableSince _ _ = id
+ hiddenField _ = F mempty
parsecFreeText :: P.CabalParsing m => m String
parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar
@@ -109,11 +120,10 @@ parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar
dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x
dotToEmpty x | trim' x == "." = ""
- dotToEmpty x = trim x
+ dotToEmpty x = trim x
trim' :: String -> String
trim' = dropWhileEnd (`elem` (" \t" :: String))
-
-class (P.Parsec a, Pretty a) => ParsecPretty a
+class (P.Parsec a, Pretty a) => ParsecPretty a
instance (P.Parsec a, Pretty a) => ParsecPretty a
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs
index 9ec51e7032cbfef7fb482f97cf4ef8764319e185..f823d3d63e5ff236fbc1522a9a84893a08481c3d 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs
@@ -1,60 +1,77 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar".
-module Distribution.FieldGrammar.Newtypes (
- -- * List
- alaList,
- alaList',
+module Distribution.FieldGrammar.Newtypes
+ ( -- * List
+ alaList
+ , alaList'
+
-- ** Modifiers
- CommaVCat (..),
- CommaFSep (..),
- VCat (..),
- FSep (..),
- NoCommaFSep (..),
- Sep (..),
+ , CommaVCat (..)
+ , CommaFSep (..)
+ , VCat (..)
+ , FSep (..)
+ , NoCommaFSep (..)
+ , Sep (..)
+
-- ** Type
- List,
+ , List
+
-- ** Set
- alaSet,
- alaSet',
- Set',
+ , alaSet
+ , alaSet'
+ , Set'
+
-- ** NonEmpty
- alaNonEmpty,
- alaNonEmpty',
- NonEmpty',
+ , alaNonEmpty
+ , alaNonEmpty'
+ , NonEmpty'
+
-- * Version & License
- SpecVersion (..),
- TestedWith (..),
- SpecLicense (..),
+ , SpecVersion (..)
+ , TestedWith (..)
+ , SpecLicense (..)
+
-- * Identifiers
- Token (..),
- Token' (..),
- MQuoted (..),
- FilePathNT (..),
- ) where
+ , Token (..)
+ , Token' (..)
+ , MQuoted (..)
+ , FilePathNT (..)
+ ) where
import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.CabalSpecVersion
-import Distribution.Compiler (CompilerFlavor)
-import Distribution.License (License)
+import Distribution.Compiler (CompilerFlavor)
+import Distribution.License (License)
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Version
- (LowerBound (..), Version, VersionInterval (..), VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion,
- version0, versionNumbers)
-import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat)
-
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Set as Set
+ ( LowerBound (..)
+ , Version
+ , VersionInterval (..)
+ , VersionRange
+ , VersionRangeF (..)
+ , anyVersion
+ , asVersionIntervals
+ , cataVersionRange
+ , mkVersion
+ , version0
+ , versionNumbers
+ )
+import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat)
+
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Set as Set
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.SPDX as SPDX
+import qualified Distribution.SPDX as SPDX
-- | Vertical list with commas. Displayed with 'vcat'
data CommaVCat = CommaVCat
@@ -71,48 +88,48 @@ data FSep = FSep
-- | Paragraph fill list without commas. Displayed with 'fsep'.
data NoCommaFSep = NoCommaFSep
-class Sep sep where
- prettySep :: Proxy sep -> [Doc] -> Doc
+class Sep sep where
+ prettySep :: Proxy sep -> [Doc] -> Doc
- parseSep :: CabalParsing m => Proxy sep -> m a -> m [a]
- parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a)
+ parseSep :: CabalParsing m => Proxy sep -> m a -> m [a]
+ parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a)
instance Sep CommaVCat where
- prettySep _ = vcat . punctuate comma
- parseSep _ p = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
- parseSepNE _ p = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
+ prettySep _ = vcat . punctuate comma
+ parseSep _ p = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
+ parseSepNE _ p = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
instance Sep CommaFSep where
- prettySep _ = fsep . punctuate comma
- parseSep _ p = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
- parseSepNE _ p = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
+ prettySep _ = fsep . punctuate comma
+ parseSep _ p = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
+ parseSepNE _ p = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
instance Sep VCat where
- prettySep _ = vcat
- parseSep _ p = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
- parseSepNE _ p = NE.some1 (p <* P.spaces)
+ prettySep _ = vcat
+ parseSep _ p = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
+ parseSepNE _ p = NE.some1 (p <* P.spaces)
instance Sep FSep where
- prettySep _ = fsep
- parseSep _ p = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
- parseSepNE _ p = NE.some1 (p <* P.spaces)
+ prettySep _ = fsep
+ parseSep _ p = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
+ parseSepNE _ p = NE.some1 (p <* P.spaces)
instance Sep NoCommaFSep where
- prettySep _ = fsep
- parseSep _ p = many (p <* P.spaces)
- parseSepNE _ p = NE.some1 (p <* P.spaces)
+ prettySep _ = fsep
+ parseSep _ p = many (p <* P.spaces)
+ parseSepNE _ p = NE.some1 (p <* P.spaces)
-- | List separated with optional commas. Displayed with @sep@, arguments of
-- type @a@ are parsed and pretty-printed as @b@.
-newtype List sep b a = List { _getList :: [a] }
+newtype List sep b a = List {_getList :: [a]}
-- | 'alaList' and 'alaList'' are simply 'List', with additional phantom
-- arguments to constrain the resulting type
@@ -122,7 +139,6 @@ newtype List sep b a = List { _getList :: [a] }
--
-- >>> :t alaList' FSep Token
-- alaList' FSep Token :: [String] -> List FSep Token String
---
alaList :: sep -> [a] -> List sep (Identity a) a
alaList _ = List
@@ -133,16 +149,17 @@ alaList' _ _ = List
instance Newtype [a] (List sep wrapper a)
instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where
- parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec
+ parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec
instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where
- pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack
+ pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack
--
+
-- | Like 'List', but for 'Set'.
--
-- @since 3.2.0.0
-newtype Set' sep b a = Set' { _getSet :: Set a }
+newtype Set' sep b a = Set' {_getSet :: Set a}
-- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom
-- arguments to constrain the resulting type
@@ -169,16 +186,17 @@ alaSet' _ _ = Set'
instance Newtype (Set a) (Set' sep wrapper a)
instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where
- parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec
+ parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec
instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where
- pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack
+ pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack
--
+
-- | Like 'List', but for 'NonEmpty'.
--
-- @since 3.2.0.0
-newtype NonEmpty' sep b a = NonEmpty' { _getNonEmpty :: NonEmpty a }
+newtype NonEmpty' sep b a = NonEmpty' {_getNonEmpty :: NonEmpty a}
-- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom
-- arguments to constrain the resulting type
@@ -202,62 +220,62 @@ alaNonEmpty' _ _ = NonEmpty'
instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a)
instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where
- parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec
+ parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec
instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where
- pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack
+ pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack
-------------------------------------------------------------------------------
-- Identifiers
-------------------------------------------------------------------------------
-- | Haskell string or @[^ ,]+@
-newtype Token = Token { getToken :: String }
+newtype Token = Token {getToken :: String}
instance Newtype String Token
instance Parsec Token where
- parsec = pack <$> parsecToken
+ parsec = pack <$> parsecToken
instance Pretty Token where
- pretty = showToken . unpack
+ pretty = showToken . unpack
-- | Haskell string or @[^ ]+@
-newtype Token' = Token' { getToken' :: String }
+newtype Token' = Token' {getToken' :: String}
instance Newtype String Token'
instance Parsec Token' where
- parsec = pack <$> parsecToken'
+ parsec = pack <$> parsecToken'
instance Pretty Token' where
- pretty = showToken . unpack
+ pretty = showToken . unpack
-- | Either @"quoted"@ or @un-quoted@.
-newtype MQuoted a = MQuoted { getMQuoted :: a }
+newtype MQuoted a = MQuoted {getMQuoted :: a}
instance Newtype a (MQuoted a)
instance Parsec a => Parsec (MQuoted a) where
- parsec = pack <$> parsecMaybeQuoted parsec
+ parsec = pack <$> parsecMaybeQuoted parsec
-instance Pretty a => Pretty (MQuoted a) where
- pretty = pretty . unpack
+instance Pretty a => Pretty (MQuoted a) where
+ pretty = pretty . unpack
-- | Filepath are parsed as 'Token'.
-newtype FilePathNT = FilePathNT { getFilePathNT :: String }
+newtype FilePathNT = FilePathNT {getFilePathNT :: String}
instance Newtype String FilePathNT
instance Parsec FilePathNT where
- parsec = do
- token <- parsecToken
- if null token
- then P.unexpected "empty FilePath"
- else return (FilePathNT token)
+ parsec = do
+ token <- parsecToken
+ if null token
+ then P.unexpected "empty FilePath"
+ else return (FilePathNT token)
instance Pretty FilePathNT where
- pretty = showFilePath . unpack
+ pretty = showFilePath . unpack
-------------------------------------------------------------------------------
-- SpecVersion
@@ -275,119 +293,124 @@ instance Pretty FilePathNT where
-- We have this newtype, as writing Parsec and Pretty instances
-- for CabalSpecVersion would cause cycle in modules:
-- Version -> CabalSpecVersion -> Parsec -> ...
---
-newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion }
+newtype SpecVersion = SpecVersion {getSpecVersion :: CabalSpecVersion}
deriving (Eq, Show) -- instances needed for tests
instance Newtype CabalSpecVersion SpecVersion
instance Parsec SpecVersion where
- parsec = do
- e <- parsecSpecVersion
- let ver :: Version
- ver = either id specVersionFromRange e
-
- digits :: [Int]
- digits = versionNumbers ver
-
- case cabalSpecFromVersionDigits digits of
- Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver
- Just csv -> do
- -- Check some warnings:
- case e of
- -- example: cabal-version: 1.10
- -- should be cabal-version: >=1.10
- Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat
- [ "With 1.10 or earlier, the 'cabal-version' field must use "
- , "range syntax rather than a simple version number. Use "
- , "'cabal-version: >= " ++ prettyShow ver ++ "'."
- ]
-
- -- example: cabal-version: >=1.12
- -- should be cabal-version: 1.12
- Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat
- [ "Packages with 'cabal-version: 1.12' or later should specify a "
- , "specific version of the Cabal spec of the form "
- , "'cabal-version: x.y'. "
- , "Use 'cabal-version: " ++ prettyShow ver ++ "'."
- ]
-
- -- example: cabal-version: >=1.10 && <1.12
- -- should be cabal-version: >=1.10
- Right vr | csv < CabalSpecV1_12
- , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat
- [ "It is recommended that the 'cabal-version' field only specify a "
- , "version range of the form '>= x.y' for older cabal versions. Use "
- , "'cabal-version: >= " ++ prettyShow ver ++ "'. "
- , "Tools based on Cabal 1.10 and later will ignore upper bounds."
- ]
-
- -- otherwise no warnings
- _ -> pure ()
-
- return (pack csv)
- where
- parsecSpecVersion = Left <$> parsec <|> Right <$> range
-
- range = do
- vr <- parsec
- if specVersionFromRange vr >= mkVersion [2,1]
- then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899"
- else return vr
-
- specVersionFromRange :: VersionRange -> Version
- specVersionFromRange versionRange = case asVersionIntervals versionRange of
- [] -> version0
- VersionInterval (LowerBound version _) _ : _ -> version
-
- simpleSpecVersionRangeSyntax = cataVersionRange alg where
- alg (OrLaterVersionF _) = True
- alg _ = False
-
+ parsec = do
+ e <- parsecSpecVersion
+ let ver :: Version
+ ver = either id specVersionFromRange e
+
+ digits :: [Int]
+ digits = versionNumbers ver
+
+ case cabalSpecFromVersionDigits digits of
+ Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver
+ Just csv -> do
+ -- Check some warnings:
+ case e of
+ -- example: cabal-version: 1.10
+ -- should be cabal-version: >=1.10
+ Left _v
+ | csv < CabalSpecV1_12 ->
+ parsecWarning PWTSpecVersion $
+ concat
+ [ "With 1.10 or earlier, the 'cabal-version' field must use "
+ , "range syntax rather than a simple version number. Use "
+ , "'cabal-version: >= " ++ prettyShow ver ++ "'."
+ ]
+ -- example: cabal-version: >=1.12
+ -- should be cabal-version: 1.12
+ Right _vr
+ | csv >= CabalSpecV1_12 ->
+ parsecWarning PWTSpecVersion $
+ concat
+ [ "Packages with 'cabal-version: 1.12' or later should specify a "
+ , "specific version of the Cabal spec of the form "
+ , "'cabal-version: x.y'. "
+ , "Use 'cabal-version: " ++ prettyShow ver ++ "'."
+ ]
+ -- example: cabal-version: >=1.10 && <1.12
+ -- should be cabal-version: >=1.10
+ Right vr
+ | csv < CabalSpecV1_12
+ , not (simpleSpecVersionRangeSyntax vr) ->
+ parsecWarning PWTSpecVersion $
+ concat
+ [ "It is recommended that the 'cabal-version' field only specify a "
+ , "version range of the form '>= x.y' for older cabal versions. Use "
+ , "'cabal-version: >= " ++ prettyShow ver ++ "'. "
+ , "Tools based on Cabal 1.10 and later will ignore upper bounds."
+ ]
+ -- otherwise no warnings
+ _ -> pure ()
+
+ return (pack csv)
+ where
+ parsecSpecVersion = Left <$> parsec <|> Right <$> range
+
+ range = do
+ vr <- parsec
+ if specVersionFromRange vr >= mkVersion [2, 1]
+ then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899"
+ else return vr
+
+ specVersionFromRange :: VersionRange -> Version
+ specVersionFromRange versionRange = case asVersionIntervals versionRange of
+ [] -> version0
+ VersionInterval (LowerBound version _) _ : _ -> version
+
+ simpleSpecVersionRangeSyntax = cataVersionRange alg
+ where
+ alg (OrLaterVersionF _) = True
+ alg _ = False
instance Pretty SpecVersion where
- pretty (SpecVersion csv)
- | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv)
- | otherwise = text ">=" <<>> text (showCabalSpecVersion csv)
+ pretty (SpecVersion csv)
+ | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv)
+ | otherwise = text ">=" <<>> text (showCabalSpecVersion csv)
-------------------------------------------------------------------------------
-- SpecLicense
-------------------------------------------------------------------------------
-- | SPDX License expression or legacy license
-newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License }
- deriving (Show, Eq)
+newtype SpecLicense = SpecLicense {getSpecLicense :: Either SPDX.License License}
+ deriving (Show, Eq)
instance Newtype (Either SPDX.License License) SpecLicense
instance Parsec SpecLicense where
- parsec = do
- v <- askCabalSpecVersion
- if v >= CabalSpecV2_2
- then SpecLicense . Left <$> parsec
- else SpecLicense . Right <$> parsec
+ parsec = do
+ v <- askCabalSpecVersion
+ if v >= CabalSpecV2_2
+ then SpecLicense . Left <$> parsec
+ else SpecLicense . Right <$> parsec
instance Pretty SpecLicense where
- pretty = either pretty pretty . unpack
+ pretty = either pretty pretty . unpack
-------------------------------------------------------------------------------
-- TestedWith
-------------------------------------------------------------------------------
-- | Version range or just version
-newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) }
+newtype TestedWith = TestedWith {getTestedWith :: (CompilerFlavor, VersionRange)}
instance Newtype (CompilerFlavor, VersionRange) TestedWith
instance Parsec TestedWith where
- parsec = pack <$> parsecTestedWith
+ parsec = pack <$> parsecTestedWith
instance Pretty TestedWith where
- pretty x = case unpack x of
- (compiler, vr) -> pretty compiler <+> pretty vr
+ pretty x = case unpack x of
+ (compiler, vr) -> pretty compiler <+> pretty vr
parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange)
parsecTestedWith = do
- name <- lexemeParsec
- ver <- parsec <|> pure anyVersion
- return (name, ver)
+ name <- lexemeParsec
+ ver <- parsec <|> pure anyVersion
+ return (name, ver)
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs
index 77a94456acf6e01ab13d3f2d144f5ba098d8ac25..4721aa4ad08d9b1c3e8e315819aed4d139efe991 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- | This module provides a 'FieldGrammarParser', one way to parse
-- @.cabal@ -like files.
--
@@ -50,34 +51,34 @@
-- We can parse 'Fields' like we parse @aeson@ objects, yet we use
-- slightly higher-level API, so we can process unspecified fields,
-- to report unknown fields and save custom @x-fields@.
---
-module Distribution.FieldGrammar.Parsec (
- ParsecFieldGrammar,
- parseFieldGrammar,
- fieldGrammarKnownFieldList,
+module Distribution.FieldGrammar.Parsec
+ ( ParsecFieldGrammar
+ , parseFieldGrammar
+ , fieldGrammarKnownFieldList
+
-- * Auxiliary
- Fields,
- NamelessField (..),
- namelessFieldAnn,
- Section (..),
- runFieldParser,
- runFieldParser',
- fieldLinesToStream,
- ) where
+ , Fields
+ , NamelessField (..)
+ , namelessFieldAnn
+ , Section (..)
+ , runFieldParser
+ , runFieldParser'
+ , fieldLinesToStream
+ ) where
import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
-import Distribution.Utils.Generic (fromUTF8BS)
+import Distribution.Utils.Generic (fromUTF8BS)
import Distribution.Utils.String (trim)
import Prelude ()
-import qualified Data.ByteString as BS
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
+import qualified Data.ByteString as BS
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
import qualified Distribution.Utils.ShortText as ShortText
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Error as P
+import qualified Text.Parsec as P
+import qualified Text.Parsec.Error as P
import Distribution.CabalSpecVersion
import Distribution.FieldGrammar.Class
@@ -85,7 +86,7 @@ import Distribution.Fields.Field
import Distribution.Fields.ParseResult
import Distribution.Parsec
import Distribution.Parsec.FieldLineStream
-import Distribution.Parsec.Position (positionCol, positionRow)
+import Distribution.Parsec.Position (positionCol, positionRow)
-------------------------------------------------------------------------------
-- Auxiliary types
@@ -109,238 +110,240 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
-------------------------------------------------------------------------------
data ParsecFieldGrammar s a = ParsecFG
- { fieldGrammarKnownFields :: !(Set FieldName)
- , fieldGrammarKnownPrefixes :: !(Set FieldName)
- , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
- }
+ { fieldGrammarKnownFields :: !(Set FieldName)
+ , fieldGrammarKnownPrefixes :: !(Set FieldName)
+ , fieldGrammarParser :: !(CabalSpecVersion -> Fields Position -> ParseResult a)
+ }
deriving (Functor)
parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar v fields grammar = do
- for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
- for_ nfields $ \(MkNamelessField pos _) ->
- parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
- -- TODO: fields allowed in this section
-
- -- parse
- fieldGrammarParser grammar v fields
+ for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
+ for_ nfields $ \(MkNamelessField pos _) ->
+ parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
+ -- TODO: fields allowed in this section
+ -- parse
+ fieldGrammarParser grammar v fields
where
- isUnknownField k _ = not $
+ isUnknownField k _ =
+ not $
k `Set.member` fieldGrammarKnownFields grammar
- || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
+ || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields
instance Applicative (ParsecFieldGrammar s) where
- pure x = ParsecFG mempty mempty (\_ _ -> pure x)
- {-# INLINE pure #-}
+ pure x = ParsecFG mempty mempty (\_ _ -> pure x)
+ {-# INLINE pure #-}
- ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG
- (mappend f x)
- (mappend f' x')
- (\v fields -> f'' v fields <*> x'' v fields)
- {-# INLINE (<*>) #-}
+ ParsecFG f f' f'' <*> ParsecFG x x' x'' =
+ ParsecFG
+ (mappend f x)
+ (mappend f' x')
+ (\v fields -> f'' v fields <*> x'' v fields)
+ {-# INLINE (<*>) #-}
warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult ()
warnMultipleSingularFields _ [] = pure ()
warnMultipleSingularFields fn (x : xs) = do
- let pos = namelessFieldAnn x
- poss = map namelessFieldAnn xs
- parseWarning pos PWTMultipleSingularField $
- "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss))
+ let pos = namelessFieldAnn x
+ poss = map namelessFieldAnn xs
+ parseWarning pos PWTMultipleSingularField $
+ "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss))
instance FieldGrammar Parsec ParsecFieldGrammar where
- blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser
-
- uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
- where
- parser v fields = case Map.lookup fn fields of
- Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing"
- Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing"
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls) =
- unpack' _pack <$> runFieldParser pos parsec v fls
-
- booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser
- where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure def
- Just [] -> pure def
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
-
- optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
- where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure Nothing
- Just [] -> pure Nothing
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls)
- | null fls = pure Nothing
- | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls
-
- optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser
- where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure def
- Just [] -> pure def
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls)
- | null fls = pure def
- | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls
-
- freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure Nothing
- Just [] -> pure Nothing
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls)
- | null fls = pure Nothing
- | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls))
- | otherwise = pure (Just (fieldlinesToFreeText fls))
-
- freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure ""
- Just [] -> pure ""
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls)
- | null fls = pure ""
- | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls)
- | otherwise = pure (fieldlinesToFreeText fls)
-
- -- freeTextFieldDefST = defaultFreeTextFieldDefST
- freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure mempty
- Just [] -> pure mempty
- Just [x] -> parseOne v x
- Just xs@(_:y:ys) -> do
- warnMultipleSingularFields fn xs
- NE.last <$> traverse (parseOne v) (y:|ys)
-
- parseOne v (MkNamelessField pos fls) = case fls of
- [] -> pure mempty
- [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs)
- _ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls)
- | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls)
-
- monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
- where
- parser v fields = case Map.lookup fn fields of
- Nothing -> pure mempty
- Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs
-
- parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
-
- prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs))
- where
- parser :: Fields Position -> [(String, String)]
- parser values = reorder $ concatMap convert $ filter match $ Map.toList values
-
- match (fn, _) = fnPfx `BS.isPrefixOf` fn
- convert (fn, fields) =
- [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls))
- | MkNamelessField pos fls <- fields
- ]
- -- hack: recover the order of prefixed fields
- reorder = map snd . sortBy (comparing fst)
-
- availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
- where
- parser' v values
- | v >= vs = parser v values
- | otherwise = do
- let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
- for_ (Map.toList unknownFields) $ \(name, fields) ->
- for_ fields $ \(MkNamelessField pos _) ->
- parseWarning pos PWTUnknownField $
- "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored."
-
- pure def
-
- availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
- where
- parser' v values
- | v >= vs = parser v values
- | otherwise = do
- let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
- for_ (Map.toList unknownFields) $ \(name, fields) ->
- for_ fields $ \(MkNamelessField pos _) ->
- parseWarning pos PWTUnknownField $
- "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "."
-
- parser v values
-
-
- -- todo we know about this field
- deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
- where
- parser' v values
- | v >= vs = do
- let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names
- for_ (Map.toList deprecatedFields) $ \(name, fields) ->
- for_ fields $ \(MkNamelessField pos _) ->
- parseWarning pos PWTDeprecatedField $
- "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg
-
- parser v values
-
- | otherwise = parser v values
-
- removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where
- parser' v values
- | v >= vs = do
- let msg' = if null msg then "" else ' ' : msg
- let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
- let namePos =
- [ (name, pos)
- | (name, fields) <- Map.toList unknownFields
- , MkNamelessField pos _ <- fields
- ]
-
- let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg'
-
- case namePos of
- -- no fields => proceed (with empty values, to be sure)
- [] -> parser v mempty
-
- -- if there's single field: fail fatally with it
- ((name, pos) : rest) -> do
- for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name'
- parseFatalFailure pos $ makeMsg name
-
- | otherwise = parser v values
-
- knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ())
-
- hiddenField = id
+ blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser
+
+ uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing"
+ Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing"
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls) =
+ unpack' _pack <$> runFieldParser pos parsec v fls
+
+ booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure def
+ Just [] -> pure def
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
+
+ optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure Nothing
+ Just [] -> pure Nothing
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls)
+ | null fls = pure Nothing
+ | otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls
+
+ optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure def
+ Just [] -> pure def
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls)
+ | null fls = pure def
+ | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls
+
+ freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure Nothing
+ Just [] -> pure Nothing
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls)
+ | null fls = pure Nothing
+ | v >= CabalSpecV3_0 = pure (Just (fieldlinesToFreeText3 pos fls))
+ | otherwise = pure (Just (fieldlinesToFreeText fls))
+
+ freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure ""
+ Just [] -> pure ""
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls)
+ | null fls = pure ""
+ | v >= CabalSpecV3_0 = pure (fieldlinesToFreeText3 pos fls)
+ | otherwise = pure (fieldlinesToFreeText fls)
+
+ -- freeTextFieldDefST = defaultFreeTextFieldDefST
+ freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure mempty
+ Just [] -> pure mempty
+ Just [x] -> parseOne v x
+ Just xs@(_ : y : ys) -> do
+ warnMultipleSingularFields fn xs
+ NE.last <$> traverse (parseOne v) (y :| ys)
+
+ parseOne v (MkNamelessField pos fls) = case fls of
+ [] -> pure mempty
+ [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs)
+ _
+ | v >= CabalSpecV3_0 -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls)
+ | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls)
+
+ monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
+ where
+ parser v fields = case Map.lookup fn fields of
+ Nothing -> pure mempty
+ Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs
+
+ parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls
+
+ prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs))
+ where
+ parser :: Fields Position -> [(String, String)]
+ parser values = reorder $ concatMap convert $ filter match $ Map.toList values
+
+ match (fn, _) = fnPfx `BS.isPrefixOf` fn
+ convert (fn, fields) =
+ [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls))
+ | MkNamelessField pos fls <- fields
+ ]
+ -- hack: recover the order of prefixed fields
+ reorder = map snd . sortBy (comparing fst)
+
+ availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
+ where
+ parser' v values
+ | v >= vs = parser v values
+ | otherwise = do
+ let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
+ for_ (Map.toList unknownFields) $ \(name, fields) ->
+ for_ fields $ \(MkNamelessField pos _) ->
+ parseWarning pos PWTUnknownField $
+ "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored."
+
+ pure def
+
+ availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
+ where
+ parser' v values
+ | v >= vs = parser v values
+ | otherwise = do
+ let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
+ for_ (Map.toList unknownFields) $ \(name, fields) ->
+ for_ fields $ \(MkNamelessField pos _) ->
+ parseWarning pos PWTUnknownField $
+ "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "."
+
+ parser v values
+
+ -- todo we know about this field
+ deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
+ where
+ parser' v values
+ | v >= vs = do
+ let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names
+ for_ (Map.toList deprecatedFields) $ \(name, fields) ->
+ for_ fields $ \(MkNamelessField pos _) ->
+ parseWarning pos PWTDeprecatedField $
+ "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg
+
+ parser v values
+ | otherwise = parser v values
+
+ removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser'
+ where
+ parser' v values
+ | v >= vs = do
+ let msg' = if null msg then "" else ' ' : msg
+ let unknownFields = Map.intersection values $ Map.fromSet (const ()) names
+ let namePos =
+ [ (name, pos)
+ | (name, fields) <- Map.toList unknownFields
+ , MkNamelessField pos _ <- fields
+ ]
+
+ let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg'
+
+ case namePos of
+ -- no fields => proceed (with empty values, to be sure)
+ [] -> parser v mempty
+ -- if there's single field: fail fatally with it
+ ((name, pos) : rest) -> do
+ for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name'
+ parseFatalFailure pos $ makeMsg name
+ | otherwise = parser v values
+
+ knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ())
+
+ hiddenField = id
-------------------------------------------------------------------------------
-- Parsec
@@ -348,26 +351,32 @@ instance FieldGrammar Parsec ParsecFieldGrammar where
runFieldParser' :: [Position] -> ParsecParser a -> CabalSpecVersion -> FieldLineStream -> ParseResult a
runFieldParser' inputPoss p v str = case P.runParser p' [] "<field>" str of
- Right (pok, ws) -> do
- traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws
- pure pok
- Left err -> do
- let ppos = P.errorPos err
- let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos)
-
- let msg = P.showErrorMessages
- "or" "unknown parse error" "expecting" "unexpected" "end of input"
- (P.errorMessages err)
- parseFatalFailure epos $ msg ++ "\n"
+ Right (pok, ws) -> do
+ traverse_ (\(PWarning t pos w) -> parseWarning (mapPosition pos) t w) ws
+ pure pok
+ Left err -> do
+ let ppos = P.errorPos err
+ let epos = mapPosition $ Position (P.sourceLine ppos) (P.sourceColumn ppos)
+
+ let msg =
+ P.showErrorMessages
+ "or"
+ "unknown parse error"
+ "expecting"
+ "unexpected"
+ "end of input"
+ (P.errorMessages err)
+ parseFatalFailure epos $ msg ++ "\n"
where
p' = (,) <$ P.spaces <*> unPP p v <* P.spaces <* P.eof <*> P.getState
-- Positions start from 1:1, not 0:0
- mapPosition (Position prow pcol) = go (prow - 1) inputPoss where
- go _ [] = zeroPos
- go _ [Position row col] = Position row (col + pcol - 1)
- go n (Position row col:_) | n <= 0 = Position row (col + pcol - 1)
- go n (_:ps) = go (n - 1) ps
+ mapPosition (Position prow pcol) = go (prow - 1) inputPoss
+ where
+ go _ [] = zeroPos
+ go _ [Position row col] = Position row (col + pcol - 1)
+ go n (Position row col : _) | n <= 0 = Position row (col + pcol - 1)
+ go n (_ : ps) = go (n - 1) ps
runFieldParser :: Position -> ParsecParser a -> CabalSpecVersion -> [FieldLine Position] -> ParseResult a
runFieldParser pp p v ls = runFieldParser' poss p v (fieldLinesToStream ls)
@@ -381,54 +390,55 @@ fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
-- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal
fieldlinesToFreeText :: [FieldLine ann] -> String
fieldlinesToFreeText [FieldLine _ "."] = "."
-fieldlinesToFreeText fls = intercalate "\n" (map go fls)
+fieldlinesToFreeText fls = intercalate "\n" (map go fls)
where
go (FieldLine _ bs)
- | s == "." = ""
- | otherwise = s
+ | s == "." = ""
+ | otherwise = s
where
s = trim (fromUTF8BS bs)
fieldlinesToFreeText3 :: Position -> [FieldLine Position] -> String
-fieldlinesToFreeText3 _ [] = ""
-fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs
+fieldlinesToFreeText3 _ [] = ""
+fieldlinesToFreeText3 _ [FieldLine _ bs] = fromUTF8BS bs
fieldlinesToFreeText3 pos (FieldLine pos1 bs1 : fls2@(FieldLine pos2 _ : _))
- -- if first line is on the same line with field name:
- -- the indentation level is either
- -- 1. the indentation of left most line in rest fields
- -- 2. the indentation of the first line
- -- whichever is leftmost
- | positionRow pos == positionRow pos1 = concat
- $ fromUTF8BS bs1
- : mealy (mk mcol1) pos1 fls2
-
- -- otherwise, also indent the first line
- | otherwise = concat
- $ replicate (positionCol pos1 - mcol2) ' '
- : fromUTF8BS bs1
- : mealy (mk mcol2) pos1 fls2
-
+ -- if first line is on the same line with field name:
+ -- the indentation level is either
+ -- 1. the indentation of left most line in rest fields
+ -- 2. the indentation of the first line
+ -- whichever is leftmost
+ | positionRow pos == positionRow pos1 =
+ concat $
+ fromUTF8BS bs1
+ : mealy (mk mcol1) pos1 fls2
+ -- otherwise, also indent the first line
+ | otherwise =
+ concat $
+ replicate (positionCol pos1 - mcol2) ' '
+ : fromUTF8BS bs1
+ : mealy (mk mcol2) pos1 fls2
where
mcol1 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (min (positionCol pos1) (positionCol pos2)) fls2
mcol2 = foldl' (\a b -> min a $ positionCol $ fieldLineAnn b) (positionCol pos1) fls2
mk :: Int -> Position -> FieldLine Position -> (Position, String)
mk col p (FieldLine q bs) =
- ( q
- , replicate newlines '\n'
+ ( q
+ , replicate newlines '\n'
++ replicate indent ' '
++ fromUTF8BS bs
- )
+ )
where
newlines = positionRow q - positionRow p
- indent = positionCol q - col
+ indent = positionCol q - col
mealy :: (s -> a -> (s, b)) -> s -> [a] -> [b]
-mealy f = go where
+mealy f = go
+ where
go _ [] = []
go s (x : xs) = let ~(s', y) = f s x in y : go s' xs
fieldLinesToStream :: [FieldLine ann] -> FieldLineStream
-fieldLinesToStream [] = fieldLineStreamEnd
-fieldLinesToStream [FieldLine _ bs] = FLSLast bs
+fieldLinesToStream [] = fieldLineStreamEnd
+fieldLinesToStream [FieldLine _ bs] = FLSLast bs
fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs)
diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs
index fdd236b0e9e29e4b8bb3358c6656f2b203152012..a35d8f361f468e629915cfa26099fd5479a5c484 100644
--- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs
+++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs
@@ -1,32 +1,33 @@
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-module Distribution.FieldGrammar.Pretty (
- PrettyFieldGrammar,
- prettyFieldGrammar,
- ) where
-
-import Distribution.CabalSpecVersion
-import Distribution.Compat.Lens
-import Distribution.Compat.Newtype
-import Distribution.Compat.Prelude
-import Distribution.Fields.Field (FieldName)
-import Distribution.Fields.Pretty (PrettyField (..))
-import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3)
-import Distribution.Utils.Generic (toUTF8BS)
-import Prelude ()
-import Text.PrettyPrint (Doc)
-import qualified Text.PrettyPrint as PP
+
+module Distribution.FieldGrammar.Pretty
+ ( PrettyFieldGrammar
+ , prettyFieldGrammar
+ ) where
+
+import Distribution.CabalSpecVersion
+import Distribution.Compat.Lens
+import Distribution.Compat.Newtype
+import Distribution.Compat.Prelude
+import Distribution.Fields.Field (FieldName)
+import Distribution.Fields.Pretty (PrettyField (..))
+import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3)
+import Distribution.Utils.Generic (toUTF8BS)
+import Text.PrettyPrint (Doc)
+import qualified Text.PrettyPrint as PP
+import Prelude ()
import Distribution.FieldGrammar.Class
newtype PrettyFieldGrammar s a = PrettyFG
- { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()]
- }
+ { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()]
+ }
deriving (Functor)
instance Applicative (PrettyFieldGrammar s) where
- pure _ = PrettyFG (\_ _ -> mempty)
- PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s)
+ pure _ = PrettyFG (\_ _ -> mempty)
+ PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s)
-- | We can use 'PrettyFieldGrammar' to pp print the @s@.
--
@@ -35,70 +36,77 @@ prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [Pretty
prettyFieldGrammar = flip fieldGrammarPretty
instance FieldGrammar Pretty PrettyFieldGrammar where
- blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f)
-
- uniqueFieldAla fn _pack l = PrettyFG $ \_v s ->
- ppField fn (pretty (pack' _pack (aview l s)))
-
- booleanFieldDef fn l def = PrettyFG pp
- where
- pp _v s
- | b == def = mempty
- | otherwise = ppField fn (PP.text (show b))
- where
- b = aview l s
-
- optionalFieldAla fn _pack l = PrettyFG pp
- where
- pp v s = case aview l s of
- Nothing -> mempty
- Just a -> ppField fn (prettyVersioned v (pack' _pack a))
-
- optionalFieldDefAla fn _pack l def = PrettyFG pp
- where
- pp v s
- | x == def = mempty
- | otherwise = ppField fn (prettyVersioned v (pack' _pack x))
- where
- x = aview l s
-
- freeTextField fn l = PrettyFG pp where
- pp v s = maybe mempty (ppField fn . showFT) (aview l s) where
- showFT | v >= CabalSpecV3_0 = showFreeTextV3
- | otherwise = showFreeText
-
- -- it's ok to just show, as showFreeText of empty string is empty.
- freeTextFieldDef fn l = PrettyFG pp where
- pp v s = ppField fn (showFT (aview l s)) where
- showFT | v >= CabalSpecV3_0 = showFreeTextV3
- | otherwise = showFreeText
-
- freeTextFieldDefST = defaultFreeTextFieldDefST
-
- monoidalFieldAla fn _pack l = PrettyFG pp
- where
- pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s)))
-
- prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l)
- where
- pp xs =
- -- always print the field, even its Doc is empty.
- -- i.e. don't use ppField
- [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s
- | (n, s) <- xs
- -- fnPfx `isPrefixOf` n
- ]
-
- knownField _ = pure ()
- deprecatedSince _ _ x = x
- -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field
- -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed
- -- so invalid documents can be only manually constructed.
- removedIn _ _ x = x
- availableSince _ _ = id
- hiddenField _ = PrettyFG (\_ -> mempty)
+ blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f)
+
+ uniqueFieldAla fn _pack l = PrettyFG $ \_v s ->
+ ppField fn (pretty (pack' _pack (aview l s)))
+
+ booleanFieldDef fn l def = PrettyFG pp
+ where
+ pp _v s
+ | b == def = mempty
+ | otherwise = ppField fn (PP.text (show b))
+ where
+ b = aview l s
+
+ optionalFieldAla fn _pack l = PrettyFG pp
+ where
+ pp v s = case aview l s of
+ Nothing -> mempty
+ Just a -> ppField fn (prettyVersioned v (pack' _pack a))
+
+ optionalFieldDefAla fn _pack l def = PrettyFG pp
+ where
+ pp v s
+ | x == def = mempty
+ | otherwise = ppField fn (prettyVersioned v (pack' _pack x))
+ where
+ x = aview l s
+
+ freeTextField fn l = PrettyFG pp
+ where
+ pp v s = maybe mempty (ppField fn . showFT) (aview l s)
+ where
+ showFT
+ | v >= CabalSpecV3_0 = showFreeTextV3
+ | otherwise = showFreeText
+
+ -- it's ok to just show, as showFreeText of empty string is empty.
+ freeTextFieldDef fn l = PrettyFG pp
+ where
+ pp v s = ppField fn (showFT (aview l s))
+ where
+ showFT
+ | v >= CabalSpecV3_0 = showFreeTextV3
+ | otherwise = showFreeText
+
+ freeTextFieldDefST = defaultFreeTextFieldDefST
+
+ monoidalFieldAla fn _pack l = PrettyFG pp
+ where
+ pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s)))
+
+ prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l)
+ where
+ pp xs =
+ -- always print the field, even its Doc is empty.
+ -- i.e. don't use ppField
+ [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s
+ | (n, s) <- xs
+ -- fnPfx `isPrefixOf` n
+ ]
+
+ knownField _ = pure ()
+ deprecatedSince _ _ x = x
+
+ -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field
+ -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed
+ -- so invalid documents can be only manually constructed.
+ removedIn _ _ x = x
+ availableSince _ _ = id
+ hiddenField _ = PrettyFG (\_ -> mempty)
ppField :: FieldName -> Doc -> [PrettyField ()]
ppField name fielddoc
- | PP.isEmpty fielddoc = []
- | otherwise = [ PrettyField () name fielddoc ]
+ | PP.isEmpty fielddoc = []
+ | otherwise = [PrettyField () name fielddoc]
diff --git a/Cabal-syntax/src/Distribution/Fields.hs b/Cabal-syntax/src/Distribution/Fields.hs
index 18b0aa6d92cbbf5dcf987f650b8b3d26a950ed65..4688bf547d954583152cdf5f20f77ca35292b36d 100644
--- a/Cabal-syntax/src/Distribution/Fields.hs
+++ b/Cabal-syntax/src/Distribution/Fields.hs
@@ -1,42 +1,49 @@
-- | Utilities to work with @.cabal@ like file structure.
-module Distribution.Fields (
- -- * Types
- Field(..),
- Name(..),
- FieldLine(..),
- SectionArg(..),
- FieldName,
+module Distribution.Fields
+ ( -- * Types
+ Field (..)
+ , Name (..)
+ , FieldLine (..)
+ , SectionArg (..)
+ , FieldName
+
-- * Grammar and parsing
- --
- -- See "Distribution.Fields.Parser" for grammar.
- readFields,
- readFields',
+
+ --
+ -- See "Distribution.Fields.Parser" for grammar.
+ , readFields
+ , readFields'
+
-- ** ParseResult
- ParseResult,
- runParseResult,
- parseWarning,
- parseWarnings,
- parseFailure,
- parseFatalFailure,
+ , ParseResult
+ , runParseResult
+ , parseWarning
+ , parseWarnings
+ , parseFailure
+ , parseFatalFailure
+
-- ** Warnings
- PWarnType (..),
- PWarning (..),
- showPWarning,
+ , PWarnType (..)
+ , PWarning (..)
+ , showPWarning
+
-- ** Errors
- PError (..),
- showPError,
+ , PError (..)
+ , showPError
+
-- * Pretty printing
- CommentPosition (..),
- PrettyField (..),
- showFields,
+ , CommentPosition (..)
+ , PrettyField (..)
+ , showFields
+
-- ** Transformation from Field
- genericFromParsecFields,
- fromParsecFields,
- ) where
+ , genericFromParsecFields
+ , fromParsecFields
+ ) where
import Distribution.Fields.Field
-import Distribution.Fields.Parser
import Distribution.Fields.ParseResult
+import Distribution.Fields.Parser
import Distribution.Fields.Pretty
import Distribution.Parsec.Error
import Distribution.Parsec.Warning
diff --git a/Cabal-syntax/src/Distribution/Fields/ConfVar.hs b/Cabal-syntax/src/Distribution/Fields/ConfVar.hs
index b045c3ef1721e7448c41d28a74a310123493fd49..760e2335143b8924aecd912e79d51c62c27c29a4 100644
--- a/Cabal-syntax/src/Distribution/Fields/ConfVar.hs
+++ b/Cabal-syntax/src/Distribution/Fields/ConfVar.hs
@@ -1,47 +1,64 @@
{-# LANGUAGE OverloadedStrings #-}
+
module Distribution.Fields.ConfVar (parseConditionConfVar, parseConditionConfVarFromClause) where
-import Distribution.Compat.CharParsing (char, integral)
+import Distribution.Compat.CharParsing (char, integral)
import Distribution.Compat.Prelude
-import Distribution.Fields.Field (SectionArg (..), Field(..))
+import Distribution.Fields.Field (Field (..), SectionArg (..))
import Distribution.Fields.ParseResult
-import Distribution.Parsec (Parsec (..), Position (..), runParsecParser)
+import Distribution.Fields.Parser (readFields)
+import Distribution.Parsec (Parsec (..), Position (..), runParsecParser)
import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
import Distribution.Types.Condition
-import Distribution.Types.ConfVar (ConfVar (..))
-import Distribution.Fields.Parser (readFields)
+import Distribution.Types.ConfVar (ConfVar (..))
import Distribution.Version
- (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion,
- mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges,
- withinVersion)
+ ( anyVersion
+ , earlierVersion
+ , intersectVersionRanges
+ , laterVersion
+ , majorBoundVersion
+ , mkVersion
+ , noVersion
+ , orEarlierVersion
+ , orLaterVersion
+ , thisVersion
+ , unionVersionRanges
+ , withinVersion
+ )
import Prelude ()
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Pos as P
+import qualified Data.ByteString.Char8 as B8
+import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
-import qualified Data.ByteString.Char8 as B8
+import qualified Text.Parsec.Pos as P
parseConditionConfVarFromClause :: B8.ByteString -> Either P.ParseError (Condition ConfVar)
-parseConditionConfVarFromClause x = readFields x >>= \r -> case r of
- (Section _ xs _ : _ ) -> P.runParser (parser <* P.eof) () "<condition>" xs
- _ -> Left $ P.newErrorMessage (P.Message "No fields in clause") (P.initialPos "<condition>")
+parseConditionConfVarFromClause x =
+ readFields x >>= \r -> case r of
+ (Section _ xs _ : _) -> P.runParser (parser <* P.eof) () "<condition>" xs
+ _ -> Left $ P.newErrorMessage (P.Message "No fields in clause") (P.initialPos "<condition>")
-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
-- based outline parser.
parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
parseConditionConfVar args =
- -- The name of the input file is irrelevant, as we reformat the error message.
- case P.runParser (parser <* P.eof) () "<condition>" args of
- Right x -> pure x
- Left err -> do
- -- Mangle the position to the actual one
- let ppos = P.errorPos err
- let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
- let msg = P.showErrorMessages
- "or" "unknown parse error" "expecting" "unexpected" "end of input"
- (P.errorMessages err)
- parseFailure epos msg
- pure $ Lit True
+ -- The name of the input file is irrelevant, as we reformat the error message.
+ case P.runParser (parser <* P.eof) () "<condition>" args of
+ Right x -> pure x
+ Left err -> do
+ -- Mangle the position to the actual one
+ let ppos = P.errorPos err
+ let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
+ let msg =
+ P.showErrorMessages
+ "or"
+ "unknown parse error"
+ "expecting"
+ "unexpected"
+ "end of input"
+ (P.errorMessages err)
+ parseFailure epos msg
+ pure $ Lit True
type Parser = P.Parsec [SectionArg Position] ()
@@ -51,72 +68,77 @@ sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)
parser :: Parser (Condition ConfVar)
parser = condOr
where
- condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
- condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd
- cond = P.choice
- [ boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond ]
-
- notCond = CNot <$ oper "!" <*> cond
-
- boolLiteral = Lit <$> boolLiteral'
- osCond = Var . OS <$ string "os" <*> parens fromParsec
- flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec
- archCond = Var . Arch <$ string "arch" <*> parens fromParsec
- implCond = Var <$ string "impl" <*> parens implCond'
-
- implCond' = Impl
+ condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
+ condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd
+ cond =
+ P.choice
+ [boolLiteral, parens condOr, notCond, osCond, archCond, flagCond, implCond]
+
+ notCond = CNot <$ oper "!" <*> cond
+
+ boolLiteral = Lit <$> boolLiteral'
+ osCond = Var . OS <$ string "os" <*> parens fromParsec
+ flagCond = Var . PackageFlag <$ string "flag" <*> parens fromParsec
+ archCond = Var . Arch <$ string "arch" <*> parens fromParsec
+ implCond = Var <$ string "impl" <*> parens implCond'
+
+ implCond' =
+ Impl
<$> fromParsec
<*> P.option anyVersion versionRange
version = fromParsec
- versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*"
+ versionStar = mkVersion <$> fromParsec' versionStar' <* oper "*"
versionStar' = some (integral <* char '.')
versionRange = expr
where
- expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||")
+ expr = foldl1 unionVersionRanges <$> sepByNonEmpty term (oper "||")
term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&")
- factor = P.choice
- $ parens expr
- : parseAnyVersion
- : parseNoVersion
- : parseWildcardRange
- : map parseRangeOp rangeOps
+ factor =
+ P.choice $
+ parens expr
+ : parseAnyVersion
+ : parseNoVersion
+ : parseWildcardRange
+ : map parseRangeOp rangeOps
- parseAnyVersion = anyVersion <$ string "-any"
- parseNoVersion = noVersion <$ string "-none"
+ parseAnyVersion = anyVersion <$ string "-any"
+ parseNoVersion = noVersion <$ string "-none"
parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar
- parseRangeOp (s,f) = P.try (f <$ oper s <*> version)
- rangeOps = [ ("<", earlierVersion),
- ("<=", orEarlierVersion),
- (">", laterVersion),
- (">=", orLaterVersion),
- ("^>=", majorBoundVersion),
- ("==", thisVersion) ]
+ parseRangeOp (s, f) = P.try (f <$ oper s <*> version)
+ rangeOps =
+ [ ("<", earlierVersion)
+ , ("<=", orEarlierVersion)
+ , (">", laterVersion)
+ , (">=", orLaterVersion)
+ , ("^>=", majorBoundVersion)
+ , ("==", thisVersion)
+ ]
-- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"
identBS = tokenPrim $ \t -> case t of
- SecArgName _ s -> Just s
- _ -> Nothing
+ SecArgName _ s -> Just s
+ _ -> Nothing
boolLiteral' = tokenPrim $ \t -> case t of
- SecArgName _ s
- | s == "True" -> Just True
- | s == "true" -> Just True
- | s == "False" -> Just False
- | s == "false" -> Just False
- _ -> Nothing
+ SecArgName _ s
+ | s == "True" -> Just True
+ | s == "true" -> Just True
+ | s == "False" -> Just False
+ | s == "false" -> Just False
+ _ -> Nothing
string s = tokenPrim $ \t -> case t of
- SecArgName _ s' | s == s' -> Just ()
- _ -> Nothing
+ SecArgName _ s' | s == s' -> Just ()
+ _ -> Nothing
oper o = tokenPrim $ \t -> case t of
- SecArgOther _ o' | o == o' -> Just ()
- _ -> Nothing
+ SecArgOther _ o' | o == o' -> Just ()
+ _ -> Nothing
parens = P.between (oper "(") (oper ")")
@@ -129,6 +151,6 @@ parser = condOr
fromParsec = fromParsec' parsec
fromParsec' p = do
- bs <- identBS
- let fls = fieldLineStreamFromBS bs
- either (fail . show) pure (runParsecParser p "<fromParsec'>" fls)
+ bs <- identBS
+ let fls = fieldLineStreamFromBS bs
+ either (fail . show) pure (runParsecParser p "<fromParsec'>" fls)
diff --git a/Cabal-syntax/src/Distribution/Fields/Field.hs b/Cabal-syntax/src/Distribution/Fields/Field.hs
index 4c06342ed065134f8acbd228145cd34cf1c87441..7f5b85809aada9ef375df14ffe1a1432481a0189 100644
--- a/Cabal-syntax/src/Distribution/Fields/Field.hs
+++ b/Cabal-syntax/src/Distribution/Fields/Field.hs
@@ -1,39 +1,41 @@
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
+
-- | Cabal-like file AST types: 'Field', 'Section' etc
--
-- These types are parametrized by an annotation.
-module Distribution.Fields.Field (
- -- * Cabal file
- Field (..),
- fieldName,
- fieldAnn,
- fieldUniverse,
- FieldLine (..),
- fieldLineAnn,
- fieldLineBS,
- SectionArg (..),
- sectionArgAnn,
- -- * Name
- FieldName,
- Name (..),
- mkName,
- getName,
- nameAnn,
- -- * Conversions to String
- sectionArgsToString,
- fieldLinesToString,
- ) where
+module Distribution.Fields.Field
+ ( -- * Cabal file
+ Field (..)
+ , fieldName
+ , fieldAnn
+ , fieldUniverse
+ , FieldLine (..)
+ , fieldLineAnn
+ , fieldLineBS
+ , SectionArg (..)
+ , sectionArgAnn
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as B
-import qualified Data.Char as Char
-import Distribution.Compat.Prelude
-import Distribution.Pretty (showTokenStr)
-import Distribution.Utils.Generic (fromUTF8BS)
-import Prelude ()
+ -- * Name
+ , FieldName
+ , Name (..)
+ , mkName
+ , getName
+ , nameAnn
+ -- * Conversions to String
+ , sectionArgsToString
+ , fieldLinesToString
+ ) where
+
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.Char as Char
+import Distribution.Compat.Prelude
+import Distribution.Pretty (showTokenStr)
+import Distribution.Utils.Generic (fromUTF8BS)
+import Prelude ()
-------------------------------------------------------------------------------
-- Cabal file
@@ -41,13 +43,13 @@ import Prelude ()
-- | A Cabal-like file consists of a series of fields (@foo: bar@) and sections (@library ...@).
data Field ann
- = Field !(Name ann) [FieldLine ann]
- | Section !(Name ann) [SectionArg ann] [Field ann]
+ = Field !(Name ann) [FieldLine ann]
+ | Section !(Name ann) [SectionArg ann] [Field ann]
deriving (Eq, Show, Functor, Foldable, Traversable)
-- | Section of field name
fieldName :: Field ann -> Name ann
-fieldName (Field n _ ) = n
+fieldName (Field n _) = n
fieldName (Section n _ _) = n
fieldAnn :: Field ann -> ann
@@ -56,16 +58,15 @@ fieldAnn = nameAnn . fieldName
-- | All transitive descendants of 'Field', including itself.
--
-- /Note:/ the resulting list is never empty.
---
fieldUniverse :: Field ann -> [Field ann]
fieldUniverse f@(Section _ _ fs) = f : concatMap fieldUniverse fs
-fieldUniverse f@(Field _ _) = [f]
+fieldUniverse f@(Field _ _) = [f]
-- | A line of text representing the value of a field from a Cabal file.
-- A field may contain multiple lines.
--
-- /Invariant:/ 'ByteString' has no newlines.
-data FieldLine ann = FieldLine !ann !ByteString
+data FieldLine ann = FieldLine !ann !ByteString
deriving (Eq, Show, Functor, Foldable, Traversable)
-- | @since 3.0.0.0
@@ -78,18 +79,18 @@ fieldLineBS (FieldLine _ bs) = bs
-- | Section arguments, e.g. name of the library
data SectionArg ann
- = SecArgName !ann !ByteString
- -- ^ identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3"
- | SecArgStr !ann !ByteString
- -- ^ quoted string
- | SecArgOther !ann !ByteString
- -- ^ everything else, mm. operators (e.g. in if-section conditionals)
+ = -- | identifier, or something which looks like number. Also many dot numbers, i.e. "7.6.3"
+ SecArgName !ann !ByteString
+ | -- | quoted string
+ SecArgStr !ann !ByteString
+ | -- | everything else, mm. operators (e.g. in if-section conditionals)
+ SecArgOther !ann !ByteString
deriving (Eq, Show, Functor, Foldable, Traversable)
-- | Extract annotation from 'SectionArg'.
sectionArgAnn :: SectionArg ann -> ann
-sectionArgAnn (SecArgName ann _) = ann
-sectionArgAnn (SecArgStr ann _) = ann
+sectionArgAnn (SecArgName ann _) = ann
+sectionArgAnn (SecArgStr ann _) = ann
sectionArgAnn (SecArgOther ann _) = ann
-------------------------------------------------------------------------------
@@ -101,7 +102,7 @@ type FieldName = ByteString
-- | A field name.
--
-- /Invariant/: 'ByteString' is lower-case ASCII.
-data Name ann = Name !ann !FieldName
+data Name ann = Name !ann !FieldName
deriving (Eq, Show, Functor, Foldable, Traversable)
mkName :: ann -> FieldName -> Name ann
@@ -121,10 +122,11 @@ nameAnn (Name ann _) = ann
--
-- @since 3.6.0.0
sectionArgsToString :: [SectionArg ann] -> String
-sectionArgsToString = unwords . map toStr where
+sectionArgsToString = unwords . map toStr
+ where
toStr :: SectionArg ann -> String
- toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs)
- toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs)
+ toStr (SecArgName _ bs) = showTokenStr (fromUTF8BS bs)
+ toStr (SecArgStr _ bs) = showTokenStr (fromUTF8BS bs)
toStr (SecArgOther _ bs) = fromUTF8BS bs
-- | Convert @['FieldLine']@ into String.
@@ -135,7 +137,7 @@ sectionArgsToString = unwords . map toStr where
-- @since 3.6.0.0
fieldLinesToString :: [FieldLine ann] -> String
fieldLinesToString =
- -- intercalate to avoid trailing newline.
- intercalate "\n" . map toStr
+ -- intercalate to avoid trailing newline.
+ intercalate "\n" . map toStr
where
toStr (FieldLine _ bs) = fromUTF8BS bs
diff --git a/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs b/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs
index ac414c18e31254005be2c1f38081f93bc552f815..4ad77d6d0e59a790766b71eb48fe1d3a70da1100 100644
--- a/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs
+++ b/Cabal-syntax/src/Distribution/Fields/LexerMonad.hs
@@ -1,43 +1,39 @@
{-# LANGUAGE CPP #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Fields.LexerMonad
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
-module Distribution.Fields.LexerMonad (
- InputStream,
- LexState(..),
- LexResult(..),
-
- Lex(..),
- execLexer,
-
- getPos,
- setPos,
- adjustPos,
-
- getInput,
- setInput,
-
- getStartCode,
- setStartCode,
-
- LexWarning(..),
- LexWarningType(..),
- addWarning,
- addWarningAt,
- toPWarnings,
-
+module Distribution.Fields.LexerMonad
+ ( InputStream
+ , LexState (..)
+ , LexResult (..)
+ , Lex (..)
+ , execLexer
+ , getPos
+ , setPos
+ , adjustPos
+ , getInput
+ , setInput
+ , getStartCode
+ , setStartCode
+ , LexWarning (..)
+ , LexWarningType (..)
+ , addWarning
+ , addWarningAt
+ , toPWarnings
) where
-import qualified Data.ByteString as B
-import qualified Data.List.NonEmpty as NE
-import Distribution.Compat.Prelude
-import Distribution.Parsec.Position (Position (..), showPos)
-import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
-import Prelude ()
+import qualified Data.ByteString as B
+import qualified Data.List.NonEmpty as NE
+import Distribution.Compat.Prelude
+import Distribution.Parsec.Position (Position (..), showPos)
+import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
+import Prelude ()
import qualified Data.Map.Strict as Map
@@ -49,7 +45,7 @@ import qualified Data.Vector as V
#endif
-- simple state monad
-newtype Lex a = Lex { unLex :: LexState -> LexResult a }
+newtype Lex a = Lex {unLex :: LexState -> LexResult a}
instance Functor Lex where
fmap = liftM
@@ -60,66 +56,83 @@ instance Applicative Lex where
instance Monad Lex where
return = pure
- (>>=) = thenLex
+ (>>=) = thenLex
data LexResult a = LexResult {-# UNPACK #-} !LexState a
data LexWarningType
- = LexWarningNBSP -- ^ Encountered non breaking space
- | LexWarningBOM -- ^ BOM at the start of the cabal file
- | LexWarningTab -- ^ Leading tags
+ = -- | Encountered non breaking space
+ LexWarningNBSP
+ | -- | BOM at the start of the cabal file
+ LexWarningBOM
+ | -- | Leading tags
+ LexWarningTab
deriving (Eq, Ord, Show)
-data LexWarning = LexWarning !LexWarningType
- {-# UNPACK #-} !Position
+data LexWarning
+ = LexWarning
+ !LexWarningType
+ {-# UNPACK #-} !Position
deriving (Show)
toPWarnings :: [LexWarning] -> [PWarning]
-toPWarnings
- = map (uncurry toWarning)
+toPWarnings =
+ map (uncurry toWarning)
. Map.toList
. Map.fromListWith (<>)
. map (\(LexWarning t p) -> (t, pure p))
where
toWarning LexWarningBOM poss =
- PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file"
+ PWarning PWTLexBOM (NE.head poss) "Byte-order mark found at the beginning of the file"
toWarning LexWarningNBSP poss =
- PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss)
+ PWarning PWTLexNBSP (NE.head poss) $ "Non breaking spaces at " ++ intercalate ", " (NE.toList $ fmap showPos poss)
toWarning LexWarningTab poss =
- PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss)
-
-data LexState = LexState {
- curPos :: {-# UNPACK #-} !Position, -- ^ position at current input location
- curInput :: {-# UNPACK #-} !InputStream, -- ^ the current input
- curCode :: {-# UNPACK #-} !StartCode, -- ^ lexer code
- warnings :: [LexWarning]
+ PWarning PWTLexTab (NE.head poss) $ "Tabs used as indentation at " ++ intercalate ", " (NE.toList $ fmap showPos poss)
+
+{- FOURMOLU_DISABLE -}
+data LexState = LexState
+ { curPos :: {-# UNPACK #-} !Position
+ -- ^ position at current input location
+ , curInput :: {-# UNPACK #-} !InputStream
+ -- ^ the current input
+ , curCode :: {-# UNPACK #-} !StartCode
+ -- ^ lexer code
+ , warnings :: [LexWarning]
#ifdef CABAL_PARSEC_DEBUG
- , dbgText :: V.Vector T.Text -- ^ input lines, to print pretty debug info
+ , dbgText :: V.Vector T.Text
+ -- ^ input lines, to print pretty debug info
#endif
- } --TODO: check if we should cache the first token
- -- since it looks like parsec's uncons can be called many times on the same input
+ }
+{- FOURMOLU_ENABLE -}
-type StartCode = Int -- ^ An @alex@ lexer start code
-type InputStream = B.ByteString
+-- TODO: check if we should cache the first token
+-- since it looks like parsec's uncons can be called many times on the same input
+type StartCode =
+ Int
+ -- ^ An @alex@ lexer start code
+type InputStream = B.ByteString
-- | Execute the given lexer on the supplied input stream.
+{- FOURMOLU_DISABLE -}
execLexer :: Lex a -> InputStream -> ([LexWarning], a)
execLexer (Lex lexer) input =
- case lexer initialState of
- LexResult LexState{ warnings = ws } result -> (ws, result)
+ case lexer initialState of
+ LexResult LexState{warnings = ws} result -> (ws, result)
where
- initialState = LexState
- -- TODO: add 'startPosition'
- { curPos = Position 1 1
- , curInput = input
- , curCode = 0
- , warnings = []
+ initialState =
+ LexState
+ { -- TODO: add 'startPosition'
+ curPos = Position 1 1
+ , curInput = input
+ , curCode = 0
+ , warnings = []
#ifdef CABAL_PARSEC_DEBUG
- , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input
+ , dbgText = V.fromList . T.lines . T.decodeUtf8 $ input
#endif
- }
+ }
+{- FOURMOLU_ENABLE -}
{-# INLINE returnLex #-}
returnLex :: a -> Lex a
@@ -130,32 +143,32 @@ thenLex :: Lex a -> (a -> Lex b) -> Lex b
(Lex m) `thenLex` k = Lex $ \s -> case m s of LexResult s' a -> (unLex (k a)) s'
setPos :: Position -> Lex ()
-setPos pos = Lex $ \s -> LexResult s{ curPos = pos } ()
+setPos pos = Lex $ \s -> LexResult s{curPos = pos} ()
getPos :: Lex Position
-getPos = Lex $ \s@LexState{ curPos = pos } -> LexResult s pos
+getPos = Lex $ \s@LexState{curPos = pos} -> LexResult s pos
adjustPos :: (Position -> Position) -> Lex ()
-adjustPos f = Lex $ \s@LexState{ curPos = pos } -> LexResult s{ curPos = f pos } ()
+adjustPos f = Lex $ \s@LexState{curPos = pos} -> LexResult s{curPos = f pos} ()
getInput :: Lex InputStream
-getInput = Lex $ \s@LexState{ curInput = i } -> LexResult s i
+getInput = Lex $ \s@LexState{curInput = i} -> LexResult s i
setInput :: InputStream -> Lex ()
-setInput i = Lex $ \s -> LexResult s{ curInput = i } ()
+setInput i = Lex $ \s -> LexResult s{curInput = i} ()
getStartCode :: Lex Int
-getStartCode = Lex $ \s@LexState{ curCode = c } -> LexResult s c
+getStartCode = Lex $ \s@LexState{curCode = c} -> LexResult s c
setStartCode :: Int -> Lex ()
-setStartCode c = Lex $ \s -> LexResult s{ curCode = c } ()
+setStartCode c = Lex $ \s -> LexResult s{curCode = c} ()
-- | Add warning at the current position
addWarning :: LexWarningType -> Lex ()
-addWarning wt = Lex $ \s@LexState{ curPos = pos, warnings = ws } ->
- LexResult s{ warnings = LexWarning wt pos : ws } ()
+addWarning wt = Lex $ \s@LexState{curPos = pos, warnings = ws} ->
+ LexResult s{warnings = LexWarning wt pos : ws} ()
-- | Add warning at specific position
addWarningAt :: Position -> LexWarningType -> Lex ()
-addWarningAt pos wt = Lex $ \s@LexState{ warnings = ws } ->
- LexResult s{ warnings = LexWarning wt pos : ws } ()
+addWarningAt pos wt = Lex $ \s@LexState{warnings = ws} ->
+ LexResult s{warnings = LexWarning wt pos : ws} ()
diff --git a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs
index f300fc115f8fd9d20568937ddeba7c2c4c4e12c7..fb09254697e1bf0a93387491bad96610b74f419d 100644
--- a/Cabal-syntax/src/Distribution/Fields/ParseResult.hs
+++ b/Cabal-syntax/src/Distribution/Fields/ParseResult.hs
@@ -1,27 +1,28 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes #-}
+
-- | A parse result type for parsers from AST to Haskell types.
-module Distribution.Fields.ParseResult (
- ParseResult,
- runParseResult,
- recoverWith,
- parseWarning,
- parseWarnings,
- parseFailure,
- parseFatalFailure,
- parseFatalFailure',
- getCabalSpecVersion,
- setCabalSpecVersion,
- withoutWarnings,
- ) where
-
-import Distribution.Parsec.Error (PError (..))
-import Distribution.Parsec.Position (Position (..), zeroPos)
-import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
-import Distribution.Version (Version)
-import Prelude ()
+module Distribution.Fields.ParseResult
+ ( ParseResult
+ , runParseResult
+ , recoverWith
+ , parseWarning
+ , parseWarnings
+ , parseFailure
+ , parseFatalFailure
+ , parseFatalFailure'
+ , getCabalSpecVersion
+ , setCabalSpecVersion
+ , withoutWarnings
+ ) where
+
+import Distribution.Parsec.Error (PError (..))
+import Distribution.Parsec.Position (Position (..), zeroPos)
+import Distribution.Parsec.Warning (PWarnType (..), PWarning (..))
+import Distribution.Version (Version)
+import Prelude ()
-- liftA2 is not in base <4.10, hence we need to only import it explicitly when we're on >=4.10
--
@@ -36,12 +37,13 @@ import Distribution.Compat.Prelude
-- | A monad with failure and accumulating errors and warnings.
newtype ParseResult a = PR
- { unPR
- :: forall r. PRState
- -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration
- -> (PRState -> a -> r) -- success
- -> r
- }
+ { unPR
+ :: forall r
+ . PRState
+ -> (PRState -> r) -- failure, but we were able to recover a new-style spec-version declaration
+ -> (PRState -> a -> r) -- success
+ -> r
+ }
-- Note: we have version here, as we could get any version.
data PRState = PRState ![PWarning] ![PError] !(Maybe Version)
@@ -54,7 +56,7 @@ emptyPRState = PRState [] [] Nothing
-- @since 3.4.0.0
withoutWarnings :: ParseResult a -> ParseResult a
withoutWarnings m = PR $ \s failure success ->
- unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s)
+ unPR m s failure $ \ !s1 -> success (s1 `withWarningsOf` s)
where
withWarningsOf (PRState _ e v) (PRState w _ _) = PRState w e v
@@ -64,99 +66,99 @@ withoutWarnings m = PR $ \s failure success ->
runParseResult :: ParseResult a -> ([PWarning], Either (Maybe Version, NonEmpty PError) a)
runParseResult pr = unPR pr emptyPRState failure success
where
- failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| []))
- failure (PRState warns (err:errs) v) = (warns, Left (v, err :| errs)) where
- success (PRState warns [] _) x = (warns, Right x)
+ failure (PRState warns [] v) = (warns, Left (v, PError zeroPos "panic" :| []))
+ failure (PRState warns (err : errs) v) = (warns, Left (v, err :| errs)) where
+ success (PRState warns [] _) x = (warns, Right x)
-- If there are any errors, don't return the result
- success (PRState warns (err:errs) v) _ = (warns, Left (v, err :| errs))
+ success (PRState warns (err : errs) v) _ = (warns, Left (v, err :| errs))
instance Functor ParseResult where
- fmap f (PR pr) = PR $ \ !s failure success ->
- pr s failure $ \ !s' a ->
- success s' (f a)
- {-# INLINE fmap #-}
+ fmap f (PR pr) = PR $ \ !s failure success ->
+ pr s failure $ \ !s' a ->
+ success s' (f a)
+ {-# INLINE fmap #-}
instance Applicative ParseResult where
- pure x = PR $ \ !s _ success -> success s x
- {-# INLINE pure #-}
+ pure x = PR $ \ !s _ success -> success s x
+ {-# INLINE pure #-}
- f <*> x = PR $ \ !s0 failure success ->
- unPR f s0 failure $ \ !s1 f' ->
- unPR x s1 failure $ \ !s2 x' ->
+ f <*> x = PR $ \ !s0 failure success ->
+ unPR f s0 failure $ \ !s1 f' ->
+ unPR x s1 failure $ \ !s2 x' ->
success s2 (f' x')
- {-# INLINE (<*>) #-}
+ {-# INLINE (<*>) #-}
- x *> y = PR $ \ !s0 failure success ->
- unPR x s0 failure $ \ !s1 _ ->
- unPR y s1 failure success
- {-# INLINE (*>) #-}
+ x *> y = PR $ \ !s0 failure success ->
+ unPR x s0 failure $ \ !s1 _ ->
+ unPR y s1 failure success
+ {-# INLINE (*>) #-}
- x <* y = PR $ \ !s0 failure success ->
- unPR x s0 failure $ \ !s1 x' ->
- unPR y s1 failure $ \ !s2 _ ->
+ x <* y = PR $ \ !s0 failure success ->
+ unPR x s0 failure $ \ !s1 x' ->
+ unPR y s1 failure $ \ !s2 _ ->
success s2 x'
- {-# INLINE (<*) #-}
+ {-# INLINE (<*) #-}
#if MIN_VERSION_base(4,10,0)
- liftA2 f x y = PR $ \ !s0 failure success ->
- unPR x s0 failure $ \ !s1 x' ->
- unPR y s1 failure $ \ !s2 y' ->
- success s2 (f x' y')
- {-# INLINE liftA2 #-}
+ liftA2 f x y = PR $ \ !s0 failure success ->
+ unPR x s0 failure $ \ !s1 x' ->
+ unPR y s1 failure $ \ !s2 y' ->
+ success s2 (f x' y')
+ {-# INLINE liftA2 #-}
#endif
instance Monad ParseResult where
- return = pure
- (>>) = (*>)
+ return = pure
+ (>>) = (*>)
- m >>= k = PR $ \ !s failure success ->
- unPR m s failure $ \ !s' a ->
- unPR (k a) s' failure success
- {-# INLINE (>>=) #-}
+ m >>= k = PR $ \ !s failure success ->
+ unPR m s failure $ \ !s' a ->
+ unPR (k a) s' failure success
+ {-# INLINE (>>=) #-}
-- | "Recover" the parse result, so we can proceed parsing.
-- 'runParseResult' will still result in 'Nothing', if there are recorded errors.
recoverWith :: ParseResult a -> a -> ParseResult a
recoverWith (PR pr) x = PR $ \ !s _failure success ->
- pr s (\ !s' -> success s' x) success
+ pr s (\ !s' -> success s' x) success
-- | Set cabal spec version.
setCabalSpecVersion :: Maybe Version -> ParseResult ()
setCabalSpecVersion v = PR $ \(PRState warns errs _) _failure success ->
- success (PRState warns errs v) ()
+ success (PRState warns errs v) ()
-- | Get cabal spec version.
getCabalSpecVersion :: ParseResult (Maybe Version)
getCabalSpecVersion = PR $ \s@(PRState _ _ v) _failure success ->
- success s v
+ success s v
-- | Add a warning. This doesn't fail the parsing process.
parseWarning :: Position -> PWarnType -> String -> ParseResult ()
parseWarning pos t msg = PR $ \(PRState warns errs v) _failure success ->
- success (PRState (PWarning t pos msg : warns) errs v) ()
+ success (PRState (PWarning t pos msg : warns) errs v) ()
-- | Add multiple warnings at once.
parseWarnings :: [PWarning] -> ParseResult ()
parseWarnings newWarns = PR $ \(PRState warns errs v) _failure success ->
- success (PRState (newWarns ++ warns) errs v) ()
+ success (PRState (newWarns ++ warns) errs v) ()
-- | Add an error, but not fail the parser yet.
--
-- For fatal failure use 'parseFatalFailure'
parseFailure :: Position -> String -> ParseResult ()
parseFailure pos msg = PR $ \(PRState warns errs v) _failure success ->
- success (PRState warns (PError pos msg : errs) v) ()
+ success (PRState warns (PError pos msg : errs) v) ()
-- | Add an fatal error.
parseFatalFailure :: Position -> String -> ParseResult a
parseFatalFailure pos msg = PR $ \(PRState warns errs v) failure _success ->
- failure (PRState warns (PError pos msg : errs) v)
+ failure (PRState warns (PError pos msg : errs) v)
-- | A 'mzero'.
parseFatalFailure' :: ParseResult a
parseFatalFailure' = PR pr
where
pr (PRState warns [] v) failure _success = failure (PRState warns [err] v)
- pr s failure _success = failure s
+ pr s failure _success = failure s
err = PError zeroPos "Unknown fatal error"
diff --git a/Cabal-syntax/src/Distribution/Fields/Parser.hs b/Cabal-syntax/src/Distribution/Fields/Parser.hs
index 9061117b04e90940678838ced2e2978a4049a193..46b65ab5ea0b839e91f151adbb6eea0f9fb77182 100644
--- a/Cabal-syntax/src/Distribution/Fields/Parser.hs
+++ b/Cabal-syntax/src/Distribution/Fields/Parser.hs
@@ -1,45 +1,55 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Fields.Parser
-- License : BSD3
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
-module Distribution.Fields.Parser (
- -- * Types
- Field(..),
- Name(..),
- FieldLine(..),
- SectionArg(..),
+{- FOURMOLU_DISABLE -}
+module Distribution.Fields.Parser
+ ( -- * Types
+ Field (..)
+ , Name (..)
+ , FieldLine (..)
+ , SectionArg (..)
+
-- * Grammar and parsing
-- $grammar
- readFields,
- readFields',
+ , readFields
+ , readFields'
#ifdef CABAL_PARSEC_DEBUG
+
-- * Internal
- parseFile,
- parseStr,
- parseBS,
+ , parseFile
+ , parseStr
+ , parseBS
#endif
- ) where
-
-import qualified Data.ByteString.Char8 as B8
-import Data.Functor.Identity
-import Distribution.Compat.Prelude
-import Distribution.Fields.Field
-import Distribution.Fields.Lexer
-import Distribution.Fields.LexerMonad
- (LexResult (..), LexState (..), LexWarning (..), unLex)
-import Distribution.Parsec.Position (Position (..))
-import Prelude ()
-import Text.Parsec.Combinator hiding (eof, notFollowedBy)
-import Text.Parsec.Error
-import Text.Parsec.Pos
-import Text.Parsec.Prim hiding (many, (<|>))
+ ) where
+{- FOURMOLU_ENABLE -}
+
+import qualified Data.ByteString.Char8 as B8
+import Data.Functor.Identity
+import Distribution.Compat.Prelude
+import Distribution.Fields.Field
+import Distribution.Fields.Lexer
+import Distribution.Fields.LexerMonad
+ ( LexResult (..)
+ , LexState (..)
+ , LexWarning (..)
+ , unLex
+ )
+import Distribution.Parsec.Position (Position (..))
+import Text.Parsec.Combinator hiding (eof, notFollowedBy)
+import Text.Parsec.Error
+import Text.Parsec.Pos
+import Text.Parsec.Prim hiding (many, (<|>))
+import Prelude ()
#ifdef CABAL_PARSEC_DEBUG
import qualified Data.Text as T
@@ -52,8 +62,10 @@ import qualified Data.Text.Encoding.Error as T
data LexState' = LexState' !LexState (LToken, LexState')
mkLexState' :: LexState -> LexState'
-mkLexState' st = LexState' st
- (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st'))
+mkLexState' st =
+ LexState'
+ st
+ (case unLex lexToken st of LexResult st' tok -> (tok, mkLexState' st'))
type Parser a = ParsecT LexState' () Identity a
@@ -61,19 +73,19 @@ instance Stream LexState' Identity LToken where
uncons (LexState' _ (tok, st')) =
case tok of
L _ EOF -> return Nothing
- _ -> return (Just (tok, st'))
+ _ -> return (Just (tok, st'))
-- | Get lexer warnings accumulated so far
getLexerWarnings :: Parser [LexWarning]
getLexerWarnings = do
- LexState' (LexState { warnings = ws }) _ <- getInput
+ LexState' (LexState{warnings = ws}) _ <- getInput
return ws
-- | Set Alex code i.e. the mode "state" lexer is in.
setLexerMode :: Int -> Parser ()
setLexerMode code = do
LexState' ls _ <- getInput
- setInput $! mkLexState' ls { curCode = code }
+ setInput $! mkLexState' ls{curCode = code}
getToken :: (Token -> Maybe a) -> Parser a
getToken getTok = getTokenWithPos (\(L _ t) -> getTok t)
@@ -86,16 +98,16 @@ getTokenWithPos getTok = tokenPrim (\(L _ t) -> describeToken t) updatePos getTo
describeToken :: Token -> String
describeToken t = case t of
- TokSym s -> "symbol " ++ show s
- TokStr s -> "string " ++ show s
- TokOther s -> "operator " ++ show s
- Indent _ -> "new line"
- TokFieldLine _ -> "field content"
- Colon -> "\":\""
- OpenBrace -> "\"{\""
- CloseBrace -> "\"}\""
--- SemiColon -> "\";\""
- EOF -> "end of file"
+ TokSym s -> "symbol " ++ show s
+ TokStr s -> "string " ++ show s
+ TokOther s -> "operator " ++ show s
+ Indent _ -> "new line"
+ TokFieldLine _ -> "field content"
+ Colon -> "\":\""
+ OpenBrace -> "\"{\""
+ CloseBrace -> "\"}\""
+ -- SemiColon -> "\";\""
+ EOF -> "end of file"
LexicalError is -> "character in input " ++ show (B8.head is)
tokSym :: Parser (Name Position)
@@ -103,28 +115,26 @@ tokSym', tokStr, tokOther :: Parser (SectionArg Position)
tokIndent :: Parser Int
tokColon, tokOpenBrace, tokCloseBrace :: Parser ()
tokFieldLine :: Parser (FieldLine Position)
-
-tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing
-tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing
-tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing
-tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing
-tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing
-tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing
-tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing
+tokSym = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (mkName pos x); _ -> Nothing
+tokSym' = getTokenWithPos $ \t -> case t of L pos (TokSym x) -> Just (SecArgName pos x); _ -> Nothing
+tokStr = getTokenWithPos $ \t -> case t of L pos (TokStr x) -> Just (SecArgStr pos x); _ -> Nothing
+tokOther = getTokenWithPos $ \t -> case t of L pos (TokOther x) -> Just (SecArgOther pos x); _ -> Nothing
+tokIndent = getToken $ \t -> case t of Indent x -> Just x; _ -> Nothing
+tokColon = getToken $ \t -> case t of Colon -> Just (); _ -> Nothing
+tokOpenBrace = getToken $ \t -> case t of OpenBrace -> Just (); _ -> Nothing
tokCloseBrace = getToken $ \t -> case t of CloseBrace -> Just (); _ -> Nothing
-tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing
+tokFieldLine = getTokenWithPos $ \t -> case t of L pos (TokFieldLine s) -> Just (FieldLine pos s); _ -> Nothing
colon, openBrace, closeBrace :: Parser ()
-
sectionArg :: Parser (SectionArg Position)
-sectionArg = tokSym' <|> tokStr <|> tokOther <?> "section parameter"
+sectionArg = tokSym' <|> tokStr <|> tokOther <?> "section parameter"
fieldSecName :: Parser (Name Position)
-fieldSecName = tokSym <?> "field or section name"
+fieldSecName = tokSym <?> "field or section name"
-colon = tokColon <?> "\":\""
-openBrace = tokOpenBrace <?> "\"{\""
-closeBrace = tokCloseBrace <?> "\"}\""
+colon = tokColon <?> "\":\""
+openBrace = tokOpenBrace <?> "\"{\""
+closeBrace = tokCloseBrace <?> "\"}\""
fieldContent :: Parser (FieldLine Position)
fieldContent = tokFieldLine <?> "field contents"
@@ -143,14 +153,12 @@ indentOfAtLeast (IndentLevel i) = try $ do
guard (j >= i) <?> "indentation of at least " ++ show i
return (IndentLevel j)
-
newtype LexerMode = LexerMode Int
inLexerMode :: LexerMode -> Parser p -> Parser p
inLexerMode (LexerMode mode) p =
do setLexerMode mode; x <- p; setLexerMode in_section; return x
-
-----------------------
-- Cabal file grammar
--
@@ -207,9 +215,10 @@ inLexerMode (LexerMode mode) p =
-- Top level of a file using cabal syntax
--
cabalStyleFile :: Parser [Field Position]
-cabalStyleFile = do es <- elements zeroIndentLevel
- eof
- return es
+cabalStyleFile = do
+ es <- elements zeroIndentLevel
+ eof
+ return es
-- Elements that live at the top level or inside a section, i.e. fields
-- and sections content
@@ -226,11 +235,15 @@ elements ilevel = many (element ilevel)
-- | name elementInNonLayoutContext
element :: IndentLevel -> Parser (Field Position)
element ilevel =
- (do ilevel' <- indentOfAtLeast ilevel
- name <- fieldSecName
- elementInLayoutContext (incIndentLevel ilevel') name)
- <|> (do name <- fieldSecName
- elementInNonLayoutContext name)
+ ( do
+ ilevel' <- indentOfAtLeast ilevel
+ name <- fieldSecName
+ elementInLayoutContext (incIndentLevel ilevel') name
+ )
+ <|> ( do
+ name <- fieldSecName
+ elementInNonLayoutContext name
+ )
-- An element (field or section) that is valid in a layout context.
-- In a layout context we can have fields and sections that themselves
@@ -240,10 +253,12 @@ element ilevel =
-- | arg* sectionLayoutOrBraces
elementInLayoutContext :: IndentLevel -> Name Position -> Parser (Field Position)
elementInLayoutContext ilevel name =
- (do colon; fieldLayoutOrBraces ilevel name)
- <|> (do args <- many sectionArg
- elems <- sectionLayoutOrBraces ilevel
- return (Section name args elems))
+ (do colon; fieldLayoutOrBraces ilevel name)
+ <|> ( do
+ args <- many sectionArg
+ elems <- sectionLayoutOrBraces ilevel
+ return (Section name args elems)
+ )
-- An element (field or section) that is valid in a non-layout context.
-- In a non-layout context we can have only have fields and sections that
@@ -253,13 +268,15 @@ elementInLayoutContext ilevel name =
-- | arg* '\\n'? '{' elements '\\n'? '}'
elementInNonLayoutContext :: Name Position -> Parser (Field Position)
elementInNonLayoutContext name =
- (do colon; fieldInlineOrBraces name)
- <|> (do args <- many sectionArg
- openBrace
- elems <- elements zeroIndentLevel
- optional tokIndent
- closeBrace
- return (Section name args elems))
+ (do colon; fieldInlineOrBraces name)
+ <|> ( do
+ args <- many sectionArg
+ openBrace
+ elems <- elements zeroIndentLevel
+ optional tokIndent
+ closeBrace
+ return (Section name args elems)
+ )
-- The body of a field, using either layout style or braces style.
--
@@ -269,16 +286,16 @@ fieldLayoutOrBraces :: IndentLevel -> Name Position -> Parser (Field Position)
fieldLayoutOrBraces ilevel name = braces <|> fieldLayout
where
braces = do
- openBrace
- ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)
- closeBrace
- return (Field name ls)
+ openBrace
+ ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)
+ closeBrace
+ return (Field name ls)
fieldLayout = inLexerMode (LexerMode in_field_layout) $ do
- l <- optionMaybe fieldContent
- ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)
- return $ case l of
- Nothing -> Field name ls
- Just l' -> Field name (l' : ls)
+ l <- optionMaybe fieldContent
+ ls <- many (do _ <- indentOfAtLeast ilevel; fieldContent)
+ return $ case l of
+ Nothing -> Field name ls
+ Just l' -> Field name (l' : ls)
-- The body of a section, using either layout style or braces style.
--
@@ -286,12 +303,14 @@ fieldLayoutOrBraces ilevel name = braces <|> fieldLayout
-- | elements
sectionLayoutOrBraces :: IndentLevel -> Parser [Field Position]
sectionLayoutOrBraces ilevel =
- (do openBrace
- elems <- elements zeroIndentLevel
- optional tokIndent
- closeBrace
- return elems)
- <|> (elements ilevel)
+ ( do
+ openBrace
+ elems <- elements zeroIndentLevel
+ optional tokIndent
+ closeBrace
+ return elems
+ )
+ <|> (elements ilevel)
-- The body of a field, using either inline style or braces.
--
@@ -299,13 +318,16 @@ sectionLayoutOrBraces ilevel =
-- | content
fieldInlineOrBraces :: Name Position -> Parser (Field Position)
fieldInlineOrBraces name =
- (do openBrace
- ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)
- closeBrace
- return (Field name ls))
- <|> (do ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent))
- return (Field name ls))
-
+ ( do
+ openBrace
+ ls <- inLexerMode (LexerMode in_field_braces) (many fieldContent)
+ closeBrace
+ return (Field name ls)
+ )
+ <|> ( do
+ ls <- inLexerMode (LexerMode in_field_braces) (option [] (fmap (\l -> [l]) fieldContent))
+ return (Field name ls)
+ )
-- | Parse cabal style 'B8.ByteString' into list of 'Field's, i.e. the cabal AST.
readFields :: B8.ByteString -> Either ParseError [Field Position]
@@ -314,12 +336,12 @@ readFields s = fmap fst (readFields' s)
-- | Like 'readFields' but also return lexer warnings
readFields' :: B8.ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' s = do
- parse parser "the input" lexSt
+ parse parser "the input" lexSt
where
parser = do
- fields <- cabalStyleFile
- ws <- getLexerWarnings
- pure (fields, ws)
+ fields <- cabalStyleFile
+ ws <- getLexerWarnings
+ pure (fields, ws)
lexSt = mkLexState' (mkLexState s)
@@ -373,5 +395,8 @@ eof :: Parser ()
eof = notFollowedBy anyToken <?> "end of file"
where
notFollowedBy :: Parser LToken -> Parser ()
- notFollowedBy p = try ( (do L _ t <- try p; unexpected (describeToken t))
- <|> return ())
+ notFollowedBy p =
+ try
+ ( (do L _ t <- try p; unexpected (describeToken t))
+ <|> return ()
+ )
diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs
index dabea67b69bac4dc2b22a2966e18dd438e4023f8..58f54d2848c0cf29157b903abdb49a1d961710f4 100644
--- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs
+++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs
@@ -1,37 +1,38 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
+
-- | Cabal-like file AST types: 'Field', 'Section' etc,
--
-- This (intermediate) data type is used for pretty-printing.
--
-- @since 3.0.0.0
---
-module Distribution.Fields.Pretty (
- -- * Fields
- CommentPosition (..),
- PrettyField (..),
- showFields,
- showFields',
+module Distribution.Fields.Pretty
+ ( -- * Fields
+ CommentPosition (..)
+ , PrettyField (..)
+ , showFields
+ , showFields'
+
-- * Transformation from 'P.Field'
- fromParsecFields,
- genericFromParsecFields,
- prettyFieldLines,
- prettySectionArgs,
- ) where
+ , fromParsecFields
+ , genericFromParsecFields
+ , prettyFieldLines
+ , prettySectionArgs
+ ) where
import Distribution.Compat.Prelude
-import Distribution.Pretty (showToken)
+import Distribution.Pretty (showToken)
import Prelude ()
-import Distribution.Fields.Field (FieldName)
-import Distribution.Utils.Generic (fromUTF8BS)
+import Distribution.Fields.Field (FieldName)
+import Distribution.Utils.Generic (fromUTF8BS)
import qualified Distribution.Fields.Parser as P
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as BS
import qualified Text.PrettyPrint as PP
-- | This type is used to discern when a comment block should go
@@ -41,9 +42,9 @@ import qualified Text.PrettyPrint as PP
data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment
data PrettyField ann
- = PrettyField ann FieldName PP.Doc
- | PrettySection ann FieldName [PP.Doc] [PrettyField ann]
- | PrettyEmpty
+ = PrettyField ann FieldName PP.Doc
+ | PrettySection ann FieldName [PP.Doc] [PrettyField ann]
+ | PrettyEmpty
deriving (Functor, Foldable, Traversable)
-- | Prettyprint a list of fields.
@@ -52,27 +53,27 @@ data PrettyField ann
-- and properly prefixes (with @--@) to count as comments.
-- This unsafety is left in place so one could generate empty lines
-- between comment lines.
---
showFields :: (ann -> CommentPosition) -> [PrettyField ann] -> String
showFields rann = showFields' rann (const id) 4
-- | 'showFields' with user specified indentation.
showFields'
:: (ann -> CommentPosition)
- -- ^ Convert an annotation to lined to precede the field or section.
+ -- ^ Convert an annotation to lined to precede the field or section.
-> (ann -> [String] -> [String])
- -- ^ Post-process non-annotation produced lines.
+ -- ^ Post-process non-annotation produced lines.
-> Int
- -- ^ Indentation level.
+ -- ^ Indentation level.
-> [PrettyField ann]
- -- ^ Fields/sections to show.
+ -- ^ Fields/sections to show.
-> String
showFields' rann post n = unlines . renderFields (Opts rann indent post)
where
-- few hardcoded, "unrolled" variants.
- indent | n == 4 = indent4
- | n == 2 = indent2
- | otherwise = (replicate (max n 1) ' ' ++)
+ indent
+ | n == 4 = indent4
+ | n == 2 = indent2
+ | otherwise = (replicate (max n 1) ' ' ++)
indent4 :: String -> String
indent4 [] = []
@@ -92,78 +93,80 @@ renderFields :: Opts ann -> [PrettyField ann] -> [String]
renderFields opts fields = flattenBlocks blocks
where
len = maxNameLength 0 fields
- blocks = filter (not . null . _contentsBlock) -- empty blocks cause extra newlines #8236
- $ map (renderField opts len) fields
+ blocks =
+ filter (not . null . _contentsBlock) $ -- empty blocks cause extra newlines #8236
+ map (renderField opts len) fields
- maxNameLength !acc [] = acc
+ maxNameLength !acc [] = acc
maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest
- maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest
+ maxNameLength !acc (PrettySection{} : rest) = maxNameLength acc rest
maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest
-- | Block of lines with flags for optional blank lines before and after
data Block = Block
- { _beforeBlock :: Margin
- , _afterBlock :: Margin
+ { _beforeBlock :: Margin
+ , _afterBlock :: Margin
, _contentsBlock :: [String]
}
data Margin = Margin | NoMargin
- deriving Eq
+ deriving (Eq)
-- | Collapse margins, any margin = margin
instance Semigroup Margin where
- NoMargin <> NoMargin = NoMargin
- _ <> _ = Margin
+ NoMargin <> NoMargin = NoMargin
+ _ <> _ = Margin
flattenBlocks :: [Block] -> [String]
-flattenBlocks = go0 where
+flattenBlocks = go0
+ where
go0 [] = []
go0 (Block _before after strs : blocks) = strs ++ go after blocks
go _surr' [] = []
- go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where
- ins | surr' <> before == Margin = ("" :)
- | otherwise = id
+ go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks
+ where
+ ins
+ | surr' <> before == Margin = ("" :)
+ | otherwise = id
renderField :: Opts ann -> Int -> PrettyField ann -> Block
renderField (Opts rann indent post) fw (PrettyField ann name doc) =
- Block before after content
+ Block before after content
where
content = case comments of
CommentBefore cs -> cs ++ post ann lines'
- CommentAfter cs -> post ann lines' ++ cs
- NoComment -> post ann lines'
+ CommentAfter cs -> post ann lines' ++ cs
+ NoComment -> post ann lines'
comments = rann ann
before = case comments of
CommentBefore [] -> NoMargin
- CommentAfter [] -> NoMargin
- NoComment -> NoMargin
- _ -> Margin
+ CommentAfter [] -> NoMargin
+ NoComment -> NoMargin
+ _ -> Margin
(lines', after) = case lines narrow of
- [] -> ([ name' ++ ":" ], NoMargin)
- [singleLine] | length singleLine < 60
- -> ([ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ], NoMargin)
- _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin)
+ [] -> ([name' ++ ":"], NoMargin)
+ [singleLine]
+ | length singleLine < 60 ->
+ ([name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow], NoMargin)
+ _ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin)
name' = fromUTF8BS name
narrow = PP.renderStyle narrowStyle doc
narrowStyle :: PP.Style
- narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw }
-
-renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $
-
+ narrowStyle = PP.style{PP.lineLength = PP.lineLength PP.style - fw}
+renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) =
+ Block Margin Margin $
attachComments
- (post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ])
- ++
- map indent (renderFields opts fields)
+ (post ann [PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args])
+ ++ map indent (renderFields opts fields)
where
attachComments content = case rann ann of
CommentBefore cs -> cs ++ content
- CommentAfter cs -> content ++ cs
- NoComment -> content
-
+ CommentAfter cs -> content ++ cs
+ NoComment -> content
renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty
-------------------------------------------------------------------------------
@@ -171,20 +174,24 @@ renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty
-------------------------------------------------------------------------------
genericFromParsecFields
- :: Applicative f
- => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents
- -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments
- -> [P.Field ann]
- -> f [PrettyField ann]
-genericFromParsecFields f g = goMany where
+ :: Applicative f
+ => (FieldName -> [P.FieldLine ann] -> f PP.Doc)
+ -- ^ transform field contents
+ -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc])
+ -- ^ transform section arguments
+ -> [P.Field ann]
+ -> f [PrettyField ann]
+genericFromParsecFields f g = goMany
+ where
goMany = traverse go
- go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls
+ go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls
go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs
-- | Used in 'fromParsecFields'.
prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc
-prettyFieldLines _ fls = PP.vcat
+prettyFieldLines _ fls =
+ PP.vcat
[ PP.text $ fromUTF8BS bs
| P.FieldLine _ bs <- fls
]
@@ -192,15 +199,17 @@ prettyFieldLines _ fls = PP.vcat
-- | Used in 'fromParsecFields'.
prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]
prettySectionArgs _ = map $ \case
- P.SecArgName _ bs -> showToken $ fromUTF8BS bs
- P.SecArgStr _ bs -> showToken $ fromUTF8BS bs
- P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs
+ P.SecArgName _ bs -> showToken $ fromUTF8BS bs
+ P.SecArgStr _ bs -> showToken $ fromUTF8BS bs
+ P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs
-- | Simple variant of 'genericFromParsecField'
fromParsecFields :: [P.Field ann] -> [PrettyField ann]
-fromParsecFields = runIdentity . genericFromParsecFields
- (Identity .: prettyFieldLines)
- (Identity .: prettySectionArgs)
+fromParsecFields =
+ runIdentity
+ . genericFromParsecFields
+ (Identity .: prettyFieldLines)
+ (Identity .: prettySectionArgs)
where
(.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b)
(f .: g) x y = f (g x y)
diff --git a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs
index 54a3fed6fc184a1c8b5970270d8dde1a06d115a3..a84b8856efd34f6048726f549c6447ad93893261 100644
--- a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs
+++ b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-- This module is meant to be local-only to Distribution...
+
-- |
-- Module : Distribution.InstalledPackageInfo
-- Copyright : (c) The University of Glasgow 2004
@@ -21,43 +24,40 @@
-- about an installed package. There is a parser and pretty printer. The
-- textual format is rather simpler than the @.cabal@ format: there are no
-- sections, for example.
-
--- This module is meant to be local-only to Distribution...
-
-module Distribution.InstalledPackageInfo (
- InstalledPackageInfo(..),
- installedComponentId,
- installedOpenUnitId,
- sourceComponentName,
- requiredSignatures,
- ExposedModule(..),
- AbiDependency(..),
- emptyInstalledPackageInfo,
- parseInstalledPackageInfo,
- showInstalledPackageInfo,
- showFullInstalledPackageInfo,
- showInstalledPackageInfoField,
- showSimpleInstalledPackageInfoField,
+module Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo (..)
+ , installedComponentId
+ , installedOpenUnitId
+ , sourceComponentName
+ , requiredSignatures
+ , ExposedModule (..)
+ , AbiDependency (..)
+ , emptyInstalledPackageInfo
+ , parseInstalledPackageInfo
+ , showInstalledPackageInfo
+ , showFullInstalledPackageInfo
+ , showInstalledPackageInfoField
+ , showSimpleInstalledPackageInfoField
) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Backpack
-import Distribution.CabalSpecVersion (cabalSpecLatest)
+import Distribution.CabalSpecVersion (cabalSpecLatest)
import Distribution.FieldGrammar
import Distribution.FieldGrammar.FieldDescrs
import Distribution.Fields.Pretty
import Distribution.ModuleName
-import Distribution.Package hiding (installedUnitId)
+import Distribution.Package hiding (installedUnitId)
import Distribution.Types.ComponentName
-import Distribution.Utils.Generic (toUTF8BS)
+import Distribution.Utils.Generic (toUTF8BS)
import Data.ByteString (ByteString)
-import qualified Data.Map as Map
+import qualified Data.Map as Map
import qualified Distribution.Fields as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
import Distribution.Types.InstalledPackageInfo
import Distribution.Types.InstalledPackageInfo.FieldGrammar
@@ -67,9 +67,9 @@ import Distribution.Types.InstalledPackageInfo.FieldGrammar
installedComponentId :: InstalledPackageInfo -> ComponentId
installedComponentId ipi =
- case unComponentId (installedComponentId_ ipi) of
- "" -> mkComponentId (unUnitId (installedUnitId ipi))
- _ -> installedComponentId_ ipi
+ case unComponentId (installedComponentId_ ipi) of
+ "" -> mkComponentId (unUnitId (installedUnitId ipi))
+ _ -> installedComponentId_ ipi
-- | Get the indefinite unit identity representing this package.
-- This IS NOT guaranteed to give you a substitution; for
@@ -77,8 +77,8 @@ installedComponentId ipi =
-- For indefinite libraries, however, you will correctly get
-- an @OpenUnitId@ with the appropriate 'OpenModuleSubst'.
installedOpenUnitId :: InstalledPackageInfo -> OpenUnitId
-installedOpenUnitId ipi
- = mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi))
+installedOpenUnitId ipi =
+ mkOpenUnitId (installedUnitId ipi) (installedComponentId ipi) (Map.fromList (instantiatedWith ipi))
-- | Returns the set of module names which need to be filled for
-- an indefinite package, or the empty set if the package is definite.
@@ -96,20 +96,23 @@ sourceComponentName = CLibName . sourceLibName
-- | Return either errors, or IPI with list of warnings
parseInstalledPackageInfo
- :: ByteString
- -> Either (NonEmpty String) ([String], InstalledPackageInfo)
+ :: ByteString
+ -> Either (NonEmpty String) ([String], InstalledPackageInfo)
parseInstalledPackageInfo s = case P.readFields s of
- Left err -> Left (show err :| [])
- Right fs -> case partitionFields fs of
- (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of
- (ws, Right x) -> x `deepseq` Right (ws', x) where
- ws' = [ P.showPWarning "" w
- | w@(P.PWarning wt _ _) <- ws
- -- filter out warnings about experimental features
- , wt /= P.PWTExperimental
- ]
- (_, Left (_, errs)) -> Left errs' where
- errs' = fmap (P.showPError "") errs
+ Left err -> Left (show err :| [])
+ Right fs -> case partitionFields fs of
+ (fs', _) -> case P.runParseResult $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of
+ (ws, Right x) -> x `deepseq` Right (ws', x)
+ where
+ ws' =
+ [ P.showPWarning "" w
+ | w@(P.PWarning wt _ _) <- ws
+ , -- filter out warnings about experimental features
+ wt /= P.PWTExperimental
+ ]
+ (_, Left (_, errs)) -> Left errs'
+ where
+ errs' = fmap (P.showPError "") errs
-- -----------------------------------------------------------------------------
-- Pretty-printing
@@ -119,7 +122,7 @@ parseInstalledPackageInfo s = case P.readFields s of
-- @pkgRoot@ isn't printed, as ghc-pkg prints it manually (as GHC-8.4).
showInstalledPackageInfo :: InstalledPackageInfo -> String
showInstalledPackageInfo ipi =
- showFullInstalledPackageInfo ipi { pkgRoot = Nothing }
+ showFullInstalledPackageInfo ipi{pkgRoot = Nothing}
-- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too.
showFullInstalledPackageInfo :: InstalledPackageInfo -> String
@@ -132,15 +135,15 @@ showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGramm
-- Just "maintainer: Tester"
showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showInstalledPackageInfoField fn =
- fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
+ fmap (\g -> Disp.render . ppField fn . g) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
showSimpleInstalledPackageInfoField fn =
- fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
+ fmap (Disp.renderStyle myStyle .) $ fieldDescrPretty ipiFieldGrammar (toUTF8BS fn)
where
- myStyle = Disp.style { Disp.mode = Disp.LeftMode }
+ myStyle = Disp.style{Disp.mode = Disp.LeftMode}
ppField :: String -> Disp.Doc -> Disp.Doc
ppField name fielddoc
- | Disp.isEmpty fielddoc = mempty
- | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc
+ | Disp.isEmpty fielddoc = mempty
+ | otherwise = Disp.text name <<>> Disp.colon Disp.<+> fielddoc
diff --git a/Cabal-syntax/src/Distribution/License.hs b/Cabal-syntax/src/Distribution/License.hs
index 51cac84603702702cfcb4120650ca44cf9b9a5fc..f79ef6d05496b7685a137d0d83e576b3db5d5901 100644
--- a/Cabal-syntax/src/Distribution/License.hs
+++ b/Cabal-syntax/src/Distribution/License.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.License
-- Description : The License data type.
@@ -41,12 +42,11 @@
-- intended for informational purposes only and in no way constitute legal
-- advice. Please read the text of the licenses and consult a lawyer for any
-- advice regarding software licensing.
-
-module Distribution.License (
- License(..),
- knownLicenses,
- licenseToSPDX,
- licenseFromSPDX,
+module Distribution.License
+ ( License (..)
+ , knownLicenses
+ , licenseToSPDX
+ , licenseFromSPDX
) where
import Distribution.Compat.Prelude
@@ -56,75 +56,61 @@ import Distribution.Parsec
import Distribution.Pretty
import Distribution.Version
+import qualified Data.Map.Strict as Map
import qualified Distribution.Compat.CharParsing as P
-import qualified Data.Map.Strict as Map
-import qualified Distribution.SPDX as SPDX
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.SPDX as SPDX
+import qualified Text.PrettyPrint as Disp
-- | Indicates the license under which a package's source code is released.
-- Versions of the licenses not listed here will be rejected by Hackage and
-- cause @cabal check@ to issue a warning.
-data License =
- -- TODO: * remove BSD4
+data License
+ = -- TODO: * remove BSD4
-- | GNU General Public License,
-- <https://www.gnu.org/licenses/old-licenses/gpl-2.0.html version 2> or
-- <https://www.gnu.org/licenses/gpl.html version 3>.
GPL (Maybe Version)
-
- -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.
- | AGPL (Maybe Version)
-
- -- | GNU Lesser General Public License,
+ | -- | <https://www.gnu.org/licenses/agpl.html GNU Affero General Public License, version 3>.
+ AGPL (Maybe Version)
+ | -- | GNU Lesser General Public License,
-- <https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html version 2.1> or
-- <https://www.gnu.org/licenses/lgpl.html version 3>.
- | LGPL (Maybe Version)
-
- -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.
- | BSD2
-
- -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.
- | BSD3
-
- -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.
+ LGPL (Maybe Version)
+ | -- | <http://www.opensource.org/licenses/bsd-license 2-clause BSD license>.
+ BSD2
+ | -- | <http://www.opensource.org/licenses/bsd-3-clause 3-clause BSD license>.
+ BSD3
+ | -- | <http://directory.fsf.org/wiki/License:BSD_4Clause 4-clause BSD license>.
-- This license has not been approved by the OSI and is incompatible with
-- the GNU GPL. It is provided for historical reasons and should be avoided.
- | BSD4
-
- -- | <http://www.opensource.org/licenses/MIT MIT license>.
- | MIT
-
- -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>
- | ISC
-
- -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.
- | MPL Version
-
- -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.
- | Apache (Maybe Version)
-
- -- | The author of a package disclaims any copyright to its source code and
+ BSD4
+ | -- | <http://www.opensource.org/licenses/MIT MIT license>.
+ MIT
+ | -- | <http://www.isc.org/downloads/software-support-policy/isc-license/ ISC license>
+ ISC
+ | -- | <https://www.mozilla.org/MPL/ Mozilla Public License, version 2.0>.
+ MPL Version
+ | -- | <https://www.apache.org/licenses/ Apache License, version 2.0>.
+ Apache (Maybe Version)
+ | -- | The author of a package disclaims any copyright to its source code and
-- dedicates it to the public domain. This is not a software license. Please
-- note that it is not possible to dedicate works to the public domain in
-- every jurisdiction, nor is a work that is in the public domain in one
-- jurisdiction necessarily in the public domain elsewhere.
- | PublicDomain
-
- -- | Explicitly 'All Rights Reserved', eg for proprietary software. The
+ PublicDomain
+ | -- | Explicitly 'All Rights Reserved', eg for proprietary software. The
-- package may not be legally modified or redistributed by anyone but the
-- rightsholder.
- | AllRightsReserved
-
- -- | No license specified which legally defaults to 'All Rights Reserved'.
+ AllRightsReserved
+ | -- | No license specified which legally defaults to 'All Rights Reserved'.
-- The package may not be legally modified or redistributed by anyone but
-- the rightsholder.
- | UnspecifiedLicense
-
- -- | Any other software license.
- | OtherLicense
-
- -- | Indicates an erroneous license name.
- | UnknownLicense String
+ UnspecifiedLicense
+ | -- | Any other software license.
+ OtherLicense
+ | -- | Indicates an erroneous license name.
+ UnknownLicense String
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary License
@@ -133,16 +119,29 @@ instance NFData License where rnf = genericRnf
-- | The list of all currently recognised licenses.
knownLicenses :: [License]
-knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
- , LGPL unversioned, LGPL (version [2, 1]), LGPL (version [3])
- , AGPL unversioned, AGPL (version [3])
- , BSD2, BSD3, MIT, ISC
- , MPL (mkVersion [2, 0])
- , Apache unversioned, Apache (version [2, 0])
- , PublicDomain, AllRightsReserved, OtherLicense]
+knownLicenses =
+ [ GPL unversioned
+ , GPL (version [2])
+ , GPL (version [3])
+ , LGPL unversioned
+ , LGPL (version [2, 1])
+ , LGPL (version [3])
+ , AGPL unversioned
+ , AGPL (version [3])
+ , BSD2
+ , BSD3
+ , MIT
+ , ISC
+ , MPL (mkVersion [2, 0])
+ , Apache unversioned
+ , Apache (version [2, 0])
+ , PublicDomain
+ , AllRightsReserved
+ , OtherLicense
+ ]
where
unversioned = Nothing
- version = Just . mkVersion
+ version = Just . mkVersion
-- | Convert old 'License' to SPDX 'SPDX.License'.
-- Non-SPDX licenses are converted to 'SPDX.LicenseRef'.
@@ -150,28 +149,28 @@ knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
-- @since 2.2.0.0
licenseToSPDX :: License -> SPDX.License
licenseToSPDX l = case l of
- GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only
- GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only
- LGPL v | v == version [2,1] -> spdx SPDX.LGPL_2_1_only
- LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only
- AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only
- BSD2 -> spdx SPDX.BSD_2_Clause
- BSD3 -> spdx SPDX.BSD_3_Clause
- BSD4 -> spdx SPDX.BSD_4_Clause
- MIT -> spdx SPDX.MIT
- ISC -> spdx SPDX.ISC
- MPL v | v == mkVersion [2,0] -> spdx SPDX.MPL_2_0
- Apache v | v == version [2,0] -> spdx SPDX.Apache_2_0
- AllRightsReserved -> SPDX.NONE
- UnspecifiedLicense -> SPDX.NONE
- OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense")
- PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain")
- UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str)
- _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l)
+ GPL v | v == version [2] -> spdx SPDX.GPL_2_0_only
+ GPL v | v == version [3] -> spdx SPDX.GPL_3_0_only
+ LGPL v | v == version [2, 1] -> spdx SPDX.LGPL_2_1_only
+ LGPL v | v == version [3] -> spdx SPDX.LGPL_3_0_only
+ AGPL v | v == version [3] -> spdx SPDX.AGPL_3_0_only
+ BSD2 -> spdx SPDX.BSD_2_Clause
+ BSD3 -> spdx SPDX.BSD_3_Clause
+ BSD4 -> spdx SPDX.BSD_4_Clause
+ MIT -> spdx SPDX.MIT
+ ISC -> spdx SPDX.ISC
+ MPL v | v == mkVersion [2, 0] -> spdx SPDX.MPL_2_0
+ Apache v | v == version [2, 0] -> spdx SPDX.Apache_2_0
+ AllRightsReserved -> SPDX.NONE
+ UnspecifiedLicense -> SPDX.NONE
+ OtherLicense -> ref (SPDX.mkLicenseRef' Nothing "OtherLicense")
+ PublicDomain -> ref (SPDX.mkLicenseRef' Nothing "PublicDomain")
+ UnknownLicense str -> ref (SPDX.mkLicenseRef' Nothing str)
+ _ -> ref (SPDX.mkLicenseRef' Nothing $ prettyShow l)
where
version = Just . mkVersion
- spdx = SPDX.License . SPDX.simpleLicenseExpression
- ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing
+ spdx = SPDX.License . SPDX.simpleLicenseExpression
+ ref r = SPDX.License $ SPDX.ELicense (SPDX.ELicenseRef r) Nothing
-- | Convert 'SPDX.License' to 'License',
--
@@ -199,11 +198,13 @@ licenseToSPDX l = case l of
licenseFromSPDX :: SPDX.License -> License
licenseFromSPDX SPDX.NONE = AllRightsReserved
licenseFromSPDX l =
- fromMaybe (mungle $ prettyShow l) $ Map.lookup l m
+ fromMaybe (mungle $ prettyShow l) $ Map.lookup l m
where
m :: Map.Map SPDX.License License
- m = Map.fromList $ filter (isSimple . fst ) $
- map (\x -> (licenseToSPDX x, x)) knownLicenses
+ m =
+ Map.fromList $
+ filter (isSimple . fst) $
+ map (\x -> (licenseToSPDX x, x)) knownLicenses
isSimple (SPDX.License (SPDX.ELicense (SPDX.ELicenseId _) Nothing)) = True
isSimple _ = False
@@ -211,41 +212,43 @@ licenseFromSPDX l =
mungle name = fromMaybe (UnknownLicense (mapMaybe mangle name)) (simpleParsec name)
mangle c
- | isAlphaNum c = Just c
- | otherwise = Nothing
+ | isAlphaNum c = Just c
+ | otherwise = Nothing
instance Pretty License where
- pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version
- pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version
- pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version
- pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version
- pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version
+ pretty (GPL version) = Disp.text "GPL" <<>> dispOptVersion version
+ pretty (LGPL version) = Disp.text "LGPL" <<>> dispOptVersion version
+ pretty (AGPL version) = Disp.text "AGPL" <<>> dispOptVersion version
+ pretty (MPL version) = Disp.text "MPL" <<>> dispVersion version
+ pretty (Apache version) = Disp.text "Apache" <<>> dispOptVersion version
pretty (UnknownLicense other) = Disp.text other
- pretty other = Disp.text (show other)
+ pretty other = Disp.text (show other)
instance Parsec License where
parsec = do
- name <- P.munch1 isAlphaNum
+ name <- P.munch1 isAlphaNum
version <- P.optional (P.char '-' *> parsec)
return $! case (name, version :: Maybe Version) of
- ("GPL", _ ) -> GPL version
- ("LGPL", _ ) -> LGPL version
- ("AGPL", _ ) -> AGPL version
- ("BSD2", Nothing) -> BSD2
- ("BSD3", Nothing) -> BSD3
- ("BSD4", Nothing) -> BSD4
- ("ISC", Nothing) -> ISC
- ("MIT", Nothing) -> MIT
- ("MPL", Just version') -> MPL version'
- ("Apache", _ ) -> Apache version
- ("PublicDomain", Nothing) -> PublicDomain
- ("AllRightsReserved", Nothing) -> AllRightsReserved
- ("OtherLicense", Nothing) -> OtherLicense
- _ -> UnknownLicense $ name ++
- maybe "" (('-':) . prettyShow) version
+ ("GPL", _) -> GPL version
+ ("LGPL", _) -> LGPL version
+ ("AGPL", _) -> AGPL version
+ ("BSD2", Nothing) -> BSD2
+ ("BSD3", Nothing) -> BSD3
+ ("BSD4", Nothing) -> BSD4
+ ("ISC", Nothing) -> ISC
+ ("MIT", Nothing) -> MIT
+ ("MPL", Just version') -> MPL version'
+ ("Apache", _) -> Apache version
+ ("PublicDomain", Nothing) -> PublicDomain
+ ("AllRightsReserved", Nothing) -> AllRightsReserved
+ ("OtherLicense", Nothing) -> OtherLicense
+ _ ->
+ UnknownLicense $
+ name
+ ++ maybe "" (('-' :) . prettyShow) version
dispOptVersion :: Maybe Version -> Disp.Doc
-dispOptVersion Nothing = Disp.empty
+dispOptVersion Nothing = Disp.empty
dispOptVersion (Just v) = dispVersion v
dispVersion :: Version -> Disp.Doc
diff --git a/Cabal-syntax/src/Distribution/ModuleName.hs b/Cabal-syntax/src/Distribution/ModuleName.hs
index f23050f296a66ce6373df678f7fa5adce39dc1e9..90082d29f065d5c56e9a0765fd38fc09bcd49d08 100644
--- a/Cabal-syntax/src/Distribution/ModuleName.hs
+++ b/Cabal-syntax/src/Distribution/ModuleName.hs
@@ -1,8 +1,10 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.ModuleName
-- Copyright : Duncan Coutts 2008
@@ -12,16 +14,16 @@
-- Portability : portable
--
-- Data type for Haskell module names.
-
-module Distribution.ModuleName (
- ModuleName,
- fromString,
- fromComponents,
- components,
- toFilePath,
- main,
- -- * Internal
- validModuleComponent,
+module Distribution.ModuleName
+ ( ModuleName
+ , fromString
+ , fromComponents
+ , components
+ , toFilePath
+ , main
+
+ -- * Internal
+ , validModuleComponent
) where
import Distribution.Compat.Prelude
@@ -30,14 +32,13 @@ import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Utils.ShortText (ShortText, fromShortText, toShortText)
-import System.FilePath (pathSeparator)
+import System.FilePath (pathSeparator)
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.Compat.DList as DList
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.Compat.DList as DList
+import qualified Text.PrettyPrint as Disp
-- | A valid Haskell module name.
---
newtype ModuleName = ModuleName ShortText
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
@@ -48,16 +49,17 @@ instance Binary ModuleName
instance Structured ModuleName
instance NFData ModuleName where
- rnf (ModuleName ms) = rnf ms
+ rnf (ModuleName ms) = rnf ms
instance Pretty ModuleName where
pretty = Disp.text . unModuleName
instance Parsec ModuleName where
- parsec = parsecModuleName
+ parsec = parsecModuleName
parsecModuleName :: forall m. CabalParsing m => m ModuleName
-parsecModuleName = state0 DList.empty where
+parsecModuleName = state0 DList.empty
+ where
upper :: m Char
!upper = P.satisfy isUpper
@@ -69,34 +71,33 @@ parsecModuleName = state0 DList.empty where
state0 :: DList.DList Char -> m ModuleName
state0 acc = do
- c <- upper
- state1 (DList.snoc acc c)
+ c <- upper
+ state1 (DList.snoc acc c)
state1 :: DList.DList Char -> m ModuleName
state1 acc = state1' acc `alt` return (fromString (DList.toList acc))
state1' :: DList.DList Char -> m ModuleName
state1' acc = do
- c <- ch
- case c of
- '.' -> state0 (DList.snoc acc c)
- _ -> state1 (DList.snoc acc c)
+ c <- ch
+ case c of
+ '.' -> state0 (DList.snoc acc c)
+ _ -> state1 (DList.snoc acc c)
validModuleChar :: Char -> Bool
validModuleChar c = isAlphaNum c || c == '_' || c == '\''
validModuleComponent :: String -> Bool
-validModuleComponent [] = False
-validModuleComponent (c:cs) = isUpper c && all validModuleChar cs
+validModuleComponent [] = False
+validModuleComponent (c : cs) = isUpper c && all validModuleChar cs
-- | Construct a 'ModuleName' from a valid module name 'String'.
--
-- This is just a convenience function intended for valid module strings. It is
-- an error if it is used with a string that is not a valid module name. If you
-- are parsing user input then use 'Distribution.Text.simpleParse' instead.
---
instance IsString ModuleName where
- fromString = ModuleName . toShortText
+ fromString = ModuleName . toShortText
-- | Construct a 'ModuleName' from valid module components, i.e. parts
-- separated by dots.
@@ -105,27 +106,25 @@ fromComponents comps = fromString (intercalate "." comps)
{-# DEPRECATED fromComponents "Exists for cabal-install only" #-}
-- | The module name @Main@.
---
main :: ModuleName
main = ModuleName (fromString "Main")
-- | The individual components of a hierarchical module name. For example
--
-- > components (fromString "A.B.C") = ["A", "B", "C"]
---
components :: ModuleName -> [String]
components mn = split (unModuleName mn)
where
- split cs = case break (=='.') cs of
- (chunk,[]) -> chunk : []
- (chunk,_:rest) -> chunk : split rest
+ split cs = case break (== '.') cs of
+ (chunk, []) -> chunk : []
+ (chunk, _ : rest) -> chunk : split rest
-- | Convert a module name to a file path, but without any file extension.
-- For example:
--
-- > toFilePath (fromString "A.B.C") = "A/B/C"
---
toFilePath :: ModuleName -> FilePath
-toFilePath = map f . unModuleName where
+toFilePath = map f . unModuleName
+ where
f '.' = pathSeparator
- f c = c
+ f c = c
diff --git a/Cabal-syntax/src/Distribution/Package.hs b/Cabal-syntax/src/Distribution/Package.hs
index 6c2950b26f01e1fff373a6cb8d9a95601685bd67..c4f2034939135d5cd2e5615713dcd7928052a4b6 100644
--- a/Cabal-syntax/src/Distribution/Package.hs
+++ b/Cabal-syntax/src/Distribution/Package.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Package
-- Copyright : Isaac Jones 2003-2004
@@ -15,7 +16,6 @@
-- 'PackageIdentifier's consist of a name and an exact version. It also defines
-- a 'Dependency' data type. A dependency is a package name and a version
-- range, like @\"foo >= 1.2 && < 2\"@.
-
module Distribution.Package
( module Distribution.Types.AbiHash
, module Distribution.Types.ComponentId
@@ -25,28 +25,33 @@ module Distribution.Package
, module Distribution.Types.PackageName
, module Distribution.Types.PkgconfigName
, module Distribution.Types.Dependency
- , Package(..), packageName, packageVersion
- , HasMungedPackageId(..), mungedName', mungedVersion'
- , HasUnitId(..)
- , PackageInstalled(..)
+ , Package (..)
+ , packageName
+ , packageVersion
+ , HasMungedPackageId (..)
+ , mungedName'
+ , mungedVersion'
+ , HasUnitId (..)
+ , PackageInstalled (..)
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Version
- ( Version )
+ ( Version
+ )
import Distribution.Types.AbiHash
import Distribution.Types.ComponentId
import Distribution.Types.Dependency
-import Distribution.Types.MungedPackageId
-import Distribution.Types.PackageId
-import Distribution.Types.UnitId
import Distribution.Types.Module
+import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
+import Distribution.Types.PackageId
import Distribution.Types.PackageName
import Distribution.Types.PkgconfigName
+import Distribution.Types.UnitId
-- | Class of things that have a 'PackageIdentifier'
--
@@ -57,15 +62,14 @@ import Distribution.Types.PkgconfigName
-- Not all kinds of packages can be uniquely identified by a
-- 'PackageIdentifier'. In particular, installed packages cannot, there may be
-- many installed instances of the same source package.
---
class Package pkg where
- packageId :: pkg -> PackageIdentifier
+ packageId :: pkg -> PackageIdentifier
-mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName
-mungedName' = mungedName . mungedId
+mungedName' :: HasMungedPackageId pkg => pkg -> MungedPackageName
+mungedName' = mungedName . mungedId
mungedVersion' :: HasMungedPackageId munged => munged -> Version
-mungedVersion' = mungedVersion . mungedId
+mungedVersion' = mungedVersion . mungedId
class HasMungedPackageId pkg where
mungedId :: pkg -> MungedPackageId
@@ -73,11 +77,11 @@ class HasMungedPackageId pkg where
instance Package PackageIdentifier where
packageId = id
-packageName :: Package pkg => pkg -> PackageName
-packageName = pkgName . packageId
+packageName :: Package pkg => pkg -> PackageName
+packageName = pkgName . packageId
packageVersion :: Package pkg => pkg -> Version
-packageVersion = pkgVersion . packageId
+packageVersion = pkgVersion . packageId
instance HasMungedPackageId MungedPackageId where
mungedId = id
@@ -92,5 +96,5 @@ class Package pkg => HasUnitId pkg where
-- 'InstalledPackageInfo', but when we are doing install plans in Cabal install
-- we may have other, installed package-like things which contain more metadata.
-- Installed packages have exact dependencies 'installedDepends'.
-class (HasUnitId pkg) => PackageInstalled pkg where
+class HasUnitId pkg => PackageInstalled pkg where
installedDepends :: pkg -> [UnitId]
diff --git a/Cabal-syntax/src/Distribution/PackageDescription.hs b/Cabal-syntax/src/Distribution/PackageDescription.hs
index 7da966e85b70c6fc234106d198423b4663a07198..47d46673e5f4502653b743c4d1ce17fa1644b7a9 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.PackageDescription
-- Copyright : Isaac Jones 2003-2005
@@ -9,67 +10,81 @@
--
-- Backwards compatibility reexport of most things you need to know
-- about @.cabal@ files.
+module Distribution.PackageDescription
+ ( -- * PD and GPD
+ module Distribution.Types.PackageDescription
+ , module Distribution.Types.GenericPackageDescription
-module Distribution.PackageDescription (
- -- * PD and GPD
- module Distribution.Types.PackageDescription,
- module Distribution.Types.GenericPackageDescription,
-- * Components
- module Distribution.Types.ComponentName,
+ , module Distribution.Types.ComponentName
+
-- ** Library
- module Distribution.Types.Library,
- module Distribution.Types.LibraryName,
- module Distribution.Types.LibraryVisibility,
+ , module Distribution.Types.Library
+ , module Distribution.Types.LibraryName
+ , module Distribution.Types.LibraryVisibility
+
-- ** Executable
- module Distribution.Types.Executable,
- module Distribution.Types.ExecutableScope,
+ , module Distribution.Types.Executable
+ , module Distribution.Types.ExecutableScope
+
-- ** TestSuite
- module Distribution.Types.TestSuite,
- module Distribution.Types.TestType,
- module Distribution.Types.TestSuiteInterface,
+ , module Distribution.Types.TestSuite
+ , module Distribution.Types.TestType
+ , module Distribution.Types.TestSuiteInterface
+
-- ** Benchmark
- module Distribution.Types.Benchmark,
- module Distribution.Types.BenchmarkType,
- module Distribution.Types.BenchmarkInterface,
+ , module Distribution.Types.Benchmark
+ , module Distribution.Types.BenchmarkType
+ , module Distribution.Types.BenchmarkInterface
+
-- ** Foreign library
- module Distribution.Types.ForeignLib,
- module Distribution.Types.ForeignLibType,
- module Distribution.Types.ForeignLibOption,
+ , module Distribution.Types.ForeignLib
+ , module Distribution.Types.ForeignLibType
+ , module Distribution.Types.ForeignLibOption
+
-- * BuildInfo
- module Distribution.Types.BuildType,
- module Distribution.Types.BuildInfo,
- module Distribution.Types.HookedBuildInfo,
- module Distribution.Types.SetupBuildInfo,
+ , module Distribution.Types.BuildType
+ , module Distribution.Types.BuildInfo
+ , module Distribution.Types.HookedBuildInfo
+ , module Distribution.Types.SetupBuildInfo
+
-- * Flags
- module Distribution.Types.Flag,
+ , module Distribution.Types.Flag
+
-- * Identifiers
- module Distribution.Types.PackageId,
- module Distribution.Types.PackageName,
- module Distribution.Types.UnqualComponentName,
+ , module Distribution.Types.PackageId
+ , module Distribution.Types.PackageName
+ , module Distribution.Types.UnqualComponentName
+
-- * Pkgconfig
- module Distribution.Types.PkgconfigName,
- module Distribution.Types.PkgconfigVersion,
- module Distribution.Types.PkgconfigVersionRange,
+ , module Distribution.Types.PkgconfigName
+ , module Distribution.Types.PkgconfigVersion
+ , module Distribution.Types.PkgconfigVersionRange
+
-- * Dependencies
- module Distribution.Types.Dependency,
- module Distribution.Types.ExeDependency,
- module Distribution.Types.LegacyExeDependency,
- module Distribution.Types.PkgconfigDependency,
+ , module Distribution.Types.Dependency
+ , module Distribution.Types.ExeDependency
+ , module Distribution.Types.LegacyExeDependency
+ , module Distribution.Types.PkgconfigDependency
+
-- * Condition trees
- module Distribution.Types.CondTree,
- module Distribution.Types.Condition,
- module Distribution.Types.ConfVar,
+ , module Distribution.Types.CondTree
+ , module Distribution.Types.Condition
+ , module Distribution.Types.ConfVar
+
-- * Mixin
- module Distribution.Types.IncludeRenaming,
- module Distribution.Types.Mixin,
- module Distribution.Types.ModuleReexport,
- module Distribution.Types.ModuleRenaming,
+ , module Distribution.Types.IncludeRenaming
+ , module Distribution.Types.Mixin
+ , module Distribution.Types.ModuleReexport
+ , module Distribution.Types.ModuleRenaming
+
-- * Source repository
- module Distribution.Types.SourceRepo,
+ , module Distribution.Types.SourceRepo
) where
import Prelude ()
---import Distribution.Compat.Prelude
+
+-- import Distribution.Compat.Prelude
import Distribution.Types.Benchmark
import Distribution.Types.BenchmarkInterface
@@ -77,13 +92,13 @@ import Distribution.Types.BenchmarkType
import Distribution.Types.BuildInfo
import Distribution.Types.BuildType
import Distribution.Types.ComponentName
-import Distribution.Types.Condition
import Distribution.Types.CondTree
+import Distribution.Types.Condition
import Distribution.Types.ConfVar
import Distribution.Types.Dependency
+import Distribution.Types.ExeDependency
import Distribution.Types.Executable
import Distribution.Types.ExecutableScope
-import Distribution.Types.ExeDependency
import Distribution.Types.Flag
import Distribution.Types.ForeignLib
import Distribution.Types.ForeignLibOption
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
index b9bb9dcb555bd53ef6be91762ae39d67379e0cf6..9a9ba2d75001f7b41ba173580c8d57c62d1dbce1 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs
@@ -1,6 +1,8 @@
-- -fno-warn-deprecations for use of Map.foldWithKey
{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.PackageDescription.Configuration
-- Copyright : Thomas Schilling, 2007
@@ -14,76 +16,78 @@
-- functions for converting 'GenericPackageDescription's down to
-- 'PackageDescription's. It has code for working with the tree of conditions
-- and resolving or flattening conditions.
-
-module Distribution.PackageDescription.Configuration (
- finalizePD,
- flattenPackageDescription,
-
- -- Utils
- parseCondition,
- freeVars,
- extractCondition,
- extractConditions,
- addBuildableCondition,
- mapCondTree,
- mapTreeData,
- mapTreeConds,
- mapTreeConstrs,
- transformAllBuildInfos,
- transformAllBuildDepends,
- transformAllBuildDependsN,
- simplifyWithSysParams
+module Distribution.PackageDescription.Configuration
+ ( finalizePD
+ , flattenPackageDescription
+ -- Utils
+ , parseCondition
+ , freeVars
+ , extractCondition
+ , extractConditions
+ , addBuildableCondition
+ , mapCondTree
+ , mapTreeData
+ , mapTreeConds
+ , mapTreeConstrs
+ , transformAllBuildInfos
+ , transformAllBuildDepends
+ , transformAllBuildDependsN
+ , simplifyWithSysParams
) where
import Distribution.Compat.Prelude
import Prelude ()
-- lens
-import qualified Distribution.Types.BuildInfo.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
-import qualified Distribution.Types.PackageDescription.Lens as L
-import qualified Distribution.Types.SetupBuildInfo.Lens as L
-
-import Distribution.Compat.CharParsing hiding (char)
-import qualified Distribution.Compat.CharParsing as P
-import Distribution.Compat.Lens
-import Distribution.Compiler
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Utils
-import Distribution.Parsec
-import Distribution.Pretty
-import Distribution.System
-import Distribution.Types.Component
+import qualified Distribution.Types.PackageDescription.Lens as L
+import qualified Distribution.Types.SetupBuildInfo.Lens as L
+
+import Distribution.Compat.CharParsing hiding (char)
+import qualified Distribution.Compat.CharParsing as P
+import Distribution.Compat.Lens
+import Distribution.Compiler
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Utils
+import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.System
+import Distribution.Types.Component
+import Distribution.Types.ComponentRequestedSpec
+import Distribution.Types.DependencyMap
+import Distribution.Types.PackageVersionConstraint
+import Distribution.Utils.Generic
import Distribution.Utils.Path
-import Distribution.Types.ComponentRequestedSpec
-import Distribution.Types.DependencyMap
-import Distribution.Types.PackageVersionConstraint
-import Distribution.Utils.Generic
-import Distribution.Version
+import Distribution.Version
import qualified Data.Map.Lazy as Map
-import Data.Tree (Tree (Node))
+import Data.Tree (Tree (Node))
------------------------------------------------------------------------------
-- | Simplify a configuration condition using the OS and arch names. Returns
-- the names of all the flags occurring in the condition.
-simplifyWithSysParams :: OS -> Arch -> CompilerInfo -> Condition ConfVar
- -> (Condition FlagName, [FlagName])
+simplifyWithSysParams
+ :: OS
+ -> Arch
+ -> CompilerInfo
+ -> Condition ConfVar
+ -> (Condition FlagName, [FlagName])
simplifyWithSysParams os arch cinfo cond = (cond', flags)
where
(cond', flags) = simplifyCondition cond interp
- interp (OS os') = Right $ os' == os
+ interp (OS os') = Right $ os' == os
interp (Arch arch') = Right $ arch' == arch
interp (Impl comp vr)
| matchImpl (compilerInfoId cinfo) = Right True
| otherwise = case compilerInfoCompat cinfo of
-- fixme: treat Nothing as unknown, rather than empty list once we
-- support partial resolution of system parameters
- Nothing -> Right False
+ Nothing -> Right False
Just compat -> Right (any matchImpl compat)
- where
- matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
+ where
+ matchImpl (CompilerId c v) = comp == c && v `withinRange` vr
interp (PackageFlag f) = Left f
-- TODO: Add instances and check
@@ -107,27 +111,36 @@ simplifyWithSysParams os arch cinfo cond = (cond', flags)
parseCondition :: CabalParsing m => m (Condition ConfVar)
parseCondition = condOr
where
- condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
- condAnd = sepByNonEmpty cond (oper "&&")>>= return . foldl1 CAnd
+ condOr = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
+ condAnd = sepByNonEmpty cond (oper "&&") >>= return . foldl1 CAnd
-- TODO: try?
- cond = sp >> (boolLiteral <|> inparens condOr <|> notCond <|> osCond
- <|> archCond <|> flagCond <|> implCond )
- inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp)
- notCond = P.char '!' >> sp >> cond >>= return . CNot
- osCond = string "os" >> sp >> inparens osIdent >>= return . Var
+ cond =
+ sp
+ >> ( boolLiteral
+ <|> inparens condOr
+ <|> notCond
+ <|> osCond
+ <|> archCond
+ <|> flagCond
+ <|> implCond
+ )
+ inparens = between (P.char '(' >> sp) (sp >> P.char ')' >> sp)
+ notCond = P.char '!' >> sp >> cond >>= return . CNot
+ osCond = string "os" >> sp >> inparens osIdent >>= return . Var
archCond = string "arch" >> sp >> inparens archIdent >>= return . Var
flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var
implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
- boolLiteral = fmap Lit parsec
- archIdent = fmap Arch parsec
- osIdent = fmap OS parsec
- flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar)
+ boolLiteral = fmap Lit parsec
+ archIdent = fmap Arch parsec
+ osIdent = fmap OS parsec
+ flagIdent = fmap (PackageFlag . mkFlagName . lowercase) (munch1 isIdentChar)
isIdentChar c = isAlphaNum c || c == '_' || c == '-'
- oper s = sp >> string s >> sp
- sp = spaces
- implIdent = do i <- parsec
- vr <- sp >> option anyVersion parsec
- return $ Impl i vr
+ oper s = sp >> string s >> sp
+ sp = spaces
+ implIdent = do
+ i <- parsec
+ vr <- sp >> option anyVersion parsec
+ return $ Impl i vr
------------------------------------------------------------------------------
@@ -136,14 +149,13 @@ parseCondition = condOr
data DepTestRslt d = DepOk | MissingDeps d
instance Semigroup d => Monoid (DepTestRslt d) where
- mempty = DepOk
- mappend = (<>)
+ mempty = DepOk
+ mappend = (<>)
instance Semigroup d => Semigroup (DepTestRslt d) where
- DepOk <> x = x
- x <> DepOk = x
- (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
-
+ DepOk <> x = x
+ x <> DepOk = x
+ (MissingDeps d) <> (MissingDeps d') = MissingDeps (d <> d')
-- | Try to find a flag assignment that satisfies the constraints of all trees.
--
@@ -165,64 +177,75 @@ instance Semigroup d => Semigroup (DepTestRslt d) where
--
-- This would require some sort of SAT solving, though, thus it's not
-- implemented unless we really need it.
---
-resolveWithFlags ::
- [(FlagName,[Bool])]
- -- ^ Domain for each flag name, will be tested in order.
+resolveWithFlags
+ :: [(FlagName, [Bool])]
+ -- ^ Domain for each flag name, will be tested in order.
-> ComponentRequestedSpec
- -> OS -- ^ OS where the installed artifacts will run (host OS)
- -> Arch -- ^ Arch where the installed artifacts will run (host Arch)
- -> CompilerInfo -- ^ Compiler information
- -> [PackageVersionConstraint] -- ^ Additional constraints
+ -> OS
+ -- ^ OS where the installed artifacts will run (host OS)
+ -> Arch
+ -- ^ Arch where the installed artifacts will run (host Arch)
+ -> CompilerInfo
+ -- ^ Compiler information
+ -> [PackageVersionConstraint]
+ -- ^ Additional constraints
-> [CondTree ConfVar [Dependency] PDTagged]
- -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
+ -> ([Dependency] -> DepTestRslt [Dependency])
+ -- ^ Dependency test function.
-> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
- -- ^ Either the missing dependencies (error case), or a pair of
- -- (set of build targets with dependencies, chosen flag assignments)
+ -- ^ Either the missing dependencies (error case), or a pair of
+ -- (set of build targets with dependencies, chosen flag assignments)
resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
- either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
+ either (Left . fromDepMapUnion) Right $ explore (build mempty dom)
where
-- simplify trees by (partially) evaluating all conditions and converting
-- dependencies to dependency maps.
simplifiedTrees :: [CondTree FlagName DependencyMap PDTagged]
- simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps
- . addBuildableConditionPDTagged
- . mapTreeConds (fst . simplifyWithSysParams os arch impl))
- trees
+ simplifiedTrees =
+ map
+ ( mapTreeConstrs toDepMap -- convert to maps
+ . addBuildableConditionPDTagged
+ . mapTreeConds (fst . simplifyWithSysParams os arch impl)
+ )
+ trees
-- @explore@ searches a tree of assignments, backtracking whenever a flag
-- introduces a dependency that cannot be satisfied. If there is no
-- solution, @explore@ returns the union of all dependencies that caused
-- it to backtrack. Since the tree is constructed lazily, we avoid some
-- computation overhead in the successful case.
- explore :: Tree FlagAssignment
- -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
+ explore
+ :: Tree FlagAssignment
+ -> Either DepMapUnion (TargetSet PDTagged, FlagAssignment)
explore (Node flags ts) =
- let targetSet = TargetSet $ flip map simplifiedTrees $
+ let targetSet =
+ TargetSet $
+ flip map simplifiedTrees $
-- apply additional constraints to all dependencies
- first (`constrainBy` constrs) .
- simplifyCondTree (env flags)
- deps = overallDependencies enabled targetSet
- in case checkDeps (fromDepMap deps) of
- DepOk | null ts -> Right (targetSet, flags)
- | otherwise -> tryAll $ map explore ts
- MissingDeps mds -> Left (toDepMapUnion mds)
+ first (`constrainBy` constrs)
+ . simplifyCondTree (env flags)
+ deps = overallDependencies enabled targetSet
+ in case checkDeps (fromDepMap deps) of
+ DepOk
+ | null ts -> Right (targetSet, flags)
+ | otherwise -> tryAll $ map explore ts
+ MissingDeps mds -> Left (toDepMapUnion mds)
-- Builds a tree of all possible flag assignments. Internal nodes
-- have only partial assignments.
build :: FlagAssignment -> [(FlagName, [Bool])] -> Tree FlagAssignment
build assigned [] = Node assigned []
build assigned ((fn, vals) : unassigned) =
- Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals
+ Node assigned $ map (\v -> build (insertFlagAssignment fn v assigned) unassigned) vals
tryAll :: [Either DepMapUnion a] -> Either DepMapUnion a
tryAll = foldr mp mz
-- special version of `mplus' for our local purposes
mp :: Either DepMapUnion a -> Either DepMapUnion a -> Either DepMapUnion a
- mp m@(Right _) _ = m
- mp _ m@(Right _) = m
- mp (Left xs) (Left ys) = Left (xs <> ys)
+ mp m@(Right _) _ = m
+ mp _ m@(Right _) = m
+ mp (Left xs) (Left ys) = Left (xs <> ys)
-- `mzero'
mz :: Either DepMapUnion a
@@ -235,14 +258,16 @@ resolveWithFlags dom enabled os arch impl constrs trees checkDeps =
-- conditional that is True when Buildable is True. If 'addBuildableCondition'
-- can determine that Buildable is always True, it returns the input unchanged.
-- If Buildable is always False, it returns the empty 'CondTree'.
-addBuildableCondition :: (Eq v, Monoid a, Monoid c) => (a -> BuildInfo)
- -> CondTree v c a
- -> CondTree v c a
+addBuildableCondition
+ :: (Eq v, Monoid a, Monoid c)
+ => (a -> BuildInfo)
+ -> CondTree v c a
+ -> CondTree v c a
addBuildableCondition getInfo t =
case extractCondition (buildable . getInfo) t of
- Lit True -> t
+ Lit True -> t
Lit False -> CondNode mempty mempty []
- c -> CondNode mempty mempty [condIfThen c t]
+ c -> CondNode mempty mempty [condIfThen c t]
-- | This is a special version of 'addBuildableCondition' for the 'PDTagged'
-- type.
@@ -253,15 +278,15 @@ addBuildableCondition getInfo t =
-- completely deleting components that are not buildable.
--
-- See <https://github.com/haskell/cabal/pull/4094> for more details.
---
-addBuildableConditionPDTagged :: (Eq v, Monoid c) =>
- CondTree v c PDTagged
- -> CondTree v c PDTagged
+addBuildableConditionPDTagged
+ :: (Eq v, Monoid c)
+ => CondTree v c PDTagged
+ -> CondTree v c PDTagged
addBuildableConditionPDTagged t =
- case extractCondition (buildable . getInfo) t of
- Lit True -> t
- Lit False -> deleteConstraints t
- c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]
+ case extractCondition (buildable . getInfo) t of
+ Lit True -> t
+ Lit False -> deleteConstraints t
+ c -> CondNode mempty mempty [condIfThenElse c t (deleteConstraints t)]
where
deleteConstraints = mapTreeConstrs (const mempty)
@@ -270,7 +295,6 @@ addBuildableConditionPDTagged t =
getInfo (SubComp _ c) = componentBuildInfo c
getInfo PDNull = mempty
-
-- Note: extracting buildable conditions.
-- --------------------------------------
--
@@ -286,52 +310,52 @@ addBuildableConditionPDTagged t =
-- | Extract conditions matched by the given predicate from all cond trees in a
-- 'GenericPackageDescription'.
-extractConditions :: (BuildInfo -> Bool) -> GenericPackageDescription
- -> [Condition ConfVar]
+extractConditions
+ :: (BuildInfo -> Bool)
+ -> GenericPackageDescription
+ -> [Condition ConfVar]
extractConditions f gpkg =
- concat [
- extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg)
- , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg
- , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg
- , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg
- , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
+ concat
+ [ extractCondition (f . libBuildInfo) <$> maybeToList (condLibrary gpkg)
+ , extractCondition (f . libBuildInfo) . snd <$> condSubLibraries gpkg
+ , extractCondition (f . buildInfo) . snd <$> condExecutables gpkg
+ , extractCondition (f . testBuildInfo) . snd <$> condTestSuites gpkg
+ , extractCondition (f . benchmarkBuildInfo) . snd <$> condBenchmarks gpkg
]
-
-- | A map of package constraints that combines version ranges using 'unionVersionRanges'.
-newtype DepMapUnion = DepMapUnion { unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName) }
+newtype DepMapUnion = DepMapUnion {unDepMapUnion :: Map PackageName (VersionRange, NonEmptySet LibraryName)}
instance Semigroup DepMapUnion where
- DepMapUnion x <> DepMapUnion y = DepMapUnion $
- Map.unionWith unionVersionRanges' x y
+ DepMapUnion x <> DepMapUnion y =
+ DepMapUnion $
+ Map.unionWith unionVersionRanges' x y
unionVersionRanges'
- :: (VersionRange, NonEmptySet LibraryName)
- -> (VersionRange, NonEmptySet LibraryName)
- -> (VersionRange, NonEmptySet LibraryName)
+ :: (VersionRange, NonEmptySet LibraryName)
+ -> (VersionRange, NonEmptySet LibraryName)
+ -> (VersionRange, NonEmptySet LibraryName)
unionVersionRanges' (vr, cs) (vr', cs') = (unionVersionRanges vr vr', cs <> cs')
toDepMapUnion :: [Dependency] -> DepMapUnion
toDepMapUnion ds =
- DepMapUnion $ Map.fromListWith unionVersionRanges' [ (p,(vr,cs)) | Dependency p vr cs <- ds ]
-
+ DepMapUnion $ Map.fromListWith unionVersionRanges' [(p, (vr, cs)) | Dependency p vr cs <- ds]
fromDepMapUnion :: DepMapUnion -> [Dependency]
-fromDepMapUnion m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDepMapUnion m) ]
+fromDepMapUnion m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDepMapUnion m)]
-freeVars :: CondTree ConfVar c a -> [FlagName]
-freeVars t = [ f | PackageFlag f <- freeVars' t ]
+freeVars :: CondTree ConfVar c a -> [FlagName]
+freeVars t = [f | PackageFlag f <- freeVars' t]
where
freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
compfv (CondBranch c ct mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
condfv c = case c of
- Var v -> [v]
- Lit _ -> []
- CNot c' -> condfv c'
- COr c1 c2 -> condfv c1 ++ condfv c2
+ Var v -> [v]
+ Lit _ -> []
+ CNot c' -> condfv c'
+ COr c1 c2 -> condfv c1 ++ condfv c2
CAnd c1 c2 -> condfv c1 ++ condfv c2
-
------------------------------------------------------------------------------
-- | A set of targets with their package dependencies
@@ -347,55 +371,58 @@ overallDependencies enabled (TargetSet targets) = mconcat depss
-- UGH. The embedded componentName in the 'Component's here is
-- BLANK. I don't know whose fault this is but I'll use the tag
-- instead. -- ezyang
- removeDisabledSections (Lib _) = componentNameRequested
- enabled
- (CLibName LMainLibName)
- removeDisabledSections (SubComp t c)
- -- Do NOT use componentName
- = componentNameRequested enabled
- $ case c of
- CLib _ -> CLibName (LSubLibName t)
- CFLib _ -> CFLibName t
- CExe _ -> CExeName t
- CTest _ -> CTestName t
- CBench _ -> CBenchName t
- removeDisabledSections PDNull = True
+ removeDisabledSections (Lib _) =
+ componentNameRequested
+ enabled
+ (CLibName LMainLibName)
+ removeDisabledSections (SubComp t c) =
+ -- Do NOT use componentName
+ componentNameRequested enabled $
+ case c of
+ CLib _ -> CLibName (LSubLibName t)
+ CFLib _ -> CFLibName t
+ CExe _ -> CExeName t
+ CTest _ -> CTestName t
+ CBench _ -> CBenchName t
+ removeDisabledSections PDNull = True
-- | Collect up the targets in a TargetSet of tagged targets, storing the
-- dependencies as we go.
flattenTaggedTargets :: TargetSet PDTagged -> (Maybe Library, [(UnqualComponentName, Component)])
-flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets where
- untag (depMap, pdTagged) accum = case (pdTagged, accum) of
- (Lib _, (Just _, _)) -> userBug "Only one library expected"
- (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps)
- (SubComp n c, (mb_lib, comps))
- | any ((== n) . fst) comps ->
- userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'"
- | otherwise -> (mb_lib, (n, redoBD c) : comps)
- (PDNull, x) -> x -- actually this should not happen, but let's be liberal
- where
- redoBD :: L.HasBuildInfo a => a -> a
- redoBD = set L.targetBuildDepends $ fromDepMap depMap
+flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, []) targets
+ where
+ untag (depMap, pdTagged) accum = case (pdTagged, accum) of
+ (Lib _, (Just _, _)) -> userBug "Only one library expected"
+ (Lib l, (Nothing, comps)) -> (Just $ redoBD l, comps)
+ (SubComp n c, (mb_lib, comps))
+ | any ((== n) . fst) comps ->
+ userBug $ "There exist several components with the same name: '" ++ prettyShow n ++ "'"
+ | otherwise -> (mb_lib, (n, redoBD c) : comps)
+ (PDNull, x) -> x -- actually this should not happen, but let's be liberal
+ where
+ redoBD :: L.HasBuildInfo a => a -> a
+ redoBD = set L.targetBuildDepends $ fromDepMap depMap
------------------------------------------------------------------------------
-- Convert GenericPackageDescription to PackageDescription
--
-data PDTagged = Lib Library
- | SubComp UnqualComponentName Component
- | PDNull
- deriving Show
+data PDTagged
+ = Lib Library
+ | SubComp UnqualComponentName Component
+ | PDNull
+ deriving (Show)
instance Monoid PDTagged where
- mempty = PDNull
- mappend = (<>)
+ mempty = PDNull
+ mappend = (<>)
instance Semigroup PDTagged where
- PDNull <> x = x
- x <> PDNull = x
- Lib l <> Lib l' = Lib (l <> l')
- SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')
- _ <> _ = cabalBug "Cannot combine incompatible tags"
+ PDNull <> x = x
+ x <> PDNull = x
+ Lib l <> Lib l' = Lib (l <> l')
+ SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x')
+ _ <> _ = cabalBug "Cannot combine incompatible tags"
-- | Create a package description with all configurations resolved.
--
@@ -422,66 +449,87 @@ instance Semigroup PDTagged where
-- Note that this drops any stanzas which have @buildable: False@. While
-- this is arguably the right thing to do, it means we give bad error
-- messages in some situations, see #3858.
---
-finalizePD ::
- FlagAssignment -- ^ Explicitly specified flag assignments
+finalizePD
+ :: FlagAssignment
+ -- ^ Explicitly specified flag assignments
-> ComponentRequestedSpec
- -> (Dependency -> Bool) -- ^ Is a given dependency satisfiable from the set of
- -- available packages? If this is unknown then use
- -- True.
- -> Platform -- ^ The 'Arch' and 'OS'
- -> CompilerInfo -- ^ Compiler information
- -> [PackageVersionConstraint] -- ^ Additional constraints
+ -> (Dependency -> Bool)
+ -- ^ Is a given dependency satisfiable from the set of
+ -- available packages? If this is unknown then use
+ -- True.
+ -> Platform
+ -- ^ The 'Arch' and 'OS'
+ -> CompilerInfo
+ -- ^ Compiler information
+ -> [PackageVersionConstraint]
+ -- ^ Additional constraints
-> GenericPackageDescription
- -> Either [Dependency]
- (PackageDescription, FlagAssignment)
- -- ^ Either missing dependencies or the resolved package
- -- description along with the flag assignments chosen.
-finalizePD userflags enabled satisfyDep
- (Platform arch os) impl constraints
- (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do
- (targetSet, flagVals) <-
- resolveWithFlags flagChoices enabled os arch impl constraints condTrees check
- let
- (mb_lib, comps) = flattenTaggedTargets targetSet
- mb_lib' = fmap libFillInDefaults mb_lib
- comps' = flip map comps $ \(n,c) -> foldComponent
- (\l -> CLib (libFillInDefaults l) { libName = LSubLibName n
- , libExposed = False })
- (\l -> CFLib (flibFillInDefaults l) { foreignLibName = n })
- (\e -> CExe (exeFillInDefaults e) { exeName = n })
- (\t -> CTest (testFillInDefaults t) { testName = n })
- (\b -> CBench (benchFillInDefaults b) { benchmarkName = n })
- c
- (sub_libs', flibs', exes', tests', bms') = partitionComponents comps'
- return ( pkg { library = mb_lib'
- , subLibraries = sub_libs'
- , foreignLibs = flibs'
- , executables = exes'
- , testSuites = tests'
- , benchmarks = bms'
- }
- , flagVals )
- where
- -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
- condTrees = maybeToList (fmap (mapTreeData Lib) mb_lib0)
- ++ map (\(name,tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0
- ++ map (\(name,tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0
- ++ map (\(name,tree) -> mapTreeData (SubComp name . CExe) tree) exes0
- ++ map (\(name,tree) -> mapTreeData (SubComp name . CTest) tree) tests0
- ++ map (\(name,tree) -> mapTreeData (SubComp name . CBench) tree) bms0
-
- flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags
- d2c manual n b = case lookupFlagAssignment n userflags of
- Just val -> [val]
- Nothing
- | manual -> [b]
- | otherwise -> [b, not b]
- --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
- check ds = let missingDeps = filter (not . satisfyDep) ds
- in if null missingDeps
- then DepOk
- else MissingDeps missingDeps
+ -> Either
+ [Dependency]
+ (PackageDescription, FlagAssignment)
+ -- ^ Either missing dependencies or the resolved package
+ -- description along with the flag assignments chosen.
+finalizePD
+ userflags
+ enabled
+ satisfyDep
+ (Platform arch os)
+ impl
+ constraints
+ (GenericPackageDescription pkg _ver flags mb_lib0 sub_libs0 flibs0 exes0 tests0 bms0) = do
+ (targetSet, flagVals) <-
+ resolveWithFlags flagChoices enabled os arch impl constraints condTrees check
+ let
+ (mb_lib, comps) = flattenTaggedTargets targetSet
+ mb_lib' = fmap libFillInDefaults mb_lib
+ comps' = flip map comps $ \(n, c) ->
+ foldComponent
+ ( \l ->
+ CLib
+ (libFillInDefaults l)
+ { libName = LSubLibName n
+ , libExposed = False
+ }
+ )
+ (\l -> CFLib (flibFillInDefaults l){foreignLibName = n})
+ (\e -> CExe (exeFillInDefaults e){exeName = n})
+ (\t -> CTest (testFillInDefaults t){testName = n})
+ (\b -> CBench (benchFillInDefaults b){benchmarkName = n})
+ c
+ (sub_libs', flibs', exes', tests', bms') = partitionComponents comps'
+ return
+ ( pkg
+ { library = mb_lib'
+ , subLibraries = sub_libs'
+ , foreignLibs = flibs'
+ , executables = exes'
+ , testSuites = tests'
+ , benchmarks = bms'
+ }
+ , flagVals
+ )
+ where
+ -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
+ condTrees =
+ maybeToList (fmap (mapTreeData Lib) mb_lib0)
+ ++ map (\(name, tree) -> mapTreeData (SubComp name . CLib) tree) sub_libs0
+ ++ map (\(name, tree) -> mapTreeData (SubComp name . CFLib) tree) flibs0
+ ++ map (\(name, tree) -> mapTreeData (SubComp name . CExe) tree) exes0
+ ++ map (\(name, tree) -> mapTreeData (SubComp name . CTest) tree) tests0
+ ++ map (\(name, tree) -> mapTreeData (SubComp name . CBench) tree) bms0
+
+ flagChoices = map (\(MkPackageFlag n _ d manual) -> (n, d2c manual n d)) flags
+ d2c manual n b = case lookupFlagAssignment n userflags of
+ Just val -> [val]
+ Nothing
+ | manual -> [b]
+ | otherwise -> [b, not b]
+ -- flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
+ check ds =
+ let missingDeps = filter (not . satisfyDep) ds
+ in if null missingDeps
+ then DepOk
+ else MissingDeps missingDeps
{-
let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])
@@ -509,31 +557,49 @@ resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribu
flattenPackageDescription :: GenericPackageDescription -> PackageDescription
flattenPackageDescription
(GenericPackageDescription pkg _ _ mlib0 sub_libs0 flibs0 exes0 tests0 bms0) =
- pkg { library = mlib
- , subLibraries = reverse sub_libs
- , foreignLibs = reverse flibs
- , executables = reverse exes
- , testSuites = reverse tests
- , benchmarks = reverse bms
- }
- where
- mlib = f <$> mlib0
- where f lib = (libFillInDefaults . fst . ignoreConditions $ lib) { libName = LMainLibName }
- sub_libs = flattenLib <$> sub_libs0
- flibs = flattenFLib <$> flibs0
- exes = flattenExe <$> exes0
- tests = flattenTst <$> tests0
- bms = flattenBm <$> bms0
- flattenLib (n, t) = libFillInDefaults $ (fst $ ignoreConditions t)
- { libName = LSubLibName n, libExposed = False }
- flattenFLib (n, t) = flibFillInDefaults $ (fst $ ignoreConditions t)
- { foreignLibName = n }
- flattenExe (n, t) = exeFillInDefaults $ (fst $ ignoreConditions t)
- { exeName = n }
- flattenTst (n, t) = testFillInDefaults $ (fst $ ignoreConditions t)
- { testName = n }
- flattenBm (n, t) = benchFillInDefaults $ (fst $ ignoreConditions t)
- { benchmarkName = n }
+ pkg
+ { library = mlib
+ , subLibraries = reverse sub_libs
+ , foreignLibs = reverse flibs
+ , executables = reverse exes
+ , testSuites = reverse tests
+ , benchmarks = reverse bms
+ }
+ where
+ mlib = f <$> mlib0
+ where
+ f lib = (libFillInDefaults . fst . ignoreConditions $ lib){libName = LMainLibName}
+ sub_libs = flattenLib <$> sub_libs0
+ flibs = flattenFLib <$> flibs0
+ exes = flattenExe <$> exes0
+ tests = flattenTst <$> tests0
+ bms = flattenBm <$> bms0
+ flattenLib (n, t) =
+ libFillInDefaults $
+ (fst $ ignoreConditions t)
+ { libName = LSubLibName n
+ , libExposed = False
+ }
+ flattenFLib (n, t) =
+ flibFillInDefaults $
+ (fst $ ignoreConditions t)
+ { foreignLibName = n
+ }
+ flattenExe (n, t) =
+ exeFillInDefaults $
+ (fst $ ignoreConditions t)
+ { exeName = n
+ }
+ flattenTst (n, t) =
+ testFillInDefaults $
+ (fst $ ignoreConditions t)
+ { testName = n
+ }
+ flattenBm (n, t) =
+ benchFillInDefaults $
+ (fst $ ignoreConditions t)
+ { benchmarkName = n
+ }
-- This is in fact rather a hack. The original version just overrode the
-- default values, however, when adding conditions we had to switch to a
@@ -543,59 +609,62 @@ flattenPackageDescription
-- This is the cleanest way i could think of, that doesn't require
-- changing all field parsing functions to return modifiers instead.
libFillInDefaults :: Library -> Library
-libFillInDefaults lib@(Library { libBuildInfo = bi }) =
- lib { libBuildInfo = biFillInDefaults bi }
+libFillInDefaults lib@(Library{libBuildInfo = bi}) =
+ lib{libBuildInfo = biFillInDefaults bi}
flibFillInDefaults :: ForeignLib -> ForeignLib
-flibFillInDefaults flib@(ForeignLib { foreignLibBuildInfo = bi }) =
- flib { foreignLibBuildInfo = biFillInDefaults bi }
+flibFillInDefaults flib@(ForeignLib{foreignLibBuildInfo = bi}) =
+ flib{foreignLibBuildInfo = biFillInDefaults bi}
exeFillInDefaults :: Executable -> Executable
-exeFillInDefaults exe@(Executable { buildInfo = bi }) =
- exe { buildInfo = biFillInDefaults bi }
+exeFillInDefaults exe@(Executable{buildInfo = bi}) =
+ exe{buildInfo = biFillInDefaults bi}
testFillInDefaults :: TestSuite -> TestSuite
-testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =
- tst { testBuildInfo = biFillInDefaults bi }
+testFillInDefaults tst@(TestSuite{testBuildInfo = bi}) =
+ tst{testBuildInfo = biFillInDefaults bi}
benchFillInDefaults :: Benchmark -> Benchmark
-benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =
- bm { benchmarkBuildInfo = biFillInDefaults bi }
+benchFillInDefaults bm@(Benchmark{benchmarkBuildInfo = bi}) =
+ bm{benchmarkBuildInfo = biFillInDefaults bi}
biFillInDefaults :: BuildInfo -> BuildInfo
biFillInDefaults bi =
- if null (hsSourceDirs bi)
- then bi { hsSourceDirs = [sameDirectory] }
+ if null (hsSourceDirs bi)
+ then bi{hsSourceDirs = [sameDirectory]}
else bi
-- Walk a 'GenericPackageDescription' and apply @onBuildInfo@/@onSetupBuildInfo@
-- to all nested 'BuildInfo'/'SetupBuildInfo' values.
-transformAllBuildInfos :: (BuildInfo -> BuildInfo)
- -> (SetupBuildInfo -> SetupBuildInfo)
- -> GenericPackageDescription
- -> GenericPackageDescription
+transformAllBuildInfos
+ :: (BuildInfo -> BuildInfo)
+ -> (SetupBuildInfo -> SetupBuildInfo)
+ -> GenericPackageDescription
+ -> GenericPackageDescription
transformAllBuildInfos onBuildInfo onSetupBuildInfo =
over L.traverseBuildInfos onBuildInfo
- . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo
+ . over (L.packageDescription . L.setupBuildInfo . traverse) onSetupBuildInfo
-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
-- @build-depends@ fields.
-transformAllBuildDepends :: (Dependency -> Dependency)
- -> GenericPackageDescription
- -> GenericPackageDescription
+transformAllBuildDepends
+ :: (Dependency -> Dependency)
+ -> GenericPackageDescription
+ -> GenericPackageDescription
transformAllBuildDepends f =
over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f
- . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
- -- cannot be point-free as normal because of higher rank
- . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)
+ . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f
+ -- cannot be point-free as normal because of higher rank
+ . over (\f' -> L.allCondTrees $ traverseCondTreeC f') (map f)
-- | Walk a 'GenericPackageDescription' and apply @f@ to all nested
-- @build-depends@ fields.
-transformAllBuildDependsN :: ([Dependency] -> [Dependency])
- -> GenericPackageDescription
- -> GenericPackageDescription
+transformAllBuildDependsN
+ :: ([Dependency] -> [Dependency])
+ -> GenericPackageDescription
+ -> GenericPackageDescription
transformAllBuildDependsN f =
over (L.traverseBuildInfos . L.targetBuildDepends) f
- . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f
- -- cannot be point-free as normal because of higher rank
- . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f
+ . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f
+ -- cannot be point-free as normal because of higher rank
+ . over (\f' -> L.allCondTrees $ traverseCondTreeC f') f
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
index 471cf489791613f581bef883d1f960897f8dcd04..c60040f8e346d10dda2665cb0572aea9453f8bac 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs
@@ -1,57 +1,69 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
+
-- | 'GenericPackageDescription' Field descriptions
-module Distribution.PackageDescription.FieldGrammar (
- -- * Package description
- packageDescriptionFieldGrammar,
- CompatFilePath(..),
- CompatLicenseFile(..),
+module Distribution.PackageDescription.FieldGrammar
+ ( -- * Package description
+ packageDescriptionFieldGrammar
+ , CompatFilePath (..)
+ , CompatLicenseFile (..)
+
-- * Library
- libraryFieldGrammar,
+ , libraryFieldGrammar
+
-- * Foreign library
- foreignLibFieldGrammar,
+ , foreignLibFieldGrammar
+
-- * Executable
- executableFieldGrammar,
+ , executableFieldGrammar
+
-- * Test suite
- TestSuiteStanza (..),
- testSuiteFieldGrammar,
- validateTestSuite,
- unvalidateTestSuite,
+ , TestSuiteStanza (..)
+ , testSuiteFieldGrammar
+ , validateTestSuite
+ , unvalidateTestSuite
+
-- ** Lenses
- testStanzaTestType,
- testStanzaMainIs,
- testStanzaTestModule,
- testStanzaBuildInfo,
+ , testStanzaTestType
+ , testStanzaMainIs
+ , testStanzaTestModule
+ , testStanzaBuildInfo
+
-- * Benchmark
- BenchmarkStanza (..),
- benchmarkFieldGrammar,
- validateBenchmark,
- unvalidateBenchmark,
+ , BenchmarkStanza (..)
+ , benchmarkFieldGrammar
+ , validateBenchmark
+ , unvalidateBenchmark
+
-- * Field grammars
- formatDependencyList,
- formatExposedModules,
- formatExtraSourceFiles,
- formatHsSourceDirs,
- formatMixinList,
- formatOtherExtensions,
- formatOtherModules,
+ , formatDependencyList
+ , formatExposedModules
+ , formatExtraSourceFiles
+ , formatHsSourceDirs
+ , formatMixinList
+ , formatOtherExtensions
+ , formatOtherModules
+
-- ** Lenses
- benchmarkStanzaBenchmarkType,
- benchmarkStanzaMainIs,
- benchmarkStanzaBenchmarkModule,
- benchmarkStanzaBuildInfo,
+ , benchmarkStanzaBenchmarkType
+ , benchmarkStanzaMainIs
+ , benchmarkStanzaBenchmarkModule
+ , benchmarkStanzaBuildInfo
+
-- * Flag
- flagFieldGrammar,
+ , flagFieldGrammar
+
-- * Source repository
- sourceRepoFieldGrammar,
+ , sourceRepoFieldGrammar
+
-- * Setup build info
- setupBInfoFieldGrammar,
- -- * Component build info
- buildInfoFieldGrammar,
- ) where
+ , setupBInfoFieldGrammar
+ -- * Component build info
+ , buildInfoFieldGrammar
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
@@ -59,134 +71,141 @@ import Language.Haskell.Extension
import Prelude ()
import Distribution.CabalSpecVersion
-import Distribution.Compat.Newtype (Newtype, pack', unpack')
-import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..))
+import Distribution.Compat.Newtype (Newtype, pack', unpack')
+import Distribution.Compiler (CompilerFlavor (..), PerCompilerFlavor (..))
import Distribution.FieldGrammar
import Distribution.Fields
-import Distribution.ModuleName (ModuleName)
+import Distribution.ModuleName (ModuleName)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Parsec
-import Distribution.Pretty (Pretty (..), prettyShow, showToken)
+import Distribution.Pretty (Pretty (..), prettyShow, showToken)
import Distribution.Utils.Path
-import Distribution.Version (Version, VersionRange)
+import Distribution.Version (Version, VersionRange)
-import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Char8 as BS8
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.SPDX as SPDX
-import qualified Distribution.Types.Lens as L
+import qualified Distribution.SPDX as SPDX
+import qualified Distribution.Types.Lens as L
-------------------------------------------------------------------------------
-- PackageDescription
-------------------------------------------------------------------------------
packageDescriptionFieldGrammar
- :: ( FieldGrammar c g, Applicative (g PackageDescription), Applicative (g PackageIdentifier)
- , c (Identity BuildType)
- , c (Identity PackageName)
- , c (Identity Version)
- , c (List FSep FilePathNT String)
- , c (List FSep CompatFilePath String)
- , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile))
- , c (List FSep TestedWith (CompilerFlavor, VersionRange))
- , c (List VCat FilePathNT String)
- , c FilePathNT
- , c CompatLicenseFile
- , c CompatFilePath
- , c SpecLicense
- , c SpecVersion
- )
- => g PackageDescription PackageDescription
-packageDescriptionFieldGrammar = PackageDescription
- <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0
+ :: ( FieldGrammar c g
+ , Applicative (g PackageDescription)
+ , Applicative (g PackageIdentifier)
+ , c (Identity BuildType)
+ , c (Identity PackageName)
+ , c (Identity Version)
+ , c (List FSep FilePathNT String)
+ , c (List FSep CompatFilePath String)
+ , c (List FSep (Identity (SymbolicPath PackageDir LicenseFile)) (SymbolicPath PackageDir LicenseFile))
+ , c (List FSep TestedWith (CompilerFlavor, VersionRange))
+ , c (List VCat FilePathNT String)
+ , c FilePathNT
+ , c CompatLicenseFile
+ , c CompatFilePath
+ , c SpecLicense
+ , c SpecVersion
+ )
+ => g PackageDescription PackageDescription
+packageDescriptionFieldGrammar =
+ PackageDescription
+ <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0
<*> blurFieldGrammar L.package packageIdentifierGrammar
- <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE)
+ <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE)
<*> licenseFilesGrammar
- <*> freeTextFieldDefST "copyright" L.copyright
- <*> freeTextFieldDefST "maintainer" L.maintainer
- <*> freeTextFieldDefST "author" L.author
- <*> freeTextFieldDefST "stability" L.stability
- <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith
- <*> freeTextFieldDefST "homepage" L.homepage
- <*> freeTextFieldDefST "package-url" L.pkgUrl
- <*> freeTextFieldDefST "bug-reports" L.bugReports
+ <*> freeTextFieldDefST "copyright" L.copyright
+ <*> freeTextFieldDefST "maintainer" L.maintainer
+ <*> freeTextFieldDefST "author" L.author
+ <*> freeTextFieldDefST "stability" L.stability
+ <*> monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith
+ <*> freeTextFieldDefST "homepage" L.homepage
+ <*> freeTextFieldDefST "package-url" L.pkgUrl
+ <*> freeTextFieldDefST "bug-reports" L.bugReports
<*> pure [] -- source-repos are stanza
- <*> freeTextFieldDefST "synopsis" L.synopsis
- <*> freeTextFieldDefST "description" L.description
- <*> freeTextFieldDefST "category" L.category
- <*> prefixedFields "x-" L.customFieldsPD
- <*> optionalField "build-type" L.buildTypeRaw
+ <*> freeTextFieldDefST "synopsis" L.synopsis
+ <*> freeTextFieldDefST "description" L.description
+ <*> freeTextFieldDefST "category" L.category
+ <*> prefixedFields "x-" L.customFieldsPD
+ <*> optionalField "build-type" L.buildTypeRaw
<*> pure Nothing -- custom-setup
-- components
- <*> pure Nothing -- lib
- <*> pure [] -- sub libs
- <*> pure [] -- executables
- <*> pure [] -- foreign libs
- <*> pure [] -- test suites
- <*> pure [] -- benchmarks
+ <*> pure Nothing -- lib
+ <*> pure [] -- sub libs
+ <*> pure [] -- executables
+ <*> pure [] -- foreign libs
+ <*> pure [] -- test suites
+ <*> pure [] -- benchmarks
-- * Files
- <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles
- <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "."
- ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "."
- <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles
- <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles
- <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles
+ <*> monoidalFieldAla "data-files" (alaList' VCat FilePathNT) L.dataFiles
+ <*> optionalFieldDefAla "data-dir" CompatFilePath L.dataDir "."
+ ^^^ fmap (\x -> if null x then "." else x) -- map empty directories to "."
+ <*> monoidalFieldAla "extra-source-files" formatExtraSourceFiles L.extraSrcFiles
+ <*> monoidalFieldAla "extra-tmp-files" (alaList' VCat FilePathNT) L.extraTmpFiles
+ <*> monoidalFieldAla "extra-doc-files" (alaList' VCat FilePathNT) L.extraDocFiles
where
- packageIdentifierGrammar = PackageIdentifier
- <$> uniqueField "name" L.pkgName
+ packageIdentifierGrammar =
+ PackageIdentifier
+ <$> uniqueField "name" L.pkgName
<*> uniqueField "version" L.pkgVersion
- licenseFilesGrammar = (++)
+ licenseFilesGrammar =
+ (++)
-- TODO: neither field is deprecated
-- should we pretty print license-file if there's single license file
-- and license-files when more
- <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles
- <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles
- ^^^ hiddenField
+ <$> monoidalFieldAla "license-file" CompatLicenseFile L.licenseFiles
+ <*> monoidalFieldAla "license-files" (alaList FSep) L.licenseFiles
+ ^^^ hiddenField
-------------------------------------------------------------------------------
-- Library
-------------------------------------------------------------------------------
libraryFieldGrammar
- :: ( FieldGrammar c g, Applicative (g Library), Applicative (g BuildInfo)
- , c (Identity LibraryVisibility)
- , c (List CommaFSep (Identity ExeDependency) ExeDependency)
- , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
- , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
- , c (List CommaVCat (Identity Dependency) Dependency)
- , c (List CommaVCat (Identity Mixin) Mixin)
- , c (List CommaVCat (Identity ModuleReexport) ModuleReexport)
- , c (List FSep (MQuoted Extension) Extension)
- , c (List FSep (MQuoted Language) Language)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (List NoCommaFSep Token' String)
- , c (List VCat (MQuoted ModuleName) ModuleName)
- , c (List VCat FilePathNT String)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- , c (List VCat Token String)
- , c (MQuoted Language)
- )
- => LibraryName
- -> g Library Library
-libraryFieldGrammar n = Library n
- <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules
- <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules
- <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures
- ^^^ availableSince CabalSpecV2_0 []
- <*> booleanFieldDef "exposed" L.libExposed True
+ :: ( FieldGrammar c g
+ , Applicative (g Library)
+ , Applicative (g BuildInfo)
+ , c (Identity LibraryVisibility)
+ , c (List CommaFSep (Identity ExeDependency) ExeDependency)
+ , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
+ , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+ , c (List CommaVCat (Identity Dependency) Dependency)
+ , c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List CommaVCat (Identity ModuleReexport) ModuleReexport)
+ , c (List FSep (MQuoted Extension) Extension)
+ , c (List FSep (MQuoted Language) Language)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (List NoCommaFSep Token' String)
+ , c (List VCat (MQuoted ModuleName) ModuleName)
+ , c (List VCat FilePathNT String)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ , c (List VCat Token String)
+ , c (MQuoted Language)
+ )
+ => LibraryName
+ -> g Library Library
+libraryFieldGrammar n =
+ Library n
+ <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules
+ <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules
+ <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures
+ ^^^ availableSince CabalSpecV2_0 []
+ <*> booleanFieldDef "exposed" L.libExposed True
<*> visibilityField
<*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar
where
visibilityField = case n of
- -- nameless/"main" libraries are public
- LMainLibName -> pure LibraryVisibilityPublic
- -- named libraries have the field
- LSubLibName _ ->
- optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate
- ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate
-
+ -- nameless/"main" libraries are public
+ LMainLibName -> pure LibraryVisibilityPublic
+ -- named libraries have the field
+ LSubLibName _ ->
+ optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate
+ ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate
{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-}
{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-}
@@ -195,34 +214,39 @@ libraryFieldGrammar n = Library n
-------------------------------------------------------------------------------
foreignLibFieldGrammar
- :: ( FieldGrammar c g, Applicative (g ForeignLib), Applicative (g BuildInfo)
- , c (Identity ForeignLibType)
- , c (Identity LibVersionInfo)
- , c (Identity Version)
- , c (List CommaFSep (Identity ExeDependency) ExeDependency)
- , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
- , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
- , c (List CommaVCat (Identity Dependency) Dependency)
- , c (List CommaVCat (Identity Mixin) Mixin)
- , c (List FSep (Identity ForeignLibOption) ForeignLibOption)
- , c (List FSep (MQuoted Extension) Extension)
- , c (List FSep (MQuoted Language) Language)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- , c (List NoCommaFSep Token' String)
- , c (List VCat (MQuoted ModuleName) ModuleName)
- , c (List VCat FilePathNT String), c (List VCat Token String)
- , c (MQuoted Language)
- )
- => UnqualComponentName -> g ForeignLib ForeignLib
-foreignLibFieldGrammar n = ForeignLib n
- <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown
- <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions
+ :: ( FieldGrammar c g
+ , Applicative (g ForeignLib)
+ , Applicative (g BuildInfo)
+ , c (Identity ForeignLibType)
+ , c (Identity LibVersionInfo)
+ , c (Identity Version)
+ , c (List CommaFSep (Identity ExeDependency) ExeDependency)
+ , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
+ , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+ , c (List CommaVCat (Identity Dependency) Dependency)
+ , c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List FSep (Identity ForeignLibOption) ForeignLibOption)
+ , c (List FSep (MQuoted Extension) Extension)
+ , c (List FSep (MQuoted Language) Language)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ , c (List NoCommaFSep Token' String)
+ , c (List VCat (MQuoted ModuleName) ModuleName)
+ , c (List VCat FilePathNT String)
+ , c (List VCat Token String)
+ , c (MQuoted Language)
+ )
+ => UnqualComponentName
+ -> g ForeignLib ForeignLib
+foreignLibFieldGrammar n =
+ ForeignLib n
+ <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown
+ <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions
<*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar
- <*> optionalField "lib-version-info" L.foreignLibVersionInfo
- <*> optionalField "lib-version-linux" L.foreignLibVersionLinux
- <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile
+ <*> optionalField "lib-version-info" L.foreignLibVersionInfo
+ <*> optionalField "lib-version-linux" L.foreignLibVersionLinux
+ <*> monoidalFieldAla "mod-def-file" (alaList' FSep FilePathNT) L.foreignLibModDefFile
{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-}
{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-}
@@ -231,30 +255,34 @@ foreignLibFieldGrammar n = ForeignLib n
-------------------------------------------------------------------------------
executableFieldGrammar
- :: ( FieldGrammar c g, Applicative (g Executable), Applicative (g BuildInfo)
- , c (Identity ExecutableScope)
- , c (List CommaFSep (Identity ExeDependency) ExeDependency)
- , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
- , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
- , c (List CommaVCat (Identity Dependency) Dependency)
- , c (List CommaVCat (Identity Mixin) Mixin)
- , c (List FSep (MQuoted Extension) Extension)
- , c (List FSep (MQuoted Language) Language)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- , c (List NoCommaFSep Token' String)
- , c (List VCat (MQuoted ModuleName) ModuleName)
- , c (List VCat FilePathNT String)
- , c (List VCat Token String)
- , c (MQuoted Language)
- )
- => UnqualComponentName -> g Executable Executable
-executableFieldGrammar n = Executable n
+ :: ( FieldGrammar c g
+ , Applicative (g Executable)
+ , Applicative (g BuildInfo)
+ , c (Identity ExecutableScope)
+ , c (List CommaFSep (Identity ExeDependency) ExeDependency)
+ , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
+ , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+ , c (List CommaVCat (Identity Dependency) Dependency)
+ , c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List FSep (MQuoted Extension) Extension)
+ , c (List FSep (MQuoted Language) Language)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ , c (List NoCommaFSep Token' String)
+ , c (List VCat (MQuoted ModuleName) ModuleName)
+ , c (List VCat FilePathNT String)
+ , c (List VCat Token String)
+ , c (MQuoted Language)
+ )
+ => UnqualComponentName
+ -> g Executable Executable
+executableFieldGrammar n =
+ Executable n
-- main-is is optional as conditional blocks don't have it
<$> optionalFieldDefAla "main-is" FilePathNT L.modulePath ""
- <*> optionalFieldDef "scope" L.exeScope ExecutablePublic
- ^^^ availableSince CabalSpecV2_0 ExecutablePublic
+ <*> optionalFieldDef "scope" L.exeScope ExecutablePublic
+ ^^^ availableSince CabalSpecV2_0 ExecutablePublic
<*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar
{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-}
{-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-}
@@ -266,129 +294,147 @@ executableFieldGrammar n = Executable n
-- | An intermediate type just used for parsing the test-suite stanza.
-- After validation it is converted into the proper 'TestSuite' type.
data TestSuiteStanza = TestSuiteStanza
- { _testStanzaTestType :: Maybe TestType
- , _testStanzaMainIs :: Maybe FilePath
- , _testStanzaTestModule :: Maybe ModuleName
- , _testStanzaBuildInfo :: BuildInfo
- , _testStanzaCodeGenerators :: [String]
- }
+ { _testStanzaTestType :: Maybe TestType
+ , _testStanzaMainIs :: Maybe FilePath
+ , _testStanzaTestModule :: Maybe ModuleName
+ , _testStanzaBuildInfo :: BuildInfo
+ , _testStanzaCodeGenerators :: [String]
+ }
instance L.HasBuildInfo TestSuiteStanza where
- buildInfo = testStanzaBuildInfo
+ buildInfo = testStanzaBuildInfo
testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType)
-testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s))
+testStanzaTestType f s = fmap (\x -> s{_testStanzaTestType = x}) (f (_testStanzaTestType s))
{-# INLINE testStanzaTestType #-}
testStanzaMainIs :: Lens' TestSuiteStanza (Maybe FilePath)
-testStanzaMainIs f s = fmap (\x -> s { _testStanzaMainIs = x }) (f (_testStanzaMainIs s))
+testStanzaMainIs f s = fmap (\x -> s{_testStanzaMainIs = x}) (f (_testStanzaMainIs s))
{-# INLINE testStanzaMainIs #-}
testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName)
-testStanzaTestModule f s = fmap (\x -> s { _testStanzaTestModule = x }) (f (_testStanzaTestModule s))
+testStanzaTestModule f s = fmap (\x -> s{_testStanzaTestModule = x}) (f (_testStanzaTestModule s))
{-# INLINE testStanzaTestModule #-}
testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo
-testStanzaBuildInfo f s = fmap (\x -> s { _testStanzaBuildInfo = x }) (f (_testStanzaBuildInfo s))
+testStanzaBuildInfo f s = fmap (\x -> s{_testStanzaBuildInfo = x}) (f (_testStanzaBuildInfo s))
{-# INLINE testStanzaBuildInfo #-}
testStanzaCodeGenerators :: Lens' TestSuiteStanza [String]
-testStanzaCodeGenerators f s = fmap (\x -> s { _testStanzaCodeGenerators = x }) (f (_testStanzaCodeGenerators s))
+testStanzaCodeGenerators f s = fmap (\x -> s{_testStanzaCodeGenerators = x}) (f (_testStanzaCodeGenerators s))
{-# INLINE testStanzaCodeGenerators #-}
testSuiteFieldGrammar
- :: ( FieldGrammar c g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo)
- , c (Identity ModuleName)
- , c (Identity TestType)
- , c (List CommaFSep (Identity ExeDependency) ExeDependency)
- , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
- , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
- , c (List CommaFSep Token String)
- , c (List CommaVCat (Identity Dependency) Dependency)
- , c (List CommaVCat (Identity Mixin) Mixin)
- , c (List FSep (MQuoted Extension) Extension)
- , c (List FSep (MQuoted Language) Language)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (List NoCommaFSep Token' String)
- , c (List VCat (MQuoted ModuleName) ModuleName)
- , c (List VCat FilePathNT String)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- , c (List VCat Token String)
- , c (MQuoted Language)
- )
- => g TestSuiteStanza TestSuiteStanza
-testSuiteFieldGrammar = TestSuiteStanza
- <$> optionalField "type" testStanzaTestType
- <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs
- <*> optionalField "test-module" testStanzaTestModule
+ :: ( FieldGrammar c g
+ , Applicative (g TestSuiteStanza)
+ , Applicative (g BuildInfo)
+ , c (Identity ModuleName)
+ , c (Identity TestType)
+ , c (List CommaFSep (Identity ExeDependency) ExeDependency)
+ , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
+ , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+ , c (List CommaFSep Token String)
+ , c (List CommaVCat (Identity Dependency) Dependency)
+ , c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List FSep (MQuoted Extension) Extension)
+ , c (List FSep (MQuoted Language) Language)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (List NoCommaFSep Token' String)
+ , c (List VCat (MQuoted ModuleName) ModuleName)
+ , c (List VCat FilePathNT String)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ , c (List VCat Token String)
+ , c (MQuoted Language)
+ )
+ => g TestSuiteStanza TestSuiteStanza
+testSuiteFieldGrammar =
+ TestSuiteStanza
+ <$> optionalField "type" testStanzaTestType
+ <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs
+ <*> optionalField "test-module" testStanzaTestModule
<*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar
- <*> monoidalFieldAla "code-generators" (alaList' CommaFSep Token) testStanzaCodeGenerators
- ^^^ availableSince CabalSpecV3_8 []
+ <*> monoidalFieldAla "code-generators" (alaList' CommaFSep Token) testStanzaCodeGenerators
+ ^^^ availableSince CabalSpecV3_8 []
validateTestSuite :: CabalSpecVersion -> Position -> TestSuiteStanza -> ParseResult TestSuite
validateTestSuite cabalSpecVersion pos stanza = case testSuiteType of
- Nothing -> pure basicTestSuite
-
- Just tt@(TestTypeUnknown _ _) ->
- pure basicTestSuite
- { testInterface = TestSuiteUnsupported tt }
-
- Just tt | tt `notElem` knownTestTypes ->
- pure basicTestSuite
- { testInterface = TestSuiteUnsupported tt }
-
- Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of
- Nothing -> do
- parseFailure pos (missingField "main-is" tt)
- pure emptyTestSuite
- Just file -> do
- when (isJust (_testStanzaTestModule stanza)) $
- parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt)
- pure basicTestSuite
- { testInterface = TestSuiteExeV10 ver file }
-
- Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of
- Nothing -> do
- parseFailure pos (missingField "test-module" tt)
- pure emptyTestSuite
- Just module_ -> do
- when (isJust (_testStanzaMainIs stanza)) $
- parseWarning pos PWTExtraMainIs (extraField "main-is" tt)
- pure basicTestSuite
- { testInterface = TestSuiteLibV09 ver module_ }
-
+ Nothing -> pure basicTestSuite
+ Just tt@(TestTypeUnknown _ _) ->
+ pure
+ basicTestSuite
+ { testInterface = TestSuiteUnsupported tt
+ }
+ Just tt
+ | tt `notElem` knownTestTypes ->
+ pure
+ basicTestSuite
+ { testInterface = TestSuiteUnsupported tt
+ }
+ Just tt@(TestTypeExe ver) -> case _testStanzaMainIs stanza of
+ Nothing -> do
+ parseFailure pos (missingField "main-is" tt)
+ pure emptyTestSuite
+ Just file -> do
+ when (isJust (_testStanzaTestModule stanza)) $
+ parseWarning pos PWTExtraBenchmarkModule (extraField "test-module" tt)
+ pure
+ basicTestSuite
+ { testInterface = TestSuiteExeV10 ver file
+ }
+ Just tt@(TestTypeLib ver) -> case _testStanzaTestModule stanza of
+ Nothing -> do
+ parseFailure pos (missingField "test-module" tt)
+ pure emptyTestSuite
+ Just module_ -> do
+ when (isJust (_testStanzaMainIs stanza)) $
+ parseWarning pos PWTExtraMainIs (extraField "main-is" tt)
+ pure
+ basicTestSuite
+ { testInterface = TestSuiteLibV09 ver module_
+ }
where
- testSuiteType = _testStanzaTestType stanza <|> do
- guard (cabalSpecVersion >= CabalSpecV3_8)
+ testSuiteType =
+ _testStanzaTestType stanza
+ <|> do
+ guard (cabalSpecVersion >= CabalSpecV3_8)
- testTypeExe <$ _testStanzaMainIs stanza
+ testTypeExe <$ _testStanzaMainIs stanza
<|> testTypeLib <$ _testStanzaTestModule stanza
- missingField name tt = "The '" ++ name ++ "' field is required for the "
- ++ prettyShow tt ++ " test suite type."
-
- extraField name tt = "The '" ++ name ++ "' field is not used for the '"
- ++ prettyShow tt ++ "' test suite type."
+ missingField name tt =
+ "The '"
+ ++ name
+ ++ "' field is required for the "
+ ++ prettyShow tt
+ ++ " test suite type."
+
+ extraField name tt =
+ "The '"
+ ++ name
+ ++ "' field is not used for the '"
+ ++ prettyShow tt
+ ++ "' test suite type."
basicTestSuite =
- emptyTestSuite {
- testBuildInfo = _testStanzaBuildInfo stanza
- , testCodeGenerators = _testStanzaCodeGenerators stanza
- }
+ emptyTestSuite
+ { testBuildInfo = _testStanzaBuildInfo stanza
+ , testCodeGenerators = _testStanzaCodeGenerators stanza
+ }
unvalidateTestSuite :: TestSuite -> TestSuiteStanza
-unvalidateTestSuite t = TestSuiteStanza
- { _testStanzaTestType = ty
- , _testStanzaMainIs = ma
+unvalidateTestSuite t =
+ TestSuiteStanza
+ { _testStanzaTestType = ty
+ , _testStanzaMainIs = ma
, _testStanzaTestModule = mo
- , _testStanzaBuildInfo = testBuildInfo t
+ , _testStanzaBuildInfo = testBuildInfo t
, _testStanzaCodeGenerators = testCodeGenerators t
}
where
(ty, ma, mo) = case testInterface t of
- TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing)
- TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu)
- _ -> (Nothing, Nothing, Nothing)
+ TestSuiteExeV10 ver file -> (Just $ TestTypeExe ver, Just file, Nothing)
+ TestSuiteLibV09 ver modu -> (Just $ TestTypeLib ver, Nothing, Just modu)
+ _ -> (Nothing, Nothing, Nothing)
-------------------------------------------------------------------------------
-- Benchmark
@@ -397,261 +443,290 @@ unvalidateTestSuite t = TestSuiteStanza
-- | An intermediate type just used for parsing the benchmark stanza.
-- After validation it is converted into the proper 'Benchmark' type.
data BenchmarkStanza = BenchmarkStanza
- { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType
- , _benchmarkStanzaMainIs :: Maybe FilePath
- , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName
- , _benchmarkStanzaBuildInfo :: BuildInfo
- }
+ { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType
+ , _benchmarkStanzaMainIs :: Maybe FilePath
+ , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName
+ , _benchmarkStanzaBuildInfo :: BuildInfo
+ }
instance L.HasBuildInfo BenchmarkStanza where
- buildInfo = benchmarkStanzaBuildInfo
+ buildInfo = benchmarkStanzaBuildInfo
benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType)
-benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s))
+benchmarkStanzaBenchmarkType f s = fmap (\x -> s{_benchmarkStanzaBenchmarkType = x}) (f (_benchmarkStanzaBenchmarkType s))
{-# INLINE benchmarkStanzaBenchmarkType #-}
benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe FilePath)
-benchmarkStanzaMainIs f s = fmap (\x -> s { _benchmarkStanzaMainIs = x }) (f (_benchmarkStanzaMainIs s))
+benchmarkStanzaMainIs f s = fmap (\x -> s{_benchmarkStanzaMainIs = x}) (f (_benchmarkStanzaMainIs s))
{-# INLINE benchmarkStanzaMainIs #-}
benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName)
-benchmarkStanzaBenchmarkModule f s = fmap (\x -> s { _benchmarkStanzaBenchmarkModule = x }) (f (_benchmarkStanzaBenchmarkModule s))
+benchmarkStanzaBenchmarkModule f s = fmap (\x -> s{_benchmarkStanzaBenchmarkModule = x}) (f (_benchmarkStanzaBenchmarkModule s))
{-# INLINE benchmarkStanzaBenchmarkModule #-}
benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo
-benchmarkStanzaBuildInfo f s = fmap (\x -> s { _benchmarkStanzaBuildInfo = x }) (f (_benchmarkStanzaBuildInfo s))
+benchmarkStanzaBuildInfo f s = fmap (\x -> s{_benchmarkStanzaBuildInfo = x}) (f (_benchmarkStanzaBuildInfo s))
{-# INLINE benchmarkStanzaBuildInfo #-}
benchmarkFieldGrammar
- :: ( FieldGrammar c g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo)
- , c (Identity BenchmarkType)
- , c (Identity ModuleName)
- , c (List CommaFSep (Identity ExeDependency) ExeDependency)
- , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
- , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
- , c (List CommaVCat (Identity Dependency) Dependency)
- , c (List CommaVCat (Identity Mixin) Mixin)
- , c (List FSep (MQuoted Extension) Extension)
- , c (List FSep (MQuoted Language) Language)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (List NoCommaFSep Token' String)
- , c (List VCat (MQuoted ModuleName) ModuleName)
- , c (List VCat FilePathNT String)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- , c (List VCat Token String)
- , c (MQuoted Language)
- )
- => g BenchmarkStanza BenchmarkStanza
-benchmarkFieldGrammar = BenchmarkStanza
- <$> optionalField "type" benchmarkStanzaBenchmarkType
- <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs
- <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule
+ :: ( FieldGrammar c g
+ , Applicative (g BenchmarkStanza)
+ , Applicative (g BuildInfo)
+ , c (Identity BenchmarkType)
+ , c (Identity ModuleName)
+ , c (List CommaFSep (Identity ExeDependency) ExeDependency)
+ , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
+ , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+ , c (List CommaVCat (Identity Dependency) Dependency)
+ , c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List FSep (MQuoted Extension) Extension)
+ , c (List FSep (MQuoted Language) Language)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (List NoCommaFSep Token' String)
+ , c (List VCat (MQuoted ModuleName) ModuleName)
+ , c (List VCat FilePathNT String)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ , c (List VCat Token String)
+ , c (MQuoted Language)
+ )
+ => g BenchmarkStanza BenchmarkStanza
+benchmarkFieldGrammar =
+ BenchmarkStanza
+ <$> optionalField "type" benchmarkStanzaBenchmarkType
+ <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs
+ <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule
<*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar
validateBenchmark :: CabalSpecVersion -> Position -> BenchmarkStanza -> ParseResult Benchmark
validateBenchmark cabalSpecVersion pos stanza = case benchmarkStanzaType of
- Nothing -> pure emptyBenchmark
- { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza }
-
- Just tt@(BenchmarkTypeUnknown _ _) -> pure emptyBenchmark
- { benchmarkInterface = BenchmarkUnsupported tt
- , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza
+ Nothing ->
+ pure
+ emptyBenchmark
+ { benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza
}
-
- Just tt | tt `notElem` knownBenchmarkTypes -> pure emptyBenchmark
+ Just tt@(BenchmarkTypeUnknown _ _) ->
+ pure
+ emptyBenchmark
{ benchmarkInterface = BenchmarkUnsupported tt
, benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza
}
-
- Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of
- Nothing -> do
- parseFailure pos (missingField "main-is" tt)
- pure emptyBenchmark
- Just file -> do
- when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $
- parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt)
- pure emptyBenchmark
- { benchmarkInterface = BenchmarkExeV10 ver file
- , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza
- }
-
+ Just tt
+ | tt `notElem` knownBenchmarkTypes ->
+ pure
+ emptyBenchmark
+ { benchmarkInterface = BenchmarkUnsupported tt
+ , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza
+ }
+ Just tt@(BenchmarkTypeExe ver) -> case _benchmarkStanzaMainIs stanza of
+ Nothing -> do
+ parseFailure pos (missingField "main-is" tt)
+ pure emptyBenchmark
+ Just file -> do
+ when (isJust (_benchmarkStanzaBenchmarkModule stanza)) $
+ parseWarning pos PWTExtraBenchmarkModule (extraField "benchmark-module" tt)
+ pure
+ emptyBenchmark
+ { benchmarkInterface = BenchmarkExeV10 ver file
+ , benchmarkBuildInfo = _benchmarkStanzaBuildInfo stanza
+ }
where
- benchmarkStanzaType = _benchmarkStanzaBenchmarkType stanza <|> do
+ benchmarkStanzaType =
+ _benchmarkStanzaBenchmarkType stanza <|> do
guard (cabalSpecVersion >= CabalSpecV3_8)
benchmarkTypeExe <$ _benchmarkStanzaMainIs stanza
- missingField name tt = "The '" ++ name ++ "' field is required for the "
- ++ prettyShow tt ++ " benchmark type."
+ missingField name tt =
+ "The '"
+ ++ name
+ ++ "' field is required for the "
+ ++ prettyShow tt
+ ++ " benchmark type."
- extraField name tt = "The '" ++ name ++ "' field is not used for the '"
- ++ prettyShow tt ++ "' benchmark type."
+ extraField name tt =
+ "The '"
+ ++ name
+ ++ "' field is not used for the '"
+ ++ prettyShow tt
+ ++ "' benchmark type."
unvalidateBenchmark :: Benchmark -> BenchmarkStanza
-unvalidateBenchmark b = BenchmarkStanza
- { _benchmarkStanzaBenchmarkType = ty
- , _benchmarkStanzaMainIs = ma
+unvalidateBenchmark b =
+ BenchmarkStanza
+ { _benchmarkStanzaBenchmarkType = ty
+ , _benchmarkStanzaMainIs = ma
, _benchmarkStanzaBenchmarkModule = mo
- , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b
+ , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b
}
where
(ty, ma, mo) = case benchmarkInterface b of
- BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing)
- BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing)
- _ -> (Nothing, Nothing, Nothing)
+ BenchmarkExeV10 ver "" -> (Just $ BenchmarkTypeExe ver, Nothing, Nothing)
+ BenchmarkExeV10 ver ma' -> (Just $ BenchmarkTypeExe ver, Just ma', Nothing)
+ _ -> (Nothing, Nothing, Nothing)
-------------------------------------------------------------------------------
-- Build info
-------------------------------------------------------------------------------
buildInfoFieldGrammar
- :: ( FieldGrammar c g, Applicative (g BuildInfo)
- , c (List CommaFSep (Identity ExeDependency) ExeDependency)
- , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
- , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
- , c (List CommaVCat (Identity Dependency) Dependency)
- , c (List CommaVCat (Identity Mixin) Mixin)
- , c (List FSep (MQuoted Extension) Extension)
- , c (List FSep (MQuoted Language) Language)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (List NoCommaFSep Token' String)
- , c (List VCat (MQuoted ModuleName) ModuleName)
- , c (List VCat FilePathNT String)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- , c (List VCat Token String)
- , c (MQuoted Language)
- )
- => g BuildInfo BuildInfo
-buildInfoFieldGrammar = BuildInfo
- <$> booleanFieldDef "buildable" L.buildable True
- <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools
- ^^^ deprecatedSince CabalSpecV2_0
- "Please use 'build-tool-depends' field"
- ^^^ removedIn CabalSpecV3_0
- "Please use 'build-tool-depends' field."
- <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends
- -- {- ^^^ availableSince [2,0] [] -}
- -- here, we explicitly want to recognise build-tool-depends for all Cabal files
- -- as otherwise cabal new-build cannot really work.
- --
- -- I.e. we don't want trigger unknown field warning
- <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions
- <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions
- ^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions
- ^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions
- <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions
- ^^^ availableSince CabalSpecV2_2 []
- <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions
- <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions
- ^^^ availableSince CabalSpecV3_6 []
- <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends
- <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks
- <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs
- <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources
- ^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources
- ^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources
- <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources
- ^^^ availableSince CabalSpecV2_2 []
- <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources
+ :: ( FieldGrammar c g
+ , Applicative (g BuildInfo)
+ , c (List CommaFSep (Identity ExeDependency) ExeDependency)
+ , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency)
+ , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency)
+ , c (List CommaVCat (Identity Dependency) Dependency)
+ , c (List CommaVCat (Identity Mixin) Mixin)
+ , c (List FSep (MQuoted Extension) Extension)
+ , c (List FSep (MQuoted Language) Language)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (List NoCommaFSep Token' String)
+ , c (List VCat (MQuoted ModuleName) ModuleName)
+ , c (List VCat FilePathNT String)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ , c (List VCat Token String)
+ , c (MQuoted Language)
+ )
+ => g BuildInfo BuildInfo
+buildInfoFieldGrammar =
+ BuildInfo
+ <$> booleanFieldDef "buildable" L.buildable True
+ <*> monoidalFieldAla "build-tools" (alaList CommaFSep) L.buildTools
+ ^^^ deprecatedSince
+ CabalSpecV2_0
+ "Please use 'build-tool-depends' field"
+ ^^^ removedIn
+ CabalSpecV3_0
+ "Please use 'build-tool-depends' field."
+ <*> monoidalFieldAla "build-tool-depends" (alaList CommaFSep) L.buildToolDepends
+ -- {- ^^^ availableSince [2,0] [] -}
+ -- here, we explicitly want to recognise build-tool-depends for all Cabal files
+ -- as otherwise cabal new-build cannot really work.
+ --
+ -- I.e. we don't want trigger unknown field warning
+ <*> monoidalFieldAla "cpp-options" (alaList' NoCommaFSep Token') L.cppOptions
+ <*> monoidalFieldAla "asm-options" (alaList' NoCommaFSep Token') L.asmOptions
+ ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "cmm-options" (alaList' NoCommaFSep Token') L.cmmOptions
+ ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "cc-options" (alaList' NoCommaFSep Token') L.ccOptions
+ <*> monoidalFieldAla "cxx-options" (alaList' NoCommaFSep Token') L.cxxOptions
+ ^^^ availableSince CabalSpecV2_2 []
+ <*> monoidalFieldAla "ld-options" (alaList' NoCommaFSep Token') L.ldOptions
+ <*> monoidalFieldAla "hsc2hs-options" (alaList' NoCommaFSep Token') L.hsc2hsOptions
+ ^^^ availableSince CabalSpecV3_6 []
+ <*> monoidalFieldAla "pkgconfig-depends" (alaList CommaFSep) L.pkgconfigDepends
+ <*> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks
+ <*> monoidalFieldAla "extra-framework-dirs" (alaList' FSep FilePathNT) L.extraFrameworkDirs
+ <*> monoidalFieldAla "asm-sources" (alaList' VCat FilePathNT) L.asmSources
+ ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "cmm-sources" (alaList' VCat FilePathNT) L.cmmSources
+ ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "c-sources" (alaList' VCat FilePathNT) L.cSources
+ <*> monoidalFieldAla "cxx-sources" (alaList' VCat FilePathNT) L.cxxSources
+ ^^^ availableSince CabalSpecV2_2 []
+ <*> monoidalFieldAla "js-sources" (alaList' VCat FilePathNT) L.jsSources
<*> hsSourceDirsGrammar
- <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules
- <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules
- ^^^ availableSince CabalSpecV2_2 []
- <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules
- ^^^ availableSince CabalSpecV2_0 []
- <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage
- ^^^ availableSince CabalSpecV1_10 Nothing
- <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages
- ^^^ availableSince CabalSpecV1_10 []
- <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions
- ^^^ availableSince CabalSpecV1_10 []
- <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions
- ^^^ availableSinceWarn CabalSpecV1_10
- <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions
- ^^^ deprecatedSince CabalSpecV1_12
- "Please use 'default-extensions' or 'other-extensions' fields."
- ^^^ removedIn CabalSpecV3_0
- "Please use 'default-extensions' or 'other-extensions' fields."
- <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs
- <*> monoidalFieldAla "extra-libraries-static" (alaList' VCat Token) L.extraLibsStatic
- ^^^ availableSince CabalSpecV3_8 []
- <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs
- <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs
- <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours
+ <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules
+ <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules
+ ^^^ availableSince CabalSpecV2_2 []
+ <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules
+ ^^^ availableSince CabalSpecV2_0 []
+ <*> optionalFieldAla "default-language" MQuoted L.defaultLanguage
+ ^^^ availableSince CabalSpecV1_10 Nothing
+ <*> monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages
+ ^^^ availableSince CabalSpecV1_10 []
+ <*> monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions
+ ^^^ availableSince CabalSpecV1_10 []
+ <*> monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions
+ ^^^ availableSinceWarn CabalSpecV1_10
+ <*> monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions
+ ^^^ deprecatedSince
+ CabalSpecV1_12
+ "Please use 'default-extensions' or 'other-extensions' fields."
+ ^^^ removedIn
+ CabalSpecV3_0
+ "Please use 'default-extensions' or 'other-extensions' fields."
+ <*> monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs
+ <*> monoidalFieldAla "extra-libraries-static" (alaList' VCat Token) L.extraLibsStatic
+ ^^^ availableSince CabalSpecV3_8 []
+ <*> monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs
+ <*> monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs
+ <*> monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours
<*> monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours
- ^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs
- <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.extraLibDirsStatic
- ^^^ availableSince CabalSpecV3_8 []
- <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs
- <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes
- <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes
- ^^^ availableSince CabalSpecV3_0 []
- <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes
+ ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "extra-lib-dirs" (alaList' FSep FilePathNT) L.extraLibDirs
+ <*> monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep FilePathNT) L.extraLibDirsStatic
+ ^^^ availableSince CabalSpecV3_8 []
+ <*> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs
+ <*> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes
+ <*> monoidalFieldAla "autogen-includes" (alaList' FSep FilePathNT) L.autogenIncludes
+ ^^^ availableSince CabalSpecV3_0 []
+ <*> monoidalFieldAla "install-includes" (alaList' FSep FilePathNT) L.installIncludes
<*> optionsFieldGrammar
<*> profOptionsFieldGrammar
<*> sharedOptionsFieldGrammar
<*> pure mempty -- static-options ???
- <*> prefixedFields "x-" L.customFieldsBI
- <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends
- <*> monoidalFieldAla "mixins" formatMixinList L.mixins
- ^^^ availableSince CabalSpecV2_0 []
+ <*> prefixedFields "x-" L.customFieldsBI
+ <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends
+ <*> monoidalFieldAla "mixins" formatMixinList L.mixins
+ ^^^ availableSince CabalSpecV2_0 []
{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-}
{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-}
hsSourceDirsGrammar
- :: ( FieldGrammar c g, Applicative (g BuildInfo)
- , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
- )
- => g BuildInfo [SymbolicPath PackageDir SourceDir]
-hsSourceDirsGrammar = (++)
+ :: ( FieldGrammar c g
+ , Applicative (g BuildInfo)
+ , c (List FSep (Identity (SymbolicPath PackageDir SourceDir)) (SymbolicPath PackageDir SourceDir))
+ )
+ => g BuildInfo [SymbolicPath PackageDir SourceDir]
+hsSourceDirsGrammar =
+ (++)
<$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs
- <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens
- --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44
- ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'"
- ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field."
+ <*> monoidalFieldAla "hs-source-dir" (alaList FSep) wrongLens
+ --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44
+ ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'"
+ ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field."
where
-- TODO: make pretty printer aware of CabalSpecVersion
wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath PackageDir SourceDir]
wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f []
optionsFieldGrammar
- :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))
- => g BuildInfo (PerCompilerFlavor [String])
-optionsFieldGrammar = PerCompilerFlavor
- <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC)
+ :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))
+ => g BuildInfo (PerCompilerFlavor [String])
+optionsFieldGrammar =
+ PerCompilerFlavor
+ <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC)
<*> monoidalFieldAla "ghcjs-options" (alaList' NoCommaFSep Token') (extract GHCJS)
-- NOTE: Hugs, NHC and JHC are not supported anymore, but these
-- fields are kept around so that we can still parse legacy .cabal
-- files that have them.
- <* knownField "jhc-options"
- <* knownField "hugs-options"
- <* knownField "nhc98-options"
+ <* knownField "jhc-options"
+ <* knownField "hugs-options"
+ <* knownField "nhc98-options"
where
extract :: CompilerFlavor -> ALens' BuildInfo [String]
extract flavor = L.options . lookupLens flavor
profOptionsFieldGrammar
- :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))
- => g BuildInfo (PerCompilerFlavor [String])
-profOptionsFieldGrammar = PerCompilerFlavor
- <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC)
+ :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))
+ => g BuildInfo (PerCompilerFlavor [String])
+profOptionsFieldGrammar =
+ PerCompilerFlavor
+ <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC)
<*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS)
where
extract :: CompilerFlavor -> ALens' BuildInfo [String]
extract flavor = L.profOptions . lookupLens flavor
sharedOptionsFieldGrammar
- :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))
- => g BuildInfo (PerCompilerFlavor [String])
-sharedOptionsFieldGrammar = PerCompilerFlavor
- <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC)
+ :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String))
+ => g BuildInfo (PerCompilerFlavor [String])
+sharedOptionsFieldGrammar =
+ PerCompilerFlavor
+ <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC)
<*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS)
where
extract :: CompilerFlavor -> ALens' BuildInfo [String]
@@ -659,21 +734,23 @@ sharedOptionsFieldGrammar = PerCompilerFlavor
lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v
lookupLens k f p@(PerCompilerFlavor ghc ghcjs)
- | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc
- | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs
- | otherwise = p <$ f mempty
+ | k == GHC = (\n -> PerCompilerFlavor n ghcjs) <$> f ghc
+ | k == GHCJS = (\n -> PerCompilerFlavor ghc n) <$> f ghcjs
+ | otherwise = p <$ f mempty
-------------------------------------------------------------------------------
-- Flag
-------------------------------------------------------------------------------
flagFieldGrammar
- :: (FieldGrammar c g, Applicative (g PackageFlag))
- => FlagName -> g PackageFlag PackageFlag
-flagFieldGrammar name = MkPackageFlag name
- <$> freeTextFieldDef "description" L.flagDescription
- <*> booleanFieldDef "default" L.flagDefault True
- <*> booleanFieldDef "manual" L.flagManual False
+ :: (FieldGrammar c g, Applicative (g PackageFlag))
+ => FlagName
+ -> g PackageFlag PackageFlag
+flagFieldGrammar name =
+ MkPackageFlag name
+ <$> freeTextFieldDef "description" L.flagDescription
+ <*> booleanFieldDef "default" L.flagDefault True
+ <*> booleanFieldDef "manual" L.flagManual False
{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-}
{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-}
@@ -682,15 +759,17 @@ flagFieldGrammar name = MkPackageFlag name
-------------------------------------------------------------------------------
sourceRepoFieldGrammar
- :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT)
- => RepoKind -> g SourceRepo SourceRepo
-sourceRepoFieldGrammar kind = SourceRepo kind
- <$> optionalField "type" L.repoType
- <*> freeTextField "location" L.repoLocation
- <*> optionalFieldAla "module" Token L.repoModule
- <*> optionalFieldAla "branch" Token L.repoBranch
- <*> optionalFieldAla "tag" Token L.repoTag
- <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir
+ :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT)
+ => RepoKind
+ -> g SourceRepo SourceRepo
+sourceRepoFieldGrammar kind =
+ SourceRepo kind
+ <$> optionalField "type" L.repoType
+ <*> freeTextField "location" L.repoLocation
+ <*> optionalFieldAla "module" Token L.repoModule
+ <*> optionalFieldAla "branch" Token L.repoBranch
+ <*> optionalFieldAla "tag" Token L.repoTag
+ <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir
{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-}
{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-}
@@ -699,9 +778,11 @@ sourceRepoFieldGrammar kind = SourceRepo kind
-------------------------------------------------------------------------------
setupBInfoFieldGrammar
- :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency))
- => Bool -> g SetupBuildInfo SetupBuildInfo
-setupBInfoFieldGrammar def = flip SetupBuildInfo def
+ :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency))
+ => Bool
+ -> g SetupBuildInfo SetupBuildInfo
+setupBInfoFieldGrammar def =
+ flip SetupBuildInfo def
<$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-}
{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-}
@@ -752,39 +833,38 @@ formatOtherModules = alaList' VCat MQuoted
--
-- across Hackage to outrule them completely.
-- I suspect some of them are generated (e.g. formatted) by machine.
---
-newtype CompatFilePath = CompatFilePath { getCompatFilePath :: FilePath } -- TODO: Change to use SymPath
+newtype CompatFilePath = CompatFilePath {getCompatFilePath :: FilePath} -- TODO: Change to use SymPath
instance Newtype String CompatFilePath
instance Parsec CompatFilePath where
- parsec = do
- token <- parsecToken
- if null token
- then do
- parsecWarning PWTEmptyFilePath "empty FilePath"
- return (CompatFilePath "")
- else return (CompatFilePath token)
+ parsec = do
+ token <- parsecToken
+ if null token
+ then do
+ parsecWarning PWTEmptyFilePath "empty FilePath"
+ return (CompatFilePath "")
+ else return (CompatFilePath token)
instance Pretty CompatFilePath where
- pretty = showToken . getCompatFilePath
+ pretty = showToken . getCompatFilePath
-newtype CompatLicenseFile = CompatLicenseFile { getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile] }
+newtype CompatLicenseFile = CompatLicenseFile {getCompatLicenseFile :: [SymbolicPath PackageDir LicenseFile]}
instance Newtype [SymbolicPath PackageDir LicenseFile] CompatLicenseFile
-- TODO
instance Parsec CompatLicenseFile where
- parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec
- where
- emptyToken = P.try $ do
- token <- parsecToken
- if null token
- then return (CompatLicenseFile [])
- else P.unexpected "non-empty-token"
+ parsec = emptyToken <|> CompatLicenseFile . unpack' (alaList FSep) <$> parsec
+ where
+ emptyToken = P.try $ do
+ token <- parsecToken
+ if null token
+ then return (CompatLicenseFile [])
+ else P.unexpected "non-empty-token"
instance Pretty CompatLicenseFile where
- pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile
+ pretty = pretty . pack' (alaList FSep) . getCompatLicenseFile
-------------------------------------------------------------------------------
-- vim syntax definitions
@@ -792,33 +872,40 @@ instance Pretty CompatLicenseFile where
-- | '_syntaxFieldNames' and '_syntaxExtensions'
-- are for generating VIM syntax file definitions.
---
_syntaxFieldNames :: IO ()
-_syntaxFieldNames = sequence_
+_syntaxFieldNames =
+ sequence_
[ BS8.putStrLn $ " \\ " <> n
- | n <- nub $ sort $ mconcat
- [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar
- , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName
- , fieldGrammarKnownFieldList $ executableFieldGrammar "exe"
- , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib"
- , fieldGrammarKnownFieldList testSuiteFieldGrammar
- , fieldGrammarKnownFieldList benchmarkFieldGrammar
- , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname")
- , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind")
- , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True
- ]
+ | n <-
+ nub $
+ sort $
+ mconcat
+ [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar
+ , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName
+ , fieldGrammarKnownFieldList $ executableFieldGrammar "exe"
+ , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib"
+ , fieldGrammarKnownFieldList testSuiteFieldGrammar
+ , fieldGrammarKnownFieldList benchmarkFieldGrammar
+ , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname")
+ , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind")
+ , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True
+ ]
]
_syntaxExtensions :: IO ()
-_syntaxExtensions = sequence_
+_syntaxExtensions =
+ sequence_
[ putStrLn $ " \\ " <> e
- | e <- ["Safe","Trustworthy","Unsafe"]
- ++ es
- ++ map ("No"++) es
+ | e <-
+ ["Safe", "Trustworthy", "Unsafe"]
+ ++ es
+ ++ map ("No" ++) es
]
where
- es = nub $ sort
+ es =
+ nub $
+ sort
[ prettyShow e
- | e <- [ minBound .. maxBound ]
- , e `notElem` [Safe,Unsafe,Trustworthy]
+ | e <- [minBound .. maxBound]
+ , e `notElem` [Safe, Unsafe, Trustworthy]
]
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs
index db8fc5d5e907d710ad9513218e19b9d0b9c8d89b..bee6965c12777e4e1543496eaf27e8a31bdd2965 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs
@@ -1,9 +1,11 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.PackageDescription.Parsec
-- Copyright : Isaac Jones 2003-2005
@@ -13,92 +15,93 @@
-- Portability : portable
--
-- This defined parsers and partial pretty printers for the @.cabal@ format.
-
-module Distribution.PackageDescription.Parsec (
- -- * Package descriptions
- parseGenericPackageDescription,
- parseGenericPackageDescriptionMaybe,
+module Distribution.PackageDescription.Parsec
+ ( -- * Package descriptions
+ parseGenericPackageDescription
+ , parseGenericPackageDescriptionMaybe
-- ** Parsing
- ParseResult,
- runParseResult,
+ , ParseResult
+ , runParseResult
-- * New-style spec-version
- scanSpecVersion,
+ , scanSpecVersion
-- ** Supplementary build information
- parseHookedBuildInfo,
- ) where
+ , parseHookedBuildInfo
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
-import Control.Monad.State.Strict (StateT, execStateT)
-import Control.Monad.Trans.Class (lift)
+import Control.Monad.State.Strict (StateT, execStateT)
+import Control.Monad.Trans.Class (lift)
import Distribution.CabalSpecVersion
import Distribution.Compat.Lens
import Distribution.FieldGrammar
-import Distribution.FieldGrammar.Parsec (NamelessField (..))
-import Distribution.Fields.ConfVar (parseConditionConfVar)
-import Distribution.Fields.Field (FieldName, getName)
-import Distribution.Fields.LexerMonad (LexWarning, toPWarnings)
-import Distribution.Fields.Parser
+import Distribution.FieldGrammar.Parsec (NamelessField (..))
+import Distribution.Fields.ConfVar (parseConditionConfVar)
+import Distribution.Fields.Field (FieldName, getName)
+import Distribution.Fields.LexerMonad (LexWarning, toPWarnings)
import Distribution.Fields.ParseResult
+import Distribution.Fields.Parser
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos)
import Distribution.PackageDescription.FieldGrammar
-import Distribution.PackageDescription.Quirks (patchQuirks)
-import Distribution.Parsec (parsec, simpleParsecBS)
-import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
-import Distribution.Parsec.Position (Position (..), zeroPos)
-import Distribution.Parsec.Warning (PWarnType (..))
-import Distribution.Pretty (prettyShow)
-import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8)
-import Distribution.Version (Version, mkVersion, versionNumbers)
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.Map.Strict as Map
-import qualified Data.Set as Set
-import qualified Distribution.Compat.Newtype as Newtype
-import qualified Distribution.Compat.NonEmptySet as NES
-import qualified Distribution.Types.BuildInfo.Lens as L
-import qualified Distribution.Types.Executable.Lens as L
-import qualified Distribution.Types.ForeignLib.Lens as L
+import Distribution.PackageDescription.Quirks (patchQuirks)
+import Distribution.Parsec (parsec, simpleParsecBS)
+import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
+import Distribution.Parsec.Position (Position (..), zeroPos)
+import Distribution.Parsec.Warning (PWarnType (..))
+import Distribution.Pretty (prettyShow)
+import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8)
+import Distribution.Version (Version, mkVersion, versionNumbers)
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Map.Strict as Map
+import qualified Data.Set as Set
+import qualified Distribution.Compat.Newtype as Newtype
+import qualified Distribution.Compat.NonEmptySet as NES
+import qualified Distribution.Types.BuildInfo.Lens as L
+import qualified Distribution.Types.Executable.Lens as L
+import qualified Distribution.Types.ForeignLib.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
-import qualified Distribution.Types.PackageDescription.Lens as L
-import qualified Distribution.Types.SetupBuildInfo.Lens as L
-import qualified Text.Parsec as P
+import qualified Distribution.Types.PackageDescription.Lens as L
+import qualified Distribution.Types.SetupBuildInfo.Lens as L
+import qualified Text.Parsec as P
------------------------------------------------------------------------------
+
-- | Parses the given file into a 'GenericPackageDescription'.
--
-- In Cabal 1.2 the syntax for package descriptions was changed to a format
-- with sections and possibly indented property descriptions.
---
parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription bs = do
- -- set scanned version
- setCabalSpecVersion ver
-
- csv <- case ver of
- -- if we get too new version, fail right away
- Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of
- Just csv -> return (Just csv)
- Nothing -> parseFatalFailure zeroPos $
- "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899."
- _ -> pure Nothing
-
- case readFields' bs'' of
- Right (fs, lexWarnings) -> do
- when patched $
- parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
- -- UTF8 is validated in a prepass step, afterwards parsing is lenient.
- parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs
- -- TODO: better marshalling of errors
- Left perr -> parseFatalFailure pos (show perr) where
- ppos = P.errorPos perr
- pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
+ -- set scanned version
+ setCabalSpecVersion ver
+
+ csv <- case ver of
+ -- if we get too new version, fail right away
+ Just v -> case cabalSpecFromVersionDigits (versionNumbers v) of
+ Just csv -> return (Just csv)
+ Nothing ->
+ parseFatalFailure zeroPos $
+ "Unsupported cabal-version " ++ prettyShow v ++ ". See https://github.com/haskell/cabal/issues/4899."
+ _ -> pure Nothing
+
+ case readFields' bs'' of
+ Right (fs, lexWarnings) -> do
+ when patched $
+ parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file"
+ -- UTF8 is validated in a prepass step, afterwards parsing is lenient.
+ parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs
+ -- TODO: better marshalling of errors
+ Left perr -> parseFatalFailure pos (show perr)
+ where
+ ppos = P.errorPos perr
+ pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
where
(patched, bs') = patchQuirks bs
ver = scanSpecVersion bs'
@@ -107,14 +110,13 @@ parseGenericPackageDescription bs = do
-- if there are invalid utf8 characters, we make the bytestring valid.
bs'' = case invalidUtf8 of
- Nothing -> bs'
- Just _ -> toUTF8BS (fromUTF8BS bs')
-
+ Nothing -> bs'
+ Just _ -> toUTF8BS (fromUTF8BS bs')
-- | 'Maybe' variant of 'parseGenericPackageDescription'
parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe =
- either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription
+ either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
@@ -124,9 +126,9 @@ type SectionParser = StateT SectionS ParseResult
-- | State of section parser
data SectionS = SectionS
- { _stateGpd :: !GenericPackageDescription
- , _stateCommonStanzas :: !(Map String CondTreeBuildInfo)
- }
+ { _stateGpd :: !GenericPackageDescription
+ , _stateCommonStanzas :: !(Map String CondTreeBuildInfo)
+ }
stateGpd :: Lens' SectionS GenericPackageDescription
stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd
@@ -139,69 +141,78 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs
-- Note [Accumulating parser]
--
-- This parser has two "states":
+
-- * first we parse fields of PackageDescription
+
-- * then we parse sections (libraries, executables, etc)
parseGenericPackageDescription'
- :: Maybe CabalSpecVersion
- -> [LexWarning]
- -> Maybe Int
- -> [Field Position]
- -> ParseResult GenericPackageDescription
+ :: Maybe CabalSpecVersion
+ -> [LexWarning]
+ -> Maybe Int
+ -> [Field Position]
+ -> ParseResult GenericPackageDescription
parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do
- parseWarnings (toPWarnings lexWarnings)
- for_ utf8WarnPos $ \pos ->
- parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
- let (syntax, fs') = sectionizeFields fs
- let (fields, sectionFields) = takeFields fs'
-
- -- cabal-version
- specVer <- case scannedVer of
- Just v -> return v
- Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of
- Nothing -> return CabalSpecV1_0
- Just (MkNamelessField pos fls) -> do
- -- version will be parsed twice, therefore we parse without warnings.
- v <- withoutWarnings $
- Newtype.unpack' SpecVersion <$>
- -- Use version with || and && but before addition of ^>= and removal of -any
- runFieldParser pos parsec CabalSpecV1_24 fls
-
- -- if it were at the beginning, scanner would found it
- when (v >= CabalSpecV2_2) $ parseFailure pos $
- "cabal-version should be at the beginning of the file starting with spec version 2.2. " ++
- "See https://github.com/haskell/cabal/issues/4899"
-
- return v
-
- -- reset cabal version, it might not be set
- let specVer' = mkVersion (cabalSpecToVersionDigits specVer)
- setCabalSpecVersion (Just specVer')
-
- -- Package description
- pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar
-
- -- Check that scanned and parsed versions match.
- unless (specVer == specVersion pd) $ parseFailure zeroPos $
- "Scanned and parsed cabal-versions don't match " ++
- prettyShow (SpecVersion specVer) ++ " /= " ++ prettyShow (SpecVersion (specVersion pd))
-
- maybeWarnCabalVersion syntax pd
-
- -- Sections
- let gpd = emptyGenericPackageDescription
- & L.packageDescription .~ pd
- gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)
-
- let gpd2 = postProcessInternalDeps specVer gpd1
- checkForUndefinedFlags gpd2
- checkForUndefinedCustomSetup gpd2
- -- See nothunks test, without this deepseq we get (at least):
- -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]}
- --
- -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks)
- -- TODO: remove the need for deepseq if `deepseq` in fact matters
- -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure
- gpd2 `deepseq` return gpd2
+ parseWarnings (toPWarnings lexWarnings)
+ for_ utf8WarnPos $ \pos ->
+ parseWarning zeroPos PWTUTF $ "UTF8 encoding problem at byte offset " ++ show pos
+ let (syntax, fs') = sectionizeFields fs
+ let (fields, sectionFields) = takeFields fs'
+
+ -- cabal-version
+ specVer <- case scannedVer of
+ Just v -> return v
+ Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of
+ Nothing -> return CabalSpecV1_0
+ Just (MkNamelessField pos fls) -> do
+ -- version will be parsed twice, therefore we parse without warnings.
+ v <-
+ withoutWarnings $
+ Newtype.unpack' SpecVersion
+ <$>
+ -- Use version with || and && but before addition of ^>= and removal of -any
+ runFieldParser pos parsec CabalSpecV1_24 fls
+
+ -- if it were at the beginning, scanner would found it
+ when (v >= CabalSpecV2_2) $
+ parseFailure pos $
+ "cabal-version should be at the beginning of the file starting with spec version 2.2. "
+ ++ "See https://github.com/haskell/cabal/issues/4899"
+
+ return v
+
+ -- reset cabal version, it might not be set
+ let specVer' = mkVersion (cabalSpecToVersionDigits specVer)
+ setCabalSpecVersion (Just specVer')
+
+ -- Package description
+ pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar
+
+ -- Check that scanned and parsed versions match.
+ unless (specVer == specVersion pd) $
+ parseFailure zeroPos $
+ "Scanned and parsed cabal-versions don't match "
+ ++ prettyShow (SpecVersion specVer)
+ ++ " /= "
+ ++ prettyShow (SpecVersion (specVersion pd))
+
+ maybeWarnCabalVersion syntax pd
+
+ -- Sections
+ let gpd =
+ emptyGenericPackageDescription
+ & L.packageDescription .~ pd
+ gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)
+
+ let gpd2 = postProcessInternalDeps specVer gpd1
+ checkForUndefinedFlags gpd2
+ checkForUndefinedCustomSetup gpd2
+ -- See nothunks test, without this deepseq we get (at least):
+ -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]}
+ --
+ -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks)
+ -- TODO: remove the need for deepseq if `deepseq` in fact matters
+ -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure
+ gpd2 `deepseq` return gpd2
where
safeLast :: [a] -> Maybe a
safeLast = listToMaybe . reverse
@@ -211,28 +222,27 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do
maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
maybeWarnCabalVersion syntax pkg
- | syntax == NewSyntax && specVersion pkg < newSyntaxVersion
- = parseWarning zeroPos PWTNewSyntax $
- "A package using section syntax must specify at least\n"
- ++ "'cabal-version: >= 1.2'."
-
+ | syntax == NewSyntax && specVersion pkg < newSyntaxVersion =
+ parseWarning zeroPos PWTNewSyntax $
+ "A package using section syntax must specify at least\n"
+ ++ "'cabal-version: >= 1.2'."
maybeWarnCabalVersion syntax pkg
- | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
- = parseWarning zeroPos PWTOldSyntax $
- "A package using 'cabal-version: "
- ++ prettyShow (SpecVersion (specVersion pkg))
- ++ "' must use section syntax. See the Cabal user guide for details."
-
+ | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion =
+ parseWarning zeroPos PWTOldSyntax $
+ "A package using 'cabal-version: "
+ ++ prettyShow (SpecVersion (specVersion pkg))
+ ++ "' must use section syntax. See the Cabal user guide for details."
maybeWarnCabalVersion _ _ = return ()
goSections :: CabalSpecVersion -> [Field Position] -> SectionParser ()
goSections specVer = traverse_ process
where
process (Field (Name pos name) _) =
- lift $ parseWarning pos PWTTrailingFields $
- "Ignoring trailing fields after sections: " ++ show name
+ lift $
+ parseWarning pos PWTTrailingFields $
+ "Ignoring trailing fields after sections: " ++ show name
process (Section name args secFields) =
- parseSection name args secFields
+ parseSection name args secFields
snoc x xs = xs ++ [x]
@@ -240,154 +250,164 @@ goSections specVer = traverse_ process
-- we need signature, because this is polymorphic, but not-closed
parseCondTree'
- :: L.HasBuildInfo a
- => ParsecFieldGrammar' a -- ^ grammar
- -> (BuildInfo -> a)
- -> Map String CondTreeBuildInfo -- ^ common stanzas
- -> [Field Position]
- -> ParseResult (CondTree ConfVar [Dependency] a)
+ :: L.HasBuildInfo a
+ => ParsecFieldGrammar' a
+ -- \^ grammar
+ -> (BuildInfo -> a)
+ -> Map String CondTreeBuildInfo
+ -- \^ common stanzas
+ -> [Field Position]
+ -> ParseResult (CondTree ConfVar [Dependency] a)
parseCondTree' = parseCondTreeWithCommonStanzas specVer
parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
parseSection (Name pos name) args fields
- | hasCommonStanzas == NoCommonStanzas, name == "common" = lift $ do
+ | hasCommonStanzas == NoCommonStanzas
+ , name == "common" = lift $ do
parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas."
-
- | name == "common" = do
- commonStanzas <- use stateCommonStanzas
- name' <- lift $ parseCommonName pos args
- biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields
-
- case Map.lookup name' commonStanzas of
- Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas
- Just _ -> lift $ parseFailure pos $
- "Duplicate common stanza: " ++ name'
-
- | name == "library" && null args = do
- prev <- use $ stateGpd . L.condLibrary
- when (isJust prev) $ lift $ parseFailure pos $
+ | name == "common" = do
+ commonStanzas <- use stateCommonStanzas
+ name' <- lift $ parseCommonName pos args
+ biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields
+
+ case Map.lookup name' commonStanzas of
+ Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas
+ Just _ ->
+ lift $
+ parseFailure pos $
+ "Duplicate common stanza: " ++ name'
+ | name == "library" && null args = do
+ prev <- use $ stateGpd . L.condLibrary
+ when (isJust prev) $
+ lift $
+ parseFailure pos $
"Multiple main libraries; have you forgotten to specify a name for an internal library?"
- commonStanzas <- use stateCommonStanzas
- let name'' = LMainLibName
- lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
- --
- -- TODO check that not set
- stateGpd . L.condLibrary ?= lib
-
- -- Sublibraries
- -- TODO: check cabal-version
- | name == "library" = do
- commonStanzas <- use stateCommonStanzas
- name' <- parseUnqualComponentName pos args
- let name'' = LSubLibName name'
- lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
- -- TODO check duplicate name here?
- stateGpd . L.condSubLibraries %= snoc (name', lib)
-
- -- TODO: check cabal-version
- | name == "foreign-library" = do
- commonStanzas <- use stateCommonStanzas
- name' <- parseUnqualComponentName pos args
- flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
-
- let hasType ts = foreignLibType ts /= foreignLibType mempty
- unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ concat
- [ "Foreign library " ++ show (prettyShow name')
- , " is missing required field \"type\" or the field "
- , "is not present in all conditional branches. The "
- , "available test types are: "
- , intercalate ", " (map prettyShow knownForeignLibTypes)
- ]
-
- -- TODO check duplicate name here?
- stateGpd . L.condForeignLibs %= snoc (name', flib)
-
- | name == "executable" = do
- commonStanzas <- use stateCommonStanzas
- name' <- parseUnqualComponentName pos args
- exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
- -- TODO check duplicate name here?
- stateGpd . L.condExecutables %= snoc (name', exe)
-
- | name == "test-suite" = do
- commonStanzas <- use stateCommonStanzas
- name' <- parseUnqualComponentName pos args
- testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields
- testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza
-
- let hasType ts = testInterface ts /= testInterface mempty
- unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat
- [ "Test suite " ++ show (prettyShow name')
-
- , concat $ case specVer of
- v | v >= CabalSpecV3_8 ->
- [ " is missing required field \"main-is\" or the field "
- , "is not present in all conditional branches."
- ]
- _ ->
+ commonStanzas <- use stateCommonStanzas
+ let name'' = LMainLibName
+ lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
+ --
+ -- TODO check that not set
+ stateGpd . L.condLibrary ?= lib
+
+ -- Sublibraries
+ -- TODO: check cabal-version
+ | name == "library" = do
+ commonStanzas <- use stateCommonStanzas
+ name' <- parseUnqualComponentName pos args
+ let name'' = LSubLibName name'
+ lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields
+ -- TODO check duplicate name here?
+ stateGpd . L.condSubLibraries %= snoc (name', lib)
+
+ -- TODO: check cabal-version
+ | name == "foreign-library" = do
+ commonStanzas <- use stateCommonStanzas
+ name' <- parseUnqualComponentName pos args
+ flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
+
+ let hasType ts = foreignLibType ts /= foreignLibType mempty
+ unless (onAllBranches hasType flib) $
+ lift $
+ parseFailure pos $
+ concat
+ [ "Foreign library " ++ show (prettyShow name')
+ , " is missing required field \"type\" or the field "
+ , "is not present in all conditional branches. The "
+ , "available test types are: "
+ , intercalate ", " (map prettyShow knownForeignLibTypes)
+ ]
+
+ -- TODO check duplicate name here?
+ stateGpd . L.condForeignLibs %= snoc (name', flib)
+ | name == "executable" = do
+ commonStanzas <- use stateCommonStanzas
+ name' <- parseUnqualComponentName pos args
+ exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields
+ -- TODO check duplicate name here?
+ stateGpd . L.condExecutables %= snoc (name', exe)
+ | name == "test-suite" = do
+ commonStanzas <- use stateCommonStanzas
+ name' <- parseUnqualComponentName pos args
+ testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields
+ testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza
+
+ let hasType ts = testInterface ts /= testInterface mempty
+ unless (onAllBranches hasType testSuite) $
+ lift $
+ parseFailure pos $
+ concat
+ [ "Test suite " ++ show (prettyShow name')
+ , concat $ case specVer of
+ v
+ | v >= CabalSpecV3_8 ->
+ [ " is missing required field \"main-is\" or the field "
+ , "is not present in all conditional branches."
+ ]
+ _ ->
[ " is missing required field \"type\" or the field "
, "is not present in all conditional branches. The "
, "available test types are: "
, intercalate ", " (map prettyShow knownTestTypes)
]
- ]
-
- -- TODO check duplicate name here?
- stateGpd . L.condTestSuites %= snoc (name', testSuite)
-
- | name == "benchmark" = do
- commonStanzas <- use stateCommonStanzas
- name' <- parseUnqualComponentName pos args
- benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields
- bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza
-
- let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty
- unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat
- [ "Benchmark " ++ show (prettyShow name')
- , concat $ case specVer of
- v | v >= CabalSpecV3_8 ->
- [ " is missing required field \"main-is\" or the field "
- , "is not present in all conditional branches."
- ]
- _ ->
+ ]
+
+ -- TODO check duplicate name here?
+ stateGpd . L.condTestSuites %= snoc (name', testSuite)
+ | name == "benchmark" = do
+ commonStanzas <- use stateCommonStanzas
+ name' <- parseUnqualComponentName pos args
+ benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields
+ bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza
+
+ let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty
+ unless (onAllBranches hasType bench) $
+ lift $
+ parseFailure pos $
+ concat
+ [ "Benchmark " ++ show (prettyShow name')
+ , concat $ case specVer of
+ v
+ | v >= CabalSpecV3_8 ->
+ [ " is missing required field \"main-is\" or the field "
+ , "is not present in all conditional branches."
+ ]
+ _ ->
[ " is missing required field \"type\" or the field "
, "is not present in all conditional branches. The "
, "available benchmark types are: "
, intercalate ", " (map prettyShow knownBenchmarkTypes)
]
- ]
-
- -- TODO check duplicate name here?
- stateGpd . L.condBenchmarks %= snoc (name', bench)
-
- | name == "flag" = do
- name' <- parseNameBS pos args
- name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
- flag <- lift $ parseFields specVer fields (flagFieldGrammar name'')
- -- Check default flag
- stateGpd . L.genPackageFlags %= snoc flag
-
- | name == "custom-setup" && null args = do
- sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False)
- stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi
-
- | name == "source-repository" = do
- kind <- lift $ case args of
- [SecArgName spos secName] ->
- runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
- [] -> do
- parseFailure pos "'source-repository' requires exactly one argument"
- pure RepoHead
- _ -> do
- parseFailure pos $ "Invalid source-repository kind " ++ show args
- pure RepoHead
-
- sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind)
- stateGpd . L.packageDescription . L.sourceRepos %= snoc sr
-
- | otherwise = lift $
- parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
+ ]
+
+ -- TODO check duplicate name here?
+ stateGpd . L.condBenchmarks %= snoc (name', bench)
+ | name == "flag" = do
+ name' <- parseNameBS pos args
+ name'' <- lift $ runFieldParser' [pos] parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
+ flag <- lift $ parseFields specVer fields (flagFieldGrammar name'')
+ -- Check default flag
+ stateGpd . L.genPackageFlags %= snoc flag
+ | name == "custom-setup" && null args = do
+ sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False)
+ stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi
+ | name == "source-repository" = do
+ kind <- lift $ case args of
+ [SecArgName spos secName] ->
+ runFieldParser' [spos] parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
+ [] -> do
+ parseFailure pos "'source-repository' requires exactly one argument"
+ pure RepoHead
+ _ -> do
+ parseFailure pos $ "Invalid source-repository kind " ++ show args
+ pure RepoHead
+
+ sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind)
+ stateGpd . L.packageDescription . L.sourceRepos %= snoc sr
+ | otherwise =
+ lift $
+ parseWarning pos PWTUnknownSection $
+ "Ignoring section: " ++ show name
parseName :: Position -> [SectionArg Position] -> SectionParser String
parseName pos args = fromUTF8BS <$> parseNameBS pos args
@@ -395,31 +415,31 @@ parseName pos args = fromUTF8BS <$> parseNameBS pos args
parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString
-- TODO: use strict parser
parseNameBS pos args = case args of
- [SecArgName _pos secName] ->
- pure secName
- [SecArgStr _pos secName] ->
- pure secName
- [] -> do
- lift $ parseFailure pos "name required"
- pure ""
- _ -> do
- -- TODO: pretty print args
- lift $ parseFailure pos $ "Invalid name " ++ show args
- pure ""
+ [SecArgName _pos secName] ->
+ pure secName
+ [SecArgStr _pos secName] ->
+ pure secName
+ [] -> do
+ lift $ parseFailure pos "name required"
+ pure ""
+ _ -> do
+ -- TODO: pretty print args
+ lift $ parseFailure pos $ "Invalid name " ++ show args
+ pure ""
parseCommonName :: Position -> [SectionArg Position] -> ParseResult String
parseCommonName pos args = case args of
- [SecArgName _pos secName] ->
- pure $ fromUTF8BS secName
- [SecArgStr _pos secName] ->
- pure $ fromUTF8BS secName
- [] -> do
- parseFailure pos $ "name required"
- pure ""
- _ -> do
- -- TODO: pretty print args
- parseFailure pos $ "Invalid name " ++ show args
- pure ""
+ [SecArgName _pos secName] ->
+ pure $ fromUTF8BS secName
+ [SecArgStr _pos secName] ->
+ pure $ fromUTF8BS secName
+ [] -> do
+ parseFailure pos $ "name required"
+ pure ""
+ _ -> do
+ -- TODO: pretty print args
+ parseFailure pos $ "Invalid name " ++ show args
+ pure ""
-- TODO: avoid conversion to 'String'.
parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
@@ -427,76 +447,83 @@ parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
-- | Parse a non-recursive list of fields.
parseFields
- :: CabalSpecVersion
- -> [Field Position] -- ^ fields to be parsed
- -> ParsecFieldGrammar' a
- -> ParseResult a
+ :: CabalSpecVersion
+ -> [Field Position]
+ -- ^ fields to be parsed
+ -> ParsecFieldGrammar' a
+ -> ParseResult a
parseFields v fields grammar = do
- let (fs0, ss) = partitionFields fields
- traverse_ (traverse_ warnInvalidSubsection) ss
- parseFieldGrammar v fs0 grammar
+ let (fs0, ss) = partitionFields fields
+ traverse_ (traverse_ warnInvalidSubsection) ss
+ parseFieldGrammar v fs0 grammar
warnInvalidSubsection :: Section Position -> ParseResult ()
warnInvalidSubsection (MkSection (Name pos name) _ _) =
- void $ parseFailure pos $ "invalid subsection " ++ show name
+ void $ parseFailure pos $ "invalid subsection " ++ show name
parseCondTree
- :: forall a. L.HasBuildInfo a
- => CabalSpecVersion
- -> HasElif -- ^ accept @elif@
- -> ParsecFieldGrammar' a -- ^ grammar
- -> Map String CondTreeBuildInfo -- ^ common stanzas
- -> (BuildInfo -> a) -- ^ constructor from buildInfo
- -> (a -> [Dependency]) -- ^ condition extractor
- -> [Field Position]
- -> ParseResult (CondTree ConfVar [Dependency] a)
+ :: forall a
+ . L.HasBuildInfo a
+ => CabalSpecVersion
+ -> HasElif
+ -- ^ accept @elif@
+ -> ParsecFieldGrammar' a
+ -- ^ grammar
+ -> Map String CondTreeBuildInfo
+ -- ^ common stanzas
+ -> (BuildInfo -> a)
+ -- ^ constructor from buildInfo
+ -> (a -> [Dependency])
+ -- ^ condition extractor
+ -> [Field Position]
+ -> ParseResult (CondTree ConfVar [Dependency] a)
parseCondTree v hasElif grammar commonStanzas fromBuildInfo cond = go
where
go fields0 = do
- (fields, endo) <-
- if v >= CabalSpecV3_0
- then processImports v fromBuildInfo commonStanzas fields0
- else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id)
+ (fields, endo) <-
+ if v >= CabalSpecV3_0
+ then processImports v fromBuildInfo commonStanzas fields0
+ else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id)
- let (fs, ss) = partitionFields fields
- x <- parseFieldGrammar v fs grammar
- branches <- concat <$> traverse parseIfs ss
- return $ endo $ CondNode x (cond x) branches
+ let (fs, ss) = partitionFields fields
+ x <- parseFieldGrammar v fs grammar
+ branches <- concat <$> traverse parseIfs ss
+ return $ endo $ CondNode x (cond x) branches
parseIfs :: [Section Position] -> ParseResult [CondBranch ConfVar [Dependency] a]
parseIfs [] = return []
parseIfs (MkSection (Name _ name) test fields : sections) | name == "if" = do
- test' <- parseConditionConfVar test
- fields' <- go fields
- (elseFields, sections') <- parseElseIfs sections
- return (CondBranch test' fields' elseFields : sections')
+ test' <- parseConditionConfVar test
+ fields' <- go fields
+ (elseFields, sections') <- parseElseIfs sections
+ return (CondBranch test' fields' elseFields : sections')
parseIfs (MkSection (Name pos name) _ _ : sections) = do
- parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
- parseIfs sections
+ parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name
+ parseIfs sections
parseElseIfs
- :: [Section Position]
- -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
+ :: [Section Position]
+ -> ParseResult (Maybe (CondTree ConfVar [Dependency] a), [CondBranch ConfVar [Dependency] a])
parseElseIfs [] = return (Nothing, [])
parseElseIfs (MkSection (Name pos name) args fields : sections) | name == "else" = do
- unless (null args) $
- parseFailure pos $ "`else` section has section arguments " ++ show args
- elseFields <- go fields
- sections' <- parseIfs sections
- return (Just elseFields, sections')
-
- parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do
- test' <- parseConditionConfVar test
- fields' <- go fields
- (elseFields, sections') <- parseElseIfs sections
- -- we parse an empty 'Fields', to get empty value for a node
- a <- parseFieldGrammar v mempty grammar
- return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
-
+ unless (null args) $
+ parseFailure pos $
+ "`else` section has section arguments " ++ show args
+ elseFields <- go fields
+ sections' <- parseIfs sections
+ return (Just elseFields, sections')
+ parseElseIfs (MkSection (Name _ name) test fields : sections)
+ | hasElif == HasElif
+ , name == "elif" = do
+ test' <- parseConditionConfVar test
+ fields' <- go fields
+ (elseFields, sections') <- parseElseIfs sections
+ -- we parse an empty 'Fields', to get empty value for a node
+ a <- parseFieldGrammar v mempty grammar
+ return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do
- parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
- (,) Nothing <$> parseIfs sections
-
+ parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals."
+ (,) Nothing <$> parseIfs sections
parseElseIfs sections = (,) Nothing <$> parseIfs sections
{- Note [Accumulating parser]
@@ -507,15 +534,15 @@ In there parser, @'FieldDescr' a@ is transformed into @Map FieldName (a ->
FieldParser a)@. The weird value is used because we accumulate structure of
@a@ by folding over the fields. There are various reasons for that:
-* Almost all fields are optional
+\* Almost all fields are optional
-* This is simple approach so declarative bi-directional format (parsing and
+\* This is simple approach so declarative bi-directional format (parsing and
printing) of structure could be specified (list of @'FieldDescr' a@)
-* There are surface syntax fields corresponding to single field in the file:
+\* There are surface syntax fields corresponding to single field in the file:
@license-file@ and @license-files@
-* This is quite safe approach.
+\* This is quite safe approach.
When/if we re-implement the parser to support formatting preservging roundtrip
with new AST, this all need to be rewritten.
@@ -555,7 +582,6 @@ with new AST, this all need to be rewritten.
-- The approach is simple, and have good properties:
--
-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them.
---
type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
-- | Create @a@ from 'BuildInfo'.
@@ -565,49 +591,57 @@ type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
--
-- This takes name, as 'FieldGrammar's take names too.
class L.HasBuildInfo a => FromBuildInfo a where
- fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a
+ fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a
libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library
-libraryFromBuildInfo n bi = emptyLibrary
- { libName = n
+libraryFromBuildInfo n bi =
+ emptyLibrary
+ { libName = n
, libVisibility = case n of
- LMainLibName -> LibraryVisibilityPublic
+ LMainLibName -> LibraryVisibilityPublic
LSubLibName _ -> LibraryVisibilityPrivate
- , libBuildInfo = bi
+ , libBuildInfo = bi
}
-instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id
+instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id
instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib
-instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable
+instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable
instance FromBuildInfo TestSuiteStanza where
- fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi []
+ fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi []
instance FromBuildInfo BenchmarkStanza where
- fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi
+ fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi
parseCondTreeWithCommonStanzas
- :: forall a. L.HasBuildInfo a
- => CabalSpecVersion
- -> ParsecFieldGrammar' a -- ^ grammar
- -> (BuildInfo -> a) -- ^ construct fromBuildInfo
- -> Map String CondTreeBuildInfo -- ^ common stanzas
- -> [Field Position]
- -> ParseResult (CondTree ConfVar [Dependency] a)
+ :: forall a
+ . L.HasBuildInfo a
+ => CabalSpecVersion
+ -> ParsecFieldGrammar' a
+ -- ^ grammar
+ -> (BuildInfo -> a)
+ -- ^ construct fromBuildInfo
+ -> Map String CondTreeBuildInfo
+ -- ^ common stanzas
+ -> [Field Position]
+ -> ParseResult (CondTree ConfVar [Dependency] a)
parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do
- (fields', endo) <- processImports v fromBuildInfo commonStanzas fields
- x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'
- return (endo x)
+ (fields', endo) <- processImports v fromBuildInfo commonStanzas fields
+ x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo (view L.targetBuildDepends) fields'
+ return (endo x)
where
hasElif = specHasElif v
processImports
- :: forall a. L.HasBuildInfo a
- => CabalSpecVersion
- -> (BuildInfo -> a) -- ^ construct fromBuildInfo
- -> Map String CondTreeBuildInfo -- ^ common stanzas
- -> [Field Position]
- -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)
+ :: forall a
+ . L.HasBuildInfo a
+ => CabalSpecVersion
+ -> (BuildInfo -> a)
+ -- ^ construct fromBuildInfo
+ -> Map String CondTreeBuildInfo
+ -- ^ common stanzas
+ -> [Field Position]
+ -> ParseResult ([Field Position], CondTree ConfVar [Dependency] a -> CondTree ConfVar [Dependency] a)
processImports v fromBuildInfo commonStanzas = go []
where
hasCommonStanzas = specHasCommonStanzas v
@@ -615,44 +649,46 @@ processImports v fromBuildInfo commonStanzas = go []
getList' :: List CommaFSep Token String -> [String]
getList' = Newtype.unpack
- go acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do
- parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
- go acc fields
+ go acc (Field (Name pos name) _ : fields)
+ | name == "import"
+ , hasCommonStanzas == NoCommonStanzas = do
+ parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
+ go acc fields
-- supported:
go acc (Field (Name pos name) fls : fields) | name == "import" = do
- names <- getList' <$> runFieldParser pos parsec v fls
- names' <- for names $ \commonName ->
- case Map.lookup commonName commonStanzas of
- Nothing -> do
- parseFailure pos $ "Undefined common stanza imported: " ++ commonName
- pure Nothing
- Just commonTree ->
- pure (Just commonTree)
+ names <- getList' <$> runFieldParser pos parsec v fls
+ names' <- for names $ \commonName ->
+ case Map.lookup commonName commonStanzas of
+ Nothing -> do
+ parseFailure pos $ "Undefined common stanza imported: " ++ commonName
+ pure Nothing
+ Just commonTree ->
+ pure (Just commonTree)
- go (acc ++ catMaybes names') fields
+ go (acc ++ catMaybes names') fields
-- parse actual CondTree
go acc fields = do
- fields' <- catMaybes <$> traverse (warnImport v) fields
- pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc)
+ fields' <- catMaybes <$> traverse (warnImport v) fields
+ pure $ (fields', \x -> foldr (mergeCommonStanza fromBuildInfo) x acc)
-- | Warn on "import" fields, also map to Maybe, so errorneous fields can be filtered
warnImport :: CabalSpecVersion -> Field Position -> ParseResult (Maybe (Field Position))
-warnImport v (Field (Name pos name) _) | name == "import" = do
- if specHasCommonStanzas v == NoCommonStanzas
+warnImport v (Field (Name pos name) _) | name == "import" = do
+ if specHasCommonStanzas v == NoCommonStanzas
then parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
else parseWarning pos PWTUnknownField "Unknown field: import. Common stanza imports should be at the top of the enclosing section"
- return Nothing
+ return Nothing
warnImport _ f = pure (Just f)
mergeCommonStanza
- :: L.HasBuildInfo a
- => (BuildInfo -> a)
- -> CondTree ConfVar [Dependency] BuildInfo
- -> CondTree ConfVar [Dependency] a
- -> CondTree ConfVar [Dependency] a
+ :: L.HasBuildInfo a
+ => (BuildInfo -> a)
+ -> CondTree ConfVar [Dependency] BuildInfo
+ -> CondTree ConfVar [Dependency] a
+ -> CondTree ConfVar [Dependency] a
mergeCommonStanza fromBuildInfo (CondNode bi _ bis) (CondNode x _ cs) =
- CondNode x' (x' ^. L.targetBuildDepends) cs'
+ CondNode x' (x' ^. L.targetBuildDepends) cs'
where
-- new value is old value with buildInfo field _prepended_.
x' = x & L.buildInfo %~ (bi <>)
@@ -674,13 +710,14 @@ onAllBranches p = go mempty
-- one need one to satisfy the property because the configure step uses
-- 'mappend' to join together the results of flag resolution.
go :: a -> CondTree v c a -> Bool
- go acc ct = let acc' = acc `mappend` condTreeData ct
- in p acc' || any (goBranch acc') (condTreeComponents ct)
+ go acc ct =
+ let acc' = acc `mappend` condTreeData ct
+ in p acc' || any (goBranch acc') (condTreeComponents ct)
-- Both the 'true' and the 'false' block must satisfy the property.
goBranch :: a -> CondBranch v c a -> Bool
- goBranch _ (CondBranch _ _ Nothing) = False
- goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
+ goBranch _ (CondBranch _ _ Nothing) = False
+ goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
-------------------------------------------------------------------------------
-- Post parsing checks
@@ -690,32 +727,32 @@ onAllBranches p = go mempty
--
-- * don't use undefined flags (very bad)
-- * define flags which are unused (just bad)
---
checkForUndefinedFlags :: GenericPackageDescription -> ParseResult ()
checkForUndefinedFlags gpd = do
- let definedFlags, usedFlags :: Set.Set FlagName
- definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd
- usedFlags = getConst $ L.allCondTrees f gpd
-
- -- Note: we can check for defined, but unused flags here too.
- unless (usedFlags `Set.isSubsetOf` definedFlags) $ parseFailure zeroPos $
- "These flags are used without having been defined: " ++
- intercalate ", " [ unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags ]
+ let definedFlags, usedFlags :: Set.Set FlagName
+ definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) gpd
+ usedFlags = getConst $ L.allCondTrees f gpd
+
+ -- Note: we can check for defined, but unused flags here too.
+ unless (usedFlags `Set.isSubsetOf` definedFlags) $
+ parseFailure zeroPos $
+ "These flags are used without having been defined: "
+ ++ intercalate ", " [unFlagName fn | fn <- Set.toList $ usedFlags `Set.difference` definedFlags]
where
f :: CondTree ConfVar c a -> Const (Set.Set FlagName) (CondTree ConfVar c a)
f ct = Const (Set.fromList (freeVars ct))
-- | Since @cabal-version: 1.24@ one can specify @custom-setup@.
-- Let us require it.
---
checkForUndefinedCustomSetup :: GenericPackageDescription -> ParseResult ()
checkForUndefinedCustomSetup gpd = do
- let pd = packageDescription gpd
- let csv = specVersion pd
+ let pd = packageDescription gpd
+ let csv = specVersion pd
- when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $
- when (csv >= CabalSpecV1_24) $ parseFailure zeroPos $
- "Since cabal-version: 1.24 specifying custom-setup section is mandatory"
+ when (buildType pd == Custom && isNothing (setupBuildInfo pd)) $
+ when (csv >= CabalSpecV1_24) $
+ parseFailure zeroPos $
+ "Since cabal-version: 1.24 specifying custom-setup section is mandatory"
-------------------------------------------------------------------------------
-- Post processing of internal dependencies
@@ -761,12 +798,12 @@ checkForUndefinedCustomSetup gpd = do
postProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription
postProcessInternalDeps specVer gpd
- | specVer >= CabalSpecV3_4 = gpd
- | otherwise = transformAllBuildInfos transformBI transformSBI gpd
+ | specVer >= CabalSpecV3_4 = gpd
+ | otherwise = transformAllBuildInfos transformBI transformSBI gpd
where
transformBI :: BuildInfo -> BuildInfo
- transformBI
- = over L.targetBuildDepends (concatMap transformD)
+ transformBI =
+ over L.targetBuildDepends (concatMap transformD)
. over L.mixins (map transformM)
transformSBI :: SetupBuildInfo -> SetupBuildInfo
@@ -774,31 +811,30 @@ postProcessInternalDeps specVer gpd
transformD :: Dependency -> [Dependency]
transformD (Dependency pn vr ln)
- | uqn `Set.member` internalLibs
- , LMainLibName `NES.member` ln
- = case NES.delete LMainLibName ln of
- Nothing -> [dep]
+ | uqn `Set.member` internalLibs
+ , LMainLibName `NES.member` ln =
+ case NES.delete LMainLibName ln of
+ Nothing -> [dep]
Just ln' -> [dep, Dependency pn vr ln']
where
uqn = packageNameToUnqualComponentName pn
dep = Dependency thisPn vr (NES.singleton (LSubLibName uqn))
-
transformD d = [d]
transformM :: Mixin -> Mixin
transformM (Mixin pn LMainLibName incl)
- | uqn `Set.member` internalLibs
- = mkMixin thisPn (LSubLibName uqn) incl
+ | uqn `Set.member` internalLibs =
+ mkMixin thisPn (LSubLibName uqn) incl
where
uqn = packageNameToUnqualComponentName pn
-
transformM m = m
thisPn :: PackageName
thisPn = pkgName (package (packageDescription gpd))
internalLibs :: Set UnqualComponentName
- internalLibs = Set.fromList
+ internalLibs =
+ Set.fromList
[ n
| (n, _) <- condSubLibraries gpd
]
@@ -823,15 +859,15 @@ postProcessInternalDeps specVer gpd
-- section.
sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
sectionizeFields fs = case classifyFields fs of
- Just fields -> (OldSyntax, convert fields)
- Nothing -> (NewSyntax, fs)
+ Just fields -> (OldSyntax, convert fields)
+ Nothing -> (NewSyntax, fs)
where
-- return 'Just' if all fields are simple fields
classifyFields :: [Field ann] -> Maybe [(Name ann, [FieldLine ann])]
classifyFields = traverse f
where
f (Field name fieldlines) = Just (name, fieldlines)
- f _ = Nothing
+ f _ = Nothing
trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse
isSpace' = (== 32)
@@ -844,30 +880,32 @@ sectionizeFields fs = case classifyFields fs of
-- compatible, we still allow it as a global field in old-style
-- package description files and translate it to a local field by
-- adding it to every non-empty section
- (hdr0, exes0) = break ((=="executable") . getName . fst) fields
+ (hdr0, exes0) = break ((== "executable") . getName . fst) fields
(hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0
- (deps, libfs) = partition ((== "build-depends") . getName . fst)
- libfs0
+ (deps, libfs) =
+ partition
+ ((== "build-depends") . getName . fst)
+ libfs0
exes = unfoldr toExe exes0
toExe [] = Nothing
toExe ((Name pos n, ls) : r)
| n == "executable" =
let (efs, r') = break ((== "executable") . getName . fst) r
- in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')
+ in Just (Section (Name pos "executable") [SecArgName pos $ trim $ fieldlinesToBS ls] (map toField $ deps ++ efs), r')
toExe _ = error "unexpected input to 'toExe'"
lib = case libfs of
- [] -> []
- ((Name pos _, _) : _) ->
- [Section (Name pos "library") [] (map toField $ deps ++ libfs)]
-
- in map toField hdr ++ lib ++ exes
+ [] -> []
+ ((Name pos _, _) : _) ->
+ [Section (Name pos "library") [] (map toField $ deps ++ libfs)]
+ in
+ map toField hdr ++ lib ++ exes
-- | See 'sectionizeFields'.
data Syntax = OldSyntax | NewSyntax
- deriving (Eq, Show)
+ deriving (Eq, Show)
-- TODO:
libFieldNames :: [FieldName]
@@ -879,57 +917,57 @@ libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName)
parseHookedBuildInfo :: BS.ByteString -> ParseResult HookedBuildInfo
parseHookedBuildInfo bs = case readFields' bs of
- Right (fs, lexWarnings) -> do
- parseHookedBuildInfo' lexWarnings fs
- -- TODO: better marshalling of errors
- Left perr -> parseFatalFailure zeroPos (show perr)
+ Right (fs, lexWarnings) -> do
+ parseHookedBuildInfo' lexWarnings fs
+ -- TODO: better marshalling of errors
+ Left perr -> parseFatalFailure zeroPos (show perr)
parseHookedBuildInfo'
- :: [LexWarning]
- -> [Field Position]
- -> ParseResult HookedBuildInfo
+ :: [LexWarning]
+ -> [Field Position]
+ -> ParseResult HookedBuildInfo
parseHookedBuildInfo' lexWarnings fs = do
- parseWarnings (toPWarnings lexWarnings)
- (mLibFields, exes) <- stanzas fs
- mLib <- parseLib mLibFields
- biExes <- traverse parseExe exes
- return (mLib, biExes)
+ parseWarnings (toPWarnings lexWarnings)
+ (mLibFields, exes) <- stanzas fs
+ mLib <- parseLib mLibFields
+ biExes <- traverse parseExe exes
+ return (mLib, biExes)
where
parseLib :: Fields Position -> ParseResult (Maybe BuildInfo)
parseLib fields
- | Map.null fields = pure Nothing
- | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
+ | Map.null fields = pure Nothing
+ | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
parseExe :: (UnqualComponentName, Fields Position) -> ParseResult (UnqualComponentName, BuildInfo)
parseExe (n, fields) = do
- bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
- pure (n, bi)
+ bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar
+ pure (n, bi)
stanzas :: [Field Position] -> ParseResult (Fields Position, [(UnqualComponentName, Fields Position)])
stanzas fields = do
- let (hdr0, exes0) = breakMaybe isExecutableField fields
- hdr <- toFields hdr0
- exes <- unfoldrM (traverse toExe) exes0
- pure (hdr, exes)
+ let (hdr0, exes0) = breakMaybe isExecutableField fields
+ hdr <- toFields hdr0
+ exes <- unfoldrM (traverse toExe) exes0
+ pure (hdr, exes)
toFields :: [Field Position] -> ParseResult (Fields Position)
toFields fields = do
- let (fields', ss) = partitionFields fields
- traverse_ (traverse_ warnInvalidSubsection) ss
- pure fields'
+ let (fields', ss) = partitionFields fields
+ traverse_ (traverse_ warnInvalidSubsection) ss
+ pure fields'
toExe
- :: ([FieldLine Position], [Field Position])
- -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position]))
+ :: ([FieldLine Position], [Field Position])
+ -> ParseResult ((UnqualComponentName, Fields Position), Maybe ([FieldLine Position], [Field Position]))
toExe (fss, fields) = do
- name <- runFieldParser zeroPos parsec cabalSpecLatest fss
- let (hdr0, rest) = breakMaybe isExecutableField fields
- hdr <- toFields hdr0
- pure ((name, hdr), rest)
+ name <- runFieldParser zeroPos parsec cabalSpecLatest fss
+ let (hdr0, rest) = breakMaybe isExecutableField fields
+ hdr <- toFields hdr0
+ pure ((name, hdr), rest)
isExecutableField (Field (Name _ name) fss)
- | name == "executable" = Just fss
- | otherwise = Nothing
+ | name == "executable" = Just fss
+ | otherwise = Nothing
isExecutableField _ = Nothing
-------------------------------------------------------------------------------
@@ -952,29 +990,29 @@ parseHookedBuildInfo' lexWarnings fs = do
-- DIGITP = %x31-39
-- WS = %20
-- @
---
scanSpecVersion :: BS.ByteString -> Maybe Version
scanSpecVersion bs = do
- fstline':_ <- pure (BS8.lines bs)
-
- -- parse <newstyle-spec-version-decl>
- -- normalise: remove all whitespace, convert to lower-case
- let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline'
- ["cabal-version",vers] <- pure (BS8.split ':' fstline)
-
- -- parse <spec-version>
- --
- -- This is currently more tolerant regarding leading 0 digits.
- --
- ver <- simpleParsecBS vers
- guard $ case versionNumbers ver of
- [_,_] -> True
- [_,_,_] -> True
- _ -> False
-
- pure ver
+ fstline' : _ <- pure (BS8.lines bs)
+
+ -- parse <newstyle-spec-version-decl>
+ -- normalise: remove all whitespace, convert to lower-case
+ let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline'
+ ["cabal-version", vers] <- pure (BS8.split ':' fstline)
+
+ -- parse <spec-version>
+ --
+ -- This is currently more tolerant regarding leading 0 digits.
+ --
+ ver <- simpleParsecBS vers
+ guard $ case versionNumbers ver of
+ [_, _] -> True
+ [_, _, _] -> True
+ _ -> False
+
+ pure ver
where
- -- | Translate ['A'..'Z'] to ['a'..'z']
+ -- \| Translate ['A'..'Z'] to ['a'..'z']
toLowerW8 :: Word8 -> Word8
- toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20
- | otherwise = w
+ toLowerW8 w
+ | 0x40 < w && w < 0x5b = w + 0x20
+ | otherwise = w
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs
index 4a2f5409695409feb28164c715b2924106d4c759..b03b1b99adaadac3ef258a08d2ffbdfa743f814f 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE OverloadedStrings #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.PackageDescription.PrettyPrint
-- Copyright : Jürgen Nicklisch-Franken 2010
@@ -10,46 +14,52 @@
-- Portability : portable
--
-- Pretty printing for cabal files
---
------------------------------------------------------------------------------
-
-module Distribution.PackageDescription.PrettyPrint (
- -- * Generic package descriptions
- writeGenericPackageDescription,
- showGenericPackageDescription,
- ppGenericPackageDescription,
+module Distribution.PackageDescription.PrettyPrint
+ ( -- * Generic package descriptions
+ writeGenericPackageDescription
+ , showGenericPackageDescription
+ , ppGenericPackageDescription
-- * Package descriptions
- writePackageDescription,
- showPackageDescription,
+ , writePackageDescription
+ , showPackageDescription
- -- ** Supplementary build information
- writeHookedBuildInfo,
- showHookedBuildInfo,
-) where
+ -- ** Supplementary build information
+ , writeHookedBuildInfo
+ , showHookedBuildInfo
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.CabalSpecVersion
-import Distribution.Fields.Pretty
import Distribution.Compat.Lens
+import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar)
+import Distribution.Fields.Pretty
import Distribution.PackageDescription
-import Distribution.Pretty
-import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar)
import Distribution.PackageDescription.Configuration (transformAllBuildInfos)
import Distribution.PackageDescription.FieldGrammar
- (benchmarkFieldGrammar, buildInfoFieldGrammar, executableFieldGrammar, flagFieldGrammar, foreignLibFieldGrammar, libraryFieldGrammar,
- packageDescriptionFieldGrammar, setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar)
-import Distribution.Utils.Generic (writeFileAtomic, writeUTF8File)
+ ( benchmarkFieldGrammar
+ , buildInfoFieldGrammar
+ , executableFieldGrammar
+ , flagFieldGrammar
+ , foreignLibFieldGrammar
+ , libraryFieldGrammar
+ , packageDescriptionFieldGrammar
+ , setupBInfoFieldGrammar
+ , sourceRepoFieldGrammar
+ , testSuiteFieldGrammar
+ )
+import Distribution.Pretty
+import Distribution.Utils.Generic (writeFileAtomic, writeUTF8File)
import qualified Distribution.PackageDescription.FieldGrammar as FG
-import qualified Distribution.Types.BuildInfo.Lens as L
-import qualified Distribution.Types.SetupBuildInfo.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
+import qualified Distribution.Types.SetupBuildInfo.Lens as L
import Text.PrettyPrint (Doc, char, hsep, parens, text)
-import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
import qualified Distribution.Compat.NonEmptySet as NES
-- | Writes a .cabal file from a generic package description
@@ -64,7 +74,8 @@ showGenericPackageDescription gpd = showFields (const NoComment) $ ppGenericPack
-- | Convert a generic package description to 'PrettyField's.
ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()]
-ppGenericPackageDescription v gpd0 = concat
+ppGenericPackageDescription v gpd0 =
+ concat
[ ppPackageDescription v (packageDescription gpd)
, ppSetupBInfo v (setupBuildInfo (packageDescription gpd))
, ppGenPackageFlags v (genPackageFlags gpd)
@@ -78,17 +89,17 @@ ppGenericPackageDescription v gpd0 = concat
where
gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0
-
ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()]
ppPackageDescription v pd =
- prettyFieldGrammar v packageDescriptionFieldGrammar pd
+ prettyFieldGrammar v packageDescriptionFieldGrammar pd
++ ppSourceRepos v (sourceRepos pd)
ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()]
ppSourceRepos = map . ppSourceRepo
ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ()
-ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $
+ppSourceRepo v repo =
+ PrettySection () "source-repository" [pretty kind] $
prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo
where
kind = repoKind repo
@@ -96,15 +107,18 @@ ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $
ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()]
ppSetupBInfo _ Nothing = mempty
ppSetupBInfo v (Just sbi)
- | defaultSetupDepends sbi = mempty
- | otherwise = pure $ PrettySection () "custom-setup" [] $
- prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi
+ | defaultSetupDepends sbi = mempty
+ | otherwise =
+ pure $
+ PrettySection () "custom-setup" [] $
+ prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi
ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()]
ppGenPackageFlags = map . ppFlag
ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ()
-ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $
+ppFlag v flag@(MkPackageFlag name _ _ _) =
+ PrettySection () "flag" [ppFlagName name] $
prettyFieldGrammar v (flagFieldGrammar name) flag
ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()]
@@ -112,15 +126,14 @@ ppCondTree2 v grammar = go
where
-- TODO: recognise elif opportunities
go (CondNode it _ ifs) =
- prettyFieldGrammar v grammar it ++
- concatMap ppIf ifs
+ prettyFieldGrammar v grammar it
+ ++ concatMap ppIf ifs
ppIf (CondBranch c thenTree Nothing)
--- | isEmpty thenDoc = mempty
- | otherwise = [ppIfCondition c thenDoc]
+ -- | isEmpty thenDoc = mempty
+ | otherwise = [ppIfCondition c thenDoc]
where
thenDoc = go thenTree
-
ppIf (CondBranch c thenTree (Just elseTree)) =
-- See #6193
[ ppIfCondition c (go thenTree)
@@ -129,60 +142,74 @@ ppCondTree2 v grammar = go
ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()]
ppCondLibrary _ Nothing = mempty
-ppCondLibrary v (Just condTree) = pure $ PrettySection () "library" [] $
- ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree
+ppCondLibrary v (Just condTree) =
+ pure $
+ PrettySection () "library" [] $
+ ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree
ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Library)] -> [PrettyField ()]
ppCondSubLibraries v libs =
- [ PrettySection () "library" [pretty n]
- $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree
- | (n, condTree) <- libs
- ]
+ [ PrettySection () "library" [pretty n] $
+ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree
+ | (n, condTree) <- libs
+ ]
ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()]
ppCondForeignLibs v flibs =
- [ PrettySection () "foreign-library" [pretty n]
- $ ppCondTree2 v (foreignLibFieldGrammar n) condTree
- | (n, condTree) <- flibs
- ]
+ [ PrettySection () "foreign-library" [pretty n] $
+ ppCondTree2 v (foreignLibFieldGrammar n) condTree
+ | (n, condTree) <- flibs
+ ]
ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Executable)] -> [PrettyField ()]
ppCondExecutables v exes =
- [ PrettySection () "executable" [pretty n]
- $ ppCondTree2 v (executableFieldGrammar n) condTree
- | (n, condTree) <- exes
- ]
+ [ PrettySection () "executable" [pretty n] $
+ ppCondTree2 v (executableFieldGrammar n) condTree
+ | (n, condTree) <- exes
+ ]
ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] TestSuite)] -> [PrettyField ()]
ppCondTestSuites v suites =
- [ PrettySection () "test-suite" [pretty n]
- $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)
- | (n, condTree) <- suites
- ]
+ [ PrettySection () "test-suite" [pretty n] $
+ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree)
+ | (n, condTree) <- suites
+ ]
ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] Benchmark)] -> [PrettyField ()]
ppCondBenchmarks v suites =
- [ PrettySection () "benchmark" [pretty n]
- $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)
- | (n, condTree) <- suites
- ]
+ [ PrettySection () "benchmark" [pretty n] $
+ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree)
+ | (n, condTree) <- suites
+ ]
ppCondition :: Condition ConfVar -> Doc
-ppCondition (Var x) = ppConfVar x
-ppCondition (Lit b) = text (show b)
-ppCondition (CNot c) = char '!' <<>> (ppCondition c)
-ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||"
- <+> ppCondition c2])
-ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&"
- <+> ppCondition c2])
+ppCondition (Var x) = ppConfVar x
+ppCondition (Lit b) = text (show b)
+ppCondition (CNot c) = char '!' <<>> (ppCondition c)
+ppCondition (COr c1 c2) =
+ parens
+ ( hsep
+ [ ppCondition c1
+ , text "||"
+ <+> ppCondition c2
+ ]
+ )
+ppCondition (CAnd c1 c2) =
+ parens
+ ( hsep
+ [ ppCondition c1
+ , text "&&"
+ <+> ppCondition c2
+ ]
+ )
ppConfVar :: ConfVar -> Doc
-ppConfVar (OS os) = text "os" <<>> parens (pretty os)
-ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch)
+ppConfVar (OS os) = text "os" <<>> parens (pretty os)
+ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch)
ppConfVar (PackageFlag name) = text "flag" <<>> parens (ppFlagName name)
-ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v)
+ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v)
ppFlagName :: FlagName -> Doc
-ppFlagName = text . unFlagName
+ppFlagName = text . unFlagName
ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField ()
ppIfCondition c = PrettySection () "if" [ppCondition c]
@@ -191,7 +218,7 @@ ppIfCondition c = PrettySection () "if" [ppCondition c]
writePackageDescription :: FilePath -> PackageDescription -> IO ()
writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
---TODO: make this use section syntax
+-- TODO: make this use section syntax
-- add equivalent for GenericPackageDescription
-- | @since 2.0.0.2
@@ -199,26 +226,28 @@ showPackageDescription :: PackageDescription -> String
showPackageDescription = showGenericPackageDescription . pdToGpd
pdToGpd :: PackageDescription -> GenericPackageDescription
-pdToGpd pd = GenericPackageDescription
+pdToGpd pd =
+ GenericPackageDescription
{ packageDescription = pd
- , gpdScannedVersion = Nothing
- , genPackageFlags = []
- , condLibrary = mkCondTree <$> library pd
- , condSubLibraries = mkCondTreeL <$> subLibraries pd
- , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd
- , condExecutables = mkCondTree' exeName <$> executables pd
- , condTestSuites = mkCondTree' testName <$> testSuites pd
- , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd
+ , gpdScannedVersion = Nothing
+ , genPackageFlags = []
+ , condLibrary = mkCondTree <$> library pd
+ , condSubLibraries = mkCondTreeL <$> subLibraries pd
+ , condForeignLibs = mkCondTree' foreignLibName <$> foreignLibs pd
+ , condExecutables = mkCondTree' exeName <$> executables pd
+ , condTestSuites = mkCondTree' testName <$> testSuites pd
+ , condBenchmarks = mkCondTree' benchmarkName <$> benchmarks pd
}
where
-- We set CondTree's [Dependency] to an empty list, as it
-- is not pretty printed anyway.
- mkCondTree x = CondNode x [] []
+ mkCondTree x = CondNode x [] []
mkCondTreeL l = (fromMaybe (mkUnqualComponentName "") (libraryNameString (libName l)), CondNode l [] [])
mkCondTree'
- :: (a -> UnqualComponentName)
- -> a -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
+ :: (a -> UnqualComponentName)
+ -> a
+ -> (UnqualComponentName, CondTree ConfVar [Dependency] a)
mkCondTree' f x = (f x, CondNode x [] [])
-------------------------------------------------------------------------------
@@ -229,12 +258,12 @@ pdToGpd pd = GenericPackageDescription
--
preProcessInternalDeps :: CabalSpecVersion -> GenericPackageDescription -> GenericPackageDescription
preProcessInternalDeps specVer gpd
- | specVer >= CabalSpecV3_4 = gpd
- | otherwise = transformAllBuildInfos transformBI transformSBI gpd
+ | specVer >= CabalSpecV3_4 = gpd
+ | otherwise = transformAllBuildInfos transformBI transformSBI gpd
where
transformBI :: BuildInfo -> BuildInfo
- transformBI
- = over L.targetBuildDepends (concatMap transformD)
+ transformBI =
+ over L.targetBuildDepends (concatMap transformD)
. over L.mixins (map transformM)
transformSBI :: SetupBuildInfo -> SetupBuildInfo
@@ -242,22 +271,21 @@ preProcessInternalDeps specVer gpd
transformD :: Dependency -> [Dependency]
transformD (Dependency pn vr ln)
- | pn == thisPn
- = if LMainLibName `NES.member` ln
- then Dependency thisPn vr mainLibSet : sublibs
- else sublibs
+ | pn == thisPn =
+ if LMainLibName `NES.member` ln
+ then Dependency thisPn vr mainLibSet : sublibs
+ else sublibs
where
sublibs =
- [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet
- | LSubLibName uqn <- NES.toList ln
- ]
-
+ [ Dependency (unqualComponentNameToPackageName uqn) vr mainLibSet
+ | LSubLibName uqn <- NES.toList ln
+ ]
transformD d = [d]
transformM :: Mixin -> Mixin
transformM (Mixin pn (LSubLibName uqn) inc)
- | pn == thisPn
- = mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc
+ | pn == thisPn =
+ mkMixin (unqualComponentNameToPackageName uqn) LMainLibName inc
transformM m = m
thisPn :: PackageName
@@ -269,14 +297,17 @@ preProcessInternalDeps specVer gpd
-- | @since 2.0.0.2
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
-writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
- . showHookedBuildInfo
+writeHookedBuildInfo fpath =
+ writeFileAtomic fpath
+ . BS.Char8.pack
+ . showHookedBuildInfo
-- | @since 2.0.0.2
showHookedBuildInfo :: HookedBuildInfo -> String
-showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const NoComment) $
- maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++
- [ PrettySection () "executable:" [pretty name]
- $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi
- | (name, bi) <- ex_bis
- ]
+showHookedBuildInfo (mb_lib_bi, ex_bis) =
+ showFields (const NoComment) $
+ maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi
+ ++ [ PrettySection () "executable:" [pretty name] $
+ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi
+ | (name, bi) <- ex_bis
+ ]
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs b/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs
index f2edfb3a387ebd8f93834f8de4ccfe130d9357f4..61b831354cdad315b61ae516baa142e238ac66b9 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/Quirks.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes #-}
+
-- |
--
-- @since 2.2.0.0
@@ -7,11 +8,11 @@ module Distribution.PackageDescription.Quirks (patchQuirks) where
import Distribution.Compat.Prelude
import Distribution.Utils.MD5
-import GHC.Fingerprint (Fingerprint (..))
+import GHC.Fingerprint (Fingerprint (..))
import Prelude ()
import qualified Data.ByteString as BS
-import qualified Data.Map as Map
+import qualified Data.Map as Map
-- | Patch legacy @.cabal@ file contents to allow parsec parser to accept
-- all of Hackage.
@@ -21,274 +22,330 @@ import qualified Data.Map as Map
-- @since 2.2.0.0
patchQuirks :: BS.ByteString -> (Bool, BS.ByteString)
patchQuirks bs = case Map.lookup (BS.take 256 bs, md5 bs) patches of
- Nothing -> (False, bs)
- Just (post, f)
- | post /= md5 output -> (False, bs)
- | otherwise -> (True, output)
- where
- output = f bs
+ Nothing -> (False, bs)
+ Just (post, f)
+ | post /= md5 output -> (False, bs)
+ | otherwise -> (True, output)
+ where
+ output = f bs
-- | 'patches' contains first 256 bytes, pre- and post-fingerprints and a patch function.
patches :: Map.Map (BS.ByteString, Fingerprint) (Fingerprint, BS.ByteString -> BS.ByteString)
-patches = Map.fromList
+patches =
+ Map.fromList
-- http://hackage.haskell.org/package/unicode-transforms-0.3.3
-- other-modules: .
-- ReadP assumed dot is empty line
- [ mk "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic"
- (Fingerprint 15958160436627155571 10318709190730872881)
- (Fingerprint 11008465475756725834 13815629925116264363)
- (bsRemove " other-modules:\n .\n") -- TODO: remove trailing \n to test structural-diff
- -- http://hackage.haskell.org/package/DSTM-0.1.2
- -- http://hackage.haskell.org/package/DSTM-0.1.1
- -- http://hackage.haskell.org/package/DSTM-0.1
- -- Other Modules: no dash
- -- ReadP parsed as section
- , mk "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed "
- (Fingerprint 6919263071548559054 9050746360708965827)
- (Fingerprint 17015177514298962556 11943164891661867280)
- (bsReplace "Other modules:" "-- ")
- , mk "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed "
- (Fingerprint 17313105789069667153 9610429408495338584)
- (Fingerprint 17250946493484671738 17629939328766863497)
- (bsReplace "Other modules:" "-- ")
- , mk "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy"
- (Fingerprint 10502599650530614586 16424112934471063115)
- (Fingerprint 13562014713536696107 17899511905611879358)
- (bsReplace "Other modules:" "-- ")
- -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3
- , mk "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f"
- (Fingerprint 18274748422558568404 4043538769550834851)
- (Fingerprint 11395257416101232635 4303318131190196308)
- (bsReplace " default- extensions:" "unknown-section")
- -- http://hackage.haskell.org/package/vacuum-opengl-0.0
- -- \DEL character
- , mk "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n "
- (Fingerprint 5946760521961682577 16933361639326309422)
- (Fingerprint 14034745101467101555 14024175957788447824)
- (bsRemove "\DEL")
- , mk "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n "
- (Fingerprint 10790950110330119503 1309560249972452700)
- (Fingerprint 1565743557025952928 13645502325715033593)
- (bsRemove "\DEL")
- -- http://hackage.haskell.org/package/ixset-1.0.4
- -- {- comments -}
- , mk "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut"
- (Fingerprint 11886092342440414185 4150518943472101551)
- (Fingerprint 5731367240051983879 17473925006273577821)
- (bsRemoveStarting "{-")
- -- : after section
- -- http://hackage.haskell.org/package/ds-kanren
- , mk "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the <http://minikanren.org miniKanren> language.\n .\n == What's in ds-kanren?\n .\n ['dis"
- (Fingerprint 2804006762382336875 9677726932108735838)
- (Fingerprint 9830506174094917897 12812107316777006473)
- (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"")
- , mk "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the <http://minikanren.org miniKanren> language.\n\nlicense: MIT\nlicense-file: "
- (Fingerprint 9130259649220396193 2155671144384738932)
- (Fingerprint 1847988234352024240 4597789823227580457)
- (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"")
- , mk "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:"
- (Fingerprint 6150019278861565482 3066802658031228162)
- (Fingerprint 9124826020564520548 15629704249829132420)
- (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"")
- , mk "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:"
- (Fingerprint 4639805967994715694 7859317050376284551)
- (Fingerprint 5566222290622325231 873197212916959151)
- (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"")
- , mk "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel <illissius@gmail.com>\nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: "
- (Fingerprint 10546509771395401582 245508422312751943)
- (Fingerprint 5169853482576003304 7247091607933993833)
- (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section")
- , mk "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: "
- (Fingerprint 7803544783533485151 10807347873998191750)
- (Fingerprint 1665635316718752601 16212378357991151549)
- (bsReplace "build depends:" "--")
- , mk "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program"
- (Fingerprint 4403237110790078829 15392625961066653722)
- (Fingerprint 10218887328390239431 4644205837817510221)
- (bsReplace "other modules:" "--")
- -- &&!
- -- http://hackage.haskell.org/package/hblas-0.3.0.0
- , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- "
- (Fingerprint 8570120150072467041 18315524331351505945)
- (Fingerprint 10838007242302656005 16026440017674974175)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- "
- (Fingerprint 5262875856214215155 10846626274067555320)
- (Fingerprint 3022954285783401045 13395975869915955260)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- "
- (Fingerprint 54222628930951453 5526514916844166577)
- (Fingerprint 1749630806887010665 8607076506606977549)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
- (Fingerprint 6817250511240350300 15278852712000783849)
- (Fingerprint 15757717081429529536 15542551865099640223)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
- (Fingerprint 8310050400349211976 201317952074418615)
- (Fingerprint 10283381191257209624 4231947623042413334)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
- (Fingerprint 7010988292906098371 11591884496857936132)
- (Fingerprint 6158672440010710301 6419743768695725095)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)"
- (Fingerprint 2076850805659055833 16615160726215879467)
- (Fingerprint 10634706281258477722 5285812379517916984)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)"
- (Fingerprint 11850020631622781099 11956481969231030830)
- (Fingerprint 13702868780337762025 13383526367149067158)
- (bsReplace "&&!" "&& !")
- , mk "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
- (Fingerprint 13690322768477779172 19704059263540994)
- (Fingerprint 11189374824645442376 8363528115442591078)
- (bsReplace "&&!" "&& !")
- -- flag used, but not defined
- , mk "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi"
- (Fingerprint 6910727116443152200 15401634478524888973)
- (Fingerprint 16551412117098094368 16260377389127603629)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: "
- (Fingerprint 14320987921316832277 10031098243571536929)
- (Fingerprint 7959395602414037224 13279941216182213050)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: "
- (Fingerprint 3809078390223299128 10796026010775813741)
- (Fingerprint 1127231189459220796 12088367524333209349)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: "
- (Fingerprint 13860013038089410950 12479824176801390651)
- (Fingerprint 4687484721703340391 8013395164515771785)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"
- (Fingerprint 16215911397419608203 15594928482155652475)
- (Fingerprint 15120681510314491047 2666192399775157359)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te"
- (Fingerprint 16593139224723441188 4052919014346212001)
- (Fingerprint 3577381082410411593 11481899387780544641)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"
- (Fingerprint 9321301260802539374 1316392715016096607)
- (Fingerprint 3784628652257760949 12662640594755291035)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te"
- (Fingerprint 2546901804824433337 2059732715322561176)
- (Fingerprint 8082068680348326500 615008613291421947)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"
- (Fingerprint 2282380737467965407 12457554753171662424)
- (Fingerprint 17324757216926991616 17172911843227482125)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te"
- (Fingerprint 12907988890480595481 11078473638628359710)
- (Fingerprint 13246185333368731848 4663060731847518614)
- (bsReplace "flag(llvm-fast)" "False")
- , mk "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: "
- (Fingerprint 12386777729082870356 17414156731912743711)
- (Fingerprint 3452290353395041602 14102887112483033720)
- (bsReplace "flag(sse42)" "False")
- , mk "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen"
- (Fingerprint 6870520675313101180 14553457351296240636)
- (Fingerprint 12481021059537696455 14711088786769892762)
- (bsReplace "flag(sse42)" "False")
- -- leading zeros in version digits
- -- https://github.com/haskell-infra/hackage-trustees/issues/128
- -- https://github.com/haskell/cabal/issues/5092
- -- https://github.com/haskell/cabal/issues/5138
- , mk "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent"
- (Fingerprint 8458530898096910998 3228538743646501413)
- (Fingerprint 14470502514907936793 17514354054641875371)
- (bsReplace "0.2017.02.26" "0.2017.2.26")
- , mk "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel <andreas.abel@gu.se>\nmaintainer: Andreas Abel <andreas.abel@gu.se>\n"
- (Fingerprint 1450130849535097473 11742099607098860444)
- (Fingerprint 16679762943850814021 4253724355613883542)
- (bsReplace "0.2017.05.01" "0.2017.5.1")
- , mk "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel <andreas.abel@gu.se>\nmaintainer: Andreas Abel <andreas.abel@gu.se>\n"
- (Fingerprint 297248532398492441 17322625167861324800)
- (Fingerprint 634812045126693280 1755581866539318862)
- (bsReplace "0.2017.05.02" "0.2017.5.2")
- , mk "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: "
- (Fingerprint 3697869560530373941 3942982281026987312)
- (Fingerprint 14344526114710295386 16386400353475114712)
- (bsReplace "0.2017.5.02" "0.2017.5.2")
- , mk "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel <andreas.abel@i"
- (Fingerprint 17167128953451088679 4300350537748753465)
- (Fingerprint 12402236925293025673 7715084875284020606)
- (bsReplace "0.2017.02.18" "0.2017.2.18")
- , mk "cabal-version:\n 2.0\nname:\n fast-downward\nversion:\n 0.1.0.0\nbuild-type:\n Simple\nsynopsis:\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n @fast-downward@ is a library for modelling classical planning probl"
- (Fingerprint 11256076039027887363 6867903407496243216)
- (Fingerprint 12159816716813155434 5278015399212299853)
- (bsReplace "1.2.03.0" "1.2.3.0")
- , mk "cabal-version:\r\n 2.0\r\nname:\r\n fast-downward\r\nversion:\r\n 0.1.0.0\r\nx-revision: \r\n 1\r\nbuild-type:\r\n Simple\r\nsynopsis:\r\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\r\ndescription:\r\n @fast-downward@ is a library for mode"
- (Fingerprint 9216193973149680231 893446343655828508)
- (Fingerprint 10020169545407746427 1828336750379510675)
- (bsReplace "1.2.03.0" "1.2.3.0")
- , mk "cabal-version:\n 2.0\nname:\n fast-downward\nversion:\n 0.1.0.1\nbuild-type:\n Simple\nsynopsis:\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n @fast-downward@ is a library for modelling classical planning probl"
- (Fingerprint 9899886602574848632 5980433644983783334)
- (Fingerprint 12007469255857289958 8321466548645225439)
- (bsReplace "1.2.03.0" "1.2.3.0")
- , mk "cabal-version:\n 2.0\nname:\n fast-downward\nversion:\n 0.1.1.0\nbuild-type:\n Simple\nsynopsis:\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n @fast-downward@ is a library for modelling classical planning probl"
- (Fingerprint 12694656661460787751 1902242956706735615)
- (Fingerprint 15433152131513403849 2284712791516353264)
- (bsReplace "1.2.03.0" "1.2.3.0")
- -- 9 digits limit
- , mk "Name: SGplus\nVersion: 1.1\nSynopsis: (updated) Small geometry library for dealing with vectors and collision detection\nLicense: BSD3\nLicense-file: LICENSE\nAuthor: Neil Brown\nMaintainer: "
- (Fingerprint 17735649550442248029 11493772714725351354)
- (Fingerprint 9565458801063261772 15955773698774721052)
- (bsReplace "1000000000" "100000000")
- , mk "-- Initial control-dotdotdot.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\nname: control-dotdotdot\nversion: 0.1.0.1\nsynopsis: Haskell operator\n "
- (Fingerprint 1514257173776509942 7756050823377346485)
- (Fingerprint 14082092642045505999 18415918653404121035)
- (bsReplace "9223372036854775807" "5")
- , mk "name: data-foldapp\r\nversion: 0.1.1.0\r\nsynopsis: Fold function applications. Framework for variadic functions.\r\ndescription: Fold function applications. Framework for variadic functions.\r\nhomepage: ht"
- (Fingerprint 4511234156311243251 11701153011544112556)
- (Fingerprint 11820542702491924189 4902231447612406724)
- (bsReplace "9223372036854775807" "999" . bsReplace "9223372036854775807" "999")
- , mk "-- Initial data-list-zigzag.cabal generated by cabal init. For further \r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\nname: data-list-zigzag\r\nversion: 0.1.1.1\r\nsynopsis: A list but with a balanced en"
- (Fingerprint 12475837388692175691 18053834261188158945)
- (Fingerprint 16279938253437334942 15753349540193002309)
- (bsReplace "9223372036854775807" "999")
- -- Not UTF8
- , mk "Name: nat\nVersion: 0.1\nDescription: Implementation of natural numbers and integers by a binary\n representation. The implementation is supposed to be lazy and\n "
- (Fingerprint 9222512268705577108 13085311382746579495)
- (Fingerprint 17468921266614378430 13221316288008291892)
- (bsReplace "\xf6" "\xc3\xb6")
- -- cabal-version: 2
- , mk "name: streaming-bracketed\nversion: 0.1.0.0\nsynopsis: A resource management decorator for \"streaming\". \ndescription: This package provides a decorator for the Stream type from\n the \"st"
- (Fingerprint 14670044663153191927 1427497586294143829)
- (Fingerprint 9233007756654759985 6571998449003682006)
- (bsReplace "cabal-version: 2" "cabal-version: 2.0")
- , mk "name: streaming-bracketed\nversion: 0.1.0.1\nsynopsis: A resource management decorator for \"streaming\". \ndescription: This package provides a decorator for the Stream type from\n \"stream"
- (Fingerprint 7298738862909203815 10141693276062967842)
- (Fingerprint 1349949738792220441 3593683359695349293)
- (bsReplace "cabal-version: 2" "cabal-version: 2.0")
- , mk "name: zsyntax\nversion: 0.2.0.0\ndescription: An automated theorem prover for Zsyntax, a\n logical calculus for molecular biology inspired by linear logic,\n that can be used to automatically verify biological\n"
- (Fingerprint 17812331267506881875 3005293725141563863)
- (Fingerprint 3445957263137759540 12472369104312474458)
- (bsReplace "cabal-version: 2" "cabal-version: 2.0")
-
- -- Empty filepath in not license-file or data-dir
- -- These have hs-source-dirs: ""
- , mk "\nname: wai-middleware-hmac-client\nversion: 0.1.0.1\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Christopher Reichert\nmaintainer: creichert07@gmail.com\ncopyright: (c) 2015, Christo"
- (Fingerprint 3112606538775065787 11984607507024462091)
- (Fingerprint 6916432989977230500 6621389616675138128)
- (bsReplace "\"\"" ".")
- , mk "\nname: wai-middleware-hmac-client\nversion: 0.1.0.2\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Christopher Reichert\nmaintainer: creichert07@gmail.com\ncopyright: (c) 2015, Christo"
- (Fingerprint 12566783342663020458 17562089389615949789)
- (Fingerprint 15745683452603944938 10556498036622072844)
- (bsReplace "\"\"" ".")
-
- -- absolute license-file
- , mk "name: reheat\nversion: 0.1.4\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner <palipalo9@gmail.com>\nstability: experimental\nhomepage: h"
- (Fingerprint 9155400339287317061 14812953666990892802)
- (Fingerprint 7687053346032173923 15384472501136606592)
- (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "")
- , mk "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner <palipalo9@gmail.com>\nstability: experimental\nhomepage: h"
- (Fingerprint 2984391146441073709 11728234882049907993)
- (Fingerprint 12058479081855347701 14017937756688869826)
- (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "")
+ [ mk
+ "-- This file has been generated from package.yaml by hpack version 0.17.0.\n--\n-- see: https://github.com/sol/hpack\n\nname: unicode-transforms\nversion: 0.3.3\nsynopsis: Unicode normalization\ndescription: Fast Unic"
+ (Fingerprint 15958160436627155571 10318709190730872881)
+ (Fingerprint 11008465475756725834 13815629925116264363)
+ (bsRemove " other-modules:\n .\n") -- TODO: remove trailing \n to test structural-diff
+ -- http://hackage.haskell.org/package/DSTM-0.1.2
+ -- http://hackage.haskell.org/package/DSTM-0.1.1
+ -- http://hackage.haskell.org/package/DSTM-0.1
+ -- Other Modules: no dash
+ -- ReadP parsed as section
+ , mk
+ "Name: DSTM\nVersion: 0.1.2\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed "
+ (Fingerprint 6919263071548559054 9050746360708965827)
+ (Fingerprint 17015177514298962556 11943164891661867280)
+ (bsReplace "Other modules:" "-- ")
+ , mk
+ "Name: DSTM\nVersion: 0.1.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed "
+ (Fingerprint 17313105789069667153 9610429408495338584)
+ (Fingerprint 17250946493484671738 17629939328766863497)
+ (bsReplace "Other modules:" "-- ")
+ , mk
+ "Name: DSTM\nVersion: 0.1\nCopyright: (c) 2010, Frank Kupke\nLicense: LGPL\nLicense-File: LICENSE\nAuthor: Frank Kupke\nMaintainer: frk@informatik.uni-kiel.de\nCabal-Version: >= 1.2.3\nStability: provisional\nSynopsis: A framework for using STM within distributed sy"
+ (Fingerprint 10502599650530614586 16424112934471063115)
+ (Fingerprint 13562014713536696107 17899511905611879358)
+ (bsReplace "Other modules:" "-- ")
+ , -- http://hackage.haskell.org/package/control-monad-exception-mtl-0.10.3
+ mk
+ "name: control-monad-exception-mtl\nversion: 0.10.3\nCabal-Version: >= 1.10\nbuild-type: Simple\nlicense: PublicDomain\nauthor: Pepe Iborra\nmaintainer: pepeiborra@gmail.com\nhomepage: http://pepeiborra.github.com/control-monad-exception\nsynopsis: MTL instances f"
+ (Fingerprint 18274748422558568404 4043538769550834851)
+ (Fingerprint 11395257416101232635 4303318131190196308)
+ (bsReplace " default- extensions:" "unknown-section")
+ , -- http://hackage.haskell.org/package/vacuum-opengl-0.0
+ -- \DEL character
+ mk
+ "Name: vacuum-opengl\nVersion: 0.0\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n "
+ (Fingerprint 5946760521961682577 16933361639326309422)
+ (Fingerprint 14034745101467101555 14024175957788447824)
+ (bsRemove "\DEL")
+ , mk
+ "Name: vacuum-opengl\nVersion: 0.0.1\nSynopsis: Visualize live Haskell data structures using vacuum, graphviz and OpenGL.\nDescription: \DELVisualize live Haskell data structures using vacuum, graphviz and OpenGL.\n "
+ (Fingerprint 10790950110330119503 1309560249972452700)
+ (Fingerprint 1565743557025952928 13645502325715033593)
+ (bsRemove "\DEL")
+ , -- http://hackage.haskell.org/package/ixset-1.0.4
+ -- {- comments -}
+ mk
+ "Name: ixset\nVersion: 1.0.4\nSynopsis: Efficient relational queries on Haskell sets.\nDescription:\n Create and query sets that are indexed by multiple indices.\nLicense: BSD3\nLicense-file: COPYING\nAut"
+ (Fingerprint 11886092342440414185 4150518943472101551)
+ (Fingerprint 5731367240051983879 17473925006273577821)
+ (bsRemoveStarting "{-")
+ , -- : after section
+ -- http://hackage.haskell.org/package/ds-kanren
+ mk
+ "name: ds-kanren\nversion: 0.2.0.0\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the <http://minikanren.org miniKanren> language.\n .\n == What's in ds-kanren?\n .\n ['dis"
+ (Fingerprint 2804006762382336875 9677726932108735838)
+ (Fingerprint 9830506174094917897 12812107316777006473)
+ (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"")
+ , mk
+ "name: ds-kanren\nversion: 0.2.0.1\nsynopsis: A subset of the miniKanren language\ndescription:\n ds-kanren is an implementation of the <http://minikanren.org miniKanren> language.\n\nlicense: MIT\nlicense-file: "
+ (Fingerprint 9130259649220396193 2155671144384738932)
+ (Fingerprint 1847988234352024240 4597789823227580457)
+ (bsReplace "Test-Suite test-unify:" "Test-Suite \"test-unify:\"" . bsReplace "Test-Suite test-list-ops:" "Test-Suite \"test-list-ops:\"")
+ , mk
+ "name: metric\nversion: 0.1.4\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:"
+ (Fingerprint 6150019278861565482 3066802658031228162)
+ (Fingerprint 9124826020564520548 15629704249829132420)
+ (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"")
+ , mk
+ "name: metric\nversion: 0.2.0\nsynopsis: Metric spaces.\nlicense: MIT\nlicense-file: LICENSE\nauthor: Vikram Verma\nmaintainer: me@vikramverma.com\ncategory: Data\nbuild-type:"
+ (Fingerprint 4639805967994715694 7859317050376284551)
+ (Fingerprint 5566222290622325231 873197212916959151)
+ (bsReplace "test-suite metric-tests:" "test-suite \"metric-tests:\"")
+ , mk
+ "name: phasechange\ncategory: Data\nversion: 0.1\nauthor: G\195\161bor Lehel\nmaintainer: G\195\161bor Lehel <illissius@gmail.com>\nhomepage: http://github.com/glehel/phasechange\ncopyright: Copyright (C) 2012 G\195\161bor Lehel\nlicense: "
+ (Fingerprint 10546509771395401582 245508422312751943)
+ (Fingerprint 5169853482576003304 7247091607933993833)
+ (bsReplace "impl(ghc >= 7.4):" "erroneous-section" . bsReplace "impl(ghc >= 7.6):" "erroneous-section")
+ , mk
+ "Name: smartword\nSynopsis: Web based flash card for Word Smart I and II vocabularies\nVersion: 0.0.0.5\nHomepage: http://kyagrd.dyndns.org/~kyagrd/project/smartword/\nCategory: Web,Education\nLicense: "
+ (Fingerprint 7803544783533485151 10807347873998191750)
+ (Fingerprint 1665635316718752601 16212378357991151549)
+ (bsReplace "build depends:" "--")
+ , mk
+ "name: shelltestrunner\n-- sync with README.md, ANNOUNCE:\nversion: 1.3\ncategory: Testing\nsynopsis: A tool for testing command-line programs.\ndescription:\n shelltestrunner is a cross-platform tool for testing command-line\n program"
+ (Fingerprint 4403237110790078829 15392625961066653722)
+ (Fingerprint 10218887328390239431 4644205837817510221)
+ (bsReplace "other modules:" "--")
+ , -- &&!
+ -- http://hackage.haskell.org/package/hblas-0.3.0.0
+ mk
+ "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- "
+ (Fingerprint 8570120150072467041 18315524331351505945)
+ (Fingerprint 10838007242302656005 16026440017674974175)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- "
+ (Fingerprint 5262875856214215155 10846626274067555320)
+ (Fingerprint 3022954285783401045 13395975869915955260)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP) \n-- "
+ (Fingerprint 54222628930951453 5526514916844166577)
+ (Fingerprint 1749630806887010665 8607076506606977549)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
+ (Fingerprint 6817250511240350300 15278852712000783849)
+ (Fingerprint 15757717081429529536 15542551865099640223)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
+ (Fingerprint 8310050400349211976 201317952074418615)
+ (Fingerprint 10283381191257209624 4231947623042413334)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
+ (Fingerprint 7010988292906098371 11591884496857936132)
+ (Fingerprint 6158672440010710301 6419743768695725095)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)"
+ (Fingerprint 2076850805659055833 16615160726215879467)
+ (Fingerprint 10634706281258477722 5285812379517916984)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further\r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\n-- The name of the package.\r\nname: hblas\r\n\r\n-- The package version. See the Haskell package versioning policy (PVP)"
+ (Fingerprint 11850020631622781099 11956481969231030830)
+ (Fingerprint 13702868780337762025 13383526367149067158)
+ (bsReplace "&&!" "&& !")
+ , mk
+ "-- Initial hblas.cabal generated by cabal init. For further\n-- documentation, see http://haskell.org/cabal/users-guide/\n\n-- The name of the package.\nname: hblas\n\n-- The package version. See the Haskell package versioning policy (PVP)\n-- fo"
+ (Fingerprint 13690322768477779172 19704059263540994)
+ (Fingerprint 11189374824645442376 8363528115442591078)
+ (bsReplace "&&!" "&& !")
+ , -- flag used, but not defined
+ mk
+ "name: brainheck\nversion: 0.1.0.2\nsynopsis: Brainh*ck interpreter in haskell\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\nhomepage: https://gi"
+ (Fingerprint 6910727116443152200 15401634478524888973)
+ (Fingerprint 16551412117098094368 16260377389127603629)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: "
+ (Fingerprint 14320987921316832277 10031098243571536929)
+ (Fingerprint 7959395602414037224 13279941216182213050)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 2\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: "
+ (Fingerprint 3809078390223299128 10796026010775813741)
+ (Fingerprint 1127231189459220796 12088367524333209349)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: brainheck\r\nversion: 0.1.0.2\r\nx-revision: 3\r\nsynopsis: Brainh*ck interpreter in haskell\r\ndescription: Brainh*ck interpreter written in haskell and taking advantage of many prominent libraries\r\nhomepage: "
+ (Fingerprint 13860013038089410950 12479824176801390651)
+ (Fingerprint 4687484721703340391 8013395164515771785)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: wordchoice\nversion: 0.1.0.1\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"
+ (Fingerprint 16215911397419608203 15594928482155652475)
+ (Fingerprint 15120681510314491047 2666192399775157359)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: wordchoice\r\nversion: 0.1.0.1\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te"
+ (Fingerprint 16593139224723441188 4052919014346212001)
+ (Fingerprint 3577381082410411593 11481899387780544641)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: wordchoice\nversion: 0.1.0.2\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"
+ (Fingerprint 9321301260802539374 1316392715016096607)
+ (Fingerprint 3784628652257760949 12662640594755291035)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: wordchoice\r\nversion: 0.1.0.2\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te"
+ (Fingerprint 2546901804824433337 2059732715322561176)
+ (Fingerprint 8082068680348326500 615008613291421947)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: wordchoice\nversion: 0.1.0.3\nsynopsis: Get word counts and distributions\ndescription: A command line tool to compute the word distribution from various types of document, converting to text with pandoc.\nho"
+ (Fingerprint 2282380737467965407 12457554753171662424)
+ (Fingerprint 17324757216926991616 17172911843227482125)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: wordchoice\r\nversion: 0.1.0.3\r\nx-revision: 1\r\nsynopsis: Get word counts and distributions\r\ndescription: A command line tool to compute the word distribution from various types of document, converting to te"
+ (Fingerprint 12907988890480595481 11078473638628359710)
+ (Fingerprint 13246185333368731848 4663060731847518614)
+ (bsReplace "flag(llvm-fast)" "False")
+ , mk
+ "name: hw-prim-bits\nversion: 0.1.0.0\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicense: "
+ (Fingerprint 12386777729082870356 17414156731912743711)
+ (Fingerprint 3452290353395041602 14102887112483033720)
+ (bsReplace "flag(sse42)" "False")
+ , mk
+ "name: hw-prim-bits\nversion: 0.1.0.1\nsynopsis: Primitive support for bit manipulation\ndescription: Please see README.md\nhomepage: https://github.com/githubuser/hw-prim-bits#readme\nlicen"
+ (Fingerprint 6870520675313101180 14553457351296240636)
+ (Fingerprint 12481021059537696455 14711088786769892762)
+ (bsReplace "flag(sse42)" "False")
+ , -- leading zeros in version digits
+ -- https://github.com/haskell-infra/hackage-trustees/issues/128
+ -- https://github.com/haskell/cabal/issues/5092
+ -- https://github.com/haskell/cabal/issues/5138
+ mk
+ "name: Sit\nversion: 0.2017.02.26\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Anonymous\nmaintainer: Anonymous\nhomepage: NONE\ncategory: Dependent"
+ (Fingerprint 8458530898096910998 3228538743646501413)
+ (Fingerprint 14470502514907936793 17514354054641875371)
+ (bsReplace "0.2017.02.26" "0.2017.2.26")
+ , mk
+ "name: Sit\nversion: 0.2017.05.01\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel <andreas.abel@gu.se>\nmaintainer: Andreas Abel <andreas.abel@gu.se>\n"
+ (Fingerprint 1450130849535097473 11742099607098860444)
+ (Fingerprint 16679762943850814021 4253724355613883542)
+ (bsReplace "0.2017.05.01" "0.2017.5.1")
+ , mk
+ "name: Sit\nversion: 0.2017.05.02\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel <andreas.abel@gu.se>\nmaintainer: Andreas Abel <andreas.abel@gu.se>\n"
+ (Fingerprint 297248532398492441 17322625167861324800)
+ (Fingerprint 634812045126693280 1755581866539318862)
+ (bsReplace "0.2017.05.02" "0.2017.5.2")
+ , mk
+ "name: Sit\nversion: 0.2017.5.02\nx-revision: 1\n-- x-revision:1 see https://github.com/haskell-infra/hackage-trustees/issues/128\nbuild-type: Simple\ncabal-version: >= 1.8\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: "
+ (Fingerprint 3697869560530373941 3942982281026987312)
+ (Fingerprint 14344526114710295386 16386400353475114712)
+ (bsReplace "0.2017.5.02" "0.2017.5.2")
+ , mk
+ "name: MiniAgda\nversion: 0.2017.02.18\nbuild-type: Simple\ncabal-version: >= 1.22\nlicense: OtherLicense\nlicense-file: LICENSE\nauthor: Andreas Abel and Karl Mehltretter\nmaintainer: Andreas Abel <andreas.abel@i"
+ (Fingerprint 17167128953451088679 4300350537748753465)
+ (Fingerprint 12402236925293025673 7715084875284020606)
+ (bsReplace "0.2017.02.18" "0.2017.2.18")
+ , mk
+ "cabal-version:\n 2.0\nname:\n fast-downward\nversion:\n 0.1.0.0\nbuild-type:\n Simple\nsynopsis:\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n @fast-downward@ is a library for modelling classical planning probl"
+ (Fingerprint 11256076039027887363 6867903407496243216)
+ (Fingerprint 12159816716813155434 5278015399212299853)
+ (bsReplace "1.2.03.0" "1.2.3.0")
+ , mk
+ "cabal-version:\r\n 2.0\r\nname:\r\n fast-downward\r\nversion:\r\n 0.1.0.0\r\nx-revision: \r\n 1\r\nbuild-type:\r\n Simple\r\nsynopsis:\r\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\r\ndescription:\r\n @fast-downward@ is a library for mode"
+ (Fingerprint 9216193973149680231 893446343655828508)
+ (Fingerprint 10020169545407746427 1828336750379510675)
+ (bsReplace "1.2.03.0" "1.2.3.0")
+ , mk
+ "cabal-version:\n 2.0\nname:\n fast-downward\nversion:\n 0.1.0.1\nbuild-type:\n Simple\nsynopsis:\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n @fast-downward@ is a library for modelling classical planning probl"
+ (Fingerprint 9899886602574848632 5980433644983783334)
+ (Fingerprint 12007469255857289958 8321466548645225439)
+ (bsReplace "1.2.03.0" "1.2.3.0")
+ , mk
+ "cabal-version:\n 2.0\nname:\n fast-downward\nversion:\n 0.1.1.0\nbuild-type:\n Simple\nsynopsis:\n Solve classical planning problems (STRIPS/SAS+) using Haskell & Fast Downward.\ndescription:\n @fast-downward@ is a library for modelling classical planning probl"
+ (Fingerprint 12694656661460787751 1902242956706735615)
+ (Fingerprint 15433152131513403849 2284712791516353264)
+ (bsReplace "1.2.03.0" "1.2.3.0")
+ , -- 9 digits limit
+ mk
+ "Name: SGplus\nVersion: 1.1\nSynopsis: (updated) Small geometry library for dealing with vectors and collision detection\nLicense: BSD3\nLicense-file: LICENSE\nAuthor: Neil Brown\nMaintainer: "
+ (Fingerprint 17735649550442248029 11493772714725351354)
+ (Fingerprint 9565458801063261772 15955773698774721052)
+ (bsReplace "1000000000" "100000000")
+ , mk
+ "-- Initial control-dotdotdot.cabal generated by cabal init. For further \n-- documentation, see http://haskell.org/cabal/users-guide/\n\nname: control-dotdotdot\nversion: 0.1.0.1\nsynopsis: Haskell operator\n "
+ (Fingerprint 1514257173776509942 7756050823377346485)
+ (Fingerprint 14082092642045505999 18415918653404121035)
+ (bsReplace "9223372036854775807" "5")
+ , mk
+ "name: data-foldapp\r\nversion: 0.1.1.0\r\nsynopsis: Fold function applications. Framework for variadic functions.\r\ndescription: Fold function applications. Framework for variadic functions.\r\nhomepage: ht"
+ (Fingerprint 4511234156311243251 11701153011544112556)
+ (Fingerprint 11820542702491924189 4902231447612406724)
+ (bsReplace "9223372036854775807" "999" . bsReplace "9223372036854775807" "999")
+ , mk
+ "-- Initial data-list-zigzag.cabal generated by cabal init. For further \r\n-- documentation, see http://haskell.org/cabal/users-guide/\r\n\r\nname: data-list-zigzag\r\nversion: 0.1.1.1\r\nsynopsis: A list but with a balanced en"
+ (Fingerprint 12475837388692175691 18053834261188158945)
+ (Fingerprint 16279938253437334942 15753349540193002309)
+ (bsReplace "9223372036854775807" "999")
+ , -- Not UTF8
+ mk
+ "Name: nat\nVersion: 0.1\nDescription: Implementation of natural numbers and integers by a binary\n representation. The implementation is supposed to be lazy and\n "
+ (Fingerprint 9222512268705577108 13085311382746579495)
+ (Fingerprint 17468921266614378430 13221316288008291892)
+ (bsReplace "\xf6" "\xc3\xb6")
+ , -- cabal-version: 2
+ mk
+ "name: streaming-bracketed\nversion: 0.1.0.0\nsynopsis: A resource management decorator for \"streaming\". \ndescription: This package provides a decorator for the Stream type from\n the \"st"
+ (Fingerprint 14670044663153191927 1427497586294143829)
+ (Fingerprint 9233007756654759985 6571998449003682006)
+ (bsReplace "cabal-version: 2" "cabal-version: 2.0")
+ , mk
+ "name: streaming-bracketed\nversion: 0.1.0.1\nsynopsis: A resource management decorator for \"streaming\". \ndescription: This package provides a decorator for the Stream type from\n \"stream"
+ (Fingerprint 7298738862909203815 10141693276062967842)
+ (Fingerprint 1349949738792220441 3593683359695349293)
+ (bsReplace "cabal-version: 2" "cabal-version: 2.0")
+ , mk
+ "name: zsyntax\nversion: 0.2.0.0\ndescription: An automated theorem prover for Zsyntax, a\n logical calculus for molecular biology inspired by linear logic,\n that can be used to automatically verify biological\n"
+ (Fingerprint 17812331267506881875 3005293725141563863)
+ (Fingerprint 3445957263137759540 12472369104312474458)
+ (bsReplace "cabal-version: 2" "cabal-version: 2.0")
+ , -- Empty filepath in not license-file or data-dir
+ -- These have hs-source-dirs: ""
+ mk
+ "\nname: wai-middleware-hmac-client\nversion: 0.1.0.1\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Christopher Reichert\nmaintainer: creichert07@gmail.com\ncopyright: (c) 2015, Christo"
+ (Fingerprint 3112606538775065787 11984607507024462091)
+ (Fingerprint 6916432989977230500 6621389616675138128)
+ (bsReplace "\"\"" ".")
+ , mk
+ "\nname: wai-middleware-hmac-client\nversion: 0.1.0.2\nlicense: BSD3\nlicense-file: LICENSE\nauthor: Christopher Reichert\nmaintainer: creichert07@gmail.com\ncopyright: (c) 2015, Christo"
+ (Fingerprint 12566783342663020458 17562089389615949789)
+ (Fingerprint 15745683452603944938 10556498036622072844)
+ (bsReplace "\"\"" ".")
+ , -- absolute license-file
+ mk
+ "name: reheat\nversion: 0.1.4\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner <palipalo9@gmail.com>\nstability: experimental\nhomepage: h"
+ (Fingerprint 9155400339287317061 14812953666990892802)
+ (Fingerprint 7687053346032173923 15384472501136606592)
+ (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "")
+ , mk
+ "name: reheat\nversion: 0.1.5\ncabal-version: >=1.8\nbuild-type: Simple\nlicense: GPL\nlicense-file: /home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt\ncopyright: GPL\nmaintainer: Ingolf Wagner <palipalo9@gmail.com>\nstability: experimental\nhomepage: h"
+ (Fingerprint 2984391146441073709 11728234882049907993)
+ (Fingerprint 12058479081855347701 14017937756688869826)
+ (bsReplace "/home/palo/dev/haskell-workspace/playground/reheat/gpl-3.0.txt" "")
]
where
mk a b c d = ((a, b), (c, d))
@@ -296,45 +353,52 @@ patches = Map.fromList
-- | Helper to create entries in patches
_makePatchKey :: FilePath -> (BS.ByteString -> BS.ByteString) -> IO ()
_makePatchKey fp transform = do
- contents <- BS.readFile fp
- let output = transform contents
- let Fingerprint hi lo = md5 contents
- let Fingerprint hi' lo' = md5 output
- putStrLn
- $ showString " , mk "
- . shows (BS.take 256 contents)
- . showString "\n (Fingerprint "
- . shows hi
- . showString " "
- . shows lo
- . showString ")\n (Fingerprint "
- . shows hi'
- . showString " "
- . shows lo'
- . showString ")"
- $ ""
+ contents <- BS.readFile fp
+ let output = transform contents
+ let Fingerprint hi lo = md5 contents
+ let Fingerprint hi' lo' = md5 output
+ putStrLn
+ $ showString " , mk "
+ . shows (BS.take 256 contents)
+ . showString "\n (Fingerprint "
+ . shows hi
+ . showString " "
+ . shows lo
+ . showString ")\n (Fingerprint "
+ . shows hi'
+ . showString " "
+ . shows lo'
+ . showString ")"
+ $ ""
-------------------------------------------------------------------------------
-- Patch helpers
-------------------------------------------------------------------------------
bsRemove
- :: BS.ByteString -- ^ needle
- -> BS.ByteString -> BS.ByteString
+ :: BS.ByteString
+ -- ^ needle
+ -> BS.ByteString
+ -> BS.ByteString
bsRemove needle haystack = case BS.breakSubstring needle haystack of
- (h, t) -> BS.append h (BS.drop (BS.length needle) t)
+ (h, t) -> BS.append h (BS.drop (BS.length needle) t)
bsReplace
- :: BS.ByteString -- ^ needle
- -> BS.ByteString -- ^ replacement
- -> BS.ByteString -> BS.ByteString
+ :: BS.ByteString
+ -- ^ needle
+ -> BS.ByteString
+ -- ^ replacement
+ -> BS.ByteString
+ -> BS.ByteString
bsReplace needle repl haystack = case BS.breakSubstring needle haystack of
- (h, t)
- | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t))
- | otherwise -> haystack
+ (h, t)
+ | not (BS.null t) -> BS.append h (BS.append repl (BS.drop (BS.length needle) t))
+ | otherwise -> haystack
bsRemoveStarting
- :: BS.ByteString -- ^ needle
- -> BS.ByteString -> BS.ByteString
+ :: BS.ByteString
+ -- ^ needle
+ -> BS.ByteString
+ -> BS.ByteString
bsRemoveStarting needle haystack = case BS.breakSubstring needle haystack of
- (h, _) -> h
+ (h, _) -> h
diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs b/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs
index d814c87e422fe20bdae28361f74fe52ed9a85166..27b993c9b615ea4870155edf0051635519ed5c1f 100644
--- a/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs
+++ b/Cabal-syntax/src/Distribution/PackageDescription/Utils.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.PackageDescription.Utils
--
@@ -6,9 +7,9 @@
-- Portability : portable
--
-- Common utils used by modules under Distribution.PackageDescription.*.
-
-module Distribution.PackageDescription.Utils (
- cabalBug, userBug
+module Distribution.PackageDescription.Utils
+ ( cabalBug
+ , userBug
) where
-- ----------------------------------------------------------------------------
@@ -18,6 +19,9 @@ userBug :: String -> a
userBug msg = error $ msg ++ ". This is a bug in your .cabal file."
cabalBug :: String -> a
-cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"
- ++ "Please report it to the developers: "
- ++ "https://github.com/haskell/cabal/issues/new"
+cabalBug msg =
+ error $
+ msg
+ ++ ". This is possibly a bug in Cabal.\n"
+ ++ "Please report it to the developers: "
+ ++ "https://github.com/haskell/cabal/issues/new"
diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs
index 0df02ffa0554f96f83ee93f9caaed3559583b099..4c6e31e5aaa5f5eeed6ac7930646858c7f69e5be 100644
--- a/Cabal-syntax/src/Distribution/Parsec.hs
+++ b/Cabal-syntax/src/Distribution/Parsec.hs
@@ -1,69 +1,75 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Parsec (
- Parsec(..),
- ParsecParser (..),
- runParsecParser,
- runParsecParser',
- simpleParsec,
- simpleParsecBS,
- simpleParsec',
- simpleParsecW',
- lexemeParsec,
- eitherParsec,
- explicitEitherParsec,
- explicitEitherParsec',
+
+module Distribution.Parsec
+ ( Parsec (..)
+ , ParsecParser (..)
+ , runParsecParser
+ , runParsecParser'
+ , simpleParsec
+ , simpleParsecBS
+ , simpleParsec'
+ , simpleParsecW'
+ , lexemeParsec
+ , eitherParsec
+ , explicitEitherParsec
+ , explicitEitherParsec'
+
-- * CabalParsing and diagnostics
- CabalParsing (..),
+ , CabalParsing (..)
+
-- ** Warnings
- PWarnType (..),
- PWarning (..),
- showPWarning,
+ , PWarnType (..)
+ , PWarning (..)
+ , showPWarning
+
-- ** Errors
- PError (..),
- showPError,
+ , PError (..)
+ , showPError
+
-- * Position
- Position (..),
- incPos,
- retPos,
- showPos,
- zeroPos,
+ , Position (..)
+ , incPos
+ , retPos
+ , showPos
+ , zeroPos
+
-- * Utilities
- parsecToken,
- parsecToken',
- parsecFilePath,
- parsecQuoted,
- parsecMaybeQuoted,
- parsecCommaList,
- parsecCommaNonEmpty,
- parsecLeadingCommaList,
- parsecLeadingCommaNonEmpty,
- parsecOptCommaList,
- parsecLeadingOptCommaList,
- parsecStandard,
- parsecUnqualComponentName,
- ) where
-
-import Data.ByteString (ByteString)
-import Data.Char (digitToInt, intToDigit)
-import Data.List (transpose)
+ , parsecToken
+ , parsecToken'
+ , parsecFilePath
+ , parsecQuoted
+ , parsecMaybeQuoted
+ , parsecCommaList
+ , parsecCommaNonEmpty
+ , parsecLeadingCommaList
+ , parsecLeadingCommaNonEmpty
+ , parsecOptCommaList
+ , parsecLeadingOptCommaList
+ , parsecStandard
+ , parsecUnqualComponentName
+ ) where
+
+import Data.ByteString (ByteString)
+import Data.Char (digitToInt, intToDigit)
+import Data.List (transpose)
import Distribution.CabalSpecVersion
import Distribution.Compat.Prelude
-import Distribution.Parsec.Error (PError (..), showPError)
+import Distribution.Parsec.Error (PError (..), showPError)
import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString)
-import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos)
-import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning)
-import Numeric (showIntAtBase)
+import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos)
+import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning)
+import Numeric (showIntAtBase)
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.Compat.DList as DList
-import qualified Distribution.Compat.MonadFail as Fail
-import qualified Text.Parsec as Parsec
+import qualified Distribution.Compat.DList as DList
+import qualified Distribution.Compat.MonadFail as Fail
+import qualified Text.Parsec as Parsec
-------------------------------------------------------------------------------
-- Class
@@ -72,118 +78,118 @@ import qualified Text.Parsec as Parsec
-- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields.
--
-- For parsing @.cabal@ like file structure, see "Distribution.Fields".
---
class Parsec a where
- parsec :: CabalParsing m => m a
+ parsec :: CabalParsing m => m a
-- | Parsing class which
--
-- * can report Cabal parser warnings.
--
-- * knows @cabal-version@ we work with
---
class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where
- parsecWarning :: PWarnType -> String -> m ()
+ parsecWarning :: PWarnType -> String -> m ()
- parsecHaskellString :: m String
- parsecHaskellString = stringLiteral
+ parsecHaskellString :: m String
+ parsecHaskellString = stringLiteral
- askCabalSpecVersion :: m CabalSpecVersion
+ askCabalSpecVersion :: m CabalSpecVersion
-- | 'parsec' /could/ consume trailing spaces, this function /will/ consume.
lexemeParsec :: (CabalParsing m, Parsec a) => m a
lexemeParsec = parsec <* P.spaces
-newtype ParsecParser a = PP { unPP
- :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a
- }
+newtype ParsecParser a = PP
+ { unPP
+ :: CabalSpecVersion
+ -> Parsec.Parsec FieldLineStream [PWarning] a
+ }
liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a
liftParsec p = PP $ \_ -> p
instance Functor ParsecParser where
- fmap f p = PP $ \v -> fmap f (unPP p v)
- {-# INLINE fmap #-}
+ fmap f p = PP $ \v -> fmap f (unPP p v)
+ {-# INLINE fmap #-}
- x <$ p = PP $ \v -> x <$ unPP p v
- {-# INLINE (<$) #-}
+ x <$ p = PP $ \v -> x <$ unPP p v
+ {-# INLINE (<$) #-}
instance Applicative ParsecParser where
- pure = liftParsec . pure
- {-# INLINE pure #-}
+ pure = liftParsec . pure
+ {-# INLINE pure #-}
- f <*> x = PP $ \v -> unPP f v <*> unPP x v
- {-# INLINE (<*>) #-}
- f *> x = PP $ \v -> unPP f v *> unPP x v
- {-# INLINE (*>) #-}
- f <* x = PP $ \v -> unPP f v <* unPP x v
- {-# INLINE (<*) #-}
+ f <*> x = PP $ \v -> unPP f v <*> unPP x v
+ {-# INLINE (<*>) #-}
+ f *> x = PP $ \v -> unPP f v *> unPP x v
+ {-# INLINE (*>) #-}
+ f <* x = PP $ \v -> unPP f v <* unPP x v
+ {-# INLINE (<*) #-}
instance Alternative ParsecParser where
- empty = liftParsec empty
+ empty = liftParsec empty
- a <|> b = PP $ \v -> unPP a v <|> unPP b v
- {-# INLINE (<|>) #-}
+ a <|> b = PP $ \v -> unPP a v <|> unPP b v
+ {-# INLINE (<|>) #-}
- many p = PP $ \v -> many (unPP p v)
- {-# INLINE many #-}
+ many p = PP $ \v -> many (unPP p v)
+ {-# INLINE many #-}
- some p = PP $ \v -> some (unPP p v)
- {-# INLINE some #-}
+ some p = PP $ \v -> some (unPP p v)
+ {-# INLINE some #-}
instance Monad ParsecParser where
- return = pure
+ return = pure
- m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v
- {-# INLINE (>>=) #-}
- (>>) = (*>)
- {-# INLINE (>>) #-}
+ m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v
+ {-# INLINE (>>=) #-}
+ (>>) = (*>)
+ {-# INLINE (>>) #-}
#if !(MIN_VERSION_base(4,13,0))
- fail = Fail.fail
+ fail = Fail.fail
#endif
instance MonadPlus ParsecParser where
- mzero = empty
- mplus = (<|>)
+ mzero = empty
+ mplus = (<|>)
instance Fail.MonadFail ParsecParser where
- fail = P.unexpected
+ fail = P.unexpected
instance P.Parsing ParsecParser where
- try p = PP $ \v -> P.try (unPP p v)
- p <?> d = PP $ \v -> unPP p v P.<?> d
- skipMany p = PP $ \v -> P.skipMany (unPP p v)
- skipSome p = PP $ \v -> P.skipSome (unPP p v)
- unexpected = liftParsec . P.unexpected
- eof = liftParsec P.eof
- notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v)
+ try p = PP $ \v -> P.try (unPP p v)
+ p <?> d = PP $ \v -> unPP p v P.<?> d
+ skipMany p = PP $ \v -> P.skipMany (unPP p v)
+ skipSome p = PP $ \v -> P.skipSome (unPP p v)
+ unexpected = liftParsec . P.unexpected
+ eof = liftParsec P.eof
+ notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v)
instance P.CharParsing ParsecParser where
- satisfy = liftParsec . P.satisfy
- char = liftParsec . P.char
- notChar = liftParsec . P.notChar
- anyChar = liftParsec P.anyChar
- string = liftParsec . P.string
+ satisfy = liftParsec . P.satisfy
+ char = liftParsec . P.char
+ notChar = liftParsec . P.notChar
+ anyChar = liftParsec P.anyChar
+ string = liftParsec . P.string
instance CabalParsing ParsecParser where
- parsecWarning t w = liftParsec $ do
- spos <- Parsec.getPosition
- Parsec.modifyState
- (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :)
- askCabalSpecVersion = PP pure
+ parsecWarning t w = liftParsec $ do
+ spos <- Parsec.getPosition
+ Parsec.modifyState
+ (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :)
+ askCabalSpecVersion = PP pure
-- | Parse a 'String' with 'lexemeParsec'.
simpleParsec :: Parsec a => String -> Maybe a
-simpleParsec
- = either (const Nothing) Just
+simpleParsec =
+ either (const Nothing) Just
. runParsecParser lexemeParsec "<simpleParsec>"
. fieldLineStreamFromString
-- | Like 'simpleParsec' but for 'ByteString'
simpleParsecBS :: Parsec a => ByteString -> Maybe a
-simpleParsecBS
- = either (const Nothing) Just
+simpleParsecBS =
+ either (const Nothing) Just
. runParsecParser lexemeParsec "<simpleParsec>"
. fieldLineStreamFromBS
@@ -191,8 +197,8 @@ simpleParsecBS
--
-- @since 3.4.0.0
simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a
-simpleParsec' spec
- = either (const Nothing) Just
+simpleParsec' spec =
+ either (const Nothing) Just
. runParsecParser' spec lexemeParsec "<simpleParsec>"
. fieldLineStreamFromString
@@ -201,8 +207,8 @@ simpleParsec' spec
--
-- @since 3.4.0.0
simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a
-simpleParsecW' spec
- = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing)
+simpleParsecW' spec =
+ either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing)
. runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "<simpleParsec>"
. fieldLineStreamFromString
@@ -212,8 +218,8 @@ eitherParsec = explicitEitherParsec parsec
-- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted.
explicitEitherParsec :: ParsecParser a -> String -> Either String a
-explicitEitherParsec parser
- = either (Left . show) Right
+explicitEitherParsec parser =
+ either (Left . show) Right
. runParsecParser (parser <* P.spaces) "<eitherParsec>"
. fieldLineStreamFromString
@@ -221,10 +227,9 @@ explicitEitherParsec parser
-- See 'explicitEitherParsec'.
--
-- @since 3.4.0.0
---
explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a
-explicitEitherParsec' spec parser
- = either (Left . show) Right
+explicitEitherParsec' spec parser =
+ either (Left . show) Right
. runParsecParser' spec (parser <* P.spaces) "<eitherParsec>"
. fieldLineStreamFromString
@@ -235,44 +240,45 @@ runParsecParser = runParsecParser' cabalSpecLatest
-- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used.
--
-- @since 3.0.0.0
---
runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a
runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n
instance Parsec a => Parsec (Identity a) where
- parsec = Identity <$> parsec
+ parsec = Identity <$> parsec
instance Parsec Bool where
- parsec = P.munch1 isAlpha >>= postprocess
- where
- postprocess str
- | str == "True" = pure True
- | str == "False" = pure False
- | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True
- | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False
- | otherwise = fail $ "Not a boolean: " ++ str
- where
- lstr = map toLower str
- caseWarning =
- "Boolean values are case sensitive, use 'True' or 'False'."
+ parsec = P.munch1 isAlpha >>= postprocess
+ where
+ postprocess str
+ | str == "True" = pure True
+ | str == "False" = pure False
+ | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True
+ | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False
+ | otherwise = fail $ "Not a boolean: " ++ str
+ where
+ lstr = map toLower str
+ caseWarning =
+ "Boolean values are case sensitive, use 'True' or 'False'."
-- | @[^ ,]@
parsecToken :: CabalParsing m => m String
-parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P.<?> "identifier" ) >>= checkNotDoubleDash)
+parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P.<?> "identifier") >>= checkNotDoubleDash)
-- | @[^ ]@
parsecToken' :: CabalParsing m => m String
parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P.<?> "token") >>= checkNotDoubleDash)
-checkNotDoubleDash :: CabalParsing m => String -> m String
+checkNotDoubleDash :: CabalParsing m => String -> m String
checkNotDoubleDash s = do
- when (s == "--") $ parsecWarning PWTDoubleDash $ unwords
+ when (s == "--") $
+ parsecWarning PWTDoubleDash $
+ unwords
[ "Double-dash token found."
, "Note: there are no end-of-line comments in .cabal files, only whole line comments."
, "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token"
]
- return s
+ return s
parsecFilePath :: CabalParsing m => m FilePath
parsecFilePath = parsecToken
@@ -280,16 +286,17 @@ parsecFilePath = parsecToken
-- | Parse a benchmark/test-suite types.
parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a
parsecStandard f = do
- cs <- some $ P.try (component <* P.char '-')
- ver <- parsec
- let name = map toLower (intercalate "-" cs)
- return $! f ver name
+ cs <- some $ P.try (component <* P.char '-')
+ ver <- parsec
+ let name = map toLower (intercalate "-" cs)
+ return $! f ver name
where
component = do
cs <- P.munch1 isAlphaNum
if all isDigit cs then fail "all digit component" else return cs
- -- each component must contain an alphabetic character, to avoid
- -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+-- each component must contain an alphabetic character, to avoid
+-- ambiguity in identifiers like foo-1 (the 1 is the version number).
parsecCommaList :: CabalParsing m => m a -> m [a]
parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P.<?> "comma")
@@ -306,10 +313,10 @@ parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces
-- @
parsecLeadingCommaList :: CabalParsing m => m a -> m [a]
parsecLeadingCommaList p = do
- c <- P.optional comma
- case c of
- Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure []
- Just _ -> toList <$> P.sepByNonEmpty lp comma
+ c <- P.optional comma
+ case c of
+ Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure []
+ Just _ -> toList <$> P.sepByNonEmpty lp comma
where
lp = p <* P.spaces
comma = P.char ',' *> P.spaces P.<?> "comma"
@@ -319,10 +326,10 @@ parsecLeadingCommaList p = do
-- @since 3.4.0.0
parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a)
parsecLeadingCommaNonEmpty p = do
- c <- P.optional comma
- case c of
- Nothing -> P.sepEndByNonEmpty lp comma
- Just _ -> P.sepByNonEmpty lp comma
+ c <- P.optional comma
+ case c of
+ Nothing -> P.sepEndByNonEmpty lp comma
+ Just _ -> P.sepByNonEmpty lp comma
where
lp = p <* P.spaces
comma = P.char ',' *> P.spaces P.<?> "comma"
@@ -345,23 +352,22 @@ parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma)
-- @
--
-- @since 3.0.0.0
---
parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a]
parsecLeadingOptCommaList p = do
- c <- P.optional comma
- case c of
- Nothing -> sepEndBy1Start <|> pure []
- Just _ -> toList <$> P.sepByNonEmpty lp comma
+ c <- P.optional comma
+ case c of
+ Nothing -> sepEndBy1Start <|> pure []
+ Just _ -> toList <$> P.sepByNonEmpty lp comma
where
lp = p <* P.spaces
comma = P.char ',' *> P.spaces P.<?> "comma"
sepEndBy1Start = do
- x <- lp
- c <- P.optional comma
- case c of
- Nothing -> (x :) <$> many lp
- Just _ -> (x :) <$> P.sepEndBy lp comma
+ x <- lp
+ c <- P.optional comma
+ case c of
+ Nothing -> (x :) <$> many lp
+ Just _ -> (x :) <$> P.sepEndBy lp comma
-- | Content isn't unquoted
parsecQuoted :: CabalParsing m => m a -> m a
@@ -372,7 +378,8 @@ parsecMaybeQuoted :: CabalParsing m => m a -> m a
parsecMaybeQuoted p = parsecQuoted p <|> p
parsecUnqualComponentName :: forall m. CabalParsing m => m String
-parsecUnqualComponentName = state0 DList.empty where
+parsecUnqualComponentName = state0 DList.empty
+ where
--
-- using @kleene@ package we can easily see that
-- we need only two states to recognize
@@ -407,23 +414,25 @@ parsecUnqualComponentName = state0 DList.empty where
state0 :: DList.DList Char -> m String
state0 acc = do
- c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc)
- case () of
- _ | isDigit c -> state0 (DList.snoc acc c)
- | isAlphaNum c -> state1 (DList.snoc acc c)
- | c == '-' -> fail ("Empty component, after " ++ DList.toList acc)
- | otherwise -> fail ("Internal error, after " ++ DList.toList acc)
+ c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc)
+ case () of
+ _
+ | isDigit c -> state0 (DList.snoc acc c)
+ | isAlphaNum c -> state1 (DList.snoc acc c)
+ | c == '-' -> fail ("Empty component, after " ++ DList.toList acc)
+ | otherwise -> fail ("Internal error, after " ++ DList.toList acc)
state1 :: DList.DList Char -> m String
state1 acc = state1' acc `alt` return (DList.toList acc)
state1' :: DList.DList Char -> m String
state1' acc = do
- c <- ch
- case () of
- _ | isAlphaNum c -> state1 (DList.snoc acc c)
- | c == '-' -> state0 (DList.snoc acc c)
- | otherwise -> fail ("Internal error, after " ++ DList.toList acc)
+ c <- ch
+ case () of
+ _
+ | isAlphaNum c -> state1 (DList.snoc acc c)
+ | c == '-' -> state0 (DList.snoc acc c)
+ | otherwise -> fail ("Internal error, after " ++ DList.toList acc)
ch :: m Char
!ch = P.satisfy (\c -> isAlphaNum c || c == '-')
@@ -432,24 +441,29 @@ parsecUnqualComponentName = state0 DList.empty where
!alt = (<|>)
stringLiteral :: forall m. P.CharParsing m => m String
-stringLiteral = lit where
+stringLiteral = lit
+ where
lit :: m String
- lit = foldr (maybe id (:)) ""
+ lit =
+ foldr (maybe id (:)) ""
<$> P.between (P.char '"') (P.char '"' P.<?> "end of string") (many stringChar)
P.<?> "string"
stringChar :: m (Maybe Char)
- stringChar = Just <$> stringLetter
- <|> stringEscape
- P.<?> "string character"
+ stringChar =
+ Just <$> stringLetter
+ <|> stringEscape
+ P.<?> "string character"
stringLetter :: m Char
stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
stringEscape :: m (Maybe Char)
- stringEscape = P.char '\\' *> esc where
+ stringEscape = P.char '\\' *> esc
+ where
esc :: m (Maybe Char)
- esc = Nothing <$ escapeGap
+ esc =
+ Nothing <$ escapeGap
<|> Nothing <$ escapeEmpty
<|> Just <$> escapeCode
@@ -460,65 +474,103 @@ stringLiteral = lit where
escapeCode :: forall m. P.CharParsing m => m Char
escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P.<?> "escape code"
where
- charControl, charNum :: m Char
- charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@'))
- charNum = toEnum <$> num
- where
- num :: m Int
- num = bounded 10 maxchar
- <|> (P.char 'o' *> bounded 8 maxchar)
- <|> (P.char 'x' *> bounded 16 maxchar)
- maxchar = fromEnum (maxBound :: Char)
-
- bounded :: Int -> Int -> m Int
- bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0
- <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "")
- where
- thedigits :: [m Char]
- thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']])
-
- toomuch :: m a
- toomuch = P.unexpected "out-of-range numeric escape sequence"
-
- bounded', bounded'' :: [m Char] -> [Int] -> m [Char]
- bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds)
- <|> bounded'' dps bds
- bounded' [] _ = error "bounded called with base 0"
- bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch
- bounded'' dps (bd : bds) = let anyd :: m Char
- anyd = P.choice dps
-
- nomore :: m ()
- nomore = P.notFollowedBy anyd <|> toomuch
-
- (low, ex, high) = case splitAt bd dps of
- (low', ex' : high') -> (low', ex', high')
- (_, _) -> error "escapeCode: Logic error"
- in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore
- <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds))
- <|> if not (null bds)
- then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore
- else empty
- atMost n p | n <= 0 = pure []
- | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure []
-
- charEsc :: m Char
- charEsc = P.choice $ parseEsc <$> escMap
-
- parseEsc (c,code) = code <$ P.char c
- escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"
-
- charAscii :: m Char
- charAscii = P.choice $ parseAscii <$> asciiMap
-
- parseAscii (asc,code) = P.try $ code <$ P.string asc
- asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
- ascii2codes, ascii3codes :: [String]
- ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO"
- , "SI","EM","FS","GS","RS","US","SP"]
- ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK"
- ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK"
- ,"SYN","ETB","CAN","SUB","ESC","DEL"]
- ascii2, ascii3 :: String
- ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP"
- ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"
+ charControl, charNum :: m Char
+ charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@'))
+ charNum = toEnum <$> num
+ where
+ num :: m Int
+ num =
+ bounded 10 maxchar
+ <|> (P.char 'o' *> bounded 8 maxchar)
+ <|> (P.char 'x' *> bounded 16 maxchar)
+ maxchar = fromEnum (maxBound :: Char)
+
+ bounded :: Int -> Int -> m Int
+ bounded base bnd =
+ foldl' (\x d -> base * x + digitToInt d) 0
+ <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "")
+ where
+ thedigits :: [m Char]
+ thedigits = map P.char ['0' .. '9'] ++ map P.oneOf (transpose [['A' .. 'F'], ['a' .. 'f']])
+
+ toomuch :: m a
+ toomuch = P.unexpected "out-of-range numeric escape sequence"
+
+ bounded', bounded'' :: [m Char] -> [Int] -> m [Char]
+ bounded' dps@(zero : _) bds =
+ P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds)
+ <|> bounded'' dps bds
+ bounded' [] _ = error "bounded called with base 0"
+ bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch
+ bounded'' dps (bd : bds) =
+ let anyd :: m Char
+ anyd = P.choice dps
+
+ nomore :: m ()
+ nomore = P.notFollowedBy anyd <|> toomuch
+
+ (low, ex, high) = case splitAt bd dps of
+ (low', ex' : high') -> (low', ex', high')
+ (_, _) -> error "escapeCode: Logic error"
+ in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore
+ <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds))
+ <|> if not (null bds)
+ then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore
+ else empty
+ atMost n p
+ | n <= 0 = pure []
+ | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure []
+
+ charEsc :: m Char
+ charEsc = P.choice $ parseEsc <$> escMap
+
+ parseEsc (c, code) = code <$ P.char c
+ escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'"
+
+ charAscii :: m Char
+ charAscii = P.choice $ parseAscii <$> asciiMap
+
+ parseAscii (asc, code) = P.try $ code <$ P.string asc
+ asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
+ ascii2codes, ascii3codes :: [String]
+ ascii2codes =
+ [ "BS"
+ , "HT"
+ , "LF"
+ , "VT"
+ , "FF"
+ , "CR"
+ , "SO"
+ , "SI"
+ , "EM"
+ , "FS"
+ , "GS"
+ , "RS"
+ , "US"
+ , "SP"
+ ]
+ ascii3codes =
+ [ "NUL"
+ , "SOH"
+ , "STX"
+ , "ETX"
+ , "EOT"
+ , "ENQ"
+ , "ACK"
+ , "BEL"
+ , "DLE"
+ , "DC1"
+ , "DC2"
+ , "DC3"
+ , "DC4"
+ , "NAK"
+ , "SYN"
+ , "ETB"
+ , "CAN"
+ , "SUB"
+ , "ESC"
+ , "DEL"
+ ]
+ ascii2, ascii3 :: String
+ ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP"
+ ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"
diff --git a/Cabal-syntax/src/Distribution/Parsec/Error.hs b/Cabal-syntax/src/Distribution/Parsec/Error.hs
index 2e958de30ffc64477086bb1049066a4e5bd98d70..46114c3ea98c40a7eeee68347e4fa1ac39e42fa7 100644
--- a/Cabal-syntax/src/Distribution/Parsec/Error.hs
+++ b/Cabal-syntax/src/Distribution/Parsec/Error.hs
@@ -1,21 +1,22 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Parsec.Error (
- PError (..),
- showPError,
- ) where
+
+module Distribution.Parsec.Error
+ ( PError (..)
+ , showPError
+ ) where
import Distribution.Compat.Prelude
import Distribution.Parsec.Position
+import System.FilePath (normalise)
import Prelude ()
-import System.FilePath (normalise)
-- | Parser error.
data PError = PError Position String
- deriving (Show, Generic)
+ deriving (Show, Generic)
instance Binary PError
instance NFData PError where rnf = genericRnf
showPError :: FilePath -> PError -> String
showPError fpath (PError pos msg) =
- normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg
+ normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg
diff --git a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs
index 670fa85f47b2470b9111e123c8e0158a2395865a..2e9cc8e2475ab1514ce8f65c91a1475b26d727f7 100644
--- a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs
+++ b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs
@@ -1,29 +1,30 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -Werror #-}
-module Distribution.Parsec.FieldLineStream (
- FieldLineStream (..),
- fieldLineStreamFromString,
- fieldLineStreamFromBS,
- fieldLineStreamEnd,
- ) where
+
+module Distribution.Parsec.FieldLineStream
+ ( FieldLineStream (..)
+ , fieldLineStreamFromString
+ , fieldLineStreamFromBS
+ , fieldLineStreamEnd
+ ) where
import Data.Bits
-import Data.ByteString (ByteString)
+import Data.ByteString (ByteString)
import Distribution.Compat.Prelude
-import Distribution.Utils.Generic (toUTF8BS)
+import Distribution.Utils.Generic (toUTF8BS)
import Prelude ()
import qualified Data.ByteString as BS
-import qualified Text.Parsec as Parsec
+import qualified Text.Parsec as Parsec
-- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@.
data FieldLineStream
- = FLSLast !ByteString
- | FLSCons {-# UNPACK #-} !ByteString FieldLineStream
- deriving Show
+ = FLSLast !ByteString
+ | FLSCons {-# UNPACK #-} !ByteString FieldLineStream
+ deriving (Show)
fieldLineStreamEnd :: FieldLineStream
fieldLineStreamEnd = FLSLast mempty
@@ -38,54 +39,55 @@ fieldLineStreamFromBS :: ByteString -> FieldLineStream
fieldLineStreamFromBS = FLSLast
instance Monad m => Parsec.Stream FieldLineStream m Char where
- uncons (FLSLast bs) = return $ case BS.uncons bs of
- Nothing -> Nothing
- Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd)
-
- uncons (FLSCons bs s) = return $ case BS.uncons bs of
- -- as lines are glued with '\n', we return '\n' here!
- Nothing -> Just ('\n', s)
- Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s)
+ uncons (FLSLast bs) = return $ case BS.uncons bs of
+ Nothing -> Nothing
+ Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd)
+ uncons (FLSCons bs s) = return $ case BS.uncons bs of
+ -- as lines are glued with '\n', we return '\n' here!
+ Nothing -> Just ('\n', s)
+ Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s)
-- Based on implementation 'decodeStringUtf8'
unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a)
unconsChar c0 bs0 f next
- | c0 <= 0x7F = (chr (fromIntegral c0), f bs0)
- | c0 <= 0xBF = (replacementChar, f bs0)
- | c0 <= 0xDF = twoBytes
- | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF)
- | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7)
- | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3)
- | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1)
- | otherwise = error $ "not implemented " ++ show c0
+ | c0 <= 0x7F = (chr (fromIntegral c0), f bs0)
+ | c0 <= 0xBF = (replacementChar, f bs0)
+ | c0 <= 0xDF = twoBytes
+ | c0 <= 0xEF = moreBytes 3 0x800 bs0 (fromIntegral $ c0 .&. 0xF)
+ | c0 <= 0xF7 = moreBytes 4 0x10000 bs0 (fromIntegral $ c0 .&. 0x7)
+ | c0 <= 0xFB = moreBytes 5 0x200000 bs0 (fromIntegral $ c0 .&. 0x3)
+ | c0 <= 0xFD = moreBytes 6 0x4000000 bs0 (fromIntegral $ c0 .&. 0x1)
+ | otherwise = error $ "not implemented " ++ show c0
where
twoBytes = case BS.uncons bs0 of
- Nothing -> (replacementChar, next)
- Just (c1, bs1)
- | c1 .&. 0xC0 == 0x80 ->
- if d >= 0x80
- then (chr d, f bs1)
- else (replacementChar, f bs1)
- | otherwise -> (replacementChar, f bs1)
- where
- d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)
+ Nothing -> (replacementChar, next)
+ Just (c1, bs1)
+ | c1 .&. 0xC0 == 0x80 ->
+ if d >= 0x80
+ then (chr d, f bs1)
+ else (replacementChar, f bs1)
+ | otherwise -> (replacementChar, f bs1)
+ where
+ d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)
moreBytes :: Int -> Int -> ByteString -> Int -> (Char, a)
moreBytes 1 overlong bs' acc
- | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc
- = (chr acc, f bs')
- | otherwise
- = (replacementChar, f bs')
-
+ | overlong <= acc
+ , acc <= 0x10FFFF
+ , acc < 0xD800 || 0xDFFF < acc =
+ (chr acc, f bs')
+ | otherwise =
+ (replacementChar, f bs')
moreBytes byteCount overlong bs' acc = case BS.uncons bs' of
- Nothing -> (replacementChar, f bs')
- Just (cn, bs1)
- | cn .&. 0xC0 == 0x80 -> moreBytes
- (byteCount-1)
- overlong
- bs1
- ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
- | otherwise -> (replacementChar, f bs1)
+ Nothing -> (replacementChar, f bs')
+ Just (cn, bs1)
+ | cn .&. 0xC0 == 0x80 ->
+ moreBytes
+ (byteCount - 1)
+ overlong
+ bs1
+ ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
+ | otherwise -> (replacementChar, f bs1)
replacementChar :: Char
replacementChar = '\xfffd'
diff --git a/Cabal-syntax/src/Distribution/Parsec/Position.hs b/Cabal-syntax/src/Distribution/Parsec/Position.hs
index 5fe20fe3acd796fe520986a9ed3f5a0116aaba59..892fc8b8fda1e9b4a3f8d6589d07bf6d526916c6 100644
--- a/Cabal-syntax/src/Distribution/Parsec/Position.hs
+++ b/Cabal-syntax/src/Distribution/Parsec/Position.hs
@@ -1,21 +1,23 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Parsec.Position (
- Position (..),
- incPos,
- retPos,
- showPos,
- zeroPos,
- positionCol,
- positionRow,
- ) where
+
+module Distribution.Parsec.Position
+ ( Position (..)
+ , incPos
+ , retPos
+ , showPos
+ , zeroPos
+ , positionCol
+ , positionRow
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
-- | 1-indexed row and column positions in a file.
-data Position = Position
- {-# UNPACK #-} !Int -- row
- {-# UNPACK #-} !Int -- column
+data Position
+ = Position
+ {-# UNPACK #-} !Int -- row
+ {-# UNPACK #-} !Int -- column
deriving (Eq, Ord, Show, Generic)
instance Binary Position
diff --git a/Cabal-syntax/src/Distribution/Parsec/Warning.hs b/Cabal-syntax/src/Distribution/Parsec/Warning.hs
index eedf5545cf76ec4c82a45f88ec89bdea7c84982b..88893e81d982b1fdb872db495e08927c5a4691bd 100644
--- a/Cabal-syntax/src/Distribution/Parsec/Warning.hs
+++ b/Cabal-syntax/src/Distribution/Parsec/Warning.hs
@@ -1,61 +1,76 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Parsec.Warning (
- PWarning (..),
- PWarnType (..),
- showPWarning,
- ) where
+
+module Distribution.Parsec.Warning
+ ( PWarning (..)
+ , PWarnType (..)
+ , showPWarning
+ ) where
import Distribution.Compat.Prelude
import Distribution.Parsec.Position
+import System.FilePath (normalise)
import Prelude ()
-import System.FilePath (normalise)
-- | Type of parser warning. We do classify warnings.
--
-- Different application may decide not to show some, or have fatal behaviour on others
data PWarnType
- = PWTOther -- ^ Unclassified warning
- | PWTUTF -- ^ Invalid UTF encoding
- | PWTBoolCase -- ^ @true@ or @false@, not @True@ or @False@
- | PWTVersionTag -- ^ there are version with tags
- | PWTNewSyntax -- ^ New syntax used, but no @cabal-version: >= 1.2@ specified
- | PWTOldSyntax -- ^ Old syntax used, and @cabal-version >= 1.2@ specified
- | PWTDeprecatedField
- | PWTInvalidSubsection
- | PWTUnknownField
- | PWTUnknownSection
- | PWTTrailingFields
- | PWTExtraMainIs -- ^ extra main-is field
- | PWTExtraTestModule -- ^ extra test-module field
- | PWTExtraBenchmarkModule -- ^ extra benchmark-module field
- | PWTLexNBSP
- | PWTLexBOM
- | PWTLexTab
- | PWTQuirkyCabalFile -- ^ legacy cabal file that we know how to patch
- | PWTDoubleDash -- ^ Double dash token, most likely it's a mistake - it's not a comment
- | PWTMultipleSingularField -- ^ e.g. name or version should be specified only once.
- | PWTBuildTypeDefault -- ^ Workaround for derive-package having build-type: Default. See <https://github.com/haskell/cabal/issues/5020>.
-
- | PWTVersionOperator -- ^ Version operators used (without cabal-version: 1.8)
- | PWTVersionWildcard -- ^ Version wildcard used (without cabal-version: 1.6)
-
- | PWTSpecVersion -- ^ Warnings about cabal-version format.
-
- | PWTEmptyFilePath -- ^ Empty filepath, i.e. literally ""
-
- | PWTExperimental -- ^ Experimental feature
- deriving (Eq, Ord, Show, Enum, Bounded, Generic)
+ = -- | Unclassified warning
+ PWTOther
+ | -- | Invalid UTF encoding
+ PWTUTF
+ | -- | @true@ or @false@, not @True@ or @False@
+ PWTBoolCase
+ | -- | there are version with tags
+ PWTVersionTag
+ | -- | New syntax used, but no @cabal-version: >= 1.2@ specified
+ PWTNewSyntax
+ | -- | Old syntax used, and @cabal-version >= 1.2@ specified
+ PWTOldSyntax
+ | PWTDeprecatedField
+ | PWTInvalidSubsection
+ | PWTUnknownField
+ | PWTUnknownSection
+ | PWTTrailingFields
+ | -- | extra main-is field
+ PWTExtraMainIs
+ | -- | extra test-module field
+ PWTExtraTestModule
+ | -- | extra benchmark-module field
+ PWTExtraBenchmarkModule
+ | PWTLexNBSP
+ | PWTLexBOM
+ | PWTLexTab
+ | -- | legacy cabal file that we know how to patch
+ PWTQuirkyCabalFile
+ | -- | Double dash token, most likely it's a mistake - it's not a comment
+ PWTDoubleDash
+ | -- | e.g. name or version should be specified only once.
+ PWTMultipleSingularField
+ | -- | Workaround for derive-package having build-type: Default. See <https://github.com/haskell/cabal/issues/5020>.
+ PWTBuildTypeDefault
+ | -- | Version operators used (without cabal-version: 1.8)
+ PWTVersionOperator
+ | -- | Version wildcard used (without cabal-version: 1.6)
+ PWTVersionWildcard
+ | -- | Warnings about cabal-version format.
+ PWTSpecVersion
+ | -- | Empty filepath, i.e. literally ""
+ PWTEmptyFilePath
+ | -- | Experimental feature
+ PWTExperimental
+ deriving (Eq, Ord, Show, Enum, Bounded, Generic)
instance Binary PWarnType
instance NFData PWarnType where rnf = genericRnf
-- | Parser warning.
data PWarning = PWarning !PWarnType !Position String
- deriving (Eq, Ord, Show, Generic)
+ deriving (Eq, Ord, Show, Generic)
instance Binary PWarning
instance NFData PWarning where rnf = genericRnf
showPWarning :: FilePath -> PWarning -> String
showPWarning fpath (PWarning _ pos msg) =
- normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg
+ normalise fpath ++ ":" ++ showPos pos ++ ": " ++ msg
diff --git a/Cabal-syntax/src/Distribution/Pretty.hs b/Cabal-syntax/src/Distribution/Pretty.hs
index 1dfed5c8337f81c3f6d737aeb093389d929d47e6..3ddb806d81bf414d44106735acb38c5107684d6d 100644
--- a/Cabal-syntax/src/Distribution/Pretty.hs
+++ b/Cabal-syntax/src/Distribution/Pretty.hs
@@ -1,17 +1,19 @@
-module Distribution.Pretty (
- Pretty (..),
- prettyShow,
- defaultStyle,
- flatStyle,
+module Distribution.Pretty
+ ( Pretty (..)
+ , prettyShow
+ , defaultStyle
+ , flatStyle
+
-- * Utilities
- showFilePath,
- showToken,
- showTokenStr,
- showFreeText,
- showFreeTextV3,
+ , showFilePath
+ , showToken
+ , showTokenStr
+ , showFreeText
+ , showFreeTextV3
+
-- * Deprecated
- Separator,
- ) where
+ , Separator
+ ) where
import Distribution.CabalSpecVersion
import Distribution.Compat.Prelude
@@ -20,23 +22,23 @@ import Prelude ()
import qualified Text.PrettyPrint as PP
class Pretty a where
- pretty :: a -> PP.Doc
+ pretty :: a -> PP.Doc
- prettyVersioned :: CabalSpecVersion -> a -> PP.Doc
- prettyVersioned _ = pretty
+ prettyVersioned :: CabalSpecVersion -> a -> PP.Doc
+ prettyVersioned _ = pretty
-- | @since 3.4.0.0
instance Pretty PP.Doc where
- pretty = id
+ pretty = id
instance Pretty Bool where
- pretty = PP.text . show
+ pretty = PP.text . show
instance Pretty Int where
- pretty = PP.text . show
+ pretty = PP.text . show
instance Pretty a => Pretty (Identity a) where
- pretty = pretty . runIdentity
+ pretty = pretty . runIdentity
prettyShow :: Pretty a => a -> String
prettyShow = PP.renderStyle defaultStyle . pretty
@@ -45,20 +47,29 @@ prettyShow = PP.renderStyle defaultStyle . pretty
-- output. It has a fixed page width and adds line breaks
-- automatically.
defaultStyle :: PP.Style
-defaultStyle = PP.Style { PP.mode = PP.PageMode
- , PP.lineLength = 79
- , PP.ribbonsPerLine = 1.0
- }
+defaultStyle =
+ PP.Style
+ { PP.mode = PP.PageMode
+ , PP.lineLength = 79
+ , PP.ribbonsPerLine = 1.0
+ }
-- | A style for rendering all on one line.
flatStyle :: PP.Style
-flatStyle = PP.Style { PP.mode = PP.LeftMode
- , PP.lineLength = err "lineLength"
- , PP.ribbonsPerLine = err "ribbonsPerLine"
- }
+flatStyle =
+ PP.Style
+ { PP.mode = PP.LeftMode
+ , PP.lineLength = err "lineLength"
+ , PP.ribbonsPerLine = err "ribbonsPerLine"
+ }
where
- err x = error ("flatStyle: tried to access " ++ x ++ " in LeftMode. " ++
- "This should never happen and indicates a bug in Cabal.")
+ err x =
+ error
+ ( "flatStyle: tried to access "
+ ++ x
+ ++ " in LeftMode. "
+ ++ "This should never happen and indicates a bug in Cabal."
+ )
-------------------------------------------------------------------------------
-- Utilities
@@ -75,21 +86,20 @@ showToken = PP.text . showTokenStr
showTokenStr :: String -> String
showTokenStr str
- -- if token looks like a comment (starts with --), print it in quotes
- | "--" `isPrefixOf` str = show str
- -- also if token ends with a colon (e.g. executable name), print it in quotes
- | ":" `isSuffixOf` str = show str
- | not (any dodgy str) && not (null str) = str
- | otherwise = show str
+ -- if token looks like a comment (starts with --), print it in quotes
+ | "--" `isPrefixOf` str = show str
+ -- also if token ends with a colon (e.g. executable name), print it in quotes
+ | ":" `isSuffixOf` str = show str
+ | not (any dodgy str) && not (null str) = str
+ | otherwise = show str
where
dodgy c = isSpace c || c == ','
-
-- | Pretty-print free-format text, ensuring that it is vertically aligned,
-- and with blank lines replaced by dots for correct re-parsing.
showFreeText :: String -> PP.Doc
showFreeText "" = mempty
-showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s ]
+showFreeText s = PP.vcat [PP.text (if null l then "." else l) | l <- lines_ s]
-- | Pretty-print free-format text.
-- Since @cabal-version: 3.0@ we don't replace blank lines with dots.
@@ -97,14 +107,14 @@ showFreeText s = PP.vcat [ PP.text (if null l then "." else l) | l <- lines_ s
-- @since 3.0.0.0
showFreeTextV3 :: String -> PP.Doc
showFreeTextV3 "" = mempty
-showFreeTextV3 s = PP.vcat [ PP.text l | l <- lines_ s ]
+showFreeTextV3 s = PP.vcat [PP.text l | l <- lines_ s]
-- | 'lines_' breaks a string up into a list of strings at newline
-- characters. The resulting strings do not contain newlines.
-lines_ :: String -> [String]
+lines_ :: String -> [String]
lines_ [] = [""]
-lines_ s =
- let (l, s') = break (== '\n') s
- in l : case s' of
- [] -> []
- (_:s'') -> lines_ s''
+lines_ s =
+ let (l, s') = break (== '\n') s
+ in l : case s' of
+ [] -> []
+ (_ : s'') -> lines_ s''
diff --git a/Cabal-syntax/src/Distribution/SPDX.hs b/Cabal-syntax/src/Distribution/SPDX.hs
index f3f4fe284e25b93c6fb487c0b6d59d4c3e11b5a1..a21c726fefe2dc73b23c74c595ed52804191aab4 100644
--- a/Cabal-syntax/src/Distribution/SPDX.hs
+++ b/Cabal-syntax/src/Distribution/SPDX.hs
@@ -1,40 +1,45 @@
-- | This module implements SPDX specification version 2.1 with a version 3.0 license list.
--
-- Specification is available on <https://spdx.org/specifications>
-module Distribution.SPDX (
- -- * License
- License (..),
+module Distribution.SPDX
+ ( -- * License
+ License (..)
+
-- * License expression
- LicenseExpression (..),
- SimpleLicenseExpression (..),
- simpleLicenseExpression,
+ , LicenseExpression (..)
+ , SimpleLicenseExpression (..)
+ , simpleLicenseExpression
+
-- * License identifier
- LicenseId (..),
- licenseId,
- licenseName,
- licenseIsOsiApproved,
- mkLicenseId,
- licenseIdList,
+ , LicenseId (..)
+ , licenseId
+ , licenseName
+ , licenseIsOsiApproved
+ , mkLicenseId
+ , licenseIdList
+
-- * License exception
- LicenseExceptionId (..),
- licenseExceptionId,
- licenseExceptionName,
- mkLicenseExceptionId,
- licenseExceptionIdList,
+ , LicenseExceptionId (..)
+ , licenseExceptionId
+ , licenseExceptionName
+ , mkLicenseExceptionId
+ , licenseExceptionIdList
+
-- * License reference
- LicenseRef,
- licenseRef,
- licenseDocumentRef,
- mkLicenseRef,
- mkLicenseRef',
+ , LicenseRef
+ , licenseRef
+ , licenseDocumentRef
+ , mkLicenseRef
+ , mkLicenseRef'
+
-- * License list version
- LicenseListVersion (..),
- cabalSpecVersionToSPDXListVersion,
- ) where
+ , LicenseListVersion (..)
+ , cabalSpecVersionToSPDXListVersion
+ ) where
-import Distribution.SPDX.LicenseExceptionId
import Distribution.SPDX.License
-import Distribution.SPDX.LicenseId
+import Distribution.SPDX.LicenseExceptionId
import Distribution.SPDX.LicenseExpression
-import Distribution.SPDX.LicenseReference
+import Distribution.SPDX.LicenseId
import Distribution.SPDX.LicenseListVersion
+import Distribution.SPDX.LicenseReference
diff --git a/Cabal-syntax/src/Distribution/SPDX/License.hs b/Cabal-syntax/src/Distribution/SPDX/License.hs
index c5ffbef572419626f2a138cb7b727d080bdc6095..af271e9115ad5675aaa99aa770e945fab5f65bda 100644
--- a/Cabal-syntax/src/Distribution/SPDX/License.hs
+++ b/Cabal-syntax/src/Distribution/SPDX/License.hs
@@ -1,14 +1,15 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.SPDX.License (
- License (..),
- ) where
-import Prelude ()
+module Distribution.SPDX.License
+ ( License (..)
+ ) where
+
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import Distribution.SPDX.LicenseExpression
import qualified Distribution.Compat.CharParsing as P
@@ -35,24 +36,23 @@ import qualified Text.PrettyPrint as Disp
-- * @PublicDomain@ isn't covered. Consider using CC0.
-- See <https://wiki.spdx.org/view/Legal_Team/Decisions/Dealing_with_Public_Domain_within_SPDX_Files>
-- for more information.
---
data License
- = NONE
- -- ^ if the package contains no license information whatsoever; or
- | License LicenseExpression
- -- ^ A valid SPDX License Expression as defined in Appendix IV.
+ = -- | if the package contains no license information whatsoever; or
+ NONE
+ | -- | A valid SPDX License Expression as defined in Appendix IV.
+ License LicenseExpression
deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
instance Binary License
instance Structured License
instance NFData License where
- rnf NONE = ()
- rnf (License l) = rnf l
+ rnf NONE = ()
+ rnf (License l) = rnf l
instance Pretty License where
- pretty NONE = Disp.text "NONE"
- pretty (License l) = pretty l
+ pretty NONE = Disp.text "NONE"
+ pretty (License l) = pretty l
-- |
-- >>> eitherParsec "BSD-3-Clause AND MIT" :: Either String License
@@ -60,6 +60,5 @@ instance Pretty License where
--
-- >>> eitherParsec "NONE" :: Either String License
-- Right NONE
---
instance Parsec License where
- parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec
+ parsec = NONE <$ P.try (P.string "NONE") <|> License <$> parsec
diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs
index a59e386e1f30b7073aec90c88d4fc350dcc90d3b..c77314746f8f673a9d24e86b9ce84de206cd7240 100644
--- a/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs
+++ b/Cabal-syntax/src/Distribution/SPDX/LicenseExpression.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Distribution.SPDX.LicenseExpression (
- LicenseExpression (..),
- SimpleLicenseExpression (..),
- simpleLicenseExpression,
- ) where
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.SPDX.LicenseExpression
+ ( LicenseExpression (..)
+ , SimpleLicenseExpression (..)
+ , simpleLicenseExpression
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -15,10 +16,10 @@ import Distribution.SPDX.LicenseExceptionId
import Distribution.SPDX.LicenseId
import Distribution.SPDX.LicenseListVersion
import Distribution.SPDX.LicenseReference
-import Distribution.Utils.Generic (isAsciiAlphaNum)
+import Distribution.Utils.Generic (isAsciiAlphaNum)
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- | SPDX License Expression.
--
@@ -39,20 +40,20 @@ import qualified Text.PrettyPrint as Disp
-- license expression = 1*1(simple expression / compound expression)
-- @
data LicenseExpression
- = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId)
- | EAnd !LicenseExpression !LicenseExpression
- | EOr !LicenseExpression !LicenseExpression
- deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
+ = ELicense !SimpleLicenseExpression !(Maybe LicenseExceptionId)
+ | EAnd !LicenseExpression !LicenseExpression
+ | EOr !LicenseExpression !LicenseExpression
+ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
-- | Simple License Expressions.
data SimpleLicenseExpression
- = ELicenseId LicenseId
- -- ^ An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@
- | ELicenseIdPlus LicenseId
- -- ^ An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@
- | ELicenseRef LicenseRef
- -- ^ A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@
- deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
+ = -- | An SPDX License List Short Form Identifier. For example: @GPL-2.0-only@
+ ELicenseId LicenseId
+ | -- | An SPDX License List Short Form Identifier with a unary"+" operator suffix to represent the current version of the license or any later version. For example: @GPL-2.0+@
+ ELicenseIdPlus LicenseId
+ | -- | A SPDX user defined license reference: For example: @LicenseRef-23@, @LicenseRef-MIT-Style-1@, or @DocumentRef-spdx-tool-1.2:LicenseRef-MIT-Style-2@
+ ELicenseRef LicenseRef
+ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
simpleLicenseExpression :: LicenseId -> LicenseExpression
simpleLicenseExpression i = ELicense (ELicenseId i) Nothing
@@ -63,41 +64,42 @@ instance Structured SimpleLicenseExpression
instance Structured LicenseExpression
instance Pretty LicenseExpression where
- pretty = go 0
- where
- go :: Int -> LicenseExpression -> Disp.Doc
- go _ (ELicense lic exc) =
- let doc = pretty lic
- in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc
- go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2
- go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2
-
-
- parens False doc = doc
- parens True doc = Disp.parens doc
+ pretty = go 0
+ where
+ go :: Int -> LicenseExpression -> Disp.Doc
+ go _ (ELicense lic exc) =
+ let doc = pretty lic
+ in maybe id (\e d -> d <+> Disp.text "WITH" <+> pretty e) exc doc
+ go d (EAnd e1 e2) = parens (d < 0) $ go 0 e1 <+> Disp.text "AND" <+> go 0 e2
+ go d (EOr e1 e2) = parens (d < 1) $ go 1 e1 <+> Disp.text "OR" <+> go 1 e2
+
+ parens False doc = doc
+ parens True doc = Disp.parens doc
instance Pretty SimpleLicenseExpression where
- pretty (ELicenseId i) = pretty i
- pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+'
- pretty (ELicenseRef r) = pretty r
+ pretty (ELicenseId i) = pretty i
+ pretty (ELicenseIdPlus i) = pretty i <<>> Disp.char '+'
+ pretty (ELicenseRef r) = pretty r
instance Parsec SimpleLicenseExpression where
- parsec = idstring >>= simple where
- simple n
- | Just l <- "LicenseRef-" `isPrefixOfMaybe` n =
- maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l
- | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do
- _ <- P.string ":LicenseRef-"
- l <- idstring
- maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l
- | otherwise = do
- v <- askCabalSpecVersion
- l <- maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $
- mkLicenseId (cabalSpecVersionToSPDXListVersion v) n
- orLater <- isJust <$> P.optional (P.char '+')
- if orLater
- then return (ELicenseIdPlus l)
- else return (ELicenseId l)
+ parsec = idstring >>= simple
+ where
+ simple n
+ | Just l <- "LicenseRef-" `isPrefixOfMaybe` n =
+ maybe (fail $ "Incorrect LicenseRef format: " ++ n) (return . ELicenseRef) $ mkLicenseRef Nothing l
+ | Just d <- "DocumentRef-" `isPrefixOfMaybe` n = do
+ _ <- P.string ":LicenseRef-"
+ l <- idstring
+ maybe (fail $ "Incorrect LicenseRef format:" ++ n) (return . ELicenseRef) $ mkLicenseRef (Just d) l
+ | otherwise = do
+ v <- askCabalSpecVersion
+ l <-
+ maybe (fail $ "Unknown SPDX license identifier: '" ++ n ++ "' " ++ licenseIdMigrationMessage n) return $
+ mkLicenseId (cabalSpecVersionToSPDXListVersion v) n
+ orLater <- isJust <$> P.optional (P.char '+')
+ if orLater
+ then return (ELicenseIdPlus l)
+ else return (ELicenseId l)
idstring :: P.CharParsing m => m String
idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
@@ -105,43 +107,43 @@ idstring = P.munch1 $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
-- returns suffix part
isPrefixOfMaybe :: Eq a => [a] -> [a] -> Maybe [a]
isPrefixOfMaybe pfx s
- | pfx `isPrefixOf` s = Just (drop (length pfx) s)
- | otherwise = Nothing
+ | pfx `isPrefixOf` s = Just (drop (length pfx) s)
+ | otherwise = Nothing
instance Parsec LicenseExpression where
- parsec = expr
- where
- expr = compoundOr
+ parsec = expr
+ where
+ expr = compoundOr
- simple = do
- s <- parsec
- exc <- exception
- return $ ELicense s exc
+ simple = do
+ s <- parsec
+ exc <- exception
+ return $ ELicense s exc
- exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec
+ exception = P.optional $ P.try (spaces1 *> P.string "WITH" *> spaces1) *> parsec
- compoundOr = do
- x <- compoundAnd
- l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr
- return $ maybe id (flip EOr) l x
+ compoundOr = do
+ x <- compoundAnd
+ l <- P.optional $ P.try (spaces1 *> P.string "OR" *> spaces1) *> compoundOr
+ return $ maybe id (flip EOr) l x
- compoundAnd = do
- x <- compound
- l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd
- return $ maybe id (flip EAnd) l x
+ compoundAnd = do
+ x <- compound
+ l <- P.optional $ P.try (spaces1 *> P.string "AND" *> spaces1) *> compoundAnd
+ return $ maybe id (flip EAnd) l x
- compound = braces <|> simple
+ compound = braces <|> simple
- -- NOTE: we require that there's a space around AND & OR operators,
- -- i.e. @(MIT)AND(MIT)@ will cause parse-error.
- braces = do
- _ <- P.char '('
- _ <- P.spaces
- x <- expr
- _ <- P.char ')'
- return x
+ -- NOTE: we require that there's a space around AND & OR operators,
+ -- i.e. @(MIT)AND(MIT)@ will cause parse-error.
+ braces = do
+ _ <- P.char '('
+ _ <- P.spaces
+ x <- expr
+ _ <- P.char ')'
+ return x
- spaces1 = P.space *> P.spaces
+ spaces1 = P.space *> P.spaces
-- notes:
--
@@ -152,11 +154,11 @@ instance Parsec LicenseExpression where
-- We handle that by having greedy 'idstring' parser, so MITAND would parse as invalid license identifier.
instance NFData LicenseExpression where
- rnf (ELicense s e) = rnf s `seq` rnf e
- rnf (EAnd x y) = rnf x `seq` rnf y
- rnf (EOr x y) = rnf x `seq` rnf y
+ rnf (ELicense s e) = rnf s `seq` rnf e
+ rnf (EAnd x y) = rnf x `seq` rnf y
+ rnf (EOr x y) = rnf x `seq` rnf y
instance NFData SimpleLicenseExpression where
- rnf (ELicenseId i) = rnf i
- rnf (ELicenseIdPlus i) = rnf i
- rnf (ELicenseRef r) = rnf r
+ rnf (ELicenseId i) = rnf i
+ rnf (ELicenseIdPlus i) = rnf i
+ rnf (ELicenseRef r) = rnf r
diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs
index 467405a0b59a609299678c4748295204d6408d0a..9aeb6280454134ad0ae08208a8a8112e99f16b7f 100644
--- a/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs
+++ b/Cabal-syntax/src/Distribution/SPDX/LicenseListVersion.hs
@@ -1,18 +1,18 @@
-module Distribution.SPDX.LicenseListVersion (
- LicenseListVersion (..),
- cabalSpecVersionToSPDXListVersion,
- ) where
+module Distribution.SPDX.LicenseListVersion
+ ( LicenseListVersion (..)
+ , cabalSpecVersionToSPDXListVersion
+ ) where
import Distribution.CabalSpecVersion
-- | SPDX License List version @Cabal@ is aware of.
data LicenseListVersion
- = LicenseListVersion_3_0
- | LicenseListVersion_3_2
- | LicenseListVersion_3_6
- | LicenseListVersion_3_9
- | LicenseListVersion_3_10
- | LicenseListVersion_3_16
+ = LicenseListVersion_3_0
+ | LicenseListVersion_3_2
+ | LicenseListVersion_3_6
+ | LicenseListVersion_3_9
+ | LicenseListVersion_3_10
+ | LicenseListVersion_3_16
deriving (Eq, Ord, Show, Enum, Bounded)
cabalSpecVersionToSPDXListVersion :: CabalSpecVersion -> LicenseListVersion
@@ -21,4 +21,4 @@ cabalSpecVersionToSPDXListVersion CabalSpecV3_6 = LicenseListVersion_3_10
cabalSpecVersionToSPDXListVersion CabalSpecV3_4 = LicenseListVersion_3_9
cabalSpecVersionToSPDXListVersion CabalSpecV3_0 = LicenseListVersion_3_6
cabalSpecVersionToSPDXListVersion CabalSpecV2_4 = LicenseListVersion_3_2
-cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0
+cabalSpecVersionToSPDXListVersion _ = LicenseListVersion_3_0
diff --git a/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs b/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs
index 3f6e754bccadab83754897b3f5f483e0490c6dac..949d6c4d15d1c02172112f921a79e34db6c7932e 100644
--- a/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs
+++ b/Cabal-syntax/src/Distribution/SPDX/LicenseReference.hs
@@ -1,28 +1,29 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.SPDX.LicenseReference (
- LicenseRef,
- licenseRef,
- licenseDocumentRef,
- mkLicenseRef,
- mkLicenseRef',
- ) where
-import Prelude ()
+module Distribution.SPDX.LicenseReference
+ ( LicenseRef
+ , licenseRef
+ , licenseDocumentRef
+ , mkLicenseRef
+ , mkLicenseRef'
+ ) where
+
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Utils.Generic (isAsciiAlphaNum)
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.Utils.Generic (isAsciiAlphaNum)
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-- | A user defined license reference denoted by @LicenseRef-[idstring]@ (for a license not on the SPDX License List);
data LicenseRef = LicenseRef
- { _lrDocument :: !(Maybe String)
- , _lrLicense :: !String
- }
+ { _lrDocument :: !(Maybe String)
+ , _lrLicense :: !String
+ }
deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
-- | License reference.
@@ -37,44 +38,45 @@ instance Binary LicenseRef
instance Structured LicenseRef
instance NFData LicenseRef where
- rnf (LicenseRef d l) = rnf d `seq` rnf l
+ rnf (LicenseRef d l) = rnf d `seq` rnf l
instance Pretty LicenseRef where
- pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l
- pretty (LicenseRef (Just d) l) =
- Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l
+ pretty (LicenseRef Nothing l) = Disp.text "LicenseRef-" <<>> Disp.text l
+ pretty (LicenseRef (Just d) l) =
+ Disp.text "DocumentRef-" <<>> Disp.text d <<>> Disp.char ':' <<>> Disp.text "LicenseRef-" <<>> Disp.text l
instance Parsec LicenseRef where
- parsec = name <|> doc
- where
- name = do
- _ <- P.string "LicenseRef-"
- n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
- pure (LicenseRef Nothing n)
+ parsec = name <|> doc
+ where
+ name = do
+ _ <- P.string "LicenseRef-"
+ n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
+ pure (LicenseRef Nothing n)
- doc = do
- _ <- P.string "DocumentRef-"
- d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
- _ <- P.char ':'
- _ <- P.string "LicenseRef-"
- n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
- pure (LicenseRef (Just d) n)
+ doc = do
+ _ <- P.string "DocumentRef-"
+ d <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
+ _ <- P.char ':'
+ _ <- P.string "LicenseRef-"
+ n <- some $ P.satisfy $ \c -> isAsciiAlphaNum c || c == '-' || c == '.'
+ pure (LicenseRef (Just d) n)
-- | Create 'LicenseRef' from optional document ref and name.
mkLicenseRef :: Maybe String -> String -> Maybe LicenseRef
mkLicenseRef d l = do
- d' <- traverse checkIdString d
- l' <- checkIdString l
- pure (LicenseRef d' l')
+ d' <- traverse checkIdString d
+ l' <- checkIdString l
+ pure (LicenseRef d' l')
where
checkIdString s
- | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s
- | otherwise = Nothing
+ | all (\c -> isAsciiAlphaNum c || c == '-' || c == '.') s = Just s
+ | otherwise = Nothing
-- | Like 'mkLicenseRef' but convert invalid characters into @-@.
mkLicenseRef' :: Maybe String -> String -> LicenseRef
mkLicenseRef' d l = LicenseRef (fmap f d) (f l)
where
f = map g
- g c | isAsciiAlphaNum c || c == '-' || c == '.' = c
- | otherwise = '-'
+ g c
+ | isAsciiAlphaNum c || c == '-' || c == '.' = c
+ | otherwise = '-'
diff --git a/Cabal-syntax/src/Distribution/System.hs b/Cabal-syntax/src/Distribution/System.hs
index 68bda631f198af5043e2109f82ec94dab057a598..5142bf523b13909662f93329745656dee8b48fed 100644
--- a/Cabal-syntax/src/Distribution/System.hs
+++ b/Cabal-syntax/src/Distribution/System.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.System
-- Copyright : Duncan Coutts 2007-2008
@@ -17,41 +18,40 @@
-- do not agree on using the same strings for the same platforms! (In
-- particular see the controversy over \"windows\" vs \"mingw32\"). So to make it
-- more consistent and easy to use we have an 'OS' enumeration.
---
-module Distribution.System (
- -- * Operating System
- OS(..),
- buildOS,
-
- -- * Machine Architecture
- Arch(..),
- buildArch,
-
- -- * Platform is a pair of arch and OS
- Platform(..),
- buildPlatform,
- platformFromTriple,
-
- -- * Internal
- knownOSs,
- knownArches,
-
- -- * Classification
- ClassificationStrictness (..),
- classifyOS,
- classifyArch,
+module Distribution.System
+ ( -- * Operating System
+ OS (..)
+ , buildOS
+
+ -- * Machine Architecture
+ , Arch (..)
+ , buildArch
+
+ -- * Platform is a pair of arch and OS
+ , Platform (..)
+ , buildPlatform
+ , platformFromTriple
+
+ -- * Internal
+ , knownOSs
+ , knownArches
+
+ -- * Classification
+ , ClassificationStrictness (..)
+ , classifyOS
+ , classifyArch
) where
+import Control.Applicative (Applicative (..))
+import Distribution.Compat.Prelude hiding (Applicative (..))
import Prelude ()
-import Distribution.Compat.Prelude hiding (Applicative(..))
-import Control.Applicative (Applicative(..))
#if !MIN_VERSION_base(4,10,0)
import Control.Applicative (liftA2)
#endif
-import qualified System.Info (os, arch)
import Distribution.Utils.Generic (lowercase)
+import qualified System.Info (arch, os)
import Distribution.Parsec
import Distribution.Pretty
@@ -75,11 +75,12 @@ import qualified Text.PrettyPrint as Disp
-- The 'Compat' classification allows us to recognise aliases that are already
-- in common use but it allows us to distinguish them from the canonical name
-- which enables us to warn about such deprecated aliases.
---
data ClassificationStrictness = Permissive | Compat | Strict
-- ------------------------------------------------------------
+
-- * Operating System
+
-- ------------------------------------------------------------
-- | These are the known OS names: Linux, Windows, OSX
@@ -93,17 +94,25 @@ data ClassificationStrictness = Permissive | Compat | Strict
-- * Hurd alias: gnu
-- * FreeBSD alias: kfreebsdgnu
-- * Solaris alias: solaris2
---
-data OS = Linux | Windows | OSX -- tier 1 desktop OSs
- | FreeBSD | OpenBSD | NetBSD -- other free Unix OSs
- | DragonFly
- | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs
- | HaLVM -- bare metal / VMs / hypervisors
- | Hurd -- GNU's microkernel
- | IOS | Android -- mobile OSs
- | Ghcjs
- | Wasi
- | OtherOS String
+data OS
+ = Linux
+ | Windows
+ | OSX -- tier 1 desktop OSs
+ | FreeBSD
+ | OpenBSD
+ | NetBSD -- other free Unix OSs
+ | DragonFly
+ | Solaris
+ | AIX
+ | HPUX
+ | IRIX -- ageing Unix OSs
+ | HaLVM -- bare metal / VMs / hypervisors
+ | Hurd -- GNU's microkernel
+ | IOS
+ | Android -- mobile OSs
+ | Ghcjs
+ | Wasi
+ | OtherOS String
deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)
instance Binary OS
@@ -111,50 +120,63 @@ instance Structured OS
instance NFData OS where rnf = genericRnf
knownOSs :: [OS]
-knownOSs = [Linux, Windows, OSX
- ,FreeBSD, OpenBSD, NetBSD, DragonFly
- ,Solaris, AIX, HPUX, IRIX
- ,HaLVM
- ,Hurd
- ,IOS, Android
- ,Ghcjs
- ,Wasi]
+knownOSs =
+ [ Linux
+ , Windows
+ , OSX
+ , FreeBSD
+ , OpenBSD
+ , NetBSD
+ , DragonFly
+ , Solaris
+ , AIX
+ , HPUX
+ , IRIX
+ , HaLVM
+ , Hurd
+ , IOS
+ , Android
+ , Ghcjs
+ , Wasi
+ ]
osAliases :: ClassificationStrictness -> OS -> [String]
osAliases Permissive Windows = ["mingw32", "win32", "cygwin32"]
-osAliases Compat Windows = ["mingw32", "win32"]
-osAliases _ OSX = ["darwin"]
-osAliases _ Hurd = ["gnu"]
+osAliases Compat Windows = ["mingw32", "win32"]
+osAliases _ OSX = ["darwin"]
+osAliases _ Hurd = ["gnu"]
osAliases Permissive FreeBSD = ["kfreebsdgnu"]
-osAliases Compat FreeBSD = ["kfreebsdgnu"]
+osAliases Compat FreeBSD = ["kfreebsdgnu"]
osAliases Permissive Solaris = ["solaris2"]
-osAliases Compat Solaris = ["solaris2"]
+osAliases Compat Solaris = ["solaris2"]
osAliases Permissive Android = ["linux-android", "linux-androideabi", "linux-androideabihf"]
-osAliases Compat Android = ["linux-android"]
-osAliases _ _ = []
+osAliases Compat Android = ["linux-android"]
+osAliases _ _ = []
instance Pretty OS where
pretty (OtherOS name) = Disp.text name
- pretty other = Disp.text (lowercase (show other))
+ pretty other = Disp.text (lowercase (show other))
instance Parsec OS where
parsec = classifyOS Compat <$> parsecIdent
-
-
classifyOS :: ClassificationStrictness -> String -> OS
classifyOS strictness s =
fromMaybe (OtherOS s) $ lookup (lowercase s) osMap
where
- osMap = [ (name, os)
- | os <- knownOSs
- , name <- prettyShow os : osAliases strictness os ]
+ osMap =
+ [ (name, os)
+ | os <- knownOSs
+ , name <- prettyShow os : osAliases strictness os
+ ]
buildOS :: OS
buildOS = classifyOS Permissive System.Info.os
-- ------------------------------------------------------------
+
-- * Machine Architecture
+
-- ------------------------------------------------------------
-- | These are the known Arches: I386, X86_64, PPC, PPC64, Sparc,
@@ -168,15 +190,27 @@ buildOS = classifyOS Permissive System.Info.os
-- * Mips aliases: mipsel, mipseb
-- * Arm aliases: armeb, armel
-- * AArch64 aliases: arm64
---
-data Arch = I386 | X86_64 | PPC | PPC64 | Sparc
- | Arm | AArch64 | Mips | SH
- | IA64 | S390 | S390X
- | Alpha | Hppa | Rs6000
- | M68k | Vax
- | JavaScript
- | Wasm32
- | OtherArch String
+data Arch
+ = I386
+ | X86_64
+ | PPC
+ | PPC64
+ | Sparc
+ | Arm
+ | AArch64
+ | Mips
+ | SH
+ | IA64
+ | S390
+ | S390X
+ | Alpha
+ | Hppa
+ | Rs6000
+ | M68k
+ | Vax
+ | JavaScript
+ | Wasm32
+ | OtherArch String
deriving (Eq, Generic, Ord, Show, Read, Typeable, Data)
instance Binary Arch
@@ -184,28 +218,42 @@ instance Structured Arch
instance NFData Arch where rnf = genericRnf
knownArches :: [Arch]
-knownArches = [I386, X86_64, PPC, PPC64, Sparc
- ,Arm, AArch64, Mips, SH
- ,IA64, S390, S390X
- ,Alpha, Hppa, Rs6000
- ,M68k, Vax
- ,JavaScript
- ,Wasm32]
+knownArches =
+ [ I386
+ , X86_64
+ , PPC
+ , PPC64
+ , Sparc
+ , Arm
+ , AArch64
+ , Mips
+ , SH
+ , IA64
+ , S390
+ , S390X
+ , Alpha
+ , Hppa
+ , Rs6000
+ , M68k
+ , Vax
+ , JavaScript
+ , Wasm32
+ ]
archAliases :: ClassificationStrictness -> Arch -> [String]
-archAliases Strict _ = []
-archAliases Compat _ = []
-archAliases _ PPC = ["powerpc"]
-archAliases _ PPC64 = ["powerpc64", "powerpc64le"]
-archAliases _ Sparc = ["sparc64", "sun4"]
-archAliases _ Mips = ["mipsel", "mipseb"]
-archAliases _ Arm = ["armeb", "armel"]
-archAliases _ AArch64 = ["arm64"]
-archAliases _ _ = []
+archAliases Strict _ = []
+archAliases Compat _ = []
+archAliases _ PPC = ["powerpc"]
+archAliases _ PPC64 = ["powerpc64", "powerpc64le"]
+archAliases _ Sparc = ["sparc64", "sun4"]
+archAliases _ Mips = ["mipsel", "mipseb"]
+archAliases _ Arm = ["armeb", "armel"]
+archAliases _ AArch64 = ["arm64"]
+archAliases _ _ = []
instance Pretty Arch where
pretty (OtherArch name) = Disp.text name
- pretty other = Disp.text (lowercase (show other))
+ pretty other = Disp.text (lowercase (show other))
instance Parsec Arch where
parsec = classifyArch Strict <$> parsecIdent
@@ -214,15 +262,19 @@ classifyArch :: ClassificationStrictness -> String -> Arch
classifyArch strictness s =
fromMaybe (OtherArch s) $ lookup (lowercase s) archMap
where
- archMap = [ (name, arch)
- | arch <- knownArches
- , name <- prettyShow arch : archAliases strictness arch ]
+ archMap =
+ [ (name, arch)
+ | arch <- knownArches
+ , name <- prettyShow arch : archAliases strictness arch
+ ]
buildArch :: Arch
buildArch = classifyArch Permissive System.Info.arch
-- ------------------------------------------------------------
+
-- * Platform
+
-- ------------------------------------------------------------
data Platform = Platform Arch OS
@@ -236,25 +288,25 @@ instance Pretty Platform where
pretty (Platform arch os) = pretty arch <<>> Disp.char '-' <<>> pretty os
instance Parsec Platform where
- -- TODO: there are ambiguous platforms like: `arch-word-os`
- -- which could be parsed as
- -- * Platform "arch-word" "os"
- -- * Platform "arch" "word-os"
- -- We could support that preferring variants 'OtherOS' or 'OtherArch'
- --
- -- For now we split into arch and os parts on the first dash.
- parsec = do
- arch <- parsecDashlessArch
- _ <- P.char '-'
- os <- parsec
- return (Platform arch os)
- where
- parsecDashlessArch = classifyArch Strict <$> dashlessIdent
-
- dashlessIdent = liftA2 (:) firstChar rest
- where
- firstChar = P.satisfy isAlpha
- rest = P.munch (\c -> isAlphaNum c || c == '_')
+ -- TODO: there are ambiguous platforms like: `arch-word-os`
+ -- which could be parsed as
+ -- * Platform "arch-word" "os"
+ -- * Platform "arch" "word-os"
+ -- We could support that preferring variants 'OtherOS' or 'OtherArch'
+ --
+ -- For now we split into arch and os parts on the first dash.
+ parsec = do
+ arch <- parsecDashlessArch
+ _ <- P.char '-'
+ os <- parsec
+ return (Platform arch os)
+ where
+ parsecDashlessArch = classifyArch Strict <$> dashlessIdent
+
+ dashlessIdent = liftA2 (:) firstChar rest
+ where
+ firstChar = P.satisfy isAlpha
+ rest = P.munch (\c -> isAlphaNum c || c == '_')
-- | The platform Cabal was compiled on. In most cases,
-- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're
@@ -268,17 +320,18 @@ parsecIdent :: CabalParsing m => m String
parsecIdent = (:) <$> firstChar <*> rest
where
firstChar = P.satisfy isAlpha
- rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
+ rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
platformFromTriple :: String -> Maybe Platform
platformFromTriple triple =
- either (const Nothing) Just $ explicitEitherParsec parseTriple triple
- where parseWord = P.munch1 (\c -> isAlphaNum c || c == '_')
- parseTriple = do
- arch <- fmap (classifyArch Permissive) parseWord
- _ <- P.char '-'
- _ <- parseWord -- Skip vendor
- _ <- P.char '-'
- os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like
- -- 'nto-qnx'
- return $ Platform arch os
+ either (const Nothing) Just $ explicitEitherParsec parseTriple triple
+ where
+ parseWord = P.munch1 (\c -> isAlphaNum c || c == '_')
+ parseTriple = do
+ arch <- fmap (classifyArch Permissive) parseWord
+ _ <- P.char '-'
+ _ <- parseWord -- Skip vendor
+ _ <- P.char '-'
+ os <- fmap (classifyOS Permissive) parsecIdent -- OS may have hyphens, like
+ -- 'nto-qnx'
+ return $ Platform arch os
diff --git a/Cabal-syntax/src/Distribution/Text.hs b/Cabal-syntax/src/Distribution/Text.hs
index 258b4dc835fb43ac7588dc527889d8cb3c2d9aad..0589e35261e70f914160e69e3176109059245aed 100644
--- a/Cabal-syntax/src/Distribution/Text.hs
+++ b/Cabal-syntax/src/Distribution/Text.hs
@@ -1,9 +1,10 @@
-- Since @3.0@ this is a compat module.
module Distribution.Text (display, simpleParse) where
+
{- {-# DEPRECATED "Use Distribution.Parsec or Distribution.Pretty" #-} -}
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
display :: Pretty a => a -> String
display = prettyShow
diff --git a/Cabal-syntax/src/Distribution/Types/AbiDependency.hs b/Cabal-syntax/src/Distribution/Types/AbiDependency.hs
index 8442bf9d410db89446fe6d8ebd1656c37985a0d1..2f380d15af211b7237865d401daf84a7fe7f3123 100644
--- a/Cabal-syntax/src/Distribution/Types/AbiDependency.hs
+++ b/Cabal-syntax/src/Distribution/Types/AbiDependency.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.AbiDependency where
import Distribution.Compat.Prelude
@@ -9,8 +10,8 @@ import Distribution.Parsec
import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.Package as Package
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.Package as Package
+import qualified Text.PrettyPrint as Disp
-- | An ABI dependency is a dependency on a library which also
-- records the ABI hash ('abiHash') of the library it depends
@@ -22,22 +23,22 @@ import qualified Text.PrettyPrint as Disp
-- is critical if we are shadowing libraries; differences in the
-- ABI hash let us know what packages get shadowed by the new version
-- of a package.
-data AbiDependency = AbiDependency {
- depUnitId :: Package.UnitId,
- depAbiHash :: Package.AbiHash
- }
+data AbiDependency = AbiDependency
+ { depUnitId :: Package.UnitId
+ , depAbiHash :: Package.AbiHash
+ }
deriving (Eq, Generic, Read, Show, Typeable)
instance Pretty AbiDependency where
- pretty (AbiDependency uid abi) =
- pretty uid <<>> Disp.char '=' <<>> pretty abi
-
-instance Parsec AbiDependency where
- parsec = do
- uid <- parsec
- _ <- P.char '='
- abi <- parsec
- return (AbiDependency uid abi)
+ pretty (AbiDependency uid abi) =
+ pretty uid <<>> Disp.char '=' <<>> pretty abi
+
+instance Parsec AbiDependency where
+ parsec = do
+ uid <- parsec
+ _ <- P.char '='
+ abi <- parsec
+ return (AbiDependency uid abi)
instance Binary AbiDependency
instance Structured AbiDependency
diff --git a/Cabal-syntax/src/Distribution/Types/AbiHash.hs b/Cabal-syntax/src/Distribution/Types/AbiHash.hs
index 6c154066e8121c7c3484778fff9bc243baca374b..a1be416c4bae2cd36f7f0f0a95898ddf1d5282ca 100644
--- a/Cabal-syntax/src/Distribution/Types/AbiHash.hs
+++ b/Cabal-syntax/src/Distribution/Types/AbiHash.hs
@@ -3,16 +3,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.AbiHash
- ( AbiHash, unAbiHash, mkAbiHash
+ ( AbiHash
+ , unAbiHash
+ , mkAbiHash
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
+import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import Text.PrettyPrint (text)
@@ -25,7 +27,7 @@ import Text.PrettyPrint (text)
--
-- @since 2.0.0.2
newtype AbiHash = AbiHash ShortText
- deriving (Eq, Show, Read, Generic, Typeable)
+ deriving (Eq, Show, Read, Generic, Typeable)
-- | Convert 'AbiHash' to 'String'
--
@@ -48,14 +50,14 @@ mkAbiHash = AbiHash . toShortText
--
-- @since 2.0.0.2
instance IsString AbiHash where
- fromString = mkAbiHash
+ fromString = mkAbiHash
instance Binary AbiHash
instance Structured AbiHash
instance NFData AbiHash where rnf = genericRnf
instance Pretty AbiHash where
- pretty = text . unAbiHash
+ pretty = text . unAbiHash
instance Parsec AbiHash where
- parsec = fmap mkAbiHash (P.munch isAlphaNum)
+ parsec = fmap mkAbiHash (P.munch isAlphaNum)
diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/Cabal-syntax/src/Distribution/Types/Benchmark.hs
index 1f0bb27c7097c8bb861a65449e0e59c1ba4f9af6..be0911432ec386f902d7f57449bc4b8ba0603e68 100644
--- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs
+++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs
@@ -1,20 +1,20 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Benchmark (
- Benchmark(..),
- emptyBenchmark,
- benchmarkType,
- benchmarkModules,
- benchmarkModulesAutogen
-) where
+module Distribution.Types.Benchmark
+ ( Benchmark (..)
+ , emptyBenchmark
+ , benchmarkType
+ , benchmarkModules
+ , benchmarkModulesAutogen
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.BuildInfo
-import Distribution.Types.BenchmarkType
import Distribution.Types.BenchmarkInterface
+import Distribution.Types.BenchmarkType
+import Distribution.Types.BuildInfo
import Distribution.Types.UnqualComponentName
import Distribution.ModuleName
@@ -22,49 +22,57 @@ import Distribution.ModuleName
import qualified Distribution.Types.BuildInfo.Lens as L
-- | A \"benchmark\" stanza in a cabal file.
---
-data Benchmark = Benchmark {
- benchmarkName :: UnqualComponentName,
- benchmarkInterface :: BenchmarkInterface,
- benchmarkBuildInfo :: BuildInfo
- }
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data Benchmark = Benchmark
+ { benchmarkName :: UnqualComponentName
+ , benchmarkInterface :: BenchmarkInterface
+ , benchmarkBuildInfo :: BuildInfo
+ }
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary Benchmark
instance Structured Benchmark
instance NFData Benchmark where rnf = genericRnf
instance L.HasBuildInfo Benchmark where
- buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3)
+ buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3)
instance Monoid Benchmark where
- mempty = Benchmark {
- benchmarkName = mempty,
- benchmarkInterface = mempty,
- benchmarkBuildInfo = mempty
- }
- mappend = (<>)
+ mempty =
+ Benchmark
+ { benchmarkName = mempty
+ , benchmarkInterface = mempty
+ , benchmarkBuildInfo = mempty
+ }
+ mappend = (<>)
instance Semigroup Benchmark where
- a <> b = Benchmark {
- benchmarkName = combine' benchmarkName,
- benchmarkInterface = combine benchmarkInterface,
- benchmarkBuildInfo = combine benchmarkBuildInfo
- }
- where combine field = field a `mappend` field b
- combine' field = case ( unUnqualComponentName $ field a
- , unUnqualComponentName $ field b) of
- ("", _) -> field b
- (_, "") -> field a
- (x, y) -> error $ "Ambiguous values for test field: '"
- ++ x ++ "' and '" ++ y ++ "'"
+ a <> b =
+ Benchmark
+ { benchmarkName = combine' benchmarkName
+ , benchmarkInterface = combine benchmarkInterface
+ , benchmarkBuildInfo = combine benchmarkBuildInfo
+ }
+ where
+ combine field = field a `mappend` field b
+ combine' field = case ( unUnqualComponentName $ field a
+ , unUnqualComponentName $ field b
+ ) of
+ ("", _) -> field b
+ (_, "") -> field a
+ (x, y) ->
+ error $
+ "Ambiguous values for test field: '"
+ ++ x
+ ++ "' and '"
+ ++ y
+ ++ "'"
emptyBenchmark :: Benchmark
emptyBenchmark = mempty
benchmarkType :: Benchmark -> BenchmarkType
benchmarkType benchmark = case benchmarkInterface benchmark of
- BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver
+ BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver
BenchmarkUnsupported benchmarktype -> benchmarktype
-- | Get all the module names from a benchmark.
diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs b/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs
index db46345f5e685040d6d52d468f12e31a49d696ef..40b17330fec4a4af64e7624010cc2e95ffcd8333 100644
--- a/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs
@@ -1,27 +1,27 @@
-module Distribution.Types.Benchmark.Lens (
- Benchmark,
- module Distribution.Types.Benchmark.Lens,
- ) where
+module Distribution.Types.Benchmark.Lens
+ ( Benchmark
+ , module Distribution.Types.Benchmark.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Types.Benchmark (Benchmark)
-import Distribution.Types.BenchmarkInterface (BenchmarkInterface)
-import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.Benchmark (Benchmark)
+import Distribution.Types.BenchmarkInterface (BenchmarkInterface)
+import Distribution.Types.BuildInfo (BuildInfo)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
import qualified Distribution.Types.Benchmark as T
benchmarkName :: Lens' Benchmark UnqualComponentName
-benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s))
+benchmarkName f s = fmap (\x -> s{T.benchmarkName = x}) (f (T.benchmarkName s))
{-# INLINE benchmarkName #-}
benchmarkInterface :: Lens' Benchmark BenchmarkInterface
-benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s))
+benchmarkInterface f s = fmap (\x -> s{T.benchmarkInterface = x}) (f (T.benchmarkInterface s))
{-# INLINE benchmarkInterface #-}
benchmarkBuildInfo :: Lens' Benchmark BuildInfo
-benchmarkBuildInfo f s = fmap (\x -> s { T.benchmarkBuildInfo = x }) (f (T.benchmarkBuildInfo s))
+benchmarkBuildInfo f s = fmap (\x -> s{T.benchmarkBuildInfo = x}) (f (T.benchmarkBuildInfo s))
{-# INLINE benchmarkBuildInfo #-}
diff --git a/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs b/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs
index d9e741fd7b1a3c554d028bdc07985fc908ac74d4..b894e71b791dc87eb7bd115782f45d12420976da 100644
--- a/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs
+++ b/Cabal-syntax/src/Distribution/Types/BenchmarkInterface.hs
@@ -1,12 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.BenchmarkInterface (
- BenchmarkInterface(..),
-) where
+module Distribution.Types.BenchmarkInterface
+ ( BenchmarkInterface (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.BenchmarkType
import Distribution.Version
@@ -15,31 +15,26 @@ import Distribution.Version
--
-- More interfaces may be defined in future, either new revisions or
-- totally new interfaces.
---
-data BenchmarkInterface =
-
- -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark
- -- takes the form of an executable. It returns a zero exit code
- -- for success, non-zero for failure. The stdout and stderr
- -- channels may be logged. Test tooling may pass command line
- -- arguments and/or connect the stdin channel to the test.
- --
- BenchmarkExeV10 Version FilePath
-
- -- | A benchmark that does not conform to one of the above
- -- interfaces for the given reason (e.g. unknown benchmark type).
- --
- | BenchmarkUnsupported BenchmarkType
- deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
+data BenchmarkInterface
+ = -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark
+ -- takes the form of an executable. It returns a zero exit code
+ -- for success, non-zero for failure. The stdout and stderr
+ -- channels may be logged. Test tooling may pass command line
+ -- arguments and/or connect the stdin channel to the test.
+ BenchmarkExeV10 Version FilePath
+ | -- | A benchmark that does not conform to one of the above
+ -- interfaces for the given reason (e.g. unknown benchmark type).
+ BenchmarkUnsupported BenchmarkType
+ deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
instance Binary BenchmarkInterface
instance Structured BenchmarkInterface
instance NFData BenchmarkInterface where rnf = genericRnf
instance Monoid BenchmarkInterface where
- mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion)
- mappend = (<>)
+ mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty nullVersion)
+ mappend = (<>)
instance Semigroup BenchmarkInterface where
- a <> (BenchmarkUnsupported _) = a
- _ <> b = b
+ a <> (BenchmarkUnsupported _) = a
+ _ <> b = b
diff --git a/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs b/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs
index c92bd292c0be0cd241a306426399ebdd2cf7b026..9dd3fad3ff96625d37a9a2afba4ae296ae47d60a 100644
--- a/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs
+++ b/Cabal-syntax/src/Distribution/Types/BenchmarkType.hs
@@ -1,12 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.BenchmarkType (
- BenchmarkType(..),
- knownBenchmarkTypes,
- benchmarkTypeExe,
-) where
+module Distribution.Types.BenchmarkType
+ ( BenchmarkType (..)
+ , knownBenchmarkTypes
+ , benchmarkTypeExe
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -14,31 +14,31 @@ import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Version
-import Text.PrettyPrint (char, text)
+import Text.PrettyPrint (char, text)
-- | The \"benchmark-type\" field in the benchmark stanza.
---
-data BenchmarkType = BenchmarkTypeExe Version
- -- ^ \"type: exitcode-stdio-x.y\"
- | BenchmarkTypeUnknown String Version
- -- ^ Some unknown benchmark type e.g. \"type: foo\"
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data BenchmarkType
+ = -- | \"type: exitcode-stdio-x.y\"
+ BenchmarkTypeExe Version
+ | -- | Some unknown benchmark type e.g. \"type: foo\"
+ BenchmarkTypeUnknown String Version
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary BenchmarkType
instance Structured BenchmarkType
instance NFData BenchmarkType where rnf = genericRnf
knownBenchmarkTypes :: [BenchmarkType]
-knownBenchmarkTypes = [ benchmarkTypeExe ]
+knownBenchmarkTypes = [benchmarkTypeExe]
benchmarkTypeExe :: BenchmarkType
-benchmarkTypeExe = BenchmarkTypeExe (mkVersion [1,0])
+benchmarkTypeExe = BenchmarkTypeExe (mkVersion [1, 0])
instance Pretty BenchmarkType where
- pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver
+ pretty (BenchmarkTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver
pretty (BenchmarkTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver
instance Parsec BenchmarkType where
- parsec = parsecStandard $ \ver name -> case name of
- "exitcode-stdio" -> BenchmarkTypeExe ver
- _ -> BenchmarkTypeUnknown name ver
+ parsec = parsecStandard $ \ver name -> case name of
+ "exitcode-stdio" -> BenchmarkTypeExe ver
+ _ -> BenchmarkTypeUnknown name ver
diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs
index cef7a374428ee68733f347652da338e79c3f2e6e..67efb90955d797f1eed78212be56beaa81da49a2 100644
--- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs
+++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs
@@ -1,223 +1,254 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.BuildInfo (
- BuildInfo(..),
+module Distribution.Types.BuildInfo
+ ( BuildInfo (..)
+ , emptyBuildInfo
+ , allLanguages
+ , allExtensions
+ , usedExtensions
+ , usesTemplateHaskellOrQQ
+ , hcOptions
+ , hcProfOptions
+ , hcSharedOptions
+ , hcStaticOptions
+ ) where
- emptyBuildInfo,
- allLanguages,
- allExtensions,
- usedExtensions,
- usesTemplateHaskellOrQQ,
-
- hcOptions,
- hcProfOptions,
- hcSharedOptions,
- hcStaticOptions,
-) where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.Mixin
import Distribution.Types.Dependency
import Distribution.Types.ExeDependency
import Distribution.Types.LegacyExeDependency
+import Distribution.Types.Mixin
import Distribution.Types.PkgconfigDependency
import Distribution.Utils.Path
-import Distribution.ModuleName
import Distribution.Compiler
+import Distribution.ModuleName
import Language.Haskell.Extension
-- Consider refactoring into executable and library versions.
-data BuildInfo = BuildInfo {
- -- | component is buildable here
- buildable :: Bool,
- -- | Tools needed to build this bit.
- --
- -- This is a legacy field that 'buildToolDepends' largely supersedes.
- --
- -- Unless use are very sure what you are doing, use the functions in
- -- "Distribution.Simple.BuildToolDepends" rather than accessing this
- -- field directly.
- buildTools :: [LegacyExeDependency],
- -- | Haskell tools needed to build this bit
- --
- -- This field is better than 'buildTools' because it allows one to
- -- precisely specify an executable in a package.
- --
- -- Unless use are very sure what you are doing, use the functions in
- -- "Distribution.Simple.BuildToolDepends" rather than accessing this
- -- field directly.
- buildToolDepends :: [ExeDependency],
- cppOptions :: [String], -- ^ options for pre-processing Haskell code
- asmOptions :: [String], -- ^ options for assembler
- cmmOptions :: [String], -- ^ options for C-- compiler
- ccOptions :: [String], -- ^ options for C compiler
- cxxOptions :: [String], -- ^ options for C++ compiler
- ldOptions :: [String], -- ^ options for linker
- hsc2hsOptions :: [String], -- ^ options for hsc2hs
- pkgconfigDepends :: [PkgconfigDependency], -- ^ pkg-config packages that are used
- frameworks :: [String], -- ^support frameworks for Mac OS X
- extraFrameworkDirs:: [String], -- ^ extra locations to find frameworks.
- asmSources :: [FilePath], -- ^ Assembly files.
- cmmSources :: [FilePath], -- ^ C-- files.
- cSources :: [FilePath],
- cxxSources :: [FilePath],
- jsSources :: [FilePath],
- hsSourceDirs :: [SymbolicPath PackageDir SourceDir], -- ^ where to look for the Haskell module hierarchy
- otherModules :: [ModuleName], -- ^ non-exposed or non-main modules
- virtualModules :: [ModuleName], -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package)
- autogenModules :: [ModuleName], -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs
-
- defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified
- otherLanguages :: [Language], -- ^ other languages used within the package
- defaultExtensions :: [Extension], -- ^ language extensions used by all modules
- otherExtensions :: [Extension], -- ^ other language extensions used within the package
- oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions'
-
- extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package
- extraLibsStatic :: [String], -- ^ what libraries to link with when compiling a program fully statically that uses your package
- extraGHCiLibs :: [String], -- ^ if present, overrides extraLibs when package is loaded with GHCi.
- extraBundledLibs :: [String], -- ^ if present, adds libs to hs-libraries, which become part of the package.
- -- Example 1: the Cffi library shipping with the rts, alongside the HSrts-1.0.a,.o,...
- -- Example 2: a library that is being built by a foreign tool (e.g. rust)
- -- and copied and registered together with this library. The
- -- logic on how this library is built will have to be encoded in a
- -- custom Setup for now. Otherwise cabal would need to learn how to
- -- call arbitrary library builders.
- extraLibFlavours :: [String], -- ^ Hidden Flag. This set of strings, will be appended to all libraries when
- -- copying. E.g. [libHS<name>_<flavour> | flavour <- extraLibFlavours]. This
- -- should only be needed in very specific cases, e.g. the `rts` package, where
- -- there are multiple copies of slightly differently built libs.
- extraDynLibFlavours :: [String], -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/
- -- libraries when copying. This is particularly useful with the `rts` package,
- -- where we want different dynamic flavours of the RTS library to be installed.
- extraLibDirs :: [String],
- extraLibDirsStatic :: [String],
- includeDirs :: [FilePath], -- ^directories to find .h files
- includes :: [FilePath], -- ^ The .h files to be found in includeDirs
- autogenIncludes :: [FilePath], -- ^ The .h files to be generated (e.g. by @autoconf@)
- installIncludes :: [FilePath], -- ^ .h files to install with the package
- options :: PerCompilerFlavor [String],
- profOptions :: PerCompilerFlavor [String],
- sharedOptions :: PerCompilerFlavor [String],
- staticOptions :: PerCompilerFlavor [String],
- customFieldsBI :: [(String,String)], -- ^Custom fields starting
- -- with x-, stored in a
- -- simple assoc-list.
- targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target
- mixins :: [Mixin]
- }
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data BuildInfo = BuildInfo
+ { buildable :: Bool
+ -- ^ component is buildable here
+ , buildTools :: [LegacyExeDependency]
+ -- ^ Tools needed to build this bit.
+ --
+ -- This is a legacy field that 'buildToolDepends' largely supersedes.
+ --
+ -- Unless use are very sure what you are doing, use the functions in
+ -- "Distribution.Simple.BuildToolDepends" rather than accessing this
+ -- field directly.
+ , buildToolDepends :: [ExeDependency]
+ -- ^ Haskell tools needed to build this bit
+ --
+ -- This field is better than 'buildTools' because it allows one to
+ -- precisely specify an executable in a package.
+ --
+ -- Unless use are very sure what you are doing, use the functions in
+ -- "Distribution.Simple.BuildToolDepends" rather than accessing this
+ -- field directly.
+ , cppOptions :: [String]
+ -- ^ options for pre-processing Haskell code
+ , asmOptions :: [String]
+ -- ^ options for assembler
+ , cmmOptions :: [String]
+ -- ^ options for C-- compiler
+ , ccOptions :: [String]
+ -- ^ options for C compiler
+ , cxxOptions :: [String]
+ -- ^ options for C++ compiler
+ , ldOptions :: [String]
+ -- ^ options for linker
+ , hsc2hsOptions :: [String]
+ -- ^ options for hsc2hs
+ , pkgconfigDepends :: [PkgconfigDependency]
+ -- ^ pkg-config packages that are used
+ , frameworks :: [String]
+ -- ^ support frameworks for Mac OS X
+ , extraFrameworkDirs :: [String]
+ -- ^ extra locations to find frameworks.
+ , asmSources :: [FilePath]
+ -- ^ Assembly files.
+ , cmmSources :: [FilePath]
+ -- ^ C-- files.
+ , cSources :: [FilePath]
+ , cxxSources :: [FilePath]
+ , jsSources :: [FilePath]
+ , hsSourceDirs :: [SymbolicPath PackageDir SourceDir]
+ -- ^ where to look for the Haskell module hierarchy
+ , otherModules :: [ModuleName]
+ -- ^ non-exposed or non-main modules
+ , virtualModules :: [ModuleName]
+ -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package)
+ , autogenModules :: [ModuleName]
+ -- ^ not present on sdist, Paths_* or user-generated with a custom Setup.hs
+ , defaultLanguage :: Maybe Language
+ -- ^ language used when not explicitly specified
+ , otherLanguages :: [Language]
+ -- ^ other languages used within the package
+ , defaultExtensions :: [Extension]
+ -- ^ language extensions used by all modules
+ , otherExtensions :: [Extension]
+ -- ^ other language extensions used within the package
+ , oldExtensions :: [Extension]
+ -- ^ the old extensions field, treated same as 'defaultExtensions'
+ , extraLibs :: [String]
+ -- ^ what libraries to link with when compiling a program that uses your package
+ , extraLibsStatic :: [String]
+ -- ^ what libraries to link with when compiling a program fully statically that uses your package
+ , extraGHCiLibs :: [String]
+ -- ^ if present, overrides extraLibs when package is loaded with GHCi.
+ , extraBundledLibs :: [String]
+ -- ^ if present, adds libs to hs-libraries, which become part of the package.
+ -- Example 1: the Cffi library shipping with the rts, alongside the HSrts-1.0.a,.o,...
+ -- Example 2: a library that is being built by a foreign tool (e.g. rust)
+ -- and copied and registered together with this library. The
+ -- logic on how this library is built will have to be encoded in a
+ -- custom Setup for now. Otherwise cabal would need to learn how to
+ -- call arbitrary library builders.
+ , extraLibFlavours :: [String]
+ -- ^ Hidden Flag. This set of strings, will be appended to all libraries when
+ -- copying. E.g. [libHS<name>_<flavour> | flavour <- extraLibFlavours]. This
+ -- should only be needed in very specific cases, e.g. the `rts` package, where
+ -- there are multiple copies of slightly differently built libs.
+ , extraDynLibFlavours :: [String]
+ -- ^ Hidden Flag. This set of strings will be appended to all /dynamic/
+ -- libraries when copying. This is particularly useful with the `rts` package,
+ -- where we want different dynamic flavours of the RTS library to be installed.
+ , extraLibDirs :: [String]
+ , extraLibDirsStatic :: [String]
+ , includeDirs :: [FilePath]
+ -- ^ directories to find .h files
+ , includes :: [FilePath]
+ -- ^ The .h files to be found in includeDirs
+ , autogenIncludes :: [FilePath]
+ -- ^ The .h files to be generated (e.g. by @autoconf@)
+ , installIncludes :: [FilePath]
+ -- ^ .h files to install with the package
+ , options :: PerCompilerFlavor [String]
+ , profOptions :: PerCompilerFlavor [String]
+ , sharedOptions :: PerCompilerFlavor [String]
+ , staticOptions :: PerCompilerFlavor [String]
+ , customFieldsBI :: [(String, String)]
+ -- ^ Custom fields starting
+ -- with x-, stored in a
+ -- simple assoc-list.
+ , targetBuildDepends :: [Dependency]
+ -- ^ Dependencies specific to a library or executable target
+ , mixins :: [Mixin]
+ }
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary BuildInfo
instance Structured BuildInfo
instance NFData BuildInfo where rnf = genericRnf
instance Monoid BuildInfo where
- mempty = BuildInfo {
- buildable = True,
- buildTools = [],
- buildToolDepends = [],
- cppOptions = [],
- asmOptions = [],
- cmmOptions = [],
- ccOptions = [],
- cxxOptions = [],
- ldOptions = [],
- hsc2hsOptions = [],
- pkgconfigDepends = [],
- frameworks = [],
- extraFrameworkDirs = [],
- asmSources = [],
- cmmSources = [],
- cSources = [],
- cxxSources = [],
- jsSources = [],
- hsSourceDirs = [],
- otherModules = [],
- virtualModules = [],
- autogenModules = [],
- defaultLanguage = Nothing,
- otherLanguages = [],
- defaultExtensions = [],
- otherExtensions = [],
- oldExtensions = [],
- extraLibs = [],
- extraLibsStatic = [],
- extraGHCiLibs = [],
- extraBundledLibs = [],
- extraLibFlavours = [],
- extraDynLibFlavours = [],
- extraLibDirs = [],
- extraLibDirsStatic = [],
- includeDirs = [],
- includes = [],
- autogenIncludes = [],
- installIncludes = [],
- options = mempty,
- profOptions = mempty,
- sharedOptions = mempty,
- staticOptions = mempty,
- customFieldsBI = [],
- targetBuildDepends = [],
- mixins = []
- }
+ mempty =
+ BuildInfo
+ { buildable = True
+ , buildTools = []
+ , buildToolDepends = []
+ , cppOptions = []
+ , asmOptions = []
+ , cmmOptions = []
+ , ccOptions = []
+ , cxxOptions = []
+ , ldOptions = []
+ , hsc2hsOptions = []
+ , pkgconfigDepends = []
+ , frameworks = []
+ , extraFrameworkDirs = []
+ , asmSources = []
+ , cmmSources = []
+ , cSources = []
+ , cxxSources = []
+ , jsSources = []
+ , hsSourceDirs = []
+ , otherModules = []
+ , virtualModules = []
+ , autogenModules = []
+ , defaultLanguage = Nothing
+ , otherLanguages = []
+ , defaultExtensions = []
+ , otherExtensions = []
+ , oldExtensions = []
+ , extraLibs = []
+ , extraLibsStatic = []
+ , extraGHCiLibs = []
+ , extraBundledLibs = []
+ , extraLibFlavours = []
+ , extraDynLibFlavours = []
+ , extraLibDirs = []
+ , extraLibDirsStatic = []
+ , includeDirs = []
+ , includes = []
+ , autogenIncludes = []
+ , installIncludes = []
+ , options = mempty
+ , profOptions = mempty
+ , sharedOptions = mempty
+ , staticOptions = mempty
+ , customFieldsBI = []
+ , targetBuildDepends = []
+ , mixins = []
+ }
mappend = (<>)
instance Semigroup BuildInfo where
- a <> b = BuildInfo {
- buildable = buildable a && buildable b,
- buildTools = combine buildTools,
- buildToolDepends = combine buildToolDepends,
- cppOptions = combine cppOptions,
- asmOptions = combine asmOptions,
- cmmOptions = combine cmmOptions,
- ccOptions = combine ccOptions,
- cxxOptions = combine cxxOptions,
- ldOptions = combine ldOptions,
- hsc2hsOptions = combine hsc2hsOptions,
- pkgconfigDepends = combine pkgconfigDepends,
- frameworks = combineNub frameworks,
- extraFrameworkDirs = combineNub extraFrameworkDirs,
- asmSources = combineNub asmSources,
- cmmSources = combineNub cmmSources,
- cSources = combineNub cSources,
- cxxSources = combineNub cxxSources,
- jsSources = combineNub jsSources,
- hsSourceDirs = combineNub hsSourceDirs,
- otherModules = combineNub otherModules,
- virtualModules = combineNub virtualModules,
- autogenModules = combineNub autogenModules,
- defaultLanguage = combineMby defaultLanguage,
- otherLanguages = combineNub otherLanguages,
- defaultExtensions = combineNub defaultExtensions,
- otherExtensions = combineNub otherExtensions,
- oldExtensions = combineNub oldExtensions,
- extraLibs = combine extraLibs,
- extraLibsStatic = combine extraLibsStatic,
- extraGHCiLibs = combine extraGHCiLibs,
- extraBundledLibs = combine extraBundledLibs,
- extraLibFlavours = combine extraLibFlavours,
- extraDynLibFlavours = combine extraDynLibFlavours,
- extraLibDirs = combineNub extraLibDirs,
- extraLibDirsStatic = combineNub extraLibDirsStatic,
- includeDirs = combineNub includeDirs,
- includes = combineNub includes,
- autogenIncludes = combineNub autogenIncludes,
- installIncludes = combineNub installIncludes,
- options = combine options,
- profOptions = combine profOptions,
- sharedOptions = combine sharedOptions,
- staticOptions = combine staticOptions,
- customFieldsBI = combine customFieldsBI,
- targetBuildDepends = combineNub targetBuildDepends,
- mixins = combine mixins
- }
+ a <> b =
+ BuildInfo
+ { buildable = buildable a && buildable b
+ , buildTools = combine buildTools
+ , buildToolDepends = combine buildToolDepends
+ , cppOptions = combine cppOptions
+ , asmOptions = combine asmOptions
+ , cmmOptions = combine cmmOptions
+ , ccOptions = combine ccOptions
+ , cxxOptions = combine cxxOptions
+ , ldOptions = combine ldOptions
+ , hsc2hsOptions = combine hsc2hsOptions
+ , pkgconfigDepends = combine pkgconfigDepends
+ , frameworks = combineNub frameworks
+ , extraFrameworkDirs = combineNub extraFrameworkDirs
+ , asmSources = combineNub asmSources
+ , cmmSources = combineNub cmmSources
+ , cSources = combineNub cSources
+ , cxxSources = combineNub cxxSources
+ , jsSources = combineNub jsSources
+ , hsSourceDirs = combineNub hsSourceDirs
+ , otherModules = combineNub otherModules
+ , virtualModules = combineNub virtualModules
+ , autogenModules = combineNub autogenModules
+ , defaultLanguage = combineMby defaultLanguage
+ , otherLanguages = combineNub otherLanguages
+ , defaultExtensions = combineNub defaultExtensions
+ , otherExtensions = combineNub otherExtensions
+ , oldExtensions = combineNub oldExtensions
+ , extraLibs = combine extraLibs
+ , extraLibsStatic = combine extraLibsStatic
+ , extraGHCiLibs = combine extraGHCiLibs
+ , extraBundledLibs = combine extraBundledLibs
+ , extraLibFlavours = combine extraLibFlavours
+ , extraDynLibFlavours = combine extraDynLibFlavours
+ , extraLibDirs = combineNub extraLibDirs
+ , extraLibDirsStatic = combineNub extraLibDirsStatic
+ , includeDirs = combineNub includeDirs
+ , includes = combineNub includes
+ , autogenIncludes = combineNub autogenIncludes
+ , installIncludes = combineNub installIncludes
+ , options = combine options
+ , profOptions = combine profOptions
+ , sharedOptions = combine sharedOptions
+ , staticOptions = combine staticOptions
+ , customFieldsBI = combine customFieldsBI
+ , targetBuildDepends = combineNub targetBuildDepends
+ , mixins = combine mixins
+ }
where
- combine field = field a `mappend` field b
+ combine field = field a `mappend` field b
combineNub field = nub (combine field)
combineMby field = field b `mplus` field a
@@ -225,32 +256,33 @@ emptyBuildInfo :: BuildInfo
emptyBuildInfo = mempty
-- | The 'Language's used by this component
---
allLanguages :: BuildInfo -> [Language]
-allLanguages bi = maybeToList (defaultLanguage bi)
- ++ otherLanguages bi
+allLanguages bi =
+ maybeToList (defaultLanguage bi)
+ ++ otherLanguages bi
-- | The 'Extension's that are used somewhere by this component
---
allExtensions :: BuildInfo -> [Extension]
-allExtensions bi = usedExtensions bi
- ++ otherExtensions bi
+allExtensions bi =
+ usedExtensions bi
+ ++ otherExtensions bi
-- | The 'Extensions' that are used by all modules in this component
---
usedExtensions :: BuildInfo -> [Extension]
-usedExtensions bi = oldExtensions bi
- ++ defaultExtensions bi
+usedExtensions bi =
+ oldExtensions bi
+ ++ defaultExtensions bi
-- | Whether any modules in this component use Template Haskell or
-- Quasi Quotes
usesTemplateHaskellOrQQ :: BuildInfo -> Bool
usesTemplateHaskellOrQQ bi = any p (allExtensions bi)
where
- p ex = ex `elem`
- [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes]
+ p ex =
+ ex
+ `elem` [EnableExtension TemplateHaskell, EnableExtension QuasiQuotes]
--- |Select options for a particular Haskell compiler.
+-- | Select options for a particular Haskell compiler.
hcOptions :: CompilerFlavor -> BuildInfo -> [String]
hcOptions = lookupHcOptions options
@@ -263,10 +295,13 @@ hcSharedOptions = lookupHcOptions sharedOptions
hcStaticOptions :: CompilerFlavor -> BuildInfo -> [String]
hcStaticOptions = lookupHcOptions staticOptions
-lookupHcOptions :: (BuildInfo -> PerCompilerFlavor [String])
- -> CompilerFlavor -> BuildInfo -> [String]
+lookupHcOptions
+ :: (BuildInfo -> PerCompilerFlavor [String])
+ -> CompilerFlavor
+ -> BuildInfo
+ -> [String]
lookupHcOptions f hc bi = case f bi of
- PerCompilerFlavor ghc ghcjs
- | hc == GHC -> ghc
- | hc == GHCJS -> ghcjs
- | otherwise -> mempty
+ PerCompilerFlavor ghc ghcjs
+ | hc == GHC -> ghc
+ | hc == GHCJS -> ghcjs
+ | otherwise -> mempty
diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs
index b3d558a9412302b5060c082064b8540d996ab0cd..63cfba526ab84497bfb647d4705a336ba7091522 100644
--- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs
@@ -1,356 +1,355 @@
-module Distribution.Types.BuildInfo.Lens (
- BuildInfo,
- HasBuildInfo (..),
- HasBuildInfos (..),
- ) where
+module Distribution.Types.BuildInfo.Lens
+ ( BuildInfo
+ , HasBuildInfo (..)
+ , HasBuildInfos (..)
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Compiler (PerCompilerFlavor)
-import Distribution.ModuleName (ModuleName)
-import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.Dependency (Dependency)
-import Distribution.Types.ExeDependency (ExeDependency)
+import Distribution.Compiler (PerCompilerFlavor)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.Dependency (Dependency)
+import Distribution.Types.ExeDependency (ExeDependency)
import Distribution.Types.LegacyExeDependency (LegacyExeDependency)
-import Distribution.Types.Mixin (Mixin)
+import Distribution.Types.Mixin (Mixin)
import Distribution.Types.PkgconfigDependency (PkgconfigDependency)
import Distribution.Utils.Path
-import Language.Haskell.Extension (Extension, Language)
+import Language.Haskell.Extension (Extension, Language)
import qualified Distribution.Types.BuildInfo as T
-- | Classy lenses for 'BuildInfo'.
class HasBuildInfo a where
- buildInfo :: Lens' a BuildInfo
+ buildInfo :: Lens' a BuildInfo
- buildable :: Lens' a Bool
- buildable = buildInfo . buildable
- {-# INLINE buildable #-}
+ buildable :: Lens' a Bool
+ buildable = buildInfo . buildable
+ {-# INLINE buildable #-}
- buildTools :: Lens' a [LegacyExeDependency]
- buildTools = buildInfo . buildTools
- {-# INLINE buildTools #-}
+ buildTools :: Lens' a [LegacyExeDependency]
+ buildTools = buildInfo . buildTools
+ {-# INLINE buildTools #-}
- buildToolDepends :: Lens' a [ExeDependency]
- buildToolDepends = buildInfo . buildToolDepends
- {-# INLINE buildToolDepends #-}
+ buildToolDepends :: Lens' a [ExeDependency]
+ buildToolDepends = buildInfo . buildToolDepends
+ {-# INLINE buildToolDepends #-}
- cppOptions :: Lens' a [String]
- cppOptions = buildInfo . cppOptions
- {-# INLINE cppOptions #-}
+ cppOptions :: Lens' a [String]
+ cppOptions = buildInfo . cppOptions
+ {-# INLINE cppOptions #-}
- asmOptions :: Lens' a [String]
- asmOptions = buildInfo . asmOptions
- {-# INLINE asmOptions #-}
+ asmOptions :: Lens' a [String]
+ asmOptions = buildInfo . asmOptions
+ {-# INLINE asmOptions #-}
- cmmOptions :: Lens' a [String]
- cmmOptions = buildInfo . cmmOptions
- {-# INLINE cmmOptions #-}
+ cmmOptions :: Lens' a [String]
+ cmmOptions = buildInfo . cmmOptions
+ {-# INLINE cmmOptions #-}
- ccOptions :: Lens' a [String]
- ccOptions = buildInfo . ccOptions
- {-# INLINE ccOptions #-}
+ ccOptions :: Lens' a [String]
+ ccOptions = buildInfo . ccOptions
+ {-# INLINE ccOptions #-}
- cxxOptions :: Lens' a [String]
- cxxOptions = buildInfo . cxxOptions
- {-# INLINE cxxOptions #-}
+ cxxOptions :: Lens' a [String]
+ cxxOptions = buildInfo . cxxOptions
+ {-# INLINE cxxOptions #-}
- ldOptions :: Lens' a [String]
- ldOptions = buildInfo . ldOptions
- {-# INLINE ldOptions #-}
+ ldOptions :: Lens' a [String]
+ ldOptions = buildInfo . ldOptions
+ {-# INLINE ldOptions #-}
- hsc2hsOptions :: Lens' a [String]
- hsc2hsOptions = buildInfo . hsc2hsOptions
- {-# INLINE hsc2hsOptions #-}
+ hsc2hsOptions :: Lens' a [String]
+ hsc2hsOptions = buildInfo . hsc2hsOptions
+ {-# INLINE hsc2hsOptions #-}
- pkgconfigDepends :: Lens' a [PkgconfigDependency]
- pkgconfigDepends = buildInfo . pkgconfigDepends
- {-# INLINE pkgconfigDepends #-}
+ pkgconfigDepends :: Lens' a [PkgconfigDependency]
+ pkgconfigDepends = buildInfo . pkgconfigDepends
+ {-# INLINE pkgconfigDepends #-}
- frameworks :: Lens' a [String]
- frameworks = buildInfo . frameworks
- {-# INLINE frameworks #-}
+ frameworks :: Lens' a [String]
+ frameworks = buildInfo . frameworks
+ {-# INLINE frameworks #-}
- extraFrameworkDirs :: Lens' a [String]
- extraFrameworkDirs = buildInfo . extraFrameworkDirs
- {-# INLINE extraFrameworkDirs #-}
+ extraFrameworkDirs :: Lens' a [String]
+ extraFrameworkDirs = buildInfo . extraFrameworkDirs
+ {-# INLINE extraFrameworkDirs #-}
- asmSources :: Lens' a [FilePath]
- asmSources = buildInfo . asmSources
- {-# INLINE asmSources #-}
+ asmSources :: Lens' a [FilePath]
+ asmSources = buildInfo . asmSources
+ {-# INLINE asmSources #-}
- cmmSources :: Lens' a [FilePath]
- cmmSources = buildInfo . cmmSources
- {-# INLINE cmmSources #-}
+ cmmSources :: Lens' a [FilePath]
+ cmmSources = buildInfo . cmmSources
+ {-# INLINE cmmSources #-}
- cSources :: Lens' a [FilePath]
- cSources = buildInfo . cSources
- {-# INLINE cSources #-}
+ cSources :: Lens' a [FilePath]
+ cSources = buildInfo . cSources
+ {-# INLINE cSources #-}
- cxxSources :: Lens' a [FilePath]
- cxxSources = buildInfo . cxxSources
- {-# INLINE cxxSources #-}
+ cxxSources :: Lens' a [FilePath]
+ cxxSources = buildInfo . cxxSources
+ {-# INLINE cxxSources #-}
- jsSources :: Lens' a [FilePath]
- jsSources = buildInfo . jsSources
- {-# INLINE jsSources #-}
+ jsSources :: Lens' a [FilePath]
+ jsSources = buildInfo . jsSources
+ {-# INLINE jsSources #-}
- hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir]
- hsSourceDirs = buildInfo . hsSourceDirs
- {-# INLINE hsSourceDirs #-}
+ hsSourceDirs :: Lens' a [SymbolicPath PackageDir SourceDir]
+ hsSourceDirs = buildInfo . hsSourceDirs
+ {-# INLINE hsSourceDirs #-}
- otherModules :: Lens' a [ModuleName]
- otherModules = buildInfo . otherModules
- {-# INLINE otherModules #-}
+ otherModules :: Lens' a [ModuleName]
+ otherModules = buildInfo . otherModules
+ {-# INLINE otherModules #-}
- virtualModules :: Lens' a [ModuleName]
- virtualModules = buildInfo . virtualModules
- {-# INLINE virtualModules #-}
+ virtualModules :: Lens' a [ModuleName]
+ virtualModules = buildInfo . virtualModules
+ {-# INLINE virtualModules #-}
- autogenModules :: Lens' a [ModuleName]
- autogenModules = buildInfo . autogenModules
- {-# INLINE autogenModules #-}
+ autogenModules :: Lens' a [ModuleName]
+ autogenModules = buildInfo . autogenModules
+ {-# INLINE autogenModules #-}
- defaultLanguage :: Lens' a (Maybe Language)
- defaultLanguage = buildInfo . defaultLanguage
- {-# INLINE defaultLanguage #-}
+ defaultLanguage :: Lens' a (Maybe Language)
+ defaultLanguage = buildInfo . defaultLanguage
+ {-# INLINE defaultLanguage #-}
- otherLanguages :: Lens' a [Language]
- otherLanguages = buildInfo . otherLanguages
- {-# INLINE otherLanguages #-}
+ otherLanguages :: Lens' a [Language]
+ otherLanguages = buildInfo . otherLanguages
+ {-# INLINE otherLanguages #-}
- defaultExtensions :: Lens' a [Extension]
- defaultExtensions = buildInfo . defaultExtensions
- {-# INLINE defaultExtensions #-}
+ defaultExtensions :: Lens' a [Extension]
+ defaultExtensions = buildInfo . defaultExtensions
+ {-# INLINE defaultExtensions #-}
- otherExtensions :: Lens' a [Extension]
- otherExtensions = buildInfo . otherExtensions
- {-# INLINE otherExtensions #-}
+ otherExtensions :: Lens' a [Extension]
+ otherExtensions = buildInfo . otherExtensions
+ {-# INLINE otherExtensions #-}
- oldExtensions :: Lens' a [Extension]
- oldExtensions = buildInfo . oldExtensions
- {-# INLINE oldExtensions #-}
+ oldExtensions :: Lens' a [Extension]
+ oldExtensions = buildInfo . oldExtensions
+ {-# INLINE oldExtensions #-}
- extraLibs :: Lens' a [String]
- extraLibs = buildInfo . extraLibs
- {-# INLINE extraLibs #-}
+ extraLibs :: Lens' a [String]
+ extraLibs = buildInfo . extraLibs
+ {-# INLINE extraLibs #-}
- extraLibsStatic :: Lens' a [String]
- extraLibsStatic = buildInfo . extraLibsStatic
- {-# INLINE extraLibsStatic #-}
+ extraLibsStatic :: Lens' a [String]
+ extraLibsStatic = buildInfo . extraLibsStatic
+ {-# INLINE extraLibsStatic #-}
- extraGHCiLibs :: Lens' a [String]
- extraGHCiLibs = buildInfo . extraGHCiLibs
- {-# INLINE extraGHCiLibs #-}
+ extraGHCiLibs :: Lens' a [String]
+ extraGHCiLibs = buildInfo . extraGHCiLibs
+ {-# INLINE extraGHCiLibs #-}
- extraBundledLibs :: Lens' a [String]
- extraBundledLibs = buildInfo . extraBundledLibs
- {-# INLINE extraBundledLibs #-}
+ extraBundledLibs :: Lens' a [String]
+ extraBundledLibs = buildInfo . extraBundledLibs
+ {-# INLINE extraBundledLibs #-}
- extraLibFlavours :: Lens' a [String]
- extraLibFlavours = buildInfo . extraLibFlavours
- {-# INLINE extraLibFlavours #-}
+ extraLibFlavours :: Lens' a [String]
+ extraLibFlavours = buildInfo . extraLibFlavours
+ {-# INLINE extraLibFlavours #-}
- extraDynLibFlavours :: Lens' a [String]
- extraDynLibFlavours = buildInfo . extraDynLibFlavours
- {-# INLINE extraDynLibFlavours #-}
+ extraDynLibFlavours :: Lens' a [String]
+ extraDynLibFlavours = buildInfo . extraDynLibFlavours
+ {-# INLINE extraDynLibFlavours #-}
- extraLibDirs :: Lens' a [String]
- extraLibDirs = buildInfo . extraLibDirs
- {-# INLINE extraLibDirs #-}
+ extraLibDirs :: Lens' a [String]
+ extraLibDirs = buildInfo . extraLibDirs
+ {-# INLINE extraLibDirs #-}
- extraLibDirsStatic :: Lens' a [String]
- extraLibDirsStatic = buildInfo . extraLibDirsStatic
- {-# INLINE extraLibDirsStatic #-}
+ extraLibDirsStatic :: Lens' a [String]
+ extraLibDirsStatic = buildInfo . extraLibDirsStatic
+ {-# INLINE extraLibDirsStatic #-}
- includeDirs :: Lens' a [FilePath]
- includeDirs = buildInfo . includeDirs
- {-# INLINE includeDirs #-}
+ includeDirs :: Lens' a [FilePath]
+ includeDirs = buildInfo . includeDirs
+ {-# INLINE includeDirs #-}
- includes :: Lens' a [FilePath]
- includes = buildInfo . includes
- {-# INLINE includes #-}
+ includes :: Lens' a [FilePath]
+ includes = buildInfo . includes
+ {-# INLINE includes #-}
- autogenIncludes :: Lens' a [FilePath]
- autogenIncludes = buildInfo . autogenIncludes
- {-# INLINE autogenIncludes #-}
+ autogenIncludes :: Lens' a [FilePath]
+ autogenIncludes = buildInfo . autogenIncludes
+ {-# INLINE autogenIncludes #-}
- installIncludes :: Lens' a [FilePath]
- installIncludes = buildInfo . installIncludes
- {-# INLINE installIncludes #-}
+ installIncludes :: Lens' a [FilePath]
+ installIncludes = buildInfo . installIncludes
+ {-# INLINE installIncludes #-}
- options :: Lens' a (PerCompilerFlavor [String])
- options = buildInfo . options
- {-# INLINE options #-}
+ options :: Lens' a (PerCompilerFlavor [String])
+ options = buildInfo . options
+ {-# INLINE options #-}
- profOptions :: Lens' a (PerCompilerFlavor [String])
- profOptions = buildInfo . profOptions
- {-# INLINE profOptions #-}
+ profOptions :: Lens' a (PerCompilerFlavor [String])
+ profOptions = buildInfo . profOptions
+ {-# INLINE profOptions #-}
- sharedOptions :: Lens' a (PerCompilerFlavor [String])
- sharedOptions = buildInfo . sharedOptions
- {-# INLINE sharedOptions #-}
+ sharedOptions :: Lens' a (PerCompilerFlavor [String])
+ sharedOptions = buildInfo . sharedOptions
+ {-# INLINE sharedOptions #-}
- staticOptions :: Lens' a (PerCompilerFlavor [String])
- staticOptions = buildInfo . staticOptions
- {-# INLINE staticOptions #-}
+ staticOptions :: Lens' a (PerCompilerFlavor [String])
+ staticOptions = buildInfo . staticOptions
+ {-# INLINE staticOptions #-}
- customFieldsBI :: Lens' a [(String,String)]
- customFieldsBI = buildInfo . customFieldsBI
- {-# INLINE customFieldsBI #-}
+ customFieldsBI :: Lens' a [(String, String)]
+ customFieldsBI = buildInfo . customFieldsBI
+ {-# INLINE customFieldsBI #-}
- targetBuildDepends :: Lens' a [Dependency]
- targetBuildDepends = buildInfo . targetBuildDepends
- {-# INLINE targetBuildDepends #-}
-
- mixins :: Lens' a [Mixin]
- mixins = buildInfo . mixins
- {-# INLINE mixins #-}
+ targetBuildDepends :: Lens' a [Dependency]
+ targetBuildDepends = buildInfo . targetBuildDepends
+ {-# INLINE targetBuildDepends #-}
+ mixins :: Lens' a [Mixin]
+ mixins = buildInfo . mixins
+ {-# INLINE mixins #-}
instance HasBuildInfo BuildInfo where
- buildInfo = id
- {-# INLINE buildInfo #-}
+ buildInfo = id
+ {-# INLINE buildInfo #-}
- buildable f s = fmap (\x -> s { T.buildable = x }) (f (T.buildable s))
- {-# INLINE buildable #-}
+ buildable f s = fmap (\x -> s{T.buildable = x}) (f (T.buildable s))
+ {-# INLINE buildable #-}
- buildTools f s = fmap (\x -> s { T.buildTools = x }) (f (T.buildTools s))
- {-# INLINE buildTools #-}
+ buildTools f s = fmap (\x -> s{T.buildTools = x}) (f (T.buildTools s))
+ {-# INLINE buildTools #-}
- buildToolDepends f s = fmap (\x -> s { T.buildToolDepends = x }) (f (T.buildToolDepends s))
- {-# INLINE buildToolDepends #-}
+ buildToolDepends f s = fmap (\x -> s{T.buildToolDepends = x}) (f (T.buildToolDepends s))
+ {-# INLINE buildToolDepends #-}
- cppOptions f s = fmap (\x -> s { T.cppOptions = x }) (f (T.cppOptions s))
- {-# INLINE cppOptions #-}
+ cppOptions f s = fmap (\x -> s{T.cppOptions = x}) (f (T.cppOptions s))
+ {-# INLINE cppOptions #-}
- asmOptions f s = fmap (\x -> s { T.asmOptions = x }) (f (T.asmOptions s))
- {-# INLINE asmOptions #-}
+ asmOptions f s = fmap (\x -> s{T.asmOptions = x}) (f (T.asmOptions s))
+ {-# INLINE asmOptions #-}
- cmmOptions f s = fmap (\x -> s { T.cmmOptions = x }) (f (T.cmmOptions s))
- {-# INLINE cmmOptions #-}
+ cmmOptions f s = fmap (\x -> s{T.cmmOptions = x}) (f (T.cmmOptions s))
+ {-# INLINE cmmOptions #-}
- ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s))
- {-# INLINE ccOptions #-}
+ ccOptions f s = fmap (\x -> s{T.ccOptions = x}) (f (T.ccOptions s))
+ {-# INLINE ccOptions #-}
- cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s))
- {-# INLINE cxxOptions #-}
+ cxxOptions f s = fmap (\x -> s{T.cxxOptions = x}) (f (T.cxxOptions s))
+ {-# INLINE cxxOptions #-}
- ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s))
- {-# INLINE ldOptions #-}
+ ldOptions f s = fmap (\x -> s{T.ldOptions = x}) (f (T.ldOptions s))
+ {-# INLINE ldOptions #-}
- hsc2hsOptions f s = fmap (\x -> s { T.hsc2hsOptions = x }) (f (T.hsc2hsOptions s))
- {-# INLINE hsc2hsOptions #-}
+ hsc2hsOptions f s = fmap (\x -> s{T.hsc2hsOptions = x}) (f (T.hsc2hsOptions s))
+ {-# INLINE hsc2hsOptions #-}
- pkgconfigDepends f s = fmap (\x -> s { T.pkgconfigDepends = x }) (f (T.pkgconfigDepends s))
- {-# INLINE pkgconfigDepends #-}
+ pkgconfigDepends f s = fmap (\x -> s{T.pkgconfigDepends = x}) (f (T.pkgconfigDepends s))
+ {-# INLINE pkgconfigDepends #-}
- frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s))
- {-# INLINE frameworks #-}
+ frameworks f s = fmap (\x -> s{T.frameworks = x}) (f (T.frameworks s))
+ {-# INLINE frameworks #-}
- extraFrameworkDirs f s = fmap (\x -> s { T.extraFrameworkDirs = x }) (f (T.extraFrameworkDirs s))
- {-# INLINE extraFrameworkDirs #-}
+ extraFrameworkDirs f s = fmap (\x -> s{T.extraFrameworkDirs = x}) (f (T.extraFrameworkDirs s))
+ {-# INLINE extraFrameworkDirs #-}
- asmSources f s = fmap (\x -> s { T.asmSources = x }) (f (T.asmSources s))
- {-# INLINE asmSources #-}
+ asmSources f s = fmap (\x -> s{T.asmSources = x}) (f (T.asmSources s))
+ {-# INLINE asmSources #-}
- cmmSources f s = fmap (\x -> s { T.cmmSources = x }) (f (T.cmmSources s))
- {-# INLINE cmmSources #-}
+ cmmSources f s = fmap (\x -> s{T.cmmSources = x}) (f (T.cmmSources s))
+ {-# INLINE cmmSources #-}
- cSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cSources s))
- {-# INLINE cSources #-}
+ cSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cSources s))
+ {-# INLINE cSources #-}
- cxxSources f s = fmap (\x -> s { T.cSources = x }) (f (T.cxxSources s))
- {-# INLINE cxxSources #-}
+ cxxSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cxxSources s))
+ {-# INLINE cxxSources #-}
- jsSources f s = fmap (\x -> s { T.jsSources = x }) (f (T.jsSources s))
- {-# INLINE jsSources #-}
+ jsSources f s = fmap (\x -> s{T.jsSources = x}) (f (T.jsSources s))
+ {-# INLINE jsSources #-}
- hsSourceDirs f s = fmap (\x -> s { T.hsSourceDirs = x }) (f (T.hsSourceDirs s))
- {-# INLINE hsSourceDirs #-}
+ hsSourceDirs f s = fmap (\x -> s{T.hsSourceDirs = x}) (f (T.hsSourceDirs s))
+ {-# INLINE hsSourceDirs #-}
- otherModules f s = fmap (\x -> s { T.otherModules = x }) (f (T.otherModules s))
- {-# INLINE otherModules #-}
+ otherModules f s = fmap (\x -> s{T.otherModules = x}) (f (T.otherModules s))
+ {-# INLINE otherModules #-}
- virtualModules f s = fmap (\x -> s { T.virtualModules = x }) (f (T.virtualModules s))
- {-# INLINE virtualModules #-}
+ virtualModules f s = fmap (\x -> s{T.virtualModules = x}) (f (T.virtualModules s))
+ {-# INLINE virtualModules #-}
- autogenModules f s = fmap (\x -> s { T.autogenModules = x }) (f (T.autogenModules s))
- {-# INLINE autogenModules #-}
+ autogenModules f s = fmap (\x -> s{T.autogenModules = x}) (f (T.autogenModules s))
+ {-# INLINE autogenModules #-}
- defaultLanguage f s = fmap (\x -> s { T.defaultLanguage = x }) (f (T.defaultLanguage s))
- {-# INLINE defaultLanguage #-}
+ defaultLanguage f s = fmap (\x -> s{T.defaultLanguage = x}) (f (T.defaultLanguage s))
+ {-# INLINE defaultLanguage #-}
- otherLanguages f s = fmap (\x -> s { T.otherLanguages = x }) (f (T.otherLanguages s))
- {-# INLINE otherLanguages #-}
+ otherLanguages f s = fmap (\x -> s{T.otherLanguages = x}) (f (T.otherLanguages s))
+ {-# INLINE otherLanguages #-}
- defaultExtensions f s = fmap (\x -> s { T.defaultExtensions = x }) (f (T.defaultExtensions s))
- {-# INLINE defaultExtensions #-}
+ defaultExtensions f s = fmap (\x -> s{T.defaultExtensions = x}) (f (T.defaultExtensions s))
+ {-# INLINE defaultExtensions #-}
- otherExtensions f s = fmap (\x -> s { T.otherExtensions = x }) (f (T.otherExtensions s))
- {-# INLINE otherExtensions #-}
+ otherExtensions f s = fmap (\x -> s{T.otherExtensions = x}) (f (T.otherExtensions s))
+ {-# INLINE otherExtensions #-}
- oldExtensions f s = fmap (\x -> s { T.oldExtensions = x }) (f (T.oldExtensions s))
- {-# INLINE oldExtensions #-}
+ oldExtensions f s = fmap (\x -> s{T.oldExtensions = x}) (f (T.oldExtensions s))
+ {-# INLINE oldExtensions #-}
- extraLibs f s = fmap (\x -> s { T.extraLibs = x }) (f (T.extraLibs s))
- {-# INLINE extraLibs #-}
+ extraLibs f s = fmap (\x -> s{T.extraLibs = x}) (f (T.extraLibs s))
+ {-# INLINE extraLibs #-}
- extraLibsStatic f s = fmap (\x -> s { T.extraLibsStatic = x}) (f (T.extraLibsStatic s))
- {-# INLINE extraLibsStatic #-}
+ extraLibsStatic f s = fmap (\x -> s{T.extraLibsStatic = x}) (f (T.extraLibsStatic s))
+ {-# INLINE extraLibsStatic #-}
- extraGHCiLibs f s = fmap (\x -> s { T.extraGHCiLibs = x }) (f (T.extraGHCiLibs s))
- {-# INLINE extraGHCiLibs #-}
+ extraGHCiLibs f s = fmap (\x -> s{T.extraGHCiLibs = x}) (f (T.extraGHCiLibs s))
+ {-# INLINE extraGHCiLibs #-}
- extraBundledLibs f s = fmap (\x -> s { T.extraBundledLibs = x }) (f (T.extraBundledLibs s))
- {-# INLINE extraBundledLibs #-}
+ extraBundledLibs f s = fmap (\x -> s{T.extraBundledLibs = x}) (f (T.extraBundledLibs s))
+ {-# INLINE extraBundledLibs #-}
- extraLibFlavours f s = fmap (\x -> s { T.extraLibFlavours = x }) (f (T.extraLibFlavours s))
- {-# INLINE extraLibFlavours #-}
+ extraLibFlavours f s = fmap (\x -> s{T.extraLibFlavours = x}) (f (T.extraLibFlavours s))
+ {-# INLINE extraLibFlavours #-}
- extraDynLibFlavours f s = fmap (\x -> s { T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s))
- {-# INLINE extraDynLibFlavours #-}
+ extraDynLibFlavours f s = fmap (\x -> s{T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s))
+ {-# INLINE extraDynLibFlavours #-}
- extraLibDirs f s = fmap (\x -> s { T.extraLibDirs = x }) (f (T.extraLibDirs s))
- {-# INLINE extraLibDirs #-}
+ extraLibDirs f s = fmap (\x -> s{T.extraLibDirs = x}) (f (T.extraLibDirs s))
+ {-# INLINE extraLibDirs #-}
- extraLibDirsStatic f s = fmap (\x -> s { T.extraLibDirsStatic = x}) (f (T.extraLibDirsStatic s))
- {-# INLINE extraLibDirsStatic #-}
+ extraLibDirsStatic f s = fmap (\x -> s{T.extraLibDirsStatic = x}) (f (T.extraLibDirsStatic s))
+ {-# INLINE extraLibDirsStatic #-}
- includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s))
- {-# INLINE includeDirs #-}
+ includeDirs f s = fmap (\x -> s{T.includeDirs = x}) (f (T.includeDirs s))
+ {-# INLINE includeDirs #-}
- includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s))
- {-# INLINE includes #-}
+ includes f s = fmap (\x -> s{T.includes = x}) (f (T.includes s))
+ {-# INLINE includes #-}
- autogenIncludes f s = fmap (\x -> s { T.autogenIncludes = x }) (f (T.autogenIncludes s))
- {-# INLINE autogenIncludes #-}
+ autogenIncludes f s = fmap (\x -> s{T.autogenIncludes = x}) (f (T.autogenIncludes s))
+ {-# INLINE autogenIncludes #-}
- installIncludes f s = fmap (\x -> s { T.installIncludes = x }) (f (T.installIncludes s))
- {-# INLINE installIncludes #-}
+ installIncludes f s = fmap (\x -> s{T.installIncludes = x}) (f (T.installIncludes s))
+ {-# INLINE installIncludes #-}
- options f s = fmap (\x -> s { T.options = x }) (f (T.options s))
- {-# INLINE options #-}
+ options f s = fmap (\x -> s{T.options = x}) (f (T.options s))
+ {-# INLINE options #-}
- profOptions f s = fmap (\x -> s { T.profOptions = x }) (f (T.profOptions s))
- {-# INLINE profOptions #-}
+ profOptions f s = fmap (\x -> s{T.profOptions = x}) (f (T.profOptions s))
+ {-# INLINE profOptions #-}
- sharedOptions f s = fmap (\x -> s { T.sharedOptions = x }) (f (T.sharedOptions s))
- {-# INLINE sharedOptions #-}
+ sharedOptions f s = fmap (\x -> s{T.sharedOptions = x}) (f (T.sharedOptions s))
+ {-# INLINE sharedOptions #-}
- staticOptions f s = fmap (\x -> s { T.staticOptions = x }) (f (T.staticOptions s))
- {-# INLINE staticOptions #-}
+ staticOptions f s = fmap (\x -> s{T.staticOptions = x}) (f (T.staticOptions s))
+ {-# INLINE staticOptions #-}
- customFieldsBI f s = fmap (\x -> s { T.customFieldsBI = x }) (f (T.customFieldsBI s))
- {-# INLINE customFieldsBI #-}
+ customFieldsBI f s = fmap (\x -> s{T.customFieldsBI = x}) (f (T.customFieldsBI s))
+ {-# INLINE customFieldsBI #-}
- targetBuildDepends f s = fmap (\x -> s { T.targetBuildDepends = x }) (f (T.targetBuildDepends s))
- {-# INLINE targetBuildDepends #-}
+ targetBuildDepends f s = fmap (\x -> s{T.targetBuildDepends = x}) (f (T.targetBuildDepends s))
+ {-# INLINE targetBuildDepends #-}
- mixins f s = fmap (\x -> s { T.mixins = x }) (f (T.mixins s))
- {-# INLINE mixins #-}
+ mixins f s = fmap (\x -> s{T.mixins = x}) (f (T.mixins s))
+ {-# INLINE mixins #-}
class HasBuildInfos a where
traverseBuildInfos :: Traversal' a BuildInfo
diff --git a/Cabal-syntax/src/Distribution/Types/BuildType.hs b/Cabal-syntax/src/Distribution/Types/BuildType.hs
index c9ace0936405e1b074035e23c4443efede5f75a4..e80770843f3514a054c90cbd4c4e2d0491ad5050 100644
--- a/Cabal-syntax/src/Distribution/Types/BuildType.hs
+++ b/Cabal-syntax/src/Distribution/Types/BuildType.hs
@@ -2,30 +2,34 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.BuildType (
- BuildType(..),
- knownBuildTypes,
-) where
+module Distribution.Types.BuildType
+ ( BuildType (..)
+ , knownBuildTypes
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.CabalSpecVersion (CabalSpecVersion (..))
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-- | The type of build system used by this package.
data BuildType
- = Simple -- ^ calls @Distribution.Simple.defaultMain@
- | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,
- -- which invokes @configure@ to generate additional build
- -- information used by later phases.
- | Make -- ^ calls @Distribution.Make.defaultMain@
- | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+ = -- | calls @Distribution.Simple.defaultMain@
+ Simple
+ | -- | calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,
+ -- which invokes @configure@ to generate additional build
+ -- information used by later phases.
+ Configure
+ | -- | calls @Distribution.Make.defaultMain@
+ Make
+ | -- | uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)
+ Custom
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary BuildType
instance Structured BuildType
@@ -41,15 +45,15 @@ instance Parsec BuildType where
parsec = do
name <- P.munch1 isAlphaNum
case name of
- "Simple" -> return Simple
+ "Simple" -> return Simple
"Configure" -> return Configure
- "Custom" -> return Custom
- "Make" -> return Make
- "Default" -> do
- v <- askCabalSpecVersion
- if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests
+ "Custom" -> return Custom
+ "Make" -> return Make
+ "Default" -> do
+ v <- askCabalSpecVersion
+ if v <= CabalSpecV1_18 -- oldest version needing this, based on hackage-tests
then do
- parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020"
- return Custom
+ parsecWarning PWTBuildTypeDefault "build-type: Default is parsed as Custom for legacy reasons. See https://github.com/haskell/cabal/issues/5020"
+ return Custom
else fail ("unknown build-type: '" ++ name ++ "'")
- _ -> fail ("unknown build-type: '" ++ name ++ "'")
+ _ -> fail ("unknown build-type: '" ++ name ++ "'")
diff --git a/Cabal-syntax/src/Distribution/Types/Component.hs b/Cabal-syntax/src/Distribution/Types/Component.hs
index c45597dd328c77c2a08b98c563c9cfa861d69f7e..6a6027bd25823ac930247fa3443fab0f4e5b7629 100644
--- a/Cabal-syntax/src/Distribution/Types/Component.hs
+++ b/Cabal-syntax/src/Distribution/Types/Component.hs
@@ -1,61 +1,63 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Component (
- Component(..),
- foldComponent,
- componentBuildInfo,
- componentBuildable,
- componentName,
- partitionComponents,
-) where
+module Distribution.Types.Component
+ ( Component (..)
+ , foldComponent
+ , componentBuildInfo
+ , componentBuildable
+ , componentName
+ , partitionComponents
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.Library
-import Distribution.Types.ForeignLib
+import Distribution.Types.Benchmark
import Distribution.Types.Executable
+import Distribution.Types.ForeignLib
+import Distribution.Types.Library
import Distribution.Types.TestSuite
-import Distribution.Types.Benchmark
-import Distribution.Types.ComponentName
import Distribution.Types.BuildInfo
+import Distribution.Types.ComponentName
import qualified Distribution.Types.BuildInfo.Lens as L
-data Component = CLib Library
- | CFLib ForeignLib
- | CExe Executable
- | CTest TestSuite
- | CBench Benchmark
- deriving (Show, Eq, Read)
+data Component
+ = CLib Library
+ | CFLib ForeignLib
+ | CExe Executable
+ | CTest TestSuite
+ | CBench Benchmark
+ deriving (Show, Eq, Read)
instance Semigroup Component where
- CLib l <> CLib l' = CLib (l <> l')
- CFLib l <> CFLib l' = CFLib (l <> l')
- CExe e <> CExe e' = CExe (e <> e')
- CTest t <> CTest t' = CTest (t <> t')
- CBench b <> CBench b' = CBench (b <> b')
- _ <> _ = error "Cannot merge Component"
+ CLib l <> CLib l' = CLib (l <> l')
+ CFLib l <> CFLib l' = CFLib (l <> l')
+ CExe e <> CExe e' = CExe (e <> e')
+ CTest t <> CTest t' = CTest (t <> t')
+ CBench b <> CBench b' = CBench (b <> b')
+ _ <> _ = error "Cannot merge Component"
instance L.HasBuildInfo Component where
- buildInfo f (CLib l) = CLib <$> L.buildInfo f l
- buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l
- buildInfo f (CExe e) = CExe <$> L.buildInfo f e
- buildInfo f (CTest t) = CTest <$> L.buildInfo f t
- buildInfo f (CBench b) = CBench <$> L.buildInfo f b
+ buildInfo f (CLib l) = CLib <$> L.buildInfo f l
+ buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l
+ buildInfo f (CExe e) = CExe <$> L.buildInfo f e
+ buildInfo f (CTest t) = CTest <$> L.buildInfo f t
+ buildInfo f (CBench b) = CBench <$> L.buildInfo f b
-foldComponent :: (Library -> a)
- -> (ForeignLib -> a)
- -> (Executable -> a)
- -> (TestSuite -> a)
- -> (Benchmark -> a)
- -> Component
- -> a
-foldComponent f _ _ _ _ (CLib lib) = f lib
-foldComponent _ f _ _ _ (CFLib flib)= f flib
-foldComponent _ _ f _ _ (CExe exe) = f exe
-foldComponent _ _ _ f _ (CTest tst) = f tst
+foldComponent
+ :: (Library -> a)
+ -> (ForeignLib -> a)
+ -> (Executable -> a)
+ -> (TestSuite -> a)
+ -> (Benchmark -> a)
+ -> Component
+ -> a
+foldComponent f _ _ _ _ (CLib lib) = f lib
+foldComponent _ f _ _ _ (CFLib flib) = f flib
+foldComponent _ _ f _ _ (CExe exe) = f exe
+foldComponent _ _ _ f _ (CTest tst) = f tst
foldComponent _ _ _ _ f (CBench bch) = f bch
componentBuildInfo :: Component -> BuildInfo
@@ -67,25 +69,25 @@ componentBuildInfo =
-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components".
--
-- @since 2.0.0.2
---
componentBuildable :: Component -> Bool
componentBuildable = buildable . componentBuildInfo
componentName :: Component -> ComponentName
componentName =
- foldComponent (CLibName . libName)
- (CFLibName . foreignLibName)
- (CExeName . exeName)
- (CTestName . testName)
- (CBenchName . benchmarkName)
+ foldComponent
+ (CLibName . libName)
+ (CFLibName . foreignLibName)
+ (CExeName . exeName)
+ (CTestName . testName)
+ (CBenchName . benchmarkName)
partitionComponents
- :: [Component]
- -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark])
-partitionComponents = foldr (foldComponent fa fb fc fd fe) ([],[],[],[],[])
+ :: [Component]
+ -> ([Library], [ForeignLib], [Executable], [TestSuite], [Benchmark])
+partitionComponents = foldr (foldComponent fa fb fc fd fe) ([], [], [], [], [])
where
- fa x ~(a,b,c,d,e) = (x:a,b,c,d,e)
- fb x ~(a,b,c,d,e) = (a,x:b,c,d,e)
- fc x ~(a,b,c,d,e) = (a,b,x:c,d,e)
- fd x ~(a,b,c,d,e) = (a,b,c,x:d,e)
- fe x ~(a,b,c,d,e) = (a,b,c,d,x:e)
+ fa x ~(a, b, c, d, e) = (x : a, b, c, d, e)
+ fb x ~(a, b, c, d, e) = (a, x : b, c, d, e)
+ fc x ~(a, b, c, d, e) = (a, b, x : c, d, e)
+ fd x ~(a, b, c, d, e) = (a, b, c, x : d, e)
+ fe x ~(a, b, c, d, e) = (a, b, c, d, x : e)
diff --git a/Cabal-syntax/src/Distribution/Types/ComponentId.hs b/Cabal-syntax/src/Distribution/Types/ComponentId.hs
index e275ab6e55ca353b767d1b6afab4390fa0fae796..47cf1d97ee3645e56d7939afdd1e09c510afe2f1 100644
--- a/Cabal-syntax/src/Distribution/Types/ComponentId.hs
+++ b/Cabal-syntax/src/Distribution/Types/ComponentId.hs
@@ -3,15 +3,17 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.ComponentId
- ( ComponentId, unComponentId, mkComponentId
+ ( ComponentId
+ , unComponentId
+ , mkComponentId
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
+import Prelude ()
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import Text.PrettyPrint (text)
@@ -30,7 +32,7 @@ import Text.PrettyPrint (text)
--
-- @since 2.0.0.2
newtype ComponentId = ComponentId ShortText
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-- | Construct a 'ComponentId' from a 'String'
--
@@ -53,7 +55,7 @@ unComponentId (ComponentId s) = fromShortText s
--
-- @since 2.0.0.2
instance IsString ComponentId where
- fromString = mkComponentId
+ fromString = mkComponentId
instance Binary ComponentId
instance Structured ComponentId
@@ -63,7 +65,8 @@ instance Pretty ComponentId where
instance Parsec ComponentId where
parsec = mkComponentId `fmap` P.munch1 abi_char
- where abi_char c = isAlphaNum c || c `elem` "-_."
+ where
+ abi_char c = isAlphaNum c || c `elem` "-_."
instance NFData ComponentId where
- rnf = rnf . unComponentId
+ rnf = rnf . unComponentId
diff --git a/Cabal-syntax/src/Distribution/Types/ComponentName.hs b/Cabal-syntax/src/Distribution/Types/ComponentName.hs
index 0dc0b3137c2671ff9dd4179b7e45f18309f46965..01ed6f7655f3680a9fab6ad16ae697b929d0d22b 100644
--- a/Cabal-syntax/src/Distribution/Types/ComponentName.hs
+++ b/Cabal-syntax/src/Distribution/Types/ComponentName.hs
@@ -2,45 +2,46 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PatternSynonyms #-}
-module Distribution.Types.ComponentName (
- ComponentName(.., CFLibName, CExeName, CTestName, CBenchName),
- showComponentName,
- componentNameRaw,
- componentNameStanza,
- componentNameString,
+module Distribution.Types.ComponentName
+ ( ComponentName (.., CFLibName, CExeName, CTestName, CBenchName)
+ , showComponentName
+ , componentNameRaw
+ , componentNameStanza
+ , componentNameString
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
-import Distribution.Types.LibraryName
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.Types.LibraryName
+import Distribution.Types.UnqualComponentName
-import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint as Disp
-- Libraries live in a separate namespace, so must distinguish
-data ComponentName = CLibName LibraryName
- | CNotLibName NotLibComponentName
- deriving (Eq, Generic, Ord, Read, Show, Typeable)
+data ComponentName
+ = CLibName LibraryName
+ | CNotLibName NotLibComponentName
+ deriving (Eq, Generic, Ord, Read, Show, Typeable)
data NotLibComponentName
- = CNLFLibName { toCompName :: UnqualComponentName }
- | CNLExeName { toCompName :: UnqualComponentName }
- | CNLTestName { toCompName :: UnqualComponentName }
- | CNLBenchName { toCompName :: UnqualComponentName }
- deriving (Eq, Generic, Ord, Read, Show, Typeable)
+ = CNLFLibName {toCompName :: UnqualComponentName}
+ | CNLExeName {toCompName :: UnqualComponentName}
+ | CNLTestName {toCompName :: UnqualComponentName}
+ | CNLBenchName {toCompName :: UnqualComponentName}
+ deriving (Eq, Generic, Ord, Read, Show, Typeable)
pattern CFLibName :: UnqualComponentName -> ComponentName
-pattern CFLibName n = CNotLibName (CNLFLibName n)
+pattern CFLibName n = CNotLibName (CNLFLibName n)
pattern CExeName :: UnqualComponentName -> ComponentName
-pattern CExeName n = CNotLibName (CNLExeName n)
+pattern CExeName n = CNotLibName (CNLExeName n)
pattern CTestName :: UnqualComponentName -> ComponentName
-pattern CTestName n = CNotLibName (CNLTestName n)
+pattern CTestName n = CNotLibName (CNLTestName n)
pattern CBenchName :: UnqualComponentName -> ComponentName
pattern CBenchName n = CNotLibName (CNLBenchName n)
@@ -54,42 +55,43 @@ instance Structured ComponentName
-- Build-target-ish syntax
instance Pretty ComponentName where
- pretty (CLibName lib) = prettyLibraryNameComponent lib
- pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str
- pretty (CExeName str) = Disp.text "exe:" <<>> pretty str
- pretty (CTestName str) = Disp.text "test:" <<>> pretty str
- pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str
+ pretty (CLibName lib) = prettyLibraryNameComponent lib
+ pretty (CFLibName str) = Disp.text "flib:" <<>> pretty str
+ pretty (CExeName str) = Disp.text "exe:" <<>> pretty str
+ pretty (CTestName str) = Disp.text "test:" <<>> pretty str
+ pretty (CBenchName str) = Disp.text "bench:" <<>> pretty str
instance Parsec ComponentName where
- -- note: this works as lib/flib/... all start with different character!
- parsec = parseComposite <|> parseLib
- where
- parseLib = CLibName <$> parsecLibraryNameComponent
- parseComposite = do
- ctor <- P.choice
- [ P.string "flib:" >> return CFLibName
- , P.string "exe:" >> return CExeName
- , P.string "bench:" >> return CBenchName
- , P.string "test:" >> return CTestName
- ]
- ctor <$> parsec
+ -- note: this works as lib/flib/... all start with different character!
+ parsec = parseComposite <|> parseLib
+ where
+ parseLib = CLibName <$> parsecLibraryNameComponent
+ parseComposite = do
+ ctor <-
+ P.choice
+ [ P.string "flib:" >> return CFLibName
+ , P.string "exe:" >> return CExeName
+ , P.string "bench:" >> return CBenchName
+ , P.string "test:" >> return CTestName
+ ]
+ ctor <$> parsec
showComponentName :: ComponentName -> String
-showComponentName (CLibName lib) = showLibraryName lib
-showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'"
-showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'"
-showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'"
+showComponentName (CLibName lib) = showLibraryName lib
+showComponentName (CFLibName name) = "foreign library '" ++ prettyShow name ++ "'"
+showComponentName (CExeName name) = "executable '" ++ prettyShow name ++ "'"
+showComponentName (CTestName name) = "test suite '" ++ prettyShow name ++ "'"
showComponentName (CBenchName name) = "benchmark '" ++ prettyShow name ++ "'"
componentNameRaw :: ComponentName -> String
-componentNameRaw l@(CLibName _) = showComponentName l
+componentNameRaw l@(CLibName _) = showComponentName l
componentNameRaw (CNotLibName x) = prettyShow $ toCompName x
componentNameStanza :: ComponentName -> String
-componentNameStanza (CLibName lib) = libraryNameStanza lib
-componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name
-componentNameStanza (CExeName name) = "executable " ++ prettyShow name
-componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name
+componentNameStanza (CLibName lib) = libraryNameStanza lib
+componentNameStanza (CFLibName name) = "foreign-library " ++ prettyShow name
+componentNameStanza (CExeName name) = "executable " ++ prettyShow name
+componentNameStanza (CTestName name) = "test-suite " ++ prettyShow name
componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name
-- | This gets the underlying unqualified component name. In fact, it is
@@ -97,5 +99,5 @@ componentNameStanza (CBenchName name) = "benchmark " ++ prettyShow name
-- @Nothing@ if the 'ComponentName' was for the public
-- library.
componentNameString :: ComponentName -> Maybe UnqualComponentName
-componentNameString (CLibName lib) = libraryNameString lib
+componentNameString (CLibName lib) = libraryNameString lib
componentNameString (CNotLibName x) = Just $ toCompName x
diff --git a/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs b/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs
index 3044c7600a80a804c357d41337202bf76a5ba471..224b38c839d93da42cdafb73bcb4ae5e636de95f 100644
--- a/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs
+++ b/Cabal-syntax/src/Distribution/Types/ComponentRequestedSpec.hs
@@ -1,20 +1,18 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.ComponentRequestedSpec (
- -- $buildable_vs_enabled_components
- ComponentRequestedSpec(..),
- ComponentDisabledReason(..),
+module Distribution.Types.ComponentRequestedSpec
+ ( -- $buildable_vs_enabled_components
+ ComponentRequestedSpec (..)
+ , ComponentDisabledReason (..)
+ , defaultComponentRequestedSpec
+ , componentNameRequested
+ , componentEnabled
+ , componentDisabledReason
+ ) where
- defaultComponentRequestedSpec,
- componentNameRequested,
-
- componentEnabled,
- componentDisabledReason,
-) where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.Component -- TODO: maybe remove me?
import Distribution.Types.ComponentName
@@ -64,9 +62,11 @@ import Distribution.Pretty (prettyShow)
--
-- @since 2.0.0.2
data ComponentRequestedSpec
- = ComponentRequestedSpec { testsRequested :: Bool
- , benchmarksRequested :: Bool }
- | OneComponentRequestedSpec ComponentName
+ = ComponentRequestedSpec
+ { testsRequested :: Bool
+ , benchmarksRequested :: Bool
+ }
+ | OneComponentRequestedSpec ComponentName
deriving (Generic, Read, Show, Eq, Typeable)
instance Binary ComponentRequestedSpec
@@ -96,32 +96,39 @@ componentNameRequested enabled = isNothing . componentNameNotRequestedReason ena
-- | Is this component disabled, and if so, why?
--
-- @since 2.0.0.2
-componentDisabledReason :: ComponentRequestedSpec -> Component
- -> Maybe ComponentDisabledReason
+componentDisabledReason
+ :: ComponentRequestedSpec
+ -> Component
+ -> Maybe ComponentDisabledReason
componentDisabledReason enabled comp
- | not (componentBuildable comp) = Just DisabledComponent
- | otherwise = componentNameNotRequestedReason enabled (componentName comp)
+ | not (componentBuildable comp) = Just DisabledComponent
+ | otherwise = componentNameNotRequestedReason enabled (componentName comp)
-- | Is this component name disabled, and if so, why?
--
-- @since 2.0.0.2
-componentNameNotRequestedReason :: ComponentRequestedSpec -> ComponentName
- -> Maybe ComponentDisabledReason
componentNameNotRequestedReason
- ComponentRequestedSpec{ testsRequested = False } (CTestName _)
- = Just DisabledAllTests
+ :: ComponentRequestedSpec
+ -> ComponentName
+ -> Maybe ComponentDisabledReason
+componentNameNotRequestedReason
+ ComponentRequestedSpec{testsRequested = False}
+ (CTestName _) =
+ Just DisabledAllTests
componentNameNotRequestedReason
- ComponentRequestedSpec{ benchmarksRequested = False } (CBenchName _)
- = Just DisabledAllBenchmarks
+ ComponentRequestedSpec{benchmarksRequested = False}
+ (CBenchName _) =
+ Just DisabledAllBenchmarks
componentNameNotRequestedReason ComponentRequestedSpec{} _ = Nothing
componentNameNotRequestedReason (OneComponentRequestedSpec cname) c
- | c == cname = Nothing
- | otherwise = Just (DisabledAllButOne (prettyShow cname))
+ | c == cname = Nothing
+ | otherwise = Just (DisabledAllButOne (prettyShow cname))
-- | A reason explaining why a component is disabled.
--
-- @since 2.0.0.2
-data ComponentDisabledReason = DisabledComponent
- | DisabledAllTests
- | DisabledAllBenchmarks
- | DisabledAllButOne String
+data ComponentDisabledReason
+ = DisabledComponent
+ | DisabledAllTests
+ | DisabledAllBenchmarks
+ | DisabledAllButOne String
diff --git a/Cabal-syntax/src/Distribution/Types/CondTree.hs b/Cabal-syntax/src/Distribution/Types/CondTree.hs
index 84d46ffa49c4f24165e84d52c37ab77ce7093aee..5fe25e649d724f37b40f96bfbe95cf215e4def3c 100644
--- a/Cabal-syntax/src/Distribution/Types/CondTree.hs
+++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs
@@ -1,37 +1,36 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Types.CondTree (
- CondTree(..),
- CondBranch(..),
- condIfThen,
- condIfThenElse,
- foldCondTree,
- mapCondTree,
- mapTreeConstrs,
- mapTreeConds,
- mapTreeData,
- traverseCondTreeV,
- traverseCondBranchV,
- traverseCondTreeC,
- traverseCondBranchC,
- extractCondition,
- simplifyCondTree,
- ignoreConditions,
-) where
+module Distribution.Types.CondTree
+ ( CondTree (..)
+ , CondBranch (..)
+ , condIfThen
+ , condIfThenElse
+ , foldCondTree
+ , mapCondTree
+ , mapTreeConstrs
+ , mapTreeConds
+ , mapTreeData
+ , traverseCondTreeV
+ , traverseCondBranchV
+ , traverseCondTreeC
+ , traverseCondBranchC
+ , extractCondition
+ , simplifyCondTree
+ , ignoreConditions
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.Condition
import qualified Distribution.Compat.Lens as L
-
-- | A 'CondTree' is used to represent the conditional structure of
-- a Cabal file, reflecting a syntax element subject to constraints,
-- and then any number of sub-elements which may be enabled subject
@@ -56,13 +55,12 @@ import qualified Distribution.Compat.Lens as L
-- derived off of 'targetBuildInfo' (perhaps a good refactoring
-- would be to convert this into an opaque type, with a smart
-- constructor that pre-computes the dependencies.)
---
data CondTree v c a = CondNode
- { condTreeData :: a
- , condTreeConstraints :: c
- , condTreeComponents :: [CondBranch v c a]
- }
- deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)
+ { condTreeData :: a
+ , condTreeConstraints :: c
+ , condTreeComponents :: [CondBranch v c a]
+ }
+ deriving (Show, Eq, Typeable, Data, Generic, Functor, Foldable, Traversable)
instance (Binary v, Binary c, Binary a) => Binary (CondTree v c a)
instance (Structured v, Structured c, Structured a) => Structured (CondTree v c a)
@@ -72,26 +70,25 @@ instance (Semigroup a, Semigroup c) => Semigroup (CondTree v c a) where
(CondNode a c bs) <> (CondNode a' c' bs') = CondNode (a <> a') (c <> c') (bs <> bs')
instance (Semigroup a, Semigroup c, Monoid a, Monoid c) => Monoid (CondTree v c a) where
- mappend = (<>)
- mempty = CondNode mempty mempty mempty
+ mappend = (<>)
+ mempty = CondNode mempty mempty mempty
-- | A 'CondBranch' represents a conditional branch, e.g., @if
-- flag(foo)@ on some syntax @a@. It also has an optional false
-- branch.
---
data CondBranch v c a = CondBranch
- { condBranchCondition :: Condition v
- , condBranchIfTrue :: CondTree v c a
- , condBranchIfFalse :: Maybe (CondTree v c a)
- }
- deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)
+ { condBranchCondition :: Condition v
+ , condBranchIfTrue :: CondTree v c a
+ , condBranchIfFalse :: Maybe (CondTree v c a)
+ }
+ deriving (Show, Eq, Typeable, Data, Generic, Functor, Traversable)
-- This instance is written by hand because GHC 8.0.1/8.0.2 infinite
-- loops when trying to derive it with optimizations. See
-- https://gitlab.haskell.org/ghc/ghc/-/issues/13056
instance Foldable (CondBranch v c) where
- foldMap f (CondBranch _ c Nothing) = foldMap f c
- foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a
+ foldMap f (CondBranch _ c Nothing) = foldMap f c
+ foldMap f (CondBranch _ c (Just a)) = foldMap f c `mappend` foldMap f a
instance (Binary v, Binary c, Binary a) => Binary (CondBranch v c a)
instance (Structured v, Structured c, Structured a) => Structured (CondBranch v c a)
@@ -103,15 +100,20 @@ condIfThen c t = CondBranch c t Nothing
condIfThenElse :: Condition v -> CondTree v c a -> CondTree v c a -> CondBranch v c a
condIfThenElse c t e = CondBranch c t (Just e)
-mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
- -> CondTree v c a -> CondTree w d b
+mapCondTree
+ :: (a -> b)
+ -> (c -> d)
+ -> (Condition v -> Condition w)
+ -> CondTree v c a
+ -> CondTree w d b
mapCondTree fa fc fcnd (CondNode a c ifs) =
- CondNode (fa a) (fc c) (map g ifs)
+ CondNode (fa a) (fc c) (map g ifs)
where
- g (CondBranch cnd t me)
- = CondBranch (fcnd cnd)
- (mapCondTree fa fc fcnd t)
- (fmap (mapCondTree fa fc fcnd) me)
+ g (CondBranch cnd t me) =
+ CondBranch
+ (fcnd cnd)
+ (mapCondTree fa fc fcnd t)
+ (fmap (mapCondTree fa fc fcnd) me)
mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
mapTreeConstrs f = mapCondTree id f id
@@ -125,11 +127,12 @@ mapTreeData f = mapCondTree f id id
-- | @@Traversal@@ for the variables
traverseCondTreeV :: L.Traversal (CondTree v c a) (CondTree w c a) v w
traverseCondTreeV f (CondNode a c ifs) =
- CondNode a c <$> traverse (traverseCondBranchV f) ifs
+ CondNode a c <$> traverse (traverseCondBranchV f) ifs
-- | @@Traversal@@ for the variables
traverseCondBranchV :: L.Traversal (CondBranch v c a) (CondBranch w c a) v w
-traverseCondBranchV f (CondBranch cnd t me) = CondBranch
+traverseCondBranchV f (CondBranch cnd t me) =
+ CondBranch
<$> traverse f cnd
<*> traverseCondTreeV f t
<*> traverse (traverseCondTreeV f) me
@@ -137,15 +140,15 @@ traverseCondBranchV f (CondBranch cnd t me) = CondBranch
-- | @@Traversal@@ for the aggregated constraints
traverseCondTreeC :: L.Traversal (CondTree v c a) (CondTree v d a) c d
traverseCondTreeC f (CondNode a c ifs) =
- CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs
+ CondNode a <$> f c <*> traverse (traverseCondBranchC f) ifs
-- | @@Traversal@@ for the aggregated constraints
traverseCondBranchC :: L.Traversal (CondBranch v c a) (CondBranch v d a) c d
-traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd
+traverseCondBranchC f (CondBranch cnd t me) =
+ CondBranch cnd
<$> traverseCondTreeC f t
<*> traverse (traverseCondTreeC f) me
-
-- | Extract the condition matched by the given predicate from a cond tree.
--
-- We use this mainly for extracting buildable conditions (see the Note in
@@ -154,40 +157,43 @@ traverseCondBranchC f (CondBranch cnd t me) = CondBranch cnd
extractCondition :: Eq v => (a -> Bool) -> CondTree v c a -> Condition v
extractCondition p = go
where
- go (CondNode x _ cs) | not (p x) = Lit False
- | otherwise = goList cs
+ go (CondNode x _ cs)
+ | not (p x) = Lit False
+ | otherwise = goList cs
- goList [] = Lit True
+ goList [] = Lit True
goList (CondBranch c t e : cs) =
let
ct = go t
ce = maybe (Lit True) go e
- in
+ in
((c `cAnd` ct) `cOr` (CNot c `cAnd` ce)) `cAnd` goList cs
-- | Flattens a CondTree using a partial flag assignment. When a condition
-- cannot be evaluated, both branches are ignored.
-simplifyCondTree :: (Semigroup a, Semigroup d) =>
- (v -> Either v Bool)
- -> CondTree v d a
- -> (d, a)
+simplifyCondTree
+ :: (Semigroup a, Semigroup d)
+ => (v -> Either v Bool)
+ -> CondTree v d a
+ -> (d, a)
simplifyCondTree env (CondNode a d ifs) =
- foldl (<>) (d, a) $ mapMaybe simplifyIf ifs
+ foldl (<>) (d, a) $ mapMaybe simplifyIf ifs
where
simplifyIf (CondBranch cnd t me) =
- case simplifyCondition cnd env of
- (Lit True, _) -> Just $ simplifyCondTree env t
- (Lit False, _) -> fmap (simplifyCondTree env) me
- _ -> Nothing
+ case simplifyCondition cnd env of
+ (Lit True, _) -> Just $ simplifyCondTree env t
+ (Lit False, _) -> fmap (simplifyCondTree env) me
+ _ -> Nothing
-- | Flatten a CondTree. This will resolve the CondTree by taking all
-- possible paths into account. Note that since branches represent exclusive
-- choices this may not result in a \"sane\" result.
ignoreConditions :: (Semigroup a, Semigroup c) => CondTree v c a -> (a, c)
ignoreConditions (CondNode a c ifs) = foldl (<>) (a, c) $ concatMap f ifs
- where f (CondBranch _ t me) = ignoreConditions t
- : maybeToList (fmap ignoreConditions me)
-
+ where
+ f (CondBranch _ t me) =
+ ignoreConditions t
+ : maybeToList (fmap ignoreConditions me)
-- | Flatten a CondTree. This will traverse the CondTree by taking all
-- possible paths into account, but merging inclusive when two paths
diff --git a/Cabal-syntax/src/Distribution/Types/Condition.hs b/Cabal-syntax/src/Distribution/Types/Condition.hs
index 0c89cb910dac2c15c152e4a9b0de6c042806483b..114c25afa668aef32cea253bd7b3cdd23b47b984 100644
--- a/Cabal-syntax/src/Distribution/Types/Condition.hs
+++ b/Cabal-syntax/src/Distribution/Types/Condition.hs
@@ -1,85 +1,87 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Condition (
- Condition(..),
- cNot,
- cAnd,
- cOr,
- simplifyCondition,
-) where
+module Distribution.Types.Condition
+ ( Condition (..)
+ , cNot
+ , cAnd
+ , cOr
+ , simplifyCondition
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- | A boolean expression parameterized over the variable type used.
-data Condition c = Var c
- | Lit Bool
- | CNot (Condition c)
- | COr (Condition c) (Condition c)
- | CAnd (Condition c) (Condition c)
- deriving (Show, Eq, Typeable, Data, Generic)
+data Condition c
+ = Var c
+ | Lit Bool
+ | CNot (Condition c)
+ | COr (Condition c) (Condition c)
+ | CAnd (Condition c) (Condition c)
+ deriving (Show, Eq, Typeable, Data, Generic)
-- | Boolean negation of a 'Condition' value.
cNot :: Condition a -> Condition a
-cNot (Lit b) = Lit (not b)
+cNot (Lit b) = Lit (not b)
cNot (CNot c) = c
-cNot c = CNot c
+cNot c = CNot c
-- | Boolean AND of two 'Condition' values.
cAnd :: Condition a -> Condition a -> Condition a
-cAnd (Lit False) _ = Lit False
-cAnd _ (Lit False) = Lit False
-cAnd (Lit True) x = x
-cAnd x (Lit True) = x
-cAnd x y = CAnd x y
+cAnd (Lit False) _ = Lit False
+cAnd _ (Lit False) = Lit False
+cAnd (Lit True) x = x
+cAnd x (Lit True) = x
+cAnd x y = CAnd x y
-- | Boolean OR of two 'Condition' values.
cOr :: Eq v => Condition v -> Condition v -> Condition v
-cOr (Lit True) _ = Lit True
-cOr _ (Lit True) = Lit True
-cOr (Lit False) x = x
-cOr x (Lit False) = x
-cOr c (CNot d)
- | c == d = Lit True
-cOr (CNot c) d
- | c == d = Lit True
-cOr x y = COr x y
+cOr (Lit True) _ = Lit True
+cOr _ (Lit True) = Lit True
+cOr (Lit False) x = x
+cOr x (Lit False) = x
+cOr c (CNot d)
+ | c == d = Lit True
+cOr (CNot c) d
+ | c == d = Lit True
+cOr x y = COr x y
instance Functor Condition where
- f `fmap` Var c = Var (f c)
- _ `fmap` Lit c = Lit c
- f `fmap` CNot c = CNot (fmap f c)
- f `fmap` COr c d = COr (fmap f c) (fmap f d)
+ f `fmap` Var c = Var (f c)
+ _ `fmap` Lit c = Lit c
+ f `fmap` CNot c = CNot (fmap f c)
+ f `fmap` COr c d = COr (fmap f c) (fmap f d)
f `fmap` CAnd c d = CAnd (fmap f c) (fmap f d)
instance Foldable Condition where
- f `foldMap` Var c = f c
- _ `foldMap` Lit _ = mempty
- f `foldMap` CNot c = foldMap f c
- f `foldMap` COr c d = foldMap f c `mappend` foldMap f d
+ f `foldMap` Var c = f c
+ _ `foldMap` Lit _ = mempty
+ f `foldMap` CNot c = 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` COr c d = COr `fmap` traverse f c <*> traverse f d
+ 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` 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 = Var
+ pure = Var
(<*>) = ap
instance Monad Condition where
return = pure
+
-- Terminating cases
(>>=) (Lit x) _ = Lit x
(>>=) (Var x) f = f x
-- Recursing cases
- (>>=) (CNot x ) f = CNot (x >>= f)
- (>>=) (COr x y) f = COr (x >>= f) (y >>= f)
- (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f)
+ (>>=) (CNot x) f = CNot (x >>= f)
+ (>>=) (COr x y) f = COr (x >>= f) (y >>= f)
+ (>>=) (CAnd x y) f = CAnd (x >>= f) (y >>= f)
instance Monoid (Condition a) where
mempty = Lit False
@@ -101,35 +103,37 @@ instance Structured c => Structured (Condition c)
instance NFData c => NFData (Condition c) where rnf = genericRnf
-- | Simplify the condition and return its free variables.
-simplifyCondition :: Condition c
- -> (c -> Either d Bool) -- ^ (partial) variable assignment
- -> (Condition d, [d])
+simplifyCondition
+ :: Condition c
+ -> (c -> Either d Bool)
+ -- ^ (partial) variable assignment
+ -> (Condition d, [d])
simplifyCondition cond i = fv . walk $ cond
where
walk cnd = case cnd of
- Var v -> either Var Lit (i v)
- Lit b -> Lit b
- CNot c -> case walk c of
- Lit True -> Lit False
- Lit False -> Lit True
- c' -> CNot c'
+ Var v -> either Var Lit (i v)
+ Lit b -> Lit b
+ CNot c -> case walk c of
+ Lit True -> Lit False
+ Lit False -> Lit True
+ c' -> CNot c'
COr c d -> case (walk c, walk d) of
- (Lit False, d') -> d'
- (Lit True, _) -> Lit True
- (c', Lit False) -> c'
- (_, Lit True) -> Lit True
- (c',d') -> COr c' d'
+ (Lit False, d') -> d'
+ (Lit True, _) -> Lit True
+ (c', Lit False) -> c'
+ (_, Lit True) -> Lit True
+ (c', d') -> COr c' d'
CAnd c d -> case (walk c, walk d) of
- (Lit False, _) -> Lit False
- (Lit True, d') -> d'
- (_, Lit False) -> Lit False
- (c', Lit True) -> c'
- (c',d') -> CAnd c' d'
+ (Lit False, _) -> Lit False
+ (Lit True, d') -> d'
+ (_, Lit False) -> Lit False
+ (c', Lit True) -> c'
+ (c', d') -> CAnd c' d'
-- gather free vars
fv c = (c, fv' c)
fv' c = case c of
- Var v -> [v]
- Lit _ -> []
- CNot c' -> fv' c'
- COr c1 c2 -> fv' c1 ++ fv' c2
+ Var v -> [v]
+ Lit _ -> []
+ CNot c' -> fv' c'
+ COr c1 c2 -> fv' c1 ++ fv' c2
CAnd c1 c2 -> fv' c1 ++ fv' c2
diff --git a/Cabal-syntax/src/Distribution/Types/ConfVar.hs b/Cabal-syntax/src/Distribution/Types/ConfVar.hs
index 39e5e04d3267b29a44a19a262d348d9414ab7eb6..220a6556fbd1e0221725be84ff585e229e979f00 100644
--- a/Cabal-syntax/src/Distribution/Types/ConfVar.hs
+++ b/Cabal-syntax/src/Distribution/Types/ConfVar.hs
@@ -1,23 +1,25 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.ConfVar (
- ConfVar(..),
- ) where
-import Prelude ()
+module Distribution.Types.ConfVar
+ ( ConfVar (..)
+ ) where
+
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.Flag
-import Distribution.Types.VersionRange
import Distribution.Compiler
import Distribution.System
+import Distribution.Types.Flag
+import Distribution.Types.VersionRange
-- | A @ConfVar@ represents the variable type used.
-data ConfVar = OS OS
- | Arch Arch
- | PackageFlag FlagName
- | Impl CompilerFlavor VersionRange
- deriving (Eq, Show, Typeable, Data, Generic)
+data ConfVar
+ = OS OS
+ | Arch Arch
+ | PackageFlag FlagName
+ | Impl CompilerFlavor VersionRange
+ deriving (Eq, Show, Typeable, Data, Generic)
instance Binary ConfVar
instance Structured ConfVar
diff --git a/Cabal-syntax/src/Distribution/Types/Dependency.hs b/Cabal-syntax/src/Distribution/Types/Dependency.hs
index bfdc78cd06d5c3fbe21387cfc1337174c6a3933d..959cb7bd2498a7a9e71c9f2cd1d6fd94cdfeea1b 100644
--- a/Cabal-syntax/src/Distribution/Types/Dependency.hs
+++ b/Cabal-syntax/src/Distribution/Types/Dependency.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.Dependency
- ( Dependency(..)
+ ( Dependency (..)
, mkDependency
, depPkgName
, depVerRange
@@ -14,11 +15,11 @@ import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Types.VersionRange (isAnyVersionLight)
-import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange)
+import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange)
import Distribution.CabalSpecVersion
-import Distribution.Compat.CharParsing (char, spaces)
-import Distribution.Compat.Parsing (between, option)
+import Distribution.Compat.CharParsing (char, spaces)
+import Distribution.Compat.Parsing (between, option)
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Types.LibraryName
@@ -26,7 +27,7 @@ import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName
import qualified Distribution.Compat.NonEmptySet as NES
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
-- | Describes a dependency on a source package (API)
--
@@ -36,15 +37,15 @@ import qualified Text.PrettyPrint as PP
-- /Note:/ 'Dependency' is not an instance of 'Ord', and so it cannot be used
-- in 'Set' or as the key to a 'Map'. For these and similar use cases see
-- 'DependencyMap'.
---
-data Dependency = Dependency
- PackageName
- VersionRange
- (NonEmptySet LibraryName)
- -- ^ The set of libraries required from the package.
- -- Only the selected libraries will be built.
- -- It does not affect the cabal-install solver yet.
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data Dependency
+ = -- | The set of libraries required from the package.
+ -- Only the selected libraries will be built.
+ -- It does not affect the cabal-install solver yet.
+ Dependency
+ PackageName
+ VersionRange
+ (NonEmptySet LibraryName)
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
depPkgName :: Dependency -> PackageName
depPkgName (Dependency pn _ _) = pn
@@ -61,15 +62,15 @@ depLibraries (Dependency _ _ cs) = cs
-- it is automatically converted to 'LMainLibName'.
--
-- @since 3.4.0.0
---
mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Dependency
mkDependency pn vr lb = Dependency pn vr (NES.map conv lb)
where
pn' = packageNameToUnqualComponentName pn
- conv l@LMainLibName = l
- conv l@(LSubLibName ln) | ln == pn' = LMainLibName
- | otherwise = l
+ conv l@LMainLibName = l
+ conv l@(LSubLibName ln)
+ | ln == pn' = LMainLibName
+ | otherwise = l
instance Binary Dependency
instance Structured Dependency
@@ -88,23 +89,23 @@ instance NFData Dependency where rnf = genericRnf
--
-- >>> prettyShow $ Dependency "pkg" anyVersion $ NES.insert (LSubLibName "sublib-b") $ NES.singleton (LSubLibName "sublib-a")
-- "pkg:{sublib-a, sublib-b}"
---
instance Pretty Dependency where
- pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver
- where
- -- TODO: change to isAnyVersion after #6736
- pver | isAnyVersionLight ver = PP.empty
- | otherwise = pretty ver
+ pretty (Dependency name ver sublibs) = withSubLibs (pretty name) <+> pver
+ where
+ -- TODO: change to isAnyVersion after #6736
+ pver
+ | isAnyVersionLight ver = PP.empty
+ | otherwise = pretty ver
- withSubLibs doc = case NES.toList sublibs of
- [LMainLibName] -> doc
- [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq
- _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs
+ withSubLibs doc = case NES.toList sublibs of
+ [LMainLibName] -> doc
+ [LSubLibName uq] -> doc <<>> PP.colon <<>> pretty uq
+ _ -> doc <<>> PP.colon <<>> PP.braces prettySublibs
- prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs
+ prettySublibs = PP.hsep $ PP.punctuate PP.comma $ prettySublib <$> NES.toList sublibs
- prettySublib LMainLibName = PP.text $ unPackageName name
- prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un
+ prettySublib LMainLibName = PP.text $ unPackageName name
+ prettySublib (LSubLibName un) = PP.text $ unUnqualComponentName un
-- |
--
@@ -137,36 +138,37 @@ instance Pretty Dependency where
--
-- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency]
-- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))]
---
instance Parsec Dependency where
- parsec = do
- name <- parsec
-
- libs <- option mainLibSet $ do
- _ <- char ':'
- versionGuardMultilibs
- NES.singleton <$> parseLib <|> parseMultipleLibs
-
- spaces -- https://github.com/haskell/cabal/issues/5846
-
- ver <- parsec <|> pure anyVersion
- return $ mkDependency name ver libs
- where
- parseLib = LSubLibName <$> parsec
- parseMultipleLibs = between
- (char '{' *> spaces)
- (spaces *> char '}')
- (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib)
+ parsec = do
+ name <- parsec
+
+ libs <- option mainLibSet $ do
+ _ <- char ':'
+ versionGuardMultilibs
+ NES.singleton <$> parseLib <|> parseMultipleLibs
+
+ spaces -- https://github.com/haskell/cabal/issues/5846
+ ver <- parsec <|> pure anyVersion
+ return $ mkDependency name ver libs
+ where
+ parseLib = LSubLibName <$> parsec
+ parseMultipleLibs =
+ between
+ (char '{' *> spaces)
+ (spaces *> char '}')
+ (NES.fromNonEmpty <$> parsecCommaNonEmpty parseLib)
versionGuardMultilibs :: CabalParsing m => m ()
versionGuardMultilibs = do
csv <- askCabalSpecVersion
- when (csv < CabalSpecV3_0) $ fail $ unwords
- [ "Sublibrary dependency syntax used."
- , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."
- , "Alternatively, if you are depending on an internal library, you can write"
- , "directly the library name as it were a package."
- ]
+ when (csv < CabalSpecV3_0) $
+ fail $
+ unwords
+ [ "Sublibrary dependency syntax used."
+ , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."
+ , "Alternatively, if you are depending on an internal library, you can write"
+ , "directly the library name as it were a package."
+ ]
-- | Library set with main library.
--
@@ -176,7 +178,6 @@ mainLibSet = NES.singleton LMainLibName
-- | Simplify the 'VersionRange' expression in a 'Dependency'.
-- See 'simplifyVersionRange'.
---
simplifyDependency :: Dependency -> Dependency
simplifyDependency (Dependency name range comps) =
Dependency name (simplifyVersionRange range) comps
diff --git a/Cabal-syntax/src/Distribution/Types/DependencyMap.hs b/Cabal-syntax/src/Distribution/Types/DependencyMap.hs
index c7e66cf73b4490530fca656d7c497b7bcea46ca5..aebca2c4cbfd83f3eb978d12f17b31f97a84d058 100644
--- a/Cabal-syntax/src/Distribution/Types/DependencyMap.hs
+++ b/Cabal-syntax/src/Distribution/Types/DependencyMap.hs
@@ -1,9 +1,9 @@
-module Distribution.Types.DependencyMap (
- DependencyMap,
- toDepMap,
- fromDepMap,
- constrainBy,
-) where
+module Distribution.Types.DependencyMap
+ ( DependencyMap
+ , toDepMap
+ , fromDepMap
+ , constrainBy
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -18,40 +18,42 @@ import qualified Data.Map.Lazy as Map
-- | A map of dependencies. Newtyped since the default monoid instance is not
-- appropriate. The monoid instance uses 'intersectVersionRanges'.
-newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName) }
+newtype DependencyMap = DependencyMap {unDependencyMap :: Map PackageName (VersionRange, NonEmptySet LibraryName)}
deriving (Show, Read, Eq)
instance Monoid DependencyMap where
- mempty = DependencyMap Map.empty
- mappend = (<>)
+ mempty = DependencyMap Map.empty
+ mappend = (<>)
instance Semigroup DependencyMap where
- (DependencyMap a) <> (DependencyMap b) =
- DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b)
+ (DependencyMap a) <> (DependencyMap b) =
+ DependencyMap (Map.unionWith intersectVersionRangesAndJoinComponents a b)
-intersectVersionRangesAndJoinComponents :: (VersionRange, NonEmptySet LibraryName)
- -> (VersionRange, NonEmptySet LibraryName)
- -> (VersionRange, NonEmptySet LibraryName)
+intersectVersionRangesAndJoinComponents
+ :: (VersionRange, NonEmptySet LibraryName)
+ -> (VersionRange, NonEmptySet LibraryName)
+ -> (VersionRange, NonEmptySet LibraryName)
intersectVersionRangesAndJoinComponents (va, ca) (vb, cb) =
(intersectVersionRanges va vb, ca <> cb)
toDepMap :: [Dependency] -> DependencyMap
toDepMap ds =
- DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [ (p,(vr,cs)) | Dependency p vr cs <- ds ]
+ DependencyMap $ Map.fromListWith intersectVersionRangesAndJoinComponents [(p, (vr, cs)) | Dependency p vr cs <- ds]
fromDepMap :: DependencyMap -> [Dependency]
-fromDepMap m = [ Dependency p vr cs | (p,(vr,cs)) <- Map.toList (unDependencyMap m) ]
+fromDepMap m = [Dependency p vr cs | (p, (vr, cs)) <- Map.toList (unDependencyMap m)]
-- Apply extra constraints to a dependency map.
-- Combines dependencies where the result will only contain keys from the left
-- (first) map. If a key also exists in the right map, both constraints will
-- be intersected.
constrainBy
- :: DependencyMap
- -> [PackageVersionConstraint]
- -> DependencyMap
-constrainBy = foldl' tightenConstraint where
+ :: DependencyMap
+ -> [PackageVersionConstraint]
+ -> DependencyMap
+constrainBy = foldl' tightenConstraint
+ where
tightenConstraint (DependencyMap l) (PackageVersionConstraint pn vr) = DependencyMap $
- case Map.lookup pn l of
- Nothing -> l
- Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l
+ case Map.lookup pn l of
+ Nothing -> l
+ Just (vr', cs) -> Map.insert pn (intersectVersionRanges vr' vr, cs) l
diff --git a/Cabal-syntax/src/Distribution/Types/ExeDependency.hs b/Cabal-syntax/src/Distribution/Types/ExeDependency.hs
index 7030058bea39abf71c9828b40015fa5510bd6ee4..17a79703fcc9ac94b936d22930365fea0afa602d 100644
--- a/Cabal-syntax/src/Distribution/Types/ExeDependency.hs
+++ b/Cabal-syntax/src/Distribution/Types/ExeDependency.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.ExeDependency
- ( ExeDependency(..)
+ ( ExeDependency (..)
, qualifiedExeName
) where
@@ -13,18 +14,18 @@ import Distribution.Pretty
import Distribution.Types.ComponentName
import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName
-import Distribution.Version (VersionRange, anyVersion, isAnyVersion)
+import Distribution.Version (VersionRange, anyVersion, isAnyVersion)
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as PP
-- | Describes a dependency on an executable from a package
---
-data ExeDependency = ExeDependency
- PackageName
- UnqualComponentName -- name of executable component of package
- VersionRange
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data ExeDependency
+ = ExeDependency
+ PackageName
+ UnqualComponentName -- name of executable component of package
+ VersionRange
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary ExeDependency
instance Structured ExeDependency
@@ -32,10 +33,11 @@ instance NFData ExeDependency where rnf = genericRnf
instance Pretty ExeDependency where
pretty (ExeDependency name exe ver) =
- pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver
+ pretty name <<>> PP.colon <<>> pretty exe PP.<+> pver
where
- pver | isAnyVersion ver = PP.empty
- | otherwise = pretty ver
+ pver
+ | isAnyVersion ver = PP.empty
+ | otherwise = pretty ver
-- |
--
@@ -58,14 +60,13 @@ instance Pretty ExeDependency where
--
-- >>> simpleParsec "happy :happy >= 1.19.12" :: Maybe ExeDependency
-- Nothing
---
instance Parsec ExeDependency where
- parsec = do
- name <- parsec
- _ <- P.char ':'
- exe <- lexemeParsec
- ver <- parsec <|> pure anyVersion
- return (ExeDependency name exe ver)
+ parsec = do
+ name <- parsec
+ _ <- P.char ':'
+ exe <- lexemeParsec
+ ver <- parsec <|> pure anyVersion
+ return (ExeDependency name exe ver)
qualifiedExeName :: ExeDependency -> ComponentName
qualifiedExeName (ExeDependency _ ucn _) = CExeName ucn
diff --git a/Cabal-syntax/src/Distribution/Types/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs
index 45fcc69a6b32d2c8fdd2433fc944425088266cdf..618f91dc5f3eb97f9c701521b16a255fd2606a24 100644
--- a/Cabal-syntax/src/Distribution/Types/Executable.hs
+++ b/Cabal-syntax/src/Distribution/Types/Executable.hs
@@ -1,33 +1,33 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Executable (
- Executable(..),
- emptyExecutable,
- exeModules,
- exeModulesAutogen
-) where
+module Distribution.Types.Executable
+ ( Executable (..)
+ , emptyExecutable
+ , exeModules
+ , exeModulesAutogen
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
+import Distribution.ModuleName
import Distribution.Types.BuildInfo
-import Distribution.Types.UnqualComponentName
import Distribution.Types.ExecutableScope
-import Distribution.ModuleName
+import Distribution.Types.UnqualComponentName
import qualified Distribution.Types.BuildInfo.Lens as L
-data Executable = Executable {
- exeName :: UnqualComponentName,
- modulePath :: FilePath,
- exeScope :: ExecutableScope,
- buildInfo :: BuildInfo
- }
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data Executable = Executable
+ { exeName :: UnqualComponentName
+ , modulePath :: FilePath
+ , exeScope :: ExecutableScope
+ , buildInfo :: BuildInfo
+ }
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance L.HasBuildInfo Executable where
- buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l)
+ buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l)
instance Binary Executable
instance Structured Executable
@@ -38,19 +38,27 @@ instance Monoid Executable where
mappend = (<>)
instance Semigroup Executable where
- a <> b = Executable{
- exeName = combine' exeName,
- modulePath = combine modulePath,
- exeScope = combine exeScope,
- buildInfo = combine buildInfo
- }
- where combine field = field a `mappend` field b
- combine' field = case ( unUnqualComponentName $ field a
- , unUnqualComponentName $ field b) of
- ("", _) -> field b
- (_, "") -> field a
- (x, y) -> error $ "Ambiguous values for executable field: '"
- ++ x ++ "' and '" ++ y ++ "'"
+ a <> b =
+ Executable
+ { exeName = combine' exeName
+ , modulePath = combine modulePath
+ , exeScope = combine exeScope
+ , buildInfo = combine buildInfo
+ }
+ where
+ combine field = field a `mappend` field b
+ combine' field = case ( unUnqualComponentName $ field a
+ , unUnqualComponentName $ field b
+ ) of
+ ("", _) -> field b
+ (_, "") -> field a
+ (x, y) ->
+ error $
+ "Ambiguous values for executable field: '"
+ ++ x
+ ++ "' and '"
+ ++ y
+ ++ "'"
emptyExecutable :: Executable
emptyExecutable = mempty
diff --git a/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs b/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs
index 36813072e69b8309c0e3f23d14a10a9320f79484..73410519e90650f9acb46d2b970c5920b0eb7672 100644
--- a/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs
@@ -1,31 +1,31 @@
-module Distribution.Types.Executable.Lens (
- Executable,
- module Distribution.Types.Executable.Lens,
- ) where
+module Distribution.Types.Executable.Lens
+ ( Executable
+ , module Distribution.Types.Executable.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.Executable (Executable)
-import Distribution.Types.ExecutableScope (ExecutableScope)
+import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.Executable (Executable)
+import Distribution.Types.ExecutableScope (ExecutableScope)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
import qualified Distribution.Types.Executable as T
exeName :: Lens' Executable UnqualComponentName
-exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s))
+exeName f s = fmap (\x -> s{T.exeName = x}) (f (T.exeName s))
{-# INLINE exeName #-}
modulePath :: Lens' Executable String
-modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s))
+modulePath f s = fmap (\x -> s{T.modulePath = x}) (f (T.modulePath s))
{-# INLINE modulePath #-}
exeScope :: Lens' Executable ExecutableScope
-exeScope f s = fmap (\x -> s { T.exeScope = x }) (f (T.exeScope s))
+exeScope f s = fmap (\x -> s{T.exeScope = x}) (f (T.exeScope s))
{-# INLINE exeScope #-}
exeBuildInfo :: Lens' Executable BuildInfo
-exeBuildInfo f s = fmap (\x -> s { T.buildInfo = x }) (f (T.buildInfo s))
+exeBuildInfo f s = fmap (\x -> s{T.buildInfo = x}) (f (T.buildInfo s))
{-# INLINE exeBuildInfo #-}
diff --git a/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs b/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs
index 520261692c66c136b08fc88f09f6eb591a10d3db..1221fae1c1a7b7908600924b41b8d99c4ac43e05 100644
--- a/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs
+++ b/Cabal-syntax/src/Distribution/Types/ExecutableScope.hs
@@ -2,31 +2,33 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.ExecutableScope (
- ExecutableScope(..),
-) where
+module Distribution.Types.ExecutableScope
+ ( ExecutableScope (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-data ExecutableScope = ExecutablePublic
- | ExecutablePrivate
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data ExecutableScope
+ = ExecutablePublic
+ | ExecutablePrivate
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Pretty ExecutableScope where
- pretty ExecutablePublic = Disp.text "public"
- pretty ExecutablePrivate = Disp.text "private"
+ pretty ExecutablePublic = Disp.text "public"
+ pretty ExecutablePrivate = Disp.text "private"
instance Parsec ExecutableScope where
- parsec = P.try pub <|> pri where
- pub = ExecutablePublic <$ P.string "public"
- pri = ExecutablePrivate <$ P.string "private"
+ parsec = P.try pub <|> pri
+ where
+ pub = ExecutablePublic <$ P.string "public"
+ pri = ExecutablePrivate <$ P.string "private"
instance Binary ExecutableScope
instance Structured ExecutableScope
@@ -34,10 +36,10 @@ instance NFData ExecutableScope where rnf = genericRnf
-- | 'Any' like semigroup, where 'ExecutablePrivate' is 'Any True'
instance Semigroup ExecutableScope where
- ExecutablePublic <> x = x
- x@ExecutablePrivate <> _ = x
+ ExecutablePublic <> x = x
+ x@ExecutablePrivate <> _ = x
-- | 'mempty' = 'ExecutablePublic'
instance Monoid ExecutableScope where
- mempty = ExecutablePublic
- mappend = (<>)
+ mempty = ExecutablePublic
+ mappend = (<>)
diff --git a/Cabal-syntax/src/Distribution/Types/ExposedModule.hs b/Cabal-syntax/src/Distribution/Types/ExposedModule.hs
index 22f8d7b9803a19eab6e89260d3879f96c6e3e158..4afd03a32632bf809542968dd2d26ed40666ccc2 100644
--- a/Cabal-syntax/src/Distribution/Types/ExposedModule.hs
+++ b/Cabal-syntax/src/Distribution/Types/ExposedModule.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.ExposedModule where
import Distribution.Compat.Prelude
@@ -11,34 +12,34 @@ import Distribution.Parsec
import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-data ExposedModule
- = ExposedModule {
- exposedName :: ModuleName,
- exposedReexport :: Maybe OpenModule
- }
+data ExposedModule = ExposedModule
+ { exposedName :: ModuleName
+ , exposedReexport :: Maybe OpenModule
+ }
deriving (Eq, Generic, Read, Show, Typeable)
instance Pretty ExposedModule where
- pretty (ExposedModule m reexport) =
- Disp.hsep [ pretty m
- , case reexport of
- Just m' -> Disp.hsep [Disp.text "from", pretty m']
- Nothing -> Disp.empty
- ]
+ pretty (ExposedModule m reexport) =
+ Disp.hsep
+ [ pretty m
+ , case reexport of
+ Just m' -> Disp.hsep [Disp.text "from", pretty m']
+ Nothing -> Disp.empty
+ ]
instance Parsec ExposedModule where
- parsec = do
- m <- parsecMaybeQuoted parsec
- P.spaces
+ parsec = do
+ m <- parsecMaybeQuoted parsec
+ P.spaces
- reexport <- P.optional $ do
- _ <- P.string "from"
- P.skipSpaces1
- parsec
+ reexport <- P.optional $ do
+ _ <- P.string "from"
+ P.skipSpaces1
+ parsec
- return (ExposedModule m reexport)
+ return (ExposedModule m reexport)
instance Binary ExposedModule
instance Structured ExposedModule
diff --git a/Cabal-syntax/src/Distribution/Types/Flag.hs b/Cabal-syntax/src/Distribution/Types/Flag.hs
index 83cff4e06398e3b993e6e5b1c4c9a17883aad22c..eff71748d9f33accda53ddb8c388ca91cf528dbe 100644
--- a/Cabal-syntax/src/Distribution/Types/Flag.hs
+++ b/Cabal-syntax/src/Distribution/Types/Flag.hs
@@ -1,45 +1,49 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Distribution.Types.Flag (
- -- * Package flag
- PackageFlag(..),
- emptyFlag,
+
+module Distribution.Types.Flag
+ ( -- * Package flag
+ PackageFlag (..)
+ , emptyFlag
+
-- * Flag name
- FlagName,
- mkFlagName,
- unFlagName,
+ , FlagName
+ , mkFlagName
+ , unFlagName
+
-- * Flag assignment
- FlagAssignment,
- mkFlagAssignment,
- unFlagAssignment,
- lookupFlagAssignment,
- insertFlagAssignment,
- diffFlagAssignment,
- findDuplicateFlagAssignments,
- nullFlagAssignment,
- showFlagValue,
- dispFlagAssignment,
- showFlagAssignment,
- parsecFlagAssignment,
- parsecFlagAssignmentNonEmpty,
+ , FlagAssignment
+ , mkFlagAssignment
+ , unFlagAssignment
+ , lookupFlagAssignment
+ , insertFlagAssignment
+ , diffFlagAssignment
+ , findDuplicateFlagAssignments
+ , nullFlagAssignment
+ , showFlagValue
+ , dispFlagAssignment
+ , showFlagAssignment
+ , parsecFlagAssignment
+ , parsecFlagAssignmentNonEmpty
+
-- ** Legacy formats
- legacyShowFlagAssignment,
- legacyShowFlagAssignment',
- legacyParsecFlagAssignment,
- ) where
+ , legacyShowFlagAssignment
+ , legacyShowFlagAssignment'
+ , legacyParsecFlagAssignment
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
-import Distribution.Utils.ShortText
import Distribution.Utils.Generic (lowercase)
+import Distribution.Utils.ShortText
+import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
import qualified Data.Map as Map
-import qualified Text.PrettyPrint as Disp
import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint as Disp
-- -----------------------------------------------------------------------------
-- The Flag' type
@@ -47,12 +51,12 @@ import qualified Distribution.Compat.CharParsing as P
-- | A flag can represent a feature to be included, or a way of linking
-- a target against its dependencies, or in fact whatever you can think of.
data PackageFlag = MkPackageFlag
- { flagName :: FlagName
- , flagDescription :: String
- , flagDefault :: Bool
- , flagManual :: Bool
- }
- deriving (Show, Eq, Typeable, Data, Generic)
+ { flagName :: FlagName
+ , flagDescription :: String
+ , flagDefault :: Bool
+ , flagManual :: Bool
+ }
+ deriving (Show, Eq, Typeable, Data, Generic)
instance Binary PackageFlag
instance Structured PackageFlag
@@ -60,11 +64,12 @@ instance NFData PackageFlag where rnf = genericRnf
-- | A 'PackageFlag' initialized with default parameters.
emptyFlag :: FlagName -> PackageFlag
-emptyFlag name = MkPackageFlag
- { flagName = name
+emptyFlag name =
+ MkPackageFlag
+ { flagName = name
, flagDescription = ""
- , flagDefault = True
- , flagManual = False
+ , flagDefault = True
+ , flagManual = False
}
-- | A 'FlagName' is the name of a user-defined configuration flag
@@ -75,7 +80,7 @@ emptyFlag name = MkPackageFlag
--
-- @since 2.0.0.2
newtype FlagName = FlagName ShortText
- deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData)
+ deriving (Eq, Generic, Ord, Show, Read, Typeable, Data, NFData)
-- | Construct a 'FlagName' from a 'String'
--
@@ -92,7 +97,7 @@ mkFlagName = FlagName . toShortText
--
-- @since 2.0.0.2
instance IsString FlagName where
- fromString = mkFlagName
+ fromString = mkFlagName
-- | Convert 'FlagName' to 'String'
--
@@ -104,16 +109,16 @@ instance Binary FlagName
instance Structured FlagName
instance Pretty FlagName where
- pretty = Disp.text . unFlagName
+ pretty = Disp.text . unFlagName
instance Parsec FlagName where
- -- Note: we don't check that FlagName doesn't have leading dash,
- -- cabal check will do that.
- parsec = mkFlagName . lowercase <$> parsec'
- where
- parsec' = (:) <$> lead <*> rest
- lead = P.satisfy (\c -> isAlphaNum c || c == '_')
- rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
+ -- Note: we don't check that FlagName doesn't have leading dash,
+ -- cabal check will do that.
+ parsec = mkFlagName . lowercase <$> parsec'
+ where
+ parsec' = (:) <$> lead <*> rest
+ lead = P.satisfy (\c -> isAlphaNum c || c == '_')
+ rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-')
-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
-- 'Bool' flag values. It represents the flags chosen by the user or
@@ -121,26 +126,23 @@ instance Parsec FlagName where
-- becomes @[("foo", True), ("bar", False)]@
--
-- TODO: Why we record the multiplicity of the flag?
---
-newtype FlagAssignment
- = FlagAssignment { getFlagAssignment :: Map.Map FlagName (Int, Bool) }
+newtype FlagAssignment = FlagAssignment {getFlagAssignment :: Map.Map FlagName (Int, Bool)}
deriving (Binary, Generic, NFData, Typeable)
instance Structured FlagAssignment
instance Eq FlagAssignment where
- (==) (FlagAssignment m1) (FlagAssignment m2)
- = fmap snd m1 == fmap snd m2
+ (==) (FlagAssignment m1) (FlagAssignment m2) =
+ fmap snd m1 == fmap snd m2
instance Ord FlagAssignment where
- compare (FlagAssignment m1) (FlagAssignment m2)
- = fmap snd m1 `compare` fmap snd m2
+ compare (FlagAssignment m1) (FlagAssignment m2) =
+ fmap snd m1 `compare` fmap snd m2
-- | Combines pairs of values contained in the 'FlagAssignment' Map.
--
-- The last flag specified takes precedence, and we record the number
-- of times we have seen the flag.
---
combineFlagValues :: (Int, Bool) -> (Int, Bool) -> (Int, Bool)
combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2)
@@ -151,8 +153,8 @@ combineFlagValues (c1, _) (c2, b2) = (c1 + c2, b2)
-- specified so that we have the option of warning the user about
-- supplying duplicate flags.
instance Semigroup FlagAssignment where
- (<>) (FlagAssignment m1) (FlagAssignment m2)
- = FlagAssignment (Map.unionWith combineFlagValues m1 m2)
+ (<>) (FlagAssignment m1) (FlagAssignment m2) =
+ FlagAssignment (Map.unionWith combineFlagValues m1 m2)
instance Monoid FlagAssignment where
mempty = FlagAssignment Map.empty
@@ -166,8 +168,9 @@ instance Monoid FlagAssignment where
-- @since 2.2.0
mkFlagAssignment :: [(FlagName, Bool)] -> FlagAssignment
mkFlagAssignment =
- FlagAssignment .
- Map.fromListWith (flip combineFlagValues) . fmap (fmap (\b -> (1, b)))
+ FlagAssignment
+ . Map.fromListWith (flip combineFlagValues)
+ . fmap (fmap (\b -> (1, b)))
-- | Deconstruct a 'FlagAssignment' into a list of flag/value pairs.
--
@@ -204,8 +207,9 @@ insertFlagAssignment :: FlagName -> Bool -> FlagAssignment -> FlagAssignment
-- flag; rather than enforcing uniqueness at construction, it's
-- verified later on via `D.C.Dependency.configuredPackageProblems`
insertFlagAssignment flag val =
- FlagAssignment .
- Map.insertWith (flip combineFlagValues) flag (1, val) . getFlagAssignment
+ FlagAssignment
+ . Map.insertWith (flip combineFlagValues) flag (1, val)
+ . getFlagAssignment
-- | Remove all flag-assignments from the first 'FlagAssignment' that
-- are contained in the second 'FlagAssignment'
@@ -217,8 +221,9 @@ insertFlagAssignment flag val =
--
-- @since 2.2.0
diffFlagAssignment :: FlagAssignment -> FlagAssignment -> FlagAssignment
-diffFlagAssignment fa1 fa2 = FlagAssignment
- (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2))
+diffFlagAssignment fa1 fa2 =
+ FlagAssignment
+ (Map.difference (getFlagAssignment fa1) (getFlagAssignment fa2))
-- | Find the 'FlagName's that have been listed more than once.
--
@@ -229,20 +234,20 @@ findDuplicateFlagAssignments =
-- | @since 2.2.0
instance Read FlagAssignment where
- readsPrec p s = [ (FlagAssignment x, rest) | (x,rest) <- readsPrec p s ]
+ readsPrec p s = [(FlagAssignment x, rest) | (x, rest) <- readsPrec p s]
-- | @since 2.2.0
instance Show FlagAssignment where
- showsPrec p (FlagAssignment xs) = showsPrec p xs
+ showsPrec p (FlagAssignment xs) = showsPrec p xs
-- | String representation of a flag-value pair.
showFlagValue :: (FlagName, Bool) -> String
-showFlagValue (f, True) = '+' : unFlagName f
-showFlagValue (f, False) = '-' : unFlagName f
+showFlagValue (f, True) = '+' : unFlagName f
+showFlagValue (f, False) = '-' : unFlagName f
-- | @since 3.4.0.0
instance Pretty FlagAssignment where
- pretty = dispFlagAssignment
+ pretty = dispFlagAssignment
-- |
--
@@ -273,33 +278,31 @@ instance Pretty FlagAssignment where
-- Nothing
--
-- @since 3.4.0.0
---
instance Parsec FlagAssignment where
- parsec = parsecFlagAssignment
+ parsec = parsecFlagAssignment
-- | Pretty-prints a flag assignment.
dispFlagAssignment :: FlagAssignment -> Disp.Doc
dispFlagAssignment = Disp.hsep . map (Disp.text . showFlagValue) . unFlagAssignment
-
-
-- | Parses a flag assignment.
parsecFlagAssignment :: CabalParsing m => m FlagAssignment
parsecFlagAssignment = mkFlagAssignment <$> sepByEnding (onFlag <|> offFlag) P.skipSpaces1
where
onFlag = do
- _ <- P.char '+'
- f <- parsec
- return (f, True)
+ _ <- P.char '+'
+ f <- parsec
+ return (f, True)
offFlag = do
- _ <- P.char '-'
- f <- parsec
- return (f, False)
+ _ <- P.char '-'
+ f <- parsec
+ return (f, False)
sepByEnding :: CabalParsing m => m a -> m b -> m [a]
- sepByEnding p sep = afterSeparator where
- element = (:) <$> p <*> afterElement
- afterElement = sep *> afterSeparator <|> pure []
+ sepByEnding p sep = afterSeparator
+ where
+ element = (:) <$> p <*> afterElement
+ afterElement = sep *> afterSeparator <|> pure []
afterSeparator = element <|> pure []
-- | Parse a non-empty flag assignment
@@ -311,18 +314,19 @@ parsecFlagAssignmentNonEmpty :: CabalParsing m => m FlagAssignment
parsecFlagAssignmentNonEmpty = mkFlagAssignment <$> sepByEnding1 (onFlag <|> offFlag) P.skipSpaces1
where
onFlag = do
- _ <- P.char '+'
- f <- parsec
- return (f, True)
+ _ <- P.char '+'
+ f <- parsec
+ return (f, True)
offFlag = do
- _ <- P.char '-'
- f <- parsec
- return (f, False)
+ _ <- P.char '-'
+ f <- parsec
+ return (f, False)
sepByEnding1 :: CabalParsing m => m a -> m b -> m [a]
- sepByEnding1 p sep = element where
- element = (:) <$> p <*> afterElement
- afterElement = sep *> afterSeparator <|> pure []
+ sepByEnding1 p sep = element
+ where
+ element = (:) <$> p <*> afterElement
+ afterElement = sep *> afterSeparator <|> pure []
afterSeparator = element <|> pure []
-- | Show flag assignment.
@@ -340,7 +344,7 @@ showFlagAssignment = prettyShow . dispFlagAssignment
-- @since 3.4.0.0
legacyShowFlagAssignment :: FlagAssignment -> String
legacyShowFlagAssignment =
- prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment'
+ prettyShow . Disp.hsep . map Disp.text . legacyShowFlagAssignment'
-- | @since 3.4.0.0
legacyShowFlagAssignment' :: FlagAssignment -> [String]
@@ -348,22 +352,23 @@ legacyShowFlagAssignment' = map legacyShowFlagValue . unFlagAssignment
-- | @since 3.4.0.0
legacyShowFlagValue :: (FlagName, Bool) -> String
-legacyShowFlagValue (f, True) = unFlagName f
-legacyShowFlagValue (f, False) = '-' : unFlagName f
+legacyShowFlagValue (f, True) = unFlagName f
+legacyShowFlagValue (f, False) = '-' : unFlagName f
-- |
-- We need this as far as we support custom setups older than 2.2.0.0
--
-- @since 3.4.0.0
legacyParsecFlagAssignment :: CabalParsing m => m FlagAssignment
-legacyParsecFlagAssignment = mkFlagAssignment <$>
- P.sepBy (onFlag <|> offFlag) P.skipSpaces1
+legacyParsecFlagAssignment =
+ mkFlagAssignment
+ <$> P.sepBy (onFlag <|> offFlag) P.skipSpaces1
where
onFlag = do
- _ <- P.optional (P.char '+')
- f <- parsec
- return (f, True)
+ _ <- P.optional (P.char '+')
+ f <- parsec
+ return (f, True)
offFlag = do
- _ <- P.char '-'
- f <- parsec
- return (f, False)
+ _ <- P.char '-'
+ f <- parsec
+ return (f, False)
diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs
index d1883483d5f41365828656622c1ac590ea252775..9d714f9895f778d51b220887b59f8847906af7e7 100644
--- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs
+++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs
@@ -1,20 +1,19 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-
-module Distribution.Types.ForeignLib(
- ForeignLib(..),
- emptyForeignLib,
- foreignLibModules,
- foreignLibIsShared,
- foreignLibVersion,
-
- LibVersionInfo,
- mkLibVersionInfo,
- libVersionInfoCRA,
- libVersionNumber,
- libVersionNumberShow,
- libVersionMajor
-) where
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Types.ForeignLib
+ ( ForeignLib (..)
+ , emptyForeignLib
+ , foreignLibModules
+ , foreignLibIsShared
+ , foreignLibVersion
+ , LibVersionInfo
+ , mkLibVersionInfo
+ , libVersionInfoCRA
+ , libVersionNumber
+ , libVersionNumberShow
+ , libVersionMajor
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -30,76 +29,76 @@ import Distribution.Types.UnqualComponentName
import Distribution.Version
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
-import qualified Text.Read as Read
+import qualified Text.PrettyPrint as Disp
+import qualified Text.Read as Read
import qualified Distribution.Types.BuildInfo.Lens as L
-- | A foreign library stanza is like a library stanza, except that
-- the built code is intended for consumption by a non-Haskell client.
-data ForeignLib = ForeignLib {
- -- | Name of the foreign library
- foreignLibName :: UnqualComponentName
- -- | What kind of foreign library is this (static or dynamic).
- , foreignLibType :: ForeignLibType
- -- | What options apply to this foreign library (e.g., are we
- -- merging in all foreign dependencies.)
- , foreignLibOptions :: [ForeignLibOption]
- -- | Build information for this foreign library.
- , foreignLibBuildInfo :: BuildInfo
- -- | Libtool-style version-info data to compute library version.
- -- Refer to the libtool documentation on the
- -- current:revision:age versioning scheme.
- , foreignLibVersionInfo :: Maybe LibVersionInfo
- -- | Linux library version
- , foreignLibVersionLinux :: Maybe Version
-
- -- | (Windows-specific) module definition files
- --
- -- This is a list rather than a maybe field so that we can flatten
- -- the condition trees (for instance, when creating an sdist)
- , foreignLibModDefFile :: [FilePath]
- }
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data ForeignLib = ForeignLib
+ { foreignLibName :: UnqualComponentName
+ -- ^ Name of the foreign library
+ , foreignLibType :: ForeignLibType
+ -- ^ What kind of foreign library is this (static or dynamic).
+ , foreignLibOptions :: [ForeignLibOption]
+ -- ^ What options apply to this foreign library (e.g., are we
+ -- merging in all foreign dependencies.)
+ , foreignLibBuildInfo :: BuildInfo
+ -- ^ Build information for this foreign library.
+ , foreignLibVersionInfo :: Maybe LibVersionInfo
+ -- ^ Libtool-style version-info data to compute library version.
+ -- Refer to the libtool documentation on the
+ -- current:revision:age versioning scheme.
+ , foreignLibVersionLinux :: Maybe Version
+ -- ^ Linux library version
+ , foreignLibModDefFile :: [FilePath]
+ -- ^ (Windows-specific) module definition files
+ --
+ -- This is a list rather than a maybe field so that we can flatten
+ -- the condition trees (for instance, when creating an sdist)
+ }
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic, Typeable)
instance Ord LibVersionInfo where
- LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ =
- case c `compare` c' of
- EQ -> r `compare` r'
- e -> e
+ LibVersionInfo c r _ `compare` LibVersionInfo c' r' _ =
+ case c `compare` c' of
+ EQ -> r `compare` r'
+ e -> e
instance Show LibVersionInfo where
- showsPrec d (LibVersionInfo c r a) = showParen (d > 10)
- $ showString "mkLibVersionInfo "
- . showsPrec 11 (c,r,a)
+ showsPrec d (LibVersionInfo c r a) =
+ showParen (d > 10) $
+ showString "mkLibVersionInfo "
+ . showsPrec 11 (c, r, a)
instance Read LibVersionInfo where
- readPrec = Read.parens $ do
- Read.Ident "mkLibVersionInfo" <- Read.lexP
- t <- Read.step Read.readPrec
- return (mkLibVersionInfo t)
+ readPrec = Read.parens $ do
+ Read.Ident "mkLibVersionInfo" <- Read.lexP
+ t <- Read.step Read.readPrec
+ return (mkLibVersionInfo t)
instance Binary LibVersionInfo
instance Structured LibVersionInfo
instance NFData LibVersionInfo where rnf = genericRnf
instance Pretty LibVersionInfo where
- pretty (LibVersionInfo c r a)
- = Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c,r,a]
+ pretty (LibVersionInfo c r a) =
+ Disp.hcat $ Disp.punctuate (Disp.char ':') $ map Disp.int [c, r, a]
instance Parsec LibVersionInfo where
- parsec = do
- c <- P.integral
- (r, a) <- P.option (0,0) $ do
- _ <- P.char ':'
- r <- P.integral
- a <- P.option 0 $ do
- _ <- P.char ':'
- P.integral
- return (r,a)
- return $ mkLibVersionInfo (c,r,a)
+ parsec = do
+ c <- P.integral
+ (r, a) <- P.option (0, 0) $ do
+ _ <- P.char ':'
+ r <- P.integral
+ a <- P.option 0 $ do
+ _ <- P.char ':'
+ P.integral
+ return (r, a)
+ return $ mkLibVersionInfo (c, r, a)
-- | Construct 'LibVersionInfo' from @(current, revision, age)@
-- numbers.
@@ -109,64 +108,73 @@ instance Parsec LibVersionInfo where
--
-- All version components must be non-negative.
mkLibVersionInfo :: (Int, Int, Int) -> LibVersionInfo
-mkLibVersionInfo (c,r,a) = LibVersionInfo c r a
+mkLibVersionInfo (c, r, a) = LibVersionInfo c r a
-- | From a given 'LibVersionInfo', extract the @(current, revision,
-- age)@ numbers.
libVersionInfoCRA :: LibVersionInfo -> (Int, Int, Int)
-libVersionInfoCRA (LibVersionInfo c r a) = (c,r,a)
+libVersionInfoCRA (LibVersionInfo c r a) = (c, r, a)
-- | Given a version-info field, produce a @major.minor.build@ version
libVersionNumber :: LibVersionInfo -> (Int, Int, Int)
-libVersionNumber (LibVersionInfo c r a) = (c-a , a , r)
+libVersionNumber (LibVersionInfo c r a) = (c - a, a, r)
-- | Given a version-info field, return @"major.minor.build"@ as a
-- 'String'
libVersionNumberShow :: LibVersionInfo -> String
libVersionNumberShow v =
- let (major, minor, build) = libVersionNumber v
- in show major ++ "." ++ show minor ++ "." ++ show build
+ let (major, minor, build) = libVersionNumber v
+ in show major ++ "." ++ show minor ++ "." ++ show build
-- | Return the @major@ version of a version-info field.
libVersionMajor :: LibVersionInfo -> Int
-libVersionMajor (LibVersionInfo c _ a) = c-a
+libVersionMajor (LibVersionInfo c _ a) = c - a
instance L.HasBuildInfo ForeignLib where
- buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l)
+ buildInfo f l = (\x -> l{foreignLibBuildInfo = x}) <$> f (foreignLibBuildInfo l)
instance Binary ForeignLib
instance Structured ForeignLib
instance NFData ForeignLib where rnf = genericRnf
instance Semigroup ForeignLib where
- a <> b = ForeignLib {
- foreignLibName = combine' foreignLibName
- , foreignLibType = combine foreignLibType
- , foreignLibOptions = combine foreignLibOptions
- , foreignLibBuildInfo = combine foreignLibBuildInfo
- , foreignLibVersionInfo = combine'' foreignLibVersionInfo
- , foreignLibVersionLinux = combine'' foreignLibVersionLinux
- , foreignLibModDefFile = combine foreignLibModDefFile
- }
- where combine field = field a `mappend` field b
- combine' field = case ( unUnqualComponentName $ field a
- , unUnqualComponentName $ field b) of
- ("", _) -> field b
- (_, "") -> field a
- (x, y) -> error $ "Ambiguous values for executable field: '"
- ++ x ++ "' and '" ++ y ++ "'"
- combine'' field = field b
+ a <> b =
+ ForeignLib
+ { foreignLibName = combine' foreignLibName
+ , foreignLibType = combine foreignLibType
+ , foreignLibOptions = combine foreignLibOptions
+ , foreignLibBuildInfo = combine foreignLibBuildInfo
+ , foreignLibVersionInfo = combine'' foreignLibVersionInfo
+ , foreignLibVersionLinux = combine'' foreignLibVersionLinux
+ , foreignLibModDefFile = combine foreignLibModDefFile
+ }
+ where
+ combine field = field a `mappend` field b
+ combine' field = case ( unUnqualComponentName $ field a
+ , unUnqualComponentName $ field b
+ ) of
+ ("", _) -> field b
+ (_, "") -> field a
+ (x, y) ->
+ error $
+ "Ambiguous values for executable field: '"
+ ++ x
+ ++ "' and '"
+ ++ y
+ ++ "'"
+ combine'' field = field b
instance Monoid ForeignLib where
- mempty = ForeignLib {
- foreignLibName = mempty
- , foreignLibType = ForeignLibTypeUnknown
- , foreignLibOptions = []
- , foreignLibBuildInfo = mempty
- , foreignLibVersionInfo = Nothing
- , foreignLibVersionLinux = Nothing
- , foreignLibModDefFile = []
- }
+ mempty =
+ ForeignLib
+ { foreignLibName = mempty
+ , foreignLibType = ForeignLibTypeUnknown
+ , foreignLibOptions = []
+ , foreignLibBuildInfo = mempty
+ , foreignLibVersionInfo = Nothing
+ , foreignLibVersionLinux = Nothing
+ , foreignLibModDefFile = []
+ }
mappend = (<>)
-- | An empty foreign library.
@@ -189,11 +197,11 @@ foreignLibIsShared = foreignLibTypeIsShared . foreignLibType
foreignLibVersion :: ForeignLib -> OS -> [Int]
foreignLibVersion flib Linux =
case foreignLibVersionLinux flib of
- Just v -> versionNumbers v
+ Just v -> versionNumbers v
Nothing ->
case foreignLibVersionInfo flib of
Just v' ->
let (major, minor, build) = libVersionNumber v'
- in [major, minor, build]
+ in [major, minor, build]
Nothing -> []
foreignLibVersion _ _ = []
diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs
index fe2df57733ce399237bc93fef4aa32e75ceae45c..a5905af2ff8f13b425aa8d662167b7a23a0da71a 100644
--- a/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs
@@ -1,45 +1,45 @@
-module Distribution.Types.ForeignLib.Lens (
- ForeignLib,
- module Distribution.Types.ForeignLib.Lens,
- ) where
+module Distribution.Types.ForeignLib.Lens
+ ( ForeignLib
+ , module Distribution.Types.ForeignLib.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo)
-import Distribution.Types.ForeignLibOption (ForeignLibOption)
-import Distribution.Types.ForeignLibType (ForeignLibType)
+import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo)
+import Distribution.Types.ForeignLibOption (ForeignLibOption)
+import Distribution.Types.ForeignLibType (ForeignLibType)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
-import Distribution.Version (Version)
+import Distribution.Version (Version)
import qualified Distribution.Types.ForeignLib as T
foreignLibName :: Lens' ForeignLib UnqualComponentName
-foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s))
+foreignLibName f s = fmap (\x -> s{T.foreignLibName = x}) (f (T.foreignLibName s))
{-# INLINE foreignLibName #-}
foreignLibType :: Lens' ForeignLib ForeignLibType
-foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s))
+foreignLibType f s = fmap (\x -> s{T.foreignLibType = x}) (f (T.foreignLibType s))
{-# INLINE foreignLibType #-}
foreignLibOptions :: Lens' ForeignLib [ForeignLibOption]
-foreignLibOptions f s = fmap (\x -> s { T.foreignLibOptions = x }) (f (T.foreignLibOptions s))
+foreignLibOptions f s = fmap (\x -> s{T.foreignLibOptions = x}) (f (T.foreignLibOptions s))
{-# INLINE foreignLibOptions #-}
foreignLibBuildInfo :: Lens' ForeignLib BuildInfo
-foreignLibBuildInfo f s = fmap (\x -> s { T.foreignLibBuildInfo = x }) (f (T.foreignLibBuildInfo s))
+foreignLibBuildInfo f s = fmap (\x -> s{T.foreignLibBuildInfo = x}) (f (T.foreignLibBuildInfo s))
{-# INLINE foreignLibBuildInfo #-}
foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo)
-foreignLibVersionInfo f s = fmap (\x -> s { T.foreignLibVersionInfo = x }) (f (T.foreignLibVersionInfo s))
+foreignLibVersionInfo f s = fmap (\x -> s{T.foreignLibVersionInfo = x}) (f (T.foreignLibVersionInfo s))
{-# INLINE foreignLibVersionInfo #-}
foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version)
-foreignLibVersionLinux f s = fmap (\x -> s { T.foreignLibVersionLinux = x }) (f (T.foreignLibVersionLinux s))
+foreignLibVersionLinux f s = fmap (\x -> s{T.foreignLibVersionLinux = x}) (f (T.foreignLibVersionLinux s))
{-# INLINE foreignLibVersionLinux #-}
foreignLibModDefFile :: Lens' ForeignLib [FilePath]
-foreignLibModDefFile f s = fmap (\x -> s { T.foreignLibModDefFile = x }) (f (T.foreignLibModDefFile s))
+foreignLibModDefFile f s = fmap (\x -> s{T.foreignLibModDefFile = x}) (f (T.foreignLibModDefFile s))
{-# INLINE foreignLibModDefFile #-}
diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs b/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs
index 4b9a2bc2c663d3716ab78c9b3afe371d18a562b0..5ed65410e70c3ec53eea213f198b09f35d119ce9 100644
--- a/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs
+++ b/Cabal-syntax/src/Distribution/Types/ForeignLibOption.hs
@@ -2,27 +2,27 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.ForeignLibOption(
- ForeignLibOption(..)
-) where
+module Distribution.Types.ForeignLibOption
+ ( ForeignLibOption (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-data ForeignLibOption =
- -- | Merge in all dependent libraries (i.e., use
- -- @ghc -shared -static@ rather than just record
- -- the dependencies, ala @ghc -shared -dynamic@).
- -- This option is compulsory on Windows and unsupported
- -- on other platforms.
- ForeignLibStandalone
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data ForeignLibOption
+ = -- | Merge in all dependent libraries (i.e., use
+ -- @ghc -shared -static@ rather than just record
+ -- the dependencies, ala @ghc -shared -dynamic@).
+ -- This option is compulsory on Windows and unsupported
+ -- on other platforms.
+ ForeignLibStandalone
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Pretty ForeignLibOption where
pretty ForeignLibStandalone = Disp.text "standalone"
@@ -32,7 +32,7 @@ instance Parsec ForeignLibOption where
name <- P.munch1 (\c -> isAlphaNum c || c == '-')
case name of
"standalone" -> return ForeignLibStandalone
- _ -> fail "unrecognized foreign-library option"
+ _ -> fail "unrecognized foreign-library option"
instance Binary ForeignLibOption
instance Structured ForeignLibOption
diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs b/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs
index d5d80d97cba225d0c2fc6c20cf9c783676ef9fc2..23617b80c48ae031fbb0078a7ca256e2307440b7 100644
--- a/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs
+++ b/Cabal-syntax/src/Distribution/Types/ForeignLibType.hs
@@ -2,37 +2,37 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.ForeignLibType(
- ForeignLibType(..),
- knownForeignLibTypes,
- foreignLibTypeIsShared,
-) where
+module Distribution.Types.ForeignLibType
+ ( ForeignLibType (..)
+ , knownForeignLibTypes
+ , foreignLibTypeIsShared
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.PackageDescription.Utils
+import Prelude ()
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-- | What kind of foreign library is to be built?
-data ForeignLibType =
- -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or
- -- @.dll@ on Windows).
- ForeignLibNativeShared
- -- | A native static library (not currently supported.)
- | ForeignLibNativeStatic
- -- TODO: Maybe this should record a string?
- | ForeignLibTypeUnknown
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data ForeignLibType
+ = -- | A native shared library (@.so@ on Linux, @.dylib@ on OSX, or
+ -- @.dll@ on Windows).
+ ForeignLibNativeShared
+ | -- | A native static library (not currently supported.)
+ ForeignLibNativeStatic
+ | -- TODO: Maybe this should record a string?
+ ForeignLibTypeUnknown
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Pretty ForeignLibType where
pretty ForeignLibNativeShared = Disp.text "native-shared"
pretty ForeignLibNativeStatic = Disp.text "native-static"
- pretty ForeignLibTypeUnknown = Disp.text "unknown"
+ pretty ForeignLibTypeUnknown = Disp.text "unknown"
instance Parsec ForeignLibType where
parsec = do
@@ -40,7 +40,7 @@ instance Parsec ForeignLibType where
return $ case name of
"native-shared" -> ForeignLibNativeShared
"native-static" -> ForeignLibNativeStatic
- _ -> ForeignLibTypeUnknown
+ _ -> ForeignLibTypeUnknown
instance Binary ForeignLibType
instance Structured ForeignLibType
@@ -56,14 +56,14 @@ instance Monoid ForeignLibType where
mappend = (<>)
knownForeignLibTypes :: [ForeignLibType]
-knownForeignLibTypes = [
- ForeignLibNativeShared
- , ForeignLibNativeStatic
- ]
+knownForeignLibTypes =
+ [ ForeignLibNativeShared
+ , ForeignLibNativeStatic
+ ]
foreignLibTypeIsShared :: ForeignLibType -> Bool
foreignLibTypeIsShared t =
- case t of
- ForeignLibNativeShared -> True
- ForeignLibNativeStatic -> False
- ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type"
+ case t of
+ ForeignLibNativeShared -> True
+ ForeignLibNativeStatic -> False
+ ForeignLibTypeUnknown -> cabalBug "Unknown foreign library type"
diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs
index ee8f9d5284b1d3168e3ac9193e122beadb427e9b..55ec8652304e8c590a46a0ad63f534ede1917324 100644
--- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs
+++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs
@@ -3,62 +3,75 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Types.GenericPackageDescription (
- GenericPackageDescription(..),
- emptyGenericPackageDescription,
-) where
+module Distribution.Types.GenericPackageDescription
+ ( GenericPackageDescription (..)
+ , emptyGenericPackageDescription
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- lens
-import Distribution.Compat.Lens as L
-import qualified Distribution.Types.BuildInfo.Lens as L
+import Distribution.Compat.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
import Distribution.Types.PackageDescription
+import Distribution.Package
import Distribution.Types.Benchmark
import Distribution.Types.CondTree
import Distribution.Types.ConfVar
-import Distribution.Types.Dependency
import Distribution.Types.Executable
import Distribution.Types.Flag
import Distribution.Types.ForeignLib
import Distribution.Types.Library
import Distribution.Types.TestSuite
import Distribution.Types.UnqualComponentName
-import Distribution.Package
import Distribution.Version
-- ---------------------------------------------------------------------------
-- The 'GenericPackageDescription' type
-data GenericPackageDescription =
- GenericPackageDescription
+data GenericPackageDescription = GenericPackageDescription
{ packageDescription :: PackageDescription
- , gpdScannedVersion :: Maybe Version
- -- ^ This is a version as specified in source.
- -- We populate this field in index reading for dummy GPDs,
- -- only when GPD reading failed, but scanning haven't.
- --
- -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion.
- --
- -- Perfectly, PackageIndex should have sum type, so we don't need to
- -- have dummy GPDs.
- , genPackageFlags :: [PackageFlag]
- , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
- , condSubLibraries :: [( UnqualComponentName
- , CondTree ConfVar [Dependency] Library )]
- , condForeignLibs :: [( UnqualComponentName
- , CondTree ConfVar [Dependency] ForeignLib )]
- , condExecutables :: [( UnqualComponentName
- , CondTree ConfVar [Dependency] Executable )]
- , condTestSuites :: [( UnqualComponentName
- , CondTree ConfVar [Dependency] TestSuite )]
- , condBenchmarks :: [( UnqualComponentName
- , CondTree ConfVar [Dependency] Benchmark )]
+ , gpdScannedVersion :: Maybe Version
+ -- ^ This is a version as specified in source.
+ -- We populate this field in index reading for dummy GPDs,
+ -- only when GPD reading failed, but scanning haven't.
+ --
+ -- Cabal-the-library never produces GPDs with Just as gpdScannedVersion.
+ --
+ -- Perfectly, PackageIndex should have sum type, so we don't need to
+ -- have dummy GPDs.
+ , genPackageFlags :: [PackageFlag]
+ , condLibrary :: Maybe (CondTree ConfVar [Dependency] Library)
+ , condSubLibraries
+ :: [ ( UnqualComponentName
+ , CondTree ConfVar [Dependency] Library
+ )
+ ]
+ , condForeignLibs
+ :: [ ( UnqualComponentName
+ , CondTree ConfVar [Dependency] ForeignLib
+ )
+ ]
+ , condExecutables
+ :: [ ( UnqualComponentName
+ , CondTree ConfVar [Dependency] Executable
+ )
+ ]
+ , condTestSuites
+ :: [ ( UnqualComponentName
+ , CondTree ConfVar [Dependency] TestSuite
+ )
+ ]
+ , condBenchmarks
+ :: [ ( UnqualComponentName
+ , CondTree ConfVar [Dependency] Benchmark
+ )
+ ]
}
- deriving (Show, Eq, Typeable, Data, Generic)
+ deriving (Show, Eq, Typeable, Data, Generic)
instance Package GenericPackageDescription where
packageId = packageId . packageDescription
@@ -74,30 +87,34 @@ emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescripti
-- Traversal Instances
instance L.HasBuildInfos GenericPackageDescription where
- traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
- GenericPackageDescription
- <$> L.traverseBuildInfos f p
- <*> pure v
- <*> pure a1
- <*> (traverse . traverseCondTreeBuildInfo) f x1
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5
- <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6
+ traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
+ GenericPackageDescription
+ <$> L.traverseBuildInfos f p
+ <*> pure v
+ <*> pure a1
+ <*> (traverse . traverseCondTreeBuildInfo) f x1
+ <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x2
+ <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x3
+ <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x4
+ <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x5
+ <*> (traverse . L._2 . traverseCondTreeBuildInfo) f x6
-- We use this traversal to keep [Dependency] field in CondTree up to date.
traverseCondTreeBuildInfo
- :: forall f comp v. (Applicative f, L.HasBuildInfo comp)
- => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo
-traverseCondTreeBuildInfo g = node where
+ :: forall f comp v
+ . (Applicative f, L.HasBuildInfo comp)
+ => LensLike' f (CondTree v [Dependency] comp) L.BuildInfo
+traverseCondTreeBuildInfo g = node
+ where
mkCondNode :: comp -> [CondBranch v [Dependency] comp] -> CondTree v [Dependency] comp
mkCondNode comp = CondNode comp (view L.targetBuildDepends comp)
- node (CondNode comp _ branches) = mkCondNode
+ node (CondNode comp _ branches) =
+ mkCondNode
<$> L.buildInfo g comp
<*> traverse branch branches
- branch (CondBranch v x y) = CondBranch v
+ branch (CondBranch v x y) =
+ CondBranch v
<$> node x
<*> traverse node y
diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs
index 012d7365e548109e0b5ff768a630713f5652022e..213c97128f9a3e4276dc88321f38eeb710ea9fcd 100644
--- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs
@@ -1,34 +1,36 @@
{-# LANGUAGE Rank2Types #-}
-module Distribution.Types.GenericPackageDescription.Lens (
- GenericPackageDescription,
- PackageFlag,
- FlagName,
- ConfVar (..),
- module Distribution.Types.GenericPackageDescription.Lens,
- ) where
-
-import Prelude()
-import Distribution.Compat.Prelude
+
+module Distribution.Types.GenericPackageDescription.Lens
+ ( GenericPackageDescription
+ , PackageFlag
+ , FlagName
+ , ConfVar (..)
+ , module Distribution.Types.GenericPackageDescription.Lens
+ ) where
+
import Distribution.Compat.Lens
+import Distribution.Compat.Prelude
+import Prelude ()
import qualified Distribution.Types.GenericPackageDescription as T
-- We import types from their packages, so we can remove unused imports
-- and have wider inter-module dependency graph
+
+import Distribution.Compiler (CompilerFlavor)
+import Distribution.System (Arch, OS)
+import Distribution.Types.Benchmark (Benchmark)
import Distribution.Types.CondTree (CondTree)
+import Distribution.Types.ConfVar (ConfVar (..))
import Distribution.Types.Dependency (Dependency)
import Distribution.Types.Executable (Executable)
-import Distribution.Types.PackageDescription (PackageDescription)
-import Distribution.Types.Benchmark (Benchmark)
+import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag))
import Distribution.Types.ForeignLib (ForeignLib)
-import Distribution.Types.GenericPackageDescription (GenericPackageDescription(GenericPackageDescription) )
-import Distribution.Types.Flag (PackageFlag(MkPackageFlag), FlagName)
-import Distribution.Types.ConfVar (ConfVar (..))
+import Distribution.Types.GenericPackageDescription (GenericPackageDescription (GenericPackageDescription))
import Distribution.Types.Library (Library)
+import Distribution.Types.PackageDescription (PackageDescription)
import Distribution.Types.TestSuite (TestSuite)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
-import Distribution.System (Arch, OS)
-import Distribution.Compiler (CompilerFlavor)
import Distribution.Version (Version, VersionRange)
-------------------------------------------------------------------------------
@@ -36,59 +38,60 @@ import Distribution.Version (Version, VersionRange)
-------------------------------------------------------------------------------
packageDescription :: Lens' GenericPackageDescription PackageDescription
-packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s))
+packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s))
{-# INLINE packageDescription #-}
gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version)
-gpdScannedVersion f s = fmap (\x -> s { T.gpdScannedVersion = x }) (f (T.gpdScannedVersion s))
+gpdScannedVersion f s = fmap (\x -> s{T.gpdScannedVersion = x}) (f (T.gpdScannedVersion s))
{-# INLINE gpdScannedVersion #-}
genPackageFlags :: Lens' GenericPackageDescription [PackageFlag]
-genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s))
+genPackageFlags f s = fmap (\x -> s{T.genPackageFlags = x}) (f (T.genPackageFlags s))
{-# INLINE genPackageFlags #-}
condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar [Dependency] Library))
-condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s))
+condLibrary f s = fmap (\x -> s{T.condLibrary = x}) (f (T.condLibrary s))
{-# INLINE condLibrary #-}
-condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))]
-condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s))
+condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Library))]
+condSubLibraries f s = fmap (\x -> s{T.condSubLibraries = x}) (f (T.condSubLibraries s))
{-# INLINE condSubLibraries #-}
-condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))]
-condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s))
+condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] ForeignLib))]
+condForeignLibs f s = fmap (\x -> s{T.condForeignLibs = x}) (f (T.condForeignLibs s))
{-# INLINE condForeignLibs #-}
-condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))]
-condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s))
+condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Executable))]
+condExecutables f s = fmap (\x -> s{T.condExecutables = x}) (f (T.condExecutables s))
{-# INLINE condExecutables #-}
-condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))]
-condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s))
+condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] TestSuite))]
+condTestSuites f s = fmap (\x -> s{T.condTestSuites = x}) (f (T.condTestSuites s))
{-# INLINE condTestSuites #-}
-condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Benchmark))]
-condBenchmarks f s = fmap (\x -> s { T.condBenchmarks = x }) (f (T.condBenchmarks s))
+condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar [Dependency] Benchmark))]
+condBenchmarks f s = fmap (\x -> s{T.condBenchmarks = x}) (f (T.condBenchmarks s))
{-# INLINE condBenchmarks #-}
allCondTrees
:: Applicative f
- => (forall a. CondTree ConfVar [Dependency] a
- -> f (CondTree ConfVar [Dependency] a))
+ => ( forall a
+ . CondTree ConfVar [Dependency] a
+ -> f (CondTree ConfVar [Dependency] a)
+ )
-> GenericPackageDescription
-> f GenericPackageDescription
allCondTrees f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) =
- GenericPackageDescription
- <$> pure p
- <*> pure v
- <*> pure a1
- <*> traverse f x1
- <*> (traverse . _2) f x2
- <*> (traverse . _2) f x3
- <*> (traverse . _2) f x4
- <*> (traverse . _2) f x5
- <*> (traverse . _2) f x6
-
+ GenericPackageDescription
+ <$> pure p
+ <*> pure v
+ <*> pure a1
+ <*> traverse f x1
+ <*> (traverse . _2) f x2
+ <*> (traverse . _2) f x3
+ <*> (traverse . _2) f x4
+ <*> (traverse . _2) f x5
+ <*> (traverse . _2) f x6
-------------------------------------------------------------------------------
-- Flag
@@ -116,16 +119,16 @@ flagManual f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 x2 x3 y
_OS :: Traversal' ConfVar OS
_OS f (OS os) = OS <$> f os
-_OS _ x = pure x
+_OS _ x = pure x
_Arch :: Traversal' ConfVar Arch
_Arch f (Arch arch) = Arch <$> f arch
-_Arch _ x = pure x
+_Arch _ x = pure x
_PackageFlag :: Traversal' ConfVar FlagName
_PackageFlag f (PackageFlag flag) = PackageFlag <$> f flag
-_PackageFlag _ x = pure x
+_PackageFlag _ x = pure x
_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange)
_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr)
-_Impl _ x = pure x
+_Impl _ x = pure x
diff --git a/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs b/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs
index 62f3551f131ce4b50ee8f71f42331881ef3a4884..a57d9f8c852ce6517ae7c55360634583442e5b7d 100644
--- a/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs
+++ b/Cabal-syntax/src/Distribution/Types/HookedBuildInfo.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.HookedBuildInfo (
- HookedBuildInfo,
- emptyHookedBuildInfo,
+module Distribution.Types.HookedBuildInfo
+ ( HookedBuildInfo
+ , emptyHookedBuildInfo
) where
-- import Distribution.Compat.Prelude
diff --git a/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs b/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs
index 0b313912a8d9cb9ef6bbf327e57c88b124efb189..c8cb70d91f16d6d7a8e12832007ddddc982df716 100644
--- a/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs
+++ b/Cabal-syntax/src/Distribution/Types/IncludeRenaming.hs
@@ -1,11 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.IncludeRenaming (
- IncludeRenaming(..),
- defaultIncludeRenaming,
- isDefaultIncludeRenaming,
-) where
+module Distribution.Types.IncludeRenaming
+ ( IncludeRenaming (..)
+ , defaultIncludeRenaming
+ , isDefaultIncludeRenaming
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -13,21 +13,20 @@ import Prelude ()
import Distribution.Types.ModuleRenaming
import qualified Distribution.Compat.CharParsing as P
-import Distribution.Parsec
-import Distribution.Pretty
-import Text.PrettyPrint (text)
-import qualified Text.PrettyPrint as Disp
+import Distribution.Parsec
+import Distribution.Pretty
+import Text.PrettyPrint (text)
+import qualified Text.PrettyPrint as Disp
-- ---------------------------------------------------------------------------
-- Module renaming
-- | A renaming on an include: (provides renaming, requires renaming)
-data IncludeRenaming
- = IncludeRenaming {
- includeProvidesRn :: ModuleRenaming,
- includeRequiresRn :: ModuleRenaming
- }
- deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
+data IncludeRenaming = IncludeRenaming
+ { includeProvidesRn :: ModuleRenaming
+ , includeRequiresRn :: ModuleRenaming
+ }
+ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
instance Binary IncludeRenaming
instance Structured IncludeRenaming
@@ -44,25 +43,26 @@ isDefaultIncludeRenaming :: IncludeRenaming -> Bool
isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r
instance Pretty IncludeRenaming where
- pretty (IncludeRenaming prov_rn req_rn) =
- pretty prov_rn
- <+> (if isDefaultRenaming req_rn
- then Disp.empty
- else text "requires" <+> pretty req_rn)
+ pretty (IncludeRenaming prov_rn req_rn) =
+ pretty prov_rn
+ <+> ( if isDefaultRenaming req_rn
+ then Disp.empty
+ else text "requires" <+> pretty req_rn
+ )
instance Parsec IncludeRenaming where
- parsec = do
- prov_rn <- parsec
- req_rn <- P.option defaultRenaming $ P.try $ do
- P.spaces -- no need to be space
- _ <- P.string "requires"
- P.spaces
- parsec
- -- Requirements don't really care if they're mentioned
- -- or not (since you can't thin a requirement.) But
- -- we have a little hack in Configure to combine
- -- the provisions and requirements together before passing
- -- them to GHC, and so the most neutral choice for a requirement
- -- is for the "with" field to be False, so we correctly
- -- thin provisions.
- return (IncludeRenaming prov_rn req_rn)
+ parsec = do
+ prov_rn <- parsec
+ req_rn <- P.option defaultRenaming $ P.try $ do
+ P.spaces -- no need to be space
+ _ <- P.string "requires"
+ P.spaces
+ parsec
+ -- Requirements don't really care if they're mentioned
+ -- or not (since you can't thin a requirement.) But
+ -- we have a little hack in Configure to combine
+ -- the provisions and requirements together before passing
+ -- them to GHC, and so the most neutral choice for a requirement
+ -- is for the "with" field to be False, so we correctly
+ -- thin provisions.
+ return (IncludeRenaming prov_rn req_rn)
diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs
index 0d047db5590655e569b70981558fa79f78f8076a..b3e353876ebe6d20e651fcd3a1ebc6b1c3192654 100644
--- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs
+++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo.hs
@@ -1,100 +1,101 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.InstalledPackageInfo (
- InstalledPackageInfo (..),
- emptyInstalledPackageInfo,
- mungedPackageId,
- mungedPackageName,
- AbiDependency (..),
- ExposedModule (..),
- ) where
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Types.InstalledPackageInfo
+ ( InstalledPackageInfo (..)
+ , emptyInstalledPackageInfo
+ , mungedPackageId
+ , mungedPackageName
+ , AbiDependency (..)
+ , ExposedModule (..)
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Backpack
-import Distribution.Compat.Graph (IsNode (..))
+import Distribution.Compat.Graph (IsNode (..))
import Distribution.License
import Distribution.ModuleName
-import Distribution.Package hiding (installedUnitId)
+import Distribution.Package hiding (installedUnitId)
import Distribution.Types.AbiDependency
import Distribution.Types.ExposedModule
import Distribution.Types.LibraryName
import Distribution.Types.LibraryVisibility
import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
-import Distribution.Version (nullVersion)
-import Distribution.Utils.ShortText (ShortText)
+import Distribution.Utils.ShortText (ShortText)
+import Distribution.Version (nullVersion)
import qualified Distribution.Package as Package
-import qualified Distribution.SPDX as SPDX
+import qualified Distribution.SPDX as SPDX
-- -----------------------------------------------------------------------------
-- The InstalledPackageInfo type
-- For BC reasons, we continue to name this record an InstalledPackageInfo;
-- but it would more accurately be called an InstalledUnitInfo with Backpack
-data InstalledPackageInfo
- = InstalledPackageInfo {
- -- these parts (sourcePackageId, installedUnitId) are
- -- exactly the same as PackageDescription
- sourcePackageId :: PackageId,
- sourceLibName :: LibraryName,
- installedComponentId_ :: ComponentId,
- libVisibility :: LibraryVisibility,
- installedUnitId :: UnitId,
- -- INVARIANT: if this package is definite, OpenModule's
- -- OpenUnitId directly records UnitId. If it is
- -- indefinite, OpenModule is always an OpenModuleVar
- -- with the same ModuleName as the key.
- instantiatedWith :: [(ModuleName, OpenModule)],
- compatPackageKey :: String,
- license :: Either SPDX.License License,
- copyright :: !ShortText,
- maintainer :: !ShortText,
- author :: !ShortText,
- stability :: !ShortText,
- homepage :: !ShortText,
- pkgUrl :: !ShortText,
- synopsis :: !ShortText,
- description :: !ShortText,
- category :: !ShortText,
- -- these parts are required by an installed package only:
- abiHash :: AbiHash,
- indefinite :: Bool,
- exposed :: Bool,
- -- INVARIANT: if the package is definite, OpenModule's
- -- OpenUnitId directly records UnitId.
- exposedModules :: [ExposedModule],
- hiddenModules :: [ModuleName],
- trusted :: Bool,
- importDirs :: [FilePath],
- libraryDirs :: [FilePath],
- libraryDirsStatic :: [FilePath],
- libraryDynDirs :: [FilePath], -- ^ overrides 'libraryDirs'
- dataDir :: FilePath,
- hsLibraries :: [String],
- extraLibraries :: [String],
- extraLibrariesStatic :: [String],
- extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi
- includeDirs :: [FilePath],
- includes :: [String],
- -- INVARIANT: if the package is definite, UnitId is NOT
- -- a ComponentId of an indefinite package
- depends :: [UnitId],
- abiDepends :: [AbiDependency],
- ccOptions :: [String],
- cxxOptions :: [String],
- ldOptions :: [String],
- frameworkDirs :: [FilePath],
- frameworks :: [String],
- haddockInterfaces :: [FilePath],
- haddockHTMLs :: [FilePath],
- pkgRoot :: Maybe FilePath
- }
- deriving (Eq, Generic, Typeable, Read, Show)
+data InstalledPackageInfo = InstalledPackageInfo
+ { -- these parts (sourcePackageId, installedUnitId) are
+ -- exactly the same as PackageDescription
+ sourcePackageId :: PackageId
+ , sourceLibName :: LibraryName
+ , installedComponentId_ :: ComponentId
+ , libVisibility :: LibraryVisibility
+ , installedUnitId :: UnitId
+ , -- INVARIANT: if this package is definite, OpenModule's
+ -- OpenUnitId directly records UnitId. If it is
+ -- indefinite, OpenModule is always an OpenModuleVar
+ -- with the same ModuleName as the key.
+ instantiatedWith :: [(ModuleName, OpenModule)]
+ , compatPackageKey :: String
+ , license :: Either SPDX.License License
+ , copyright :: !ShortText
+ , maintainer :: !ShortText
+ , author :: !ShortText
+ , stability :: !ShortText
+ , homepage :: !ShortText
+ , pkgUrl :: !ShortText
+ , synopsis :: !ShortText
+ , description :: !ShortText
+ , category :: !ShortText
+ , -- these parts are required by an installed package only:
+ abiHash :: AbiHash
+ , indefinite :: Bool
+ , exposed :: Bool
+ , -- INVARIANT: if the package is definite, OpenModule's
+ -- OpenUnitId directly records UnitId.
+ exposedModules :: [ExposedModule]
+ , hiddenModules :: [ModuleName]
+ , trusted :: Bool
+ , importDirs :: [FilePath]
+ , libraryDirs :: [FilePath]
+ , libraryDirsStatic :: [FilePath]
+ , libraryDynDirs :: [FilePath]
+ -- ^ overrides 'libraryDirs'
+ , dataDir :: FilePath
+ , hsLibraries :: [String]
+ , extraLibraries :: [String]
+ , extraLibrariesStatic :: [String]
+ , extraGHCiLibraries :: [String] -- overrides extraLibraries for GHCi
+ , includeDirs :: [FilePath]
+ , includes :: [String]
+ , -- INVARIANT: if the package is definite, UnitId is NOT
+ -- a ComponentId of an indefinite package
+ depends :: [UnitId]
+ , abiDepends :: [AbiDependency]
+ , ccOptions :: [String]
+ , cxxOptions :: [String]
+ , ldOptions :: [String]
+ , frameworkDirs :: [FilePath]
+ , frameworks :: [String]
+ , haddockInterfaces :: [FilePath]
+ , haddockHTMLs :: [FilePath]
+ , pkgRoot :: Maybe FilePath
+ }
+ deriving (Eq, Generic, Typeable, Read, Show)
instance Binary InstalledPackageInfo
instance Structured InstalledPackageInfo
@@ -102,25 +103,25 @@ instance Structured InstalledPackageInfo
instance NFData InstalledPackageInfo where rnf = genericRnf
instance Package.HasMungedPackageId InstalledPackageInfo where
- mungedId = mungedPackageId
+ mungedId = mungedPackageId
instance Package.Package InstalledPackageInfo where
- packageId = sourcePackageId
+ packageId = sourcePackageId
instance Package.HasUnitId InstalledPackageInfo where
- installedUnitId = installedUnitId
+ installedUnitId = installedUnitId
instance Package.PackageInstalled InstalledPackageInfo where
- installedDepends = depends
+ installedDepends = depends
instance IsNode InstalledPackageInfo where
- type Key InstalledPackageInfo = UnitId
- nodeKey = installedUnitId
- nodeNeighbors = depends
+ type Key InstalledPackageInfo = UnitId
+ nodeKey = installedUnitId
+ nodeNeighbors = depends
mungedPackageId :: InstalledPackageInfo -> MungedPackageId
mungedPackageId ipi =
- MungedPackageId (mungedPackageName ipi) (packageVersion ipi)
+ MungedPackageId (mungedPackageName ipi) (packageVersion ipi)
-- | Returns the munged package name, which we write into @name@ for
-- compatibility with old versions of GHC.
@@ -128,50 +129,50 @@ mungedPackageName :: InstalledPackageInfo -> MungedPackageName
mungedPackageName ipi = MungedPackageName (packageName ipi) (sourceLibName ipi)
emptyInstalledPackageInfo :: InstalledPackageInfo
-emptyInstalledPackageInfo
- = InstalledPackageInfo {
- sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion,
- sourceLibName = LMainLibName,
- installedComponentId_ = mkComponentId "",
- installedUnitId = mkUnitId "",
- instantiatedWith = [],
- compatPackageKey = "",
- license = Left SPDX.NONE,
- copyright = "",
- maintainer = "",
- author = "",
- stability = "",
- homepage = "",
- pkgUrl = "",
- synopsis = "",
- description = "",
- category = "",
- abiHash = mkAbiHash "",
- indefinite = False,
- exposed = False,
- exposedModules = [],
- hiddenModules = [],
- trusted = False,
- importDirs = [],
- libraryDirs = [],
- libraryDirsStatic = [],
- libraryDynDirs = [],
- dataDir = "",
- hsLibraries = [],
- extraLibraries = [],
- extraLibrariesStatic = [],
- extraGHCiLibraries= [],
- includeDirs = [],
- includes = [],
- depends = [],
- abiDepends = [],
- ccOptions = [],
- cxxOptions = [],
- ldOptions = [],
- frameworkDirs = [],
- frameworks = [],
- haddockInterfaces = [],
- haddockHTMLs = [],
- pkgRoot = Nothing,
- libVisibility = LibraryVisibilityPrivate
+emptyInstalledPackageInfo =
+ InstalledPackageInfo
+ { sourcePackageId = PackageIdentifier (mkPackageName "") nullVersion
+ , sourceLibName = LMainLibName
+ , installedComponentId_ = mkComponentId ""
+ , installedUnitId = mkUnitId ""
+ , instantiatedWith = []
+ , compatPackageKey = ""
+ , license = Left SPDX.NONE
+ , copyright = ""
+ , maintainer = ""
+ , author = ""
+ , stability = ""
+ , homepage = ""
+ , pkgUrl = ""
+ , synopsis = ""
+ , description = ""
+ , category = ""
+ , abiHash = mkAbiHash ""
+ , indefinite = False
+ , exposed = False
+ , exposedModules = []
+ , hiddenModules = []
+ , trusted = False
+ , importDirs = []
+ , libraryDirs = []
+ , libraryDirsStatic = []
+ , libraryDynDirs = []
+ , dataDir = ""
+ , hsLibraries = []
+ , extraLibraries = []
+ , extraLibrariesStatic = []
+ , extraGHCiLibraries = []
+ , includeDirs = []
+ , includes = []
+ , depends = []
+ , abiDepends = []
+ , ccOptions = []
+ , cxxOptions = []
+ , ldOptions = []
+ , frameworkDirs = []
+ , frameworks = []
+ , haddockInterfaces = []
+ , haddockHTMLs = []
+ , pkgRoot = Nothing
+ , libVisibility = LibraryVisibilityPrivate
}
diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs
index f176ea0118705d08cd40b7c54187336147c62e10..d75466355453804204726e99a8866d7bf95572a3 100644
--- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs
+++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs
@@ -1,18 +1,19 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-module Distribution.Types.InstalledPackageInfo.FieldGrammar (
- ipiFieldGrammar,
- ) where
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Distribution.Types.InstalledPackageInfo.FieldGrammar
+ ( ipiFieldGrammar
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Backpack
import Distribution.CabalSpecVersion
-import Distribution.Compat.Lens (Lens', (&), (.~))
+import Distribution.Compat.Lens (Lens', (&), (.~))
import Distribution.Compat.Newtype
import Distribution.FieldGrammar
import Distribution.FieldGrammar.FieldDescrs
@@ -27,16 +28,16 @@ import Distribution.Types.MungedPackageName
import Distribution.Types.UnqualComponentName
import Distribution.Version
-import qualified Data.Char as Char
-import qualified Data.Map as Map
+import qualified Data.Char as Char
+import qualified Data.Map as Map
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.SPDX as SPDX
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.SPDX as SPDX
+import qualified Text.PrettyPrint as Disp
import Distribution.Types.InstalledPackageInfo
import qualified Distribution.Types.InstalledPackageInfo.Lens as L
-import qualified Distribution.Types.PackageId.Lens as L
+import qualified Distribution.Types.PackageId.Lens as L
-- Note: GHC goes nuts and inlines everything,
-- One can see e.g. in -ddump-simpl-stats:
@@ -53,76 +54,80 @@ f <@> x = f <*> x
{-# NOINLINE (<@>) #-}
ipiFieldGrammar
- :: ( FieldGrammar c g, Applicative (g InstalledPackageInfo), Applicative (g Basic)
- , c (Identity AbiHash)
- , c (Identity LibraryVisibility)
- , c (Identity PackageName)
- , c (Identity UnitId)
- , c (Identity UnqualComponentName)
- , c (List FSep (Identity AbiDependency) AbiDependency)
- , c (List FSep (Identity UnitId) UnitId)
- , c (List FSep (MQuoted ModuleName) ModuleName)
- , c (List FSep FilePathNT String)
- , c (List FSep Token String)
- , c (MQuoted MungedPackageName)
- , c (MQuoted Version)
- , c CompatPackageKey
- , c ExposedModules
- , c InstWith
- , c SpecLicenseLenient
- )
- => g InstalledPackageInfo InstalledPackageInfo
-ipiFieldGrammar = mkInstalledPackageInfo
+ :: ( FieldGrammar c g
+ , Applicative (g InstalledPackageInfo)
+ , Applicative (g Basic)
+ , c (Identity AbiHash)
+ , c (Identity LibraryVisibility)
+ , c (Identity PackageName)
+ , c (Identity UnitId)
+ , c (Identity UnqualComponentName)
+ , c (List FSep (Identity AbiDependency) AbiDependency)
+ , c (List FSep (Identity UnitId) UnitId)
+ , c (List FSep (MQuoted ModuleName) ModuleName)
+ , c (List FSep FilePathNT String)
+ , c (List FSep Token String)
+ , c (MQuoted MungedPackageName)
+ , c (MQuoted Version)
+ , c CompatPackageKey
+ , c ExposedModules
+ , c InstWith
+ , c SpecLicenseLenient
+ )
+ => g InstalledPackageInfo InstalledPackageInfo
+ipiFieldGrammar =
+ mkInstalledPackageInfo
-- Deprecated fields
- <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList
- --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b
- ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore"
+ <$> monoidalFieldAla "hugs-options" (alaList' FSep Token) unitedList
+ --- https://github.com/haskell/cabal/commit/40f3601e17024f07e0da8e64d3dd390177ce908b
+ ^^^ deprecatedSince CabalSpecV1_22 "hugs isn't supported anymore"
-- Very basic fields: name, version, package-name, lib-name and visibility
<@> blurFieldGrammar basic basicFieldGrammar
-- Basic fields
- <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "")
- <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith []
- <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey ""
- <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE)
- <@> freeTextFieldDefST "copyright" L.copyright
- <@> freeTextFieldDefST "maintainer" L.maintainer
- <@> freeTextFieldDefST "author" L.author
- <@> freeTextFieldDefST "stability" L.stability
- <@> freeTextFieldDefST "homepage" L.homepage
- <@> freeTextFieldDefST "package-url" L.pkgUrl
- <@> freeTextFieldDefST "synopsis" L.synopsis
- <@> freeTextFieldDefST "description" L.description
- <@> freeTextFieldDefST "category" L.category
+ <@> optionalFieldDef "id" L.installedUnitId (mkUnitId "")
+ <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith []
+ <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey ""
+ <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE)
+ <@> freeTextFieldDefST "copyright" L.copyright
+ <@> freeTextFieldDefST "maintainer" L.maintainer
+ <@> freeTextFieldDefST "author" L.author
+ <@> freeTextFieldDefST "stability" L.stability
+ <@> freeTextFieldDefST "homepage" L.homepage
+ <@> freeTextFieldDefST "package-url" L.pkgUrl
+ <@> freeTextFieldDefST "synopsis" L.synopsis
+ <@> freeTextFieldDefST "description" L.description
+ <@> freeTextFieldDefST "category" L.category
-- Installed fields
- <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "")
- <@> booleanFieldDef "indefinite" L.indefinite False
- <@> booleanFieldDef "exposed" L.exposed False
- <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules
- <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules
- <@> booleanFieldDef "trusted" L.trusted False
- <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs
- <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs
- <@> monoidalFieldAla "library-dirs-static" (alaList' FSep FilePathNT) L.libraryDirsStatic
- <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs
- <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir ""
- <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries
- <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries
- <@> monoidalFieldAla "extra-libraries-static" (alaList' FSep Token) L.extraLibrariesStatic
- <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries
- <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs
- <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes
- <@> monoidalFieldAla "depends" (alaList FSep) L.depends
- <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends
- <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions
- <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions
- <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions
- <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs
- <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks
- <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces
- <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs
- <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot
+ <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "")
+ <@> booleanFieldDef "indefinite" L.indefinite False
+ <@> booleanFieldDef "exposed" L.exposed False
+ <@> monoidalFieldAla "exposed-modules" ExposedModules L.exposedModules
+ <@> monoidalFieldAla "hidden-modules" (alaList' FSep MQuoted) L.hiddenModules
+ <@> booleanFieldDef "trusted" L.trusted False
+ <@> monoidalFieldAla "import-dirs" (alaList' FSep FilePathNT) L.importDirs
+ <@> monoidalFieldAla "library-dirs" (alaList' FSep FilePathNT) L.libraryDirs
+ <@> monoidalFieldAla "library-dirs-static" (alaList' FSep FilePathNT) L.libraryDirsStatic
+ <@> monoidalFieldAla "dynamic-library-dirs" (alaList' FSep FilePathNT) L.libraryDynDirs
+ <@> optionalFieldDefAla "data-dir" FilePathNT L.dataDir ""
+ <@> monoidalFieldAla "hs-libraries" (alaList' FSep Token) L.hsLibraries
+ <@> monoidalFieldAla "extra-libraries" (alaList' FSep Token) L.extraLibraries
+ <@> monoidalFieldAla "extra-libraries-static" (alaList' FSep Token) L.extraLibrariesStatic
+ <@> monoidalFieldAla "extra-ghci-libraries" (alaList' FSep Token) L.extraGHCiLibraries
+ <@> monoidalFieldAla "include-dirs" (alaList' FSep FilePathNT) L.includeDirs
+ <@> monoidalFieldAla "includes" (alaList' FSep FilePathNT) L.includes
+ <@> monoidalFieldAla "depends" (alaList FSep) L.depends
+ <@> monoidalFieldAla "abi-depends" (alaList FSep) L.abiDepends
+ <@> monoidalFieldAla "cc-options" (alaList' FSep Token) L.ccOptions
+ <@> monoidalFieldAla "cxx-options" (alaList' FSep Token) L.cxxOptions
+ <@> monoidalFieldAla "ld-options" (alaList' FSep Token) L.ldOptions
+ <@> monoidalFieldAla "framework-dirs" (alaList' FSep FilePathNT) L.frameworkDirs
+ <@> monoidalFieldAla "frameworks" (alaList' FSep Token) L.frameworks
+ <@> monoidalFieldAla "haddock-interfaces" (alaList' FSep FilePathNT) L.haddockInterfaces
+ <@> monoidalFieldAla "haddock-html" (alaList' FSep FilePathNT) L.haddockHTMLs
+ <@> optionalFieldAla "pkgroot" FilePathNT L.pkgRoot
where
- mkInstalledPackageInfo _ Basic {..} = InstalledPackageInfo
+ mkInstalledPackageInfo _ Basic{..} =
+ InstalledPackageInfo
-- _basicPkgName is not used
-- setMaybePackageId says it can be no-op.
(PackageIdentifier pn _basicVersion)
@@ -149,7 +154,7 @@ unitedList f s = s <$ f []
-- /Should/ be irrelevant.
combineLibraryName :: LibraryName -> LibraryName -> LibraryName
combineLibraryName l@(LSubLibName _) _ = l
-combineLibraryName _ l = l
+combineLibraryName _ l = l
-- To maintain backwards-compatibility, we accept both comma/non-comma
-- separated variants of this field. You SHOULD use the comma syntax if you
@@ -158,23 +163,26 @@ combineLibraryName _ l = l
showExposedModules :: [ExposedModule] -> Disp.Doc
showExposedModules xs
- | all isExposedModule xs = Disp.fsep (map pretty xs)
- | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs))
- where isExposedModule (ExposedModule _ Nothing) = True
- isExposedModule _ = False
+ | all isExposedModule xs = Disp.fsep (map pretty xs)
+ | otherwise = Disp.fsep (Disp.punctuate Disp.comma (map pretty xs))
+ where
+ isExposedModule (ExposedModule _ Nothing) = True
+ isExposedModule _ = False
-- | Setter for the @package-name@ field. It should be acceptable for this
-- to be a no-op.
setMaybePackageName :: Maybe PackageName -> InstalledPackageInfo -> InstalledPackageInfo
-setMaybePackageName Nothing ipi = ipi
-setMaybePackageName (Just pn) ipi = ipi
- { sourcePackageId = (sourcePackageId ipi) {pkgName=pn}
+setMaybePackageName Nothing ipi = ipi
+setMaybePackageName (Just pn) ipi =
+ ipi
+ { sourcePackageId = (sourcePackageId ipi){pkgName = pn}
}
setMungedPackageName :: MungedPackageName -> InstalledPackageInfo -> InstalledPackageInfo
-setMungedPackageName (MungedPackageName pn ln) ipi = ipi
- { sourcePackageId = (sourcePackageId ipi) {pkgName=pn}
- , sourceLibName = ln
+setMungedPackageName (MungedPackageName pn ln) ipi =
+ ipi
+ { sourcePackageId = (sourcePackageId ipi){pkgName = pn}
+ , sourceLibName = ln
}
--- | Returns @Just@ if the @name@ field of the IPI record would not contain
@@ -182,54 +190,55 @@ setMungedPackageName (MungedPackageName pn ln) ipi = ipi
--- when it's redundant.
maybePackageName :: InstalledPackageInfo -> Maybe PackageName
maybePackageName ipi = case sourceLibName ipi of
- LMainLibName -> Nothing
- LSubLibName _ -> Just (packageName ipi)
+ LMainLibName -> Nothing
+ LSubLibName _ -> Just (packageName ipi)
-------------------------------------------------------------------------------
-- Auxiliary types
-------------------------------------------------------------------------------
-newtype ExposedModules = ExposedModules { getExposedModules :: [ExposedModule] }
+newtype ExposedModules = ExposedModules {getExposedModules :: [ExposedModule]}
instance Newtype [ExposedModule] ExposedModules
instance Parsec ExposedModules where
- parsec = ExposedModules <$> parsecOptCommaList parsec
+ parsec = ExposedModules <$> parsecOptCommaList parsec
instance Pretty ExposedModules where
- pretty = showExposedModules . getExposedModules
+ pretty = showExposedModules . getExposedModules
-newtype CompatPackageKey = CompatPackageKey { getCompatPackageKey :: String }
+newtype CompatPackageKey = CompatPackageKey {getCompatPackageKey :: String}
instance Newtype String CompatPackageKey
instance Pretty CompatPackageKey where
- pretty = Disp.text . getCompatPackageKey
+ pretty = Disp.text . getCompatPackageKey
instance Parsec CompatPackageKey where
- parsec = CompatPackageKey <$> P.munch1 uid_char where
- uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String)
+ parsec = CompatPackageKey <$> P.munch1 uid_char
+ where
+ uid_char c = Char.isAlphaNum c || c `elem` ("-_.=[],:<>+" :: String)
-newtype InstWith = InstWith { getInstWith :: [(ModuleName,OpenModule)] }
+newtype InstWith = InstWith {getInstWith :: [(ModuleName, OpenModule)]}
-instance Newtype [(ModuleName, OpenModule)] InstWith
+instance Newtype [(ModuleName, OpenModule)] InstWith
instance Pretty InstWith where
- pretty = dispOpenModuleSubst . Map.fromList . getInstWith
+ pretty = dispOpenModuleSubst . Map.fromList . getInstWith
instance Parsec InstWith where
- parsec = InstWith . Map.toList <$> parsecOpenModuleSubst
+ parsec = InstWith . Map.toList <$> parsecOpenModuleSubst
-- | SPDX License expression or legacy license. Lenient parser, accepts either.
-newtype SpecLicenseLenient = SpecLicenseLenient { getSpecLicenseLenient :: Either SPDX.License License }
+newtype SpecLicenseLenient = SpecLicenseLenient {getSpecLicenseLenient :: Either SPDX.License License}
instance Newtype (Either SPDX.License License) SpecLicenseLenient
instance Parsec SpecLicenseLenient where
- parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec
+ parsec = fmap SpecLicenseLenient $ Left <$> P.try parsec <|> Right <$> parsec
instance Pretty SpecLicenseLenient where
- pretty = either pretty pretty . getSpecLicenseLenient
+ pretty = either pretty pretty . getSpecLicenseLenient
-------------------------------------------------------------------------------
-- Basic fields
@@ -239,24 +248,26 @@ instance Pretty SpecLicenseLenient where
-- in serialised textual representation
-- to the actual 'InstalledPackageInfo' fields.
data Basic = Basic
- { _basicName :: MungedPackageName
- , _basicVersion :: Version
- , _basicPkgName :: Maybe PackageName
- , _basicLibName :: LibraryName
- , _basicLibVisibility :: LibraryVisibility
- }
+ { _basicName :: MungedPackageName
+ , _basicVersion :: Version
+ , _basicPkgName :: Maybe PackageName
+ , _basicLibName :: LibraryName
+ , _basicLibVisibility :: LibraryVisibility
+ }
basic :: Lens' InstalledPackageInfo Basic
basic f ipi = g <$> f b
where
- b = Basic
+ b =
+ Basic
(mungedPackageName ipi)
(packageVersion ipi)
(maybePackageName ipi)
(sourceLibName ipi)
(libVisibility ipi)
- g (Basic n v pn ln lv) = ipi
+ g (Basic n v pn ln lv) =
+ ipi
& setMungedPackageName n
& L.sourcePackageId . L.pkgVersion .~ v
& setMaybePackageName pn
@@ -264,42 +275,46 @@ basic f ipi = g <$> f b
& L.libVisibility .~ lv
basicName :: Lens' Basic MungedPackageName
-basicName f b = (\x -> b { _basicName = x }) <$> f (_basicName b)
+basicName f b = (\x -> b{_basicName = x}) <$> f (_basicName b)
{-# INLINE basicName #-}
basicVersion :: Lens' Basic Version
-basicVersion f b = (\x -> b { _basicVersion = x }) <$> f (_basicVersion b)
+basicVersion f b = (\x -> b{_basicVersion = x}) <$> f (_basicVersion b)
{-# INLINE basicVersion #-}
basicPkgName :: Lens' Basic (Maybe PackageName)
-basicPkgName f b = (\x -> b { _basicPkgName = x }) <$> f (_basicPkgName b)
+basicPkgName f b = (\x -> b{_basicPkgName = x}) <$> f (_basicPkgName b)
{-# INLINE basicPkgName #-}
basicLibName :: Lens' Basic (Maybe UnqualComponentName)
-basicLibName f b = (\x -> b { _basicLibName = maybeToLibraryName x }) <$>
- f (libraryNameString (_basicLibName b))
+basicLibName f b =
+ (\x -> b{_basicLibName = maybeToLibraryName x})
+ <$> f (libraryNameString (_basicLibName b))
{-# INLINE basicLibName #-}
basicLibVisibility :: Lens' Basic LibraryVisibility
-basicLibVisibility f b = (\x -> b { _basicLibVisibility = x }) <$>
- f (_basicLibVisibility b)
+basicLibVisibility f b =
+ (\x -> b{_basicLibVisibility = x})
+ <$> f (_basicLibVisibility b)
{-# INLINE basicLibVisibility #-}
basicFieldGrammar
- :: ( FieldGrammar c g, Applicative (g Basic)
- , c (Identity LibraryVisibility)
- , c (Identity PackageName)
- , c (Identity UnqualComponentName)
- , c (MQuoted MungedPackageName)
- , c (MQuoted Version)
- )
- => g Basic Basic
-basicFieldGrammar = mkBasic
- <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
- <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion
- <*> optionalField "package-name" basicPkgName
- <*> optionalField "lib-name" basicLibName
- <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
+ :: ( FieldGrammar c g
+ , Applicative (g Basic)
+ , c (Identity LibraryVisibility)
+ , c (Identity PackageName)
+ , c (Identity UnqualComponentName)
+ , c (MQuoted MungedPackageName)
+ , c (MQuoted Version)
+ )
+ => g Basic Basic
+basicFieldGrammar =
+ mkBasic
+ <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo)
+ <*> optionalFieldDefAla "version" MQuoted basicVersion nullVersion
+ <*> optionalField "package-name" basicPkgName
+ <*> optionalField "lib-name" basicLibName
+ <*> optionalFieldDef "visibility" basicLibVisibility LibraryVisibilityPrivate
where
mkBasic n v pn ln lv = Basic n v pn ln' lv'
where
@@ -310,10 +325,10 @@ basicFieldGrammar = mkBasic
-- This can be removed once we stop supporting GHC<8.8, at the
-- condition that we keep marking main libraries as public when
-- registering them.
- lv' = if
- let MungedPackageName _ mln = n in
- -- We need to check both because on ghc<8.2 ln' will always
- -- be LMainLibName
- ln' == LMainLibName && mln == LMainLibName
- then LibraryVisibilityPublic
- else lv
+ lv' =
+ if let MungedPackageName _ mln = n
+ in -- We need to check both because on ghc<8.2 ln' will always
+ -- be LMainLibName
+ ln' == LMainLibName && mln == LMainLibName
+ then LibraryVisibilityPublic
+ else lv
diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs
index 9d1df886370a3364490d51a71d529895b583a882..47fa1c96f4000bf17973298c1a3816601ee1896e 100644
--- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/Lens.hs
@@ -1,198 +1,196 @@
-module Distribution.Types.InstalledPackageInfo.Lens (
- InstalledPackageInfo,
- module Distribution.Types.InstalledPackageInfo.Lens
- ) where
+module Distribution.Types.InstalledPackageInfo.Lens
+ ( InstalledPackageInfo
+ , module Distribution.Types.InstalledPackageInfo.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Backpack (OpenModule)
-import Distribution.License (License)
-import Distribution.ModuleName (ModuleName)
-import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId)
+import Distribution.Backpack (OpenModule)
+import Distribution.License (License)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Package (AbiHash, ComponentId, PackageIdentifier, UnitId)
import Distribution.Types.InstalledPackageInfo (AbiDependency, ExposedModule, InstalledPackageInfo)
-import Distribution.Types.LibraryName (LibraryName)
-import Distribution.Types.LibraryVisibility (LibraryVisibility)
-import Distribution.Utils.ShortText (ShortText)
+import Distribution.Types.LibraryName (LibraryName)
+import Distribution.Types.LibraryVisibility (LibraryVisibility)
+import Distribution.Utils.ShortText (ShortText)
-
-import qualified Distribution.SPDX as SPDX
+import qualified Distribution.SPDX as SPDX
import qualified Distribution.Types.InstalledPackageInfo as T
sourcePackageId :: Lens' InstalledPackageInfo PackageIdentifier
-sourcePackageId f s = fmap (\x -> s { T.sourcePackageId = x }) (f (T.sourcePackageId s))
+sourcePackageId f s = fmap (\x -> s{T.sourcePackageId = x}) (f (T.sourcePackageId s))
{-# INLINE sourcePackageId #-}
installedUnitId :: Lens' InstalledPackageInfo UnitId
-installedUnitId f s = fmap (\x -> s { T.installedUnitId = x }) (f (T.installedUnitId s))
+installedUnitId f s = fmap (\x -> s{T.installedUnitId = x}) (f (T.installedUnitId s))
{-# INLINE installedUnitId #-}
installedComponentId_ :: Lens' InstalledPackageInfo ComponentId
-installedComponentId_ f s = fmap (\x -> s { T.installedComponentId_ = x }) (f (T.installedComponentId_ s))
+installedComponentId_ f s = fmap (\x -> s{T.installedComponentId_ = x}) (f (T.installedComponentId_ s))
{-# INLINE installedComponentId_ #-}
-instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName,OpenModule)]
-instantiatedWith f s = fmap (\x -> s { T.instantiatedWith = x }) (f (T.instantiatedWith s))
+instantiatedWith :: Lens' InstalledPackageInfo [(ModuleName, OpenModule)]
+instantiatedWith f s = fmap (\x -> s{T.instantiatedWith = x}) (f (T.instantiatedWith s))
{-# INLINE instantiatedWith #-}
sourceLibName :: Lens' InstalledPackageInfo LibraryName
-sourceLibName f s = fmap (\x -> s { T.sourceLibName = x }) (f (T.sourceLibName s))
+sourceLibName f s = fmap (\x -> s{T.sourceLibName = x}) (f (T.sourceLibName s))
{-# INLINE sourceLibName #-}
compatPackageKey :: Lens' InstalledPackageInfo String
-compatPackageKey f s = fmap (\x -> s { T.compatPackageKey = x }) (f (T.compatPackageKey s))
+compatPackageKey f s = fmap (\x -> s{T.compatPackageKey = x}) (f (T.compatPackageKey s))
{-# INLINE compatPackageKey #-}
license :: Lens' InstalledPackageInfo (Either SPDX.License License)
-license f s = fmap (\x -> s { T.license = x }) (f (T.license s))
+license f s = fmap (\x -> s{T.license = x}) (f (T.license s))
{-# INLINE license #-}
copyright :: Lens' InstalledPackageInfo ShortText
-copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s))
+copyright f s = fmap (\x -> s{T.copyright = x}) (f (T.copyright s))
{-# INLINE copyright #-}
maintainer :: Lens' InstalledPackageInfo ShortText
-maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s))
+maintainer f s = fmap (\x -> s{T.maintainer = x}) (f (T.maintainer s))
{-# INLINE maintainer #-}
author :: Lens' InstalledPackageInfo ShortText
-author f s = fmap (\x -> s { T.author = x }) (f (T.author s))
+author f s = fmap (\x -> s{T.author = x}) (f (T.author s))
{-# INLINE author #-}
stability :: Lens' InstalledPackageInfo ShortText
-stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s))
+stability f s = fmap (\x -> s{T.stability = x}) (f (T.stability s))
{-# INLINE stability #-}
homepage :: Lens' InstalledPackageInfo ShortText
-homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s))
+homepage f s = fmap (\x -> s{T.homepage = x}) (f (T.homepage s))
{-# INLINE homepage #-}
pkgUrl :: Lens' InstalledPackageInfo ShortText
-pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s))
+pkgUrl f s = fmap (\x -> s{T.pkgUrl = x}) (f (T.pkgUrl s))
{-# INLINE pkgUrl #-}
synopsis :: Lens' InstalledPackageInfo ShortText
-synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s))
+synopsis f s = fmap (\x -> s{T.synopsis = x}) (f (T.synopsis s))
{-# INLINE synopsis #-}
description :: Lens' InstalledPackageInfo ShortText
-description f s = fmap (\x -> s { T.description = x }) (f (T.description s))
+description f s = fmap (\x -> s{T.description = x}) (f (T.description s))
{-# INLINE description #-}
category :: Lens' InstalledPackageInfo ShortText
-category f s = fmap (\x -> s { T.category = x }) (f (T.category s))
+category f s = fmap (\x -> s{T.category = x}) (f (T.category s))
{-# INLINE category #-}
abiHash :: Lens' InstalledPackageInfo AbiHash
-abiHash f s = fmap (\x -> s { T.abiHash = x }) (f (T.abiHash s))
+abiHash f s = fmap (\x -> s{T.abiHash = x}) (f (T.abiHash s))
{-# INLINE abiHash #-}
indefinite :: Lens' InstalledPackageInfo Bool
-indefinite f s = fmap (\x -> s { T.indefinite = x }) (f (T.indefinite s))
+indefinite f s = fmap (\x -> s{T.indefinite = x}) (f (T.indefinite s))
{-# INLINE indefinite #-}
exposed :: Lens' InstalledPackageInfo Bool
-exposed f s = fmap (\x -> s { T.exposed = x }) (f (T.exposed s))
+exposed f s = fmap (\x -> s{T.exposed = x}) (f (T.exposed s))
{-# INLINE exposed #-}
exposedModules :: Lens' InstalledPackageInfo [ExposedModule]
-exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s))
+exposedModules f s = fmap (\x -> s{T.exposedModules = x}) (f (T.exposedModules s))
{-# INLINE exposedModules #-}
hiddenModules :: Lens' InstalledPackageInfo [ModuleName]
-hiddenModules f s = fmap (\x -> s { T.hiddenModules = x }) (f (T.hiddenModules s))
+hiddenModules f s = fmap (\x -> s{T.hiddenModules = x}) (f (T.hiddenModules s))
{-# INLINE hiddenModules #-}
trusted :: Lens' InstalledPackageInfo Bool
-trusted f s = fmap (\x -> s { T.trusted = x }) (f (T.trusted s))
+trusted f s = fmap (\x -> s{T.trusted = x}) (f (T.trusted s))
{-# INLINE trusted #-}
importDirs :: Lens' InstalledPackageInfo [FilePath]
-importDirs f s = fmap (\x -> s { T.importDirs = x }) (f (T.importDirs s))
+importDirs f s = fmap (\x -> s{T.importDirs = x}) (f (T.importDirs s))
{-# INLINE importDirs #-}
libraryDirs :: Lens' InstalledPackageInfo [FilePath]
-libraryDirs f s = fmap (\x -> s { T.libraryDirs = x }) (f (T.libraryDirs s))
+libraryDirs f s = fmap (\x -> s{T.libraryDirs = x}) (f (T.libraryDirs s))
{-# INLINE libraryDirs #-}
libraryDirsStatic :: Lens' InstalledPackageInfo [FilePath]
-libraryDirsStatic f s = fmap (\x -> s { T.libraryDirsStatic = x }) (f (T.libraryDirsStatic s))
+libraryDirsStatic f s = fmap (\x -> s{T.libraryDirsStatic = x}) (f (T.libraryDirsStatic s))
{-# INLINE libraryDirsStatic #-}
libraryDynDirs :: Lens' InstalledPackageInfo [FilePath]
-libraryDynDirs f s = fmap (\x -> s { T.libraryDynDirs = x }) (f (T.libraryDynDirs s))
+libraryDynDirs f s = fmap (\x -> s{T.libraryDynDirs = x}) (f (T.libraryDynDirs s))
{-# INLINE libraryDynDirs #-}
dataDir :: Lens' InstalledPackageInfo FilePath
-dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s))
+dataDir f s = fmap (\x -> s{T.dataDir = x}) (f (T.dataDir s))
{-# INLINE dataDir #-}
hsLibraries :: Lens' InstalledPackageInfo [String]
-hsLibraries f s = fmap (\x -> s { T.hsLibraries = x }) (f (T.hsLibraries s))
+hsLibraries f s = fmap (\x -> s{T.hsLibraries = x}) (f (T.hsLibraries s))
{-# INLINE hsLibraries #-}
extraLibraries :: Lens' InstalledPackageInfo [String]
-extraLibraries f s = fmap (\x -> s { T.extraLibraries = x }) (f (T.extraLibraries s))
+extraLibraries f s = fmap (\x -> s{T.extraLibraries = x}) (f (T.extraLibraries s))
{-# INLINE extraLibraries #-}
extraLibrariesStatic :: Lens' InstalledPackageInfo [String]
-extraLibrariesStatic f s = fmap (\x -> s { T.extraLibrariesStatic = x }) (f (T.extraLibrariesStatic s))
+extraLibrariesStatic f s = fmap (\x -> s{T.extraLibrariesStatic = x}) (f (T.extraLibrariesStatic s))
{-# INLINE extraLibrariesStatic #-}
extraGHCiLibraries :: Lens' InstalledPackageInfo [String]
-extraGHCiLibraries f s = fmap (\x -> s { T.extraGHCiLibraries = x }) (f (T.extraGHCiLibraries s))
+extraGHCiLibraries f s = fmap (\x -> s{T.extraGHCiLibraries = x}) (f (T.extraGHCiLibraries s))
{-# INLINE extraGHCiLibraries #-}
includeDirs :: Lens' InstalledPackageInfo [FilePath]
-includeDirs f s = fmap (\x -> s { T.includeDirs = x }) (f (T.includeDirs s))
+includeDirs f s = fmap (\x -> s{T.includeDirs = x}) (f (T.includeDirs s))
{-# INLINE includeDirs #-}
includes :: Lens' InstalledPackageInfo [String]
-includes f s = fmap (\x -> s { T.includes = x }) (f (T.includes s))
+includes f s = fmap (\x -> s{T.includes = x}) (f (T.includes s))
{-# INLINE includes #-}
depends :: Lens' InstalledPackageInfo [UnitId]
-depends f s = fmap (\x -> s { T.depends = x }) (f (T.depends s))
+depends f s = fmap (\x -> s{T.depends = x}) (f (T.depends s))
{-# INLINE depends #-}
abiDepends :: Lens' InstalledPackageInfo [AbiDependency]
-abiDepends f s = fmap (\x -> s { T.abiDepends = x }) (f (T.abiDepends s))
+abiDepends f s = fmap (\x -> s{T.abiDepends = x}) (f (T.abiDepends s))
{-# INLINE abiDepends #-}
ccOptions :: Lens' InstalledPackageInfo [String]
-ccOptions f s = fmap (\x -> s { T.ccOptions = x }) (f (T.ccOptions s))
+ccOptions f s = fmap (\x -> s{T.ccOptions = x}) (f (T.ccOptions s))
{-# INLINE ccOptions #-}
cxxOptions :: Lens' InstalledPackageInfo [String]
-cxxOptions f s = fmap (\x -> s { T.cxxOptions = x }) (f (T.cxxOptions s))
+cxxOptions f s = fmap (\x -> s{T.cxxOptions = x}) (f (T.cxxOptions s))
{-# INLINE cxxOptions #-}
ldOptions :: Lens' InstalledPackageInfo [String]
-ldOptions f s = fmap (\x -> s { T.ldOptions = x }) (f (T.ldOptions s))
+ldOptions f s = fmap (\x -> s{T.ldOptions = x}) (f (T.ldOptions s))
{-# INLINE ldOptions #-}
frameworkDirs :: Lens' InstalledPackageInfo [FilePath]
-frameworkDirs f s = fmap (\x -> s { T.frameworkDirs = x }) (f (T.frameworkDirs s))
+frameworkDirs f s = fmap (\x -> s{T.frameworkDirs = x}) (f (T.frameworkDirs s))
{-# INLINE frameworkDirs #-}
frameworks :: Lens' InstalledPackageInfo [String]
-frameworks f s = fmap (\x -> s { T.frameworks = x }) (f (T.frameworks s))
+frameworks f s = fmap (\x -> s{T.frameworks = x}) (f (T.frameworks s))
{-# INLINE frameworks #-}
haddockInterfaces :: Lens' InstalledPackageInfo [FilePath]
-haddockInterfaces f s = fmap (\x -> s { T.haddockInterfaces = x }) (f (T.haddockInterfaces s))
+haddockInterfaces f s = fmap (\x -> s{T.haddockInterfaces = x}) (f (T.haddockInterfaces s))
{-# INLINE haddockInterfaces #-}
haddockHTMLs :: Lens' InstalledPackageInfo [FilePath]
-haddockHTMLs f s = fmap (\x -> s { T.haddockHTMLs = x }) (f (T.haddockHTMLs s))
+haddockHTMLs f s = fmap (\x -> s{T.haddockHTMLs = x}) (f (T.haddockHTMLs s))
{-# INLINE haddockHTMLs #-}
pkgRoot :: Lens' InstalledPackageInfo (Maybe FilePath)
-pkgRoot f s = fmap (\x -> s { T.pkgRoot = x }) (f (T.pkgRoot s))
+pkgRoot f s = fmap (\x -> s{T.pkgRoot = x}) (f (T.pkgRoot s))
{-# INLINE pkgRoot #-}
libVisibility :: Lens' InstalledPackageInfo LibraryVisibility
-libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s))
+libVisibility f s = fmap (\x -> s{T.libVisibility = x}) (f (T.libVisibility s))
{-# INLINE libVisibility #-}
-
diff --git a/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs b/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs
index 8f010d330edf57795d95e42378e10182f4c5209d..7acf028d0b3c81b323bb8ffc68166272b1861787 100644
--- a/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs
+++ b/Cabal-syntax/src/Distribution/Types/LegacyExeDependency.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.LegacyExeDependency
- ( LegacyExeDependency(..)
+ ( LegacyExeDependency (..)
) where
import Distribution.Compat.Prelude
@@ -12,7 +13,7 @@ import Distribution.Pretty
import Distribution.Version (VersionRange, anyVersion)
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- | Describes a legacy `build-tools`-style dependency on an executable
--
@@ -21,27 +22,28 @@ import qualified Text.PrettyPrint as Disp
-- executable (UnqualComponentName). Thus the name is stringly typed.
--
-- @since 2.0.0.2
-data LegacyExeDependency = LegacyExeDependency
- String
- VersionRange
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data LegacyExeDependency
+ = LegacyExeDependency
+ String
+ VersionRange
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary LegacyExeDependency
instance Structured LegacyExeDependency
instance NFData LegacyExeDependency where rnf = genericRnf
instance Pretty LegacyExeDependency where
- pretty (LegacyExeDependency name ver) =
- Disp.text name <+> pretty ver
+ pretty (LegacyExeDependency name ver) =
+ Disp.text name <+> pretty ver
instance Parsec LegacyExeDependency where
- parsec = do
- name <- parsecMaybeQuoted nameP
- P.spaces
- verRange <- parsecMaybeQuoted parsec <|> pure anyVersion
- pure $ LegacyExeDependency name verRange
- where
- nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-')
- component = do
- cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
- if all isDigit cs then fail "invalid component" else return cs
+ parsec = do
+ name <- parsecMaybeQuoted nameP
+ P.spaces
+ verRange <- parsecMaybeQuoted parsec <|> pure anyVersion
+ pure $ LegacyExeDependency name verRange
+ where
+ nameP = intercalate "-" <$> toList <$> P.sepByNonEmpty component (P.char '-')
+ component = do
+ cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
+ if all isDigit cs then fail "invalid component" else return cs
diff --git a/Cabal-syntax/src/Distribution/Types/Lens.hs b/Cabal-syntax/src/Distribution/Types/Lens.hs
index 1581ff23cdd4b1380872980fe5e2f3b8c17b433d..2934d722fbdcbf9a1e9cc20d9a3cdbd71feb2ba3 100644
--- a/Cabal-syntax/src/Distribution/Types/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/Lens.hs
@@ -1,16 +1,16 @@
-module Distribution.Types.Lens (
- module Distribution.Types.Benchmark.Lens,
- module Distribution.Types.BuildInfo.Lens,
- module Distribution.Types.Executable.Lens,
- module Distribution.Types.ForeignLib.Lens,
- module Distribution.Types.GenericPackageDescription.Lens,
- module Distribution.Types.Library.Lens,
- module Distribution.Types.PackageDescription.Lens,
- module Distribution.Types.PackageId.Lens,
- module Distribution.Types.SetupBuildInfo.Lens,
- module Distribution.Types.SourceRepo.Lens,
- module Distribution.Types.TestSuite.Lens,
- ) where
+module Distribution.Types.Lens
+ ( module Distribution.Types.Benchmark.Lens
+ , module Distribution.Types.BuildInfo.Lens
+ , module Distribution.Types.Executable.Lens
+ , module Distribution.Types.ForeignLib.Lens
+ , module Distribution.Types.GenericPackageDescription.Lens
+ , module Distribution.Types.Library.Lens
+ , module Distribution.Types.PackageDescription.Lens
+ , module Distribution.Types.PackageId.Lens
+ , module Distribution.Types.SetupBuildInfo.Lens
+ , module Distribution.Types.SourceRepo.Lens
+ , module Distribution.Types.TestSuite.Lens
+ ) where
import Distribution.Types.Benchmark.Lens
import Distribution.Types.BuildInfo.Lens
diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs
index 4ac153bc0b069229228c856a5cfc0add49befb85..738965ea1670c0cdc7945370646f00c21f38a4dd 100644
--- a/Cabal-syntax/src/Distribution/Types/Library.hs
+++ b/Cabal-syntax/src/Distribution/Types/Library.hs
@@ -1,51 +1,55 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Library (
- Library(..),
- emptyLibrary,
- explicitLibModules,
- libModulesAutogen,
-) where
+module Distribution.Types.Library
+ ( Library (..)
+ , emptyLibrary
+ , explicitLibModules
+ , libModulesAutogen
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.ModuleName
import Distribution.Types.BuildInfo
+import Distribution.Types.LibraryName
import Distribution.Types.LibraryVisibility
import Distribution.Types.ModuleReexport
-import Distribution.Types.LibraryName
import qualified Distribution.Types.BuildInfo.Lens as L
data Library = Library
- { libName :: LibraryName
- , exposedModules :: [ModuleName]
- , reexportedModules :: [ModuleReexport]
- , signatures :: [ModuleName] -- ^ What sigs need implementations?
- , libExposed :: Bool -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example)
- , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be used as a dependency for other packages.
- , libBuildInfo :: BuildInfo
- }
- deriving (Generic, Show, Eq, Ord, Read, Typeable, Data)
+ { libName :: LibraryName
+ , exposedModules :: [ModuleName]
+ , reexportedModules :: [ModuleReexport]
+ , signatures :: [ModuleName]
+ -- ^ What sigs need implementations?
+ , libExposed :: Bool
+ -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example)
+ , libVisibility :: LibraryVisibility
+ -- ^ Whether this multilib can be used as a dependency for other packages.
+ , libBuildInfo :: BuildInfo
+ }
+ deriving (Generic, Show, Eq, Ord, Read, Typeable, Data)
instance L.HasBuildInfo Library where
- buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l)
+ buildInfo f l = (\x -> l{libBuildInfo = x}) <$> f (libBuildInfo l)
instance Binary Library
instance Structured Library
instance NFData Library where rnf = genericRnf
emptyLibrary :: Library
-emptyLibrary = Library
- { libName = LMainLibName
- , exposedModules = mempty
+emptyLibrary =
+ Library
+ { libName = LMainLibName
+ , exposedModules = mempty
, reexportedModules = mempty
- , signatures = mempty
- , libExposed = True
- , libVisibility = mempty
- , libBuildInfo = mempty
+ , signatures = mempty
+ , libExposed = True
+ , libVisibility = mempty
+ , libBuildInfo = mempty
}
-- | This instance is not good.
@@ -55,22 +59,23 @@ emptyLibrary = Library
--
-- More concretely, 'addBuildableCondition' will make `libVisibility = False`
-- libraries when `buildable: false`. This may cause problems.
---
instance Monoid Library where
- mempty = emptyLibrary
- mappend = (<>)
+ mempty = emptyLibrary
+ mappend = (<>)
instance Semigroup Library where
- a <> b = Library
- { libName = combineLibraryName (libName a) (libName b)
- , exposedModules = combine exposedModules
- , reexportedModules = combine reexportedModules
- , signatures = combine signatures
- , libExposed = libExposed a && libExposed b -- so False propagates
- , libVisibility = combine libVisibility
- , libBuildInfo = combine libBuildInfo
- }
- where combine field = field a `mappend` field b
+ a <> b =
+ Library
+ { libName = combineLibraryName (libName a) (libName b)
+ , exposedModules = combine exposedModules
+ , reexportedModules = combine reexportedModules
+ , signatures = combine signatures
+ , libExposed = libExposed a && libExposed b -- so False propagates
+ , libVisibility = combine libVisibility
+ , libBuildInfo = combine libBuildInfo
+ }
+ where
+ combine field = field a `mappend` field b
-- | Get all the module names from the library (exposed and internal modules)
-- which are explicitly listed in the package description which would
@@ -78,9 +83,10 @@ instance Semigroup Library where
-- do not need to be compiled.) This may not include all modules for which
-- GHC generated interface files (i.e., implicit modules.)
explicitLibModules :: Library -> [ModuleName]
-explicitLibModules lib = exposedModules lib
- ++ otherModules (libBuildInfo lib)
- ++ signatures lib
+explicitLibModules lib =
+ exposedModules lib
+ ++ otherModules (libBuildInfo lib)
+ ++ signatures lib
-- | Get all the auto generated module names from the library, exposed or not.
-- This are a subset of 'libModules'.
@@ -93,4 +99,4 @@ libModulesAutogen lib = autogenModules (libBuildInfo lib)
-- /Should/ be irrelevant.
combineLibraryName :: LibraryName -> LibraryName -> LibraryName
combineLibraryName l@(LSubLibName _) _ = l
-combineLibraryName _ l = l
+combineLibraryName _ l = l
diff --git a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs
index fefccbdd1a36b01e34db780600ed1db1fe407e19..9787f3700ddd7187276b2035de4e2cee5e5ac260 100644
--- a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs
@@ -1,45 +1,45 @@
-module Distribution.Types.Library.Lens (
- Library,
- module Distribution.Types.Library.Lens,
- ) where
+module Distribution.Types.Library.Lens
+ ( Library
+ , module Distribution.Types.Library.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.ModuleName (ModuleName)
-import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.Library (Library)
-import Distribution.Types.LibraryName (LibraryName)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.Library (Library)
+import Distribution.Types.LibraryName (LibraryName)
import Distribution.Types.LibraryVisibility (LibraryVisibility)
-import Distribution.Types.ModuleReexport (ModuleReexport)
+import Distribution.Types.ModuleReexport (ModuleReexport)
import qualified Distribution.Types.Library as T
libName :: Lens' Library LibraryName
-libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s))
+libName f s = fmap (\x -> s{T.libName = x}) (f (T.libName s))
{-# INLINE libName #-}
exposedModules :: Lens' Library [ModuleName]
-exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s))
+exposedModules f s = fmap (\x -> s{T.exposedModules = x}) (f (T.exposedModules s))
{-# INLINE exposedModules #-}
reexportedModules :: Lens' Library [ModuleReexport]
-reexportedModules f s = fmap (\x -> s { T.reexportedModules = x }) (f (T.reexportedModules s))
+reexportedModules f s = fmap (\x -> s{T.reexportedModules = x}) (f (T.reexportedModules s))
{-# INLINE reexportedModules #-}
signatures :: Lens' Library [ModuleName]
-signatures f s = fmap (\x -> s { T.signatures = x }) (f (T.signatures s))
+signatures f s = fmap (\x -> s{T.signatures = x}) (f (T.signatures s))
{-# INLINE signatures #-}
libExposed :: Lens' Library Bool
-libExposed f s = fmap (\x -> s { T.libExposed = x }) (f (T.libExposed s))
+libExposed f s = fmap (\x -> s{T.libExposed = x}) (f (T.libExposed s))
{-# INLINE libExposed #-}
libVisibility :: Lens' Library LibraryVisibility
-libVisibility f s = fmap (\x -> s { T.libVisibility = x }) (f (T.libVisibility s))
+libVisibility f s = fmap (\x -> s{T.libVisibility = x}) (f (T.libVisibility s))
{-# INLINE libVisibility #-}
libBuildInfo :: Lens' Library BuildInfo
-libBuildInfo f s = fmap (\x -> s { T.libBuildInfo = x }) (f (T.libBuildInfo s))
+libBuildInfo f s = fmap (\x -> s{T.libBuildInfo = x}) (f (T.libBuildInfo s))
{-# INLINE libBuildInfo #-}
diff --git a/Cabal-syntax/src/Distribution/Types/LibraryName.hs b/Cabal-syntax/src/Distribution/Types/LibraryName.hs
index 109ccd1a127ce8e94b6aa2bb8d147774538a5b64..2b8f53f4f89e1bb5b3072df6f41f907aa7d4bd3e 100644
--- a/Cabal-syntax/src/Distribution/Types/LibraryName.hs
+++ b/Cabal-syntax/src/Distribution/Types/LibraryName.hs
@@ -1,31 +1,33 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.LibraryName (
- LibraryName(..),
- defaultLibName,
- maybeToLibraryName,
- showLibraryName,
- libraryNameStanza,
- libraryNameString,
- -- * Pretty & Parse
- prettyLibraryNameComponent,
- parsecLibraryNameComponent,
+module Distribution.Types.LibraryName
+ ( LibraryName (..)
+ , defaultLibName
+ , maybeToLibraryName
+ , showLibraryName
+ , libraryNameStanza
+ , libraryNameString
+
+ -- * Pretty & Parse
+ , prettyLibraryNameComponent
+ , parsecLibraryNameComponent
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.Types.UnqualComponentName
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-data LibraryName = LMainLibName
- | LSubLibName UnqualComponentName
- deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
+data LibraryName
+ = LMainLibName
+ | LSubLibName UnqualComponentName
+ deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
instance Binary LibraryName
instance Structured LibraryName
@@ -37,28 +39,28 @@ instance NFData LibraryName where rnf = genericRnf
-- as there's other way to represent 'LibraryName', namely as bare
-- 'UnqualComponentName'.
prettyLibraryNameComponent :: LibraryName -> Disp.Doc
-prettyLibraryNameComponent LMainLibName = Disp.text "lib"
+prettyLibraryNameComponent LMainLibName = Disp.text "lib"
prettyLibraryNameComponent (LSubLibName str) = Disp.text "lib:" <<>> pretty str
parsecLibraryNameComponent :: CabalParsing m => m LibraryName
parsecLibraryNameComponent = do
- _ <- P.string "lib"
- parseComposite <|> parseSingle
+ _ <- P.string "lib"
+ parseComposite <|> parseSingle
where
parseSingle = return LMainLibName
parseComposite = do
- _ <- P.char ':'
- LSubLibName <$> parsec
+ _ <- P.char ':'
+ LSubLibName <$> parsec
defaultLibName :: LibraryName
defaultLibName = LMainLibName
showLibraryName :: LibraryName -> String
-showLibraryName LMainLibName = "library"
+showLibraryName LMainLibName = "library"
showLibraryName (LSubLibName name) = "library '" ++ prettyShow name ++ "'"
libraryNameStanza :: LibraryName -> String
-libraryNameStanza LMainLibName = "library"
+libraryNameStanza LMainLibName = "library"
libraryNameStanza (LSubLibName name) = "library " ++ prettyShow name
libraryNameString :: LibraryName -> Maybe UnqualComponentName
@@ -70,4 +72,3 @@ libraryNameString (LSubLibName n) = Just n
maybeToLibraryName :: Maybe UnqualComponentName -> LibraryName
maybeToLibraryName Nothing = LMainLibName
maybeToLibraryName (Just n) = LSubLibName n
-
diff --git a/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs b/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs
index 7ef160ace4dbf66c5953b5c1334b908c2d28f745..bf113488a5ca40c3a0daf9736f9ba47866a61561 100644
--- a/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs
+++ b/Cabal-syntax/src/Distribution/Types/LibraryVisibility.hs
@@ -1,10 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.LibraryVisibility(
- LibraryVisibility(..),
-) where
+module Distribution.Types.LibraryVisibility
+ ( LibraryVisibility (..)
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -13,39 +13,38 @@ import Distribution.Parsec
import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- | Multi-lib visibility
--
-- @since 3.0.0.0
---
data LibraryVisibility
- -- | Can be used as a dependency for other packages
- = LibraryVisibilityPublic
- -- | Internal library, default
- | LibraryVisibilityPrivate
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+ = -- | Can be used as a dependency for other packages
+ LibraryVisibilityPublic
+ | -- | Internal library, default
+ LibraryVisibilityPrivate
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Pretty LibraryVisibility where
- pretty LibraryVisibilityPublic = Disp.text "public"
- pretty LibraryVisibilityPrivate = Disp.text "private"
+ pretty LibraryVisibilityPublic = Disp.text "public"
+ pretty LibraryVisibilityPrivate = Disp.text "private"
instance Parsec LibraryVisibility where
parsec = do
name <- P.munch1 isAlpha
case name of
- "public" -> return LibraryVisibilityPublic
+ "public" -> return LibraryVisibilityPublic
"private" -> return LibraryVisibilityPrivate
- _ -> fail $ "Unknown visibility: " ++ name
+ _ -> fail $ "Unknown visibility: " ++ name
instance Binary LibraryVisibility
instance Structured LibraryVisibility
instance NFData LibraryVisibility where rnf = genericRnf
instance Semigroup LibraryVisibility where
- LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate
- _ <> _ = LibraryVisibilityPublic
+ LibraryVisibilityPrivate <> LibraryVisibilityPrivate = LibraryVisibilityPrivate
+ _ <> _ = LibraryVisibilityPublic
instance Monoid LibraryVisibility where
- mempty = LibraryVisibilityPrivate
- mappend = (<>)
+ mempty = LibraryVisibilityPrivate
+ mappend = (<>)
diff --git a/Cabal-syntax/src/Distribution/Types/Mixin.hs b/Cabal-syntax/src/Distribution/Types/Mixin.hs
index c119006e163ced8e45fcf16e2633eeda86a5db33..6a2a527ca58f0f928d787af23592c0bab5fa5ce7 100644
--- a/Cabal-syntax/src/Distribution/Types/Mixin.hs
+++ b/Cabal-syntax/src/Distribution/Types/Mixin.hs
@@ -1,11 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Mixin (
- Mixin(..),
- mkMixin,
- normaliseMixin,
-) where
+module Distribution.Types.Mixin
+ ( Mixin (..)
+ , mkMixin
+ , normaliseMixin
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -19,18 +19,19 @@ import Distribution.Types.PackageName
import Distribution.Types.UnqualComponentName
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
-- |
--
-- /Invariant:/ if 'mixinLibraryName' is 'LSubLibName', it's not
-- the same as 'mixinPackageName'. In other words,
-- the same invariant as 'Dependency' has.
---
-data Mixin = Mixin { mixinPackageName :: PackageName
- , mixinLibraryName :: LibraryName
- , mixinIncludeRenaming :: IncludeRenaming }
- deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
+data Mixin = Mixin
+ { mixinPackageName :: PackageName
+ , mixinLibraryName :: LibraryName
+ , mixinIncludeRenaming :: IncludeRenaming
+ }
+ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
instance Binary Mixin
instance Structured Mixin
@@ -38,8 +39,8 @@ instance Structured Mixin
instance NFData Mixin where rnf = genericRnf
instance Pretty Mixin where
- pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl
- pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl
+ pretty (Mixin pn LMainLibName incl) = pretty pn <+> pretty incl
+ pretty (Mixin pn (LSubLibName ln) incl) = pretty pn <<>> PP.colon <<>> pretty ln <+> pretty incl
-- |
--
@@ -56,36 +57,37 @@ instance Pretty Mixin where
--
-- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV3_0, CabalSpecV3_4] :: [Maybe Mixin]
-- [Nothing,Just (Mixin {mixinPackageName = PackageName "mylib", mixinLibraryName = LSubLibName (UnqualComponentName "sub"), mixinIncludeRenaming = IncludeRenaming {includeProvidesRn = DefaultRenaming, includeRequiresRn = DefaultRenaming}})]
---
instance Parsec Mixin where
- parsec = do
- pn <- parsec
- ln <- P.option LMainLibName $ do
- _ <- P.char ':'
- versionGuardMultilibs
- LSubLibName <$> parsec
- P.spaces
- incl <- parsec
- return (mkMixin pn ln incl)
- where
+ parsec = do
+ pn <- parsec
+ ln <- P.option LMainLibName $ do
+ _ <- P.char ':'
+ versionGuardMultilibs
+ LSubLibName <$> parsec
+ P.spaces
+ incl <- parsec
+ return (mkMixin pn ln incl)
+ where
versionGuardMultilibs :: CabalParsing m => m ()
versionGuardMultilibs = do
csv <- askCabalSpecVersion
- when (csv < CabalSpecV3_4) $ fail $ unwords
- [ "Sublibrary mixin syntax used."
- , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'."
- ]
+ when (csv < CabalSpecV3_4) $
+ fail $
+ unwords
+ [ "Sublibrary mixin syntax used."
+ , "To use this syntax the package needs to specify at least 'cabal-version: 3.4'."
+ ]
-- | Smart constructor of 'Mixin', enforces invariant.
--
-- @since 3.4.0.0
mkMixin :: PackageName -> LibraryName -> IncludeRenaming -> Mixin
mkMixin pn (LSubLibName uqn) incl
- | packageNameToUnqualComponentName pn == uqn
- = Mixin pn LMainLibName incl
-mkMixin pn ln incl
- = Mixin pn ln incl
+ | packageNameToUnqualComponentName pn == uqn =
+ Mixin pn LMainLibName incl
+mkMixin pn ln incl =
+ Mixin pn ln incl
-- | Restore invariant
normaliseMixin :: Mixin -> Mixin
diff --git a/Cabal-syntax/src/Distribution/Types/Module.hs b/Cabal-syntax/src/Distribution/Types/Module.hs
index 187163c2824aabf803b5b5ba02bfc4681e18b29d..e9febeff0704242ba937b3fc137cdaa96413ef26 100644
--- a/Cabal-syntax/src/Distribution/Types/Module.hs
+++ b/Cabal-syntax/src/Distribution/Types/Module.hs
@@ -3,18 +3,18 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.Module
- ( Module(..)
+ ( Module (..)
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
-import Distribution.Pretty
+import Distribution.ModuleName
import Distribution.Parsec
+import Distribution.Pretty
import Distribution.Types.UnitId
-import Distribution.ModuleName
+import qualified Text.PrettyPrint as Disp
-- | A module identity uniquely identifies a Haskell module by
-- qualifying a 'ModuleName' with the 'UnitId' which defined
@@ -24,23 +24,23 @@ import Distribution.ModuleName
-- There are a few cases where Cabal needs to know about
-- module identities, e.g., when writing out reexported modules in
-- the 'InstalledPackageInfo'.
-data Module =
- Module DefUnitId ModuleName
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data Module
+ = Module DefUnitId ModuleName
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary Module
instance Structured Module
instance Pretty Module where
- pretty (Module uid mod_name) =
- pretty uid <<>> Disp.text ":" <<>> pretty mod_name
+ pretty (Module uid mod_name) =
+ pretty uid <<>> Disp.text ":" <<>> pretty mod_name
instance Parsec Module where
- parsec = do
- uid <- parsec
- _ <- P.char ':'
- mod_name <- parsec
- return (Module uid mod_name)
+ parsec = do
+ uid <- parsec
+ _ <- P.char ':'
+ mod_name <- parsec
+ return (Module uid mod_name)
instance NFData Module where
- rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name
+ rnf (Module uid mod_name) = rnf uid `seq` rnf mod_name
diff --git a/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs b/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs
index 03aae9cd4f69241a849d6b89ec951060af738826..0dae6002c3c19ac27c0e2f56f43c6dc18d22e821 100644
--- a/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs
+++ b/Cabal-syntax/src/Distribution/Types/ModuleReexport.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.ModuleReexport (
- ModuleReexport(..)
-) where
+module Distribution.Types.ModuleReexport
+ ( ModuleReexport (..)
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -14,37 +14,37 @@ import Distribution.Pretty
import Distribution.Types.PackageName
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- -----------------------------------------------------------------------------
-- Module re-exports
-data ModuleReexport = ModuleReexport {
- moduleReexportOriginalPackage :: Maybe PackageName,
- moduleReexportOriginalName :: ModuleName,
- moduleReexportName :: ModuleName
- }
- deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
+data ModuleReexport = ModuleReexport
+ { moduleReexportOriginalPackage :: Maybe PackageName
+ , moduleReexportOriginalName :: ModuleName
+ , moduleReexportName :: ModuleName
+ }
+ deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
instance Binary ModuleReexport
instance Structured ModuleReexport
instance NFData ModuleReexport where rnf = genericRnf
instance Pretty ModuleReexport where
- pretty (ModuleReexport mpkgname origname newname) =
- maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname
- <<>> pretty origname
+ pretty (ModuleReexport mpkgname origname newname) =
+ maybe Disp.empty (\pkgname -> pretty pkgname <<>> Disp.char ':') mpkgname
+ <<>> pretty origname
<+> if newname == origname
- then Disp.empty
- else Disp.text "as" <+> pretty newname
+ then Disp.empty
+ else Disp.text "as" <+> pretty newname
instance Parsec ModuleReexport where
- parsec = do
- mpkgname <- P.optional (P.try $ parsec <* P.char ':')
- origname <- parsec
- newname <- P.option origname $ P.try $ do
- P.spaces
- _ <- P.string "as"
- P.spaces
- parsec
- return (ModuleReexport mpkgname origname newname)
+ parsec = do
+ mpkgname <- P.optional (P.try $ parsec <* P.char ':')
+ origname <- parsec
+ newname <- P.option origname $ P.try $ do
+ P.spaces
+ _ <- P.string "as"
+ P.spaces
+ parsec
+ return (ModuleReexport mpkgname origname newname)
diff --git a/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs b/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs
index 581d45b99389083f080e873971bfe6acbbec1b60..022a321a05567983879cae41e98eb78df60d5eba 100644
--- a/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs
+++ b/Cabal-syntax/src/Distribution/Types/ModuleRenaming.hs
@@ -1,13 +1,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE RankNTypes #-}
-module Distribution.Types.ModuleRenaming (
- ModuleRenaming(..),
- interpModuleRenaming,
- defaultRenaming,
- isDefaultRenaming,
-) where
+module Distribution.Types.ModuleRenaming
+ ( ModuleRenaming (..)
+ , interpModuleRenaming
+ , defaultRenaming
+ , isDefaultRenaming
+ ) where
import Distribution.CabalSpecVersion
import Distribution.Compat.Prelude hiding (empty)
@@ -17,10 +17,10 @@ import Distribution.ModuleName
import Distribution.Parsec
import Distribution.Pretty
-import qualified Data.Map as Map
-import qualified Data.Set as Set
+import qualified Data.Map as Map
+import qualified Data.Set as Set
import qualified Distribution.Compat.CharParsing as P
-import Text.PrettyPrint (hsep, parens, punctuate, text, comma)
+import Text.PrettyPrint (comma, hsep, parens, punctuate, text)
-- | Renaming applied to the modules provided by a package.
-- The boolean indicates whether or not to also include all of the
@@ -30,18 +30,17 @@ import Text.PrettyPrint (hsep, parens, punctuate, text, comm
-- If a renaming is omitted you get the 'DefaultRenaming'.
--
-- (NB: This is a list not a map so that we can preserve order.)
---
data ModuleRenaming
- -- | A module renaming/thinning; e.g., @(A as B, C as C)@
- -- brings @B@ and @C@ into scope.
- = ModuleRenaming [(ModuleName, ModuleName)]
- -- | The default renaming, bringing all exported modules
- -- into scope.
- | DefaultRenaming
- -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all
- -- exported modules into scope except the hidden ones.
- | HidingRenaming [ModuleName]
- deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
+ = -- | A module renaming/thinning; e.g., @(A as B, C as C)@
+ -- brings @B@ and @C@ into scope.
+ ModuleRenaming [(ModuleName, ModuleName)]
+ | -- | The default renaming, bringing all exported modules
+ -- into scope.
+ DefaultRenaming
+ | -- | Hiding renaming, e.g., @hiding (A, B)@, bringing all
+ -- exported modules into scope except the hidden ones.
+ HidingRenaming [ModuleName]
+ deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
-- | Interpret a 'ModuleRenaming' as a partial map from 'ModuleName'
-- to 'ModuleName'. For efficiency, you should partially apply it
@@ -49,11 +48,11 @@ data ModuleRenaming
interpModuleRenaming :: ModuleRenaming -> ModuleName -> Maybe ModuleName
interpModuleRenaming DefaultRenaming = Just
interpModuleRenaming (ModuleRenaming rns) =
- let m = Map.fromList rns
- in \k -> Map.lookup k m
+ let m = Map.fromList rns
+ in \k -> Map.lookup k m
interpModuleRenaming (HidingRenaming hs) =
- let s = Set.fromList hs
- in \k -> if k `Set.member` s then Nothing else Just k
+ let s = Set.fromList hs
+ in \k -> if k `Set.member` s then Nothing else Just k
-- | The default renaming, if something is specified in @build-depends@
-- only.
@@ -66,10 +65,8 @@ isDefaultRenaming :: ModuleRenaming -> Bool
isDefaultRenaming DefaultRenaming = True
isDefaultRenaming _ = False
-
-
-instance Binary ModuleRenaming where
-instance Structured ModuleRenaming where
+instance Binary ModuleRenaming
+instance Structured ModuleRenaming
instance NFData ModuleRenaming where rnf = genericRnf
@@ -77,58 +74,62 @@ instance NFData ModuleRenaming where rnf = genericRnf
-- to allow "hiding (A, B)" or other modifier words.
instance Pretty ModuleRenaming where
pretty DefaultRenaming = mempty
- pretty (HidingRenaming hides)
- = text "hiding" <+> parens (hsep (punctuate comma (map pretty hides)))
- pretty (ModuleRenaming rns)
- = parens . hsep $ punctuate comma (map dispEntry rns)
- where dispEntry (orig, new)
- | orig == new = pretty orig
- | otherwise = pretty orig <+> text "as" <+> pretty new
+ pretty (HidingRenaming hides) =
+ text "hiding" <+> parens (hsep (punctuate comma (map pretty hides)))
+ pretty (ModuleRenaming rns) =
+ parens . hsep $ punctuate comma (map dispEntry rns)
+ where
+ dispEntry (orig, new)
+ | orig == new = pretty orig
+ | otherwise = pretty orig <+> text "as" <+> pretty new
instance Parsec ModuleRenaming where
- parsec = do
- csv <- askCabalSpecVersion
- if csv >= CabalSpecV3_0
- then moduleRenamingParsec parensLax lexemeParsec
- else moduleRenamingParsec parensStrict parsec
- where
- -- For cabal spec versions < 3.0 white spaces were not skipped
- -- after the '(' and ')' tokens in the mixin field. This
- -- parser checks the cabal file version and does the correct
- -- skipping of spaces.
- parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p
- parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p
-
- warnSpaces = P.optional $
- P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher"
+ parsec = do
+ csv <- askCabalSpecVersion
+ if csv >= CabalSpecV3_0
+ then moduleRenamingParsec parensLax lexemeParsec
+ else moduleRenamingParsec parensStrict parsec
+ where
+ -- For cabal spec versions < 3.0 white spaces were not skipped
+ -- after the '(' and ')' tokens in the mixin field. This
+ -- parser checks the cabal file version and does the correct
+ -- skipping of spaces.
+ parensLax p = P.between (P.char '(' >> P.spaces) (P.char ')' >> P.spaces) p
+ parensStrict p = P.between (P.char '(' >> warnSpaces) (P.char ')') p
+
+ warnSpaces =
+ P.optional $
+ P.space *> fail "space after parenthesis, use cabal-version: 3.0 or higher"
moduleRenamingParsec
- :: CabalParsing m
- => (forall a. m a -> m a) -- ^ between parens
- -> m ModuleName -- ^ module name parser
- -> m ModuleRenaming
+ :: CabalParsing m
+ => (forall a. m a -> m a)
+ -- ^ between parens
+ -> m ModuleName
+ -- ^ module name parser
+ -> m ModuleRenaming
moduleRenamingParsec bp mn =
- -- NB: try not necessary as the first token is obvious
- P.choice [ parseRename, parseHiding, return DefaultRenaming ]
+ -- NB: try not necessary as the first token is obvious
+ P.choice [parseRename, parseHiding, return DefaultRenaming]
where
cma = P.char ',' >> P.spaces
parseRename = do
- rns <- bp parseList
- P.spaces
- return (ModuleRenaming rns)
+ rns <- bp parseList
+ P.spaces
+ return (ModuleRenaming rns)
parseHiding = do
- _ <- P.string "hiding"
- P.spaces -- space isn't strictly required as next is an open paren
- hides <- bp (P.sepBy mn cma)
- return (HidingRenaming hides)
+ _ <- P.string "hiding"
+ P.spaces -- space isn't strictly required as next is an open paren
+ hides <- bp (P.sepBy mn cma)
+ return (HidingRenaming hides)
parseList =
- P.sepBy parseEntry cma
+ P.sepBy parseEntry cma
parseEntry = do
- orig <- parsec
+ orig <- parsec
+ P.spaces
+ P.option (orig, orig) $ do
+ _ <- P.string "as"
+ P.skipSpaces1 -- require space after "as"
+ new <- parsec
P.spaces
- P.option (orig, orig) $ do
- _ <- P.string "as"
- P.skipSpaces1 -- require space after "as"
- new <- parsec
- P.spaces
- return (orig, new)
+ return (orig, new)
diff --git a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs
index 2403c9f220c0b0aadbe466822c9618a4aec6a6bb..f1e0904586d53b640f97122d4cbc0e166bc6ed9f 100644
--- a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs
+++ b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.MungedPackageId
- ( MungedPackageId(..)
+ ( MungedPackageId (..)
, computeCompatPackageId
) where
@@ -13,22 +14,21 @@ import Distribution.Pretty
import Distribution.Types.LibraryName
import Distribution.Types.MungedPackageName
import Distribution.Types.PackageId
-import Distribution.Version (Version, nullVersion)
+import Distribution.Version (Version, nullVersion)
import qualified Text.PrettyPrint as Disp
-- | A simple pair of a 'MungedPackageName' and 'Version'. 'MungedPackageName' is to
-- 'MungedPackageId' as 'PackageName' is to 'PackageId'. See 'MungedPackageName' for more
-- info.
-data MungedPackageId
- = MungedPackageId {
- -- | The combined package and component name. see documentation for
- -- 'MungedPackageName'.
- mungedName :: MungedPackageName,
- -- | The version of this package / component, eg 1.2
- mungedVersion :: Version
- }
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data MungedPackageId = MungedPackageId
+ { mungedName :: MungedPackageName
+ -- ^ The combined package and component name. see documentation for
+ -- 'MungedPackageName'.
+ , mungedVersion :: Version
+ -- ^ The version of this package / component, eg 1.2
+ }
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary MungedPackageId
instance Structured MungedPackageId
@@ -40,11 +40,10 @@ instance Structured MungedPackageId
--
-- >>> prettyShow $ MungedPackageId (MungedPackageName "servant" (LSubLibName "lackey")) (mkVersion [0,1,2])
-- "z-servant-z-lackey-0.1.2"
---
instance Pretty MungedPackageId where
- pretty (MungedPackageId n v)
- | v == nullVersion = pretty n -- if no version, don't show version.
- | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
+ pretty (MungedPackageId n v)
+ | v == nullVersion = pretty n -- if no version, don't show version.
+ | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
-- |
--
@@ -65,18 +64,17 @@ instance Pretty MungedPackageId where
--
-- >>> simpleParsec "foo-bar.4-2" :: Maybe MungedPackageId
-- Nothing
---
instance Parsec MungedPackageId where
- parsec = do
- PackageIdentifier pn v <- parsec
- return $ MungedPackageId (decodeCompatPackageName pn) v
+ parsec = do
+ PackageIdentifier pn v <- parsec
+ return $ MungedPackageId (decodeCompatPackageName pn) v
instance NFData MungedPackageId where
- rnf (MungedPackageId name version) = rnf name `seq` rnf version
+ rnf (MungedPackageId name version) = rnf name `seq` rnf version
computeCompatPackageId :: PackageId -> LibraryName -> MungedPackageId
computeCompatPackageId (PackageIdentifier pn vr) ln =
- MungedPackageId (MungedPackageName pn ln) vr
+ MungedPackageId (MungedPackageName pn ln) vr
-- $setup
-- >>> :seti -XOverloadedStrings
diff --git a/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs b/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs
index 6b80ebb8cce9bd925aa6bd11b44b593c7a6ea970..78b648993d4b9538a13665e0227d7de58565e1e3 100644
--- a/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs
+++ b/Cabal-syntax/src/Distribution/Types/MungedPackageName.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.MungedPackageName
( MungedPackageName (..)
, decodeCompatPackageName
@@ -29,7 +30,6 @@ import qualified Text.PrettyPrint as Disp
-- In @3.0.0.0@ representation was changed from opaque (string) to semantic representation.
--
-- @since 2.0.0.2
---
data MungedPackageName = MungedPackageName !PackageName !LibraryName
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
@@ -71,12 +71,11 @@ instance NFData MungedPackageName where rnf = genericRnf
--
-- >>> prettyShow $ MungedPackageName "servant" (LSubLibName "lackey")
-- "z-servant-z-lackey"
---
instance Pretty MungedPackageName where
- -- First handle the cases where we can just use the original 'PackageName'.
- -- This is for the PRIMARY library, and it is non-Backpack, or the
- -- indefinite package for us.
- pretty = Disp.text . encodeCompatPackageName'
+ -- First handle the cases where we can just use the original 'PackageName'.
+ -- This is for the PRIMARY library, and it is non-Backpack, or the
+ -- indefinite package for us.
+ pretty = Disp.text . encodeCompatPackageName'
-- |
--
@@ -88,9 +87,8 @@ instance Pretty MungedPackageName where
--
-- >>> simpleParsec "z-servant-zz" :: Maybe MungedPackageName
-- Just (MungedPackageName (PackageName "z-servant-zz") LMainLibName)
---
instance Parsec MungedPackageName where
- parsec = decodeCompatPackageName' <$> parsecUnqualComponentName
+ parsec = decodeCompatPackageName' <$> parsecUnqualComponentName
-------------------------------------------------------------------------------
-- ZDashCode conversions
@@ -100,7 +98,6 @@ instance Parsec MungedPackageName where
--
-- >>> decodeCompatPackageName "z-servant-z-lackey"
-- MungedPackageName (PackageName "servant") (LSubLibName (UnqualComponentName "lackey"))
---
decodeCompatPackageName :: PackageName -> MungedPackageName
decodeCompatPackageName = decodeCompatPackageName' . unPackageName
@@ -111,44 +108,48 @@ decodeCompatPackageName = decodeCompatPackageName' . unPackageName
--
-- This is used in @cabal-install@ in the Solver.
-- May become obsolete as solver moves to per-component solving.
---
encodeCompatPackageName :: MungedPackageName -> PackageName
encodeCompatPackageName = mkPackageName . encodeCompatPackageName'
decodeCompatPackageName' :: String -> MungedPackageName
decodeCompatPackageName' m =
- case m of
- 'z':'-':rest | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest
- -> MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn))
- s -> MungedPackageName (mkPackageName s) LMainLibName
+ case m of
+ 'z' : '-' : rest
+ | Right [pn, cn] <- explicitEitherParsec parseZDashCode rest ->
+ MungedPackageName (mkPackageName pn) (LSubLibName (mkUnqualComponentName cn))
+ s -> MungedPackageName (mkPackageName s) LMainLibName
encodeCompatPackageName' :: MungedPackageName -> String
-encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn
+encodeCompatPackageName' (MungedPackageName pn LMainLibName) = unPackageName pn
encodeCompatPackageName' (MungedPackageName pn (LSubLibName uqn)) =
- "z-" ++ zdashcode (unPackageName pn) ++
- "-z-" ++ zdashcode (unUnqualComponentName uqn)
+ "z-"
+ ++ zdashcode (unPackageName pn)
+ ++ "-z-"
+ ++ zdashcode (unUnqualComponentName uqn)
zdashcode :: String -> String
zdashcode s = go s (Nothing :: Maybe Int) []
- where go [] _ r = reverse r
- go ('-':z) (Just n) r | n > 0 = go z (Just 0) ('-':'z':r)
- go ('-':z) _ r = go z (Just 0) ('-':r)
- go ('z':z) (Just n) r = go z (Just (n+1)) ('z':r)
- go (c:z) _ r = go z Nothing (c:r)
+ where
+ go [] _ r = reverse r
+ go ('-' : z) (Just n) r | n > 0 = go z (Just 0) ('-' : 'z' : r)
+ go ('-' : z) _ r = go z (Just 0) ('-' : r)
+ go ('z' : z) (Just n) r = go z (Just (n + 1)) ('z' : r)
+ go (c : z) _ r = go z Nothing (c : r)
parseZDashCode :: CabalParsing m => m [String]
parseZDashCode = do
- ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-')
- return (go ns)
+ ns <- toList <$> P.sepByNonEmpty (some (P.satisfy (/= '-'))) (P.char '-')
+ return (go ns)
where
- go ns = case break (=="z") ns of
- (_, []) -> [paste ns]
- (as, "z":bs) -> paste as : go bs
- _ -> error "parseZDashCode: go"
+ go ns = case break (== "z") ns of
+ (_, []) -> [paste ns]
+ (as, "z" : bs) -> paste as : go bs
+ _ -> error "parseZDashCode: go"
unZ :: String -> String
unZ "" = error "parseZDashCode: unZ"
- unZ r@('z':zs) | all (=='z') zs = zs
- | otherwise = r
+ unZ r@('z' : zs)
+ | all (== 'z') zs = zs
+ | otherwise = r
unZ r = r
paste :: [String] -> String
paste = intercalate "-" . map unZ
diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs
index cab7af05bd4fa1759cbea19fe8b53e45d7a28c88..f8f84311cec9676a820d9ae4662920448fd09184 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Types.PackageDescription
-- Copyright : Isaac Jones 2003-2005
@@ -25,70 +26,70 @@
-- It was done this way initially to avoid breaking too much stuff when the
-- feature was introduced. It could probably do with being rationalised at some
-- point to make it simpler.
-
-module Distribution.Types.PackageDescription (
- PackageDescription(..),
- license,
- license',
- buildType,
- emptyPackageDescription,
- hasPublicLib,
- hasLibs,
- allLibraries,
- withLib,
- hasExes,
- withExe,
- hasTests,
- withTest,
- hasBenchmarks,
- withBenchmark,
- hasForeignLibs,
- withForeignLib,
- allBuildInfo,
- enabledBuildInfos,
- allBuildDepends,
- enabledBuildDepends,
- updatePackageDescription,
- pkgComponents,
- pkgBuildableComponents,
- enabledComponents,
- lookupComponent,
- getComponent,
+module Distribution.Types.PackageDescription
+ ( PackageDescription (..)
+ , license
+ , license'
+ , buildType
+ , emptyPackageDescription
+ , hasPublicLib
+ , hasLibs
+ , allLibraries
+ , withLib
+ , hasExes
+ , withExe
+ , hasTests
+ , withTest
+ , hasBenchmarks
+ , withBenchmark
+ , hasForeignLibs
+ , withForeignLib
+ , allBuildInfo
+ , enabledBuildInfos
+ , allBuildDepends
+ , enabledBuildDepends
+ , updatePackageDescription
+ , pkgComponents
+ , pkgBuildableComponents
+ , enabledComponents
+ , lookupComponent
+ , getComponent
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Control.Monad ((<=<))
-- lens
-import qualified Distribution.Types.BuildInfo.Lens as L
-import Distribution.Types.Library
-import Distribution.Types.TestSuite
-import Distribution.Types.Executable
+
import Distribution.Types.Benchmark
+import qualified Distribution.Types.BuildInfo.Lens as L
+import Distribution.Types.Executable
import Distribution.Types.ForeignLib
+import Distribution.Types.Library
+import Distribution.Types.TestSuite
+import Distribution.Types.BuildInfo
+import Distribution.Types.BuildType
import Distribution.Types.Component
+import Distribution.Types.ComponentName
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.Dependency
+import Distribution.Types.HookedBuildInfo
import Distribution.Types.PackageId
-import Distribution.Types.ComponentName
import Distribution.Types.PackageName
-import Distribution.Types.UnqualComponentName
import Distribution.Types.SetupBuildInfo
-import Distribution.Types.BuildInfo
-import Distribution.Types.BuildType
import Distribution.Types.SourceRepo
-import Distribution.Types.HookedBuildInfo
+import Distribution.Types.UnqualComponentName
import Distribution.CabalSpecVersion
import Distribution.Compiler
import Distribution.License
import Distribution.Package
-import Distribution.Version
import Distribution.Utils.Path
import Distribution.Utils.ShortText
+import Distribution.Version
import qualified Distribution.SPDX as SPDX
@@ -100,53 +101,53 @@ import qualified Distribution.SPDX as SPDX
-- which is needed for all packages, such as the package name and version, and
-- information which is needed for the simple build system only, such as
-- the compiler options and library name.
---
-data PackageDescription
- = PackageDescription {
- -- the following are required by all packages:
-
- -- | The version of the Cabal spec that this package description uses.
- specVersion :: CabalSpecVersion,
- package :: PackageIdentifier,
- licenseRaw :: Either SPDX.License License,
- licenseFiles :: [SymbolicPath PackageDir LicenseFile],
- copyright :: !ShortText,
- maintainer :: !ShortText,
- author :: !ShortText,
- stability :: !ShortText,
- testedWith :: [(CompilerFlavor,VersionRange)],
- homepage :: !ShortText,
- pkgUrl :: !ShortText,
- bugReports :: !ShortText,
- sourceRepos :: [SourceRepo],
- synopsis :: !ShortText, -- ^A one-line summary of this package
- description :: !ShortText, -- ^A more verbose description of this package
- category :: !ShortText,
- customFieldsPD :: [(String,String)], -- ^Custom fields starting
- -- with x-, stored in a
- -- simple assoc-list.
-
- -- | The original @build-type@ value as parsed from the
- -- @.cabal@ file without defaulting. See also 'buildType'.
- --
- -- @since 2.2
- buildTypeRaw :: Maybe BuildType,
- setupBuildInfo :: Maybe SetupBuildInfo,
- -- components
- library :: Maybe Library,
- subLibraries :: [Library],
- executables :: [Executable],
- foreignLibs :: [ForeignLib],
- testSuites :: [TestSuite],
- benchmarks :: [Benchmark],
- -- files
- dataFiles :: [FilePath],
- dataDir :: FilePath,
- extraSrcFiles :: [FilePath],
- extraTmpFiles :: [FilePath],
- extraDocFiles :: [FilePath]
- }
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data PackageDescription = PackageDescription
+ { -- the following are required by all packages:
+
+ specVersion :: CabalSpecVersion
+ -- ^ The version of the Cabal spec that this package description uses.
+ , package :: PackageIdentifier
+ , licenseRaw :: Either SPDX.License License
+ , licenseFiles :: [SymbolicPath PackageDir LicenseFile]
+ , copyright :: !ShortText
+ , maintainer :: !ShortText
+ , author :: !ShortText
+ , stability :: !ShortText
+ , testedWith :: [(CompilerFlavor, VersionRange)]
+ , homepage :: !ShortText
+ , pkgUrl :: !ShortText
+ , bugReports :: !ShortText
+ , sourceRepos :: [SourceRepo]
+ , synopsis :: !ShortText
+ -- ^ A one-line summary of this package
+ , description :: !ShortText
+ -- ^ A more verbose description of this package
+ , category :: !ShortText
+ , customFieldsPD :: [(String, String)]
+ -- ^ Custom fields starting
+ -- with x-, stored in a
+ -- simple assoc-list.
+ , buildTypeRaw :: Maybe BuildType
+ -- ^ The original @build-type@ value as parsed from the
+ -- @.cabal@ file without defaulting. See also 'buildType'.
+ --
+ -- @since 2.2
+ , setupBuildInfo :: Maybe SetupBuildInfo
+ , -- components
+ library :: Maybe Library
+ , subLibraries :: [Library]
+ , executables :: [Executable]
+ , foreignLibs :: [ForeignLib]
+ , testSuites :: [TestSuite]
+ , benchmarks :: [Benchmark]
+ , -- files
+ dataFiles :: [FilePath]
+ , dataDir :: FilePath
+ , extraSrcFiles :: [FilePath]
+ , extraTmpFiles :: [FilePath]
+ , extraDocFiles :: [FilePath]
+ }
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary PackageDescription
instance Structured PackageDescription
@@ -185,49 +186,53 @@ license' = either id licenseToSPDX
-- @since 2.2
buildType :: PackageDescription -> BuildType
buildType pkg
- | specVersion pkg >= CabalSpecV2_2
- = fromMaybe newDefault (buildTypeRaw pkg)
+ | specVersion pkg >= CabalSpecV2_2 =
+ fromMaybe newDefault (buildTypeRaw pkg)
| otherwise -- cabal-version < 2.1
- = fromMaybe Custom (buildTypeRaw pkg)
+ =
+ fromMaybe Custom (buildTypeRaw pkg)
where
- newDefault | isNothing (setupBuildInfo pkg) = Simple
- | otherwise = Custom
+ newDefault
+ | isNothing (setupBuildInfo pkg) = Simple
+ | otherwise = Custom
emptyPackageDescription :: PackageDescription
-emptyPackageDescription
- = PackageDescription {
- package = PackageIdentifier (mkPackageName "")
- nullVersion,
- licenseRaw = Right UnspecifiedLicense, -- TODO:
- licenseFiles = [],
- specVersion = CabalSpecV1_0,
- buildTypeRaw = Nothing,
- copyright = mempty,
- maintainer = mempty,
- author = mempty,
- stability = mempty,
- testedWith = [],
- homepage = mempty,
- pkgUrl = mempty,
- bugReports = mempty,
- sourceRepos = [],
- synopsis = mempty,
- description = mempty,
- category = mempty,
- customFieldsPD = [],
- setupBuildInfo = Nothing,
- library = Nothing,
- subLibraries = [],
- foreignLibs = [],
- executables = [],
- testSuites = [],
- benchmarks = [],
- dataFiles = [],
- dataDir = ".",
- extraSrcFiles = [],
- extraTmpFiles = [],
- extraDocFiles = []
- }
+emptyPackageDescription =
+ PackageDescription
+ { package =
+ PackageIdentifier
+ (mkPackageName "")
+ nullVersion
+ , licenseRaw = Right UnspecifiedLicense -- TODO:
+ , licenseFiles = []
+ , specVersion = CabalSpecV1_0
+ , buildTypeRaw = Nothing
+ , copyright = mempty
+ , maintainer = mempty
+ , author = mempty
+ , stability = mempty
+ , testedWith = []
+ , homepage = mempty
+ , pkgUrl = mempty
+ , bugReports = mempty
+ , sourceRepos = []
+ , synopsis = mempty
+ , description = mempty
+ , category = mempty
+ , customFieldsPD = []
+ , setupBuildInfo = Nothing
+ , library = Nothing
+ , subLibraries = []
+ , foreignLibs = []
+ , executables = []
+ , testSuites = []
+ , benchmarks = []
+ , dataFiles = []
+ , dataDir = "."
+ , extraSrcFiles = []
+ , extraTmpFiles = []
+ , extraDocFiles = []
+ }
-- ---------------------------------------------------------------------------
-- The Library type
@@ -235,9 +240,9 @@ emptyPackageDescription
-- | Does this package have a buildable PUBLIC library?
hasPublicLib :: PackageDescription -> Bool
hasPublicLib p =
- case library p of
- Just lib -> buildable (libBuildInfo lib)
- Nothing -> False
+ case library p of
+ Just lib -> buildable (libBuildInfo lib)
+ Nothing -> False
-- | Does this package have any libraries?
hasLibs :: PackageDescription -> Bool
@@ -254,12 +259,12 @@ allLibraries p = maybeToList (library p) ++ subLibraries p
-- for more information.
withLib :: PackageDescription -> (Library -> IO ()) -> IO ()
withLib pkg_descr f =
- sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)]
+ sequence_ [f lib | lib <- allLibraries pkg_descr, buildable (libBuildInfo lib)]
-- ---------------------------------------------------------------------------
-- The Executable type
--- |does this package have any executables?
+-- | does this package have any executables?
hasExes :: PackageDescription -> Bool
hasExes p = any (buildable . buildInfo) (executables p)
@@ -283,10 +288,9 @@ hasTests = any (buildable . testBuildInfo) . testSuites
-- You probably want 'withTestLBI' if you have a 'LocalBuildInfo', see the note in
-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"
-- for more information.
-
withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
withTest pkg_descr f =
- sequence_ [ f test | test <- testSuites pkg_descr, buildable (testBuildInfo test) ]
+ sequence_ [f test | test <- testSuites pkg_descr, buildable (testBuildInfo test)]
-- ---------------------------------------------------------------------------
-- The Benchmark type
@@ -299,10 +303,9 @@ hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
-- You probably want 'withBenchLBI' if you have a 'LocalBuildInfo', see the note in
-- "Distribution.Types.ComponentRequestedSpec#buildable_vs_enabled_components"
-- for more information.
-
withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
withBenchmark pkg_descr f =
- sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)]
+ sequence_ [f bench | bench <- benchmarks pkg_descr, buildable (benchmarkBuildInfo bench)]
-- ---------------------------------------------------------------------------
-- The ForeignLib type
@@ -315,10 +318,11 @@ hasForeignLibs p = any (buildable . foreignLibBuildInfo) (foreignLibs p)
-- description.
withForeignLib :: PackageDescription -> (ForeignLib -> IO ()) -> IO ()
withForeignLib pkg_descr f =
- sequence_ [ f flib
- | flib <- foreignLibs pkg_descr
- , buildable (foreignLibBuildInfo flib)
- ]
+ sequence_
+ [ f flib
+ | flib <- foreignLibs pkg_descr
+ , buildable (foreignLibBuildInfo flib)
+ ]
-- ---------------------------------------------------------------------------
-- The BuildInfo type
@@ -328,27 +332,30 @@ withForeignLib pkg_descr f =
--
-- Useful for implementing package checks.
allBuildInfo :: PackageDescription -> [BuildInfo]
-allBuildInfo pkg_descr = [ bi | lib <- allLibraries pkg_descr
- , let bi = libBuildInfo lib ]
- ++ [ bi | flib <- foreignLibs pkg_descr
- , let bi = foreignLibBuildInfo flib ]
- ++ [ bi | exe <- executables pkg_descr
- , let bi = buildInfo exe ]
- ++ [ bi | tst <- testSuites pkg_descr
- , let bi = testBuildInfo tst ]
- ++ [ bi | tst <- benchmarks pkg_descr
- , let bi = benchmarkBuildInfo tst ]
+allBuildInfo pkg_descr =
+ [ bi | lib <- allLibraries pkg_descr, let bi = libBuildInfo lib
+ ]
+ ++ [ bi | flib <- foreignLibs pkg_descr, let bi = foreignLibBuildInfo flib
+ ]
+ ++ [ bi | exe <- executables pkg_descr, let bi = buildInfo exe
+ ]
+ ++ [ bi | tst <- testSuites pkg_descr, let bi = testBuildInfo tst
+ ]
+ ++ [ bi | tst <- benchmarks pkg_descr, let bi = benchmarkBuildInfo tst
+ ]
-- | Return all of the 'BuildInfo's of enabled components, i.e., all of
-- the ones that would be built if you run @./Setup build@.
enabledBuildInfos :: PackageDescription -> ComponentRequestedSpec -> [BuildInfo]
enabledBuildInfos pkg enabled =
- [ componentBuildInfo comp
- | comp <- enabledComponents pkg enabled ]
-
+ [ componentBuildInfo comp
+ | comp <- enabledComponents pkg enabled
+ ]
-- ------------------------------------------------------------
+
-- * Utils
+
-- ------------------------------------------------------------
-- | Get the combined build-depends entries of all components.
@@ -360,42 +367,50 @@ allBuildDepends = targetBuildDepends <=< allBuildInfo
enabledBuildDepends :: PackageDescription -> ComponentRequestedSpec -> [Dependency]
enabledBuildDepends spec pd = targetBuildDepends =<< enabledBuildInfos spec pd
-
updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription
-updatePackageDescription (mb_lib_bi, exe_bi) p
- = p{ executables = updateExecutables exe_bi (executables p)
- , library = updateLibrary mb_lib_bi (library p) }
- where
- updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library
- updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})
- updateLibrary Nothing mb_lib = mb_lib
- updateLibrary (Just _) Nothing = Nothing
-
- updateExecutables :: [(UnqualComponentName, BuildInfo)] -- ^[(exeName, new buildinfo)]
- -> [Executable] -- ^list of executables to update
- -> [Executable] -- ^list with exeNames updated
- updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'
-
- updateExecutable :: (UnqualComponentName, BuildInfo) -- ^(exeName, new buildinfo)
- -> [Executable] -- ^list of executables to update
- -> [Executable] -- ^list with exeName updated
- updateExecutable _ [] = []
- updateExecutable exe_bi'@(name,bi) (exe:exes)
- | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
- | otherwise = exe : updateExecutable exe_bi' exes
+updatePackageDescription (mb_lib_bi, exe_bi) p =
+ p
+ { executables = updateExecutables exe_bi (executables p)
+ , library = updateLibrary mb_lib_bi (library p)
+ }
+ where
+ updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library
+ updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})
+ updateLibrary Nothing mb_lib = mb_lib
+ updateLibrary (Just _) Nothing = Nothing
+
+ updateExecutables
+ :: [(UnqualComponentName, BuildInfo)]
+ -- \^[(exeName, new buildinfo)]
+ -> [Executable]
+ -- \^list of executables to update
+ -> [Executable]
+ -- \^list with exeNames updated
+ updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'
+
+ updateExecutable
+ :: (UnqualComponentName, BuildInfo)
+ -- \^(exeName, new buildinfo)
+ -> [Executable]
+ -- \^list of executables to update
+ -> [Executable]
+ -- \^list with exeName updated
+ updateExecutable _ [] = []
+ updateExecutable exe_bi'@(name, bi) (exe : exes)
+ | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
+ | otherwise = exe : updateExecutable exe_bi' exes
-- -----------------------------------------------------------------------------
-- Source-representation of buildable components
-- | All the components in the package.
---
pkgComponents :: PackageDescription -> [Component]
pkgComponents pkg =
- [ CLib lib | lib <- allLibraries pkg ]
- ++ [ CFLib flib | flib <- foreignLibs pkg ]
- ++ [ CExe exe | exe <- executables pkg ]
- ++ [ CTest tst | tst <- testSuites pkg ]
- ++ [ CBench bm | bm <- benchmarks pkg ]
+ [CLib lib | lib <- allLibraries pkg]
+ ++ [CFLib flib | flib <- foreignLibs pkg]
+ ++ [CExe exe | exe <- executables pkg]
+ ++ [CTest tst | tst <- testSuites pkg]
+ ++ [CBench bm | bm <- benchmarks pkg]
-- | A list of all components in the package that are buildable,
-- i.e., were not marked with @buildable: False@. This does NOT
@@ -403,55 +418,86 @@ pkgComponents pkg =
-- see 'enabledComponents' instead.
--
-- @since 2.0.0.2
---
pkgBuildableComponents :: PackageDescription -> [Component]
pkgBuildableComponents = filter componentBuildable . pkgComponents
-- | A list of all components in the package that are enabled.
--
-- @since 2.0.0.2
---
enabledComponents :: PackageDescription -> ComponentRequestedSpec -> [Component]
enabledComponents pkg enabled = filter (componentEnabled enabled) $ pkgBuildableComponents pkg
lookupComponent :: PackageDescription -> ComponentName -> Maybe Component
lookupComponent pkg (CLibName name) =
- fmap CLib $ find ((name ==) . libName) (allLibraries pkg)
+ fmap CLib $ find ((name ==) . libName) (allLibraries pkg)
lookupComponent pkg (CFLibName name) =
- fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg)
+ fmap CFLib $ find ((name ==) . foreignLibName) (foreignLibs pkg)
lookupComponent pkg (CExeName name) =
- fmap CExe $ find ((name ==) . exeName) (executables pkg)
+ fmap CExe $ find ((name ==) . exeName) (executables pkg)
lookupComponent pkg (CTestName name) =
- fmap CTest $ find ((name ==) . testName) (testSuites pkg)
+ fmap CTest $ find ((name ==) . testName) (testSuites pkg)
lookupComponent pkg (CBenchName name) =
- fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
+ fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)
getComponent :: PackageDescription -> ComponentName -> Component
getComponent pkg cname =
- case lookupComponent pkg cname of
- Just cpnt -> cpnt
- Nothing -> missingComponent
+ case lookupComponent pkg cname of
+ Just cpnt -> cpnt
+ Nothing -> missingComponent
where
missingComponent =
- error $ "internal error: the package description contains no "
- ++ "component corresponding to " ++ show cname
+ error $
+ "internal error: the package description contains no "
+ ++ "component corresponding to "
+ ++ show cname
-- -----------------------------------------------------------------------------
-- Traversal Instances
instance L.HasBuildInfos PackageDescription where
- traverseBuildInfos f (PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
- x1 x2 x3 x4 x5 x6
- a20 a21 a22 a23 a24) =
- PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
+ traverseBuildInfos
+ f
+ ( PackageDescription
+ a1
+ a2
+ a3
+ a4
+ a5
+ a6
+ a7
+ a8
+ a9
+ a10
+ a11
+ a12
+ a13
+ a14
+ a15
+ a16
+ a17
+ a18
+ a19
+ x1
+ x2
+ x3
+ x4
+ x5
+ x6
+ a20
+ a21
+ a22
+ a23
+ a24
+ ) =
+ PackageDescription a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 a16 a17 a18 a19
<$> (traverse . L.buildInfo) f x1 -- library
<*> (traverse . L.buildInfo) f x2 -- sub libraries
<*> (traverse . L.buildInfo) f x3 -- executables
<*> (traverse . L.buildInfo) f x4 -- foreign libs
<*> (traverse . L.buildInfo) f x5 -- test suites
<*> (traverse . L.buildInfo) f x6 -- benchmarks
- <*> pure a20 -- data files
- <*> pure a21 -- data dir
- <*> pure a22 -- extra src files
- <*> pure a23 -- extra temp files
- <*> pure a24 -- extra doc files
+ <*> pure a20 -- data files
+ <*> pure a21 -- data dir
+ <*> pure a22 -- extra src files
+ <*> pure a23 -- extra temp files
+ <*> pure a24 -- extra doc files
diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs
index 84be2292c5b40295fae303e579fb8f709dcb8faf..f2fdc7e57d6d0c0d38d98e096edecce21b663fa7 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs
@@ -1,193 +1,194 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-module Distribution.Types.PackageDescription.Lens (
- PackageDescription,
- module Distribution.Types.PackageDescription.Lens,
- ) where
+{-# LANGUAGE RankNTypes #-}
+
+module Distribution.Types.PackageDescription.Lens
+ ( PackageDescription
+ , module Distribution.Types.PackageDescription.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.CabalSpecVersion (CabalSpecVersion)
-import Distribution.Compiler (CompilerFlavor)
-import Distribution.License (License)
-import Distribution.ModuleName (ModuleName)
-import Distribution.Types.Benchmark (Benchmark, benchmarkModules)
-import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName)
-import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.BuildType (BuildType)
-import Distribution.Types.ComponentName (ComponentName (..))
-import Distribution.Types.Executable (Executable, exeModules)
-import Distribution.Types.Executable.Lens (exeBuildInfo, exeName)
-import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules)
-import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName)
-import Distribution.Types.Library (Library, explicitLibModules)
-import Distribution.Types.Library.Lens (libBuildInfo, libName)
+import Distribution.CabalSpecVersion (CabalSpecVersion)
+import Distribution.Compiler (CompilerFlavor)
+import Distribution.License (License)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Types.Benchmark (Benchmark, benchmarkModules)
+import Distribution.Types.Benchmark.Lens (benchmarkBuildInfo, benchmarkName)
+import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.BuildType (BuildType)
+import Distribution.Types.ComponentName (ComponentName (..))
+import Distribution.Types.Executable (Executable, exeModules)
+import Distribution.Types.Executable.Lens (exeBuildInfo, exeName)
+import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules)
+import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName)
+import Distribution.Types.Library (Library, explicitLibModules)
+import Distribution.Types.Library.Lens (libBuildInfo, libName)
import Distribution.Types.PackageDescription (PackageDescription)
-import Distribution.Types.PackageId (PackageIdentifier)
-import Distribution.Types.SetupBuildInfo (SetupBuildInfo)
-import Distribution.Types.SourceRepo (SourceRepo)
-import Distribution.Types.TestSuite (TestSuite, testModules)
-import Distribution.Types.TestSuite.Lens (testBuildInfo, testName)
-import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath)
-import Distribution.Utils.ShortText (ShortText)
-import Distribution.Version (VersionRange)
-
-import qualified Distribution.SPDX as SPDX
+import Distribution.Types.PackageId (PackageIdentifier)
+import Distribution.Types.SetupBuildInfo (SetupBuildInfo)
+import Distribution.Types.SourceRepo (SourceRepo)
+import Distribution.Types.TestSuite (TestSuite, testModules)
+import Distribution.Types.TestSuite.Lens (testBuildInfo, testName)
+import Distribution.Utils.Path (LicenseFile, PackageDir, SymbolicPath)
+import Distribution.Utils.ShortText (ShortText)
+import Distribution.Version (VersionRange)
+
+import qualified Distribution.SPDX as SPDX
import qualified Distribution.Types.PackageDescription as T
package :: Lens' PackageDescription PackageIdentifier
-package f s = fmap (\x -> s { T.package = x }) (f (T.package s))
+package f s = fmap (\x -> s{T.package = x}) (f (T.package s))
{-# INLINE package #-}
licenseRaw :: Lens' PackageDescription (Either SPDX.License License)
-licenseRaw f s = fmap (\x -> s { T.licenseRaw = x }) (f (T.licenseRaw s))
+licenseRaw f s = fmap (\x -> s{T.licenseRaw = x}) (f (T.licenseRaw s))
{-# INLINE licenseRaw #-}
licenseFiles :: Lens' PackageDescription [SymbolicPath PackageDir LicenseFile]
-licenseFiles f s = fmap (\x -> s { T.licenseFiles = x }) (f (T.licenseFiles s))
+licenseFiles f s = fmap (\x -> s{T.licenseFiles = x}) (f (T.licenseFiles s))
{-# INLINE licenseFiles #-}
copyright :: Lens' PackageDescription ShortText
-copyright f s = fmap (\x -> s { T.copyright = x }) (f (T.copyright s))
+copyright f s = fmap (\x -> s{T.copyright = x}) (f (T.copyright s))
{-# INLINE copyright #-}
maintainer :: Lens' PackageDescription ShortText
-maintainer f s = fmap (\x -> s { T.maintainer = x }) (f (T.maintainer s))
+maintainer f s = fmap (\x -> s{T.maintainer = x}) (f (T.maintainer s))
{-# INLINE maintainer #-}
author :: Lens' PackageDescription ShortText
-author f s = fmap (\x -> s { T.author = x }) (f (T.author s))
+author f s = fmap (\x -> s{T.author = x}) (f (T.author s))
{-# INLINE author #-}
stability :: Lens' PackageDescription ShortText
-stability f s = fmap (\x -> s { T.stability = x }) (f (T.stability s))
+stability f s = fmap (\x -> s{T.stability = x}) (f (T.stability s))
{-# INLINE stability #-}
-testedWith :: Lens' PackageDescription [(CompilerFlavor,VersionRange)]
-testedWith f s = fmap (\x -> s { T.testedWith = x }) (f (T.testedWith s))
+testedWith :: Lens' PackageDescription [(CompilerFlavor, VersionRange)]
+testedWith f s = fmap (\x -> s{T.testedWith = x}) (f (T.testedWith s))
{-# INLINE testedWith #-}
homepage :: Lens' PackageDescription ShortText
-homepage f s = fmap (\x -> s { T.homepage = x }) (f (T.homepage s))
+homepage f s = fmap (\x -> s{T.homepage = x}) (f (T.homepage s))
{-# INLINE homepage #-}
pkgUrl :: Lens' PackageDescription ShortText
-pkgUrl f s = fmap (\x -> s { T.pkgUrl = x }) (f (T.pkgUrl s))
+pkgUrl f s = fmap (\x -> s{T.pkgUrl = x}) (f (T.pkgUrl s))
{-# INLINE pkgUrl #-}
bugReports :: Lens' PackageDescription ShortText
-bugReports f s = fmap (\x -> s { T.bugReports = x }) (f (T.bugReports s))
+bugReports f s = fmap (\x -> s{T.bugReports = x}) (f (T.bugReports s))
{-# INLINE bugReports #-}
sourceRepos :: Lens' PackageDescription [SourceRepo]
-sourceRepos f s = fmap (\x -> s { T.sourceRepos = x }) (f (T.sourceRepos s))
+sourceRepos f s = fmap (\x -> s{T.sourceRepos = x}) (f (T.sourceRepos s))
{-# INLINE sourceRepos #-}
synopsis :: Lens' PackageDescription ShortText
-synopsis f s = fmap (\x -> s { T.synopsis = x }) (f (T.synopsis s))
+synopsis f s = fmap (\x -> s{T.synopsis = x}) (f (T.synopsis s))
{-# INLINE synopsis #-}
description :: Lens' PackageDescription ShortText
-description f s = fmap (\x -> s { T.description = x }) (f (T.description s))
+description f s = fmap (\x -> s{T.description = x}) (f (T.description s))
{-# INLINE description #-}
category :: Lens' PackageDescription ShortText
-category f s = fmap (\x -> s { T.category = x }) (f (T.category s))
+category f s = fmap (\x -> s{T.category = x}) (f (T.category s))
{-# INLINE category #-}
-customFieldsPD :: Lens' PackageDescription [(String,String)]
-customFieldsPD f s = fmap (\x -> s { T.customFieldsPD = x }) (f (T.customFieldsPD s))
+customFieldsPD :: Lens' PackageDescription [(String, String)]
+customFieldsPD f s = fmap (\x -> s{T.customFieldsPD = x}) (f (T.customFieldsPD s))
{-# INLINE customFieldsPD #-}
specVersion :: Lens' PackageDescription CabalSpecVersion
-specVersion f s = fmap (\x -> s { T.specVersion = x }) (f (T.specVersion s))
+specVersion f s = fmap (\x -> s{T.specVersion = x}) (f (T.specVersion s))
{-# INLINE specVersion #-}
buildTypeRaw :: Lens' PackageDescription (Maybe BuildType)
-buildTypeRaw f s = fmap (\x -> s { T.buildTypeRaw = x }) (f (T.buildTypeRaw s))
+buildTypeRaw f s = fmap (\x -> s{T.buildTypeRaw = x}) (f (T.buildTypeRaw s))
{-# INLINE buildTypeRaw #-}
setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo)
-setupBuildInfo f s = fmap (\x -> s { T.setupBuildInfo = x }) (f (T.setupBuildInfo s))
+setupBuildInfo f s = fmap (\x -> s{T.setupBuildInfo = x}) (f (T.setupBuildInfo s))
{-# INLINE setupBuildInfo #-}
library :: Lens' PackageDescription (Maybe Library)
-library f s = fmap (\x -> s { T.library = x }) (f (T.library s))
+library f s = fmap (\x -> s{T.library = x}) (f (T.library s))
{-# INLINE library #-}
subLibraries :: Lens' PackageDescription [Library]
-subLibraries f s = fmap (\x -> s { T.subLibraries = x }) (f (T.subLibraries s))
+subLibraries f s = fmap (\x -> s{T.subLibraries = x}) (f (T.subLibraries s))
{-# INLINE subLibraries #-}
executables :: Lens' PackageDescription [Executable]
-executables f s = fmap (\x -> s { T.executables = x }) (f (T.executables s))
+executables f s = fmap (\x -> s{T.executables = x}) (f (T.executables s))
{-# INLINE executables #-}
foreignLibs :: Lens' PackageDescription [ForeignLib]
-foreignLibs f s = fmap (\x -> s { T.foreignLibs = x }) (f (T.foreignLibs s))
+foreignLibs f s = fmap (\x -> s{T.foreignLibs = x}) (f (T.foreignLibs s))
{-# INLINE foreignLibs #-}
testSuites :: Lens' PackageDescription [TestSuite]
-testSuites f s = fmap (\x -> s { T.testSuites = x }) (f (T.testSuites s))
+testSuites f s = fmap (\x -> s{T.testSuites = x}) (f (T.testSuites s))
{-# INLINE testSuites #-}
benchmarks :: Lens' PackageDescription [Benchmark]
-benchmarks f s = fmap (\x -> s { T.benchmarks = x }) (f (T.benchmarks s))
+benchmarks f s = fmap (\x -> s{T.benchmarks = x}) (f (T.benchmarks s))
{-# INLINE benchmarks #-}
dataFiles :: Lens' PackageDescription [FilePath]
-dataFiles f s = fmap (\x -> s { T.dataFiles = x }) (f (T.dataFiles s))
+dataFiles f s = fmap (\x -> s{T.dataFiles = x}) (f (T.dataFiles s))
{-# INLINE dataFiles #-}
dataDir :: Lens' PackageDescription FilePath
-dataDir f s = fmap (\x -> s { T.dataDir = x }) (f (T.dataDir s))
+dataDir f s = fmap (\x -> s{T.dataDir = x}) (f (T.dataDir s))
{-# INLINE dataDir #-}
extraSrcFiles :: Lens' PackageDescription [String]
-extraSrcFiles f s = fmap (\x -> s { T.extraSrcFiles = x }) (f (T.extraSrcFiles s))
+extraSrcFiles f s = fmap (\x -> s{T.extraSrcFiles = x}) (f (T.extraSrcFiles s))
{-# INLINE extraSrcFiles #-}
extraTmpFiles :: Lens' PackageDescription [String]
-extraTmpFiles f s = fmap (\x -> s { T.extraTmpFiles = x }) (f (T.extraTmpFiles s))
+extraTmpFiles f s = fmap (\x -> s{T.extraTmpFiles = x}) (f (T.extraTmpFiles s))
{-# INLINE extraTmpFiles #-}
extraDocFiles :: Lens' PackageDescription [String]
-extraDocFiles f s = fmap (\x -> s { T.extraDocFiles = x }) (f (T.extraDocFiles s))
+extraDocFiles f s = fmap (\x -> s{T.extraDocFiles = x}) (f (T.extraDocFiles s))
{-# INLINE extraDocFiles #-}
-- | @since 3.0.0.0
allLibraries :: Traversal' PackageDescription Library
allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd)
where
- mk l ls = pd { T.library = l, T.subLibraries = ls }
+ mk l ls = pd{T.library = l, T.subLibraries = ls}
-- | @since 2.4
componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName]
componentModules cname = case cname of
- CLibName name ->
- componentModules' name allLibraries libName explicitLibModules
- CFLibName name ->
- componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules
- CExeName name ->
- componentModules' name (executables . traverse) exeName exeModules
- CTestName name ->
- componentModules' name (testSuites . traverse) testName testModules
- CBenchName name ->
- componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules
+ CLibName name ->
+ componentModules' name allLibraries libName explicitLibModules
+ CFLibName name ->
+ componentModules' name (foreignLibs . traverse) foreignLibName foreignLibModules
+ CExeName name ->
+ componentModules' name (executables . traverse) exeName exeModules
+ CTestName name ->
+ componentModules' name (testSuites . traverse) testName testModules
+ CBenchName name ->
+ componentModules' name (benchmarks . traverse) benchmarkName benchmarkModules
where
componentModules'
- :: (Eq name, Monoid r)
- => name
- -> Traversal' PackageDescription a
- -> Lens' a name
- -> (a -> [ModuleName])
- -> Getting r PackageDescription [ModuleName]
+ :: (Eq name, Monoid r)
+ => name
+ -> Traversal' PackageDescription a
+ -> Lens' a name
+ -> (a -> [ModuleName])
+ -> Getting r PackageDescription [ModuleName]
componentModules' name pdL nameL modules =
- pdL
- . filtered ((== name) . view nameL)
- . getting modules
+ pdL
+ . filtered ((== name) . view nameL)
+ . getting modules
filtered :: (a -> Bool) -> Traversal' a a
filtered p f s = if p s then f s else pure s
@@ -195,27 +196,28 @@ componentModules cname = case cname of
-- | @since 2.4
componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo
componentBuildInfo cname = case cname of
- CLibName name ->
- componentBuildInfo' name allLibraries libName libBuildInfo
- CFLibName name ->
- componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo
- CExeName name ->
- componentBuildInfo' name (executables . traverse) exeName exeBuildInfo
- CTestName name ->
- componentBuildInfo' name (testSuites . traverse) testName testBuildInfo
- CBenchName name ->
- componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo
+ CLibName name ->
+ componentBuildInfo' name allLibraries libName libBuildInfo
+ CFLibName name ->
+ componentBuildInfo' name (foreignLibs . traverse) foreignLibName foreignLibBuildInfo
+ CExeName name ->
+ componentBuildInfo' name (executables . traverse) exeName exeBuildInfo
+ CTestName name ->
+ componentBuildInfo' name (testSuites . traverse) testName testBuildInfo
+ CBenchName name ->
+ componentBuildInfo' name (benchmarks . traverse) benchmarkName benchmarkBuildInfo
where
- componentBuildInfo' :: Eq name
- => name
- -> Traversal' PackageDescription a
- -> Lens' a name
- -> Traversal' a BuildInfo
- -> Traversal' PackageDescription BuildInfo
+ componentBuildInfo'
+ :: Eq name
+ => name
+ -> Traversal' PackageDescription a
+ -> Lens' a name
+ -> Traversal' a BuildInfo
+ -> Traversal' PackageDescription BuildInfo
componentBuildInfo' name pdL nameL biL =
- pdL
- . filtered ((== name) . view nameL)
- . biL
+ pdL
+ . filtered ((== name) . view nameL)
+ . biL
filtered :: (a -> Bool) -> Traversal' a a
filtered p f s = if p s then f s else pure s
diff --git a/Cabal-syntax/src/Distribution/Types/PackageId.hs b/Cabal-syntax/src/Distribution/Types/PackageId.hs
index 5740153f1a93648b63afc697a824f95ef98928c8..b5c4764ad22627186fcce72336e7ab116529f59a 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageId.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageId.hs
@@ -1,32 +1,34 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.PackageId
- ( PackageIdentifier(..)
+ ( PackageIdentifier (..)
, PackageId
) where
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Parsec (Parsec (..), simpleParsec)
+import Distribution.Parsec (Parsec (..), simpleParsec)
import Distribution.Pretty
import Distribution.Types.PackageName
-import Distribution.Version (Version, nullVersion)
+import Distribution.Version (Version, nullVersion)
-import qualified Data.List.NonEmpty as NE
+import qualified Data.List.NonEmpty as NE
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- | Type alias so we can use the shorter name PackageId.
type PackageId = PackageIdentifier
-- | The name and version of a package.
-data PackageIdentifier
- = PackageIdentifier {
- pkgName :: PackageName, -- ^The name of this package, eg. foo
- pkgVersion :: Version -- ^the version of this package, eg 1.2
- }
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data PackageIdentifier = PackageIdentifier
+ { pkgName :: PackageName
+ -- ^ The name of this package, eg. foo
+ , pkgVersion :: Version
+ -- ^ the version of this package, eg 1.2
+ }
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary PackageIdentifier
instance Structured PackageIdentifier
@@ -34,7 +36,7 @@ instance Structured PackageIdentifier
instance Pretty PackageIdentifier where
pretty (PackageIdentifier n v)
| v == nullVersion = pretty n -- if no version, don't show version.
- | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
+ | otherwise = pretty n <<>> Disp.char '-' <<>> pretty v
-- |
--
@@ -57,18 +59,17 @@ instance Pretty PackageIdentifier where
--
-- >>> simpleParsec "1.2.3" :: Maybe PackageIdentifier
-- Nothing
---
instance Parsec PackageIdentifier where
parsec = do
- xs' <- P.sepByNonEmpty component (P.char '-')
- (v, xs) <- case simpleParsec (NE.last xs') of
- Nothing -> return (nullVersion, toList xs') -- all components are version
- Just v -> return (v, NE.init xs')
- if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs
- then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v
+ xs' <- P.sepByNonEmpty component (P.char '-')
+ (v, xs) <- case simpleParsec (NE.last xs') of
+ Nothing -> return (nullVersion, toList xs') -- all components are version
+ Just v -> return (v, NE.init xs')
+ if not (null xs) && all (\c -> all (/= '.') c && not (all isDigit c)) xs
+ then return $ PackageIdentifier (mkPackageName (intercalate "-" xs)) v
else fail "all digits or a dot in a portion of package name"
where
- component = P.munch1 (\c -> isAlphaNum c || c == '.')
+ component = P.munch1 (\c -> isAlphaNum c || c == '.')
instance NFData PackageIdentifier where
- rnf (PackageIdentifier name version) = rnf name `seq` rnf version
+ rnf (PackageIdentifier name version) = rnf name `seq` rnf version
diff --git a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs
index d2a669a89afa770a9d69eae014fa44658dc50b11..08305234fbd7777e30476b80e44e75aac69dba83 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs
@@ -1,22 +1,22 @@
-module Distribution.Types.PackageId.Lens (
- PackageIdentifier,
- module Distribution.Types.PackageId.Lens,
- ) where
+module Distribution.Types.PackageId.Lens
+ ( PackageIdentifier
+ , module Distribution.Types.PackageId.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Types.PackageId (PackageIdentifier)
+import Distribution.Types.PackageId (PackageIdentifier)
import Distribution.Types.PackageName (PackageName)
-import Distribution.Version (Version)
+import Distribution.Version (Version)
import qualified Distribution.Types.PackageId as T
pkgName :: Lens' PackageIdentifier PackageName
-pkgName f s = fmap (\x -> s { T.pkgName = x }) (f (T.pkgName s))
+pkgName f s = fmap (\x -> s{T.pkgName = x}) (f (T.pkgName s))
{-# INLINE pkgName #-}
pkgVersion :: Lens' PackageIdentifier Version
-pkgVersion f s = fmap (\x -> s { T.pkgVersion = x }) (f (T.pkgVersion s))
+pkgVersion f s = fmap (\x -> s{T.pkgVersion = x}) (f (T.pkgVersion s))
{-# INLINE pkgVersion #-}
diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs
index b9afa5aee94b64757b6deafc2ac7925fbd455c6e..4cf9d1aeb59fae49f1da05fa4567c3edb67320de 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageName.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs
@@ -1,19 +1,22 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Distribution.Types.PackageName
( PackageName
- , unPackageName, mkPackageName
- , unPackageNameST, mkPackageNameST
+ , unPackageName
+ , mkPackageName
+ , unPackageNameST
+ , mkPackageNameST
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
+import Prelude ()
-import qualified Text.PrettyPrint as Disp
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
+import qualified Text.PrettyPrint as Disp
-- | A package name.
--
@@ -24,7 +27,7 @@ import Distribution.Parsec
--
-- @since 2.0.0.2
newtype PackageName = PackageName ShortText
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-- | Convert 'PackageName' to 'String'
unPackageName :: PackageName -> String
@@ -70,4 +73,4 @@ instance Parsec PackageName where
parsec = mkPackageName <$> parsecUnqualComponentName
instance NFData PackageName where
- rnf (PackageName pkg) = rnf pkg
+ rnf (PackageName pkg) = rnf pkg
diff --git a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs
index dc35ad45f6f6dcc1cc7de66d73d0c2c5e7b2494b..9c328378d07cac1368c418c55a530ef47f3c09c1 100644
--- a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs
+++ b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.PackageVersionConstraint (
- PackageVersionConstraint(..),
- thisPackageVersionConstraint,
- simplifyPackageVersionConstraint,
-) where
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Types.PackageVersionConstraint
+ ( PackageVersionConstraint (..)
+ , thisPackageVersionConstraint
+ , simplifyPackageVersionConstraint
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -15,7 +16,7 @@ import Distribution.Types.PackageId
import Distribution.Types.PackageName
import Distribution.Types.Version
import Distribution.Types.VersionRange.Internal
-import Distribution.Version (simplifyVersionRange)
+import Distribution.Version (simplifyVersionRange)
import qualified Distribution.Compat.CharParsing as P
@@ -25,7 +26,7 @@ import qualified Distribution.Compat.CharParsing as P
-- There are a few places in the codebase where 'Dependency' was used where
-- 'PackageVersionConstraint' is not used instead (#5570).
data PackageVersionConstraint = PackageVersionConstraint PackageName VersionRange
- deriving (Generic, Read, Show, Eq, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Typeable, Data)
instance Binary PackageVersionConstraint
instance Structured PackageVersionConstraint
@@ -38,7 +39,7 @@ instance Pretty PackageVersionConstraint where
-- pretty (PackageVersionConstraint name (ThisVersion ver)) =
-- pretty (PackageIdentifier name ver)
pretty (PackageVersionConstraint name ver) =
- pretty name <+> pretty ver
+ pretty name <+> pretty ver
-- |
--
@@ -50,25 +51,23 @@ instance Pretty PackageVersionConstraint where
--
-- >>> simpleParsec "foo-2.0" :: Maybe PackageVersionConstraint
-- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0])))
---
instance Parsec PackageVersionConstraint where
parsec = do
- PackageIdentifier name ver <- parsec
- if ver == nullVersion
+ PackageIdentifier name ver <- parsec
+ if ver == nullVersion
then do
- P.spaces
- vr <- parsec <|> return anyVersion
- P.spaces
- return (PackageVersionConstraint name vr)
- else
- pure (PackageVersionConstraint name (thisVersion ver))
+ P.spaces
+ vr <- parsec <|> return anyVersion
+ P.spaces
+ return (PackageVersionConstraint name vr)
+ else pure (PackageVersionConstraint name (thisVersion ver))
-- | @since 3.4.0.0
thisPackageVersionConstraint :: PackageIdentifier -> PackageVersionConstraint
thisPackageVersionConstraint (PackageIdentifier pn vr) =
- PackageVersionConstraint pn (thisVersion vr)
+ PackageVersionConstraint pn (thisVersion vr)
-- | @since 3.4.0.0
simplifyPackageVersionConstraint :: PackageVersionConstraint -> PackageVersionConstraint
simplifyPackageVersionConstraint (PackageVersionConstraint pn vr) =
- PackageVersionConstraint pn (simplifyVersionRange vr)
+ PackageVersionConstraint pn (simplifyVersionRange vr)
diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs
index 737c71ee5b819b90b571c06c77da3a507efa8cff..695d3a3a184d1c6a25016f109360808a243ee1b3 100644
--- a/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs
+++ b/Cabal-syntax/src/Distribution/Types/PkgconfigDependency.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.PkgconfigDependency
- ( PkgconfigDependency(..)
+ ( PkgconfigDependency (..)
) where
import Distribution.Compat.Prelude
@@ -18,22 +19,23 @@ import qualified Distribution.Compat.CharParsing as P
-- | Describes a dependency on a pkg-config library
--
-- @since 2.0.0.2
-data PkgconfigDependency = PkgconfigDependency
- PkgconfigName
- PkgconfigVersionRange
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+data PkgconfigDependency
+ = PkgconfigDependency
+ PkgconfigName
+ PkgconfigVersionRange
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary PkgconfigDependency
instance Structured PkgconfigDependency
instance NFData PkgconfigDependency where rnf = genericRnf
instance Pretty PkgconfigDependency where
- pretty (PkgconfigDependency name PcAnyVersion) = pretty name
- pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver
+ pretty (PkgconfigDependency name PcAnyVersion) = pretty name
+ pretty (PkgconfigDependency name ver) = pretty name <+> pretty ver
instance Parsec PkgconfigDependency where
- parsec = do
- name <- parsec
- P.spaces
- verRange <- parsec <|> pure anyPkgconfigVersion
- pure $ PkgconfigDependency name verRange
+ parsec = do
+ name <- parsec
+ P.spaces
+ verRange <- parsec <|> pure anyPkgconfigVersion
+ pure $ PkgconfigDependency name verRange
diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs
index 61176687e8139faeabb8c24a9f627ed8217457cb..c3a93dd27c1a8f6d2ebf8b64c67ef7c14c0f9d87 100644
--- a/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs
+++ b/Cabal-syntax/src/Distribution/Types/PkgconfigName.hs
@@ -1,16 +1,19 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Distribution.Types.PkgconfigName
- ( PkgconfigName, unPkgconfigName, mkPkgconfigName
+ ( PkgconfigName
+ , unPkgconfigName
+ , mkPkgconfigName
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
+import Prelude ()
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
@@ -21,7 +24,7 @@ import qualified Text.PrettyPrint as Disp
--
-- @since 2.0.0.2
newtype PkgconfigName = PkgconfigName ShortText
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
+ deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
-- | Convert 'PkgconfigName' to 'String'
--
@@ -44,7 +47,7 @@ mkPkgconfigName = PkgconfigName . toShortText
--
-- @since 2.0.0.2
instance IsString PkgconfigName where
- fromString = mkPkgconfigName
+ fromString = mkPkgconfigName
instance Binary PkgconfigName
instance Structured PkgconfigName
@@ -56,13 +59,14 @@ instance Pretty PkgconfigName where
pretty = Disp.text . unPkgconfigName
instance Parsec PkgconfigName where
- parsec = mkPkgconfigName <$> P.munch1 isNameChar where
- -- https://gitlab.haskell.org/ghc/ghc/issues/17752
- isNameChar '-' = True
- isNameChar '_' = True
- isNameChar '.' = True
- isNameChar '+' = True
- isNameChar c = isAlphaNum c
+ parsec = mkPkgconfigName <$> P.munch1 isNameChar
+ where
+ -- https://gitlab.haskell.org/ghc/ghc/issues/17752
+ isNameChar '-' = True
+ isNameChar '_' = True
+ isNameChar '.' = True
+ isNameChar '+' = True
+ isNameChar c = isAlphaNum c
instance NFData PkgconfigName where
- rnf (PkgconfigName pkg) = rnf pkg
+ rnf (PkgconfigName pkg) = rnf pkg
diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs
index 8779f328a665015fd41732ed6c30a8f390b4bac6..dc328c44ddaa7743dcf366e177ce37ab6e787a73 100644
--- a/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs
+++ b/Cabal-syntax/src/Distribution/Types/PkgconfigVersion.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
+
-- @since 3.0
-module Distribution.Types.PkgconfigVersion (
- PkgconfigVersion (..),
- rpmvercmp,
- ) where
+module Distribution.Types.PkgconfigVersion
+ ( PkgconfigVersion (..)
+ , rpmvercmp
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -13,10 +14,10 @@ import Distribution.Parsec
import Distribution.Pretty
import Distribution.Utils.Generic (isAsciiAlphaNum)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
-- | @pkg-config@ versions.
--
@@ -28,17 +29,17 @@ newtype PkgconfigVersion = PkgconfigVersion BS.ByteString
deriving (Generic, Read, Show, Typeable, Data)
instance Eq PkgconfigVersion where
- PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ
+ PkgconfigVersion a == PkgconfigVersion b = rpmvercmp a b == EQ
instance Ord PkgconfigVersion where
- PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b
+ PkgconfigVersion a `compare` PkgconfigVersion b = rpmvercmp a b
instance Binary PkgconfigVersion
instance Structured PkgconfigVersion
instance NFData PkgconfigVersion where rnf = genericRnf
instance Pretty PkgconfigVersion where
- pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs)
+ pretty (PkgconfigVersion bs) = PP.text (BS8.unpack bs)
-- |
--
@@ -47,10 +48,10 @@ instance Pretty PkgconfigVersion where
--
-- >>> simpleParsec "0.3.5+ds" :: Maybe PkgconfigVersion
-- Nothing
---
instance Parsec PkgconfigVersion where
- parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate where
- predicate c = isAsciiAlphaNum c || c == '.' || c == '-'
+ parsec = PkgconfigVersion . BS8.pack <$> P.munch1 predicate
+ where
+ predicate c = isAsciiAlphaNum c || c == '.' || c == '-'
-------------------------------------------------------------------------------
-- rpmvercmp - pure Haskell implementation
@@ -66,36 +67,36 @@ rpmvercmp a b = go0 (BS.unpack a) (BS.unpack b)
-- if there is _any_ trailing "garbage", it seems to affect result
-- https://github.com/haskell/cabal/issues/6805
go0 [] [] = EQ
- go0 [] _ = LT
- go0 _ [] = GT
+ go0 [] _ = LT
+ go0 _ [] = GT
go0 xs ys = go1 (dropNonAlnum8 xs) (dropNonAlnum8 ys)
go1 :: [Word8] -> [Word8] -> Ordering
go1 [] [] = EQ
- go1 [] _ = LT
- go1 _ [] = GT
- go1 xs@(x:_) ys
+ go1 [] _ = LT
+ go1 _ [] = GT
+ go1 xs@(x : _) ys
| isDigit8 x =
let (xs1, xs2) = span isDigit8 xs
(ys1, ys2) = span isDigit8 ys
- -- numeric segments are always newer than alpha segments
- in if null ys1
- then GT
- else compareInt xs1 ys1 <> go0 xs2 ys2
-
+ in -- numeric segments are always newer than alpha segments
+ if null ys1
+ then GT
+ else compareInt xs1 ys1 <> go0 xs2 ys2
-- isAlpha
| otherwise =
let (xs1, xs2) = span isAlpha8 xs
(ys1, ys2) = span isAlpha8 ys
- in if null ys1
- then LT
- else compareStr xs1 ys1 <> go0 xs2 ys2
+ in if null ys1
+ then LT
+ else compareStr xs1 ys1 <> go0 xs2 ys2
-- compare as numbers
compareInt :: [Word8] -> [Word8] -> Ordering
compareInt xs ys =
- -- whichever number has more digits wins
- compare (length xs') (length ys') <>
+ -- whichever number has more digits wins
+ compare (length xs') (length ys')
+ <>
-- equal length: use per character compare, "strcmp"
compare xs' ys'
where
@@ -115,4 +116,3 @@ isDigit8 w = 0x30 <= w && w <= 0x39
isAlpha8 :: Word8 -> Bool
isAlpha8 w = (0x41 <= w && w <= 0x5A) || (0x61 <= w && w <= 0x7A)
-
diff --git a/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs b/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs
index d39499b447588b8b31f3d6e0bd6f6328b289ddd1..fe74f70c7bef39632240a7b626ee145623e35beb 100644
--- a/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs
+++ b/Cabal-syntax/src/Distribution/Types/PkgconfigVersionRange.hs
@@ -1,14 +1,16 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.PkgconfigVersionRange (
- PkgconfigVersionRange (..),
- anyPkgconfigVersion,
- isAnyPkgconfigVersion,
- withinPkgconfigVersionRange,
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Types.PkgconfigVersionRange
+ ( PkgconfigVersionRange (..)
+ , anyPkgconfigVersion
+ , isAnyPkgconfigVersion
+ , withinPkgconfigVersionRange
+
-- * Internal
- versionToPkgconfigVersion,
- versionRangeToPkgconfigVersionRange,
- ) where
+ , versionToPkgconfigVersion
+ , versionRangeToPkgconfigVersionRange
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -21,19 +23,19 @@ import Distribution.Types.Version
import Distribution.Types.VersionInterval
import Distribution.Types.VersionRange
-import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Char8 as BS8
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
-- | @since 3.0
data PkgconfigVersionRange
= PcAnyVersion
- | PcThisVersion PkgconfigVersion -- = version
- | PcLaterVersion PkgconfigVersion -- > version (NB. not >=)
- | PcEarlierVersion PkgconfigVersion -- < version
- | PcOrLaterVersion PkgconfigVersion -- >= version
- | PcOrEarlierVersion PkgconfigVersion -- =< version
- | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange
+ | PcThisVersion PkgconfigVersion -- = version
+ | PcLaterVersion PkgconfigVersion -- > version (NB. not >=)
+ | PcEarlierVersion PkgconfigVersion -- < version
+ | PcOrLaterVersion PkgconfigVersion -- >= version
+ | PcOrEarlierVersion PkgconfigVersion -- =< version
+ | PcUnionVersionRanges PkgconfigVersionRange PkgconfigVersionRange
| PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
@@ -42,62 +44,63 @@ instance Structured PkgconfigVersionRange
instance NFData PkgconfigVersionRange where rnf = genericRnf
instance Pretty PkgconfigVersionRange where
- pretty = pp 0 where
- pp :: Int -> PkgconfigVersionRange -> PP.Doc
- pp _ PcAnyVersion = PP.text "-any"
- pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v
- pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v
- pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v
- pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v
- pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v
-
- pp d (PcUnionVersionRanges v u) = parens (d >= 1) $
- pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u
- pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $
- pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u
-
- parens True = PP.parens
- parens False = id
+ pretty = pp 0
+ where
+ pp :: Int -> PkgconfigVersionRange -> PP.Doc
+ pp _ PcAnyVersion = PP.text "-any"
+ pp _ (PcThisVersion v) = PP.text "==" <<>> pretty v
+ pp _ (PcLaterVersion v) = PP.text ">" <<>> pretty v
+ pp _ (PcEarlierVersion v) = PP.text "<" <<>> pretty v
+ pp _ (PcOrLaterVersion v) = PP.text ">=" <<>> pretty v
+ pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v
+ pp d (PcUnionVersionRanges v u) =
+ parens (d >= 1) $
+ pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u
+ pp d (PcIntersectVersionRanges v u) =
+ parens (d >= 2) $
+ pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u
+
+ parens True = PP.parens
+ parens False = id
instance Parsec PkgconfigVersionRange where
- -- note: the wildcard is used in some places, e.g
- -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal
- --
- -- however, in the presence of alphanumerics etc. lax version parser,
- -- wildcard is ill-specified
-
- parsec = do
- csv <- askCabalSpecVersion
- if csv >= CabalSpecV3_0
- then pkgconfigParser
- else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv
+ -- note: the wildcard is used in some places, e.g
+ -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal
+ --
+ -- however, in the presence of alphanumerics etc. lax version parser,
+ -- wildcard is ill-specified
+
+ parsec = do
+ csv <- askCabalSpecVersion
+ if csv >= CabalSpecV3_0
+ then pkgconfigParser
+ else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv
-- "modern" parser of @pkg-config@ package versions.
pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange
-pkgconfigParser = P.spaces >> expr where
+pkgconfigParser = P.spaces >> expr
+ where
-- every parser here eats trailing space
expr = do
- ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces)
- return $ foldr1 PcUnionVersionRanges ts
+ ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces)
+ return $ foldr1 PcUnionVersionRanges ts
term = do
- fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces)
- return $ foldr1 PcIntersectVersionRanges fs
+ fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces)
+ return $ foldr1 PcIntersectVersionRanges fs
factor = parens expr <|> prim
prim = do
- op <- P.munch1 isOpChar P.<?> "operator"
- case op of
- "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces)
-
- "==" -> afterOp PcThisVersion
- ">" -> afterOp PcLaterVersion
- "<" -> afterOp PcEarlierVersion
- ">=" -> afterOp PcOrLaterVersion
- "<=" -> afterOp PcOrEarlierVersion
-
- _ -> P.unexpected $ "Unknown version operator " ++ show op
+ op <- P.munch1 isOpChar P.<?> "operator"
+ case op of
+ "-" -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces)
+ "==" -> afterOp PcThisVersion
+ ">" -> afterOp PcLaterVersion
+ "<" -> afterOp PcEarlierVersion
+ ">=" -> afterOp PcOrLaterVersion
+ "<=" -> afterOp PcOrEarlierVersion
+ _ -> P.unexpected $ "Unknown version operator " ++ show op
-- https://gitlab.haskell.org/ghc/ghc/issues/17752
isOpChar '<' = True
@@ -105,15 +108,16 @@ pkgconfigParser = P.spaces >> expr where
isOpChar '>' = True
isOpChar '^' = True
isOpChar '-' = True
- isOpChar _ = False
+ isOpChar _ = False
afterOp f = do
- P.spaces
- v <- parsec
- P.spaces
- return (f v)
+ P.spaces
+ v <- parsec
+ P.spaces
+ return (f v)
- parens = P.between
+ parens =
+ P.between
((P.char '(' P.<?> "opening paren") >> P.spaces)
(P.char ')' >> P.spaces)
@@ -125,14 +129,15 @@ isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool
isAnyPkgconfigVersion = (== PcAnyVersion)
withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool
-withinPkgconfigVersionRange v = go where
- go PcAnyVersion = True
- go (PcThisVersion u) = v == u
- go (PcLaterVersion u) = v > u
- go (PcEarlierVersion u) = v < u
- go (PcOrLaterVersion u) = v >= u
- go (PcOrEarlierVersion u) = v <= u
- go (PcUnionVersionRanges a b) = go a || go b
+withinPkgconfigVersionRange v = go
+ where
+ go PcAnyVersion = True
+ go (PcThisVersion u) = v == u
+ go (PcLaterVersion u) = v > u
+ go (PcEarlierVersion u) = v < u
+ go (PcOrLaterVersion u) = v >= u
+ go (PcOrEarlierVersion u) = v <= u
+ go (PcUnionVersionRanges a b) = go a || go b
go (PcIntersectVersionRanges a b) = go a && go b
-------------------------------------------------------------------------------
@@ -144,14 +149,14 @@ versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow
versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange
versionRangeToPkgconfigVersionRange vr
- | isAnyVersion vr
- = PcAnyVersion
- | otherwise
- = case asVersionIntervals vr of
- [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0"))
- (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is
+ | isAnyVersion vr =
+ PcAnyVersion
+ | otherwise =
+ case asVersionIntervals vr of
+ [] -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0"))
+ (i : is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is
where
- conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b
+ conv (VersionInterval (LowerBound v b) NoUpperBound) = convL v b
conv (VersionInterval (LowerBound v b) (UpperBound u c)) = PcIntersectVersionRanges (convL v b) (convU u c)
convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v)
diff --git a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs
index fe4f716169de5da2d8f1c0475a359322349bdc5c..18a01523a9e77cb4fe95117835eb19c316deb73d 100644
--- a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs
+++ b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo.hs
@@ -1,12 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.SetupBuildInfo (
- SetupBuildInfo(..)
-) where
+module Distribution.Types.SetupBuildInfo
+ ( SetupBuildInfo (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.Dependency
@@ -18,24 +18,25 @@ import Distribution.Types.Dependency
-- options authors can specify to just Haskell package dependencies.
data SetupBuildInfo = SetupBuildInfo
- { setupDepends :: [Dependency]
- , defaultSetupDepends :: Bool
- -- ^ Is this a default 'custom-setup' section added by the cabal-install
- -- code (as opposed to user-provided)? This field is only used
- -- internally, and doesn't correspond to anything in the .cabal
- -- file. See #3199.
- }
- deriving (Generic, Show, Eq, Ord, Read, Typeable, Data)
+ { setupDepends :: [Dependency]
+ , defaultSetupDepends :: Bool
+ -- ^ Is this a default 'custom-setup' section added by the cabal-install
+ -- code (as opposed to user-provided)? This field is only used
+ -- internally, and doesn't correspond to anything in the .cabal
+ -- file. See #3199.
+ }
+ deriving (Generic, Show, Eq, Ord, Read, Typeable, Data)
instance Binary SetupBuildInfo
instance Structured SetupBuildInfo
instance NFData SetupBuildInfo where rnf = genericRnf
instance Monoid SetupBuildInfo where
- mempty = SetupBuildInfo [] False
- mappend = (<>)
+ mempty = SetupBuildInfo [] False
+ mappend = (<>)
instance Semigroup SetupBuildInfo where
- a <> b = SetupBuildInfo
- (setupDepends a <> setupDepends b)
- (defaultSetupDepends a || defaultSetupDepends b)
+ a <> b =
+ SetupBuildInfo
+ (setupDepends a <> setupDepends b)
+ (defaultSetupDepends a || defaultSetupDepends b)
diff --git a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs
index d10ca2e9f4dfeb019f87fcbb59df42d88cee27b2..93bd28ae819d9b07842192c529aabf3dd657622d 100644
--- a/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/SetupBuildInfo/Lens.hs
@@ -1,21 +1,21 @@
-module Distribution.Types.SetupBuildInfo.Lens (
- SetupBuildInfo,
- module Distribution.Types.SetupBuildInfo.Lens,
- ) where
+module Distribution.Types.SetupBuildInfo.Lens
+ ( SetupBuildInfo
+ , module Distribution.Types.SetupBuildInfo.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Types.Dependency (Dependency)
+import Distribution.Types.Dependency (Dependency)
import Distribution.Types.SetupBuildInfo (SetupBuildInfo)
import qualified Distribution.Types.SetupBuildInfo as T
setupDepends :: Lens' SetupBuildInfo [Dependency]
-setupDepends f s = fmap (\x -> s { T.setupDepends = x }) (f (T.setupDepends s))
+setupDepends f s = fmap (\x -> s{T.setupDepends = x}) (f (T.setupDepends s))
{-# INLINE setupDepends #-}
defaultSetupDepends :: Lens' SetupBuildInfo Bool
-defaultSetupDepends f s = fmap (\x -> s { T.defaultSetupDepends = x }) (f (T.defaultSetupDepends s))
+defaultSetupDepends f s = fmap (\x -> s{T.defaultSetupDepends = x}) (f (T.defaultSetupDepends s))
{-# INLINE defaultSetupDepends #-}
diff --git a/Cabal-syntax/src/Distribution/Types/SourceRepo.hs b/Cabal-syntax/src/Distribution/Types/SourceRepo.hs
index 12e0cada2b95f8e1f3fbeb2a1407503f0c6a93c5..16a0fc60e0e0c707ed10a3c6a8889a5a81abc8c3 100644
--- a/Cabal-syntax/src/Distribution/Types/SourceRepo.hs
+++ b/Cabal-syntax/src/Distribution/Types/SourceRepo.hs
@@ -1,31 +1,33 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.SourceRepo (
- SourceRepo(..),
- RepoKind(..),
- RepoType(..),
- KnownRepoType (..),
- knownRepoTypes,
- emptySourceRepo,
- classifyRepoType,
- classifyRepoKind,
+module Distribution.Types.SourceRepo
+ ( SourceRepo (..)
+ , RepoKind (..)
+ , RepoType (..)
+ , KnownRepoType (..)
+ , knownRepoTypes
+ , emptySourceRepo
+ , classifyRepoType
+ , classifyRepoKind
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Utils.Generic (lowercase)
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
+import qualified Data.Map.Strict as M
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-import qualified Data.Map.Strict as M
-- ------------------------------------------------------------
+
-- * Source repos
+
-- ------------------------------------------------------------
-- | Information about the source revision control system for a package.
@@ -43,57 +45,50 @@ import qualified Data.Map.Strict as M
-- The required information is the 'RepoType' which tells us if it's using
-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are
-- interpreted according to the repo type.
---
-data SourceRepo = SourceRepo {
- -- | The kind of repo. This field is required.
- repoKind :: RepoKind,
-
- -- | The type of the source repository system for this repo, eg 'Darcs' or
+data SourceRepo = SourceRepo
+ { repoKind :: RepoKind
+ -- ^ The kind of repo. This field is required.
+ , repoType :: Maybe RepoType
+ -- ^ The type of the source repository system for this repo, eg 'Darcs' or
-- 'Git'. This field is required.
- repoType :: Maybe RepoType,
-
- -- | The location of the repository. For most 'RepoType's this is a URL.
+ , repoLocation :: Maybe String
+ -- ^ The location of the repository. For most 'RepoType's this is a URL.
-- This field is required.
- repoLocation :: Maybe String,
-
- -- | 'CVS' can put multiple \"modules\" on one server and requires a
+ , repoModule :: Maybe String
+ -- ^ 'CVS' can put multiple \"modules\" on one server and requires a
-- module name in addition to the location to identify a particular repo.
-- Logically this is part of the location but unfortunately has to be
-- specified separately. This field is required for the 'CVS' 'RepoType' and
-- should not be given otherwise.
- repoModule :: Maybe String,
-
- -- | The name or identifier of the branch, if any. Many source control
+ , repoBranch :: Maybe String
+ -- ^ The name or identifier of the branch, if any. Many source control
-- systems have the notion of multiple branches in a repo that exist in the
-- same location. For example 'Git' and 'CVS' use this while systems like
-- 'Darcs' use different locations for different branches. This field is
-- optional but should be used if necessary to identify the sources,
-- especially for the 'RepoThis' repo kind.
- repoBranch :: Maybe String,
-
- -- | The tag identify a particular state of the repository. This should be
+ , repoTag :: Maybe String
+ -- ^ The tag identify a particular state of the repository. This should be
-- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.
- --
- repoTag :: Maybe String,
-
- -- | Some repositories contain multiple projects in different subdirectories
+ , repoSubdir :: Maybe FilePath
+ -- ^ Some repositories contain multiple projects in different subdirectories
-- This field specifies the subdirectory where this packages sources can be
-- found, eg the subdirectory containing the @.cabal@ file. It is interpreted
-- relative to the root of the repository. This field is optional. If not
-- given the default is \".\" ie no subdirectory.
- repoSubdir :: Maybe FilePath
-}
+ }
deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
emptySourceRepo :: RepoKind -> SourceRepo
-emptySourceRepo kind = SourceRepo
- { repoKind = kind
- , repoType = Nothing
+emptySourceRepo kind =
+ SourceRepo
+ { repoKind = kind
+ , repoType = Nothing
, repoLocation = Nothing
- , repoModule = Nothing
- , repoBranch = Nothing
- , repoTag = Nothing
- , repoSubdir = Nothing
+ , repoModule = Nothing
+ , repoBranch = Nothing
+ , repoTag = Nothing
+ , repoSubdir = Nothing
}
instance Binary SourceRepo
@@ -101,18 +96,15 @@ instance Structured SourceRepo
instance NFData SourceRepo where rnf = genericRnf
-- | What this repo info is for, what it represents.
---
-data RepoKind =
- -- | The repository for the \"head\" or development version of the project.
+data RepoKind
+ = -- | The repository for the \"head\" or development version of the project.
-- This repo is where we should track the latest development activity or
-- the usual repo people should get to contribute patches.
RepoHead
-
- -- | The repository containing the sources for this exact package version
+ | -- | The repository containing the sources for this exact package version
-- or release. For this kind of repo a tag should be given to give enough
-- information to re-create the exact sources.
- | RepoThis
-
+ RepoThis
| RepoKindUnknown String
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
@@ -123,10 +115,17 @@ instance NFData RepoKind where rnf = genericRnf
-- | An enumeration of common source control systems. The fields used in the
-- 'SourceRepo' depend on the type of repo. The tools and methods used to
-- obtain and track the repo depend on the repo type.
---
-data KnownRepoType = Darcs | Git | SVN | CVS
- | Mercurial | GnuArch | Bazaar | Monotone
- | Pijul -- ^ @since 3.4.0.0
+data KnownRepoType
+ = Darcs
+ | Git
+ | SVN
+ | CVS
+ | Mercurial
+ | GnuArch
+ | Bazaar
+ | Monotone
+ | -- | @since 3.4.0.0
+ Pijul
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded)
instance Binary KnownRepoType
@@ -144,8 +143,9 @@ instance Parsec KnownRepoType where
instance Pretty KnownRepoType where
pretty = Disp.text . lowercase . show
-data RepoType = KnownRepoType KnownRepoType
- | OtherRepoType String
+data RepoType
+ = KnownRepoType KnownRepoType
+ | OtherRepoType String
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
instance Binary RepoType
@@ -156,14 +156,14 @@ knownRepoTypes :: [KnownRepoType]
knownRepoTypes = [minBound .. maxBound]
repoTypeAliases :: KnownRepoType -> [String]
-repoTypeAliases Bazaar = ["bzr"]
+repoTypeAliases Bazaar = ["bzr"]
repoTypeAliases Mercurial = ["hg"]
-repoTypeAliases GnuArch = ["arch"]
-repoTypeAliases _ = []
+repoTypeAliases GnuArch = ["arch"]
+repoTypeAliases _ = []
instance Pretty RepoKind where
- pretty RepoHead = Disp.text "head"
- pretty RepoThis = Disp.text "this"
+ pretty RepoHead = Disp.text "head"
+ pretty RepoThis = Disp.text "this"
pretty (RepoKindUnknown other) = Disp.text other
instance Parsec RepoKind where
@@ -173,7 +173,7 @@ classifyRepoKind :: String -> RepoKind
classifyRepoKind name = case lowercase name of
"head" -> RepoHead
"this" -> RepoThis
- _ -> RepoKindUnknown name
+ _ -> RepoKindUnknown name
instance Parsec RepoType where
parsec = classifyRepoType <$> P.munch1 isIdent
@@ -193,8 +193,8 @@ knownRepoTypeMap :: Map String KnownRepoType
knownRepoTypeMap =
M.fromList
[ (name, repoType')
- | repoType' <- knownRepoTypes
- , name <- prettyShow repoType' : repoTypeAliases repoType'
+ | repoType' <- knownRepoTypes
+ , name <- prettyShow repoType' : repoTypeAliases repoType'
]
isIdent :: Char -> Bool
diff --git a/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs b/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs
index 5f2fd8be873df90a43f817016a0898aa5c92a6d0..171fc6f3e97f4b1894b041183b6c118603423c95 100644
--- a/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/SourceRepo/Lens.hs
@@ -1,39 +1,39 @@
-module Distribution.Types.SourceRepo.Lens (
- T.SourceRepo,
- module Distribution.Types.SourceRepo.Lens,
- ) where
+module Distribution.Types.SourceRepo.Lens
+ ( T.SourceRepo
+ , module Distribution.Types.SourceRepo.Lens
+ ) where
-import Prelude()
-import Distribution.Compat.Prelude
import Distribution.Compat.Lens
+import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.SourceRepo (SourceRepo, RepoKind, RepoType)
+import Distribution.Types.SourceRepo (RepoKind, RepoType, SourceRepo)
import qualified Distribution.Types.SourceRepo as T
repoKind :: Lens' SourceRepo RepoKind
-repoKind f s = fmap (\x -> s { T.repoKind = x }) (f (T.repoKind s))
+repoKind f s = fmap (\x -> s{T.repoKind = x}) (f (T.repoKind s))
{-# INLINE repoKind #-}
repoType :: Lens' SourceRepo (Maybe RepoType)
-repoType f s = fmap (\x -> s { T.repoType = x }) (f (T.repoType s))
+repoType f s = fmap (\x -> s{T.repoType = x}) (f (T.repoType s))
{-# INLINE repoType #-}
repoLocation :: Lens' SourceRepo (Maybe String)
-repoLocation f s = fmap (\x -> s { T.repoLocation = x }) (f (T.repoLocation s))
+repoLocation f s = fmap (\x -> s{T.repoLocation = x}) (f (T.repoLocation s))
{-# INLINE repoLocation #-}
repoModule :: Lens' SourceRepo (Maybe String)
-repoModule f s = fmap (\x -> s { T.repoModule = x }) (f (T.repoModule s))
+repoModule f s = fmap (\x -> s{T.repoModule = x}) (f (T.repoModule s))
{-# INLINE repoModule #-}
repoBranch :: Lens' SourceRepo (Maybe String)
-repoBranch f s = fmap (\x -> s { T.repoBranch = x }) (f (T.repoBranch s))
+repoBranch f s = fmap (\x -> s{T.repoBranch = x}) (f (T.repoBranch s))
{-# INLINE repoBranch #-}
repoTag :: Lens' SourceRepo (Maybe String)
-repoTag f s = fmap (\x -> s { T.repoTag = x }) (f (T.repoTag s))
+repoTag f s = fmap (\x -> s{T.repoTag = x}) (f (T.repoTag s))
{-# INLINE repoTag #-}
repoSubdir :: Lens' SourceRepo (Maybe FilePath)
-repoSubdir f s = fmap (\x -> s { T.repoSubdir = x }) (f (T.repoSubdir s))
+repoSubdir f s = fmap (\x -> s{T.repoSubdir = x}) (f (T.repoSubdir s))
{-# INLINE repoSubdir #-}
diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs
index 9cdacbadba14e12b2856605fdd8a31ac41d7f792..5e72965b815b12172209b74d5726d37213f7d47f 100644
--- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs
+++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs
@@ -1,20 +1,20 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.TestSuite (
- TestSuite(..),
- emptyTestSuite,
- testType,
- testModules,
- testModulesAutogen
-) where
+module Distribution.Types.TestSuite
+ ( TestSuite (..)
+ , emptyTestSuite
+ , testType
+ , testModules
+ , testModulesAutogen
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.BuildInfo
-import Distribution.Types.TestType
import Distribution.Types.TestSuiteInterface
+import Distribution.Types.TestType
import Distribution.Types.UnqualComponentName
import Distribution.ModuleName
@@ -22,17 +22,16 @@ import Distribution.ModuleName
import qualified Distribution.Types.BuildInfo.Lens as L
-- | A \"test-suite\" stanza in a cabal file.
---
-data TestSuite = TestSuite {
- testName :: UnqualComponentName,
- testInterface :: TestSuiteInterface,
- testBuildInfo :: BuildInfo,
- testCodeGenerators :: [String]
- }
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data TestSuite = TestSuite
+ { testName :: UnqualComponentName
+ , testInterface :: TestSuiteInterface
+ , testBuildInfo :: BuildInfo
+ , testCodeGenerators :: [String]
+ }
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance L.HasBuildInfo TestSuite where
- buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l)
+ buildInfo f l = (\x -> l{testBuildInfo = x}) <$> f (testBuildInfo l)
instance Binary TestSuite
instance Structured TestSuite
@@ -40,45 +39,55 @@ instance Structured TestSuite
instance NFData TestSuite where rnf = genericRnf
instance Monoid TestSuite where
- mempty = TestSuite {
- testName = mempty,
- testInterface = mempty,
- testBuildInfo = mempty,
- testCodeGenerators = mempty
- }
- mappend = (<>)
+ mempty =
+ TestSuite
+ { testName = mempty
+ , testInterface = mempty
+ , testBuildInfo = mempty
+ , testCodeGenerators = mempty
+ }
+ mappend = (<>)
instance Semigroup TestSuite where
- a <> b = TestSuite {
- testName = combine' testName,
- testInterface = combine testInterface,
- testBuildInfo = combine testBuildInfo,
- testCodeGenerators = combine testCodeGenerators
- }
- where combine field = field a `mappend` field b
- combine' field = case ( unUnqualComponentName $ field a
- , unUnqualComponentName $ field b) of
- ("", _) -> field b
- (_, "") -> field a
- (x, y) -> error $ "Ambiguous values for test field: '"
- ++ x ++ "' and '" ++ y ++ "'"
+ a <> b =
+ TestSuite
+ { testName = combine' testName
+ , testInterface = combine testInterface
+ , testBuildInfo = combine testBuildInfo
+ , testCodeGenerators = combine testCodeGenerators
+ }
+ where
+ combine field = field a `mappend` field b
+ combine' field = case ( unUnqualComponentName $ field a
+ , unUnqualComponentName $ field b
+ ) of
+ ("", _) -> field b
+ (_, "") -> field a
+ (x, y) ->
+ error $
+ "Ambiguous values for test field: '"
+ ++ x
+ ++ "' and '"
+ ++ y
+ ++ "'"
emptyTestSuite :: TestSuite
emptyTestSuite = mempty
-
testType :: TestSuite -> TestType
testType test = case testInterface test of
- TestSuiteExeV10 ver _ -> TestTypeExe ver
- TestSuiteLibV09 ver _ -> TestTypeLib ver
+ TestSuiteExeV10 ver _ -> TestTypeExe ver
+ TestSuiteLibV09 ver _ -> TestTypeLib ver
TestSuiteUnsupported testtype -> testtype
-- | Get all the module names from a test suite.
testModules :: TestSuite -> [ModuleName]
-testModules test = (case testInterface test of
- TestSuiteLibV09 _ m -> [m]
- _ -> [])
- ++ otherModules (testBuildInfo test)
+testModules test =
+ ( case testInterface test of
+ TestSuiteLibV09 _ m -> [m]
+ _ -> []
+ )
+ ++ otherModules (testBuildInfo test)
-- | Get all the auto generated module names from a test suite.
-- This are a subset of 'testModules'.
diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs b/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs
index 3f7135f37e7e834e65661d4f8467e940ef5b5d89..d44862eed480a2ed1f45a64b8be262cac5b96ae0 100644
--- a/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs
+++ b/Cabal-syntax/src/Distribution/Types/TestSuite/Lens.hs
@@ -1,27 +1,27 @@
-module Distribution.Types.TestSuite.Lens (
- TestSuite,
- module Distribution.Types.TestSuite.Lens,
- ) where
+module Distribution.Types.TestSuite.Lens
+ ( TestSuite
+ , module Distribution.Types.TestSuite.Lens
+ ) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
-import Distribution.Types.BuildInfo (BuildInfo)
-import Distribution.Types.TestSuite (TestSuite)
-import Distribution.Types.TestSuiteInterface (TestSuiteInterface)
+import Distribution.Types.BuildInfo (BuildInfo)
+import Distribution.Types.TestSuite (TestSuite)
+import Distribution.Types.TestSuiteInterface (TestSuiteInterface)
import Distribution.Types.UnqualComponentName (UnqualComponentName)
import qualified Distribution.Types.TestSuite as T
testName :: Lens' TestSuite UnqualComponentName
-testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s))
+testName f s = fmap (\x -> s{T.testName = x}) (f (T.testName s))
{-# INLINE testName #-}
testInterface :: Lens' TestSuite TestSuiteInterface
-testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s))
+testInterface f s = fmap (\x -> s{T.testInterface = x}) (f (T.testInterface s))
{-# INLINE testInterface #-}
testBuildInfo :: Lens' TestSuite BuildInfo
-testBuildInfo f s = fmap (\x -> s { T.testBuildInfo = x }) (f (T.testBuildInfo s))
+testBuildInfo f s = fmap (\x -> s{T.testBuildInfo = x}) (f (T.testBuildInfo s))
{-# INLINE testBuildInfo #-}
diff --git a/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs b/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs
index 7bbf2a142652add3422570d55e8ec85de9cadc41..a1a2879a9248c024a9445e8d6e711c8dcd72d9e4 100644
--- a/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs
+++ b/Cabal-syntax/src/Distribution/Types/TestSuiteInterface.hs
@@ -1,41 +1,34 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.TestSuiteInterface (
- TestSuiteInterface(..),
-) where
+module Distribution.Types.TestSuiteInterface
+ ( TestSuiteInterface (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.TestType
import Distribution.ModuleName
+import Distribution.Types.TestType
import Distribution.Version
-- | The test suite interfaces that are currently defined.
--
-- More interfaces may be defined in future, either new revisions or totally
-- new interfaces.
---
-data TestSuiteInterface =
-
- -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form
- -- of an executable. It returns a zero exit code for success, non-zero for
- -- failure. The stdout and stderr channels may be logged. Test tooling may
- -- pass command line arguments and/or connect the stdin channel to the test.
- --
- TestSuiteExeV10 Version FilePath
-
- -- | Test interface \"detailed-0.9\". The test-suite takes the form of a
- -- library containing a designated module that exports \"tests :: [Test]\".
- --
- | TestSuiteLibV09 Version ModuleName
-
- -- | A test suite that does not conform to one of the above interfaces for
- -- the given reason (e.g. unknown test type).
- --
- | TestSuiteUnsupported TestType
- deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
+data TestSuiteInterface
+ = -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form
+ -- of an executable. It returns a zero exit code for success, non-zero for
+ -- failure. The stdout and stderr channels may be logged. Test tooling may
+ -- pass command line arguments and/or connect the stdin channel to the test.
+ TestSuiteExeV10 Version FilePath
+ | -- | Test interface \"detailed-0.9\". The test-suite takes the form of a
+ -- library containing a designated module that exports \"tests :: [Test]\".
+ TestSuiteLibV09 Version ModuleName
+ | -- | A test suite that does not conform to one of the above interfaces for
+ -- the given reason (e.g. unknown test type).
+ TestSuiteUnsupported TestType
+ deriving (Eq, Ord, Generic, Read, Show, Typeable, Data)
instance Binary TestSuiteInterface
instance Structured TestSuiteInterface
@@ -43,9 +36,9 @@ instance Structured TestSuiteInterface
instance NFData TestSuiteInterface where rnf = genericRnf
instance Monoid TestSuiteInterface where
- mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion)
- mappend = (<>)
+ mempty = TestSuiteUnsupported (TestTypeUnknown mempty nullVersion)
+ mappend = (<>)
instance Semigroup TestSuiteInterface where
- a <> (TestSuiteUnsupported _) = a
- _ <> b = b
+ a <> (TestSuiteUnsupported _) = a
+ _ <> b = b
diff --git a/Cabal-syntax/src/Distribution/Types/TestType.hs b/Cabal-syntax/src/Distribution/Types/TestType.hs
index 748d0c2bcd5cd897d95ba1aa40fa063e48f6679f..6ac0866d6f1452bec405d6c31731a308a1c65a23 100644
--- a/Cabal-syntax/src/Distribution/Types/TestType.hs
+++ b/Cabal-syntax/src/Distribution/Types/TestType.hs
@@ -1,13 +1,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Types.TestType (
- TestType(..),
- knownTestTypes,
- testTypeExe,
- testTypeLib,
-) where
+module Distribution.Types.TestType
+ ( TestType (..)
+ , knownTestTypes
+ , testTypeExe
+ , testTypeLib
+ ) where
import Distribution.Compat.Prelude
import Distribution.Version
@@ -15,14 +15,17 @@ import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
-import Text.PrettyPrint (char, text)
+import Text.PrettyPrint (char, text)
-- | The \"test-type\" field in the test suite stanza.
---
-data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\"
- | TestTypeLib Version -- ^ \"type: detailed-x.y\"
- | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"
- deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
+data TestType
+ = -- | \"type: exitcode-stdio-x.y\"
+ TestTypeExe Version
+ | -- | \"type: detailed-x.y\"
+ TestTypeLib Version
+ | -- | Some unknown test type e.g. \"type: foo\"
+ TestTypeUnknown String Version
+ deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary TestType
instance Structured TestType
@@ -30,23 +33,24 @@ instance Structured TestType
instance NFData TestType where rnf = genericRnf
knownTestTypes :: [TestType]
-knownTestTypes = [ testTypeExe
- , testTypeLib
- ]
+knownTestTypes =
+ [ testTypeExe
+ , testTypeLib
+ ]
testTypeExe :: TestType
-testTypeExe = TestTypeExe (mkVersion [1,0])
+testTypeExe = TestTypeExe (mkVersion [1, 0])
testTypeLib :: TestType
-testTypeLib = TestTypeLib (mkVersion [0,9])
+testTypeLib = TestTypeLib (mkVersion [0, 9])
instance Pretty TestType where
- pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver
- pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver
+ pretty (TestTypeExe ver) = text "exitcode-stdio-" <<>> pretty ver
+ pretty (TestTypeLib ver) = text "detailed-" <<>> pretty ver
pretty (TestTypeUnknown name ver) = text name <<>> char '-' <<>> pretty ver
instance Parsec TestType where
parsec = parsecStandard $ \ver name -> case name of
- "exitcode-stdio" -> TestTypeExe ver
- "detailed" -> TestTypeLib ver
- _ -> TestTypeUnknown name ver
+ "exitcode-stdio" -> TestTypeExe ver
+ "detailed" -> TestTypeLib ver
+ _ -> TestTypeUnknown name ver
diff --git a/Cabal-syntax/src/Distribution/Types/UnitId.hs b/Cabal-syntax/src/Distribution/Types/UnitId.hs
index 047a43f27c365bd0e8de24c074da1d36ba50f3d6..36a1d003b2e1fb31b6e01686488f2b2d7bf91e70 100644
--- a/Cabal-syntax/src/Distribution/Types/UnitId.hs
+++ b/Cabal-syntax/src/Distribution/Types/UnitId.hs
@@ -1,10 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Distribution.Types.UnitId
- ( UnitId, unUnitId, mkUnitId
+ ( UnitId
+ , unUnitId
+ , mkUnitId
, DefUnitId
, unsafeMkDefUnitId
, unDefUnitId
@@ -13,13 +15,13 @@ module Distribution.Types.UnitId
, getHSLibraryName
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.ShortText
+import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
import Distribution.Types.ComponentId
import Distribution.Types.PackageId
@@ -61,7 +63,6 @@ import Text.PrettyPrint (text)
-- representation of a UnitId to pass, e.g., as a @-package-id@
-- flag, use the 'display' function, which will work on all
-- versions of Cabal.
---
newtype UnitId = UnitId ShortText
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, NFData)
@@ -70,25 +71,23 @@ instance Structured UnitId
-- | The textual format for 'UnitId' coincides with the format
-- GHC accepts for @-package-id@.
---
instance Pretty UnitId where
- pretty = text . unUnitId
+ pretty = text . unUnitId
-- | The textual format for 'UnitId' coincides with the format
-- GHC accepts for @-package-id@.
---
instance Parsec UnitId where
- parsec = mkUnitId <$> P.munch1 isUnitChar where
- -- https://gitlab.haskell.org/ghc/ghc/issues/17752
- isUnitChar '-' = True
- isUnitChar '_' = True
- isUnitChar '.' = True
- isUnitChar '+' = True
- isUnitChar c = isAlphaNum c
+ parsec = mkUnitId <$> P.munch1 isUnitChar
+ where
+ -- https://gitlab.haskell.org/ghc/ghc/issues/17752
+ isUnitChar '-' = True
+ isUnitChar '_' = True
+ isUnitChar '.' = True
+ isUnitChar '+' = True
+ isUnitChar c = isAlphaNum c
-- | If you need backwards compatibility, consider using 'display'
-- instead, which is supported by all versions of Cabal.
---
unUnitId :: UnitId -> String
unUnitId (UnitId s) = fromShortText s
@@ -99,7 +98,7 @@ mkUnitId = UnitId . toShortText
--
-- @since 2.0.0.2
instance IsString UnitId where
- fromString = mkUnitId
+ fromString = mkUnitId
-- | Create a unit identity with no associated hash directly
-- from a 'ComponentId'.
@@ -118,7 +117,7 @@ getHSLibraryName uid = "HS" ++ prettyShow uid
-- | A 'UnitId' for a definite package. The 'DefUnitId' invariant says
-- that a 'UnitId' identified this way is definite; i.e., it has no
-- unfilled holes.
-newtype DefUnitId = DefUnitId { unDefUnitId :: UnitId }
+newtype DefUnitId = DefUnitId {unDefUnitId :: UnitId}
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data, Binary, NFData, Pretty)
instance Structured DefUnitId
diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs
index 763ec99d5687a930d0f3e01018c2cd7d54ab0b6c..a13fc917633c554f27f109b7b57613d78b56986e 100644
--- a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs
+++ b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs
@@ -1,9 +1,14 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
module Distribution.Types.UnqualComponentName
- ( UnqualComponentName, unUnqualComponentName, unUnqualComponentNameST, mkUnqualComponentName
- , packageNameToUnqualComponentName, unqualComponentNameToPackageName
+ ( UnqualComponentName
+ , unUnqualComponentName
+ , unUnqualComponentNameST
+ , mkUnqualComponentName
+ , packageNameToUnqualComponentName
+ , unqualComponentNameToPackageName
) where
import Distribution.Compat.Prelude
@@ -22,8 +27,17 @@ import Distribution.Types.PackageName
--
-- @since 2.0.0.2
newtype UnqualComponentName = UnqualComponentName ShortText
- deriving (Generic, Read, Show, Eq, Ord, Typeable, Data,
- Semigroup, Monoid) -- TODO: bad enabler of bad monoids
+ deriving
+ ( Generic
+ , Read
+ , Show
+ , Eq
+ , Ord
+ , Typeable
+ , Data
+ , Semigroup
+ , Monoid -- TODO: bad enabler of bad monoids
+ )
-- | Convert 'UnqualComponentName' to 'String'
--
diff --git a/Cabal-syntax/src/Distribution/Types/Version.hs b/Cabal-syntax/src/Distribution/Types/Version.hs
index fae5f889b01aa45d3d4cb1d40e6ecdfe1ea5e3c2..90ad33b1048528a8653dc5907d42dfc55082b3a9 100644
--- a/Cabal-syntax/src/Distribution/Types/Version.hs
+++ b/Cabal-syntax/src/Distribution/Types/Version.hs
@@ -1,31 +1,32 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.Version (
- -- * Package versions
- Version,
- mkVersion,
- mkVersion',
- versionNumbers,
- nullVersion,
- alterVersion,
- version0,
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Types.Version
+ ( -- * Package versions
+ Version
+ , mkVersion
+ , mkVersion'
+ , versionNumbers
+ , nullVersion
+ , alterVersion
+ , version0
-- * Internal
- validVersion,
- versionDigitParser,
- ) where
+ , validVersion
+ , versionDigitParser
+ ) where
-import Data.Bits (shiftL, shiftR, (.&.), (.|.))
+import Data.Bits (shiftL, shiftR, (.&.), (.|.))
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
-import qualified Data.Version as Base
+import qualified Data.Version as Base
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
-import qualified Text.Read as Read
+import qualified Text.PrettyPrint as Disp
+import qualified Text.Read as Read
-- | A 'Version' represents the version of a software entity.
--
@@ -38,68 +39,73 @@ import qualified Text.Read as Read
-- 'Binary' instance using a different (and more compact) encoding.
--
-- @since 2.0.0.2
-data Version = PV0 {-# UNPACK #-} !Word64
- | PV1 !Int [Int]
- -- NOTE: If a version fits into the packed Word64
- -- representation (i.e. at most four version components
- -- which all fall into the [0..0xfffe] range), then PV0
- -- MUST be used. This is essential for the 'Eq' instance
- -- to work.
- deriving (Data,Eq,Generic,Typeable)
+data Version
+ = PV0 {-# UNPACK #-} !Word64
+ | PV1 !Int [Int]
+ -- NOTE: If a version fits into the packed Word64
+ -- representation (i.e. at most four version components
+ -- which all fall into the [0..0xfffe] range), then PV0
+ -- MUST be used. This is essential for the 'Eq' instance
+ -- to work.
+ deriving (Data, Eq, Generic, Typeable)
instance Ord Version where
- compare (PV0 x) (PV0 y) = compare x y
- compare (PV1 x xs) (PV1 y ys) = case compare x y of
- EQ -> compare xs ys
- c -> c
- compare (PV0 w) (PV1 y ys) = case compare x y of
- EQ -> compare [x2,x3,x4] ys
- c -> c
- where
- x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1
- x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1
- x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1
- x4 = fromIntegral (w .&. 0xffff) - 1
- compare (PV1 x xs) (PV0 w) = case compare x y of
- EQ -> compare xs [y2,y3,y4]
- c -> c
- where
- y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1
- y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1
- y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1
- y4 = fromIntegral (w .&. 0xffff) - 1
+ compare (PV0 x) (PV0 y) = compare x y
+ compare (PV1 x xs) (PV1 y ys) = case compare x y of
+ EQ -> compare xs ys
+ c -> c
+ compare (PV0 w) (PV1 y ys) = case compare x y of
+ EQ -> compare [x2, x3, x4] ys
+ c -> c
+ where
+ x = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1
+ x2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1
+ x3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1
+ x4 = fromIntegral (w .&. 0xffff) - 1
+ compare (PV1 x xs) (PV0 w) = case compare x y of
+ EQ -> compare xs [y2, y3, y4]
+ c -> c
+ where
+ y = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1
+ y2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1
+ y3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1
+ y4 = fromIntegral (w .&. 0xffff) - 1
instance Show Version where
- showsPrec d v = showParen (d > 10)
- $ showString "mkVersion "
+ showsPrec d v =
+ showParen (d > 10) $
+ showString "mkVersion "
. showsPrec 11 (versionNumbers v)
instance Read Version where
- readPrec = Read.parens $ do
- Read.Ident "mkVersion" <- Read.lexP
- v <- Read.step Read.readPrec
- return (mkVersion v)
+ readPrec = Read.parens $ do
+ Read.Ident "mkVersion" <- Read.lexP
+ v <- Read.step Read.readPrec
+ return (mkVersion v)
instance Binary Version
instance Structured Version
instance NFData Version where
- rnf (PV0 _) = ()
- rnf (PV1 _ ns) = rnf ns
+ rnf (PV0 _) = ()
+ rnf (PV1 _ ns) = rnf ns
instance Pretty Version where
- pretty ver
- = Disp.hcat (Disp.punctuate (Disp.char '.')
- (map Disp.int $ versionNumbers ver))
+ pretty ver =
+ Disp.hcat
+ ( Disp.punctuate
+ (Disp.char '.')
+ (map Disp.int $ versionNumbers ver)
+ )
instance Parsec Version where
- parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags
- where
- tags = do
- ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)
- case ts of
- [] -> pure ()
- (_ : _) -> parsecWarning PWTVersionTag "version with tags"
+ parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags
+ where
+ tags = do
+ ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)
+ case ts of
+ [] -> pure ()
+ (_ : _) -> parsecWarning PWTVersionTag "version with tags"
-- | An integral without leading zeroes.
--
@@ -108,15 +114,15 @@ versionDigitParser :: CabalParsing m => m Int
versionDigitParser = (some d >>= toNumber) P.<?> "version digit (integral without leading zeroes)"
where
toNumber :: CabalParsing m => [Int] -> m Int
- toNumber [0] = return 0
- toNumber (0:_) = P.unexpected "Version digit with leading zero"
+ toNumber [0] = return 0
+ toNumber (0 : _) = P.unexpected "Version digit with leading zero"
toNumber xs
- -- 10^9 = 1000000000
- -- 2^30 = 1073741824
- --
- -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'.
- | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part"
- | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs
+ -- 10^9 = 1000000000
+ -- 2^30 = 1073741824
+ --
+ -- GHC Int is at least 32 bits, so 2^31-1 is the 'maxBound'.
+ | length xs > 9 = P.unexpected "At most 9 numbers are allowed per version number part"
+ | otherwise = return $ foldl' (\a b -> a * 10 + b) 0 xs
d :: P.CharParsing m => m Int
d = f <$> P.satisfyRange '0' '9'
@@ -134,42 +140,56 @@ versionDigitParser = (some d >>= toNumber) P.<?> "version digit (integral withou
mkVersion :: [Int] -> Version
-- TODO: add validity check; disallow 'mkVersion []' (we have
-- 'nullVersion' for that)
-mkVersion [] = nullVersion
-mkVersion (v1:[])
- | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1)
- | otherwise = PV1 v1 []
+mkVersion [] = nullVersion
+mkVersion (v1 : [])
+ | inWord16VerRep1 v1 = PV0 (mkWord64VerRep1 v1)
+ | otherwise = PV1 v1 []
where
- inWord16VerRep1 x1 = inWord16 (x1 .|. (x1+1))
- mkWord64VerRep1 y1 = mkWord64VerRep (y1+1) 0 0 0
-
-mkVersion (v1:vs@(v2:[]))
- | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2)
- | otherwise = PV1 v1 vs
+ inWord16VerRep1 x1 = inWord16 (x1 .|. (x1 + 1))
+ mkWord64VerRep1 y1 = mkWord64VerRep (y1 + 1) 0 0 0
+mkVersion (v1 : vs@(v2 : []))
+ | inWord16VerRep2 v1 v2 = PV0 (mkWord64VerRep2 v1 v2)
+ | otherwise = PV1 v1 vs
where
- inWord16VerRep2 x1 x2 = inWord16 (x1 .|. (x1+1)
- .|. x2 .|. (x2+1))
- mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1+1) (y2+1) 0 0
-
-mkVersion (v1:vs@(v2:v3:[]))
- | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3)
- | otherwise = PV1 v1 vs
+ inWord16VerRep2 x1 x2 =
+ inWord16
+ ( x1
+ .|. (x1 + 1)
+ .|. x2
+ .|. (x2 + 1)
+ )
+ mkWord64VerRep2 y1 y2 = mkWord64VerRep (y1 + 1) (y2 + 1) 0 0
+mkVersion (v1 : vs@(v2 : v3 : []))
+ | inWord16VerRep3 v1 v2 v3 = PV0 (mkWord64VerRep3 v1 v2 v3)
+ | otherwise = PV1 v1 vs
where
- inWord16VerRep3 x1 x2 x3 = inWord16 (x1 .|. (x1+1)
- .|. x2 .|. (x2+1)
- .|. x3 .|. (x3+1))
- mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1+1) (y2+1) (y3+1) 0
-
-mkVersion (v1:vs@(v2:v3:v4:[]))
+ inWord16VerRep3 x1 x2 x3 =
+ inWord16
+ ( x1
+ .|. (x1 + 1)
+ .|. x2
+ .|. (x2 + 1)
+ .|. x3
+ .|. (x3 + 1)
+ )
+ mkWord64VerRep3 y1 y2 y3 = mkWord64VerRep (y1 + 1) (y2 + 1) (y3 + 1) 0
+mkVersion (v1 : vs@(v2 : v3 : v4 : []))
| inWord16VerRep4 v1 v2 v3 v4 = PV0 (mkWord64VerRep4 v1 v2 v3 v4)
- | otherwise = PV1 v1 vs
+ | otherwise = PV1 v1 vs
where
- inWord16VerRep4 x1 x2 x3 x4 = inWord16 (x1 .|. (x1+1)
- .|. x2 .|. (x2+1)
- .|. x3 .|. (x3+1)
- .|. x4 .|. (x4+1))
- mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1+1) (y2+1) (y3+1) (y4+1)
-
-mkVersion (v1:vs) = PV1 v1 vs
+ inWord16VerRep4 x1 x2 x3 x4 =
+ inWord16
+ ( x1
+ .|. (x1 + 1)
+ .|. x2
+ .|. (x2 + 1)
+ .|. x3
+ .|. (x3 + 1)
+ .|. x4
+ .|. (x4 + 1)
+ )
+ mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1 + 1) (y2 + 1) (y3 + 1) (y4 + 1)
+mkVersion (v1 : vs) = PV1 v1 vs
-- | Version 0. A lower bound of 'Version'.
--
@@ -180,10 +200,10 @@ version0 = mkVersion [0]
{-# INLINE mkWord64VerRep #-}
mkWord64VerRep :: Int -> Int -> Int -> Int -> Word64
mkWord64VerRep v1 v2 v3 v4 =
- (fromIntegral v1 `shiftL` 48)
- .|. (fromIntegral v2 `shiftL` 32)
- .|. (fromIntegral v3 `shiftL` 16)
- .|. fromIntegral v4
+ (fromIntegral v1 `shiftL` 48)
+ .|. (fromIntegral v2 `shiftL` 32)
+ .|. (fromIntegral v3 `shiftL` 16)
+ .|. fromIntegral v4
{-# INLINE inWord16 #-}
inWord16 :: Int -> Bool
@@ -204,20 +224,19 @@ mkVersion' = mkVersion . Base.versionBranch
--
-- @since 2.0.0.2
versionNumbers :: Version -> [Int]
-versionNumbers (PV1 n ns) = n:ns
+versionNumbers (PV1 n ns) = n : ns
versionNumbers (PV0 w)
- | v1 < 0 = []
- | v2 < 0 = [v1]
- | v3 < 0 = [v1,v2]
- | v4 < 0 = [v1,v2,v3]
- | otherwise = [v1,v2,v3,v4]
+ | v1 < 0 = []
+ | v2 < 0 = [v1]
+ | v3 < 0 = [v1, v2]
+ | v4 < 0 = [v1, v2, v3]
+ | otherwise = [v1, v2, v3, v4]
where
v1 = fromIntegral ((w `shiftR` 48) .&. 0xffff) - 1
v2 = fromIntegral ((w `shiftR` 32) .&. 0xffff) - 1
v3 = fromIntegral ((w `shiftR` 16) .&. 0xffff) - 1
v4 = fromIntegral (w .&. 0xffff) - 1
-
-- | Constant representing the special /null/ 'Version'
--
-- The 'nullVersion' compares (via 'Ord') as less than every proper
@@ -239,4 +258,4 @@ alterVersion f = mkVersion . f . versionNumbers
-- internal helper
validVersion :: Version -> Bool
-validVersion v = v /= nullVersion && all (>=0) (versionNumbers v)
+validVersion v = v /= nullVersion && all (>= 0) (versionNumbers v)
diff --git a/Cabal-syntax/src/Distribution/Types/VersionInterval.hs b/Cabal-syntax/src/Distribution/Types/VersionInterval.hs
index cc8c39663490193a40e663aceb2d6137d10da650..e63e8701188619b5fcbd18660d813769a753bcaa 100644
--- a/Cabal-syntax/src/Distribution/Types/VersionInterval.hs
+++ b/Cabal-syntax/src/Distribution/Types/VersionInterval.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | This module implements a view of a 'VersionRange' as a finite
@@ -8,37 +8,36 @@
-- preserve the caret operator @^>=x.y@. This constraint a priori
-- specifies the same interval as @==x.y.*@, but indicates that newer
-- versions could be acceptable (@allow-newer: ^@).
---
-module Distribution.Types.VersionInterval (
- -- * Version intervals
- VersionIntervals,
- unVersionIntervals,
+module Distribution.Types.VersionInterval
+ ( -- * Version intervals
+ VersionIntervals
+ , unVersionIntervals
-- * Conversions
- toVersionIntervals,
- fromVersionIntervals,
+ , toVersionIntervals
+ , fromVersionIntervals
-- ** Normalisation
- normaliseVersionRange2,
+ , normaliseVersionRange2
-- * Relaxation
- relaxLastInterval,
- relaxHeadInterval,
+ , relaxLastInterval
+ , relaxHeadInterval
-- * Version intervals view
- asVersionIntervals,
- VersionInterval (..),
- LowerBound(..),
- UpperBound(..),
- Bound(..),
+ , asVersionIntervals
+ , VersionInterval (..)
+ , LowerBound (..)
+ , UpperBound (..)
+ , Bound (..)
-- * Invariants
- invariantVersionIntervals,
- ) where
+ , invariantVersionIntervals
+ ) where
-import Control.Applicative (liftA2)
-import Control.Exception (assert)
-import Distribution.Compat.Prelude hiding (Applicative(..))
+import Control.Applicative (liftA2)
+import Control.Exception (assert)
+import Distribution.Compat.Prelude hiding (Applicative (..))
import Prelude ()
import Distribution.Types.Version
@@ -64,19 +63,17 @@ import Distribution.Types.VersionRange.Internal
-- or containment. It also makes it easier to identify \'simple\' version
-- predicates for translation into foreign packaging systems that do not
-- support complex version range expressions.
---
newtype VersionIntervals = VersionIntervals [VersionInterval]
deriving (Eq, Show, Typeable)
-- | Inspect the list of version intervals.
---
unVersionIntervals :: VersionIntervals -> [VersionInterval]
unVersionIntervals (VersionIntervals is) = is
-data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show)
-data LowerBound = LowerBound !Version !Bound deriving (Eq, Show)
-data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show)
-data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
+data VersionInterval = VersionInterval !LowerBound !UpperBound deriving (Eq, Show)
+data LowerBound = LowerBound !Version !Bound deriving (Eq, Show)
+data UpperBound = NoUpperBound | UpperBound !Version !Bound deriving (Eq, Show)
+data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show)
zeroLowerBound :: LowerBound
zeroLowerBound = LowerBound version0 InclusiveBound
@@ -89,29 +86,27 @@ isVersion0 = (==) version0
-------------------------------------------------------------------------------
stage1 :: VersionRange -> [VersionInterval]
-stage1 = cataVersionRange alg where
+stage1 = cataVersionRange alg
+ where
-- version range leafs transform into singleton intervals
- alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)]
- alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound]
- alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound]
+ alg (ThisVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound v InclusiveBound)]
+ alg (LaterVersionF v) = [VersionInterval (LowerBound v ExclusiveBound) NoUpperBound]
+ alg (OrLaterVersionF v) = [VersionInterval (LowerBound v InclusiveBound) NoUpperBound]
alg (EarlierVersionF v)
- | isVersion0 v = []
- | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)]
- alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)]
-
- -- ^>= version-range's upper bound should be MajorBound
- alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)]
-
+ | isVersion0 v = []
+ | otherwise = [VersionInterval zeroLowerBound (UpperBound v ExclusiveBound)]
+ alg (OrEarlierVersionF v) = [VersionInterval zeroLowerBound (UpperBound v InclusiveBound)]
+ -- \^>= version-range's upper bound should be MajorBound
+ alg (MajorBoundVersionF v) = [VersionInterval (LowerBound v InclusiveBound) (UpperBound (majorUpperBound v) ExclusiveBound)]
-- union: just merge the version intervals
- alg (UnionVersionRangesF v1 v2) = v1 ++ v2
-
+ alg (UnionVersionRangesF v1 v2) = v1 ++ v2
-- intersection: pairwise intersect. Strip empty intervals. Sort to restore the invariant.
alg (IntersectVersionRangesF v1 v2) = mapMaybe nonEmptyInterval $ liftA2 intersectInterval (stage2and3 v1) (stage2and3 v2)
-- | Check that interval is non-empty
nonEmptyInterval :: VersionInterval -> Maybe VersionInterval
nonEmptyInterval i | nonEmptyVI i = Just i
-nonEmptyInterval _ = Nothing
+nonEmptyInterval _ = Nothing
-------------------------------------------------------------------------------
-- Stage2
@@ -122,7 +117,7 @@ stage2 = sortBy lowerboundCmp
lowerboundCmp :: VersionInterval -> VersionInterval -> Ordering
lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound u ub) _) =
- compare v u `mappend` compareBound vb ub
+ compare v u `mappend` compareBound vb ub
where
compareBound :: Bound -> Bound -> Ordering
compareBound InclusiveBound InclusiveBound = EQ
@@ -136,7 +131,6 @@ lowerboundCmp (VersionInterval (LowerBound v vb) _) (VersionInterval (LowerBound
-- | Post-processing takes a list of ordered version intervals,
-- but possibly overlapping, and creates 'VersionIntervals'.
---
postprocess :: [VersionInterval] -> VersionIntervals
postprocess = checkInvariant . VersionIntervals . stage2and3
@@ -144,15 +138,15 @@ stage2and3 :: [VersionInterval] -> [VersionInterval]
stage2and3 = stage3 . stage2
stage3 :: [VersionInterval] -> [VersionInterval]
-stage3 [] = []
-stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest
+stage3 [] = []
+stage3 (VersionInterval lb ub : rest) = stage3go lb ub rest
stage3go :: LowerBound -> UpperBound -> [VersionInterval] -> [VersionInterval]
-stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound]
-stage3go !lb !ub [] = [VersionInterval lb ub]
-stage3go !lb !ub (VersionInterval lb' ub' : rest')
- | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest'
- | otherwise = stage3go lb (unionUpper ub ub') rest'
+stage3go !lb NoUpperBound _ = [VersionInterval lb NoUpperBound]
+stage3go !lb !ub [] = [VersionInterval lb ub]
+stage3go !lb !ub (VersionInterval lb' ub' : rest')
+ | doesNotTouch ub lb' = VersionInterval lb ub : stage3go lb' ub' rest'
+ | otherwise = stage3go lb (unionUpper ub ub') rest'
-------------------------------------------------------------------------------
-- Intersections
@@ -160,41 +154,41 @@ stage3go !lb !ub (VersionInterval lb' ub' : rest')
intersectInterval :: VersionInterval -> VersionInterval -> VersionInterval
intersectInterval (VersionInterval lv uv) (VersionInterval lu uu) =
- VersionInterval (intersectLower lv lu) (intersectUpper uv uu)
+ VersionInterval (intersectLower lv lu) (intersectUpper uv uu)
intersectLower :: LowerBound -> LowerBound -> LowerBound
intersectLower (LowerBound v vb) (LowerBound u ub) = case compare v u of
- EQ -> LowerBound v (intersectBound vb ub)
- LT -> LowerBound u ub
- GT -> LowerBound v vb
+ EQ -> LowerBound v (intersectBound vb ub)
+ LT -> LowerBound u ub
+ GT -> LowerBound v vb
intersectUpper :: UpperBound -> UpperBound -> UpperBound
-intersectUpper NoUpperBound b = b
-intersectUpper b NoUpperBound = b
+intersectUpper NoUpperBound b = b
+intersectUpper b NoUpperBound = b
intersectUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of
- EQ -> UpperBound v (intersectBound vb ub)
- LT -> UpperBound v vb
- GT -> UpperBound u ub
+ EQ -> UpperBound v (intersectBound vb ub)
+ LT -> UpperBound v vb
+ GT -> UpperBound u ub
intersectBound :: Bound -> Bound -> Bound
intersectBound InclusiveBound InclusiveBound = InclusiveBound
-intersectBound _ _ = ExclusiveBound
+intersectBound _ _ = ExclusiveBound
-------------------------------------------------------------------------------
-- Unions
-------------------------------------------------------------------------------
unionUpper :: UpperBound -> UpperBound -> UpperBound
-unionUpper NoUpperBound _ = NoUpperBound
-unionUpper _ NoUpperBound = NoUpperBound
+unionUpper NoUpperBound _ = NoUpperBound
+unionUpper _ NoUpperBound = NoUpperBound
unionUpper (UpperBound v vb) (UpperBound u ub) = case compare v u of
- EQ -> UpperBound v (unionBound vb ub)
- LT -> UpperBound u ub
- GT -> UpperBound v vb
+ EQ -> UpperBound v (unionBound vb ub)
+ LT -> UpperBound u ub
+ GT -> UpperBound v vb
unionBound :: Bound -> Bound -> Bound
unionBound ExclusiveBound ExclusiveBound = ExclusiveBound
-unionBound _ _ = InclusiveBound
+unionBound _ _ = InclusiveBound
-------------------------------------------------------------------------------
-- VersionRange
@@ -221,7 +215,6 @@ unionBound _ _ = InclusiveBound
-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr
-- > , v == v' = Just v
-- > | otherwise = Nothing
---
asVersionIntervals :: VersionRange -> [VersionInterval]
asVersionIntervals = unVersionIntervals . toVersionIntervals
@@ -235,11 +228,10 @@ asVersionIntervals = unVersionIntervals . toVersionIntervals
-- ---| or ---) but not ---] or ---) or ---]
-- |--- (--- (--- [--- [---
-- @
---
doesNotTouch :: UpperBound -> LowerBound -> Bool
-doesNotTouch NoUpperBound _ = False
+doesNotTouch NoUpperBound _ = False
doesNotTouch (UpperBound u ub) (LowerBound l lb) =
- (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
+ (u < l) || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
-------------------------------------------------------------------------------
-- Invariants
@@ -249,19 +241,18 @@ doesNotTouch (UpperBound u ub) (LowerBound l lb) =
--
-- * all intervals are valid (lower bound is less then upper bound, i.e. non-empty)
-- * intervals doesn't touch each other (distinct)
---
invariantVersionIntervals :: VersionIntervals -> Bool
invariantVersionIntervals (VersionIntervals intervals) =
- all validInterval intervals &&
- all doesNotTouch' adjacentIntervals
+ all validInterval intervals
+ && all doesNotTouch' adjacentIntervals
where
doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
doesNotTouch' (VersionInterval _ u, VersionInterval l' _) = doesNotTouch u l'
adjacentIntervals :: [(VersionInterval, VersionInterval)]
adjacentIntervals = case intervals of
- [] -> []
- (_:tl) -> zip intervals tl
+ [] -> []
+ (_ : tl) -> zip intervals tl
checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant is = assert (invariantVersionIntervals is) is
@@ -271,13 +262,13 @@ validInterval :: VersionInterval -> Bool
validInterval i@(VersionInterval l u) = validLower l && validUpper u && nonEmptyVI i
where
validLower (LowerBound v _) = validVersion v
- validUpper NoUpperBound = True
- validUpper (UpperBound v _) = validVersion v
+ validUpper NoUpperBound = True
+ validUpper (UpperBound v _) = validVersion v
-- Check an interval is non-empty
--
nonEmptyVI :: VersionInterval -> Bool
-nonEmptyVI (VersionInterval _ NoUpperBound) = True
+nonEmptyVI (VersionInterval _ NoUpperBound) = True
nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) =
(l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)
@@ -286,39 +277,35 @@ nonEmptyVI (VersionInterval (LowerBound l lb) (UpperBound u ub)) =
-------------------------------------------------------------------------------
-- | Convert a 'VersionRange' to a sequence of version intervals.
---
toVersionIntervals :: VersionRange -> VersionIntervals
toVersionIntervals = postprocess . stage1
-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
-- representing the version intervals.
---
fromVersionIntervals :: VersionIntervals -> VersionRange
-fromVersionIntervals (VersionIntervals []) = noVersion
-fromVersionIntervals (VersionIntervals (x:xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x:|xs))
+fromVersionIntervals (VersionIntervals []) = noVersion
+fromVersionIntervals (VersionIntervals (x : xs)) = foldr1 unionVersionRanges (fmap intervalToVersionRange (x :| xs))
intervalToVersionRange :: VersionInterval -> VersionRange
intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper' of
- NoUpperBound
- -> lowerBound
-
- UpperBound u ub
- | vb == InclusiveBound
- , ub == InclusiveBound
- , v == u
- -> thisVersion v
-
- UpperBound u ub -> withLowerBound (makeUpperBound u ub)
+ NoUpperBound ->
+ lowerBound
+ UpperBound u ub
+ | vb == InclusiveBound
+ , ub == InclusiveBound
+ , v == u ->
+ thisVersion v
+ UpperBound u ub -> withLowerBound (makeUpperBound u ub)
where
lowerBound :: VersionRange
lowerBound = case vb of
- InclusiveBound -> orLaterVersion v
- ExclusiveBound -> laterVersion v
+ InclusiveBound -> orLaterVersion v
+ ExclusiveBound -> laterVersion v
withLowerBound :: VersionRange -> VersionRange
withLowerBound vr
- | isVersion0 v, vb == InclusiveBound = vr
- | otherwise = intersectVersionRanges lowerBound vr
+ | isVersion0 v, vb == InclusiveBound = vr
+ | otherwise = intersectVersionRanges lowerBound vr
makeUpperBound :: Version -> Bound -> VersionRange
makeUpperBound u InclusiveBound = orEarlierVersion u
@@ -329,7 +316,6 @@ intervalToVersionRange (VersionInterval (LowerBound v vb) upper') = case upper'
-------------------------------------------------------------------------------
-- | Since @Cabal-3.6@ this function.. TODO
---
normaliseVersionRange2 :: VersionRange -> VersionRange
normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals
@@ -340,12 +326,12 @@ normaliseVersionRange2 = fromVersionIntervals . toVersionIntervals
relaxLastInterval :: VersionIntervals -> VersionIntervals
relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)
where
- relaxLastInterval' [] = []
+ relaxLastInterval' [] = []
relaxLastInterval' [VersionInterval l _] = [VersionInterval l NoUpperBound]
- relaxLastInterval' (i:is) = i : relaxLastInterval' is
+ relaxLastInterval' (i : is) = i : relaxLastInterval' is
relaxHeadInterval :: VersionIntervals -> VersionIntervals
relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)
where
- relaxHeadInterval' [] = []
+ relaxHeadInterval' [] = []
relaxHeadInterval' (VersionInterval _ u : is) = VersionInterval zeroLowerBound u : is
diff --git a/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs b/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs
index a24ab771dd790618346d8efb8a2a3ce6f8671061..f5e86d4a429d63d6e7101b2952ebc2679aa6bbe9 100644
--- a/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs
+++ b/Cabal-syntax/src/Distribution/Types/VersionInterval/Legacy.hs
@@ -9,32 +9,31 @@
-- The current module "Distribution.Types.VersionInterval" (refurbished since
-- @Cabal >= 3.6@) makes some effort to preserve the caret operator,
-- but so far does not expose the Boolean algebra structure.
---
-module Distribution.Types.VersionInterval.Legacy (
- -- * Version intervals
- VersionIntervals,
- toVersionIntervals,
- fromVersionIntervals,
- withinIntervals,
- versionIntervals,
- mkVersionIntervals,
- unionVersionIntervals,
- intersectVersionIntervals,
- invertVersionIntervals,
- relaxLastInterval,
- relaxHeadInterval,
+module Distribution.Types.VersionInterval.Legacy
+ ( -- * Version intervals
+ VersionIntervals
+ , toVersionIntervals
+ , fromVersionIntervals
+ , withinIntervals
+ , versionIntervals
+ , mkVersionIntervals
+ , unionVersionIntervals
+ , intersectVersionIntervals
+ , invertVersionIntervals
+ , relaxLastInterval
+ , relaxHeadInterval
-- * Version intervals view
- asVersionIntervals,
- VersionInterval,
- LowerBound(..),
- UpperBound(..),
- Bound(..),
- ) where
+ , asVersionIntervals
+ , VersionInterval
+ , LowerBound (..)
+ , UpperBound (..)
+ , Bound (..)
+ ) where
-import Prelude ()
-import Distribution.Compat.Prelude
import Control.Exception (assert)
+import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.Version
import Distribution.Types.VersionRange.Internal
@@ -72,11 +71,9 @@ import qualified Prelude (foldr1)
-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr
-- > , v == v' = Just v
-- > | otherwise = Nothing
---
asVersionIntervals :: VersionRange -> [VersionInterval]
asVersionIntervals = versionIntervals . toVersionIntervals
-
-------------------------------------------------------------------------------
-- VersionInterval
-------------------------------------------------------------------------------
@@ -98,12 +95,10 @@ asVersionIntervals = versionIntervals . toVersionIntervals
-- or containment. It also makes it easier to identify \'simple\' version
-- predicates for translation into foreign packaging systems that do not
-- support complex version range expressions.
---
newtype VersionIntervals = VersionIntervals [VersionInterval]
deriving (Eq, Show, Typeable)
-- | Inspect the list of version intervals.
---
versionIntervals :: VersionIntervals -> [VersionInterval]
versionIntervals (VersionIntervals is) = is
@@ -115,21 +110,25 @@ versionIntervals (VersionIntervals is) = is
-- 4. \( [lb,ub] \) meaning \( lb ≤ \_ < ub \).
--
-- The upper bound can also be missing, meaning "\( ..,∞) \)".
---
type VersionInterval = (LowerBound, UpperBound)
data LowerBound
- = LowerBound Version !Bound -- ^ Either exclusive @(v,..@ or inclusive @[v,..@.
+ = -- | Either exclusive @(v,..@ or inclusive @[v,..@.
+ LowerBound Version !Bound
deriving (Eq, Show)
data UpperBound
- = NoUpperBound -- ^ @..,∞)@
- | UpperBound Version !Bound -- ^ Either exclusive @..,v)@ or inclusive @..,v]@.
+ = -- | @..,∞)@
+ NoUpperBound
+ | -- | Either exclusive @..,v)@ or inclusive @..,v]@.
+ UpperBound Version !Bound
deriving (Eq, Show)
data Bound
- = ExclusiveBound -- ^ @(v,..@ if used as lower bound, @..,v)@ if used as upper bound.
- | InclusiveBound -- ^ @[v,..@ if used as lower bound, @..,v]@ if used as upper bound.
+ = -- | @(v,..@ if used as lower bound, @..,v)@ if used as upper bound.
+ ExclusiveBound
+ | -- | @[v,..@ if used as lower bound, @..,v]@ if used as upper bound.
+ InclusiveBound
deriving (Eq, Show)
-- | @[0,..@.
@@ -140,7 +139,6 @@ isVersion0 :: Version -> Bool
isVersion0 = (==) version0
-- | @lb1 <= lb2@ holds iff interval @lb1..@ is contained in interval @lb2..@.
---
instance Ord LowerBound where
LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of
LT -> True
@@ -148,9 +146,8 @@ instance Ord LowerBound where
GT -> False
-- | @ub1 <= ub2@ holds iff interval @0..ub1@ is contained in interval @0..ub2@.
---
instance Ord UpperBound where
- _ <= NoUpperBound = True
+ _ <= NoUpperBound = True
NoUpperBound <= UpperBound _ _ = False
UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of
LT -> True
@@ -160,54 +157,49 @@ instance Ord UpperBound where
-- | Check that the sequence is ordered,
-- adjacent intervals are separated (do not overlap),
-- an no interval is empty (which would be a redundant entry).
---
invariant :: VersionIntervals -> Bool
-invariant (VersionIntervals intervals) = all validInterval intervals
- && all doesNotTouch' adjacentIntervals
+invariant (VersionIntervals intervals) =
+ all validInterval intervals
+ && all doesNotTouch' adjacentIntervals
where
doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool
- doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l'
+ doesNotTouch' ((_, u), (l', _)) = doesNotTouch u l'
-- adjacentIntervals = zip intervals (tail intervals)
adjacentIntervals :: [(VersionInterval, VersionInterval)]
adjacentIntervals = case intervals of
- [] -> []
- (_:tl) -> zip intervals tl
+ [] -> []
+ (_ : tl) -> zip intervals tl
-- | The partial identity function, erroring out on illformed 'VersionIntervals'.
---
checkInvariant :: VersionIntervals -> VersionIntervals
checkInvariant is = assert (invariant is) is
-- | Directly construct a 'VersionIntervals' from a list of intervals.
---
mkVersionIntervals :: [VersionInterval] -> VersionIntervals
mkVersionIntervals intervals
- | invariant (VersionIntervals intervals) = VersionIntervals intervals
- | otherwise
- = checkInvariant
+ | invariant (VersionIntervals intervals) = VersionIntervals intervals
+ | otherwise =
+ checkInvariant
. foldl' (flip insertInterval) (VersionIntervals [])
. filter validInterval
$ intervals
-- | Add an interval to the sequence, fusing with existing intervals if necessary.
---
insertInterval :: VersionInterval -> VersionIntervals -> VersionIntervals
insertInterval i is = unionVersionIntervals (VersionIntervals [i]) is
-- | A valid interval is non-empty.
---
validInterval :: (LowerBound, UpperBound) -> Bool
validInterval i@(l, u) = validLower l && validUpper u && nonEmptyVI i
where
validLower (LowerBound v _) = validVersion v
- validUpper NoUpperBound = True
+ validUpper NoUpperBound = True
validUpper (UpperBound v _) = validVersion v
-- | Check that an interval is non-empty.
---
nonEmptyVI :: VersionInterval -> Bool
-nonEmptyVI (_, NoUpperBound ) = True
+nonEmptyVI (_, NoUpperBound) = True
nonEmptyVI (LowerBound l lb, UpperBound u ub) =
(l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound)
@@ -222,8 +214,8 @@ nonEmptyVI (LowerBound l lb, UpperBound u ub) =
doesNotTouch :: UpperBound -> LowerBound -> Bool
doesNotTouch NoUpperBound _ = False
doesNotTouch (UpperBound u ub) (LowerBound l lb) =
- u < l
- || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
+ u < l
+ || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)
-- | Check an upper bound does not intersect a lower bound:
--
@@ -233,12 +225,11 @@ doesNotTouch (UpperBound u ub) (LowerBound l lb) =
-- |--- (--- (--- [--- [---
--
-- @
---
doesNotIntersect :: UpperBound -> LowerBound -> Bool
doesNotIntersect NoUpperBound _ = False
doesNotIntersect (UpperBound u ub) (LowerBound l lb) =
- u < l
- || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))
+ u < l
+ || (u == l && not (ub == InclusiveBound && lb == InclusiveBound))
-- | Test if a version falls within the version intervals.
--
@@ -247,39 +238,39 @@ doesNotIntersect (UpperBound u ub) (LowerBound l lb) =
--
-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr
-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs)
---
withinIntervals :: Version -> VersionIntervals -> Bool
withinIntervals v (VersionIntervals intervals) = any withinInterval intervals
where
- withinInterval (lowerBound, upperBound) = withinLower lowerBound
- && withinUpper upperBound
- withinLower (LowerBound v' ExclusiveBound) = v' < v
+ withinInterval (lowerBound, upperBound) =
+ withinLower lowerBound
+ && withinUpper upperBound
+ withinLower (LowerBound v' ExclusiveBound) = v' < v
withinLower (LowerBound v' InclusiveBound) = v' <= v
- withinUpper NoUpperBound = True
- withinUpper (UpperBound v' ExclusiveBound) = v' > v
+ withinUpper NoUpperBound = True
+ withinUpper (UpperBound v' ExclusiveBound) = v' > v
withinUpper (UpperBound v' InclusiveBound) = v' >= v
-- | Convert a 'VersionRange' to a sequence of version intervals.
---
toVersionIntervals :: VersionRange -> VersionIntervals
-toVersionIntervals = cataVersionRange alg where
+toVersionIntervals = cataVersionRange alg
+ where
-- @== v@
- alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)
+ alg (ThisVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)
-- @> v@
- alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound)
+ alg (LaterVersionF v) = chkIvl (LowerBound v ExclusiveBound, NoUpperBound)
-- @>= v@
- alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound)
+ alg (OrLaterVersionF v) = chkIvl (LowerBound v InclusiveBound, NoUpperBound)
-- @< v@
alg (EarlierVersionF v)
- | isVersion0 v = VersionIntervals []
- | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound)
+ | isVersion0 v = VersionIntervals []
+ | otherwise = chkIvl (minLowerBound, UpperBound v ExclusiveBound)
-- @<= v@
- alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound)
+ alg (OrEarlierVersionF v) = chkIvl (minLowerBound, UpperBound v InclusiveBound)
-- @^>= v@
- alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound)
+ alg (MajorBoundVersionF v) = chkIvl (LowerBound v InclusiveBound, UpperBound (majorUpperBound v) ExclusiveBound)
-- @r || r'@
- alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2
+ alg (UnionVersionRangesF v1 v2) = unionVersionIntervals v1 v2
-- @r && r'@
alg (IntersectVersionRangesF v1 v2) = intersectVersionIntervals v1 v2
@@ -287,55 +278,52 @@ toVersionIntervals = cataVersionRange alg where
-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression
-- representing the version intervals.
---
fromVersionIntervals :: VersionIntervals -> VersionRange
fromVersionIntervals (VersionIntervals []) = noVersion
fromVersionIntervals (VersionIntervals intervals) =
- Prelude.foldr1 unionVersionRanges [ interval l u | (l, u) <- intervals ]
-
+ Prelude.foldr1 unionVersionRanges [interval l u | (l, u) <- intervals]
where
- interval (LowerBound v InclusiveBound)
- (UpperBound v' InclusiveBound) | v == v'
- = thisVersion v
+ interval
+ (LowerBound v InclusiveBound)
+ (UpperBound v' InclusiveBound)
+ | v == v' =
+ thisVersion v
interval l u = lowerBound l `intersectVersionRanges'` upperBound u
lowerBound (LowerBound v InclusiveBound)
- | isVersion0 v = Nothing
- | otherwise = Just (orLaterVersion v)
+ | isVersion0 v = Nothing
+ | otherwise = Just (orLaterVersion v)
lowerBound (LowerBound v ExclusiveBound) = Just (laterVersion v)
- upperBound NoUpperBound = Nothing
+ upperBound NoUpperBound = Nothing
upperBound (UpperBound v InclusiveBound) = Just (orEarlierVersion v)
upperBound (UpperBound v ExclusiveBound) = Just (earlierVersion v)
- intersectVersionRanges' Nothing Nothing = anyVersion
- intersectVersionRanges' (Just vr) Nothing = vr
- intersectVersionRanges' Nothing (Just vr) = vr
+ intersectVersionRanges' Nothing Nothing = anyVersion
+ intersectVersionRanges' (Just vr) Nothing = vr
+ intersectVersionRanges' Nothing (Just vr) = vr
intersectVersionRanges' (Just vr) (Just vr') = intersectVersionRanges vr vr'
-- | Union two interval sequences, fusing intervals where necessary.
-- Computed \( O(n+m) \) time, resulting in sequence of length \( ≤ n+m \).
---
-unionVersionIntervals :: VersionIntervals -> VersionIntervals
- -> VersionIntervals
+unionVersionIntervals
+ :: VersionIntervals
+ -> VersionIntervals
+ -> VersionIntervals
unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
checkInvariant (VersionIntervals (union is0 is'0))
where
- union is [] = is
+ union is [] = is
union [] is' = is'
- union (i:is) (i':is') = case unionInterval i i' of
-
+ union (i : is) (i' : is') = case unionInterval i i' of
-- @i < i'@ and separated: keep @i@.
- Left Nothing -> i : union is (i' :is')
-
+ Left Nothing -> i : union is (i' : is')
-- @i'' = i ∪ i'@ and @i@ ends first: drop @i@, replace @i'@ by @i''@.
- Left (Just i'') -> union is (i'':is')
-
+ Left (Just i'') -> union is (i'' : is')
-- @i' < i@ and separated: keep @i'@.
- Right Nothing -> i' : union (i :is) is'
-
+ Right Nothing -> i' : union (i : is) is'
-- @i'' = i ∪ i'@ and @i'@ ends first: drop @i'@, replace @i@ by @i''@.
- Right (Just i'') -> union (i'':is) is'
+ Right (Just i'') -> union (i'' : is) is'
-- | Given two version intervals @i1@ and @i2@, return one of the following:
--
@@ -346,24 +334,23 @@ unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
--
-- Herein, @i < i'@ means that the whole of the interval @i@ is strictly left of the whole of @i'@,
-- and @ub(i)@ returns the right boundary of interval @i@ which could be inclusive or exclusive.
---
-unionInterval :: VersionInterval -> VersionInterval
- -> Either (Maybe VersionInterval) (Maybe VersionInterval)
-unionInterval (lower , upper ) (lower', upper')
-
+unionInterval
+ :: VersionInterval
+ -> VersionInterval
+ -> Either (Maybe VersionInterval) (Maybe VersionInterval)
+unionInterval (lower, upper) (lower', upper')
-- Non-intersecting intervals with the left interval ending first
| upper `doesNotTouch` lower' = Left Nothing
-
-- Non-intersecting intervals with the right interval first
| upper' `doesNotTouch` lower = Right Nothing
-
-- Complete or partial overlap, with the left interval ending first
- | upper <= upper' = lowerBound `seq`
- Left (Just (lowerBound, upper'))
-
+ | upper <= upper' =
+ lowerBound `seq`
+ Left (Just (lowerBound, upper'))
-- Complete or partial overlap, with the left interval ending first
- | otherwise = lowerBound `seq`
- Right (Just (lowerBound, upper))
+ | otherwise =
+ lowerBound `seq`
+ Right (Just (lowerBound, upper))
where
lowerBound = min lower lower'
@@ -374,27 +361,24 @@ unionInterval (lower , upper ) (lower', upper')
-- (rather than the naive \( O(nm) \).
--
-- The length of \( is \cap is' \) is \( ≤ \min(n,m) \).
---
-intersectVersionIntervals :: VersionIntervals -> VersionIntervals
- -> VersionIntervals
+intersectVersionIntervals
+ :: VersionIntervals
+ -> VersionIntervals
+ -> VersionIntervals
intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
checkInvariant (VersionIntervals (intersect is0 is'0))
where
- intersect _ [] = []
- intersect [] _ = []
- intersect (i:is) (i':is') = case intersectInterval i i' of
-
+ intersect _ [] = []
+ intersect [] _ = []
+ intersect (i : is) (i' : is') = case intersectInterval i i' of
-- @i < i'@: throw out @i@
- Left Nothing -> intersect is (i':is')
-
+ Left Nothing -> intersect is (i' : is')
-- @i'' = i /\ i'@ and @i@ ends first: replace @i@ by @i''@.
- Left (Just i'') -> i'' : intersect is (i':is')
-
+ Left (Just i'') -> i'' : intersect is (i' : is')
-- @i' < i@: throw out @i'@
- Right Nothing -> intersect (i:is) is'
-
+ Right Nothing -> intersect (i : is) is'
-- @i'' = i /\ i'@ and @i'@ ends first: replace @i'@ by @i''@.
- Right (Just i'') -> i'' : intersect (i:is) is'
+ Right (Just i'') -> i'' : intersect (i : is) is'
-- | Given two version intervals @i1@ and @i2@, return one of the following:
--
@@ -405,69 +389,72 @@ intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) =
--
-- Herein, @i < i'@ means that the whole of the interval @i@ is strictly left of the whole of @i'@,
-- and @ub(i)@ returns the right boundary of interval @i@ which could be inclusive or exclusive.
---
-intersectInterval :: VersionInterval -> VersionInterval
- -> Either (Maybe VersionInterval) (Maybe VersionInterval)
-intersectInterval (lower , upper ) (lower', upper')
-
+intersectInterval
+ :: VersionInterval
+ -> VersionInterval
+ -> Either (Maybe VersionInterval) (Maybe VersionInterval)
+intersectInterval (lower, upper) (lower', upper')
-- Non-intersecting intervals with the left interval ending first
| upper `doesNotIntersect` lower' = Left Nothing
-
-- Non-intersecting intervals with the right interval first
| upper' `doesNotIntersect` lower = Right Nothing
-
-- Complete or partial overlap, with the left interval ending first
- | upper <= upper' = lowerBound `seq`
- Left (Just (lowerBound, upper))
-
+ | upper <= upper' =
+ lowerBound `seq`
+ Left (Just (lowerBound, upper))
-- Complete or partial overlap, with the right interval ending first
- | otherwise = lowerBound `seq`
- Right (Just (lowerBound, upper'))
+ | otherwise =
+ lowerBound `seq`
+ Right (Just (lowerBound, upper'))
where
lowerBound = max lower lower'
-- | Compute the complement.
-- \( O(n) \).
-invertVersionIntervals :: VersionIntervals
- -> VersionIntervals
+invertVersionIntervals
+ :: VersionIntervals
+ -> VersionIntervals
invertVersionIntervals (VersionIntervals xs) =
- case xs of
- -- Empty interval set
- [] -> VersionIntervals [(noLowerBound, NoUpperBound)]
- -- Interval with no lower bound
- ((lb, ub) : more) | lb == noLowerBound ->
- VersionIntervals $ invertVersionIntervals' ub more
- -- Interval with a lower bound
- ((lb, ub) : more) ->
- VersionIntervals $ (noLowerBound, invertLowerBound lb)
+ case xs of
+ -- Empty interval set
+ [] -> VersionIntervals [(noLowerBound, NoUpperBound)]
+ -- Interval with no lower bound
+ ((lb, ub) : more)
+ | lb == noLowerBound ->
+ VersionIntervals $ invertVersionIntervals' ub more
+ -- Interval with a lower bound
+ ((lb, ub) : more) ->
+ VersionIntervals $
+ (noLowerBound, invertLowerBound lb)
: invertVersionIntervals' ub more
- where
- -- Invert subsequent version intervals given the upper bound of
- -- the intervals already inverted.
- invertVersionIntervals' :: UpperBound
- -> [(LowerBound, UpperBound)]
- -> [(LowerBound, UpperBound)]
- invertVersionIntervals' NoUpperBound [] = []
- invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]
- invertVersionIntervals' ub0 [(lb, NoUpperBound)] =
- [(invertUpperBound ub0, invertLowerBound lb)]
- invertVersionIntervals' ub0 ((lb, ub1) : more) =
- (invertUpperBound ub0, invertLowerBound lb)
- : invertVersionIntervals' ub1 more
-
- invertLowerBound :: LowerBound -> UpperBound
- invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)
-
- invertUpperBound :: UpperBound -> LowerBound
- invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)
- invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"
-
- invertBound :: Bound -> Bound
- invertBound ExclusiveBound = InclusiveBound
- invertBound InclusiveBound = ExclusiveBound
-
- noLowerBound :: LowerBound
- noLowerBound = LowerBound (mkVersion [0]) InclusiveBound
+ where
+ -- Invert subsequent version intervals given the upper bound of
+ -- the intervals already inverted.
+ invertVersionIntervals'
+ :: UpperBound
+ -> [(LowerBound, UpperBound)]
+ -> [(LowerBound, UpperBound)]
+ invertVersionIntervals' NoUpperBound [] = []
+ invertVersionIntervals' ub0 [] = [(invertUpperBound ub0, NoUpperBound)]
+ invertVersionIntervals' ub0 [(lb, NoUpperBound)] =
+ [(invertUpperBound ub0, invertLowerBound lb)]
+ invertVersionIntervals' ub0 ((lb, ub1) : more) =
+ (invertUpperBound ub0, invertLowerBound lb)
+ : invertVersionIntervals' ub1 more
+
+ invertLowerBound :: LowerBound -> UpperBound
+ invertLowerBound (LowerBound v b) = UpperBound v (invertBound b)
+
+ invertUpperBound :: UpperBound -> LowerBound
+ invertUpperBound (UpperBound v b) = LowerBound v (invertBound b)
+ invertUpperBound NoUpperBound = error "NoUpperBound: unexpected"
+
+ invertBound :: Bound -> Bound
+ invertBound ExclusiveBound = InclusiveBound
+ invertBound InclusiveBound = ExclusiveBound
+
+ noLowerBound :: LowerBound
+ noLowerBound = LowerBound (mkVersion [0]) InclusiveBound
-- | Remove the last upper bound, enlarging the range.
-- But empty ranges stay empty.
@@ -475,9 +462,9 @@ invertVersionIntervals (VersionIntervals xs) =
relaxLastInterval :: VersionIntervals -> VersionIntervals
relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' xs)
where
- relaxLastInterval' [] = []
- relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]
- relaxLastInterval' (i:is) = i : relaxLastInterval' is
+ relaxLastInterval' [] = []
+ relaxLastInterval' [(l, _)] = [(l, NoUpperBound)]
+ relaxLastInterval' (i : is) = i : relaxLastInterval' is
-- | Remove the first lower bound (i.e, make it \( [0 \).
-- Empty ranges stay empty.
@@ -485,5 +472,5 @@ relaxLastInterval (VersionIntervals xs) = VersionIntervals (relaxLastInterval' x
relaxHeadInterval :: VersionIntervals -> VersionIntervals
relaxHeadInterval (VersionIntervals xs) = VersionIntervals (relaxHeadInterval' xs)
where
- relaxHeadInterval' [] = []
- relaxHeadInterval' ((_,u):is) = (minLowerBound,u) : is
+ relaxHeadInterval' [] = []
+ relaxHeadInterval' ((_, u) : is) = (minLowerBound, u) : is
diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange.hs b/Cabal-syntax/src/Distribution/Types/VersionRange.hs
index 1f10688407d2bb194b8d2532bff8071bbca5632e..c470b93c0d2e4c9b4ef9e31a2f9d4b699c08b829 100644
--- a/Cabal-syntax/src/Distribution/Types/VersionRange.hs
+++ b/Cabal-syntax/src/Distribution/Types/VersionRange.hs
@@ -1,42 +1,48 @@
-module Distribution.Types.VersionRange (
- -- * Version ranges
- VersionRange,
+module Distribution.Types.VersionRange
+ ( -- * Version ranges
+ VersionRange
-- ** Constructing
- anyVersion, noVersion,
- thisVersion, notThisVersion,
- laterVersion, earlierVersion,
- orLaterVersion, orEarlierVersion,
- unionVersionRanges, intersectVersionRanges,
- withinVersion,
- majorBoundVersion,
+ , anyVersion
+ , noVersion
+ , thisVersion
+ , notThisVersion
+ , laterVersion
+ , earlierVersion
+ , orLaterVersion
+ , orEarlierVersion
+ , unionVersionRanges
+ , intersectVersionRanges
+ , withinVersion
+ , majorBoundVersion
-- ** Inspection
- --
- -- See "Distribution.Version" for more utilities.
- withinRange,
- foldVersionRange,
- normaliseVersionRange,
- stripParensVersionRange,
- hasUpperBound,
- hasLowerBound,
+
+ --
+ -- See "Distribution.Version" for more utilities.
+ , withinRange
+ , foldVersionRange
+ , normaliseVersionRange
+ , stripParensVersionRange
+ , hasUpperBound
+ , hasLowerBound
-- ** Cata & ana
- VersionRangeF (..),
- cataVersionRange,
- anaVersionRange,
- hyloVersionRange,
- projectVersionRange,
- embedVersionRange,
+ , VersionRangeF (..)
+ , cataVersionRange
+ , anaVersionRange
+ , hyloVersionRange
+ , projectVersionRange
+ , embedVersionRange
-- ** Utilities
- isAnyVersion,
- isAnyVersionLight,
- wildcardUpperBound,
- majorUpperBound,
- isWildcardRange,
- versionRangeParser,
- ) where
+ , isAnyVersion
+ , isAnyVersionLight
+ , wildcardUpperBound
+ , majorUpperBound
+ , isWildcardRange
+ , versionRangeParser
+ ) where
import Distribution.Compat.Prelude
import Distribution.Types.Version
@@ -51,30 +57,38 @@ import Prelude ()
-- in terms of the other basic syntax.
--
-- For a semantic view use 'asVersionIntervals'.
---
-foldVersionRange :: a -- ^ @\"-any\"@ version
- -> (Version -> a) -- ^ @\"== v\"@
- -> (Version -> a) -- ^ @\"> v\"@
- -> (Version -> a) -- ^ @\"< v\"@
- -> (a -> a -> a) -- ^ @\"_ || _\"@ union
- -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection
- -> VersionRange -> a
+foldVersionRange
+ :: a
+ -- ^ @\"-any\"@ version
+ -> (Version -> a)
+ -- ^ @\"== v\"@
+ -> (Version -> a)
+ -- ^ @\"> v\"@
+ -> (Version -> a)
+ -- ^ @\"< v\"@
+ -> (a -> a -> a)
+ -- ^ @\"_ || _\"@ union
+ -> (a -> a -> a)
+ -- ^ @\"_ && _\"@ intersection
+ -> VersionRange
+ -> a
foldVersionRange _any this later earlier union intersect = fold
where
fold = cataVersionRange alg
- alg (ThisVersionF v) = this v
- alg (LaterVersionF v) = later v
- alg (OrLaterVersionF v) = union (this v) (later v)
- alg (EarlierVersionF v) = earlier v
- alg (OrEarlierVersionF v) = union (this v) (earlier v)
- alg (MajorBoundVersionF v) = fold (majorBound v)
- alg (UnionVersionRangesF v1 v2) = union v1 v2
+ alg (ThisVersionF v) = this v
+ alg (LaterVersionF v) = later v
+ alg (OrLaterVersionF v) = union (this v) (later v)
+ alg (EarlierVersionF v) = earlier v
+ alg (OrEarlierVersionF v) = union (this v) (earlier v)
+ alg (MajorBoundVersionF v) = fold (majorBound v)
+ alg (UnionVersionRangesF v1 v2) = union v1 v2
alg (IntersectVersionRangesF v1 v2) = intersect v1 v2
- majorBound v = intersectVersionRanges
- (orLaterVersion v)
- (earlierVersion (majorUpperBound v))
+ majorBound v =
+ intersectVersionRanges
+ (orLaterVersion v)
+ (earlierVersion (majorUpperBound v))
-- | Normalise 'VersionRange'.
--
@@ -83,17 +97,19 @@ normaliseVersionRange :: VersionRange -> VersionRange
normaliseVersionRange = hyloVersionRange embed projectVersionRange
where
-- == v || > v, > v || == v ==> >= v
- embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v')) | v == v' =
- orLaterVersion v
- embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v')) | v == v' =
- orLaterVersion v
-
+ embed (UnionVersionRangesF (ThisVersion v) (LaterVersion v'))
+ | v == v' =
+ orLaterVersion v
+ embed (UnionVersionRangesF (LaterVersion v) (ThisVersion v'))
+ | v == v' =
+ orLaterVersion v
-- == v || < v, < v || == v ==> <= v
- embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v')) | v == v' =
- orEarlierVersion v
- embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v')) | v == v' =
- orEarlierVersion v
-
+ embed (UnionVersionRangesF (ThisVersion v) (EarlierVersion v'))
+ | v == v' =
+ orEarlierVersion v
+ embed (UnionVersionRangesF (EarlierVersion v) (ThisVersion v'))
+ | v == v' =
+ orEarlierVersion v
-- otherwise embed normally
embed vr = embedVersionRange vr
@@ -108,15 +124,15 @@ stripParensVersionRange = id
-- | Does this version fall within the given range?
--
-- This is the evaluation function for the 'VersionRange' type.
---
withinRange :: Version -> VersionRange -> Bool
-withinRange v = foldVersionRange
- True
- (\v' -> v == v')
- (\v' -> v > v')
- (\v' -> v < v')
- (||)
- (&&)
+withinRange v =
+ foldVersionRange
+ True
+ (\v' -> v == v')
+ (\v' -> v > v')
+ (\v' -> v < v')
+ (||)
+ (&&)
-- | Does this 'VersionRange' place any restriction on the 'Version' or is it
-- in fact equivalent to 'AnyVersion'.
@@ -125,11 +141,10 @@ withinRange v = foldVersionRange
-- the following is @True@ (for all @v@).
--
-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v)
---
isAnyVersion :: VersionRange -> Bool
isAnyVersion vr = case asVersionIntervals vr of
- [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0
- _ -> False
+ [VersionInterval (LowerBound v InclusiveBound) NoUpperBound] -> v == version0
+ _ -> False
-- A fast and non-precise version of 'isAnyVersion',
-- returns 'True' only for @>= 0@ 'VersionRange's.
@@ -141,29 +156,31 @@ isAnyVersion vr = case asVersionIntervals vr of
--
isAnyVersionLight :: VersionRange -> Bool
isAnyVersionLight (OrLaterVersion v) = v == version0
-isAnyVersionLight _vr = False
+isAnyVersionLight _vr = False
----------------------------
-- Wildcard range utilities
--
-
isWildcardRange :: Version -> Version -> Bool
isWildcardRange ver1 ver2 = check (versionNumbers ver1) (versionNumbers ver2)
- where check (n:[]) (m:[]) | n+1 == m = True
- check (n:ns) (m:ms) | n == m = check ns ms
- check _ _ = False
+ where
+ check (n : []) (m : []) | n + 1 == m = True
+ check (n : ns) (m : ms) | n == m = check ns ms
+ check _ _ = False
-- | Does the version range have an upper bound?
--
-- @since 1.24.0.0
hasUpperBound :: VersionRange -> Bool
-hasUpperBound = foldVersionRange
- False
- (const True)
- (const False)
- (const True)
- (&&) (||)
+hasUpperBound =
+ foldVersionRange
+ False
+ (const True)
+ (const False)
+ (const True)
+ (&&)
+ (||)
-- | Does the version range have an explicit lower bound?
--
@@ -172,9 +189,11 @@ hasUpperBound = foldVersionRange
--
-- @since 1.24.0.0
hasLowerBound :: VersionRange -> Bool
-hasLowerBound = foldVersionRange
- False
- (const True)
- (const True)
- (const False)
- (&&) (||)
+hasLowerBound =
+ foldVersionRange
+ False
+ (const True)
+ (const True)
+ (const False)
+ (&&)
+ (||)
diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs
index 67eede71059cb9e41c84d1c77567ec0d92d56ea2..7d7101d866077474652b7ef851a96302c93cdbd2 100644
--- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs
+++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs
@@ -1,35 +1,37 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | The only purpose of this module is to prevent the export of
-- 'VersionRange' constructors from
-- "Distribution.Types.VersionRange". To avoid creating orphan
-- instances, a lot of related code had to be moved here too.
-
module Distribution.Types.VersionRange.Internal
- ( VersionRange(..)
- , anyVersion, noVersion
- , thisVersion, notThisVersion
- , laterVersion, earlierVersion
- , orLaterVersion, orEarlierVersion
- , unionVersionRanges, intersectVersionRanges
+ ( VersionRange (..)
+ , anyVersion
+ , noVersion
+ , thisVersion
+ , notThisVersion
+ , laterVersion
+ , earlierVersion
+ , orLaterVersion
+ , orEarlierVersion
+ , unionVersionRanges
+ , intersectVersionRanges
, withinVersion
, majorBoundVersion
-
- , VersionRangeF(..)
+ , VersionRangeF (..)
, projectVersionRange
, embedVersionRange
, cataVersionRange
, anaVersionRange
, hyloVersionRange
, versionRangeParser
-
, majorUpperBound
, wildcardUpperBound
) where
@@ -41,22 +43,22 @@ import Prelude ()
import Distribution.CabalSpecVersion
import Distribution.Parsec
import Distribution.Pretty
-import Distribution.Utils.Generic (unsnoc)
+import Distribution.Utils.Generic (unsnoc)
import qualified Distribution.Compat.CharParsing as P
-import qualified Distribution.Compat.DList as DList
-import qualified Text.PrettyPrint as Disp
+import qualified Distribution.Compat.DList as DList
+import qualified Text.PrettyPrint as Disp
data VersionRange
- = ThisVersion Version -- = version
- | LaterVersion Version -- > version (NB. not >=)
- | OrLaterVersion Version -- >= version
- | EarlierVersion Version -- < version
- | OrEarlierVersion Version -- <= version
- | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1)
- | UnionVersionRanges VersionRange VersionRange
+ = ThisVersion Version -- = version
+ | LaterVersion Version -- > version (NB. not >=)
+ | OrLaterVersion Version -- >= version
+ | EarlierVersion Version -- < version
+ | OrEarlierVersion Version -- <= version
+ | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1)
+ | UnionVersionRanges VersionRange VersionRange
| IntersectVersionRanges VersionRange VersionRange
- deriving ( Data, Eq, Ord, Generic, Read, Show, Typeable )
+ deriving (Data, Eq, Ord, Generic, Read, Show, Typeable)
instance Binary VersionRange
instance Structured VersionRange
@@ -66,7 +68,6 @@ instance NFData VersionRange where rnf = genericRnf
-- versions.
--
-- > withinRange v anyVersion = True
---
anyVersion :: VersionRange
anyVersion = OrLaterVersion (mkVersion [0])
@@ -76,49 +77,42 @@ anyVersion = OrLaterVersion (mkVersion [0])
-- for example @< 0@.
--
-- > withinRange v noVersion = False
---
noVersion :: VersionRange
noVersion = EarlierVersion (mkVersion [0])
-- | The version range @== v@.
--
-- > withinRange v' (thisVersion v) = v' == v
---
thisVersion :: Version -> VersionRange
thisVersion = ThisVersion
-- | The version range @/= v@.
--
-- > withinRange v' (notThisVersion v) = v' /= v
---
notThisVersion :: Version -> VersionRange
notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v)
-- | The version range @> v@.
--
-- > withinRange v' (laterVersion v) = v' > v
---
laterVersion :: Version -> VersionRange
laterVersion = LaterVersion
-- | The version range @>= v@.
--
-- > withinRange v' (orLaterVersion v) = v' >= v
---
orLaterVersion :: Version -> VersionRange
orLaterVersion = OrLaterVersion
-- | The version range @< v@.
--
-- > withinRange v' (earlierVersion v) = v' < v
---
earlierVersion :: Version -> VersionRange
earlierVersion = EarlierVersion
-- | The version range @<= v@.
--
-- > withinRange v' (orEarlierVersion v) = v' <= v
---
orEarlierVersion :: Version -> VersionRange
orEarlierVersion = OrEarlierVersion
@@ -126,7 +120,6 @@ orEarlierVersion = OrEarlierVersion
--
-- > withinRange v' (unionVersionRanges vr1 vr2)
-- > = withinRange v' vr1 || withinRange v' vr2
---
unionVersionRanges :: VersionRange -> VersionRange -> VersionRange
unionVersionRanges = UnionVersionRanges
@@ -134,7 +127,6 @@ unionVersionRanges = UnionVersionRanges
--
-- > withinRange v' (intersectVersionRanges vr1 vr2)
-- > = withinRange v' vr1 && withinRange v' vr2
---
intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange
intersectVersionRanges = IntersectVersionRanges
@@ -146,9 +138,9 @@ intersectVersionRanges = IntersectVersionRanges
-- > withinRange v' (withinVersion v) = v' >= v && v' < upper v
-- > where
-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t
---
withinVersion :: Version -> VersionRange
-withinVersion v = intersectVersionRanges
+withinVersion v =
+ intersectVersionRanges
(orLaterVersion v)
(earlierVersion (wildcardUpperBound v))
@@ -163,33 +155,49 @@ withinVersion v = intersectVersionRanges
majorBoundVersion :: Version -> VersionRange
majorBoundVersion = MajorBoundVersion
-
-- | F-Algebra of 'VersionRange'. See 'cataVersionRange'.
--
-- @since 2.2
data VersionRangeF a
- = ThisVersionF Version -- ^ @== version@.
- | LaterVersionF Version -- ^ @> version@. NB: not @>=@
- | OrLaterVersionF Version -- ^ @>= version@.
- | EarlierVersionF Version -- ^ @< version@.
- | OrEarlierVersionF Version -- ^ @<= version@.
- | MajorBoundVersionF Version -- ^ @^>= version@, same as @>= version && < MAJ(version)+1@.
- | UnionVersionRangesF a a -- ^ @||@.
- | IntersectVersionRangesF a a -- ^ @&&@.
- deriving ( Data, Eq, Generic, Read, Show, Typeable
- , Functor, Foldable, Traversable )
+ = -- | @== version@.
+ ThisVersionF Version
+ | -- | @> version@. NB: not @>=@
+ LaterVersionF Version
+ | -- | @>= version@.
+ OrLaterVersionF Version
+ | -- | @< version@.
+ EarlierVersionF Version
+ | -- | @<= version@.
+ OrEarlierVersionF Version
+ | -- | @^>= version@, same as @>= version && < MAJ(version)+1@.
+ MajorBoundVersionF Version
+ | -- | @||@.
+ UnionVersionRangesF a a
+ | -- | @&&@.
+ IntersectVersionRangesF a a
+ deriving
+ ( Data
+ , Eq
+ , Generic
+ , Read
+ , Show
+ , Typeable
+ , Functor
+ , Foldable
+ , Traversable
+ )
-- | Generic destructor for 'VersionRange'.
--
-- @since 2.2
projectVersionRange :: VersionRange -> VersionRangeF VersionRange
-projectVersionRange (ThisVersion v) = ThisVersionF v
-projectVersionRange (LaterVersion v) = LaterVersionF v
-projectVersionRange (OrLaterVersion v) = OrLaterVersionF v
-projectVersionRange (EarlierVersion v) = EarlierVersionF v
-projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v
-projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v
-projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b
+projectVersionRange (ThisVersion v) = ThisVersionF v
+projectVersionRange (LaterVersion v) = LaterVersionF v
+projectVersionRange (OrLaterVersion v) = OrLaterVersionF v
+projectVersionRange (EarlierVersion v) = EarlierVersionF v
+projectVersionRange (OrEarlierVersion v) = OrEarlierVersionF v
+projectVersionRange (MajorBoundVersion v) = MajorBoundVersionF v
+projectVersionRange (UnionVersionRanges a b) = UnionVersionRangesF a b
projectVersionRange (IntersectVersionRanges a b) = IntersectVersionRangesF a b
-- | Fold 'VersionRange'.
@@ -202,13 +210,13 @@ cataVersionRange f = c where c = f . fmap c . projectVersionRange
--
-- @since 2.2
embedVersionRange :: VersionRangeF VersionRange -> VersionRange
-embedVersionRange (ThisVersionF v) = ThisVersion v
-embedVersionRange (LaterVersionF v) = LaterVersion v
-embedVersionRange (OrLaterVersionF v) = OrLaterVersion v
-embedVersionRange (EarlierVersionF v) = EarlierVersion v
-embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v
-embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v
-embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b
+embedVersionRange (ThisVersionF v) = ThisVersion v
+embedVersionRange (LaterVersionF v) = LaterVersion v
+embedVersionRange (OrLaterVersionF v) = OrLaterVersion v
+embedVersionRange (EarlierVersionF v) = EarlierVersion v
+embedVersionRange (OrEarlierVersionF v) = OrEarlierVersion v
+embedVersionRange (MajorBoundVersionF v) = MajorBoundVersion v
+embedVersionRange (UnionVersionRangesF a b) = UnionVersionRanges a b
embedVersionRange (IntersectVersionRangesF a b) = IntersectVersionRanges a b
-- | Unfold 'VersionRange'.
@@ -220,9 +228,11 @@ anaVersionRange g = a where a = embedVersionRange . fmap a . g
-- | Refold 'VersionRange'.
--
-- @since 2.2
-hyloVersionRange :: (VersionRangeF VersionRange -> VersionRange)
- -> (VersionRange -> VersionRangeF VersionRange)
- -> VersionRange -> VersionRange
+hyloVersionRange
+ :: (VersionRangeF VersionRange -> VersionRange)
+ -> (VersionRange -> VersionRangeF VersionRange)
+ -> VersionRange
+ -> VersionRange
hyloVersionRange f g = h where h = f . fmap h . g
-------------------------------------------------------------------------------
@@ -242,43 +252,46 @@ hyloVersionRange f g = h where h = f . fmap h . g
--
-- >>> fmap (prettyVersioned CabalSpecV1_6) (simpleParsec' CabalSpecV1_6 "-any" :: Maybe VersionRange)
-- Just >=0
---
instance Pretty VersionRange where
- pretty = prettyVersioned cabalSpecLatest
+ pretty = prettyVersioned cabalSpecLatest
- prettyVersioned csv
- | csv > CabalSpecV1_6 = prettyVersionRange
- | otherwise = prettyVersionRange16
+ prettyVersioned csv
+ | csv > CabalSpecV1_6 = prettyVersionRange
+ | otherwise = prettyVersionRange16
prettyVersionRange :: VersionRange -> Disp.Doc
prettyVersionRange vr = cataVersionRange alg vr 0
where
alg :: VersionRangeF (Int -> Disp.Doc) -> Int -> Disp.Doc
- alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v
- alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v
- alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v
- alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v
- alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v
- alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v
- alg (UnionVersionRangesF r1 r2) d = parens (d > 0)
- $ r1 1 <+> Disp.text "||" <+> r2 0
- alg (IntersectVersionRangesF r1 r2) d = parens (d > 1)
- $ r1 2 <+> Disp.text "&&" <+> r2 1
-
- parens True = Disp.parens
+ alg (ThisVersionF v) _ = Disp.text "==" <<>> pretty v
+ alg (LaterVersionF v) _ = Disp.text ">" <<>> pretty v
+ alg (OrLaterVersionF v) _ = Disp.text ">=" <<>> pretty v
+ alg (EarlierVersionF v) _ = Disp.text "<" <<>> pretty v
+ alg (OrEarlierVersionF v) _ = Disp.text "<=" <<>> pretty v
+ alg (MajorBoundVersionF v) _ = Disp.text "^>=" <<>> pretty v
+ alg (UnionVersionRangesF r1 r2) d =
+ parens (d > 0) $
+ r1 1 <+> Disp.text "||" <+> r2 0
+ alg (IntersectVersionRangesF r1 r2) d =
+ parens (d > 1) $
+ r1 2 <+> Disp.text "&&" <+> r2 1
+
+ parens True = Disp.parens
parens False = id
-- | Don't use && and || operators. If possible.
prettyVersionRange16 :: VersionRange -> Disp.Doc
prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion u))
- | u == wildcardUpperBound v
- = Disp.text "==" <<>> dispWild v
+ | u == wildcardUpperBound v =
+ Disp.text "==" <<>> dispWild v
where
dispWild ver =
- Disp.hcat (Disp.punctuate (Disp.char '.')
- (map Disp.int $ versionNumbers ver))
+ Disp.hcat
+ ( Disp.punctuate
+ (Disp.char '.')
+ (map Disp.int $ versionNumbers ver)
+ )
<<>> Disp.text ".*"
-
prettyVersionRange16 vr = prettyVersionRange vr
-- |
@@ -318,9 +331,8 @@ prettyVersionRange16 vr = prettyVersionRange vr
--
-- >>> map (`simpleParsecW'` "== 1.2.*") [CabalSpecV1_4, CabalSpecV1_6] :: [Maybe VersionRange]
-- [Nothing,Just (IntersectVersionRanges (OrLaterVersion (mkVersion [1,2])) (EarlierVersion (mkVersion [1,3])))]
---
instance Parsec VersionRange where
- parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser
+ parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser
-- | 'VersionRange' parser parametrised by version digit parser.
--
@@ -331,180 +343,197 @@ instance Parsec VersionRange where
-- @since 3.0
versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange
versionRangeParser digitParser csv = expr
+ where
+ expr = do
+ P.spaces
+ t <- term
+ P.spaces
+ ( do
+ _ <- P.string "||"
+ checkOp
+ P.spaces
+ e <- expr
+ return (unionVersionRanges t e)
+ <|> return t
+ )
+ term = do
+ f <- factor
+ P.spaces
+ ( do
+ _ <- P.string "&&"
+ checkOp
+ P.spaces
+ t <- term
+ return (intersectVersionRanges f t)
+ <|> return f
+ )
+ factor = parens expr <|> prim
+
+ prim = do
+ op <- P.munch1 isOpChar P.<?> "operator"
+ case op of
+ "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion'
+ "==" -> do
+ P.spaces
+ ( do
+ (wild, v) <- verOrWild
+ checkWild wild
+ pure $ (if wild then withinVersion else thisVersion) v
+ <|> (verSet' thisVersion =<< verSet)
+ )
+ "^>=" -> do
+ P.spaces
+ ( do
+ (wild, v) <- verOrWild
+ when wild $
+ P.unexpected $
+ "wild-card version after ^>= operator"
+ majorBoundVersion' v
+ <|> (verSet' majorBoundVersion =<< verSet)
+ )
+ _ -> do
+ P.spaces
+ (wild, v) <- verOrWild
+ when wild $
+ P.unexpected $
+ "wild-card version after non-== operator: " ++ show op
+ case op of
+ ">=" -> pure $ orLaterVersion v
+ "<" -> pure $ earlierVersion v
+ "<=" -> pure $ orEarlierVersion v
+ ">" -> pure $ laterVersion v
+ _ -> fail $ "Unknown version operator " ++ show op
+
+ -- Cannot be warning
+ -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this
+ -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal
+ --
+ checkOp =
+ when (csv < CabalSpecV1_8) $
+ parsecWarning PWTVersionOperator $
+ unwords
+ [ "version operators used."
+ , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'."
+ ]
+
+ -- Cannot be warning
+ -- On 2020-03-16 there was 46 files on Hackage failing to parse due this
+ -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal
+ --
+ checkWild False = pure ()
+ checkWild True =
+ when (csv < CabalSpecV1_6) $
+ parsecWarning PWTVersionWildcard $
+ unwords
+ [ "Wildcard syntax used."
+ , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'."
+ ]
+
+ -- https://gitlab.haskell.org/ghc/ghc/issues/17752
+ isOpChar '<' = True
+ isOpChar '=' = True
+ isOpChar '>' = True
+ isOpChar '^' = True
+ isOpChar '-' = csv < CabalSpecV3_4
+ -- https://github.com/haskell/cabal/issues/6589
+ -- Unfortunately we have must not consume the dash,
+ -- as otherwise following parts may not be parsed.
+ --
+ -- i.e. we cannot fail here with good error.
+ isOpChar _ = False
+
+ -- -none version range is available since 1.22
+ noVersion' =
+ if csv >= CabalSpecV1_22
+ then pure noVersion
+ else
+ fail $
+ unwords
+ [ "-none version range used."
+ , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'."
+ , "Alternatively, if broader compatibility is important then use"
+ , "<0 or other empty range."
+ ]
+
+ -- \^>= is available since 2.0
+ majorBoundVersion' v =
+ if csv >= CabalSpecV2_0
+ then pure $ majorBoundVersion v
+ else
+ fail $
+ unwords
+ [ "major bounded version syntax (caret, ^>=) used."
+ , "To use this syntax the package need to specify at least 'cabal-version: 2.0'."
+ , "Alternatively, if broader compatibility is important then use:"
+ , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v
+ ]
where
- expr = do P.spaces
- t <- term
- P.spaces
- (do _ <- P.string "||"
- checkOp
- P.spaces
- e <- expr
- return (unionVersionRanges t e)
- <|>
- return t)
- term = do f <- factor
- P.spaces
- (do _ <- P.string "&&"
- checkOp
- P.spaces
- t <- term
- return (intersectVersionRanges f t)
- <|>
- return f)
- factor = parens expr <|> prim
-
- prim = do
- op <- P.munch1 isOpChar P.<?> "operator"
- case op of
- "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion'
-
- "==" -> do
- P.spaces
- (do (wild, v) <- verOrWild
- checkWild wild
- pure $ (if wild then withinVersion else thisVersion) v
- <|>
- (verSet' thisVersion =<< verSet))
-
- "^>=" -> do
- P.spaces
- (do (wild, v) <- verOrWild
- when wild $ P.unexpected $
- "wild-card version after ^>= operator"
- majorBoundVersion' v
- <|>
- (verSet' majorBoundVersion =<< verSet))
-
- _ -> do
- P.spaces
- (wild, v) <- verOrWild
- when wild $ P.unexpected $
- "wild-card version after non-== operator: " ++ show op
- case op of
- ">=" -> pure $ orLaterVersion v
- "<" -> pure $ earlierVersion v
- "<=" -> pure $ orEarlierVersion v
- ">" -> pure $ laterVersion v
- _ -> fail $ "Unknown version operator " ++ show op
-
- -- Cannot be warning
- -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this
- -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal
- --
- checkOp = when (csv < CabalSpecV1_8) $
- parsecWarning PWTVersionOperator $ unwords
- [ "version operators used."
- , "To use version operators the package needs to specify at least 'cabal-version: >= 1.8'."
- ]
-
- -- Cannot be warning
- -- On 2020-03-16 there was 46 files on Hackage failing to parse due this
- -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal
- --
- checkWild False = pure ()
- checkWild True = when (csv < CabalSpecV1_6) $
- parsecWarning PWTVersionWildcard $ unwords
- [ "Wildcard syntax used."
- , "To use version wildcards the package needs to specify at least 'cabal-version: >= 1.6'."
- ]
-
- -- https://gitlab.haskell.org/ghc/ghc/issues/17752
- isOpChar '<' = True
- isOpChar '=' = True
- isOpChar '>' = True
- isOpChar '^' = True
- isOpChar '-' = csv < CabalSpecV3_4
- -- https://github.com/haskell/cabal/issues/6589
- -- Unfortunately we have must not consume the dash,
- -- as otherwise following parts may not be parsed.
- --
- -- i.e. we cannot fail here with good error.
- isOpChar _ = False
-
- -- -none version range is available since 1.22
- noVersion' =
- if csv >= CabalSpecV1_22
- then pure noVersion
- else fail $ unwords
- [ "-none version range used."
- , "To use this syntax the package needs to specify at least 'cabal-version: 1.22'."
- , "Alternatively, if broader compatibility is important then use"
- , "<0 or other empty range."
- ]
-
- -- ^>= is available since 2.0
- majorBoundVersion' v =
- if csv >= CabalSpecV2_0
- then pure $ majorBoundVersion v
- else fail $ unwords
- [ "major bounded version syntax (caret, ^>=) used."
- , "To use this syntax the package need to specify at least 'cabal-version: 2.0'."
- , "Alternatively, if broader compatibility is important then use:"
- , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v
- ]
- where
- eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange
- embed (MajorBoundVersionF u) = intersectVersionRanges
- (orLaterVersion u) (earlierVersion (majorUpperBound u))
- embed vr = embedVersionRange vr
-
- -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }")
- verSet' op vs =
- if csv >= CabalSpecV3_0
- then pure $ foldr1 unionVersionRanges (fmap op vs)
- else fail $ unwords
- [ "version set syntax used."
- , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."
- , "Alternatively, if broader compatibility is important then use"
- , "a series of single version constraints joined with the || operator:"
- , prettyShow (foldr1 unionVersionRanges (fmap op vs))
- ]
-
- verSet :: CabalParsing m => m (NonEmpty Version)
- verSet = do
- _ <- P.char '{'
- P.spaces
- vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces)
- _ <- P.char '}'
- pure vs
-
- -- a plain version without tags or wildcards
- verPlain :: CabalParsing m => m Version
- verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.')
-
- -- either wildcard or normal version
- verOrWild :: CabalParsing m => m (Bool, Version)
- verOrWild = do
- x <- digitParser
- verLoop (DList.singleton x)
-
- -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag)
- verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version)
- verLoop acc = verLoop' acc
- <|> (tags *> pure (False, mkVersion (DList.toList acc)))
-
- verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version)
- verLoop' acc = do
- _ <- P.char '.'
- let digit = digitParser >>= verLoop . DList.snoc acc
- let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*'
- digit <|> wild
-
- parens p = P.between
- ((P.char '(' P.<?> "opening paren") >> P.spaces)
- (P.char ')' >> P.spaces)
- $ do
- a <- p
- P.spaces
- return a
-
- tags :: CabalParsing m => m ()
- tags = do
- ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)
- case ts of
- [] -> pure ()
- (_ : _) -> parsecWarning PWTVersionTag "version with tags"
-
+ eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange
+ embed (MajorBoundVersionF u) =
+ intersectVersionRanges
+ (orLaterVersion u)
+ (earlierVersion (majorUpperBound u))
+ embed vr = embedVersionRange vr
+
+ -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }")
+ verSet' op vs =
+ if csv >= CabalSpecV3_0
+ then pure $ foldr1 unionVersionRanges (fmap op vs)
+ else
+ fail $
+ unwords
+ [ "version set syntax used."
+ , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'."
+ , "Alternatively, if broader compatibility is important then use"
+ , "a series of single version constraints joined with the || operator:"
+ , prettyShow (foldr1 unionVersionRanges (fmap op vs))
+ ]
+
+ verSet :: CabalParsing m => m (NonEmpty Version)
+ verSet = do
+ _ <- P.char '{'
+ P.spaces
+ vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces)
+ _ <- P.char '}'
+ pure vs
+
+ -- a plain version without tags or wildcards
+ verPlain :: CabalParsing m => m Version
+ verPlain = mkVersion <$> toList <$> P.sepByNonEmpty digitParser (P.char '.')
+
+ -- either wildcard or normal version
+ verOrWild :: CabalParsing m => m (Bool, Version)
+ verOrWild = do
+ x <- digitParser
+ verLoop (DList.singleton x)
+
+ -- trailing: wildcard (.y.*) or normal version (optional tags) (.y.z-tag)
+ verLoop :: CabalParsing m => DList.DList Int -> m (Bool, Version)
+ verLoop acc =
+ verLoop' acc
+ <|> (tags *> pure (False, mkVersion (DList.toList acc)))
+
+ verLoop' :: CabalParsing m => DList.DList Int -> m (Bool, Version)
+ verLoop' acc = do
+ _ <- P.char '.'
+ let digit = digitParser >>= verLoop . DList.snoc acc
+ let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*'
+ digit <|> wild
+
+ parens p = P.between
+ ((P.char '(' P.<?> "opening paren") >> P.spaces)
+ (P.char ')' >> P.spaces)
+ $ do
+ a <- p
+ P.spaces
+ return a
+
+ tags :: CabalParsing m => m ()
+ tags = do
+ ts <- many $ P.char '-' *> some (P.satisfy isAlphaNum)
+ case ts of
+ [] -> pure ()
+ (_ : _) -> parsecWarning PWTVersionTag "version with tags"
----------------------------
-- Wildcard range utilities
@@ -518,9 +547,9 @@ versionRangeParser digitParser csv = expr
-- @since 2.2
majorUpperBound :: Version -> Version
majorUpperBound = alterVersion $ \numbers -> case numbers of
- [] -> [0,1] -- should not happen
- [m1] -> [m1,1] -- e.g. version '1'
- (m1:m2:_) -> [m1,m2+1]
+ [] -> [0, 1] -- should not happen
+ [m1] -> [m1, 1] -- e.g. version '1'
+ (m1 : m2 : _) -> [m1, m2 + 1]
-- | Increment the last version number.
--
@@ -531,6 +560,6 @@ majorUpperBound = alterVersion $ \numbers -> case numbers of
-- @since 2.2
wildcardUpperBound :: Version -> Version
wildcardUpperBound = alterVersion $
- \lowerBound -> case unsnoc lowerBound of
- Nothing -> []
- Just (xs, x) -> xs ++ [x + 1]
+ \lowerBound -> case unsnoc lowerBound of
+ Nothing -> []
+ Just (xs, x) -> xs ++ [x + 1]
diff --git a/Cabal-syntax/src/Distribution/Utils/Base62.hs b/Cabal-syntax/src/Distribution/Utils/Base62.hs
index ad3bc10fea81ef43a1d0ea80f9a6bb3064fbb119..757528e750f0bbdba7feebd8e4e6e0c48bf78822 100644
--- a/Cabal-syntax/src/Distribution/Utils/Base62.hs
+++ b/Cabal-syntax/src/Distribution/Utils/Base62.hs
@@ -1,11 +1,10 @@
-
-- | Implementation of base-62 encoding, which we use when computing hashes
-- for fully instantiated unit ids.
module Distribution.Utils.Base62 (hashToBase62) where
-import GHC.Fingerprint ( Fingerprint(..), fingerprintString )
-import Numeric ( showIntAtBase )
-import Data.Char ( chr )
+import Data.Char (chr)
+import GHC.Fingerprint (Fingerprint (..), fingerprintString)
+import Numeric (showIntAtBase)
-- | Hash a string using GHC's fingerprinting algorithm (a 128-bit
-- MD5 hash) and then encode the resulting hash in base 62.
@@ -14,9 +13,8 @@ hashToBase62 s = showFingerprint $ fingerprintString s
where
showIntAtBase62 x = showIntAtBase 62 representBase62 x ""
representBase62 x
- | x < 10 = chr (48 + x)
- | x < 36 = chr (65 + x - 10)
- | x < 62 = chr (97 + x - 36)
- | otherwise = '@'
+ | x < 10 = chr (48 + x)
+ | x < 36 = chr (65 + x - 10)
+ | x < 62 = chr (97 + x - 36)
+ | otherwise = '@'
showFingerprint (Fingerprint a b) = showIntAtBase62 a ++ showIntAtBase62 b
-
diff --git a/Cabal-syntax/src/Distribution/Utils/Generic.hs b/Cabal-syntax/src/Distribution/Utils/Generic.hs
index 5a3e750a397f84849b1ed1eff9e2e0560e8bafae..997e0132f5ab90c43bf7075b9e1e117d1b40e5fb 100644
--- a/Cabal-syntax/src/Distribution/Utils/Generic.hs
+++ b/Cabal-syntax/src/Distribution/Utils/Generic.hs
@@ -1,11 +1,12 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Utils.Generic
-- Copyright : Isaac Jones, Simon Marlow 2003-2004
@@ -20,122 +21,132 @@
-- lib like @cabal-install@. It has a very simple set of logging actions. It
-- has low level functions for running programs, a bunch of wrappers for
-- various directory and file functions that do extra logging.
-
-module Distribution.Utils.Generic (
- -- * reading and writing files safely
- withFileContents,
- writeFileAtomic,
-
- -- * Unicode
-
- -- ** Conversions
- fromUTF8BS,
- fromUTF8LBS,
-
- toUTF8BS,
- toUTF8LBS,
-
- validateUTF8,
-
- -- ** File I/O
- readUTF8File,
- withUTF8FileContents,
- writeUTF8File,
-
- -- ** BOM
- ignoreBOM,
-
- -- ** Misc
- normaliseLineEndings,
-
- -- * generic utils
- dropWhileEndLE,
- takeWhileEndLE,
- equating,
- comparing,
- isInfixOf,
- intercalate,
- lowercase,
- isAscii,
- isAsciiAlpha,
- isAsciiAlphaNum,
- listUnion,
- listUnionRight,
- ordNub,
- ordNubBy,
- ordNubRight,
- safeHead,
- safeTail,
- safeLast,
- safeInit,
- unintersperse,
- wrapText,
- wrapLine,
- unfoldrM,
- spanMaybe,
- breakMaybe,
- unsnoc,
- unsnocNE,
-
- -- * Triples
- fstOf3,
- sndOf3,
- trdOf3,
-
- -- * FilePath stuff
- isAbsoluteOnAnyPlatform,
- isRelativeOnAnyPlatform,
+module Distribution.Utils.Generic
+ ( -- * reading and writing files safely
+ withFileContents
+ , writeFileAtomic
+
+ -- * Unicode
+
+ -- ** Conversions
+ , fromUTF8BS
+ , fromUTF8LBS
+ , toUTF8BS
+ , toUTF8LBS
+ , validateUTF8
+
+ -- ** File I/O
+ , readUTF8File
+ , withUTF8FileContents
+ , writeUTF8File
+
+ -- ** BOM
+ , ignoreBOM
+
+ -- ** Misc
+ , normaliseLineEndings
+
+ -- * generic utils
+ , dropWhileEndLE
+ , takeWhileEndLE
+ , equating
+ , comparing
+ , isInfixOf
+ , intercalate
+ , lowercase
+ , isAscii
+ , isAsciiAlpha
+ , isAsciiAlphaNum
+ , listUnion
+ , listUnionRight
+ , ordNub
+ , ordNubBy
+ , ordNubRight
+ , safeHead
+ , safeTail
+ , safeLast
+ , safeInit
+ , unintersperse
+ , wrapText
+ , wrapLine
+ , unfoldrM
+ , spanMaybe
+ , breakMaybe
+ , unsnoc
+ , unsnocNE
+
+ -- * Triples
+ , fstOf3
+ , sndOf3
+ , trdOf3
+
+ -- * FilePath stuff
+ , isAbsoluteOnAnyPlatform
+ , isRelativeOnAnyPlatform
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Utils.String
-import Data.Bits ((.&.), (.|.), shiftL)
-import Data.List
- ( isInfixOf )
-import qualified Data.Set as Set
+import Data.Bits (shiftL, (.&.), (.|.))
import qualified Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
+import Data.List
+ ( isInfixOf
+ )
+import qualified Data.Set as Set
+import qualified Control.Exception as Exception
import System.Directory
- ( removeFile, renameFile )
+ ( removeFile
+ , renameFile
+ )
import System.FilePath
- ( (<.>), splitFileName )
+ ( splitFileName
+ , (<.>)
+ )
import System.IO
- ( withFile, withBinaryFile
- , openBinaryTempFileWithDefaultPermissions
- , IOMode(ReadMode), hGetContents, hClose )
-import qualified Control.Exception as Exception
+ ( IOMode (ReadMode)
+ , hClose
+ , hGetContents
+ , openBinaryTempFileWithDefaultPermissions
+ , withBinaryFile
+ , withFile
+ )
-- -----------------------------------------------------------------------------
-- Helper functions
-- | Wraps text to the default line width. Existing newlines are preserved.
wrapText :: String -> String
-wrapText = unlines
- . map (intercalate "\n"
- . map unwords
- . wrapLine 79
- . words)
- . lines
+wrapText =
+ unlines
+ . map
+ ( intercalate "\n"
+ . map unwords
+ . wrapLine 79
+ . words
+ )
+ . lines
-- | Wraps a list of words to a list of lines of words of a particular width.
wrapLine :: Int -> [String] -> [[String]]
wrapLine width = wrap 0 []
- where wrap :: Int -> [String] -> [String] -> [[String]]
- wrap 0 [] (w:ws)
- | length w + 1 > width
- = wrap (length w) [w] ws
- wrap col line (w:ws)
- | col + length w + 1 > width
- = reverse line : wrap 0 [] (w:ws)
- wrap col line (w:ws)
- = let col' = col + length w + 1
- in wrap col' (w:line) ws
- wrap _ [] [] = []
- wrap _ line [] = [reverse line]
+ where
+ wrap :: Int -> [String] -> [String] -> [[String]]
+ wrap 0 [] (w : ws)
+ | length w + 1 > width =
+ wrap (length w) [w] ws
+ wrap col line (w : ws)
+ | col + length w + 1 > width =
+ reverse line : wrap 0 [] (w : ws)
+ wrap col line (w : ws) =
+ let col' = col + length w + 1
+ in wrap col' (w : line) ws
+ wrap _ [] [] = []
+ wrap _ line [] = [reverse line]
-----------------------------------
-- Safely reading and writing files
@@ -144,11 +155,12 @@ wrapLine width = wrap 0 []
--
-- The file is read lazily but if it is not fully consumed by the action then
-- the remaining input is truncated and the file is closed.
---
withFileContents :: FilePath -> (String -> IO a) -> IO a
withFileContents name action =
- withFile name ReadMode
- (\hnd -> hGetContents hnd >>= action)
+ withFile
+ name
+ ReadMode
+ (\hnd -> hGetContents hnd >>= action)
-- | Writes a file atomically.
--
@@ -157,32 +169,32 @@ withFileContents name action =
--
-- On windows it is not possible to delete a file that is open by a process.
-- This case will give an IO exception but the atomic property is not affected.
---
writeFileAtomic :: FilePath -> LBS.ByteString -> IO ()
writeFileAtomic targetPath content = do
let (targetDir, targetFile) = splitFileName targetPath
Exception.bracketOnError
(openBinaryTempFileWithDefaultPermissions targetDir $ targetFile <.> "tmp")
(\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
- (\(tmpPath, handle) -> do
+ ( \(tmpPath, handle) -> do
LBS.hPut handle content
hClose handle
- renameFile tmpPath targetPath)
+ renameFile tmpPath targetPath
+ )
-- ------------------------------------------------------------
+
-- * Unicode stuff
+
-- ------------------------------------------------------------
-- | Decode 'String' from UTF8-encoded 'BS.ByteString'
--
-- Invalid data in the UTF8 stream (this includes code-points @U+D800@
-- through @U+DFFF@) will be decoded as the replacement character (@U+FFFD@).
---
fromUTF8BS :: SBS.ByteString -> String
fromUTF8BS = decodeStringUtf8 . SBS.unpack
-- | Variant of 'fromUTF8BS' for lazy 'BS.ByteString's
---
fromUTF8LBS :: LBS.ByteString -> String
fromUTF8LBS = decodeStringUtf8 . LBS.unpack
@@ -190,93 +202,92 @@ fromUTF8LBS = decodeStringUtf8 . LBS.unpack
--
-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded
-- as the replacement character (i.e. @U+FFFD@).
---
toUTF8BS :: String -> SBS.ByteString
toUTF8BS = SBS.pack . encodeStringUtf8
-- | Variant of 'toUTF8BS' for lazy 'BS.ByteString's
---
toUTF8LBS :: String -> LBS.ByteString
toUTF8LBS = LBS.pack . encodeStringUtf8
-- | Check that strict 'ByteString' is valid UTF8. Returns 'Just offset' if it's not.
validateUTF8 :: SBS.ByteString -> Maybe Int
-validateUTF8 = go 0 where
+validateUTF8 = go 0
+ where
go off bs = case SBS.uncons bs of
- Nothing -> Nothing
- Just (c, bs')
- | c <= 0x7F -> go (off + 1) bs'
- | c <= 0xBF -> Just off
- | c <= 0xDF -> twoBytes off c bs'
- | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF)
- | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7)
- | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3)
- | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1)
- | otherwise -> Just off
+ Nothing -> Nothing
+ Just (c, bs')
+ | c <= 0x7F -> go (off + 1) bs'
+ | c <= 0xBF -> Just off
+ | c <= 0xDF -> twoBytes off c bs'
+ | c <= 0xEF -> moreBytes off 3 0x800 bs' (fromIntegral $ c .&. 0xF)
+ | c <= 0xF7 -> moreBytes off 4 0x10000 bs' (fromIntegral $ c .&. 0x7)
+ | c <= 0xFB -> moreBytes off 5 0x200000 bs' (fromIntegral $ c .&. 0x3)
+ | c <= 0xFD -> moreBytes off 6 0x4000000 bs' (fromIntegral $ c .&. 0x1)
+ | otherwise -> Just off
twoBytes off c0 bs = case SBS.uncons bs of
- Nothing -> Just off
- Just (c1, bs')
- | c1 .&. 0xC0 == 0x80 ->
- if d >= (0x80 :: Int)
- then go (off + 2) bs'
- else Just off
- | otherwise -> Just off
- where
- d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)
+ Nothing -> Just off
+ Just (c1, bs')
+ | c1 .&. 0xC0 == 0x80 ->
+ if d >= (0x80 :: Int)
+ then go (off + 2) bs'
+ else Just off
+ | otherwise -> Just off
+ where
+ d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6) .|. fromIntegral (c1 .&. 0x3F)
moreBytes :: Int -> Int -> Int -> SBS.ByteString -> Int -> Maybe Int
moreBytes off 1 overlong cs' acc
- | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc
- = go (off + 1) cs'
-
- | otherwise
- = Just off
-
+ | overlong <= acc
+ , acc <= 0x10FFFF
+ , acc < 0xD800 || 0xDFFF < acc =
+ go (off + 1) cs'
+ | otherwise =
+ Just off
moreBytes off byteCount overlong bs acc = case SBS.uncons bs of
- Just (cn, bs') | cn .&. 0xC0 == 0x80 ->
- moreBytes (off + 1) (byteCount-1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
- _ -> Just off
-
+ Just (cn, bs')
+ | cn .&. 0xC0 == 0x80 ->
+ moreBytes (off + 1) (byteCount - 1) overlong bs' ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
+ _ -> Just off
-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input
---
ignoreBOM :: String -> String
-ignoreBOM ('\xFEFF':string) = string
-ignoreBOM string = string
+ignoreBOM ('\xFEFF' : string) = string
+ignoreBOM string = string
-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Reads lazily using ordinary 'readFile'.
---
readUTF8File :: FilePath -> IO String
readUTF8File f = (ignoreBOM . fromUTF8LBS) <$> LBS.readFile f
-- | Reads a UTF8 encoded text file as a Unicode String
--
-- Same behaviour as 'withFileContents'.
---
withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
withUTF8FileContents name action =
- withBinaryFile name ReadMode
+ withBinaryFile
+ name
+ ReadMode
(\hnd -> LBS.hGetContents hnd >>= action . ignoreBOM . fromUTF8LBS)
-- | Writes a Unicode String as a UTF8 encoded text file.
--
-- Uses 'writeFileAtomic', so provides the same guarantees.
---
writeUTF8File :: FilePath -> String -> IO ()
writeUTF8File path = writeFileAtomic path . toUTF8LBS
-- | Fix different systems silly line ending conventions
normaliseLineEndings :: String -> String
normaliseLineEndings [] = []
-normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows
-normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old OS X
-normaliseLineEndings ( c :s) = c : normaliseLineEndings s
+normaliseLineEndings ('\r' : '\n' : s) = '\n' : normaliseLineEndings s -- windows
+normaliseLineEndings ('\r' : s) = '\n' : normaliseLineEndings s -- old OS X
+normaliseLineEndings (c : s) = c : normaliseLineEndings s
-- ------------------------------------------------------------
+
-- * Common utils
+
-- ------------------------------------------------------------
-- | @dropWhileEndLE p@ is equivalent to @reverse . dropWhile p . reverse@, but
@@ -300,9 +311,8 @@ normaliseLineEndings ( c :s) = c : normaliseLineEndings s
-- >>> take 3 $ dropWhileEndLE (<3) [5, 4, 3, 2, 1, undefined]
-- *** Exception: Prelude.undefined
-- ...
---
dropWhileEndLE :: (a -> Bool) -> [a] -> [a]
-dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x:r) []
+dropWhileEndLE p = foldr (\x r -> if null r && p x then [] else x : r) []
-- | @takeWhileEndLE p@ is equivalent to @reverse . takeWhile p . reverse@, but
-- is usually faster (as well as being easier to read).
@@ -310,7 +320,7 @@ takeWhileEndLE :: (a -> Bool) -> [a] -> [a]
takeWhileEndLE p = fst . foldr go ([], False)
where
go x (rest, done)
- | not done && p x = (x:rest, False)
+ | not done && p x = (x : rest, False)
| otherwise = (rest, True)
-- | Like 'Data.List.nub', but has @O(n log n)@ complexity instead of
@@ -325,16 +335,17 @@ ordNubBy :: Ord b => (a -> b) -> [a] -> [a]
ordNubBy f l = go Set.empty l
where
go !_ [] = []
- go !s (x:xs)
+ go !s (x : xs)
| y `Set.member` s = go s xs
- | otherwise = let !s' = Set.insert y s
- in x : go s' xs
+ | otherwise =
+ let !s' = Set.insert y s
+ in x : go s' xs
where
y = f x
-- | Like "Data.List.union", but has @O(n log n)@ complexity instead of
-- @O(n^2)@.
-listUnion :: (Ord a) => [a] -> [a] -> [a]
+listUnion :: Ord a => [a] -> [a] -> [a]
listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b)
where
aSet = Set.fromList a
@@ -348,12 +359,13 @@ listUnion a b = a ++ ordNub (filter (`Set.notMember` aSet) b)
--
-- >>> ordNubRight [1,2,1] :: [Int]
-- [2,1]
---
-ordNubRight :: (Ord a) => [a] -> [a]
+ordNubRight :: Ord a => [a] -> [a]
ordNubRight = fst . foldr go ([], Set.empty)
where
- go x p@(l, s) = if x `Set.member` s then p
- else (x:l, Set.insert x s)
+ go x p@(l, s) =
+ if x `Set.member` s
+ then p
+ else (x : l, Set.insert x s)
-- | A right-biased version of 'listUnion'.
--
@@ -364,8 +376,7 @@ ordNubRight = fst . foldr go ([], Set.empty)
--
-- >>> listUnionRight [1,2,3,4,3] [2,1,1]
-- [4,3,2,1,1]
---
-listUnionRight :: (Ord a) => [a] -> [a] -> [a]
+listUnionRight :: Ord a => [a] -> [a] -> [a]
listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b
where
bSet = Set.fromList b
@@ -374,30 +385,30 @@ listUnionRight a b = ordNubRight (filter (`Set.notMember` bSet) a) ++ b
--
-- @since 3.2.0.0
safeHead :: [a] -> Maybe a
-safeHead [] = Nothing
-safeHead (x:_) = Just x
+safeHead [] = Nothing
+safeHead (x : _) = Just x
-- | A total variant of 'tail'.
--
-- @since 3.2.0.0
safeTail :: [a] -> [a]
-safeTail [] = []
-safeTail (_:xs) = xs
+safeTail [] = []
+safeTail (_ : xs) = xs
-- | A total variant of 'last'.
--
-- @since 3.2.0.0
safeLast :: [a] -> Maybe a
-safeLast [] = Nothing
-safeLast (x:xs) = Just (foldl (\_ a -> a) x xs)
+safeLast [] = Nothing
+safeLast (x : xs) = Just (foldl (\_ a -> a) x xs)
-- | A total variant of 'init'.
--
-- @since 3.2.0.0
safeInit :: [a] -> [a]
-safeInit [] = []
-safeInit [_] = []
-safeInit (x:xs) = x : safeInit xs
+safeInit [] = []
+safeInit [_] = []
+safeInit (x : xs) = x : safeInit xs
equating :: Eq a => (b -> a) -> b -> b -> Bool
equating p x y = p x == p y
@@ -415,7 +426,8 @@ isAscii c = fromEnum c < 0x80
-- | Ascii letters.
isAsciiAlpha :: Char -> Bool
-isAsciiAlpha c = ('a' <= c && c <= 'z')
+isAsciiAlpha c =
+ ('a' <= c && c <= 'z')
|| ('A' <= c && c <= 'Z')
-- | Ascii letters and digits.
@@ -425,17 +437,17 @@ isAsciiAlpha c = ('a' <= c && c <= 'z')
--
-- >>> isAsciiAlphaNum 'ä'
-- False
---
isAsciiAlphaNum :: Char -> Bool
isAsciiAlphaNum c = isAscii c && isAlphaNum c
unintersperse :: Char -> String -> [String]
-unintersperse mark = unfoldr unintersperse1 where
- unintersperse1 str
- | null str = Nothing
- | otherwise =
- let (this, rest) = break (== mark) str in
- Just (this, safeTail rest)
+unintersperse mark = unfoldr unintersperse1
+ where
+ unintersperse1 str
+ | null str = Nothing
+ | otherwise =
+ let (this, rest) = break (== mark) str
+ in Just (this, safeTail rest)
-- | Like 'break', but with 'Maybe' predicate
--
@@ -446,13 +458,13 @@ unintersperse mark = unfoldr unintersperse1 where
-- (["foo","bar"],Nothing)
--
-- @since 2.2
---
breakMaybe :: (a -> Maybe b) -> [a] -> ([a], Maybe (b, [a]))
-breakMaybe f = go id where
- go !acc [] = (acc [], Nothing)
- go !acc (x:xs) = case f x of
- Nothing -> go (acc . (x:)) xs
- Just b -> (acc [], Just (b, xs))
+breakMaybe f = go id
+ where
+ go !acc [] = (acc [], Nothing)
+ go !acc (x : xs) = case f x of
+ Nothing -> go (acc . (x :)) xs
+ Just b -> (acc [], Just (b, xs))
-- | Like 'span' but with 'Maybe' predicate
--
@@ -463,12 +475,11 @@ breakMaybe f = go id where
-- ([1,2],["foo"])
--
-- @since 2.2
---
-spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a])
-spanMaybe _ xs@[] = ([], xs)
-spanMaybe p xs@(x:xs') = case p x of
- Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)
- Nothing -> ([], xs)
+spanMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])
+spanMaybe _ xs@[] = ([], xs)
+spanMaybe p xs@(x : xs') = case p x of
+ Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs)
+ Nothing -> ([], xs)
-- | 'unfoldr' with monadic action.
--
@@ -476,14 +487,14 @@ spanMaybe p xs@(x:xs') = case p x of
-- [3,4,5,6,7]
--
-- @since 2.2
---
unfoldrM :: Monad m => (b -> m (Maybe (a, b))) -> b -> m [a]
-unfoldrM f = go where
+unfoldrM f = go
+ where
go b = do
- m <- f b
- case m of
- Nothing -> return []
- Just (a, b') -> liftM (a :) (go b')
+ m <- f b
+ case m of
+ Nothing -> return []
+ Just (a, b') -> liftM (a :) (go b')
-- | The opposite of 'snoc', which is the reverse of 'cons'
--
@@ -496,10 +507,9 @@ unfoldrM f = go where
-- Nothing
--
-- @since 3.2.0.0
---
unsnoc :: [a] -> Maybe ([a], a)
-unsnoc [] = Nothing
-unsnoc (x:xs) = Just (unsnocNE (x :| xs))
+unsnoc [] = Nothing
+unsnoc (x : xs) = Just (unsnocNE (x :| xs))
-- | Like 'unsnoc', but for 'NonEmpty' so without the 'Maybe'
--
@@ -512,30 +522,32 @@ unsnoc (x:xs) = Just (unsnocNE (x :| xs))
-- ([],1)
--
-- @since 3.2.0.0
---
unsnocNE :: NonEmpty a -> ([a], a)
-unsnocNE (x:|xs) = go x xs where
- go y [] = ([], y)
- go y (z:zs) = let ~(ws, w) = go z zs in (y : ws, w)
+unsnocNE (x :| xs) = go x xs
+ where
+ go y [] = ([], y)
+ go y (z : zs) = let ~(ws, w) = go z zs in (y : ws, w)
-------------------------------------------------------------------------------
-- Triples
-------------------------------------------------------------------------------
-- | @since 3.4.0.0
-fstOf3 :: (a,b,c) -> a
-fstOf3 (a,_,_) = a
+fstOf3 :: (a, b, c) -> a
+fstOf3 (a, _, _) = a
-- | @since 3.4.0.0
-sndOf3 :: (a,b,c) -> b
-sndOf3 (_,b,_) = b
+sndOf3 :: (a, b, c) -> b
+sndOf3 (_, b, _) = b
-- | @since 3.4.0.0
-trdOf3 :: (a,b,c) -> c
-trdOf3 (_,_,c) = c
+trdOf3 :: (a, b, c) -> c
+trdOf3 (_, _, c) = c
-- ------------------------------------------------------------
+
-- * FilePath stuff
+
-- ------------------------------------------------------------
-- | 'isAbsoluteOnAnyPlatform' and 'isRelativeOnAnyPlatform' are like
@@ -559,12 +571,12 @@ trdOf3 (_,_,c) = c
-- the platform independent heuristics.
isAbsoluteOnAnyPlatform :: FilePath -> Bool
-- C:\\directory
-isAbsoluteOnAnyPlatform (drive:':':'\\':_) = isAlpha drive
-isAbsoluteOnAnyPlatform (drive:':':'/':_) = isAlpha drive
+isAbsoluteOnAnyPlatform (drive : ':' : '\\' : _) = isAlpha drive
+isAbsoluteOnAnyPlatform (drive : ':' : '/' : _) = isAlpha drive
-- UNC
-isAbsoluteOnAnyPlatform ('\\':'\\':_) = True
+isAbsoluteOnAnyPlatform ('\\' : '\\' : _) = True
-- Posix root
-isAbsoluteOnAnyPlatform ('/':_) = True
+isAbsoluteOnAnyPlatform ('/' : _) = True
isAbsoluteOnAnyPlatform _ = False
-- | @isRelativeOnAnyPlatform = not . 'isAbsoluteOnAnyPlatform'@
diff --git a/Cabal-syntax/src/Distribution/Utils/MD5.hs b/Cabal-syntax/src/Distribution/Utils/MD5.hs
index 323fbc05023f3a83b72f7f37909a51a37415ec06..f42f91037548f707ea2838a237e52d906f5b69bb 100644
--- a/Cabal-syntax/src/Distribution/Utils/MD5.hs
+++ b/Cabal-syntax/src/Distribution/Utils/MD5.hs
@@ -1,24 +1,26 @@
-module Distribution.Utils.MD5 (
- MD5,
- showMD5,
- md5,
+module Distribution.Utils.MD5
+ ( MD5
+ , showMD5
+ , md5
+
-- * Helpers
- md5FromInteger,
+ , md5FromInteger
+
-- * Binary
- binaryPutMD5,
- binaryGetMD5,
- ) where
+ , binaryPutMD5
+ , binaryGetMD5
+ ) where
-import Data.Binary (Get, Put)
-import Data.Binary.Get (getWord64le)
-import Data.Binary.Put (putWord64le)
-import Data.Bits (complement, shiftR, (.&.))
-import Foreign.Ptr (castPtr)
-import GHC.Fingerprint (Fingerprint (..), fingerprintData)
-import Numeric (showHex)
+import Data.Binary (Get, Put)
+import Data.Binary.Get (getWord64le)
+import Data.Binary.Put (putWord64le)
+import Data.Bits (complement, shiftR, (.&.))
+import Foreign.Ptr (castPtr)
+import GHC.Fingerprint (Fingerprint (..), fingerprintData)
+import Numeric (showHex)
import System.IO.Unsafe (unsafeDupablePerformIO)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BS
type MD5 = Fingerprint
@@ -33,7 +35,8 @@ type MD5 = Fingerprint
--
-- @since 3.2.0.0
showMD5 :: MD5 -> String
-showMD5 (Fingerprint a b) = pad a' ++ pad b' where
+showMD5 (Fingerprint a b) = pad a' ++ pad b'
+ where
a' = showHex a ""
b' = showHex b ""
pad s = replicate (16 - length s) '0' ++ s
@@ -41,20 +44,20 @@ showMD5 (Fingerprint a b) = pad a' ++ pad b' where
-- | @since 3.2.0.0
md5 :: BS.ByteString -> MD5
md5 bs = unsafeDupablePerformIO $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) ->
- fingerprintData (castPtr ptr) len
+ fingerprintData (castPtr ptr) len
-- | @since 3.2.0.0
binaryPutMD5 :: MD5 -> Put
binaryPutMD5 (Fingerprint a b) = do
- putWord64le a
- putWord64le b
+ putWord64le a
+ putWord64le b
-- | @since 3.2.0.0
binaryGetMD5 :: Get MD5
binaryGetMD5 = do
- a <- getWord64le
- b <- getWord64le
- return (Fingerprint a b)
+ a <- getWord64le
+ b <- getWord64le
+ return (Fingerprint a b)
-- |
--
@@ -73,7 +76,8 @@ binaryGetMD5 = do
--
-- @since 3.4.0.0
md5FromInteger :: Integer -> MD5
-md5FromInteger i = Fingerprint hi lo where
+md5FromInteger i = Fingerprint hi lo
+ where
mask = complement 0
- lo = mask .&. fromInteger i
- hi = mask .&. fromInteger (i `shiftR` 64)
+ lo = mask .&. fromInteger i
+ hi = mask .&. fromInteger (i `shiftR` 64)
diff --git a/Cabal-syntax/src/Distribution/Utils/Path.hs b/Cabal-syntax/src/Distribution/Utils/Path.hs
index eb3d11deb962bd4edb0b2bd3e116bacdbbf28803..9da89bdd7f368d4b70dce46166a3829603162be3 100644
--- a/Cabal-syntax/src/Distribution/Utils/Path.hs
+++ b/Cabal-syntax/src/Distribution/Utils/Path.hs
@@ -1,31 +1,36 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
-module Distribution.Utils.Path (
- -- * Symbolic path
- SymbolicPath,
- getSymbolicPath,
- sameDirectory,
- unsafeMakeSymbolicPath,
+
+module Distribution.Utils.Path
+ ( -- * Symbolic path
+ SymbolicPath
+ , getSymbolicPath
+ , sameDirectory
+ , unsafeMakeSymbolicPath
+
-- * Path ends
- PackageDir,
- SourceDir,
- LicenseFile,
- IsDir,
-) where
+ , PackageDir
+ , SourceDir
+ , LicenseFile
+ , IsDir
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Utils.Generic (isAbsoluteOnAnyPlatform)
import qualified Distribution.Compat.CharParsing as P
+
-- import qualified Text.PrettyPrint as Disp
-------------------------------------------------------------------------------
+
-- * SymbolicPath
+
-------------------------------------------------------------------------------
-- | Symbolic paths.
@@ -33,7 +38,6 @@ import qualified Distribution.Compat.CharParsing as P
-- These paths are system independent and relative.
-- They are *symbolic* which means we cannot perform any 'IO'
-- until we interpret them.
---
newtype SymbolicPath from to = SymbolicPath FilePath
deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
@@ -44,7 +48,6 @@ instance NFData (SymbolicPath from to) where rnf = genericRnf
-- | Extract underlying 'FilePath'.
--
-- Avoid using this in new code.
---
getSymbolicPath :: SymbolicPath from to -> FilePath
getSymbolicPath (SymbolicPath p) = p
@@ -56,21 +59,28 @@ unsafeMakeSymbolicPath :: FilePath -> SymbolicPath from to
unsafeMakeSymbolicPath = SymbolicPath
-------------------------------------------------------------------------------
+
-- ** Parsing and pretty printing
+
-------------------------------------------------------------------------------
instance Parsec (SymbolicPath from to) where
- parsec = do
- token <- parsecToken
- if null token then P.unexpected "empty FilePath"
- else if isAbsoluteOnAnyPlatform token then P.unexpected "absolute FilePath"
- else return (SymbolicPath token) -- TODO: normalise
+ parsec = do
+ token <- parsecToken
+ if null token
+ then P.unexpected "empty FilePath"
+ else
+ if isAbsoluteOnAnyPlatform token
+ then P.unexpected "absolute FilePath"
+ else return (SymbolicPath token) -- TODO: normalise
instance Pretty (SymbolicPath from to) where
- pretty = showFilePath . getSymbolicPath
+ pretty = showFilePath . getSymbolicPath
-------------------------------------------------------------------------------
+
-- * Composition
+
-------------------------------------------------------------------------------
-- TODO
@@ -83,14 +93,16 @@ instance Pretty (SymbolicPath from to) where
-- (<//>) :: path a b -> path b c -> path a c
-------------------------------------------------------------------------------
+
-- * Path ends
+
-------------------------------------------------------------------------------
-- | Class telling that index is for directories.
class IsDir dir
data PackageDir deriving (Typeable)
-data SourceDir deriving (Typeable)
+data SourceDir deriving (Typeable)
data LicenseFile deriving (Typeable)
diff --git a/Cabal-syntax/src/Distribution/Utils/ShortText.hs b/Cabal-syntax/src/Distribution/Utils/ShortText.hs
index 8279b4af6feaff1aaa4e9ce56fbe5adcda2b21aa..0b128de96983953d68ad6e2d810d339331a38afb 100644
--- a/Cabal-syntax/src/Distribution/Utils/ShortText.hs
+++ b/Cabal-syntax/src/Distribution/Utils/ShortText.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
-- | Compact representation of short 'Strings'
--
@@ -11,25 +11,25 @@
-- import qualified Distribution.Utils.ShortText as ShortText
-- @
module Distribution.Utils.ShortText
- ( -- * 'ShortText' type
- ShortText
- , toShortText
- , fromShortText
- , unsafeFromUTF8BS
+ ( -- * 'ShortText' type
+ ShortText
+ , toShortText
+ , fromShortText
+ , unsafeFromUTF8BS
- -- * Operations
- , null
- , length
+ -- * Operations
+ , null
+ , length
- -- * internal utilities
- , decodeStringUtf8
- , encodeStringUtf8
- ) where
+ -- * internal utilities
+ , decodeStringUtf8
+ , encodeStringUtf8
+ ) where
import Distribution.Compat.Prelude hiding (length, null)
import Prelude ()
-import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8)
+import Distribution.Utils.String (decodeStringUtf8, encodeStringUtf8)
import Distribution.Utils.Structured (Structured (..), nominalStructure)
#if defined(MIN_VERSION_bytestring)
@@ -56,7 +56,7 @@ import Distribution.Utils.Structured (Structured (..), nominalStructure)
#endif
import qualified Data.ByteString as BS
-import qualified Data.List as List
+import qualified Data.List as List
#if HAVE_SHORTBYTESTRING
import qualified Data.ByteString.Short as BS.Short
@@ -133,27 +133,28 @@ null = List.null . unST
instance Structured ShortText where structure = nominalStructure
instance NFData ShortText where
- rnf = rnf . unST
+ rnf = rnf . unST
instance Show ShortText where
- show = show . fromShortText
+ show = show . fromShortText
instance Read ShortText where
- readsPrec p = map (first toShortText) . readsPrec p
+ readsPrec p = map (first toShortText) . readsPrec p
instance Semigroup ShortText where
- ST a <> ST b = ST (mappend a b)
+ ST a <> ST b = ST (mappend a b)
instance Monoid ShortText where
- mempty = ST mempty
- mappend = (<>)
+ mempty = ST mempty
+ mappend = (<>)
instance IsString ShortText where
- fromString = toShortText
+ fromString = toShortText
-- | /O(n)/. Length in characters. /Slow/ as converts to string.
--
-- @since 3.2.0.0
length :: ShortText -> Int
length = List.length . fromShortText
+
-- Note: avoid using it, we use it @cabal check@ implementation, where it's ok.
diff --git a/Cabal-syntax/src/Distribution/Utils/String.hs b/Cabal-syntax/src/Distribution/Utils/String.hs
index a1cf4633ae9b123182bc402d2d12b29f259216ff..13b022f812cf7ee9694298e04f88e5d13516a048 100644
--- a/Cabal-syntax/src/Distribution/Utils/String.hs
+++ b/Cabal-syntax/src/Distribution/Utils/String.hs
@@ -1,14 +1,14 @@
module Distribution.Utils.String
- ( -- * Encode to/from UTF8
- decodeStringUtf8
- , encodeStringUtf8
- , trim
- ) where
+ ( -- * Encode to/from UTF8
+ decodeStringUtf8
+ , encodeStringUtf8
+ , trim
+ ) where
-import Data.Word
import Data.Bits
-import Data.Char (chr,ord)
+import Data.Char (chr, ord)
import Data.List (dropWhileEnd)
+import Data.Word
import GHC.Unicode (isSpace)
-- | Decode 'String' from UTF8-encoded octets.
@@ -21,46 +21,48 @@ decodeStringUtf8 :: [Word8] -> String
decodeStringUtf8 = go
where
go :: [Word8] -> String
- go [] = []
+ go [] = []
go (c : cs)
| c <= 0x7F = chr (fromIntegral c) : go cs
| c <= 0xBF = replacementChar : go cs
| c <= 0xDF = twoBytes c cs
- | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF)
- | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7)
- | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3)
+ | c <= 0xEF = moreBytes 3 0x800 cs (fromIntegral $ c .&. 0xF)
+ | c <= 0xF7 = moreBytes 4 0x10000 cs (fromIntegral $ c .&. 0x7)
+ | c <= 0xFB = moreBytes 5 0x200000 cs (fromIntegral $ c .&. 0x3)
| c <= 0xFD = moreBytes 6 0x4000000 cs (fromIntegral $ c .&. 0x1)
- | otherwise = replacementChar : go cs
+ | otherwise = replacementChar : go cs
twoBytes :: Word8 -> [Word8] -> String
- twoBytes c0 (c1:cs')
- | c1 .&. 0xC0 == 0x80
- = let d = (fromIntegral (c0 .&. 0x1F) `shiftL` 6)
- .|. fromIntegral (c1 .&. 0x3F)
- in if d >= 0x80
- then chr d : go cs'
- else replacementChar : go cs'
- twoBytes _ cs' = replacementChar : go cs'
+ twoBytes c0 (c1 : cs')
+ | c1 .&. 0xC0 == 0x80 =
+ let d =
+ (fromIntegral (c0 .&. 0x1F) `shiftL` 6)
+ .|. fromIntegral (c1 .&. 0x3F)
+ in if d >= 0x80
+ then chr d : go cs'
+ else replacementChar : go cs'
+ twoBytes _ cs' = replacementChar : go cs'
moreBytes :: Int -> Int -> [Word8] -> Int -> [Char]
moreBytes 1 overlong cs' acc
- | overlong <= acc, acc <= 0x10FFFF, acc < 0xD800 || 0xDFFF < acc
- = chr acc : go cs'
-
- | otherwise
- = replacementChar : go cs'
-
- moreBytes byteCount overlong (cn:cs') acc
- | cn .&. 0xC0 == 0x80
- = moreBytes (byteCount-1) overlong cs'
- ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
-
- moreBytes _ _ cs' _
- = replacementChar : go cs'
+ | overlong <= acc
+ , acc <= 0x10FFFF
+ , acc < 0xD800 || 0xDFFF < acc =
+ chr acc : go cs'
+ | otherwise =
+ replacementChar : go cs'
+ moreBytes byteCount overlong (cn : cs') acc
+ | cn .&. 0xC0 == 0x80 =
+ moreBytes
+ (byteCount - 1)
+ overlong
+ cs'
+ ((acc `shiftL` 6) .|. fromIntegral cn .&. 0x3F)
+ moreBytes _ _ cs' _ =
+ replacementChar : go cs'
replacementChar = '\xfffd'
-
-- | Encode 'String' to a list of UTF8-encoded octets
--
-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded
@@ -68,28 +70,36 @@ decodeStringUtf8 = go
--
-- See also 'decodeUtf8'
encodeStringUtf8 :: String -> [Word8]
-encodeStringUtf8 [] = []
-encodeStringUtf8 (c:cs)
- | c <= '\x07F' = w8
- : encodeStringUtf8 cs
- | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 )
- : (0x80 .|. (w8 .&. 0x3F))
- : encodeStringUtf8 cs
- | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 )
- : (0x80 .|. (w8ShiftR 6 .&. 0x3F))
- : (0x80 .|. (w8 .&. 0x3F))
- : encodeStringUtf8 cs
- | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD
- : encodeStringUtf8 cs
- | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 )
- : (0x80 .|. (w8ShiftR 6 .&. 0x3F))
- : (0x80 .|. (w8 .&. 0x3F))
- : encodeStringUtf8 cs
- | otherwise = (0xf0 .|. w8ShiftR 18 )
- : (0x80 .|. (w8ShiftR 12 .&. 0x3F))
- : (0x80 .|. (w8ShiftR 6 .&. 0x3F))
- : (0x80 .|. (w8 .&. 0x3F))
- : encodeStringUtf8 cs
+encodeStringUtf8 [] = []
+encodeStringUtf8 (c : cs)
+ | c <= '\x07F' =
+ w8
+ : encodeStringUtf8 cs
+ | c <= '\x7FF' =
+ (0xC0 .|. w8ShiftR 6)
+ : (0x80 .|. (w8 .&. 0x3F))
+ : encodeStringUtf8 cs
+ | c <= '\xD7FF' =
+ (0xE0 .|. w8ShiftR 12)
+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))
+ : (0x80 .|. (w8 .&. 0x3F))
+ : encodeStringUtf8 cs
+ | c <= '\xDFFF' =
+ 0xEF
+ : 0xBF
+ : 0xBD -- U+FFFD
+ : encodeStringUtf8 cs
+ | c <= '\xFFFF' =
+ (0xE0 .|. w8ShiftR 12)
+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))
+ : (0x80 .|. (w8 .&. 0x3F))
+ : encodeStringUtf8 cs
+ | otherwise =
+ (0xf0 .|. w8ShiftR 18)
+ : (0x80 .|. (w8ShiftR 12 .&. 0x3F))
+ : (0x80 .|. (w8ShiftR 6 .&. 0x3F))
+ : (0x80 .|. (w8 .&. 0x3F))
+ : encodeStringUtf8 cs
where
w8 = fromIntegral (ord c) :: Word8
w8ShiftR :: Int -> Word8
diff --git a/Cabal-syntax/src/Distribution/Utils/Structured.hs b/Cabal-syntax/src/Distribution/Utils/Structured.hs
index ca3147710c8a8551de1e3f7b88bfaaf899fffada..ba10212bca178ab92e6f5996035b84a34e1a413b 100644
--- a/Cabal-syntax/src/Distribution/Utils/Structured.hs
+++ b/Cabal-syntax/src/Distribution/Utils/Structured.hs
@@ -1,12 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
-- |
--
-- Copyright: (c) 2019 Oleg Grenrus
@@ -38,42 +39,44 @@
--
-- Technically, 'Structured' is not related to 'Binary', and may
-- be useful in other uses.
---
-module Distribution.Utils.Structured (
- -- * Encoding and decoding
+module Distribution.Utils.Structured
+ ( -- * Encoding and decoding
+
-- | These functions operate like @binary@'s counterparts,
-- but the serialised version has a structure hash in front.
- structuredEncode,
- structuredEncodeFile,
- structuredDecode,
- structuredDecodeOrFailIO,
- structuredDecodeFileOrFail,
+ structuredEncode
+ , structuredEncodeFile
+ , structuredDecode
+ , structuredDecodeOrFailIO
+ , structuredDecodeFileOrFail
+
-- * Structured class
- Structured (structure),
- MD5,
- structureHash,
- structureBuilder,
- genericStructure,
- GStructured,
- nominalStructure,
- containerStructure,
+ , Structured (structure)
+ , MD5
+ , structureHash
+ , structureBuilder
+ , genericStructure
+ , GStructured
+ , nominalStructure
+ , containerStructure
+
-- * Structure type
- Structure (..),
- Tag (..),
- TypeName,
- ConstructorName,
- TypeVersion,
- SopStructure,
- hashStructure,
- typeVersion,
- typeName,
- ) where
-
-import Data.Int (Int16, Int32, Int64, Int8)
+ , Structure (..)
+ , Tag (..)
+ , TypeName
+ , ConstructorName
+ , TypeVersion
+ , SopStructure
+ , hashStructure
+ , typeVersion
+ , typeName
+ ) where
+
+import Data.Int (Int16, Int32, Int64, Int8)
import Data.List.NonEmpty (NonEmpty)
-import Data.Proxy (Proxy (..))
-import Data.Ratio (Ratio)
-import Data.Word (Word, Word16, Word32, Word64, Word8)
+import Data.Proxy (Proxy (..))
+import Data.Ratio (Ratio)
+import Data.Word (Word, Word16, Word32, Word64, Word8)
import qualified Control.Monad.Trans.State.Strict as State
@@ -81,22 +84,22 @@ import Control.Exception (ErrorCall (..), catch, evaluate)
import GHC.Generics
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
#if MIN_VERSION_bytestring(0,10,4)
import qualified Data.ByteString.Builder as Builder
#else
import qualified Data.ByteString.Lazy.Builder as Builder
#endif
-import qualified Data.IntMap as IM
-import qualified Data.IntSet as IS
-import qualified Data.Map as Map
-import qualified Data.Sequence as Seq
-import qualified Data.Set as Set
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import qualified Data.Time as Time
-import qualified Distribution.Compat.Binary as Binary
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Time as Time
+import qualified Distribution.Compat.Binary as Binary
#ifdef MIN_VERSION_aeson
import qualified Data.Aeson as Aeson
@@ -104,34 +107,35 @@ import qualified Data.Aeson as Aeson
import Data.Kind (Type)
-import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep)
+import Distribution.Compat.Typeable (TypeRep, Typeable, typeRep)
import Distribution.Utils.MD5
import Data.Monoid (mconcat)
-import qualified Data.Semigroup
import qualified Data.Foldable
-
+import qualified Data.Semigroup
-------------------------------------------------------------------------------
-- Types
-------------------------------------------------------------------------------
-type TypeName = String
+type TypeName = String
type ConstructorName = String
-- | A semantic version of a data type. Usually 0.
-type TypeVersion = Word32
+type TypeVersion = Word32
-- | Structure of a datatype.
--
-- It can be infinite, as far as 'TypeRep's involved are finite.
-- (e.g. polymorphic recursion might cause troubles).
---
data Structure
- = Nominal !TypeRep !TypeVersion TypeName [Structure] -- ^ nominal, yet can be parametrised by other structures.
- | Newtype !TypeRep !TypeVersion TypeName Structure -- ^ a newtype wrapper
- | Structure !TypeRep !TypeVersion TypeName SopStructure -- ^ sum-of-products structure
+ = -- | nominal, yet can be parametrised by other structures.
+ Nominal !TypeRep !TypeVersion TypeName [Structure]
+ | -- | a newtype wrapper
+ Newtype !TypeRep !TypeVersion TypeName Structure
+ | -- | sum-of-products structure
+ Structure !TypeRep !TypeVersion TypeName SopStructure
deriving (Eq, Ord, Show, Generic)
type SopStructure = [(ConstructorName, [Structure])]
@@ -146,8 +150,8 @@ hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder
-- 'typeVersion' :: Lens' 'Structure' 'TypeVersion'
-- @
typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure
-typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v)
-typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v)
+typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v)
+typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v)
typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v)
-- | A van-Laarhoven lens into 'TypeName' of 'Structure'
@@ -156,8 +160,8 @@ typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v)
-- 'typeName' :: Lens' 'Structure' 'TypeName'
-- @
typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure
-typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n)
-typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n)
+typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n)
+typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n)
typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n)
-------------------------------------------------------------------------------
@@ -170,45 +174,45 @@ typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n)
-- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred
-- another time.
structureBuilder :: Structure -> Builder.Builder
-structureBuilder s0 = State.evalState (go s0) Map.empty where
+structureBuilder s0 = State.evalState (go s0) Map.empty
+ where
go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder
- go (Nominal t v n s) = withTypeRep t $ do
- s' <- traverse go s
- return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s'
-
- go (Newtype t v n s) = withTypeRep t $ do
- s' <- go s
- return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s']
-
+ go (Nominal t v n s) = withTypeRep t $ do
+ s' <- traverse go s
+ return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s'
+ go (Newtype t v n s) = withTypeRep t $ do
+ s' <- go s
+ return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s']
go (Structure t v n s) = withTypeRep t $ do
- s' <- goSop s
- return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s']
+ s' <- goSop s
+ return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s']
withTypeRep t k = do
- acc <- State.get
- case insert t acc of
- Nothing -> return $ mconcat [ Builder.word8 0, Builder.stringUtf8 (show t) ]
- Just acc' -> do
- State.put acc'
- k
+ acc <- State.get
+ case insert t acc of
+ Nothing -> return $ mconcat [Builder.word8 0, Builder.stringUtf8 (show t)]
+ Just acc' -> do
+ State.put acc'
+ k
goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder
goSop sop = do
- parts <- traverse part sop
- return $ mconcat parts
+ parts <- traverse part sop
+ return $ mconcat parts
part (cn, s) = do
- s' <- traverse go s
- return $ Data.Monoid.mconcat [ Builder.stringUtf8 cn, mconcat s' ]
+ s' <- traverse go s
+ return $ Data.Monoid.mconcat [Builder.stringUtf8 cn, mconcat s']
insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep))
insert tr m = case Map.lookup trShown m of
- Nothing -> inserted
- Just ne | tr `Data.Foldable.elem` ne -> Nothing
- | otherwise -> inserted
+ Nothing -> inserted
+ Just ne
+ | tr `Data.Foldable.elem` ne -> Nothing
+ | otherwise -> inserted
where
inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m)
- trShown = show tr
+ trShown = show tr
-------------------------------------------------------------------------------
-- Classes
@@ -224,18 +228,17 @@ structureBuilder s0 = State.evalState (go s0) Map.empty where
-- @
--
-- @since 3.2.0.0
---
class Typeable a => Structured a where
- structure :: Proxy a -> Structure
- default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure
- structure = genericStructure
+ structure :: Proxy a -> Structure
+ default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure
+ structure = genericStructure
- -- This member is hidden. It's there to precalc
- structureHash' :: Tagged a MD5
- structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a)))
+ -- This member is hidden. It's there to precalc
+ structureHash' :: Tagged a MD5
+ structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a)))
-- private Tagged
-newtype Tagged a b = Tagged { untag :: b }
+newtype Tagged a b = Tagged {untag :: b}
-- | Semantically @'hashStructure' . 'structure'@.
structureHash :: forall a. Structured a => Proxy a -> MD5
@@ -249,8 +252,10 @@ structureHash _ = untag (structureHash' :: Tagged a MD5)
-- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'.
-- Encoding starts with 16 byte large structure hash.
structuredEncode
- :: forall a. (Binary.Binary a, Structured a)
- => a -> LBS.ByteString
+ :: forall a
+ . (Binary.Binary a, Structured a)
+ => a
+ -> LBS.ByteString
structuredEncode x = Binary.encode (Tag :: Tag a, x)
-- | Lazily serialise a value to a file
@@ -261,13 +266,15 @@ structuredEncodeFile f = LBS.writeFile f . structuredEncode
-- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure.
-- Throws pure exception on invalid inputs.
structuredDecode
- :: forall a. (Binary.Binary a, Structured a)
- => LBS.ByteString -> a
+ :: forall a
+ . (Binary.Binary a, Structured a)
+ => LBS.ByteString
+ -> a
structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a))
structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)
structuredDecodeOrFailIO bs =
- catch (evaluate (structuredDecode bs) >>= return . Right) handler
+ catch (evaluate (structuredDecode bs) >>= return . Right) handler
where
handler (ErrorCallWithLocation str _) = return $ Left str
@@ -282,22 +289,24 @@ structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f
data Tag a = Tag
instance Structured a => Binary.Binary (Tag a) where
- get = do
- actual <- binaryGetMD5
- if actual == expected
- then return Tag
- else fail $ concat
+ get = do
+ actual <- binaryGetMD5
+ if actual == expected
+ then return Tag
+ else
+ fail $
+ concat
[ "Non-matching structured hashes: "
, showMD5 actual
, "; expected: "
, showMD5 expected
]
- where
- expected = untag (structureHash' :: Tagged a MD5)
+ where
+ expected = untag (structureHash' :: Tagged a MD5)
- put _ = binaryPutMD5 expected
- where
- expected = untag (structureHash' :: Tagged a MD5)
+ put _ = binaryPutMD5 expected
+ where
+ expected = untag (structureHash' :: Tagged a MD5)
-------------------------------------------------------------------------------
-- Smart constructors
@@ -305,15 +314,20 @@ instance Structured a => Binary.Binary (Tag a) where
-- | Use 'Typeable' to infer name
nominalStructure :: Typeable a => Proxy a -> Structure
-nominalStructure p = Nominal tr 0 (show tr) [] where
+nominalStructure p = Nominal tr 0 (show tr) []
+ where
tr = typeRep p
containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure
-containerStructure _ = Nominal faTypeRep 0 (show fTypeRep)
+containerStructure _ =
+ Nominal
+ faTypeRep
+ 0
+ (show fTypeRep)
[ structure (Proxy :: Proxy a)
]
where
- fTypeRep = typeRep (Proxy :: Proxy f)
+ fTypeRep = typeRep (Proxy :: Proxy f)
faTypeRep = typeRep (Proxy :: Proxy (f a))
-------------------------------------------------------------------------------
@@ -326,50 +340,50 @@ genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (R
-- | Used to implement 'genericStructure'.
class GStructured (f :: Type -> Type) where
- gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure
+ gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure
instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where
- gstructured tr _ v = case sop of
- [(_, [s])] | isNewtype p -> Newtype tr v name s
- _ -> Structure tr v name sop
- where
- p = undefined :: M1 i c f ()
- name = datatypeName p
- sop = gstructuredSum (Proxy :: Proxy f) []
+ gstructured tr _ v = case sop of
+ [(_, [s])] | isNewtype p -> Newtype tr v name s
+ _ -> Structure tr v name sop
+ where
+ p = undefined :: M1 i c f ()
+ name = datatypeName p
+ sop = gstructuredSum (Proxy :: Proxy f) []
class GStructuredSum (f :: Type -> Type) where
- gstructuredSum :: Proxy f -> SopStructure -> SopStructure
+ gstructuredSum :: Proxy f -> SopStructure -> SopStructure
instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where
- gstructuredSum _ xs = (name, prod) : xs
- where
- name = conName (undefined :: M1 i c f ())
- prod = gstructuredProd (Proxy :: Proxy f) []
+ gstructuredSum _ xs = (name, prod) : xs
+ where
+ name = conName (undefined :: M1 i c f ())
+ prod = gstructuredProd (Proxy :: Proxy f) []
instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where
- gstructuredSum _ xs
- = gstructuredSum (Proxy :: Proxy f)
- $ gstructuredSum (Proxy :: Proxy g) xs
+ gstructuredSum _ xs =
+ gstructuredSum (Proxy :: Proxy f) $
+ gstructuredSum (Proxy :: Proxy g) xs
instance GStructuredSum V1 where
- gstructuredSum _ = id
+ gstructuredSum _ = id
class GStructuredProd (f :: Type -> Type) where
- gstructuredProd :: Proxy f -> [Structure] -> [Structure]
+ gstructuredProd :: Proxy f -> [Structure] -> [Structure]
instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where
- gstructuredProd _ = gstructuredProd (Proxy :: Proxy f)
+ gstructuredProd _ = gstructuredProd (Proxy :: Proxy f)
instance Structured c => GStructuredProd (K1 i c) where
- gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs
+ gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs
instance GStructuredProd U1 where
- gstructuredProd _ = id
+ gstructuredProd _ = id
instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where
- gstructuredProd _ xs
- = gstructuredProd (Proxy :: Proxy f)
- $ gstructuredProd (Proxy :: Proxy g) xs
+ gstructuredProd _ xs =
+ gstructuredProd (Proxy :: Proxy f) $
+ gstructuredProd (Proxy :: Proxy g) xs
-------------------------------------------------------------------------------
-- instances
@@ -379,23 +393,23 @@ instance Structured ()
instance Structured Bool
instance Structured Ordering
-instance Structured Char where structure = nominalStructure
-instance Structured Int where structure = nominalStructure
+instance Structured Char where structure = nominalStructure
+instance Structured Int where structure = nominalStructure
instance Structured Integer where structure = nominalStructure
instance Structured Data.Word.Word where structure = nominalStructure
-instance Structured Int8 where structure = nominalStructure
+instance Structured Int8 where structure = nominalStructure
instance Structured Int16 where structure = nominalStructure
instance Structured Int32 where structure = nominalStructure
instance Structured Int64 where structure = nominalStructure
-instance Structured Word8 where structure = nominalStructure
+instance Structured Word8 where structure = nominalStructure
instance Structured Word16 where structure = nominalStructure
instance Structured Word32 where structure = nominalStructure
instance Structured Word64 where structure = nominalStructure
-instance Structured Float where structure = nominalStructure
+instance Structured Float where structure = nominalStructure
instance Structured Double where structure = nominalStructure
instance Structured a => Structured (Maybe a)
@@ -417,17 +431,17 @@ instance Structured LBS.ByteString where structure = nominalStructure
instance Structured T.Text where structure = nominalStructure
instance Structured LT.Text where structure = nominalStructure
-instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [ structure (Proxy :: Proxy k), structure (Proxy :: Proxy v) ]
-instance (Structured k) => Structured (Set.Set k) where structure = containerStructure
-instance (Structured v) => Structured (IM.IntMap v) where structure = containerStructure
+instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [structure (Proxy :: Proxy k), structure (Proxy :: Proxy v)]
+instance Structured k => Structured (Set.Set k) where structure = containerStructure
+instance Structured v => Structured (IM.IntMap v) where structure = containerStructure
instance Structured IS.IntSet where structure = nominalStructure
-instance (Structured v) => Structured (Seq.Seq v) where structure = containerStructure
+instance Structured v => Structured (Seq.Seq v) where structure = containerStructure
-instance Structured Time.UTCTime where structure = nominalStructure
-instance Structured Time.DiffTime where structure = nominalStructure
-instance Structured Time.UniversalTime where structure = nominalStructure
+instance Structured Time.UTCTime where structure = nominalStructure
+instance Structured Time.DiffTime where structure = nominalStructure
+instance Structured Time.UniversalTime where structure = nominalStructure
instance Structured Time.NominalDiffTime where structure = nominalStructure
-instance Structured Time.Day where structure = nominalStructure
-instance Structured Time.TimeZone where structure = nominalStructure
-instance Structured Time.TimeOfDay where structure = nominalStructure
-instance Structured Time.LocalTime where structure = nominalStructure
+instance Structured Time.Day where structure = nominalStructure
+instance Structured Time.TimeZone where structure = nominalStructure
+instance Structured Time.TimeOfDay where structure = nominalStructure
+instance Structured Time.LocalTime where structure = nominalStructure
diff --git a/Cabal-syntax/src/Distribution/Version.hs b/Cabal-syntax/src/Distribution/Version.hs
index 33e2885af7e26ea081e3d2e1f3d5ab06f601cce8..80383358037e3233f1e05cdba97204606ce4e417 100644
--- a/Cabal-syntax/src/Distribution/Version.hs
+++ b/Cabal-syntax/src/Distribution/Version.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Version
-- Copyright : Isaac Jones, Simon Marlow 2003-2004
@@ -11,83 +12,86 @@
-- Exports the 'Version' type along with a parser and pretty printer. A version
-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data
-- types. Version ranges are like @\">= 1.2 && < 2\"@.
-
-module Distribution.Version (
- -- * Package versions
- Version,
- version0,
- mkVersion,
- mkVersion',
- versionNumbers,
- nullVersion,
- alterVersion,
-
- -- * Version ranges
- VersionRange,
-
- -- ** Constructing
- anyVersion, noVersion,
- thisVersion, notThisVersion,
- laterVersion, earlierVersion,
- orLaterVersion, orEarlierVersion,
- unionVersionRanges, intersectVersionRanges,
- withinVersion,
- majorBoundVersion,
-
- -- ** Inspection
- withinRange,
- isAnyVersion,
- isNoVersion,
- isSpecificVersion,
- simplifyVersionRange,
- foldVersionRange,
- normaliseVersionRange,
- stripParensVersionRange,
- hasUpperBound,
- hasLowerBound,
-
- -- ** Cata & ana
- VersionRangeF (..),
- cataVersionRange,
- anaVersionRange,
- hyloVersionRange,
- projectVersionRange,
- embedVersionRange,
-
- -- ** Utilities
- wildcardUpperBound,
- majorUpperBound,
-
- -- ** Modification
- removeUpperBound,
- removeLowerBound,
- transformCaret,
- transformCaretUpper,
- transformCaretLower,
-
- -- * Version intervals view
- asVersionIntervals,
- VersionInterval(..),
- LowerBound(..),
- UpperBound(..),
- Bound(..),
-
- -- ** 'VersionIntervals' abstract type
- -- | The 'VersionIntervals' type and the accompanying functions are exposed
- -- primarily for completeness and testing purposes. In practice
- -- 'asVersionIntervals' is the main function to use to
- -- view a 'VersionRange' as a bunch of 'VersionInterval's.
- --
- VersionIntervals,
- toVersionIntervals,
- fromVersionIntervals,
- unVersionIntervals,
-
- ) where
+module Distribution.Version
+ ( -- * Package versions
+ Version
+ , version0
+ , mkVersion
+ , mkVersion'
+ , versionNumbers
+ , nullVersion
+ , alterVersion
+
+ -- * Version ranges
+ , VersionRange
+
+ -- ** Constructing
+ , anyVersion
+ , noVersion
+ , thisVersion
+ , notThisVersion
+ , laterVersion
+ , earlierVersion
+ , orLaterVersion
+ , orEarlierVersion
+ , unionVersionRanges
+ , intersectVersionRanges
+ , withinVersion
+ , majorBoundVersion
+
+ -- ** Inspection
+ , withinRange
+ , isAnyVersion
+ , isNoVersion
+ , isSpecificVersion
+ , simplifyVersionRange
+ , foldVersionRange
+ , normaliseVersionRange
+ , stripParensVersionRange
+ , hasUpperBound
+ , hasLowerBound
+
+ -- ** Cata & ana
+ , VersionRangeF (..)
+ , cataVersionRange
+ , anaVersionRange
+ , hyloVersionRange
+ , projectVersionRange
+ , embedVersionRange
+
+ -- ** Utilities
+ , wildcardUpperBound
+ , majorUpperBound
+
+ -- ** Modification
+ , removeUpperBound
+ , removeLowerBound
+ , transformCaret
+ , transformCaretUpper
+ , transformCaretLower
+
+ -- * Version intervals view
+ , asVersionIntervals
+ , VersionInterval (..)
+ , LowerBound (..)
+ , UpperBound (..)
+ , Bound (..)
+
+ -- ** 'VersionIntervals' abstract type
+
+ -- | The 'VersionIntervals' type and the accompanying functions are exposed
+ -- primarily for completeness and testing purposes. In practice
+ -- 'asVersionIntervals' is the main function to use to
+ -- view a 'VersionRange' as a bunch of 'VersionInterval's.
+ , VersionIntervals
+ , toVersionIntervals
+ , fromVersionIntervals
+ , unVersionIntervals
+ ) where
import Distribution.Types.Version
-import Distribution.Types.VersionRange
import Distribution.Types.VersionInterval
+import Distribution.Types.VersionRange
-------------------------------------------------------------------------------
-- Utilities on VersionRange requiring VersionInterval
@@ -99,22 +103,20 @@ import Distribution.Types.VersionInterval
-- For example this is @True@ (for all @v@):
--
-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v)
---
isNoVersion :: VersionRange -> Bool
isNoVersion vr = case asVersionIntervals vr of
[] -> True
- _ -> False
+ _ -> False
-- | Is this version range in fact just a specific version?
--
-- For example the version range @\">= 3 && <= 3\"@ contains only the version
-- @3@.
---
isSpecificVersion :: VersionRange -> Maybe Version
isSpecificVersion vr = case asVersionIntervals vr of
- [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)]
+ [VersionInterval (LowerBound v InclusiveBound) (UpperBound v' InclusiveBound)]
| v == v' -> Just v
- _ -> Nothing
+ _ -> Nothing
-------------------------------------------------------------------------------
-- Transformations
@@ -135,14 +137,13 @@ isSpecificVersion vr = case asVersionIntervals vr of
-- > ==> simplifyVersionRange r = simplifyVersionRange r'
-- > || isNoVersion r
-- > || isNoVersion r'
---
simplifyVersionRange :: VersionRange -> VersionRange
simplifyVersionRange vr
- -- If the version range is inconsistent then we just return the
- -- original since that has more information than ">1 && < 1", which
- -- is the canonical inconsistent version range.
- | null (unVersionIntervals vi) = vr
- | otherwise = fromVersionIntervals vi
+ -- If the version range is inconsistent then we just return the
+ -- original since that has more information than ">1 && < 1", which
+ -- is the canonical inconsistent version range.
+ | null (unVersionIntervals vi) = vr
+ | otherwise = fromVersionIntervals vi
where
vi = toVersionIntervals vr
@@ -160,26 +161,26 @@ removeLowerBound = fromVersionIntervals . relaxHeadInterval . toVersionIntervals
-- | Rewrite @^>= x.y.z@ into @>= x.y.z && < x.(y+1)@
--
-- @since 3.6.0.0
---
transformCaret :: VersionRange -> VersionRange
-transformCaret = hyloVersionRange embed projectVersionRange where
+transformCaret = hyloVersionRange embed projectVersionRange
+ where
embed (MajorBoundVersionF v) = orLaterVersion v `intersectVersionRanges` earlierVersion (majorUpperBound v)
- embed vr = embedVersionRange vr
+ embed vr = embedVersionRange vr
-- | Rewrite @^>= x.y.z@ into @>= x.y.z@
--
-- @since 3.6.0.0
---
transformCaretUpper :: VersionRange -> VersionRange
-transformCaretUpper = hyloVersionRange embed projectVersionRange where
+transformCaretUpper = hyloVersionRange embed projectVersionRange
+ where
embed (MajorBoundVersionF v) = orLaterVersion v
- embed vr = embedVersionRange vr
+ embed vr = embedVersionRange vr
-- | Rewrite @^>= x.y.z@ into @<x.(y+1)@
--
-- @since 3.6.0.0
---
transformCaretLower :: VersionRange -> VersionRange
-transformCaretLower = hyloVersionRange embed projectVersionRange where
+transformCaretLower = hyloVersionRange embed projectVersionRange
+ where
embed (MajorBoundVersionF v) = earlierVersion (majorUpperBound v)
- embed vr = embedVersionRange vr
+ embed vr = embedVersionRange vr
diff --git a/Cabal-syntax/src/Language/Haskell/Extension.hs b/Cabal-syntax/src/Language/Haskell/Extension.hs
index b7adc1c7e7e103ba74bb0ce8f72b983d5d5f7efc..669e569c23994f56505987e5709ffaf79faf5c62 100644
--- a/Cabal-syntax/src/Language/Haskell/Extension.hs
+++ b/Cabal-syntax/src/Language/Haskell/Extension.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE OverloadedStrings #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Language.Haskell.Extension
-- Copyright : Isaac Jones 2003-2004
@@ -12,22 +13,20 @@
-- Portability : portable
--
-- Haskell language dialects and extensions
-
-module Language.Haskell.Extension (
- Language(..),
- knownLanguages,
- classifyLanguage,
-
- Extension(..),
- KnownExtension(..),
- deprecatedExtensions,
- classifyExtension,
- knownExtensions
+module Language.Haskell.Extension
+ ( Language (..)
+ , knownLanguages
+ , classifyLanguage
+ , Extension (..)
+ , KnownExtension (..)
+ , deprecatedExtensions
+ , classifyExtension
+ , knownExtensions
) where
import Distribution.Compat.Prelude
-import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))
+import Data.Array (Array, Ix (inRange), accumArray, bounds, (!))
import Distribution.Parsec
import Distribution.Pretty
@@ -36,30 +35,27 @@ import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
-- ------------------------------------------------------------
+
-- * Language
+
-- ------------------------------------------------------------
-- | This represents a Haskell language dialect.
--
-- Language 'Extension's are interpreted relative to one of these base
-- languages.
---
-data Language =
-
- -- | The Haskell 98 language as defined by the Haskell 98 report.
- -- <http://haskell.org/onlinereport/>
- Haskell98
-
- -- | The Haskell 2010 language as defined by the Haskell 2010 report.
- -- <http://www.haskell.org/onlinereport/haskell2010>
- | Haskell2010
-
- -- | The GHC2021 collection of language extensions.
- -- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0380-ghc2021.rst>
- | GHC2021
-
- -- | An unknown language, identified by its name.
- | UnknownLanguage String
+data Language
+ = -- | The Haskell 98 language as defined by the Haskell 98 report.
+ -- <http://haskell.org/onlinereport/>
+ Haskell98
+ | -- | The Haskell 2010 language as defined by the Haskell 2010 report.
+ -- <http://www.haskell.org/onlinereport/haskell2010>
+ Haskell2010
+ | -- | The GHC2021 collection of language extensions.
+ -- <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0380-ghc2021.rst>
+ GHC2021
+ | -- | An unknown language, identified by its name.
+ UnknownLanguage String
deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary Language
@@ -73,46 +69,49 @@ knownLanguages = [Haskell98, Haskell2010, GHC2021]
instance Pretty Language where
pretty (UnknownLanguage other) = Disp.text other
- pretty other = Disp.text (show other)
+ pretty other = Disp.text (show other)
instance Parsec Language where
parsec = classifyLanguage <$> P.munch1 isAlphaNum
classifyLanguage :: String -> Language
classifyLanguage = \str -> case lookup str langTable of
- Just lang -> lang
- Nothing -> UnknownLanguage str
+ Just lang -> lang
+ Nothing -> UnknownLanguage str
where
- langTable = [ (show lang, lang)
- | lang <- knownLanguages ]
+ langTable =
+ [ (show lang, lang)
+ | lang <- knownLanguages
+ ]
-- ------------------------------------------------------------
+
-- * Extension
+
-- ------------------------------------------------------------
-- Note: if you add a new 'KnownExtension':
--
+
-- * also add it to the Distribution.Simple.X.languageExtensions lists
+
-- (where X is each compiler: GHC, UHC, HaskellSuite)
--
+
-- | This represents language extensions beyond a base 'Language' definition
-- (such as 'Haskell98') that are supported by some implementations, usually
-- in some special mode.
--
-- Where applicable, references are given to an implementation's
-- official documentation.
-
-data Extension =
- -- | Enable a known extension
+data Extension
+ = -- | Enable a known extension
EnableExtension KnownExtension
-
- -- | Disable a known extension
- | DisableExtension KnownExtension
-
- -- | An unknown extension, identified by the name of its @LANGUAGE@
- -- pragma.
- | UnknownExtension String
-
+ | -- | Disable a known extension
+ DisableExtension KnownExtension
+ | -- | An unknown extension, identified by the name of its @LANGUAGE@
+ -- pragma.
+ UnknownExtension String
deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary Extension
@@ -125,567 +124,420 @@ instance NFData Extension where rnf = genericRnf
--
-- Check <https://downloads.haskell.org/~ghc/9.2.3/docs/html/users_guide/exts/table.html “Overview of all language extensions” in GHC User’s Guide>
-- for more information.
-data KnownExtension =
-
- -- | Allow overlapping class instances, provided there is a unique
- -- most specific instance for each use.
+data KnownExtension
+ = -- | Allow overlapping class instances, provided there is a unique
+ -- most specific instance for each use.
OverlappingInstances
-
- -- | Ignore structural rules guaranteeing the termination of class
- -- instance resolution. Termination is guaranteed by a fixed-depth
- -- recursion stack, and compilation may fail if this depth is
- -- exceeded.
- | UndecidableInstances
-
- -- | Implies 'OverlappingInstances'. Allow the implementation to
- -- choose an instance even when it is possible that further
- -- instantiation of types will lead to a more specific instance
- -- being applicable.
- | IncoherentInstances
-
- -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'.
- --
- -- Old description: Allow recursive bindings in @do@ blocks, using
- -- the @rec@ keyword. See also 'RecursiveDo'.
- | DoRec
-
- -- | Allow recursive bindings in @do@ blocks, using the @rec@
- -- keyword, or @mdo@, a variant of @do@.
- | RecursiveDo
-
- -- | Provide syntax for writing list comprehensions which iterate
- -- over several lists together, like the 'zipWith' family of
- -- functions.
- | ParallelListComp
-
- -- | Allow multiple parameters in a type class.
- | MultiParamTypeClasses
-
- -- | Enable the dreaded monomorphism restriction.
- | MonomorphismRestriction
-
- -- | Enable deep subsumption, relaxing the simple subsumption rules,
- -- implicitly inserting eta-expansions when matching up function types
- -- with different quantification structures.
- | DeepSubsumption
-
- -- | Allow a specification attached to a multi-parameter type class
- -- which indicates that some parameters are entirely determined by
- -- others. The implementation will check that this property holds
- -- for the declared instances, and will use this property to reduce
- -- ambiguity in instance resolution.
- | FunctionalDependencies
-
- -- | /(deprecated)/ A synonym for 'RankNTypes'.
- --
- -- Old description: Like 'RankNTypes' but does not allow a
- -- higher-rank type to itself appear on the left of a function
- -- arrow.
- | Rank2Types
-
- -- | Allow a universally-quantified type to occur on the left of a
- -- function arrow.
- | RankNTypes
-
- -- | /(deprecated)/ A synonym for 'RankNTypes'.
- --
- -- Old description: Allow data constructors to have polymorphic
- -- arguments. Unlike 'RankNTypes', does not allow this for ordinary
- -- functions.
- | PolymorphicComponents
-
- -- | Allow existentially-quantified data constructors.
- | ExistentialQuantification
-
- -- | Cause a type variable in a signature, which has an explicit
- -- @forall@ quantifier, to scope over the definition of the
- -- accompanying value declaration.
- | ScopedTypeVariables
-
- -- | Deprecated, use 'ScopedTypeVariables' instead.
- | PatternSignatures
-
- -- | Enable implicit function parameters with dynamic scope.
- | ImplicitParams
-
- -- | Relax some restrictions on the form of the context of a type
- -- signature.
- | FlexibleContexts
-
- -- | Relax some restrictions on the form of the context of an
- -- instance declaration.
- | FlexibleInstances
-
- -- | Allow data type declarations with no constructors.
- | EmptyDataDecls
-
- -- | Run the C preprocessor on Haskell source code.
- | CPP
-
- -- | Allow an explicit kind signature giving the kind of types over
- -- which a type variable ranges.
- | KindSignatures
-
- -- | Enable a form of pattern which forces evaluation before an
- -- attempted match, and a form of strict @let@/@where@ binding.
- | BangPatterns
-
- -- | Allow type synonyms in instance heads.
- | TypeSynonymInstances
-
- -- | Enable Template Haskell, a system for compile-time
- -- metaprogramming.
- | TemplateHaskell
-
- -- | Enable the Foreign Function Interface. In GHC, implements the
- -- standard Haskell 98 Foreign Function Interface Addendum, plus
- -- some GHC-specific extensions.
- | ForeignFunctionInterface
-
- -- | Enable arrow notation.
- | Arrows
-
- -- | /(deprecated)/ Enable generic type classes, with default instances defined in
- -- terms of the algebraic structure of a type.
- | Generics
-
- -- | Enable the implicit importing of the module "Prelude". When
- -- disabled, when desugaring certain built-in syntax into ordinary
- -- identifiers, use whatever is in scope rather than the "Prelude"
- -- -- version.
- | ImplicitPrelude
-
- -- | Enable syntax for implicitly binding local names corresponding
- -- to the field names of a record. Puns bind specific names, unlike
- -- 'RecordWildCards'.
- | NamedFieldPuns
-
- -- | Enable a form of guard which matches a pattern and binds
- -- variables.
- | PatternGuards
-
- -- | Allow a type declared with @newtype@ to use @deriving@ for any
- -- class with an instance for the underlying type.
- | GeneralizedNewtypeDeriving
-
- -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1.
- | GeneralisedNewtypeDeriving
-
- -- | Enable the \"Trex\" extensible records system.
- | ExtensibleRecords
-
- -- | Enable type synonyms which are transparent in some definitions
- -- and opaque elsewhere, as a way of implementing abstract
- -- datatypes.
- | RestrictedTypeSynonyms
-
- -- | Enable an alternate syntax for string literals,
- -- with string templating.
- | HereDocuments
-
- -- | Allow the character @#@ as a postfix modifier on identifiers.
- -- Also enables literal syntax for unboxed values.
- | MagicHash
-
- -- | Allow data types and type synonyms which are indexed by types,
- -- i.e. ad-hoc polymorphism for types.
- | TypeFamilies
-
- -- | Allow a standalone declaration which invokes the type class
- -- @deriving@ mechanism.
- | StandaloneDeriving
-
- -- | Allow certain Unicode characters to stand for certain ASCII
- -- character sequences, e.g. keywords and punctuation.
- | UnicodeSyntax
-
- -- | Allow the use of unboxed types as foreign types, e.g. in
- -- @foreign import@ and @foreign export@.
- | UnliftedFFITypes
-
- -- | Enable interruptible FFI.
- | InterruptibleFFI
-
- -- | Allow use of CAPI FFI calling convention (@foreign import capi@).
- | CApiFFI
-
- -- | Defer validity checking of types until after expanding type
- -- synonyms, relaxing the constraints on how synonyms may be used.
- | LiberalTypeSynonyms
-
- -- | Allow the name of a type constructor, type class, or type
- -- variable to be an infix operator.
- | TypeOperators
-
- -- | Enable syntax for implicitly binding local names corresponding
- -- to the field names of a record. A wildcard binds all unmentioned
- -- names, unlike 'NamedFieldPuns'.
- | RecordWildCards
-
- -- | Deprecated, use 'NamedFieldPuns' instead.
- | RecordPuns
-
- -- | Allow a record field name to be disambiguated by the type of
- -- the record it's in.
- | DisambiguateRecordFields
-
- -- | Enable traditional record syntax (as supported by Haskell 98)
- | TraditionalRecordSyntax
-
- -- | Enable overloading of string literals using a type class, much
- -- like integer literals.
- | OverloadedStrings
-
- -- | Enable generalized algebraic data types, in which type
- -- variables may be instantiated on a per-constructor basis. Implies
- -- 'GADTSyntax'.
- | GADTs
-
- -- | Enable GADT syntax for declaring ordinary algebraic datatypes.
- | GADTSyntax
-
- -- | /(deprecated)/ Has no effect.
- --
- -- Old description: Make pattern bindings monomorphic.
- | MonoPatBinds
-
- -- | Relax the requirements on mutually-recursive polymorphic
- -- functions.
- | RelaxedPolyRec
-
- -- | Allow default instantiation of polymorphic types in more
- -- situations.
- | ExtendedDefaultRules
-
- -- | Enable unboxed tuples.
- | UnboxedTuples
-
- -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and
- -- 'Data.Generics.Data'.
- | DeriveDataTypeable
-
- -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.
- | DeriveGeneric
-
- -- | Enable support for default signatures.
- | DefaultSignatures
-
- -- | Allow type signatures to be specified in instance declarations.
- | InstanceSigs
-
- -- | Allow a class method's type to place additional constraints on
- -- a class type variable.
- | ConstrainedClassMethods
-
- -- | Allow imports to be qualified by the package name the module is
- -- intended to be imported from, e.g.
- --
- -- > import "network" Network.Socket
- | PackageImports
-
- -- | /(deprecated)/ Allow a type variable to be instantiated at a
- -- polymorphic type.
- | ImpredicativeTypes
-
- -- | /(deprecated)/ Change the syntax for qualified infix operators.
- | NewQualifiedOperators
-
- -- | Relax the interpretation of left operator sections to allow
- -- unary postfix operators.
- | PostfixOperators
-
- -- | Enable quasi-quotation, a mechanism for defining new concrete
- -- syntax for expressions and patterns.
- | QuasiQuotes
-
- -- | Enable generalized list comprehensions, supporting operations
- -- such as sorting and grouping.
- | TransformListComp
-
- -- | Enable monad comprehensions, which generalise the list
- -- comprehension syntax to work for any monad.
- | MonadComprehensions
-
- -- | Enable view patterns, which match a value by applying a
- -- function and matching on the result.
- | ViewPatterns
-
- -- | Allow concrete XML syntax to be used in expressions and patterns,
- -- as per the Haskell Server Pages extension language:
- -- <http://www.haskell.org/haskellwiki/HSP>. The ideas behind it are
- -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\"
- -- by Niklas Broberg, from Haskell Workshop '05.
- | XmlSyntax
-
- -- | Allow regular pattern matching over lists, as discussed in the
- -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre
- -- and Josef Svenningsson, from ICFP '04.
- | RegularPatterns
-
- -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into
- -- @\x -> (x, True)@.
- | TupleSections
-
- -- | Allow GHC primops, written in C--, to be imported into a Haskell
- -- file.
- | GHCForeignImportPrim
-
- -- | Support for patterns of the form @n + k@, where @k@ is an
- -- integer literal.
- | NPlusKPatterns
-
- -- | Improve the layout rule when @if@ expressions are used in a @do@
- -- block.
- | DoAndIfThenElse
-
- -- | Enable support for multi-way @if@-expressions.
- | MultiWayIf
-
- -- | Enable support lambda-@case@ expressions.
- | LambdaCase
-
- -- | Makes much of the Haskell sugar be desugared into calls to the
- -- function with a particular name that is in scope.
- | RebindableSyntax
-
- -- | Make @forall@ a keyword in types, which can be used to give the
- -- generalisation explicitly.
- | ExplicitForAll
-
- -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in
- -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.
- | DatatypeContexts
-
- -- | Local (@let@ and @where@) bindings are monomorphic.
- | MonoLocalBinds
-
- -- | Enable @deriving@ for the 'Data.Functor.Functor' class.
- | DeriveFunctor
-
- -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.
- | DeriveTraversable
-
- -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.
- | DeriveFoldable
-
- -- | Enable non-decreasing indentation for @do@ blocks.
- | NondecreasingIndentation
-
- -- | Allow imports to be qualified with a safe keyword that requires
- -- the imported module be trusted as according to the Safe Haskell
- -- definition of trust.
- --
- -- > import safe Network.Socket
- | SafeImports
-
- -- | Compile a module in the Safe, Safe Haskell mode -- a restricted
- -- form of the Haskell language to ensure type safety.
- | Safe
-
- -- | Compile a module in the Trustworthy, Safe Haskell mode -- no
- -- restrictions apply but the module is marked as trusted as long as
- -- the package the module resides in is trusted.
- | Trustworthy
-
- -- | Compile a module in the Unsafe, Safe Haskell mode so that
- -- modules compiled using Safe, Safe Haskell mode can't import it.
- | Unsafe
-
- -- | Allow type class/implicit parameter/equality constraints to be
- -- used as types with the special kind constraint. Also generalise
- -- the @(ctxt => ty)@ syntax so that any type of kind constraint can
- -- occur before the arrow.
- | ConstraintKinds
-
- -- | Enable kind polymorphism.
- | PolyKinds
-
- -- | Enable datatype promotion.
- | DataKinds
-
- -- | Enable @type data@ declarations, defining constructors at the type level.
- | TypeData
-
- -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.
- | ParallelArrays
-
- -- | Enable explicit role annotations, like in (@type role Foo representational representational@).
- | RoleAnnotations
-
- -- | Enable overloading of list literals, arithmetic sequences and
- -- list patterns using the 'IsList' type class.
- | OverloadedLists
-
- -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.
- | EmptyCase
-
- -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'.
- --
- -- Old description: Triggers the generation of derived 'Typeable'
- -- instances for every datatype and type class declaration.
- | AutoDeriveTypeable
-
- -- | Desugars negative literals directly (without using negate).
- | NegativeLiterals
-
- -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@).
- | BinaryLiterals
-
- -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.
- | NumDecimals
-
- -- | Enable support for type classes with no type parameter.
- | NullaryTypeClasses
-
- -- | Enable explicit namespaces in module import/export lists.
- | ExplicitNamespaces
-
- -- | Allow the user to write ambiguous types, and the type inference engine to infer them.
- | AllowAmbiguousTypes
-
- -- | Enable @foreign import javascript@.
- | JavaScriptFFI
-
- -- | Allow giving names to and abstracting over patterns.
- | PatternSynonyms
-
- -- | Allow anonymous placeholders (underscore) inside type signatures. The
- -- type inference engine will generate a message describing the type inferred
- -- at the hole's location.
- | PartialTypeSignatures
-
- -- | Allow named placeholders written with a leading underscore inside type
- -- signatures. Wildcards with the same name unify to the same type.
- | NamedWildCards
-
- -- | Enable @deriving@ for any class.
- | DeriveAnyClass
-
- -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class.
- | DeriveLift
-
- -- | Enable support for 'static pointers' (and the @static@
- -- keyword) to refer to globally stable names, even across
- -- different programs.
- | StaticPointers
-
- -- | Switches data type declarations to be strict by default (as if
- -- they had a bang using @BangPatterns@), and allow opt-in field
- -- laziness using @~@.
- | StrictData
-
- -- | Switches all pattern bindings to be strict by default (as if
- -- they had a bang using @BangPatterns@), ordinary patterns are
- -- recovered using @~@. Implies @StrictData@.
- | Strict
-
- -- | Allows @do@-notation for types that are @'Applicative'@ as well
- -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use
- -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible.
- | ApplicativeDo
-
- -- | Allow records to use duplicated field labels for accessors.
- | DuplicateRecordFields
-
- -- | Enable explicit type applications with the syntax @id \@Int@.
- | TypeApplications
-
- -- | Dissolve the distinction between types and kinds, allowing the compiler
- -- to reason about kind equality and therefore enabling GADTs to be promoted
- -- to the type-level.
- | TypeInType
-
- -- | Allow recursive (and therefore undecidable) super-class relationships.
- | UndecidableSuperClasses
-
- -- | A temporary extension to help library authors check if their
- -- code will compile with the new planned desugaring of fail.
- | MonadFailDesugaring
-
- -- | A subset of @TemplateHaskell@ including only quoting.
- | TemplateHaskellQuotes
-
- -- | Allows use of the @#label@ syntax.
- | OverloadedLabels
-
- -- | Allow functional dependency annotations on type families to declare them
- -- as injective.
- | TypeFamilyDependencies
-
- -- | Allow multiple @deriving@ clauses, each optionally qualified with a
- -- /strategy/.
- | DerivingStrategies
-
- -- | Enable deriving instances via types of the same runtime representation.
- -- Implies 'DerivingStrategies'.
- | DerivingVia
-
- -- | Enable the use of unboxed sum syntax.
- | UnboxedSums
-
- -- | Allow use of hexadecimal literal notation for floating-point values.
- | HexFloatLiterals
-
- -- | Allow @do@ blocks etc. in argument position.
- | BlockArguments
-
- -- | Allow use of underscores in numeric literals.
- | NumericUnderscores
-
- -- | Allow @forall@ in constraints.
- | QuantifiedConstraints
-
- -- | Have @*@ refer to @Type@.
- | StarIsType
-
- -- | Liberalises deriving to provide instances for empty data types.
- | EmptyDataDeriving
-
- -- | Enable detection of complete user-supplied kind signatures.
- | CUSKs
-
- -- | Allows the syntax @import M qualified@.
- | ImportQualifiedPost
-
- -- | Allow the use of standalone kind signatures.
- | StandaloneKindSignatures
-
- -- | Enable unlifted newtypes.
- | UnliftedNewtypes
-
- -- | Use whitespace to determine whether the minus sign stands for negation or subtraction.
- | LexicalNegation
-
- -- | Enable qualified do-notation desugaring.
- | QualifiedDo
-
- -- | Enable linear types.
- | LinearTypes
-
- -- | Allow the use of visible forall in types of terms.
- | RequiredTypeArguments
-
- -- | Enable the generation of selector functions corresponding to record fields.
- | FieldSelectors
-
- -- | Enable the use of record dot-accessor and updater syntax
- | OverloadedRecordDot
-
- -- | Provides record @.@ syntax in record updates, e.g. @x {foo.bar = 1}@.
- | OverloadedRecordUpdate
-
- -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred.
- | UnliftedDatatypes
-
- -- | Undocumented parsing-related extensions introduced in GHC 7.0.
- | AlternativeLayoutRule
-
- -- | Undocumented parsing-related extensions introduced in GHC 7.0.
- | AlternativeLayoutRuleTransitional
-
- -- | Undocumented parsing-related extensions introduced in GHC 7.2.
- | RelaxedLayout
-
+ | -- | Ignore structural rules guaranteeing the termination of class
+ -- instance resolution. Termination is guaranteed by a fixed-depth
+ -- recursion stack, and compilation may fail if this depth is
+ -- exceeded.
+ UndecidableInstances
+ | -- | Implies 'OverlappingInstances'. Allow the implementation to
+ -- choose an instance even when it is possible that further
+ -- instantiation of types will lead to a more specific instance
+ -- being applicable.
+ IncoherentInstances
+ | -- | /(deprecated)/ Deprecated in favour of 'RecursiveDo'.
+ --
+ -- Old description: Allow recursive bindings in @do@ blocks, using
+ -- the @rec@ keyword. See also 'RecursiveDo'.
+ DoRec
+ | -- | Allow recursive bindings in @do@ blocks, using the @rec@
+ -- keyword, or @mdo@, a variant of @do@.
+ RecursiveDo
+ | -- | Provide syntax for writing list comprehensions which iterate
+ -- over several lists together, like the 'zipWith' family of
+ -- functions.
+ ParallelListComp
+ | -- | Allow multiple parameters in a type class.
+ MultiParamTypeClasses
+ | -- | Enable the dreaded monomorphism restriction.
+ MonomorphismRestriction
+ | -- | Enable deep subsumption, relaxing the simple subsumption rules,
+ -- implicitly inserting eta-expansions when matching up function types
+ -- with different quantification structures.
+ DeepSubsumption
+ | -- | Allow a specification attached to a multi-parameter type class
+ -- which indicates that some parameters are entirely determined by
+ -- others. The implementation will check that this property holds
+ -- for the declared instances, and will use this property to reduce
+ -- ambiguity in instance resolution.
+ FunctionalDependencies
+ | -- | /(deprecated)/ A synonym for 'RankNTypes'.
+ --
+ -- Old description: Like 'RankNTypes' but does not allow a
+ -- higher-rank type to itself appear on the left of a function
+ -- arrow.
+ Rank2Types
+ | -- | Allow a universally-quantified type to occur on the left of a
+ -- function arrow.
+ RankNTypes
+ | -- | /(deprecated)/ A synonym for 'RankNTypes'.
+ --
+ -- Old description: Allow data constructors to have polymorphic
+ -- arguments. Unlike 'RankNTypes', does not allow this for ordinary
+ -- functions.
+ PolymorphicComponents
+ | -- | Allow existentially-quantified data constructors.
+ ExistentialQuantification
+ | -- | Cause a type variable in a signature, which has an explicit
+ -- @forall@ quantifier, to scope over the definition of the
+ -- accompanying value declaration.
+ ScopedTypeVariables
+ | -- | Deprecated, use 'ScopedTypeVariables' instead.
+ PatternSignatures
+ | -- | Enable implicit function parameters with dynamic scope.
+ ImplicitParams
+ | -- | Relax some restrictions on the form of the context of a type
+ -- signature.
+ FlexibleContexts
+ | -- | Relax some restrictions on the form of the context of an
+ -- instance declaration.
+ FlexibleInstances
+ | -- | Allow data type declarations with no constructors.
+ EmptyDataDecls
+ | -- | Run the C preprocessor on Haskell source code.
+ CPP
+ | -- | Allow an explicit kind signature giving the kind of types over
+ -- which a type variable ranges.
+ KindSignatures
+ | -- | Enable a form of pattern which forces evaluation before an
+ -- attempted match, and a form of strict @let@/@where@ binding.
+ BangPatterns
+ | -- | Allow type synonyms in instance heads.
+ TypeSynonymInstances
+ | -- | Enable Template Haskell, a system for compile-time
+ -- metaprogramming.
+ TemplateHaskell
+ | -- | Enable the Foreign Function Interface. In GHC, implements the
+ -- standard Haskell 98 Foreign Function Interface Addendum, plus
+ -- some GHC-specific extensions.
+ ForeignFunctionInterface
+ | -- | Enable arrow notation.
+ Arrows
+ | -- | /(deprecated)/ Enable generic type classes, with default instances defined in
+ -- terms of the algebraic structure of a type.
+ Generics
+ | -- | Enable the implicit importing of the module "Prelude". When
+ -- disabled, when desugaring certain built-in syntax into ordinary
+ -- identifiers, use whatever is in scope rather than the "Prelude"
+ -- -- version.
+ ImplicitPrelude
+ | -- | Enable syntax for implicitly binding local names corresponding
+ -- to the field names of a record. Puns bind specific names, unlike
+ -- 'RecordWildCards'.
+ NamedFieldPuns
+ | -- | Enable a form of guard which matches a pattern and binds
+ -- variables.
+ PatternGuards
+ | -- | Allow a type declared with @newtype@ to use @deriving@ for any
+ -- class with an instance for the underlying type.
+ GeneralizedNewtypeDeriving
+ | -- Synonym for GeneralizedNewtypeDeriving added in GHC 8.6.1.
+ GeneralisedNewtypeDeriving
+ | -- | Enable the \"Trex\" extensible records system.
+ ExtensibleRecords
+ | -- | Enable type synonyms which are transparent in some definitions
+ -- and opaque elsewhere, as a way of implementing abstract
+ -- datatypes.
+ RestrictedTypeSynonyms
+ | -- | Enable an alternate syntax for string literals,
+ -- with string templating.
+ HereDocuments
+ | -- | Allow the character @#@ as a postfix modifier on identifiers.
+ -- Also enables literal syntax for unboxed values.
+ MagicHash
+ | -- | Allow data types and type synonyms which are indexed by types,
+ -- i.e. ad-hoc polymorphism for types.
+ TypeFamilies
+ | -- | Allow a standalone declaration which invokes the type class
+ -- @deriving@ mechanism.
+ StandaloneDeriving
+ | -- | Allow certain Unicode characters to stand for certain ASCII
+ -- character sequences, e.g. keywords and punctuation.
+ UnicodeSyntax
+ | -- | Allow the use of unboxed types as foreign types, e.g. in
+ -- @foreign import@ and @foreign export@.
+ UnliftedFFITypes
+ | -- | Enable interruptible FFI.
+ InterruptibleFFI
+ | -- | Allow use of CAPI FFI calling convention (@foreign import capi@).
+ CApiFFI
+ | -- | Defer validity checking of types until after expanding type
+ -- synonyms, relaxing the constraints on how synonyms may be used.
+ LiberalTypeSynonyms
+ | -- | Allow the name of a type constructor, type class, or type
+ -- variable to be an infix operator.
+ TypeOperators
+ | -- | Enable syntax for implicitly binding local names corresponding
+ -- to the field names of a record. A wildcard binds all unmentioned
+ -- names, unlike 'NamedFieldPuns'.
+ RecordWildCards
+ | -- | Deprecated, use 'NamedFieldPuns' instead.
+ RecordPuns
+ | -- | Allow a record field name to be disambiguated by the type of
+ -- the record it's in.
+ DisambiguateRecordFields
+ | -- | Enable traditional record syntax (as supported by Haskell 98)
+ TraditionalRecordSyntax
+ | -- | Enable overloading of string literals using a type class, much
+ -- like integer literals.
+ OverloadedStrings
+ | -- | Enable generalized algebraic data types, in which type
+ -- variables may be instantiated on a per-constructor basis. Implies
+ -- 'GADTSyntax'.
+ GADTs
+ | -- | Enable GADT syntax for declaring ordinary algebraic datatypes.
+ GADTSyntax
+ | -- | /(deprecated)/ Has no effect.
+ --
+ -- Old description: Make pattern bindings monomorphic.
+ MonoPatBinds
+ | -- | Relax the requirements on mutually-recursive polymorphic
+ -- functions.
+ RelaxedPolyRec
+ | -- | Allow default instantiation of polymorphic types in more
+ -- situations.
+ ExtendedDefaultRules
+ | -- | Enable unboxed tuples.
+ UnboxedTuples
+ | -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and
+ -- 'Data.Generics.Data'.
+ DeriveDataTypeable
+ | -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.
+ DeriveGeneric
+ | -- | Enable support for default signatures.
+ DefaultSignatures
+ | -- | Allow type signatures to be specified in instance declarations.
+ InstanceSigs
+ | -- | Allow a class method's type to place additional constraints on
+ -- a class type variable.
+ ConstrainedClassMethods
+ | -- | Allow imports to be qualified by the package name the module is
+ -- intended to be imported from, e.g.
+ --
+ -- > import "network" Network.Socket
+ PackageImports
+ | -- | /(deprecated)/ Allow a type variable to be instantiated at a
+ -- polymorphic type.
+ ImpredicativeTypes
+ | -- | /(deprecated)/ Change the syntax for qualified infix operators.
+ NewQualifiedOperators
+ | -- | Relax the interpretation of left operator sections to allow
+ -- unary postfix operators.
+ PostfixOperators
+ | -- | Enable quasi-quotation, a mechanism for defining new concrete
+ -- syntax for expressions and patterns.
+ QuasiQuotes
+ | -- | Enable generalized list comprehensions, supporting operations
+ -- such as sorting and grouping.
+ TransformListComp
+ | -- | Enable monad comprehensions, which generalise the list
+ -- comprehension syntax to work for any monad.
+ MonadComprehensions
+ | -- | Enable view patterns, which match a value by applying a
+ -- function and matching on the result.
+ ViewPatterns
+ | -- | Allow concrete XML syntax to be used in expressions and patterns,
+ -- as per the Haskell Server Pages extension language:
+ -- <http://www.haskell.org/haskellwiki/HSP>. The ideas behind it are
+ -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\"
+ -- by Niklas Broberg, from Haskell Workshop '05.
+ XmlSyntax
+ | -- | Allow regular pattern matching over lists, as discussed in the
+ -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre
+ -- and Josef Svenningsson, from ICFP '04.
+ RegularPatterns
+ | -- | Enable the use of tuple sections, e.g. @(, True)@ desugars into
+ -- @\x -> (x, True)@.
+ TupleSections
+ | -- | Allow GHC primops, written in C--, to be imported into a Haskell
+ -- file.
+ GHCForeignImportPrim
+ | -- | Support for patterns of the form @n + k@, where @k@ is an
+ -- integer literal.
+ NPlusKPatterns
+ | -- | Improve the layout rule when @if@ expressions are used in a @do@
+ -- block.
+ DoAndIfThenElse
+ | -- | Enable support for multi-way @if@-expressions.
+ MultiWayIf
+ | -- | Enable support lambda-@case@ expressions.
+ LambdaCase
+ | -- | Makes much of the Haskell sugar be desugared into calls to the
+ -- function with a particular name that is in scope.
+ RebindableSyntax
+ | -- | Make @forall@ a keyword in types, which can be used to give the
+ -- generalisation explicitly.
+ ExplicitForAll
+ | -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in
+ -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.
+ DatatypeContexts
+ | -- | Local (@let@ and @where@) bindings are monomorphic.
+ MonoLocalBinds
+ | -- | Enable @deriving@ for the 'Data.Functor.Functor' class.
+ DeriveFunctor
+ | -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.
+ DeriveTraversable
+ | -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.
+ DeriveFoldable
+ | -- | Enable non-decreasing indentation for @do@ blocks.
+ NondecreasingIndentation
+ | -- | Allow imports to be qualified with a safe keyword that requires
+ -- the imported module be trusted as according to the Safe Haskell
+ -- definition of trust.
+ --
+ -- > import safe Network.Socket
+ SafeImports
+ | -- | Compile a module in the Safe, Safe Haskell mode -- a restricted
+ -- form of the Haskell language to ensure type safety.
+ Safe
+ | -- | Compile a module in the Trustworthy, Safe Haskell mode -- no
+ -- restrictions apply but the module is marked as trusted as long as
+ -- the package the module resides in is trusted.
+ Trustworthy
+ | -- | Compile a module in the Unsafe, Safe Haskell mode so that
+ -- modules compiled using Safe, Safe Haskell mode can't import it.
+ Unsafe
+ | -- | Allow type class/implicit parameter/equality constraints to be
+ -- used as types with the special kind constraint. Also generalise
+ -- the @(ctxt => ty)@ syntax so that any type of kind constraint can
+ -- occur before the arrow.
+ ConstraintKinds
+ | -- | Enable kind polymorphism.
+ PolyKinds
+ | -- | Enable datatype promotion.
+ DataKinds
+ | -- | Enable @type data@ declarations, defining constructors at the type level.
+ TypeData
+ | -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.
+ ParallelArrays
+ | -- | Enable explicit role annotations, like in (@type role Foo representational representational@).
+ RoleAnnotations
+ | -- | Enable overloading of list literals, arithmetic sequences and
+ -- list patterns using the 'IsList' type class.
+ OverloadedLists
+ | -- | Enable case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.
+ EmptyCase
+ | -- | /(deprecated)/ Deprecated in favour of 'DeriveDataTypeable'.
+ --
+ -- Old description: Triggers the generation of derived 'Typeable'
+ -- instances for every datatype and type class declaration.
+ AutoDeriveTypeable
+ | -- | Desugars negative literals directly (without using negate).
+ NegativeLiterals
+ | -- | Allow the use of binary integer literal syntax (e.g. @0b11001001@ to denote @201@).
+ BinaryLiterals
+ | -- | Allow the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.
+ NumDecimals
+ | -- | Enable support for type classes with no type parameter.
+ NullaryTypeClasses
+ | -- | Enable explicit namespaces in module import/export lists.
+ ExplicitNamespaces
+ | -- | Allow the user to write ambiguous types, and the type inference engine to infer them.
+ AllowAmbiguousTypes
+ | -- | Enable @foreign import javascript@.
+ JavaScriptFFI
+ | -- | Allow giving names to and abstracting over patterns.
+ PatternSynonyms
+ | -- | Allow anonymous placeholders (underscore) inside type signatures. The
+ -- type inference engine will generate a message describing the type inferred
+ -- at the hole's location.
+ PartialTypeSignatures
+ | -- | Allow named placeholders written with a leading underscore inside type
+ -- signatures. Wildcards with the same name unify to the same type.
+ NamedWildCards
+ | -- | Enable @deriving@ for any class.
+ DeriveAnyClass
+ | -- | Enable @deriving@ for the 'Language.Haskell.TH.Syntax.Lift' class.
+ DeriveLift
+ | -- | Enable support for 'static pointers' (and the @static@
+ -- keyword) to refer to globally stable names, even across
+ -- different programs.
+ StaticPointers
+ | -- | Switches data type declarations to be strict by default (as if
+ -- they had a bang using @BangPatterns@), and allow opt-in field
+ -- laziness using @~@.
+ StrictData
+ | -- | Switches all pattern bindings to be strict by default (as if
+ -- they had a bang using @BangPatterns@), ordinary patterns are
+ -- recovered using @~@. Implies @StrictData@.
+ Strict
+ | -- | Allows @do@-notation for types that are @'Applicative'@ as well
+ -- as @'Monad'@. When enabled, desugaring @do@ notation tries to use
+ -- @(<*>)@ and @'fmap'@ and @'join'@ as far as possible.
+ ApplicativeDo
+ | -- | Allow records to use duplicated field labels for accessors.
+ DuplicateRecordFields
+ | -- | Enable explicit type applications with the syntax @id \@Int@.
+ TypeApplications
+ | -- | Dissolve the distinction between types and kinds, allowing the compiler
+ -- to reason about kind equality and therefore enabling GADTs to be promoted
+ -- to the type-level.
+ TypeInType
+ | -- | Allow recursive (and therefore undecidable) super-class relationships.
+ UndecidableSuperClasses
+ | -- | A temporary extension to help library authors check if their
+ -- code will compile with the new planned desugaring of fail.
+ MonadFailDesugaring
+ | -- | A subset of @TemplateHaskell@ including only quoting.
+ TemplateHaskellQuotes
+ | -- | Allows use of the @#label@ syntax.
+ OverloadedLabels
+ | -- | Allow functional dependency annotations on type families to declare them
+ -- as injective.
+ TypeFamilyDependencies
+ | -- | Allow multiple @deriving@ clauses, each optionally qualified with a
+ -- /strategy/.
+ DerivingStrategies
+ | -- | Enable deriving instances via types of the same runtime representation.
+ -- Implies 'DerivingStrategies'.
+ DerivingVia
+ | -- | Enable the use of unboxed sum syntax.
+ UnboxedSums
+ | -- | Allow use of hexadecimal literal notation for floating-point values.
+ HexFloatLiterals
+ | -- | Allow @do@ blocks etc. in argument position.
+ BlockArguments
+ | -- | Allow use of underscores in numeric literals.
+ NumericUnderscores
+ | -- | Allow @forall@ in constraints.
+ QuantifiedConstraints
+ | -- | Have @*@ refer to @Type@.
+ StarIsType
+ | -- | Liberalises deriving to provide instances for empty data types.
+ EmptyDataDeriving
+ | -- | Enable detection of complete user-supplied kind signatures.
+ CUSKs
+ | -- | Allows the syntax @import M qualified@.
+ ImportQualifiedPost
+ | -- | Allow the use of standalone kind signatures.
+ StandaloneKindSignatures
+ | -- | Enable unlifted newtypes.
+ UnliftedNewtypes
+ | -- | Use whitespace to determine whether the minus sign stands for negation or subtraction.
+ LexicalNegation
+ | -- | Enable qualified do-notation desugaring.
+ QualifiedDo
+ | -- | Enable linear types.
+ LinearTypes
+ | -- | Allow the use of visible forall in types of terms.
+ RequiredTypeArguments
+ | -- | Enable the generation of selector functions corresponding to record fields.
+ FieldSelectors
+ | -- | Enable the use of record dot-accessor and updater syntax
+ OverloadedRecordDot
+ | -- | Provides record @.@ syntax in record updates, e.g. @x {foo.bar = 1}@.
+ OverloadedRecordUpdate
+ | -- | Enable data types for which an unlifted or levity-polymorphic result kind is inferred.
+ UnliftedDatatypes
+ | -- | Undocumented parsing-related extensions introduced in GHC 7.0.
+ AlternativeLayoutRule
+ | -- | Undocumented parsing-related extensions introduced in GHC 7.0.
+ AlternativeLayoutRuleTransitional
+ | -- | Undocumented parsing-related extensions introduced in GHC 7.2.
+ RelaxedLayout
deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable, Data)
instance Binary KnownExtension
@@ -695,12 +547,12 @@ instance NFData KnownExtension where rnf = genericRnf
-- | Extensions that have been deprecated, possibly paired with another
-- extension that replaces it.
---
deprecatedExtensions :: [(Extension, Maybe Extension)]
deprecatedExtensions =
[ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns))
, (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables))
]
+
-- NOTE: when adding deprecated extensions that have new alternatives
-- we must be careful to make sure that the deprecation messages are
-- valid. We must not recommend aliases that cannot be used with older
@@ -710,8 +562,8 @@ deprecatedExtensions =
instance Pretty Extension where
pretty (UnknownExtension other) = Disp.text other
- pretty (EnableExtension ke) = Disp.text (show ke)
- pretty (DisableExtension ke) = Disp.text ("No" ++ show ke)
+ pretty (EnableExtension ke) = Disp.text (show ke)
+ pretty (DisableExtension ke) = Disp.text ("No" ++ show ke)
instance Parsec Extension where
parsec = classifyExtension <$> P.munch1 isAlphaNum
@@ -720,13 +572,13 @@ instance Pretty KnownExtension where
pretty ke = Disp.text (show ke)
classifyExtension :: String -> Extension
-classifyExtension string
- = case classifyKnownExtension string of
+classifyExtension string =
+ case classifyKnownExtension string of
Just ext -> EnableExtension ext
Nothing ->
- case string of
- 'N':'o':string' ->
- case classifyKnownExtension string' of
+ case string of
+ 'N' : 'o' : string' ->
+ case classifyKnownExtension string' of
Just ext -> DisableExtension ext
Nothing -> UnknownExtension string
_ -> UnknownExtension string
@@ -740,17 +592,19 @@ classifyExtension string
--
-- This gives an order of magnitude improvement in parsing speed, and it'll
-- also allow us to do case insensitive matches in future if we prefer.
---
classifyKnownExtension :: String -> Maybe KnownExtension
classifyKnownExtension "" = Nothing
classifyKnownExtension string@(c : _)
- | inRange (bounds knownExtensionTable) c
- = lookup string (knownExtensionTable ! c)
+ | inRange (bounds knownExtensionTable) c =
+ lookup string (knownExtensionTable ! c)
| otherwise = Nothing
knownExtensionTable :: Array Char [(String, KnownExtension)]
knownExtensionTable =
- accumArray (flip (:)) [] ('A', 'Z')
+ accumArray
+ (flip (:))
+ []
+ ('A', 'Z')
[ (hd, (str, extension)) -- assume KnownExtension's Show returns a non-empty string
| (extension, str@(hd : _)) <- map (\e -> (e, show e)) [toEnum 0 ..]
]
diff --git a/Cabal/Setup.hs b/Cabal/Setup.hs
index 42784ab13d2c5f136b6b8a03643229b576cb401e..a3e3aa6e410731311386b88018b749d297605b3a 100644
--- a/Cabal/Setup.hs
+++ b/Cabal/Setup.hs
@@ -1,4 +1,5 @@
import Distribution.Simple
+
main :: IO ()
main = defaultMain
diff --git a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs
index 656fc22d3645a6865ab3d2ba9d9d032b0b4a6eb2..aef3db817c6b9ec6b48c733423532ebd246c2ce7 100644
--- a/Cabal/src/Distribution/Backpack/ComponentsGraph.hs
+++ b/Cabal/src/Distribution/Backpack/ComponentsGraph.hs
@@ -1,24 +1,24 @@
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.ComponentsGraph (
- ComponentsGraph,
- ComponentsWithDeps,
- mkComponentsGraph,
- componentsGraphToList,
- dispComponentsWithDeps,
- componentCycleMsg
-) where
+module Distribution.Backpack.ComponentsGraph
+ ( ComponentsGraph
+ , ComponentsWithDeps
+ , mkComponentsGraph
+ , componentsGraphToList
+ , dispComponentsWithDeps
+ , componentCycleMsg
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
+import Distribution.Compat.Graph (Graph, Node (..))
+import qualified Distribution.Compat.Graph as Graph
+import qualified Distribution.Compat.NonEmptySet as NES
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
-import Distribution.Compat.Graph (Graph, Node(..))
-import qualified Distribution.Compat.Graph as Graph
-import qualified Distribution.Compat.NonEmptySet as NES
import Distribution.Utils.Generic
import Distribution.Pretty (pretty)
@@ -30,68 +30,76 @@ import Text.PrettyPrint
-- | A graph of source-level components by their source-level
-- dependencies
---
type ComponentsGraph = Graph (Node ComponentName Component)
-- | A list of components associated with the source level
-- dependencies between them.
---
type ComponentsWithDeps = [(Component, [ComponentName])]
-- | Pretty-print 'ComponentsWithDeps'.
---
dispComponentsWithDeps :: ComponentsWithDeps -> Doc
dispComponentsWithDeps graph =
- vcat [ hang (text "component" <+> pretty (componentName c)) 4
- (vcat [ text "dependency" <+> pretty cdep | cdep <- cdeps ])
- | (c, cdeps) <- graph ]
+ vcat
+ [ hang
+ (text "component" <+> pretty (componentName c))
+ 4
+ (vcat [text "dependency" <+> pretty cdep | cdep <- cdeps])
+ | (c, cdeps) <- graph
+ ]
-- | Create a 'Graph' of 'Component', or report a cycle if there is a
-- problem.
---
-mkComponentsGraph :: ComponentRequestedSpec
- -> PackageDescription
- -> Either [ComponentName] ComponentsGraph
+mkComponentsGraph
+ :: ComponentRequestedSpec
+ -> PackageDescription
+ -> Either [ComponentName] ComponentsGraph
mkComponentsGraph enabled pkg_descr =
- let g = Graph.fromDistinctList
- [ N c (componentName c) (componentDeps c)
- | c <- pkgBuildableComponents pkg_descr
- , componentEnabled enabled c ]
- in case Graph.cycles g of
- [] -> Right g
- ccycles -> Left [ componentName c | N c _ _ <- concat ccycles ]
+ let g =
+ Graph.fromDistinctList
+ [ N c (componentName c) (componentDeps c)
+ | c <- pkgBuildableComponents pkg_descr
+ , componentEnabled enabled c
+ ]
+ in case Graph.cycles g of
+ [] -> Right g
+ ccycles -> Left [componentName c | N c _ _ <- concat ccycles]
where
-- The dependencies for the given component
componentDeps component =
- toolDependencies ++ libDependencies
+ toolDependencies ++ libDependencies
where
bi = componentBuildInfo component
toolDependencies = CExeName <$> getAllInternalToolDependencies pkg_descr bi
libDependencies = do
- Dependency pkgname _ lns <- targetBuildDepends bi
- guard (pkgname == packageName pkg_descr)
+ Dependency pkgname _ lns <- targetBuildDepends bi
+ guard (pkgname == packageName pkg_descr)
- ln <- NES.toList lns
- return (CLibName ln)
+ ln <- NES.toList lns
+ return (CLibName ln)
-- | Given the package description and a 'PackageDescription' (used
-- to determine if a package name is internal or not), sort the
-- components in dependency order (fewest dependencies first). This is
-- NOT necessarily the build order (although it is in the absence of
-- Backpack.)
---
-componentsGraphToList :: ComponentsGraph
- -> ComponentsWithDeps
+componentsGraphToList
+ :: ComponentsGraph
+ -> ComponentsWithDeps
componentsGraphToList =
- map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort
+ map (\(N c _ cs) -> (c, cs)) . Graph.revTopSort
-- | Error message when there is a cycle; takes the SCC of components.
componentCycleMsg :: PackageIdentifier -> [ComponentName] -> Doc
componentCycleMsg pn cnames =
- text "Components in the package" <+> pretty pn <+> text "depend on each other in a cyclic way:"
- $$
- text (intercalate " depends on "
- [ "'" ++ showComponentName cname ++ "'"
- | cname <- cnames ++ maybeToList (safeHead cnames) ])
+ text "Components in the package"
+ <+> pretty pn
+ <+> text "depend on each other in a cyclic way:"
+ $$ text
+ ( intercalate
+ " depends on "
+ [ "'" ++ showComponentName cname ++ "'"
+ | cname <- cnames ++ maybeToList (safeHead cnames)
+ ]
+ )
diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs
index 60764fdf32d226eab39da005475e1b394a32509e..7d85d487fc88258a0382abc43611b490209d2e5d 100644
--- a/Cabal/src/Distribution/Backpack/Configure.hs
+++ b/Cabal/src/Distribution/Backpack/Configure.hs
@@ -1,56 +1,59 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
--
-- WARNING: The contents of this module are HIGHLY experimental.
-- We may refactor it under you.
-module Distribution.Backpack.Configure (
- configureComponentLocalBuildInfos,
-) where
+module Distribution.Backpack.Configure
+ ( configureComponentLocalBuildInfos
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
+import Prelude ()
import Distribution.Backpack
-import Distribution.Backpack.FullUnitId
-import Distribution.Backpack.PreExistingComponent
+import Distribution.Backpack.ComponentsGraph
import Distribution.Backpack.ConfiguredComponent
+import Distribution.Backpack.FullUnitId
+import Distribution.Backpack.Id
import Distribution.Backpack.LinkedComponent
+import Distribution.Backpack.PreExistingComponent
import Distribution.Backpack.ReadyComponent
-import Distribution.Backpack.ComponentsGraph
-import Distribution.Backpack.Id
-import Distribution.Simple.Compiler
-import Distribution.Package
+import Distribution.Compat.Graph (Graph, IsNode (..))
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.InstalledPackageInfo
+ ( InstalledPackageInfo
+ , emptyInstalledPackageInfo
+ )
import qualified Distribution.InstalledPackageInfo as Installed
-import Distribution.InstalledPackageInfo (InstalledPackageInfo
- ,emptyInstalledPackageInfo)
-import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import Distribution.PackageDescription
import Distribution.ModuleName
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.Simple.Compiler
import Distribution.Simple.Flag
import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Types.AnnotatedId
-import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ComponentInclude
+import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.MungedPackageName
-import Distribution.Verbosity
-import qualified Distribution.Compat.Graph as Graph
-import Distribution.Compat.Graph (Graph, IsNode(..))
import Distribution.Utils.LogProgress
+import Distribution.Verbosity
import Data.Either
- ( lefts )
-import qualified Data.Set as Set
+ ( lefts
+ )
import qualified Data.Map as Map
+import qualified Data.Set as Set
import Distribution.Pretty
import Text.PrettyPrint
@@ -59,75 +62,123 @@ import Text.PrettyPrint
------------------------------------------------------------------------------
configureComponentLocalBuildInfos
- :: Verbosity
- -> Bool -- use_external_internal_deps
- -> ComponentRequestedSpec
- -> Bool -- deterministic
- -> Flag String -- configIPID
- -> Flag ComponentId -- configCID
- -> PackageDescription
- -> [PreExistingComponent]
- -> FlagAssignment -- configConfigurationsFlags
- -> [(ModuleName, Module)] -- configInstantiateWith
- -> InstalledPackageIndex
- -> Compiler
- -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
+ :: Verbosity
+ -> Bool -- use_external_internal_deps
+ -> ComponentRequestedSpec
+ -> Bool -- deterministic
+ -> Flag String -- configIPID
+ -> Flag ComponentId -- configCID
+ -> PackageDescription
+ -> [PreExistingComponent]
+ -> FlagAssignment -- configConfigurationsFlags
+ -> [(ModuleName, Module)] -- configInstantiateWith
+ -> InstalledPackageIndex
+ -> Compiler
+ -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
configureComponentLocalBuildInfos
- verbosity use_external_internal_deps enabled deterministic ipid_flag cid_flag pkg_descr
- prePkgDeps flagAssignment instantiate_with installedPackageSet comp = do
+ verbosity
+ use_external_internal_deps
+ enabled
+ deterministic
+ ipid_flag
+ cid_flag
+ pkg_descr
+ prePkgDeps
+ flagAssignment
+ instantiate_with
+ installedPackageSet
+ comp = do
-- NB: In single component mode, this returns a *single* component.
-- In this graph, the graph is NOT closed.
graph0 <- case mkComponentsGraph enabled pkg_descr of
- Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)
- Right g -> return (componentsGraphToList g)
- infoProgress $ hang (text "Source component graph:") 4
- (dispComponentsWithDeps graph0)
+ Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)
+ Right g -> return (componentsGraphToList g)
+ infoProgress $
+ hang
+ (text "Source component graph:")
+ 4
+ (dispComponentsWithDeps graph0)
- let conf_pkg_map = Map.fromListWith Map.union
- [(pc_pkgname pkg,
- Map.singleton (pc_compname pkg)
- (AnnotatedId {
- ann_id = pc_cid pkg,
- ann_pid = packageId pkg,
- ann_cname = pc_compname pkg
- }))
- | pkg <- prePkgDeps]
- graph1 <- toConfiguredComponents use_external_internal_deps
- flagAssignment
- deterministic ipid_flag cid_flag pkg_descr
- conf_pkg_map (map fst graph0)
- infoProgress $ hang (text "Configured component graph:") 4
- (vcat (map dispConfiguredComponent graph1))
+ let conf_pkg_map =
+ Map.fromListWith
+ Map.union
+ [ ( pc_pkgname pkg
+ , Map.singleton
+ (pc_compname pkg)
+ ( AnnotatedId
+ { ann_id = pc_cid pkg
+ , ann_pid = packageId pkg
+ , ann_cname = pc_compname pkg
+ }
+ )
+ )
+ | pkg <- prePkgDeps
+ ]
+ graph1 <-
+ toConfiguredComponents
+ use_external_internal_deps
+ flagAssignment
+ deterministic
+ ipid_flag
+ cid_flag
+ pkg_descr
+ conf_pkg_map
+ (map fst graph0)
+ infoProgress $
+ hang
+ (text "Configured component graph:")
+ 4
+ (vcat (map dispConfiguredComponent graph1))
- let shape_pkg_map = Map.fromList
+ let shape_pkg_map =
+ Map.fromList
[ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))
- | pkg <- prePkgDeps]
+ | pkg <- prePkgDeps
+ ]
uid_lookup def_uid
- | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid
- = FullUnitId (Installed.installedComponentId pkg)
- (Map.fromList (Installed.instantiatedWith pkg))
- | otherwise = error ("uid_lookup: " ++ prettyShow uid)
- where uid = unDefUnitId def_uid
- graph2 <- toLinkedComponents verbosity uid_lookup
- (package pkg_descr) shape_pkg_map graph1
+ | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid =
+ FullUnitId
+ (Installed.installedComponentId pkg)
+ (Map.fromList (Installed.instantiatedWith pkg))
+ | otherwise = error ("uid_lookup: " ++ prettyShow uid)
+ where
+ uid = unDefUnitId def_uid
+ graph2 <-
+ toLinkedComponents
+ verbosity
+ uid_lookup
+ (package pkg_descr)
+ shape_pkg_map
+ graph1
infoProgress $
- hang (text "Linked component graph:") 4
- (vcat (map dispLinkedComponent graph2))
+ hang
+ (text "Linked component graph:")
+ 4
+ (vcat (map dispLinkedComponent graph2))
- let pid_map = Map.fromList $
+ let pid_map =
+ Map.fromList $
[ (pc_uid pkg, pc_munged_id pkg)
- | pkg <- prePkgDeps] ++
- [ (Installed.installedUnitId pkg, mungedId pkg)
- | (_, Module uid _) <- instantiate_with
- , Just pkg <- [PackageIndex.lookupUnitId
- installedPackageSet (unDefUnitId uid)] ]
+ | pkg <- prePkgDeps
+ ]
+ ++ [ (Installed.installedUnitId pkg, mungedId pkg)
+ | (_, Module uid _) <- instantiate_with
+ , Just pkg <-
+ [ PackageIndex.lookupUnitId
+ installedPackageSet
+ (unDefUnitId uid)
+ ]
+ ]
subst = Map.fromList instantiate_with
graph3 = toReadyComponents pid_map subst graph2
graph4 = Graph.revTopSort (Graph.fromDistinctList graph3)
- infoProgress $ hang (text "Ready component graph:") 4
- (vcat (map dispReadyComponent graph4))
+ infoProgress $
+ hang
+ (text "Ready component graph:")
+ 4
+ (vcat (map dispReadyComponent graph4))
toComponentLocalBuildInfos comp installedPackageSet pkg_descr prePkgDeps graph4
@@ -136,67 +187,81 @@ configureComponentLocalBuildInfos
------------------------------------------------------------------------------
toComponentLocalBuildInfos
- :: Compiler
- -> InstalledPackageIndex -- FULL set
- -> PackageDescription
- -> [PreExistingComponent] -- external package deps
- -> [ReadyComponent]
- -> LogProgress ([ComponentLocalBuildInfo],
- InstalledPackageIndex) -- only relevant packages
+ :: Compiler
+ -> InstalledPackageIndex -- FULL set
+ -> PackageDescription
+ -> [PreExistingComponent] -- external package deps
+ -> [ReadyComponent]
+ -> LogProgress
+ ( [ComponentLocalBuildInfo]
+ , InstalledPackageIndex -- only relevant packages
+ )
toComponentLocalBuildInfos
- comp installedPackageSet pkg_descr externalPkgDeps graph = do
+ comp
+ installedPackageSet
+ pkg_descr
+ externalPkgDeps
+ graph = do
-- Check and make sure that every instantiated component exists.
-- We have to do this now, because prior to linking/instantiating
-- we don't actually know what the full set of 'UnitId's we need
-- are.
- let -- TODO: This is actually a bit questionable performance-wise,
- -- since we will pay for the ALL installed packages even if
- -- they are not related to what we are building. This was true
- -- in the old configure code.
- external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
- external_graph = Graph.fromDistinctList
- . map Left
- $ PackageIndex.allPackages installedPackageSet
- internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
- internal_graph = Graph.fromDistinctList
- . map Right
- $ graph
- combined_graph = Graph.unionRight external_graph internal_graph
- local_graph = fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing")
- $ Graph.closure combined_graph (map nodeKey graph)
- -- The database of transitively reachable installed packages that the
- -- external components the package (as a whole) depends on. This will be
- -- used in several ways:
- --
- -- * We'll use it to do a consistency check so we're not depending
- -- on multiple versions of the same package (TODO: someday relax
- -- this for private dependencies.) See right below.
- --
- -- * We'll pass it on in the LocalBuildInfo, where preprocessors
- -- and other things will incorrectly use it to determine what
- -- the include paths and everything should be.
- --
- packageDependsIndex = PackageIndex.fromList (lefts local_graph)
- fullIndex = Graph.fromDistinctList local_graph
+ let
+ -- TODO: This is actually a bit questionable performance-wise,
+ -- since we will pay for the ALL installed packages even if
+ -- they are not related to what we are building. This was true
+ -- in the old configure code.
+ external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+ external_graph =
+ Graph.fromDistinctList
+ . map Left
+ $ PackageIndex.allPackages installedPackageSet
+ internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+ internal_graph =
+ Graph.fromDistinctList
+ . map Right
+ $ graph
+ combined_graph = Graph.unionRight external_graph internal_graph
+ local_graph =
+ fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $
+ Graph.closure combined_graph (map nodeKey graph)
+ -- The database of transitively reachable installed packages that the
+ -- external components the package (as a whole) depends on. This will be
+ -- used in several ways:
+ --
+ -- * We'll use it to do a consistency check so we're not depending
+ -- on multiple versions of the same package (TODO: someday relax
+ -- this for private dependencies.) See right below.
+ --
+ -- * We'll pass it on in the LocalBuildInfo, where preprocessors
+ -- and other things will incorrectly use it to determine what
+ -- the include paths and everything should be.
+ --
+ packageDependsIndex = PackageIndex.fromList (lefts local_graph)
+ fullIndex = Graph.fromDistinctList local_graph
case Graph.broken fullIndex of
- [] -> return ()
- broken ->
- -- TODO: ppr this
- dieProgress . text $
- "The following packages are broken because other"
- ++ " packages they depend on are missing. These broken "
- ++ "packages must be rebuilt before they can be used.\n"
- -- TODO: Undupe.
- ++ unlines [ "installed package "
- ++ prettyShow (packageId pkg)
- ++ " is broken due to missing package "
- ++ intercalate ", " (map prettyShow deps)
- | (Left pkg, deps) <- broken ]
- ++ unlines [ "planned package "
- ++ prettyShow (packageId pkg)
- ++ " is broken due to missing package "
- ++ intercalate ", " (map prettyShow deps)
- | (Right pkg, deps) <- broken ]
+ [] -> return ()
+ broken ->
+ -- TODO: ppr this
+ dieProgress . text $
+ "The following packages are broken because other"
+ ++ " packages they depend on are missing. These broken "
+ ++ "packages must be rebuilt before they can be used.\n"
+ -- TODO: Undupe.
+ ++ unlines
+ [ "installed package "
+ ++ prettyShow (packageId pkg)
+ ++ " is broken due to missing package "
+ ++ intercalate ", " (map prettyShow deps)
+ | (Left pkg, deps) <- broken
+ ]
+ ++ unlines
+ [ "planned package "
+ ++ prettyShow (packageId pkg)
+ ++ " is broken due to missing package "
+ ++ intercalate ", " (map prettyShow deps)
+ | (Right pkg, deps) <- broken
+ ]
-- In this section, we'd like to look at the 'packageDependsIndex'
-- and see if we've picked multiple versions of the same
@@ -213,25 +278,34 @@ toComponentLocalBuildInfos
--
-- TODO: This is probably wrong for Backpack
let pseudoTopPkg :: InstalledPackageInfo
- pseudoTopPkg = emptyInstalledPackageInfo {
- Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr),
- Installed.sourcePackageId = packageId pkg_descr,
- Installed.depends = map pc_uid externalPkgDeps
- }
+ pseudoTopPkg =
+ emptyInstalledPackageInfo
+ { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)
+ , Installed.sourcePackageId = packageId pkg_descr
+ , Installed.depends = map pc_uid externalPkgDeps
+ }
case PackageIndex.dependencyInconsistencies
- . PackageIndex.insert pseudoTopPkg
- $ packageDependsIndex of
+ . PackageIndex.insert pseudoTopPkg
+ $ packageDependsIndex of
[] -> return ()
inconsistencies ->
warnProgress $
- hang (text "This package indirectly depends on multiple versions of the same" <+>
- text "package. This is very likely to cause a compile failure.") 2
- (vcat [ text "package" <+> pretty (packageName user) <+>
- parens (pretty (installedUnitId user)) <+> text "requires" <+>
- pretty inst
- | (_dep_key, insts) <- inconsistencies
- , (inst, users) <- insts
- , user <- users ])
+ hang
+ ( text "This package indirectly depends on multiple versions of the same"
+ <+> text "package. This is very likely to cause a compile failure."
+ )
+ 2
+ ( vcat
+ [ text "package"
+ <+> pretty (packageName user)
+ <+> parens (pretty (installedUnitId user))
+ <+> text "requires"
+ <+> pretty inst
+ | (_dep_key, insts) <- inconsistencies
+ , (inst, users) <- insts
+ , user <- users
+ ]
+ )
let clbis = mkLinkedComponentsLocalBuildInfo comp graph
-- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
return (clbis, packageDependsIndex)
@@ -241,119 +315,124 @@ toComponentLocalBuildInfos
--
-- This conversion is lossy; we lose some invariants from ReadyComponent
mkLinkedComponentsLocalBuildInfo
- :: Compiler
- -> [ReadyComponent]
- -> [ComponentLocalBuildInfo]
+ :: Compiler
+ -> [ReadyComponent]
+ -> [ComponentLocalBuildInfo]
mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
where
internalUnits = Set.fromList (map rc_uid rcs)
isInternal x = Set.member x internalUnits
go rc =
case rc_component rc of
- CLib lib ->
- let convModuleExport (modname', (Module uid modname))
- | this_uid == unDefUnitId uid
- , modname' == modname
- = Installed.ExposedModule modname' Nothing
- | otherwise
- = Installed.ExposedModule modname'
- (Just (OpenModule (DefiniteUnitId uid) modname))
- convOpenModuleExport (modname', modu@(OpenModule uid modname))
- | uid == this_open_uid
- , modname' == modname
- = Installed.ExposedModule modname' Nothing
- | otherwise
- = Installed.ExposedModule modname' (Just modu)
- convOpenModuleExport (_, OpenModuleVar _)
- = error "convOpenModuleExport: top-level modvar"
- exports =
+ CLib lib ->
+ let convModuleExport (modname', (Module uid modname))
+ | this_uid == unDefUnitId uid
+ , modname' == modname =
+ Installed.ExposedModule modname' Nothing
+ | otherwise =
+ Installed.ExposedModule
+ modname'
+ (Just (OpenModule (DefiniteUnitId uid) modname))
+ convOpenModuleExport (modname', modu@(OpenModule uid modname))
+ | uid == this_open_uid
+ , modname' == modname =
+ Installed.ExposedModule modname' Nothing
+ | otherwise =
+ Installed.ExposedModule modname' (Just modu)
+ convOpenModuleExport (_, OpenModuleVar _) =
+ error "convOpenModuleExport: top-level modvar"
+ exports =
-- Loses invariants
case rc_i rc of
- Left indefc -> map convOpenModuleExport
- $ Map.toList (indefc_provides indefc)
- Right instc -> map convModuleExport
- $ Map.toList (instc_provides instc)
- insts =
+ Left indefc ->
+ map convOpenModuleExport $
+ Map.toList (indefc_provides indefc)
+ Right instc ->
+ map convModuleExport $
+ Map.toList (instc_provides instc)
+ insts =
case rc_i rc of
- Left indefc -> [ (m, OpenModuleVar m) | m <- indefc_requires indefc ]
- Right instc -> [ (m, OpenModule (DefiniteUnitId uid') m')
- | (m, Module uid' m') <- instc_insts instc ]
-
- compat_name = MungedPackageName (packageName rc) (libName lib)
- compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid
+ Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc]
+ Right instc ->
+ [ (m, OpenModule (DefiniteUnitId uid') m')
+ | (m, Module uid' m') <- instc_insts instc
+ ]
- in LibComponentLocalBuildInfo {
- componentPackageDeps = cpds,
- componentUnitId = this_uid,
- componentComponentId = this_cid,
- componentInstantiatedWith = insts,
- componentIsIndefinite_ = is_indefinite,
- componentLocalName = cname,
- componentInternalDeps = internal_deps,
- componentExeDeps = exe_deps,
- componentIncludes = includes,
- componentExposedModules = exports,
- componentIsPublic = rc_public rc,
- componentCompatPackageKey = compat_key,
- componentCompatPackageName = compat_name
- }
- CFLib _ ->
- FLibComponentLocalBuildInfo {
- componentUnitId = this_uid,
- componentComponentId = this_cid,
- componentLocalName = cname,
- componentPackageDeps = cpds,
- componentExeDeps = exe_deps,
- componentInternalDeps = internal_deps,
- componentIncludes = includes
- }
- CExe _ ->
- ExeComponentLocalBuildInfo {
- componentUnitId = this_uid,
- componentComponentId = this_cid,
- componentLocalName = cname,
- componentPackageDeps = cpds,
- componentExeDeps = exe_deps,
- componentInternalDeps = internal_deps,
- componentIncludes = includes
- }
- CTest _ ->
- TestComponentLocalBuildInfo {
- componentUnitId = this_uid,
- componentComponentId = this_cid,
- componentLocalName = cname,
- componentPackageDeps = cpds,
- componentExeDeps = exe_deps,
- componentInternalDeps = internal_deps,
- componentIncludes = includes
- }
- CBench _ ->
- BenchComponentLocalBuildInfo {
- componentUnitId = this_uid,
- componentComponentId = this_cid,
- componentLocalName = cname,
- componentPackageDeps = cpds,
- componentExeDeps = exe_deps,
- componentInternalDeps = internal_deps,
- componentIncludes = includes
- }
- where
- this_uid = rc_uid rc
- this_open_uid = rc_open_uid rc
- this_cid = rc_cid rc
- cname = componentName (rc_component rc)
- cpds = rc_depends rc
- exe_deps = map ann_id $ rc_exe_deps rc
- is_indefinite =
- case rc_i rc of
+ compat_name = MungedPackageName (packageName rc) (libName lib)
+ compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid
+ in LibComponentLocalBuildInfo
+ { componentPackageDeps = cpds
+ , componentUnitId = this_uid
+ , componentComponentId = this_cid
+ , componentInstantiatedWith = insts
+ , componentIsIndefinite_ = is_indefinite
+ , componentLocalName = cname
+ , componentInternalDeps = internal_deps
+ , componentExeDeps = exe_deps
+ , componentIncludes = includes
+ , componentExposedModules = exports
+ , componentIsPublic = rc_public rc
+ , componentCompatPackageKey = compat_key
+ , componentCompatPackageName = compat_name
+ }
+ CFLib _ ->
+ FLibComponentLocalBuildInfo
+ { componentUnitId = this_uid
+ , componentComponentId = this_cid
+ , componentLocalName = cname
+ , componentPackageDeps = cpds
+ , componentExeDeps = exe_deps
+ , componentInternalDeps = internal_deps
+ , componentIncludes = includes
+ }
+ CExe _ ->
+ ExeComponentLocalBuildInfo
+ { componentUnitId = this_uid
+ , componentComponentId = this_cid
+ , componentLocalName = cname
+ , componentPackageDeps = cpds
+ , componentExeDeps = exe_deps
+ , componentInternalDeps = internal_deps
+ , componentIncludes = includes
+ }
+ CTest _ ->
+ TestComponentLocalBuildInfo
+ { componentUnitId = this_uid
+ , componentComponentId = this_cid
+ , componentLocalName = cname
+ , componentPackageDeps = cpds
+ , componentExeDeps = exe_deps
+ , componentInternalDeps = internal_deps
+ , componentIncludes = includes
+ }
+ CBench _ ->
+ BenchComponentLocalBuildInfo
+ { componentUnitId = this_uid
+ , componentComponentId = this_cid
+ , componentLocalName = cname
+ , componentPackageDeps = cpds
+ , componentExeDeps = exe_deps
+ , componentInternalDeps = internal_deps
+ , componentIncludes = includes
+ }
+ where
+ this_uid = rc_uid rc
+ this_open_uid = rc_open_uid rc
+ this_cid = rc_cid rc
+ cname = componentName (rc_component rc)
+ cpds = rc_depends rc
+ exe_deps = map ann_id $ rc_exe_deps rc
+ is_indefinite =
+ case rc_i rc of
Left _ -> True
Right _ -> False
- includes =
- map (\ci -> (ci_id ci, ci_renaming ci)) $
+ includes =
+ map (\ci -> (ci_id ci, ci_renaming ci)) $
case rc_i rc of
- Left indefc ->
- indefc_includes indefc
- Right instc ->
- map (\ci -> ci { ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci) })
- (instc_includes instc)
- internal_deps = filter isInternal (nodeNeighbors rc)
+ Left indefc ->
+ indefc_includes indefc
+ Right instc ->
+ map
+ (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)})
+ (instc_includes instc)
+ internal_deps = filter isInternal (nodeNeighbors rc)
diff --git a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs
index 5f40fc6085ab4ce9b7c2ffa48a64245ac5a977e0..79408f0ffa2832536a085ed868a95cc2367f001b 100644
--- a/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs
+++ b/Cabal/src/Distribution/Backpack/ConfiguredComponent.hs
@@ -1,80 +1,68 @@
{-# LANGUAGE PatternGuards #-}
--- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.ConfiguredComponent (
- ConfiguredComponent(..),
- cc_name,
- cc_cid,
- cc_pkgid,
- toConfiguredComponent,
- toConfiguredComponents,
- dispConfiguredComponent,
-
- ConfiguredComponentMap,
- extendConfiguredComponentMap,
- -- TODO: Should go somewhere else
- newPackageDepsBehaviour
-) where
+-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
+module Distribution.Backpack.ConfiguredComponent
+ ( ConfiguredComponent (..)
+ , cc_name
+ , cc_cid
+ , cc_pkgid
+ , toConfiguredComponent
+ , toConfiguredComponents
+ , dispConfiguredComponent
+ , ConfiguredComponentMap
+ , extendConfiguredComponentMap
+ -- TODO: Should go somewhere else
+ , newPackageDepsBehaviour
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
+import Prelude ()
import Distribution.Backpack.Id
import Distribution.CabalSpecVersion
-import Distribution.Types.AnnotatedId
-import Distribution.Types.Dependency
-import Distribution.Types.ExeDependency
-import Distribution.Types.IncludeRenaming
-import Distribution.Types.ComponentId
-import Distribution.Types.PackageId
-import Distribution.Types.PackageName
-import Distribution.Types.Mixin
-import Distribution.Types.ComponentName
-import Distribution.Types.LibraryName
-import Distribution.Types.ComponentInclude
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.BuildToolDepends
-import Distribution.Simple.Flag ( Flag )
+import Distribution.Simple.Flag (Flag)
import Distribution.Simple.LocalBuildInfo
+import Distribution.Types.AnnotatedId
+import Distribution.Types.ComponentInclude
+import Distribution.Utils.Generic
import Distribution.Utils.LogProgress
import Distribution.Utils.MapAccum
-import Distribution.Utils.Generic
import Control.Monad
+import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Distribution.Compat.NonEmptySet as NonEmptySet
-import qualified Data.Map as Map
import Distribution.Pretty
-import Text.PrettyPrint (Doc, hang, text, vcat, hsep, quotes, ($$))
+import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($$))
import qualified Text.PrettyPrint as PP
-- | A configured component, we know exactly what its 'ComponentId' is,
-- and the 'ComponentId's of the things it depends on.
-data ConfiguredComponent
- = ConfiguredComponent {
- -- | Unique identifier of component, plus extra useful info.
- cc_ann_id :: AnnotatedId ComponentId,
- -- | The fragment of syntax from the Cabal file describing this
- -- component.
- cc_component :: Component,
- -- | Is this the public library component of the package?
- -- (If we invoke Setup with an instantiation, this is the
- -- component the instantiation applies to.)
- -- Note that in one-component configure mode, this is
- -- always True, because any component is the "public" one.)
- cc_public :: Bool,
- -- | Dependencies on executables from @build-tools@ and
- -- @build-tool-depends@.
- cc_exe_deps :: [AnnotatedId ComponentId],
- -- | The mixins of this package, including both explicit (from
- -- the @mixins@ field) and implicit (from @build-depends@). Not
- -- mix-in linked yet; component configuration only looks at
- -- 'ComponentId's.
- cc_includes :: [ComponentInclude ComponentId IncludeRenaming]
- }
-
+data ConfiguredComponent = ConfiguredComponent
+ { cc_ann_id :: AnnotatedId ComponentId
+ -- ^ Unique identifier of component, plus extra useful info.
+ , cc_component :: Component
+ -- ^ The fragment of syntax from the Cabal file describing this
+ -- component.
+ , cc_public :: Bool
+ -- ^ Is this the public library component of the package?
+ -- (If we invoke Setup with an instantiation, this is the
+ -- component the instantiation applies to.)
+ -- Note that in one-component configure mode, this is
+ -- always True, because any component is the "public" one.)
+ , cc_exe_deps :: [AnnotatedId ComponentId]
+ -- ^ Dependencies on executables from @build-tools@ and
+ -- @build-tool-depends@.
+ , cc_includes :: [ComponentInclude ComponentId IncludeRenaming]
+ -- ^ The mixins of this package, including both explicit (from
+ -- the @mixins@ field) and implicit (from @build-depends@). Not
+ -- mix-in linked yet; component configuration only looks at
+ -- 'ComponentId's.
+ }
-- | Uniquely identifies a configured component.
cc_cid :: ConfiguredComponent -> ComponentId
@@ -93,110 +81,132 @@ cc_name = ann_cname . cc_ann_id
-- | Pretty-print a 'ConfiguredComponent'.
dispConfiguredComponent :: ConfiguredComponent -> Doc
dispConfiguredComponent cc =
- hang (text "component" <+> pretty (cc_cid cc)) 4
- (vcat [ hsep $ [ text "include"
- , pretty (ci_id incl), pretty (ci_renaming incl) ]
- | incl <- cc_includes cc
- ])
+ hang
+ (text "component" <+> pretty (cc_cid cc))
+ 4
+ ( vcat
+ [ hsep $
+ [ text "include"
+ , pretty (ci_id incl)
+ , pretty (ci_renaming incl)
+ ]
+ | incl <- cc_includes cc
+ ]
+ )
-- | Construct a 'ConfiguredComponent', given that the 'ComponentId'
-- and library/executable dependencies are known. The primary
-- work this does is handling implicit @backpack-include@ fields.
mkConfiguredComponent
- :: PackageDescription
- -> ComponentId
- -> [AnnotatedId ComponentId] -- lib deps
- -> [AnnotatedId ComponentId] -- exe deps
- -> Component
- -> LogProgress ConfiguredComponent
+ :: PackageDescription
+ -> ComponentId
+ -> [AnnotatedId ComponentId] -- lib deps
+ -> [AnnotatedId ComponentId] -- exe deps
+ -> Component
+ -> LogProgress ConfiguredComponent
mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do
- -- Resolve each @mixins@ into the actual dependency
- -- from @lib_deps@.
- explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do
- aid <- case Map.lookup (pn, CLibName ln) deps_map of
- Nothing ->
- dieProgress $
- text "Mix-in refers to non-existent library" <+>
- quotes (pretty pn <<>> prettyLN ln) $$
- text "(did you forget to add the package to build-depends?)"
- Just r -> return r
- return ComponentInclude {
- ci_ann_id = aid,
- ci_renaming = rns,
- ci_implicit = False
- }
+ -- Resolve each @mixins@ into the actual dependency
+ -- from @lib_deps@.
+ explicit_includes <- forM (mixins bi) $ \(Mixin pn ln rns) -> do
+ aid <- case Map.lookup (pn, CLibName ln) deps_map of
+ Nothing ->
+ dieProgress $
+ text "Mix-in refers to non-existent library"
+ <+> quotes (pretty pn <<>> prettyLN ln)
+ $$ text "(did you forget to add the package to build-depends?)"
+ Just r -> return r
+ return
+ ComponentInclude
+ { ci_ann_id = aid
+ , ci_renaming = rns
+ , ci_implicit = False
+ }
- -- Any @build-depends@ which is not explicitly mentioned in
- -- @backpack-include@ is converted into an "implicit" include.
- let used_explicitly = Set.fromList (map ci_id explicit_includes)
- implicit_includes
- = map (\aid -> ComponentInclude {
- ci_ann_id = aid,
- ci_renaming = defaultIncludeRenaming,
- ci_implicit = True
- })
- $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps
+ -- Any @build-depends@ which is not explicitly mentioned in
+ -- @backpack-include@ is converted into an "implicit" include.
+ let used_explicitly = Set.fromList (map ci_id explicit_includes)
+ implicit_includes =
+ map
+ ( \aid ->
+ ComponentInclude
+ { ci_ann_id = aid
+ , ci_renaming = defaultIncludeRenaming
+ , ci_implicit = True
+ }
+ )
+ $ filter (flip Set.notMember used_explicitly . ann_id) lib_deps
- return ConfiguredComponent {
- cc_ann_id = AnnotatedId {
- ann_id = this_cid,
- ann_pid = package pkg_descr,
- ann_cname = componentName component
- },
- cc_component = component,
- cc_public = is_public,
- cc_exe_deps = exe_deps,
- cc_includes = explicit_includes ++ implicit_includes
- }
+ return
+ ConfiguredComponent
+ { cc_ann_id =
+ AnnotatedId
+ { ann_id = this_cid
+ , ann_pid = package pkg_descr
+ , ann_cname = componentName component
+ }
+ , cc_component = component
+ , cc_public = is_public
+ , cc_exe_deps = exe_deps
+ , cc_includes = explicit_includes ++ implicit_includes
+ }
where
bi :: BuildInfo
bi = componentBuildInfo component
prettyLN :: LibraryName -> Doc
- prettyLN LMainLibName = PP.empty
+ prettyLN LMainLibName = PP.empty
prettyLN (LSubLibName n) = PP.colon <<>> pretty n
deps_map :: Map (PackageName, ComponentName) (AnnotatedId ComponentId)
- deps_map = Map.fromList [ ((packageName dep, ann_cname dep), dep)
- | dep <- lib_deps ]
+ deps_map =
+ Map.fromList
+ [ ((packageName dep, ann_cname dep), dep)
+ | dep <- lib_deps
+ ]
is_public = componentName component == CLibName LMainLibName
type ConfiguredComponentMap =
- Map PackageName (Map ComponentName (AnnotatedId ComponentId))
+ Map PackageName (Map ComponentName (AnnotatedId ComponentId))
toConfiguredComponent
- :: PackageDescription
- -> ComponentId
- -> ConfiguredComponentMap
- -> ConfiguredComponentMap
- -> Component
- -> LogProgress ConfiguredComponent
+ :: PackageDescription
+ -> ComponentId
+ -> ConfiguredComponentMap
+ -> ConfiguredComponentMap
+ -> Component
+ -> LogProgress ConfiguredComponent
toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
- lib_deps <-
- if newPackageDepsBehaviour pkg_descr
- then fmap concat $ forM (targetBuildDepends bi) $
- \(Dependency name _ sublibs) -> do
- pkg <- case Map.lookup name lib_dep_map of
- Nothing ->
- dieProgress $
- text "Dependency on unbuildable" <+>
- text "package" <+> pretty name
- Just p -> return p
- -- Return all library components
- forM (NonEmptySet.toList sublibs) $ \lib ->
- let comp = CLibName lib in
- case Map.lookup comp pkg of
- Nothing ->
- dieProgress $
- text "Dependency on unbuildable" <+>
- text (showLibraryName lib) <+>
- text "from" <+> pretty name
- Just v -> return v
- else return old_style_lib_deps
- mkConfiguredComponent
- pkg_descr this_cid
- lib_deps exe_deps component
+ lib_deps <-
+ if newPackageDepsBehaviour pkg_descr
+ then fmap concat $
+ forM (targetBuildDepends bi) $
+ \(Dependency name _ sublibs) -> do
+ pkg <- case Map.lookup name lib_dep_map of
+ Nothing ->
+ dieProgress $
+ text "Dependency on unbuildable"
+ <+> text "package"
+ <+> pretty name
+ Just p -> return p
+ -- Return all library components
+ forM (NonEmptySet.toList sublibs) $ \lib ->
+ let comp = CLibName lib
+ in case Map.lookup comp pkg of
+ Nothing ->
+ dieProgress $
+ text "Dependency on unbuildable"
+ <+> text (showLibraryName lib)
+ <+> text "from"
+ <+> pretty name
+ Just v -> return v
+ else return old_style_lib_deps
+ mkConfiguredComponent
+ pkg_descr
+ this_cid
+ lib_deps
+ exe_deps
+ component
where
bi = componentBuildInfo component
-- lib_dep_map contains a mix of internal and external deps.
@@ -206,62 +216,84 @@ toConfiguredComponent pkg_descr this_cid lib_dep_map exe_dep_map component = do
-- this is not supported by old-style deps behavior
-- because it would imply a cyclic dependency for the
-- library itself.
- old_style_lib_deps = [ e
- | (pn, comp_map) <- Map.toList lib_dep_map
- , pn /= packageName pkg_descr
- , (cn, e) <- Map.toList comp_map
- , cn == CLibName LMainLibName ]
+ old_style_lib_deps =
+ [ e
+ | (pn, comp_map) <- Map.toList lib_dep_map
+ , pn /= packageName pkg_descr
+ , (cn, e) <- Map.toList comp_map
+ , cn == CLibName LMainLibName
+ ]
-- We have to nub here, because 'getAllToolDependencies' may return
-- duplicates (see #4986). (NB: This is not needed for lib_deps,
-- since those elaborate into includes, for which there explicitly
-- may be multiple instances of a package)
- exe_deps = ordNub $
+ exe_deps =
+ ordNub $
[ exe
| ExeDependency pn cn _ <- getAllToolDependencies pkg_descr bi
- -- The error suppression here is important, because in general
+ , -- The error suppression here is important, because in general
-- we won't know about external dependencies (e.g., 'happy')
-- which the package is attempting to use (those deps are only
-- fed in when cabal-install uses this codepath.)
-- TODO: Let cabal-install request errors here
- , Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]
+ Just exe <- [Map.lookup (CExeName cn) =<< Map.lookup pn exe_dep_map]
]
-- | Also computes the 'ComponentId', and sets cc_public if necessary.
-- This is Cabal-only; cabal-install won't use this.
toConfiguredComponent'
- :: Bool -- use_external_internal_deps
- -> FlagAssignment
- -> PackageDescription
- -> Bool -- deterministic
- -> Flag String -- configIPID (todo: remove me)
- -> Flag ComponentId -- configCID
- -> ConfiguredComponentMap
- -> Component
- -> LogProgress ConfiguredComponent
-toConfiguredComponent' use_external_internal_deps flags
- pkg_descr deterministic ipid_flag cid_flag
- dep_map component = do
- cc <- toConfiguredComponent
- pkg_descr this_cid
- dep_map dep_map component
- return $ if use_external_internal_deps
- then cc { cc_public = True }
- else cc
- where
- -- TODO: pass component names to it too!
- this_cid = computeComponentId deterministic ipid_flag cid_flag
- (package pkg_descr) (componentName component) (Just (deps, flags))
- deps = [ ann_id aid | m <- Map.elems dep_map
- , aid <- Map.elems m ]
+ :: Bool -- use_external_internal_deps
+ -> FlagAssignment
+ -> PackageDescription
+ -> Bool -- deterministic
+ -> Flag String -- configIPID (todo: remove me)
+ -> Flag ComponentId -- configCID
+ -> ConfiguredComponentMap
+ -> Component
+ -> LogProgress ConfiguredComponent
+toConfiguredComponent'
+ use_external_internal_deps
+ flags
+ pkg_descr
+ deterministic
+ ipid_flag
+ cid_flag
+ dep_map
+ component = do
+ cc <-
+ toConfiguredComponent
+ pkg_descr
+ this_cid
+ dep_map
+ dep_map
+ component
+ return $
+ if use_external_internal_deps
+ then cc{cc_public = True}
+ else cc
+ where
+ -- TODO: pass component names to it too!
+ this_cid =
+ computeComponentId
+ deterministic
+ ipid_flag
+ cid_flag
+ (package pkg_descr)
+ (componentName component)
+ (Just (deps, flags))
+ deps =
+ [ ann_id aid | m <- Map.elems dep_map, aid <- Map.elems m
+ ]
extendConfiguredComponentMap
- :: ConfiguredComponent
- -> ConfiguredComponentMap
- -> ConfiguredComponentMap
+ :: ConfiguredComponent
+ -> ConfiguredComponentMap
+ -> ConfiguredComponentMap
extendConfiguredComponentMap cc =
- Map.insertWith Map.union
- (pkgName (cc_pkgid cc))
- (Map.singleton (cc_name cc) (cc_ann_id cc))
+ Map.insertWith
+ Map.union
+ (pkgName (cc_pkgid cc))
+ (Map.singleton (cc_name cc) (cc_ann_id cc))
-- Compute the 'ComponentId's for a graph of 'Component's. The
-- list of internal components must be topologically sorted
@@ -273,31 +305,42 @@ extendConfiguredComponentMap cc =
-- be used to configure a component that depends on one version of a package for
-- a library and another version for a build-tool.
toConfiguredComponents
- :: Bool -- use_external_internal_deps
- -> FlagAssignment
- -> Bool -- deterministic
- -> Flag String -- configIPID
- -> Flag ComponentId -- configCID
- -> PackageDescription
- -> ConfiguredComponentMap
- -> [Component]
- -> LogProgress [ConfiguredComponent]
+ :: Bool -- use_external_internal_deps
+ -> FlagAssignment
+ -> Bool -- deterministic
+ -> Flag String -- configIPID
+ -> Flag ComponentId -- configCID
+ -> PackageDescription
+ -> ConfiguredComponentMap
+ -> [Component]
+ -> LogProgress [ConfiguredComponent]
toConfiguredComponents
- use_external_internal_deps flags deterministic ipid_flag cid_flag pkg_descr
- dep_map comps
- = fmap snd (mapAccumM go dep_map comps)
- where
- go m component = do
- cc <- toConfiguredComponent'
- use_external_internal_deps flags pkg_descr
- deterministic ipid_flag cid_flag
- m component
+ use_external_internal_deps
+ flags
+ deterministic
+ ipid_flag
+ cid_flag
+ pkg_descr
+ dep_map
+ comps =
+ fmap snd (mapAccumM go dep_map comps)
+ where
+ go m component = do
+ cc <-
+ toConfiguredComponent'
+ use_external_internal_deps
+ flags
+ pkg_descr
+ deterministic
+ ipid_flag
+ cid_flag
+ m
+ component
return (extendConfiguredComponentMap cc m, cc)
newPackageDepsBehaviourMinVersion :: CabalSpecVersion
newPackageDepsBehaviourMinVersion = CabalSpecV1_8
-
-- In older cabal versions, there was only one set of package dependencies for
-- the whole package. In this version, we can have separate dependencies per
-- target, but we only enable this behaviour if the minimum cabal version
@@ -305,4 +348,4 @@ newPackageDepsBehaviourMinVersion = CabalSpecV1_8
-- old behaviour.
newPackageDepsBehaviour :: PackageDescription -> Bool
newPackageDepsBehaviour pkg =
- specVersion pkg >= newPackageDepsBehaviourMinVersion
+ specVersion pkg >= newPackageDepsBehaviourMinVersion
diff --git a/Cabal/src/Distribution/Backpack/DescribeUnitId.hs b/Cabal/src/Distribution/Backpack/DescribeUnitId.hs
index 3dc063bdfcdb5b2655a017d23f01fd1d78f3f9c2..9ea30c2924b955c6e673ac17e386ee9e3af869a7 100644
--- a/Cabal/src/Distribution/Backpack/DescribeUnitId.hs
+++ b/Cabal/src/Distribution/Backpack/DescribeUnitId.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE Rank2Types #-}
+
module Distribution.Backpack.DescribeUnitId where
import Distribution.Compat.Prelude
@@ -36,26 +37,36 @@ import Text.PrettyPrint
-- | Print a Setup message stating (1) what operation we are doing,
-- for (2) which component (with enough details to uniquely identify
-- the build in question.)
---
-setupMessage' :: Pretty a => Verbosity
- -> String -- ^ Operation being done (capitalized), on:
- -> PackageIdentifier -- ^ Package
- -> ComponentName -- ^ Component name
- -> Maybe [(ModuleName, a)] -- ^ Instantiation, if available.
- -- Polymorphic to take
- -- 'OpenModule' or 'Module'
- -> IO ()
+setupMessage'
+ :: Pretty a
+ => Verbosity
+ -> String
+ -- ^ Operation being done (capitalized), on:
+ -> PackageIdentifier
+ -- ^ Package
+ -> ComponentName
+ -- ^ Component name
+ -> Maybe [(ModuleName, a)]
+ -- ^ Instantiation, if available.
+ -- Polymorphic to take
+ -- 'OpenModule' or 'Module'
+ -> IO ()
setupMessage' verbosity msg pkgid cname mb_insts = withFrozenCallStack $ do
- noticeDoc verbosity $
- case mb_insts of
- Just insts | not (null insts) ->
- hang (msg_doc <+> text "instantiated with") 2
- (vcat [ pretty k <+> text "=" <+> pretty v
- | (k,v) <- insts ]) $$
- for_doc
- _ ->
- msg_doc <+> for_doc
-
+ noticeDoc verbosity $
+ case mb_insts of
+ Just insts
+ | not (null insts) ->
+ hang
+ (msg_doc <+> text "instantiated with")
+ 2
+ ( vcat
+ [ pretty k <+> text "=" <+> pretty v
+ | (k, v) <- insts
+ ]
+ )
+ $$ for_doc
+ _ ->
+ msg_doc <+> for_doc
where
msg_doc = text msg <+> text (showComponentName cname)
for_doc = text "for" <+> pretty pkgid <<>> text ".."
diff --git a/Cabal/src/Distribution/Backpack/FullUnitId.hs b/Cabal/src/Distribution/Backpack/FullUnitId.hs
index fbc05386b61d40c74220c0627e592f517fd486d2..0a751a66f2716bac578c07d5e2244d5666583a01 100644
--- a/Cabal/src/Distribution/Backpack/FullUnitId.hs
+++ b/Cabal/src/Distribution/Backpack/FullUnitId.hs
@@ -1,26 +1,27 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Backpack.FullUnitId (
- FullUnitId(..),
- FullDb,
- expandOpenUnitId,
- expandUnitId
-) where
+
+module Distribution.Backpack.FullUnitId
+ ( FullUnitId (..)
+ , FullDb
+ , expandOpenUnitId
+ , expandUnitId
+ ) where
import Distribution.Backpack
-import Distribution.Types.ComponentId
import Distribution.Compat.Prelude
+import Distribution.Types.ComponentId
-- Unlike OpenUnitId, which could direct to a UnitId.
data FullUnitId = FullUnitId ComponentId OpenModuleSubst
- deriving (Show, Generic)
+ deriving (Show, Generic)
type FullDb = DefUnitId -> FullUnitId
expandOpenUnitId :: FullDb -> OpenUnitId -> FullUnitId
-expandOpenUnitId _db (IndefFullUnitId cid subst)
- = FullUnitId cid subst
-expandOpenUnitId db (DefiniteUnitId uid)
- = expandUnitId db uid
+expandOpenUnitId _db (IndefFullUnitId cid subst) =
+ FullUnitId cid subst
+expandOpenUnitId db (DefiniteUnitId uid) =
+ expandUnitId db uid
expandUnitId :: FullDb -> DefUnitId -> FullUnitId
expandUnitId db uid = db uid
diff --git a/Cabal/src/Distribution/Backpack/Id.hs b/Cabal/src/Distribution/Backpack/Id.hs
index 9e1de85028fb9e0722289532b14c740f3c0642d0..38e831acf1795a17c1938d452475123a193e35a3 100644
--- a/Cabal/src/Distribution/Backpack/Id.hs
+++ b/Cabal/src/Distribution/Backpack/Id.hs
@@ -1,74 +1,86 @@
{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE RankNTypes #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.Id(
- computeComponentId,
- computeCompatPackageKey,
-) where
+module Distribution.Backpack.Id
+ ( computeComponentId
+ , computeCompatPackageKey
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
-import Distribution.Simple.Compiler
import Distribution.PackageDescription
-import Distribution.Simple.Flag ( Flag(..) )
+import Distribution.Simple.Compiler
+import Distribution.Simple.Flag (Flag (..))
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.ComponentId
-import Distribution.Types.UnitId
import Distribution.Types.MungedPackageName
+import Distribution.Types.UnitId
import Distribution.Utils.Base62
import Distribution.Version
+import Distribution.Parsec (simpleParsec)
import Distribution.Pretty
- ( prettyShow )
-import Distribution.Parsec ( simpleParsec )
+ ( prettyShow
+ )
-- | This method computes a default, "good enough" 'ComponentId'
-- for a package. The intent is that cabal-install (or the user) will
-- specify a more detailed IPID via the @--ipid@ flag if necessary.
computeComponentId
- :: Bool -- deterministic mode
- -> Flag String
- -> Flag ComponentId
- -> PackageIdentifier
- -> ComponentName
- -- This is used by cabal-install's legacy codepath
- -> Maybe ([ComponentId], FlagAssignment)
- -> ComponentId
+ :: Bool -- deterministic mode
+ -> Flag String
+ -> Flag ComponentId
+ -> PackageIdentifier
+ -> ComponentName
+ -- This is used by cabal-install's legacy codepath
+ -> Maybe ([ComponentId], FlagAssignment)
+ -> ComponentId
computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =
- -- show is found to be faster than intercalate and then replacement of
- -- special character used in intercalating. We cannot simply hash by
- -- doubly concatenating list, as it just flatten out the nested list, so
- -- different sources can produce same hash
- let hash_suffix
- | Just (dep_ipids, flags) <- mb_details
- = "-" ++ hashToBase62
+ -- show is found to be faster than intercalate and then replacement of
+ -- special character used in intercalating. We cannot simply hash by
+ -- doubly concatenating list, as it just flatten out the nested list, so
+ -- different sources can produce same hash
+ let hash_suffix
+ | Just (dep_ipids, flags) <- mb_details =
+ "-"
+ ++ hashToBase62
-- For safety, include the package + version here
-- for GHC 7.10, where just the hash is used as
-- the package key
- ( prettyShow pid
- ++ show dep_ipids
- ++ show flags )
- | otherwise = ""
- generated_base = prettyShow pid ++ hash_suffix
- explicit_base cid0 = fromPathTemplate (InstallDirs.substPathTemplate env
- (toPathTemplate cid0))
- -- Hack to reuse install dirs machinery
- -- NB: no real IPID available at this point
- where env = packageTemplateEnv pid (mkUnitId "")
- actual_base = case mb_ipid of
- Flag ipid0 -> explicit_base ipid0
- NoFlag | deterministic -> prettyShow pid
- | otherwise -> generated_base
- in case mb_cid of
- Flag cid -> cid
- NoFlag -> mkComponentId $ actual_base
- ++ (case componentNameString cname of
- Nothing -> ""
- Just s -> "-" ++ unUnqualComponentName s)
+ ( prettyShow pid
+ ++ show dep_ipids
+ ++ show flags
+ )
+ | otherwise = ""
+ generated_base = prettyShow pid ++ hash_suffix
+ explicit_base cid0 =
+ fromPathTemplate
+ ( InstallDirs.substPathTemplate
+ env
+ (toPathTemplate cid0)
+ )
+ where
+ -- Hack to reuse install dirs machinery
+ -- NB: no real IPID available at this point
+ env = packageTemplateEnv pid (mkUnitId "")
+ actual_base = case mb_ipid of
+ Flag ipid0 -> explicit_base ipid0
+ NoFlag
+ | deterministic -> prettyShow pid
+ | otherwise -> generated_base
+ in case mb_cid of
+ Flag cid -> cid
+ NoFlag ->
+ mkComponentId $
+ actual_base
+ ++ ( case componentNameString cname of
+ Nothing -> ""
+ Just s -> "-" ++ unUnqualComponentName s
+ )
-- | In GHC 8.0, the string we pass to GHC to use for symbol
-- names for a package can be an arbitrary, IPID-compatible string.
@@ -116,30 +128,29 @@ computeComponentId deterministic mb_ipid mb_cid pid cname mb_details =
--
-- * For sub-components, we rehash the IPID into the correct format
-- and pass that.
---
computeCompatPackageKey
- :: Compiler
- -> MungedPackageName
- -> Version
- -> UnitId
- -> String
+ :: Compiler
+ -> MungedPackageName
+ -> Version
+ -> UnitId
+ -> String
computeCompatPackageKey comp pkg_name pkg_version uid
- | not (packageKeySupported comp || unitIdSupported comp)
- = prettyShow pkg_name ++ "-" ++ prettyShow pkg_version
- | not (unifiedIPIDRequired comp) =
- let str = unUnitId uid -- assume no Backpack support
- mb_verbatim_key
- = case simpleParsec str :: Maybe PackageId of
- -- Something like 'foo-0.1', use it verbatim.
- -- (NB: hash tags look like tags, so they are parsed,
- -- so the extra equality check tests if a tag was dropped.)
- Just pid0 | prettyShow pid0 == str -> Just str
- _ -> Nothing
- mb_truncated_key
- = let cand = reverse (takeWhile isAlphaNum (reverse str))
- in if length cand == 22 && all isAlphaNum cand
- then Just cand
- else Nothing
- rehashed_key = hashToBase62 str
- in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)
- | otherwise = prettyShow uid
+ | not (packageKeySupported comp || unitIdSupported comp) =
+ prettyShow pkg_name ++ "-" ++ prettyShow pkg_version
+ | not (unifiedIPIDRequired comp) =
+ let str = unUnitId uid -- assume no Backpack support
+ mb_verbatim_key =
+ case simpleParsec str :: Maybe PackageId of
+ -- Something like 'foo-0.1', use it verbatim.
+ -- (NB: hash tags look like tags, so they are parsed,
+ -- so the extra equality check tests if a tag was dropped.)
+ Just pid0 | prettyShow pid0 == str -> Just str
+ _ -> Nothing
+ mb_truncated_key =
+ let cand = reverse (takeWhile isAlphaNum (reverse str))
+ in if length cand == 22 && all isAlphaNum cand
+ then Just cand
+ else Nothing
+ rehashed_key = hashToBase62 str
+ in fromMaybe rehashed_key (mb_verbatim_key `mplus` mb_truncated_key)
+ | otherwise = prettyShow uid
diff --git a/Cabal/src/Distribution/Backpack/LinkedComponent.hs b/Cabal/src/Distribution/Backpack/LinkedComponent.hs
index 797fef251ac3568c1ab73c87555a6a7ee91ba581..130157df20aa59cd458341f0ce4e8f5a2f21ad1c 100644
--- a/Cabal/src/Distribution/Backpack/LinkedComponent.hs
+++ b/Cabal/src/Distribution/Backpack/LinkedComponent.hs
@@ -1,82 +1,76 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.LinkedComponent (
- LinkedComponent(..),
- lc_insts,
- lc_uid,
- lc_cid,
- lc_pkgid,
- toLinkedComponent,
- toLinkedComponents,
- dispLinkedComponent,
- LinkedComponentMap,
- extendLinkedComponentMap,
-) where
+module Distribution.Backpack.LinkedComponent
+ ( LinkedComponent (..)
+ , lc_insts
+ , lc_uid
+ , lc_cid
+ , lc_pkgid
+ , toLinkedComponent
+ , toLinkedComponents
+ , dispLinkedComponent
+ , LinkedComponentMap
+ , extendLinkedComponentMap
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
+import Prelude ()
import Distribution.Backpack
-import Distribution.Backpack.FullUnitId
import Distribution.Backpack.ConfiguredComponent
+import Distribution.Backpack.FullUnitId
+import Distribution.Backpack.MixLink
+import Distribution.Backpack.ModuleScope
import Distribution.Backpack.ModuleShape
import Distribution.Backpack.PreModuleShape
-import Distribution.Backpack.ModuleScope
import Distribution.Backpack.UnifyM
-import Distribution.Backpack.MixLink
import Distribution.Utils.MapAccum
-import Distribution.Types.AnnotatedId
-import Distribution.Types.ComponentName
-import Distribution.Types.ModuleReexport
-import Distribution.Types.ModuleRenaming
-import Distribution.Types.IncludeRenaming
-import Distribution.Types.ComponentInclude
-import Distribution.Types.ComponentId
-import Distribution.Types.PackageId
+import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
-import Distribution.ModuleName
import Distribution.Simple.LocalBuildInfo
-import Distribution.Verbosity
+import Distribution.Types.AnnotatedId
+import Distribution.Types.ComponentInclude
import Distribution.Utils.LogProgress
+import Distribution.Verbosity
-import qualified Data.Set as Set
import qualified Data.Map as Map
+import qualified Data.Set as Set
import Distribution.Pretty (pretty)
-import Text.PrettyPrint (Doc, hang, text, vcat, ($+$), hsep, quotes)
+import Text.PrettyPrint (Doc, hang, hsep, quotes, text, vcat, ($+$))
-- | A linked component is a component that has been mix-in linked, at
-- which point we have determined how all the dependencies of the
-- component are explicitly instantiated (in the form of an OpenUnitId).
-- 'ConfiguredComponent' is mix-in linked into 'LinkedComponent', which
-- is then instantiated into 'ReadyComponent'.
-data LinkedComponent
- = LinkedComponent {
- -- | Uniquely identifies linked component
- lc_ann_id :: AnnotatedId ComponentId,
- -- | Corresponds to 'cc_component'.
- lc_component :: Component,
- -- | @build-tools@ and @build-tool-depends@ dependencies.
- -- Corresponds to 'cc_exe_deps'.
- lc_exe_deps :: [AnnotatedId OpenUnitId],
- -- | Is this the public library of a package? Corresponds to
- -- 'cc_public'.
- lc_public :: Bool,
- -- | Corresponds to 'cc_includes', but (1) this does not contain
- -- includes of signature packages (packages with no exports),
- -- and (2) the 'ModuleRenaming' for requirements (stored in
- -- 'IncludeRenaming') has been removed, as it is reflected in
- -- 'OpenUnitId'.)
- lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
- -- | Like 'lc_includes', but this specifies includes on
- -- signature packages which have no exports.
- lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming],
- -- | The module shape computed by mix-in linking. This is
- -- newly computed from 'ConfiguredComponent'
- lc_shape :: ModuleShape
- }
+data LinkedComponent = LinkedComponent
+ { lc_ann_id :: AnnotatedId ComponentId
+ -- ^ Uniquely identifies linked component
+ , lc_component :: Component
+ -- ^ Corresponds to 'cc_component'.
+ , lc_exe_deps :: [AnnotatedId OpenUnitId]
+ -- ^ @build-tools@ and @build-tool-depends@ dependencies.
+ -- Corresponds to 'cc_exe_deps'.
+ , lc_public :: Bool
+ -- ^ Is this the public library of a package? Corresponds to
+ -- 'cc_public'.
+ , lc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
+ -- ^ Corresponds to 'cc_includes', but (1) this does not contain
+ -- includes of signature packages (packages with no exports),
+ -- and (2) the 'ModuleRenaming' for requirements (stored in
+ -- 'IncludeRenaming') has been removed, as it is reflected in
+ -- 'OpenUnitId'.)
+ , lc_sig_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
+ -- ^ Like 'lc_includes', but this specifies includes on
+ -- signature packages which have no exports.
+ , lc_shape :: ModuleShape
+ -- ^ The module shape computed by mix-in linking. This is
+ -- newly computed from 'ConfiguredComponent'
+ }
-- | Uniquely identifies a 'LinkedComponent'. Corresponds to
-- 'cc_cid'.
@@ -96,94 +90,122 @@ lc_uid lc = IndefFullUnitId (lc_cid lc) . Map.fromList $ lc_insts lc
-- | The instantiation of 'lc_uid'; this always has the invariant
-- that it is a mapping from a module name @A@ to @<A>@ (the hole A).
lc_insts :: LinkedComponent -> [(ModuleName, OpenModule)]
-lc_insts lc = [ (req, OpenModuleVar req)
- | req <- Set.toList (modShapeRequires (lc_shape lc)) ]
+lc_insts lc =
+ [ (req, OpenModuleVar req)
+ | req <- Set.toList (modShapeRequires (lc_shape lc))
+ ]
dispLinkedComponent :: LinkedComponent -> Doc
dispLinkedComponent lc =
- hang (text "unit" <+> pretty (lc_uid lc)) 4 $
- vcat [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)
- | incl <- lc_includes lc ]
- $+$
- vcat [ text "signature include" <+> pretty (ci_id incl)
- | incl <- lc_sig_includes lc ]
- $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))
+ hang (text "unit" <+> pretty (lc_uid lc)) 4 $
+ vcat
+ [ text "include" <+> pretty (ci_id incl) <+> pretty (ci_renaming incl)
+ | incl <- lc_includes lc
+ ]
+ $+$ vcat
+ [ text "signature include" <+> pretty (ci_id incl)
+ | incl <- lc_sig_includes lc
+ ]
+ $+$ dispOpenModuleSubst (modShapeProvides (lc_shape lc))
instance Package LinkedComponent where
- packageId = lc_pkgid
+ packageId = lc_pkgid
toLinkedComponent
- :: Verbosity
- -> FullDb
- -> PackageId
- -> LinkedComponentMap
- -> ConfiguredComponent
- -> LogProgress LinkedComponent
-toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
- cc_ann_id = aid@AnnotatedId { ann_id = this_cid },
- cc_component = component,
- cc_exe_deps = exe_deps,
- cc_public = is_public,
- cc_includes = cid_includes
- } = do
+ :: Verbosity
+ -> FullDb
+ -> PackageId
+ -> LinkedComponentMap
+ -> ConfiguredComponent
+ -> LogProgress LinkedComponent
+toLinkedComponent
+ verbosity
+ db
+ this_pid
+ pkg_map
+ ConfiguredComponent
+ { cc_ann_id = aid@AnnotatedId{ann_id = this_cid}
+ , cc_component = component
+ , cc_exe_deps = exe_deps
+ , cc_public = is_public
+ , cc_includes = cid_includes
+ } = do
let
- -- The explicitly specified requirements, provisions and
- -- reexports from the Cabal file. These are only non-empty for
- -- libraries; everything else is trivial.
- (src_reqs :: [ModuleName],
- src_provs :: [ModuleName],
- src_reexports :: [ModuleReexport]) =
- case component of
- CLib lib -> (signatures lib,
- exposedModules lib,
- reexportedModules lib)
- _ -> ([], [], [])
- src_hidden = otherModules (componentBuildInfo component)
-
- -- Take each included ComponentId and resolve it into an
- -- *unlinked* unit identity. We will use unification (relying
- -- on the ModuleShape) to resolve these into linked identities.
- unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
- unlinked_includes = [ ComponentInclude (fmap lookupUid dep_aid) rns i
- | ComponentInclude dep_aid rns i <- cid_includes ]
-
- lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
- lookupUid cid = fromMaybe (error "linkComponent: lookupUid")
- (Map.lookup cid pkg_map)
+ -- The explicitly specified requirements, provisions and
+ -- reexports from the Cabal file. These are only non-empty for
+ -- libraries; everything else is trivial.
+ ( src_reqs :: [ModuleName]
+ , src_provs :: [ModuleName]
+ , src_reexports :: [ModuleReexport]
+ ) =
+ case component of
+ CLib lib ->
+ ( signatures lib
+ , exposedModules lib
+ , reexportedModules lib
+ )
+ _ -> ([], [], [])
+ src_hidden = otherModules (componentBuildInfo component)
+
+ -- Take each included ComponentId and resolve it into an
+ -- \*unlinked* unit identity. We will use unification (relying
+ -- on the ModuleShape) to resolve these into linked identities.
+ unlinked_includes :: [ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming]
+ unlinked_includes =
+ [ ComponentInclude (fmap lookupUid dep_aid) rns i
+ | ComponentInclude dep_aid rns i <- cid_includes
+ ]
+
+ lookupUid :: ComponentId -> (OpenUnitId, ModuleShape)
+ lookupUid cid =
+ fromMaybe
+ (error "linkComponent: lookupUid")
+ (Map.lookup cid pkg_map)
let orErr (Right x) = return x
orErr (Left [err]) = dieProgress err
orErr (Left errs) = do
- dieProgress (vcat (intersperse (text "") -- double newline!
- [ hang (text "-") 2 err | err <- errs]))
+ dieProgress
+ ( vcat
+ ( intersperse
+ (text "") -- double newline!
+ [hang (text "-") 2 err | err <- errs]
+ )
+ )
-- Pre-shaping
- let pre_shape = mixLinkPreModuleShape $
- PreModuleShape {
- preModShapeProvides = Set.fromList (src_provs ++ src_hidden),
- preModShapeRequires = Set.fromList src_reqs
- } : [ renamePreModuleShape (toPreModuleShape sh) rns
- | ComponentInclude (AnnotatedId { ann_id = (_, sh) }) rns _ <- unlinked_includes ]
- reqs = preModShapeRequires pre_shape
- insts = [ (req, OpenModuleVar req)
- | req <- Set.toList reqs ]
+ let pre_shape =
+ mixLinkPreModuleShape $
+ PreModuleShape
+ { preModShapeProvides = Set.fromList (src_provs ++ src_hidden)
+ , preModShapeRequires = Set.fromList src_reqs
+ }
+ : [ renamePreModuleShape (toPreModuleShape sh) rns
+ | ComponentInclude (AnnotatedId{ann_id = (_, sh)}) rns _ <- unlinked_includes
+ ]
+ reqs = preModShapeRequires pre_shape
+ insts =
+ [ (req, OpenModuleVar req)
+ | req <- Set.toList reqs
+ ]
this_uid = IndefFullUnitId this_cid . Map.fromList $ insts
-- OK, actually do unification
-- TODO: the unification monad might return errors, in which
-- case we have to deal. Use monadic bind for now.
- (linked_shape0 :: ModuleScope,
- linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming],
- linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming])
- <- orErr $ runUnifyM verbosity this_cid db $ do
+ ( linked_shape0 :: ModuleScope
+ , linked_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]
+ , linked_sig_includes0 :: [ComponentInclude OpenUnitId ModuleRenaming]
+ ) <-
+ orErr $ runUnifyM verbosity this_cid db $ do
-- The unification monad is implemented using mutable
-- references. Thus, we must convert our *pure* data
-- structures into mutable ones to perform unification.
let convertMod :: (ModuleName -> ModuleSource) -> ModuleName -> UnifyM s (ModuleScopeU s)
convertMod from m = do
- m_u <- convertModule (OpenModule this_uid m)
- return (Map.singleton m [WithSource (from m) m_u], Map.empty)
+ 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 <- traverse (convertMod FromExposedModules) src_provs
-- Handle 'other-modules'
@@ -192,8 +214,8 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
-- 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_u <- convertModule (OpenModuleVar req)
+ return (Map.empty, Map.singleton req [WithSource (FromSignatures req) req_u])
req_shapes_u <- traverse convertReq src_reqs
-- Handle 'mixins'
@@ -201,22 +223,26 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
failIfErrs -- Prevent error cascade
-- Mix-in link everything! mixLink is the real workhorse.
- shape_u <- mixLink $ exposed_mod_shapes_u
- ++ other_mod_shapes_u
- ++ req_shapes_u
- ++ incl_shapes_u
+ shape_u <-
+ mixLink $
+ exposed_mod_shapes_u
+ ++ other_mod_shapes_u
+ ++ req_shapes_u
+ ++ incl_shapes_u
-- 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
- let component_name = pretty $ ann_cname dep_aid
- uid <- convertUnitIdU (ann_id dep_aid) component_name
- return (ComponentInclude {
- ci_ann_id = dep_aid { ann_id = uid },
- ci_renaming = rns,
- ci_implicit = i
- })
+ let component_name = pretty $ ann_cname dep_aid
+ uid <- convertUnitIdU (ann_id dep_aid) component_name
+ return
+ ( ComponentInclude
+ { ci_ann_id = dep_aid{ann_id = uid}
+ , ci_renaming = rns
+ , ci_implicit = i
+ }
+ )
shape <- convertModuleScopeU shape_u
let (includes_u, sig_includes_u) = partitionEithers all_includes_u
@@ -225,23 +251,26 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
return (shape, incls, sig_incls)
let isNotLib (CLib _) = False
- isNotLib _ = True
+ isNotLib _ = True
when (not (Set.null reqs) && isNotLib component) $
- dieProgress $
- hang (text "Non-library component has unfilled requirements:")
- 4 (vcat [pretty req | req <- Set.toList reqs])
+ dieProgress $
+ hang
+ (text "Non-library component has unfilled requirements:")
+ 4
+ (vcat [pretty req | req <- Set.toList reqs])
-- NB: do NOT include hidden modules here: GHC 7.10's ghc-pkg
-- won't allow it (since someone could directly synthesize
-- an 'InstalledPackageInfo' that violates abstraction.)
-- Though, maybe it should be relaxed?
let src_hidden_set = Set.fromList src_hidden
- linked_shape = linked_shape0 {
- modScopeProvides =
+ linked_shape =
+ linked_shape0
+ { modScopeProvides =
-- Would rather use withoutKeys but need BC
Map.filterWithKey
- (\k _ -> not (k `Set.member` src_hidden_set))
- (modScopeProvides linked_shape0)
+ (\k _ -> not (k `Set.member` src_hidden_set))
+ (modScopeProvides linked_shape0)
}
-- OK, compute the reexports
@@ -250,27 +279,29 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
-- once.
let hdl :: [Either Doc a] -> LogProgress [a]
hdl es =
- case partitionEithers es of
- ([], rs) -> return rs
- (ls, _) ->
- dieProgress $
- hang (text "Problem with module re-exports:") 2
- (vcat [hang (text "-") 2 l | l <- ls])
+ case partitionEithers es of
+ ([], rs) -> return rs
+ (ls, _) ->
+ dieProgress $
+ hang
+ (text "Problem with module re-exports:")
+ 2
+ (vcat [hang (text "-") 2 l | l <- ls])
reexports_list <- hdl . (flip map) src_reexports $ \reex@(ModuleReexport mb_pn from to) -> do
case Map.lookup from (modScopeProvides linked_shape) of
- Just cands@(x0:xs0) -> do
+ Just cands@(x0 : xs0) -> do
-- Make sure there is at least one candidate
(x, xs) <-
case mb_pn of
Just pn ->
- let matches_pn (FromMixins pn' _ _) = pn == pn'
+ let matches_pn (FromMixins pn' _ _) = pn == pn'
matches_pn (FromBuildDepends pn' _) = pn == pn'
matches_pn (FromExposedModules _) = pn == packageName this_pid
- matches_pn (FromOtherModules _) = pn == packageName this_pid
- matches_pn (FromSignatures _) = pn == packageName this_pid
- in case filter (matches_pn . getSource) cands of
- (x1:xs1) -> return (x1, xs1)
- _ -> Left (brokenReexportMsg reex)
+ matches_pn (FromOtherModules _) = pn == packageName this_pid
+ matches_pn (FromSignatures _) = pn == packageName this_pid
+ in case filter (matches_pn . getSource) cands of
+ (x1 : xs1) -> return (x1, xs1)
+ _ -> Left (brokenReexportMsg reex)
Nothing -> return (x0, xs0)
-- Test that all the candidates are consistent
case filter (\x' -> unWithSource x /= unWithSource x') xs of
@@ -282,33 +313,36 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
-- TODO: maybe check this earlier; it's syntactically obvious.
let build_reexports m (k, v)
- | Map.member k m =
- dieProgress $ hsep
- [ text "Module name ", pretty k, text " is exported multiple times." ]
- | otherwise = return (Map.insert k v m)
- provs <- foldM build_reexports Map.empty $
- -- TODO: doublecheck we have checked for
- -- src_provs duplicates already!
- [ (mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs ] ++
- reexports_list
+ | Map.member k m =
+ dieProgress $
+ hsep
+ [text "Module name ", pretty k, text " is exported multiple times."]
+ | otherwise = return (Map.insert k v m)
+ provs <-
+ foldM build_reexports Map.empty $
+ -- TODO: doublecheck we have checked for
+ -- src_provs duplicates already!
+ [(mod_name, OpenModule this_uid mod_name) | mod_name <- src_provs]
+ ++ reexports_list
let final_linked_shape = ModuleShape provs (Map.keysSet (modScopeRequires linked_shape))
-- See Note Note [Signature package special case]
let (linked_includes, linked_sig_includes)
- | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])
- | otherwise = (linked_includes0, linked_sig_includes0)
-
- return $ LinkedComponent {
- lc_ann_id = aid,
- lc_component = component,
- lc_public = is_public,
- -- These must be executables
- lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps,
- lc_shape = final_linked_shape,
- lc_includes = linked_includes,
- lc_sig_includes = linked_sig_includes
- }
+ | Set.null reqs = (linked_includes0 ++ linked_sig_includes0, [])
+ | otherwise = (linked_includes0, linked_sig_includes0)
+
+ return $
+ LinkedComponent
+ { lc_ann_id = aid
+ , lc_component = component
+ , lc_public = is_public
+ , -- These must be executables
+ lc_exe_deps = map (fmap (\cid -> IndefFullUnitId cid Map.empty)) exe_deps
+ , lc_shape = final_linked_shape
+ , lc_includes = linked_includes
+ , lc_sig_includes = linked_sig_includes
+ }
-- Note [Signature package special case]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -336,63 +370,79 @@ toLinkedComponent verbosity db this_pid pkg_map ConfiguredComponent {
-- Handle mix-in linking for components. In the absence of Backpack,
-- every ComponentId gets converted into a UnitId by way of SimpleUnitId.
toLinkedComponents
- :: Verbosity
- -> FullDb
- -> PackageId
- -> LinkedComponentMap
- -> [ConfiguredComponent]
- -> LogProgress [LinkedComponent]
-toLinkedComponents verbosity db this_pid lc_map0 comps
- = fmap snd (mapAccumM go lc_map0 comps)
- where
- go :: Map ComponentId (OpenUnitId, ModuleShape)
- -> ConfiguredComponent
- -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
- go lc_map cc = do
- lc <- addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $
- toLinkedComponent verbosity db this_pid lc_map cc
- return (extendLinkedComponentMap lc lc_map, lc)
+ :: Verbosity
+ -> FullDb
+ -> PackageId
+ -> LinkedComponentMap
+ -> [ConfiguredComponent]
+ -> LogProgress [LinkedComponent]
+toLinkedComponents verbosity db this_pid lc_map0 comps =
+ fmap snd (mapAccumM go lc_map0 comps)
+ where
+ go
+ :: Map ComponentId (OpenUnitId, ModuleShape)
+ -> ConfiguredComponent
+ -> LogProgress (Map ComponentId (OpenUnitId, ModuleShape), LinkedComponent)
+ go lc_map cc = do
+ lc <-
+ addProgressCtx (text "In the stanza" <+> text (componentNameStanza (cc_name cc))) $
+ toLinkedComponent verbosity db this_pid lc_map cc
+ return (extendLinkedComponentMap lc lc_map, lc)
type LinkedComponentMap = Map ComponentId (OpenUnitId, ModuleShape)
-extendLinkedComponentMap :: LinkedComponent
- -> LinkedComponentMap
- -> LinkedComponentMap
+extendLinkedComponentMap
+ :: LinkedComponent
+ -> LinkedComponentMap
+ -> LinkedComponentMap
extendLinkedComponentMap lc m =
- Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m
+ Map.insert (lc_cid lc) (lc_uid lc, lc_shape lc) m
brokenReexportMsg :: ModuleReexport -> Doc
brokenReexportMsg (ModuleReexport (Just pn) from _to) =
- vcat [ text "The package" <+> quotes (pretty pn)
- , text "does not export a module" <+> quotes (pretty from) ]
+ vcat
+ [ text "The package" <+> quotes (pretty pn)
+ , text "does not export a module" <+> quotes (pretty from)
+ ]
brokenReexportMsg (ModuleReexport Nothing from _to) =
- vcat [ text "The module" <+> quotes (pretty from)
- , text "is not exported by any suitable package."
- , text "It occurs in neither the 'exposed-modules' of this package,"
- , text "nor any of its 'build-depends' dependencies." ]
+ vcat
+ [ text "The module" <+> quotes (pretty from)
+ , text "is not exported by any suitable package."
+ , text "It occurs in neither the 'exposed-modules' of this package,"
+ , text "nor any of its 'build-depends' dependencies."
+ ]
ambiguousReexportMsg :: ModuleReexport -> ModuleWithSource -> [ModuleWithSource] -> Doc
ambiguousReexportMsg (ModuleReexport mb_pn from _to) y1 ys =
- vcat [ text "Ambiguous reexport" <+> quotes (pretty from)
- , hang (text "It could refer to either:") 2
- (vcat (msg : msgs))
- , help_msg mb_pn ]
+ vcat
+ [ text "Ambiguous reexport" <+> quotes (pretty from)
+ , hang
+ (text "It could refer to either:")
+ 2
+ (vcat (msg : msgs))
+ , help_msg mb_pn
+ ]
where
- msg = text " " <+> displayModuleWithSource y1
+ msg = text " " <+> displayModuleWithSource y1
msgs = [text "or" <+> displayModuleWithSource y | y <- ys]
help_msg Nothing =
-- TODO: This advice doesn't help if the ambiguous exports
-- come from a package named the same thing
- vcat [ text "The ambiguity can be resolved by qualifying the"
- , text "re-export with a package name."
- , text "The syntax is 'packagename:ModuleName [as NewName]'." ]
+ vcat
+ [ text "The ambiguity can be resolved by qualifying the"
+ , text "re-export with a package name."
+ , text "The syntax is 'packagename:ModuleName [as NewName]'."
+ ]
-- Qualifying won't help that much.
help_msg (Just _) =
- vcat [ text "The ambiguity can be resolved by using the"
- , text "mixins field to rename one of the module"
- , text "names differently." ]
- displayModuleWithSource y
- = vcat [ quotes (pretty (unWithSource y))
- , text "brought into scope by" <+>
- dispModuleSource (getSource y)
- ]
+ vcat
+ [ text "The ambiguity can be resolved by using the"
+ , text "mixins field to rename one of the module"
+ , text "names differently."
+ ]
+ displayModuleWithSource y =
+ vcat
+ [ quotes (pretty (unWithSource y))
+ , text "brought into scope by"
+ <+> dispModuleSource (getSource y)
+ ]
diff --git a/Cabal/src/Distribution/Backpack/MixLink.hs b/Cabal/src/Distribution/Backpack/MixLink.hs
index 8b44e74e6e510f380d6f077fecde0203537ac59c..b358612b244f634e3f27dff72133973ea908bf30 100644
--- a/Cabal/src/Distribution/Backpack/MixLink.hs
+++ b/Cabal/src/Distribution/Backpack/MixLink.hs
@@ -1,26 +1,27 @@
{-# LANGUAGE NondecreasingIndentation #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.MixLink (
- mixLink,
-) where
+module Distribution.Backpack.MixLink
+ ( mixLink
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
+import Prelude ()
import Distribution.Backpack
-import Distribution.Backpack.UnifyM
import Distribution.Backpack.FullUnitId
import Distribution.Backpack.ModuleScope
+import Distribution.Backpack.UnifyM
-import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.ModuleName
import Distribution.Pretty
import Distribution.Types.ComponentId
+import qualified Distribution.Utils.UnionFind as UnionFind
-import Text.PrettyPrint
import Control.Monad
-import qualified Data.Map as Map
import qualified Data.Foldable as F
+import qualified Data.Map as Map
+import Text.PrettyPrint
-----------------------------------------------------------------------
-- Linking
@@ -28,78 +29,98 @@ import qualified Data.Foldable as F
-- | Given to scopes of provisions and requirements, link them together.
mixLink :: [ModuleScopeU s] -> UnifyM s (ModuleScopeU s)
mixLink scopes = do
- let provs = Map.unionsWith (++) (map fst scopes)
- -- Invariant: any identically named holes refer to same mutable cell
- reqs = Map.unionsWith (++) (map snd scopes)
- filled = Map.intersectionWithKey linkProvision provs reqs
- F.sequenceA_ filled
- let remaining = Map.difference reqs filled
- return (provs, remaining)
+ let provs = Map.unionsWith (++) (map fst scopes)
+ -- Invariant: any identically named holes refer to same mutable cell
+ reqs = Map.unionsWith (++) (map snd scopes)
+ filled = Map.intersectionWithKey linkProvision provs reqs
+ F.sequenceA_ filled
+ let remaining = Map.difference reqs filled
+ return (provs, remaining)
-- | Link a list of possibly provided modules to a single
-- requirement. This applies a side-condition that all
-- of the provided modules at the same name are *actually*
-- the same module.
-linkProvision :: ModuleName
- -> [ModuleWithSourceU s] -- provs
- -> [ModuleWithSourceU s] -- reqs
- -> UnifyM s [ModuleWithSourceU s]
-linkProvision mod_name ret@(prov:provs) (req:reqs) = do
- -- TODO: coalesce all the non-unifying modules together
- forM_ provs $ \prov' -> do
- -- Careful: read it out BEFORE unifying, because the
- -- unification algorithm preemptively unifies modules
- mod <- convertModuleU (unWithSource prov)
- mod' <- convertModuleU (unWithSource prov')
- r <- unify prov prov'
- case r of
- Just () -> return ()
- Nothing -> do
- addErr $
- text "Ambiguous module" <+> quotes (pretty mod_name) $$
- text "It could refer to" <+>
- ( text " " <+> (quotes (pretty mod) $$ in_scope_by (getSource prov)) $$
- text "or" <+> (quotes (pretty mod') $$ in_scope_by (getSource prov')) ) $$
- link_doc
+linkProvision
+ :: ModuleName
+ -> [ModuleWithSourceU s] -- provs
+ -> [ModuleWithSourceU s] -- reqs
+ -> UnifyM s [ModuleWithSourceU s]
+linkProvision mod_name ret@(prov : provs) (req : reqs) = do
+ -- TODO: coalesce all the non-unifying modules together
+ forM_ provs $ \prov' -> do
+ -- Careful: read it out BEFORE unifying, because the
+ -- unification algorithm preemptively unifies modules
mod <- convertModuleU (unWithSource prov)
- req_mod <- convertModuleU (unWithSource req)
- self_cid <- fmap unify_self_cid getUnifEnv
- case mod of
- OpenModule (IndefFullUnitId cid _) _
- | cid == self_cid -> addErr $
- text "Cannot instantiate requirement" <+> quotes (pretty mod_name) <+>
- in_scope_by (getSource req) $$
- text "with locally defined module" <+> in_scope_by (getSource prov) $$
- text "as this would create a cyclic dependency, which GHC does not support." $$
- text "Try moving this module to a separate library, e.g.," $$
- text "create a new stanza: library 'sublib'."
- _ -> return ()
- r <- unify prov req
+ mod' <- convertModuleU (unWithSource prov')
+ r <- unify prov prov'
case r of
- Just () -> return ()
- Nothing -> do
- -- TODO: Record and report WHERE the bad constraint came from
- addErr $ text "Could not instantiate requirement" <+> quotes (pretty mod_name) $$
- nest 4 (text "Expected:" <+> pretty mod $$
- text "Actual: " <+> pretty req_mod) $$
- parens (text "This can occur if an exposed module of" <+>
- text "a libraries shares a name with another module.") $$
- link_doc
- return ret
+ Just () -> return ()
+ Nothing -> do
+ addErr $
+ text "Ambiguous module"
+ <+> quotes (pretty mod_name)
+ $$ text "It could refer to"
+ <+> ( text " "
+ <+> (quotes (pretty mod) $$ in_scope_by (getSource prov))
+ $$ text "or"
+ <+> (quotes (pretty mod') $$ in_scope_by (getSource prov'))
+ )
+ $$ link_doc
+ mod <- convertModuleU (unWithSource prov)
+ req_mod <- convertModuleU (unWithSource req)
+ self_cid <- fmap unify_self_cid getUnifEnv
+ case mod of
+ OpenModule (IndefFullUnitId cid _) _
+ | cid == self_cid ->
+ addErr $
+ text "Cannot instantiate requirement"
+ <+> quotes (pretty mod_name)
+ <+> in_scope_by (getSource req)
+ $$ text "with locally defined module"
+ <+> in_scope_by (getSource prov)
+ $$ text "as this would create a cyclic dependency, which GHC does not support."
+ $$ text "Try moving this module to a separate library, e.g.,"
+ $$ text "create a new stanza: library 'sublib'."
+ _ -> return ()
+ r <- unify prov req
+ case r of
+ Just () -> return ()
+ Nothing -> do
+ -- TODO: Record and report WHERE the bad constraint came from
+ addErr $
+ text "Could not instantiate requirement"
+ <+> quotes (pretty mod_name)
+ $$ nest
+ 4
+ ( text "Expected:"
+ <+> pretty mod
+ $$ text "Actual: "
+ <+> pretty req_mod
+ )
+ $$ parens
+ ( text "This can occur if an exposed module of"
+ <+> text "a libraries shares a name with another module."
+ )
+ $$ link_doc
+ return ret
where
- unify s1 s2 = tryM $ addErrContext short_link_doc
- $ unifyModule (unWithSource s1) (unWithSource s2)
+ unify s1 s2 =
+ tryM $
+ addErrContext short_link_doc $
+ unifyModule (unWithSource s1) (unWithSource s2)
in_scope_by s = text "brought into scope by" <+> dispModuleSource s
short_link_doc = text "While filling requirement" <+> quotes (pretty mod_name)
link_doc = text "While filling requirements of" <+> reqs_doc
reqs_doc
| null reqs = dispModuleSource (getSource req)
- | otherwise = ( text " " <+> dispModuleSource (getSource req) $$
- vcat [ text "and" <+> dispModuleSource (getSource r) | r <- reqs])
+ | otherwise =
+ ( text " "
+ <+> dispModuleSource (getSource req)
+ $$ vcat [text "and" <+> dispModuleSource (getSource r) | r <- reqs]
+ )
linkProvision _ _ _ = error "linkProvision"
-
-
-----------------------------------------------------------------------
-- The unification algorithm
@@ -108,78 +129,93 @@ linkProvision _ _ _ = error "linkProvision"
unifyUnitId :: UnitIdU s -> UnitIdU s -> UnifyM s ()
unifyUnitId uid1_u uid2_u
- | uid1_u == uid2_u = return ()
- | otherwise = do
- xuid1 <- liftST $ UnionFind.find uid1_u
- xuid2 <- liftST $ UnionFind.find uid2_u
- case (xuid1, xuid2) of
- (UnitIdThunkU u1, UnitIdThunkU u2)
- | u1 == u2 -> return ()
- | otherwise ->
- failWith $ hang (text "Couldn't match unit IDs:") 4
- (text " " <+> pretty u1 $$
- text "and" <+> pretty u2)
- (UnitIdThunkU uid1, UnitIdU _ cid2 insts2)
- -> unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u
- (UnitIdU _ cid1 insts1, UnitIdThunkU uid2)
- -> unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u
- (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2)
- -> unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
+ | uid1_u == uid2_u = return ()
+ | otherwise = do
+ xuid1 <- liftST $ UnionFind.find uid1_u
+ xuid2 <- liftST $ UnionFind.find uid2_u
+ case (xuid1, xuid2) of
+ (UnitIdThunkU u1, UnitIdThunkU u2)
+ | u1 == u2 -> return ()
+ | otherwise ->
+ failWith $
+ hang
+ (text "Couldn't match unit IDs:")
+ 4
+ ( text " "
+ <+> pretty u1
+ $$ text "and"
+ <+> pretty u2
+ )
+ (UnitIdThunkU uid1, UnitIdU _ cid2 insts2) ->
+ unifyThunkWith cid2 insts2 uid2_u uid1 uid1_u
+ (UnitIdU _ cid1 insts1, UnitIdThunkU uid2) ->
+ unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u
+ (UnitIdU _ cid1 insts1, UnitIdU _ cid2 insts2) ->
+ unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
-unifyThunkWith :: ComponentId
- -> Map ModuleName (ModuleU s)
- -> UnitIdU s
- -> DefUnitId
- -> UnitIdU s
- -> UnifyM s ()
+unifyThunkWith
+ :: ComponentId
+ -> Map ModuleName (ModuleU s)
+ -> UnitIdU s
+ -> DefUnitId
+ -> UnitIdU s
+ -> UnifyM s ()
unifyThunkWith cid1 insts1 uid1_u uid2 uid2_u = do
- db <- fmap unify_db getUnifEnv
- let FullUnitId cid2 insts2' = expandUnitId db uid2
- insts2 <- convertModuleSubst insts2'
- unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
+ db <- fmap unify_db getUnifEnv
+ let FullUnitId cid2 insts2' = expandUnitId db uid2
+ insts2 <- convertModuleSubst insts2'
+ unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u
-unifyInner :: ComponentId
- -> Map ModuleName (ModuleU s)
- -> UnitIdU s
- -> ComponentId
- -> Map ModuleName (ModuleU s)
- -> UnitIdU s
- -> UnifyM s ()
+unifyInner
+ :: ComponentId
+ -> Map ModuleName (ModuleU s)
+ -> UnitIdU s
+ -> ComponentId
+ -> Map ModuleName (ModuleU s)
+ -> UnitIdU s
+ -> UnifyM s ()
unifyInner cid1 insts1 uid1_u cid2 insts2 uid2_u = do
- when (cid1 /= cid2) $
- -- TODO: if we had a package identifier, could be an
- -- easier to understand error message.
- failWith $
- hang (text "Couldn't match component IDs:") 4
- (text " " <+> pretty cid1 $$
- text "and" <+> pretty cid2)
- -- The KEY STEP which makes this a Huet-style unification
- -- algorithm. (Also a payoff of using union-find.)
- -- We can build infinite unit IDs this way, which is necessary
- -- for support mutual recursion. NB: union keeps the SECOND
- -- descriptor, so we always arrange for a UnitIdThunkU to live
- -- there.
- liftST $ UnionFind.union uid1_u uid2_u
- F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2
+ when (cid1 /= cid2) $
+ -- TODO: if we had a package identifier, could be an
+ -- easier to understand error message.
+ failWith $
+ hang
+ (text "Couldn't match component IDs:")
+ 4
+ ( text " "
+ <+> pretty cid1
+ $$ text "and"
+ <+> pretty cid2
+ )
+ -- The KEY STEP which makes this a Huet-style unification
+ -- algorithm. (Also a payoff of using union-find.)
+ -- We can build infinite unit IDs this way, which is necessary
+ -- for support mutual recursion. NB: union keeps the SECOND
+ -- descriptor, so we always arrange for a UnitIdThunkU to live
+ -- there.
+ liftST $ UnionFind.union uid1_u uid2_u
+ F.sequenceA_ $ Map.intersectionWith unifyModule insts1 insts2
-- | Imperatively unify two modules.
unifyModule :: ModuleU s -> ModuleU s -> UnifyM s ()
unifyModule mod1_u mod2_u
- | mod1_u == mod2_u = return ()
- | otherwise = do
- mod1 <- liftST $ UnionFind.find mod1_u
- mod2 <- liftST $ UnionFind.find mod2_u
- case (mod1, mod2) of
- (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u
- (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u
- (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do
- when (mod_name1 /= mod_name2) $
- failWith $
- hang (text "Cannot match module names") 4 $
- text " " <+> pretty mod_name1 $$
- text "and" <+> pretty mod_name2
- -- NB: this is not actually necessary (because we'll
- -- detect loops eventually in 'unifyUnitId'), but it
- -- seems harmless enough
- liftST $ UnionFind.union mod1_u mod2_u
- unifyUnitId uid1 uid2
+ | mod1_u == mod2_u = return ()
+ | otherwise = do
+ mod1 <- liftST $ UnionFind.find mod1_u
+ mod2 <- liftST $ UnionFind.find mod2_u
+ case (mod1, mod2) of
+ (ModuleVarU _, _) -> liftST $ UnionFind.union mod1_u mod2_u
+ (_, ModuleVarU _) -> liftST $ UnionFind.union mod2_u mod1_u
+ (ModuleU uid1 mod_name1, ModuleU uid2 mod_name2) -> do
+ when (mod_name1 /= mod_name2) $
+ failWith $
+ hang (text "Cannot match module names") 4 $
+ text " "
+ <+> pretty mod_name1
+ $$ text "and"
+ <+> pretty mod_name2
+ -- NB: this is not actually necessary (because we'll
+ -- detect loops eventually in 'unifyUnitId'), but it
+ -- seems harmless enough
+ liftST $ UnionFind.union mod1_u mod2_u
+ unifyUnitId uid1 uid2
diff --git a/Cabal/src/Distribution/Backpack/ModSubst.hs b/Cabal/src/Distribution/Backpack/ModSubst.hs
index 7a9a01e3af7b4c0091e80d8edde58296f58c094d..984d4c0be986f1e69e6bc6b843c9529c2ea20fe9 100644
--- a/Cabal/src/Distribution/Backpack/ModSubst.hs
+++ b/Cabal/src/Distribution/Backpack/ModSubst.hs
@@ -5,13 +5,12 @@
-- applied to them.
--
-- See also <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
+module Distribution.Backpack.ModSubst
+ ( ModSubst (..)
+ ) where
-module Distribution.Backpack.ModSubst (
- ModSubst(..),
-) where
-
-import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
+import Prelude ()
import Distribution.Backpack
import Distribution.ModuleName
@@ -21,32 +20,33 @@ import qualified Data.Set as Set
-- | Applying module substitutions to semantic objects.
class ModSubst a where
- -- In notation, substitution is postfix, which implies
- -- putting it on the right hand side, but for partial
- -- application it's more convenient to have it on the left
- -- hand side.
- modSubst :: OpenModuleSubst -> a -> a
+ -- In notation, substitution is postfix, which implies
+ -- putting it on the right hand side, but for partial
+ -- application it's more convenient to have it on the left
+ -- hand side.
+ modSubst :: OpenModuleSubst -> a -> a
instance ModSubst OpenModule where
- modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name
- modSubst subst mod@(OpenModuleVar mod_name)
- | Just mod' <- Map.lookup mod_name subst = mod'
- | otherwise = mod
+ modSubst subst (OpenModule cid mod_name) = OpenModule (modSubst subst cid) mod_name
+ modSubst subst mod@(OpenModuleVar mod_name)
+ | Just mod' <- Map.lookup mod_name subst = mod'
+ | otherwise = mod
instance ModSubst OpenUnitId where
- modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)
- modSubst _subst uid = uid
+ modSubst subst (IndefFullUnitId cid insts) = IndefFullUnitId cid (modSubst subst insts)
+ modSubst _subst uid = uid
instance ModSubst (Set ModuleName) where
- modSubst subst reqs
- = Set.union (Set.difference reqs (Map.keysSet subst))
- (openModuleSubstFreeHoles subst)
+ modSubst subst reqs =
+ Set.union
+ (Set.difference reqs (Map.keysSet subst))
+ (openModuleSubstFreeHoles subst)
-- Substitutions are functorial. NB: this means that
-- there is an @instance 'ModSubst' 'ModuleSubst'@!
instance ModSubst a => ModSubst (Map k a) where
- modSubst subst = fmap (modSubst subst)
+ modSubst subst = fmap (modSubst subst)
instance ModSubst a => ModSubst [a] where
- modSubst subst = fmap (modSubst subst)
+ modSubst subst = fmap (modSubst subst)
instance ModSubst a => ModSubst (k, a) where
- modSubst subst (x,y) = (x, modSubst subst y)
+ modSubst subst (x, y) = (x, modSubst subst y)
diff --git a/Cabal/src/Distribution/Backpack/ModuleScope.hs b/Cabal/src/Distribution/Backpack/ModuleScope.hs
index a6736d528d5399416ba9b03a68e77b6773e0e93d..5e18766a15dec3e6af8db384254d7784e0ee364d 100644
--- a/Cabal/src/Distribution/Backpack/ModuleScope.hs
+++ b/Cabal/src/Distribution/Backpack/ModuleScope.hs
@@ -1,30 +1,31 @@
+{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE DeriveFoldable #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.ModuleScope (
- -- * Module scopes
- ModuleScope(..),
- ModuleProvides,
- ModuleRequires,
- ModuleSource(..),
- dispModuleSource,
- WithSource(..),
- unWithSource,
- getSource,
- ModuleWithSource,
- emptyModuleScope,
-) where
+module Distribution.Backpack.ModuleScope
+ ( -- * Module scopes
+ ModuleScope (..)
+ , ModuleProvides
+ , ModuleRequires
+ , ModuleSource (..)
+ , dispModuleSource
+ , WithSource (..)
+ , unWithSource
+ , getSource
+ , ModuleWithSource
+ , emptyModuleScope
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.ModuleName
-import Distribution.Types.IncludeRenaming
-import Distribution.Types.PackageName
+import Distribution.Pretty
import Distribution.Types.ComponentName
+import Distribution.Types.IncludeRenaming
import Distribution.Types.LibraryName
-import Distribution.Pretty
+import Distribution.Types.PackageName
import Distribution.Backpack
import Distribution.Backpack.ModSubst
@@ -32,7 +33,6 @@ import Distribution.Backpack.ModSubst
import qualified Data.Map as Map
import Text.PrettyPrint
-
-----------------------------------------------------------------------
-- Module scopes
@@ -60,17 +60,16 @@ import Text.PrettyPrint
-- Alternate strategy: go ahead and unify, and then if it is revealed
-- that some requirements got filled "out-of-thin-air", error.
-
-- | A 'ModuleScope' describes the modules and requirements that
-- are in-scope as we are processing a Cabal package. Unlike
-- a 'ModuleShape', there may be multiple modules in scope at
-- the same 'ModuleName'; this is only an error if we attempt
-- to use those modules to fill a requirement. A 'ModuleScope'
-- can influence the 'ModuleShape' via a reexport.
-data ModuleScope = ModuleScope {
- modScopeProvides :: ModuleProvides,
- modScopeRequires :: ModuleRequires
- }
+data ModuleScope = ModuleScope
+ { modScopeProvides :: ModuleProvides
+ , modScopeRequires :: ModuleRequires
+ }
-- | An empty 'ModuleScope'.
emptyModuleScope :: ModuleScope
@@ -79,49 +78,53 @@ emptyModuleScope = ModuleScope Map.empty Map.empty
-- | Every 'Module' in scope at a 'ModuleName' is annotated with
-- the 'PackageName' it comes from.
type ModuleProvides = Map ModuleName [ModuleWithSource]
+
-- | INVARIANT: entries for ModuleName m, have msrc_module is OpenModuleVar m
type ModuleRequires = Map ModuleName [ModuleWithSource]
+
-- TODO: consider newtping the two types above.
-- | Description of where a module participating in mixin linking came
-- from.
data ModuleSource
- = FromMixins PackageName ComponentName IncludeRenaming
- | FromBuildDepends PackageName ComponentName
- | FromExposedModules ModuleName
- | FromOtherModules ModuleName
- | FromSignatures ModuleName
+ = FromMixins PackageName ComponentName IncludeRenaming
+ | FromBuildDepends PackageName ComponentName
+ | FromExposedModules ModuleName
+ | FromOtherModules ModuleName
+ | FromSignatures ModuleName
+
-- We don't have line numbers, but if we did, we'd want to record that
-- too
-- TODO: Deduplicate this with Distribution.Backpack.UnifyM.ci_msg
dispModuleSource :: ModuleSource -> Doc
-dispModuleSource (FromMixins pn cn incls)
- = text "mixins:" <+> dispComponent pn cn <+> pretty incls
-dispModuleSource (FromBuildDepends pn cn)
- = text "build-depends:" <+> dispComponent pn cn
-dispModuleSource (FromExposedModules m)
- = text "exposed-modules:" <+> pretty m
-dispModuleSource (FromOtherModules m)
- = text "other-modules:" <+> pretty m
-dispModuleSource (FromSignatures m)
- = text "signatures:" <+> pretty m
+dispModuleSource (FromMixins pn cn incls) =
+ text "mixins:" <+> dispComponent pn cn <+> pretty incls
+dispModuleSource (FromBuildDepends pn cn) =
+ text "build-depends:" <+> dispComponent pn cn
+dispModuleSource (FromExposedModules m) =
+ text "exposed-modules:" <+> pretty m
+dispModuleSource (FromOtherModules m) =
+ text "other-modules:" <+> pretty m
+dispModuleSource (FromSignatures m) =
+ text "signatures:" <+> pretty m
-- Dependency
dispComponent :: PackageName -> ComponentName -> Doc
dispComponent pn cn =
- -- NB: This syntax isn't quite the source syntax, but it
- -- should be clear enough. To do source syntax, we'd
- -- need to know what the package we're linking is.
- case cn of
- CLibName LMainLibName -> pretty pn
- CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn
- -- Case below shouldn't happen
- _ -> pretty pn <+> parens (pretty cn)
+ -- NB: This syntax isn't quite the source syntax, but it
+ -- should be clear enough. To do source syntax, we'd
+ -- need to know what the package we're linking is.
+ case cn of
+ CLibName LMainLibName -> pretty pn
+ CLibName (LSubLibName ucn) -> pretty pn <<>> colon <<>> pretty ucn
+ -- Case below shouldn't happen
+ _ -> pretty pn <+> parens (pretty cn)
-- | An 'OpenModule', annotated with where it came from in a Cabal file.
data WithSource a = WithSource ModuleSource a
- deriving (Functor, Foldable, Traversable)
+ deriving (Functor, Foldable, Traversable)
+
unWithSource :: WithSource a -> a
unWithSource (WithSource _ x) = x
getSource :: WithSource a -> ModuleSource
@@ -129,4 +132,4 @@ getSource (WithSource s _) = s
type ModuleWithSource = WithSource OpenModule
instance ModSubst a => ModSubst (WithSource a) where
- modSubst subst (WithSource s m) = WithSource s (modSubst subst m)
+ modSubst subst (WithSource s m) = WithSource s (modSubst subst m)
diff --git a/Cabal/src/Distribution/Backpack/ModuleShape.hs b/Cabal/src/Distribution/Backpack/ModuleShape.hs
index d1862776e13af8372f787552c3815b9c74cfb7ba..039a6a30239a64269c5082e97851dff17040a4f8 100644
--- a/Cabal/src/Distribution/Backpack/ModuleShape.hs
+++ b/Cabal/src/Distribution/Backpack/ModuleShape.hs
@@ -1,21 +1,22 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.ModuleShape (
- -- * Module shapes
- ModuleShape(..),
- emptyModuleShape,
- shapeInstalledPackage,
-) where
+module Distribution.Backpack.ModuleShape
+ ( -- * Module shapes
+ ModuleShape (..)
+ , emptyModuleShape
+ , shapeInstalledPackage
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
+import Prelude ()
-import Distribution.ModuleName
import Distribution.InstalledPackageInfo as IPI
+import Distribution.ModuleName
-import Distribution.Backpack.ModSubst
import Distribution.Backpack
+import Distribution.Backpack.ModSubst
import qualified Data.Map as Map
import qualified Data.Set as Set
@@ -26,18 +27,18 @@ import qualified Data.Set as Set
-- | A 'ModuleShape' describes the provisions and requirements of
-- a library. We can extract a 'ModuleShape' from an
-- 'InstalledPackageInfo'.
-data ModuleShape = ModuleShape {
- modShapeProvides :: OpenModuleSubst,
- modShapeRequires :: Set ModuleName
- }
- deriving (Eq, Show, Generic, Typeable)
+data ModuleShape = ModuleShape
+ { modShapeProvides :: OpenModuleSubst
+ , modShapeRequires :: Set ModuleName
+ }
+ deriving (Eq, Show, Generic, Typeable)
instance Binary ModuleShape
instance Structured ModuleShape
instance ModSubst ModuleShape where
- modSubst subst (ModuleShape provs reqs)
- = ModuleShape (modSubst subst provs) (modSubst subst reqs)
+ modSubst subst (ModuleShape provs reqs) =
+ ModuleShape (modSubst subst provs) (modSubst subst reqs)
-- | The default module shape, with no provisions and no requirements.
emptyModuleShape :: ModuleShape
@@ -78,7 +79,7 @@ shapeInstalledPackage ipi = ModuleShape (Map.fromList provs) reqs
uid = installedOpenUnitId ipi
provs = map shapeExposedModule (IPI.exposedModules ipi)
reqs = requiredSignatures ipi
- shapeExposedModule (IPI.ExposedModule mod_name Nothing)
- = (mod_name, OpenModule uid mod_name)
- shapeExposedModule (IPI.ExposedModule mod_name (Just mod))
- = (mod_name, mod)
+ shapeExposedModule (IPI.ExposedModule mod_name Nothing) =
+ (mod_name, OpenModule uid mod_name)
+ shapeExposedModule (IPI.ExposedModule mod_name (Just mod)) =
+ (mod_name, mod)
diff --git a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs
index 2fcfdf1cc8324f0d6344db82630b721ea38fd4eb..859f5424d1b3803ab461181debc0b5756f000357 100644
--- a/Cabal/src/Distribution/Backpack/PreExistingComponent.hs
+++ b/Cabal/src/Distribution/Backpack/PreExistingComponent.hs
@@ -1,59 +1,55 @@
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.PreExistingComponent (
- PreExistingComponent(..),
- ipiToPreExistingComponent,
-) where
+module Distribution.Backpack.PreExistingComponent
+ ( PreExistingComponent (..)
+ , ipiToPreExistingComponent
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Backpack.ModuleShape
import Distribution.Backpack
-import Distribution.Types.ComponentId
-import Distribution.Types.MungedPackageId
-import Distribution.Types.PackageId
-import Distribution.Types.UnitId
-import Distribution.Types.ComponentName
-import Distribution.Types.PackageName
+import Distribution.Backpack.ModuleShape
import Distribution.Package
+import Distribution.Types.ComponentName
+import Distribution.Types.MungedPackageId
import qualified Data.Map as Map
-import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import qualified Distribution.InstalledPackageInfo as Installed
-- | Stripped down version of 'LinkedComponent' for things
-- we don't need to know how to build.
-data PreExistingComponent
- = PreExistingComponent {
- -- | The actual name of the package. This may DISAGREE with 'pc_pkgid'
- -- for internal dependencies: e.g., an internal component @lib@ may be
- -- munged to @z-pkg-z-lib@, but we still want to use it when we see
- -- @lib@ in @build-depends@
- pc_pkgname :: PackageName,
- -- | The actual name of the component.
- pc_compname :: ComponentName,
- pc_munged_id :: MungedPackageId,
- pc_uid :: UnitId,
- pc_cid :: ComponentId,
- pc_open_uid :: OpenUnitId,
- pc_shape :: ModuleShape
- }
+data PreExistingComponent = PreExistingComponent
+ { pc_pkgname :: PackageName
+ -- ^ The actual name of the package. This may DISAGREE with 'pc_pkgid'
+ -- for internal dependencies: e.g., an internal component @lib@ may be
+ -- munged to @z-pkg-z-lib@, but we still want to use it when we see
+ -- @lib@ in @build-depends@
+ , pc_compname :: ComponentName
+ -- ^ The actual name of the component.
+ , pc_munged_id :: MungedPackageId
+ , pc_uid :: UnitId
+ , pc_cid :: ComponentId
+ , pc_open_uid :: OpenUnitId
+ , pc_shape :: ModuleShape
+ }
-- | Convert an 'InstalledPackageInfo' into a 'PreExistingComponent',
-- which was brought into scope under the 'PackageName' (important for
-- a package qualified reference.)
ipiToPreExistingComponent :: InstalledPackageInfo -> PreExistingComponent
ipiToPreExistingComponent ipi =
- PreExistingComponent {
- pc_pkgname = packageName ipi,
- pc_compname = CLibName $ Installed.sourceLibName ipi,
- pc_munged_id = mungedId ipi,
- pc_uid = Installed.installedUnitId ipi,
- pc_cid = Installed.installedComponentId ipi,
- pc_open_uid =
- IndefFullUnitId (Installed.installedComponentId ipi)
- (Map.fromList (Installed.instantiatedWith ipi)),
- pc_shape = shapeInstalledPackage ipi
+ PreExistingComponent
+ { pc_pkgname = packageName ipi
+ , pc_compname = CLibName $ Installed.sourceLibName ipi
+ , pc_munged_id = mungedId ipi
+ , pc_uid = Installed.installedUnitId ipi
+ , pc_cid = Installed.installedComponentId ipi
+ , pc_open_uid =
+ IndefFullUnitId
+ (Installed.installedComponentId ipi)
+ (Map.fromList (Installed.instantiatedWith ipi))
+ , pc_shape = shapeInstalledPackage ipi
}
instance HasMungedPackageId PreExistingComponent where
@@ -61,7 +57,8 @@ instance HasMungedPackageId PreExistingComponent where
instance Package PreExistingComponent where
packageId pec = PackageIdentifier (pc_pkgname pec) v
- where MungedPackageId _ v = pc_munged_id pec
+ where
+ MungedPackageId _ v = pc_munged_id pec
instance HasUnitId PreExistingComponent where
installedUnitId = pc_uid
diff --git a/Cabal/src/Distribution/Backpack/PreModuleShape.hs b/Cabal/src/Distribution/Backpack/PreModuleShape.hs
index f07cd6123e48bb67c79738f93bc937d781f5fdbb..1a26e59be5d68e8082d5f6e9641b9cb6b9421cea 100644
--- a/Cabal/src/Distribution/Backpack/PreModuleShape.hs
+++ b/Cabal/src/Distribution/Backpack/PreModuleShape.hs
@@ -1,38 +1,38 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Backpack.PreModuleShape (
- PreModuleShape(..),
- toPreModuleShape,
- renamePreModuleShape,
- mixLinkPreModuleShape,
-) where
+module Distribution.Backpack.PreModuleShape
+ ( PreModuleShape (..)
+ , toPreModuleShape
+ , renamePreModuleShape
+ , mixLinkPreModuleShape
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import qualified Data.Set as Set
import qualified Data.Map as Map
+import qualified Data.Set as Set
import Distribution.Backpack.ModuleShape
+import Distribution.ModuleName
import Distribution.Types.IncludeRenaming
import Distribution.Types.ModuleRenaming
-import Distribution.ModuleName
-data PreModuleShape = PreModuleShape {
- preModShapeProvides :: Set ModuleName,
- preModShapeRequires :: Set ModuleName
- }
- deriving (Eq, Show, Generic)
+data PreModuleShape = PreModuleShape
+ { preModShapeProvides :: Set ModuleName
+ , preModShapeRequires :: Set ModuleName
+ }
+ deriving (Eq, Show, Generic)
toPreModuleShape :: ModuleShape -> PreModuleShape
toPreModuleShape (ModuleShape provs reqs) = PreModuleShape (Map.keysSet provs) reqs
renamePreModuleShape :: PreModuleShape -> IncludeRenaming -> PreModuleShape
renamePreModuleShape (PreModuleShape provs reqs) (IncludeRenaming prov_rn req_rn) =
- PreModuleShape
- (Set.fromList (mapMaybe prov_fn (Set.toList provs)))
- (Set.map req_fn reqs)
+ PreModuleShape
+ (Set.fromList (mapMaybe prov_fn (Set.toList provs)))
+ (Set.map req_fn reqs)
where
prov_fn = interpModuleRenaming prov_rn
req_fn k = fromMaybe k (interpModuleRenaming req_rn k)
@@ -41,4 +41,4 @@ mixLinkPreModuleShape :: [PreModuleShape] -> PreModuleShape
mixLinkPreModuleShape shapes = PreModuleShape provs (Set.difference reqs provs)
where
provs = Set.unions (map preModShapeProvides shapes)
- reqs = Set.unions (map preModShapeRequires shapes)
+ reqs = Set.unions (map preModShapeRequires shapes)
diff --git a/Cabal/src/Distribution/Backpack/ReadyComponent.hs b/Cabal/src/Distribution/Backpack/ReadyComponent.hs
index 1064776203bc62035c21c43ccf27838dc1e3b2fe..7a3523d5eab2aa72bf8d80fe6b9d555dc2e0420e 100644
--- a/Cabal/src/Distribution/Backpack/ReadyComponent.hs
+++ b/Cabal/src/Distribution/Backpack/ReadyComponent.hs
@@ -1,186 +1,199 @@
-{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeFamilies #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.ReadyComponent (
- ReadyComponent(..),
- InstantiatedComponent(..),
- IndefiniteComponent(..),
- rc_depends,
- rc_uid,
- rc_pkgid,
- dispReadyComponent,
- toReadyComponents,
-) where
+module Distribution.Backpack.ReadyComponent
+ ( ReadyComponent (..)
+ , InstantiatedComponent (..)
+ , IndefiniteComponent (..)
+ , rc_depends
+ , rc_uid
+ , rc_pkgid
+ , dispReadyComponent
+ , toReadyComponents
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding ((<>))
+import Prelude ()
import Distribution.Backpack
import Distribution.Backpack.LinkedComponent
import Distribution.Backpack.ModuleShape
+import Distribution.Compat.Graph (IsNode (..))
import Distribution.Types.AnnotatedId
-import Distribution.Types.ModuleRenaming
import Distribution.Types.Component
-import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentId
+import Distribution.Types.ComponentInclude
import Distribution.Types.ComponentName
-import Distribution.Types.PackageId
-import Distribution.Types.PackageName.Magic
-import Distribution.Types.UnitId
-import Distribution.Compat.Graph (IsNode(..))
+import Distribution.Types.Library
+import Distribution.Types.LibraryName
import Distribution.Types.Module
+import Distribution.Types.ModuleRenaming
import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
-import Distribution.Types.Library
-import Distribution.Types.LibraryName
+import Distribution.Types.PackageId
+import Distribution.Types.PackageName.Magic
+import Distribution.Types.UnitId
import Distribution.ModuleName
import Distribution.Package
import Distribution.Simple.Utils
import Control.Monad
-import Text.PrettyPrint
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Text.PrettyPrint
-import Distribution.Version
import Distribution.Pretty
+import Distribution.Version
-- | A 'ReadyComponent' is one that we can actually generate build
-- products for. We have a ready component for the typecheck-only
-- products of every indefinite package, as well as a ready component
-- for every way these packages can be fully instantiated.
---
-data ReadyComponent
- = ReadyComponent {
- rc_ann_id :: AnnotatedId UnitId,
- -- | The 'OpenUnitId' for this package. At the moment, this
- -- is used in only one case, which is to determine if an
- -- export is of a module from this library (indefinite
- -- libraries record these exports as 'OpenModule');
- -- 'rc_open_uid' can be conveniently used to test for
- -- equality, whereas 'UnitId' cannot always be used in this
- -- case.
- rc_open_uid :: OpenUnitId,
- -- | Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid'
- -- records a 'ComponentId', it coincides with this one.
- rc_cid :: ComponentId,
- -- | Corresponds to 'lc_component'.
- rc_component :: Component,
- -- | Corresponds to 'lc_exe_deps'.
- -- Build-tools don't participate in mix-in linking.
- -- (but what if they could?)
- rc_exe_deps :: [AnnotatedId UnitId],
- -- | Corresponds to 'lc_public'.
- rc_public :: Bool,
- -- | Extra metadata depending on whether or not this is an
- -- indefinite library (typechecked only) or an instantiated
- -- component (can be compiled).
- rc_i :: Either IndefiniteComponent InstantiatedComponent
- }
+data ReadyComponent = ReadyComponent
+ { rc_ann_id :: AnnotatedId UnitId
+ , rc_open_uid :: OpenUnitId
+ -- ^ The 'OpenUnitId' for this package. At the moment, this
+ -- is used in only one case, which is to determine if an
+ -- export is of a module from this library (indefinite
+ -- libraries record these exports as 'OpenModule');
+ -- 'rc_open_uid' can be conveniently used to test for
+ -- equality, whereas 'UnitId' cannot always be used in this
+ -- case.
+ , rc_cid :: ComponentId
+ -- ^ Corresponds to 'lc_cid'. Invariant: if 'rc_open_uid'
+ -- records a 'ComponentId', it coincides with this one.
+ , rc_component :: Component
+ -- ^ Corresponds to 'lc_component'.
+ , rc_exe_deps :: [AnnotatedId UnitId]
+ -- ^ Corresponds to 'lc_exe_deps'.
+ -- Build-tools don't participate in mix-in linking.
+ -- (but what if they could?)
+ , rc_public :: Bool
+ -- ^ Corresponds to 'lc_public'.
+ , rc_i :: Either IndefiniteComponent InstantiatedComponent
+ -- ^ Extra metadata depending on whether or not this is an
+ -- indefinite library (typechecked only) or an instantiated
+ -- component (can be compiled).
+ }
-- | The final, string 'UnitId' that will uniquely identify
-- the compilation products of this component.
-rc_uid :: ReadyComponent -> UnitId
+rc_uid :: ReadyComponent -> UnitId
rc_uid = ann_id . rc_ann_id
-- | Corresponds to 'lc_pkgid'.
-rc_pkgid :: ReadyComponent -> PackageId
+rc_pkgid :: ReadyComponent -> PackageId
rc_pkgid = ann_pid . rc_ann_id
-- | An 'InstantiatedComponent' is a library which is fully instantiated
-- (or, possibly, has no requirements at all.)
-data InstantiatedComponent
- = InstantiatedComponent {
- -- | How this library was instantiated.
- instc_insts :: [(ModuleName, Module)],
- -- | Dependencies induced by 'instc_insts'. These are recorded
- -- here because there isn't a convenient way otherwise to get
- -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.
- instc_insts_deps :: [(UnitId, MungedPackageId)],
- -- | The modules exported/reexported by this library.
- instc_provides :: Map ModuleName Module,
- -- | The dependencies which need to be passed to the compiler
- -- to bring modules into scope. These always refer to installed
- -- fully instantiated libraries.
- instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
- }
+data InstantiatedComponent = InstantiatedComponent
+ { instc_insts :: [(ModuleName, Module)]
+ -- ^ How this library was instantiated.
+ , instc_insts_deps :: [(UnitId, MungedPackageId)]
+ -- ^ Dependencies induced by 'instc_insts'. These are recorded
+ -- here because there isn't a convenient way otherwise to get
+ -- the 'PackageId' we need to fill 'componentPackageDeps' as needed.
+ , instc_provides :: Map ModuleName Module
+ -- ^ The modules exported/reexported by this library.
+ , instc_includes :: [ComponentInclude DefUnitId ModuleRenaming]
+ -- ^ The dependencies which need to be passed to the compiler
+ -- to bring modules into scope. These always refer to installed
+ -- fully instantiated libraries.
+ }
-- | An 'IndefiniteComponent' is a library with requirements
-- which we will typecheck only.
-data IndefiniteComponent
- = IndefiniteComponent {
- -- | The requirements of the library.
- indefc_requires :: [ModuleName],
- -- | The modules exported/reexported by this library.
- indefc_provides :: Map ModuleName OpenModule,
- -- | The dependencies which need to be passed to the compiler
- -- to bring modules into scope. These are 'OpenUnitId' because
- -- these may refer to partially instantiated libraries.
- indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
- }
+data IndefiniteComponent = IndefiniteComponent
+ { indefc_requires :: [ModuleName]
+ -- ^ The requirements of the library.
+ , indefc_provides :: Map ModuleName OpenModule
+ -- ^ The modules exported/reexported by this library.
+ , indefc_includes :: [ComponentInclude OpenUnitId ModuleRenaming]
+ -- ^ The dependencies which need to be passed to the compiler
+ -- to bring modules into scope. These are 'OpenUnitId' because
+ -- these may refer to partially instantiated libraries.
+ }
-- | Compute the dependencies of a 'ReadyComponent' that should
-- be recorded in the @depends@ field of 'InstalledPackageInfo'.
rc_depends :: ReadyComponent -> [(UnitId, MungedPackageId)]
rc_depends rc = ordNub $
- case rc_i rc of
- Left indefc ->
- map (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))
- (indefc_includes indefc)
- Right instc ->
- map (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))
- (instc_includes instc)
- ++ instc_insts_deps instc
+ case rc_i rc of
+ Left indefc ->
+ map
+ (\ci -> (abstractUnitId $ ci_id ci, toMungedPackageId ci))
+ (indefc_includes indefc)
+ Right instc ->
+ map
+ (\ci -> (unDefUnitId $ ci_id ci, toMungedPackageId ci))
+ (instc_includes instc)
+ ++ instc_insts_deps instc
where
toMungedPackageId :: Pretty id => ComponentInclude id rn -> MungedPackageId
toMungedPackageId ci =
- computeCompatPackageId
- (ci_pkgid ci)
- (case ci_cname ci of
- CLibName name -> name
- _ -> error $ prettyShow (rc_cid rc) ++
- " depends on non-library " ++ prettyShow (ci_id ci))
+ computeCompatPackageId
+ (ci_pkgid ci)
+ ( case ci_cname ci of
+ CLibName name -> name
+ _ ->
+ error $
+ prettyShow (rc_cid rc)
+ ++ " depends on non-library "
+ ++ prettyShow (ci_id ci)
+ )
-- | Get the 'MungedPackageId' of a 'ReadyComponent' IF it is
-- a library.
rc_munged_id :: ReadyComponent -> MungedPackageId
rc_munged_id rc =
- computeCompatPackageId
- (rc_pkgid rc)
- (case rc_component rc of
- CLib lib -> libName lib
- _ -> error "rc_munged_id: not library")
+ computeCompatPackageId
+ (rc_pkgid rc)
+ ( case rc_component rc of
+ CLib lib -> libName lib
+ _ -> error "rc_munged_id: not library"
+ )
instance Package ReadyComponent where
- packageId = rc_pkgid
+ packageId = rc_pkgid
instance HasUnitId ReadyComponent where
- installedUnitId = rc_uid
+ installedUnitId = rc_uid
instance IsNode ReadyComponent where
- type Key ReadyComponent = UnitId
- nodeKey = rc_uid
- nodeNeighbors rc =
- (case rc_i rc of
- Right inst | [] <- instc_insts inst
- -> []
- | otherwise
- -> [newSimpleUnitId (rc_cid rc)]
- _ -> []) ++
- ordNub (map fst (rc_depends rc)) ++
- map ann_id (rc_exe_deps rc)
+ type Key ReadyComponent = UnitId
+ nodeKey = rc_uid
+ nodeNeighbors rc =
+ ( case rc_i rc of
+ Right inst
+ | [] <- instc_insts inst ->
+ []
+ | otherwise ->
+ [newSimpleUnitId (rc_cid rc)]
+ _ -> []
+ )
+ ++ ordNub (map fst (rc_depends rc))
+ ++ map ann_id (rc_exe_deps rc)
dispReadyComponent :: ReadyComponent -> Doc
dispReadyComponent rc =
- hang (text (case rc_i rc of
- Left _ -> "indefinite"
- Right _ -> "definite")
- <+> pretty (nodeKey rc)
- {- <+> dispModSubst (Map.fromList (lc_insts lc)) -} ) 4 $
- vcat [ text "depends" <+> pretty uid
- | uid <- nodeNeighbors rc ]
+ hang
+ ( text
+ ( case rc_i rc of
+ Left _ -> "indefinite"
+ Right _ -> "definite"
+ )
+ <+> pretty (nodeKey rc)
+ {- <+> dispModSubst (Map.fromList (lc_insts lc)) -}
+ )
+ 4
+ $ vcat
+ [ text "depends" <+> pretty uid
+ | uid <- nodeNeighbors rc
+ ]
-- | The state of 'InstM'; a mapping from 'UnitId's to their
-- ready component, or @Nothing@ if its an external
@@ -189,22 +202,25 @@ type InstS = Map UnitId (Maybe ReadyComponent)
-- | A state monad for doing instantiations (can't use actual
-- State because that would be an extra dependency.)
-newtype InstM a = InstM { runInstM :: InstS -> (a, InstS) }
+newtype InstM a = InstM {runInstM :: InstS -> (a, InstS)}
instance Functor InstM where
- fmap f (InstM m) = InstM $ \s -> let (x, s') = m s
- in (f x, s')
+ fmap f (InstM m) = InstM $ \s ->
+ let (x, s') = m s
+ in (f x, s')
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'')
+ 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 = pure
- InstM m >>= f = InstM $ \s -> let (x, s') = m s
- in runInstM (f x) s'
+ return = pure
+ InstM m >>= f = InstM $ \s ->
+ let (x, s') = m s
+ in runInstM (f x) s'
-- | Given a list of 'LinkedComponent's, expand the module graph
-- so that we have an instantiated graph containing all of the
@@ -222,27 +238,30 @@ instance Monad InstM where
--
-- We also call 'improveUnitId' during this process, so that fully
-- instantiated components are given 'HashedUnitId'.
---
toReadyComponents
- :: Map UnitId MungedPackageId
- -> Map ModuleName Module -- subst for the public component
- -> [LinkedComponent]
- -> [ReadyComponent]
-toReadyComponents pid_map subst0 comps
- = catMaybes (Map.elems ready_map)
+ :: Map UnitId MungedPackageId
+ -> Map ModuleName Module -- subst for the public component
+ -> [LinkedComponent]
+ -> [ReadyComponent]
+toReadyComponents pid_map subst0 comps =
+ catMaybes (Map.elems ready_map)
where
- cmap = Map.fromList [ (lc_cid lc, lc) | lc <- comps ]
+ cmap = Map.fromList [(lc_cid lc, lc) | lc <- comps]
- instantiateUnitId :: ComponentId -> Map ModuleName Module
- -> InstM DefUnitId
+ instantiateUnitId
+ :: ComponentId
+ -> Map ModuleName Module
+ -> InstM DefUnitId
instantiateUnitId cid insts = InstM $ \s ->
- case Map.lookup uid s of
- Nothing ->
- -- Knot tied
- let (r, s') = runInstM (instantiateComponent uid cid insts)
- (Map.insert uid r s)
- in (def_uid, Map.insert uid r s')
- Just _ -> (def_uid, s)
+ case Map.lookup uid s of
+ Nothing ->
+ -- Knot tied
+ let (r, s') =
+ runInstM
+ (instantiateComponent uid cid insts)
+ (Map.insert uid r s)
+ in (def_uid, Map.insert uid r s')
+ Just _ -> (def_uid, s)
where
-- The mkDefUnitId here indicates that we assume
-- that Cabal handles unit id hash allocation.
@@ -252,125 +271,142 @@ toReadyComponents pid_map subst0 comps
uid = unDefUnitId def_uid
instantiateComponent
- :: UnitId -> ComponentId -> Map ModuleName Module
- -> InstM (Maybe ReadyComponent)
+ :: UnitId
+ -> ComponentId
+ -> Map ModuleName Module
+ -> InstM (Maybe ReadyComponent)
instantiateComponent uid cid insts
| Just lc <- Map.lookup cid cmap = do
- 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 <- 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
+ 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 <- 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 <|>
- fmap rc_munged_id (join (Map.lookup dep_uid s)))]
- where
- err_pid = MungedPackageId
- (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)
- (mkVersion [0])
- instc = InstantiatedComponent {
- instc_insts = Map.toList insts,
- instc_insts_deps = concatMap getDep (Map.elems insts),
- instc_provides = provides,
- instc_includes = includes
- -- NB: there is no dependency on the
- -- indefinite version of this instantiated package here,
- -- as (1) it doesn't go in depends in the
- -- IPI: it's not a run time dep, and (2)
- -- we don't have to tell GHC about it, it
- -- will match up the ComponentId
- -- automatically
- }
- return $ Just ReadyComponent {
- rc_ann_id = (lc_ann_id lc) { ann_id = uid },
- rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid),
- rc_cid = lc_cid lc,
- rc_component = lc_component lc,
- rc_exe_deps = exe_deps,
- rc_public = lc_public lc,
- rc_i = Right instc
- }
+ [
+ ( dep_uid
+ , fromMaybe err_pid $
+ Map.lookup dep_uid pid_map
+ <|> fmap rc_munged_id (join (Map.lookup dep_uid s))
+ )
+ ]
+ where
+ err_pid =
+ MungedPackageId
+ (MungedPackageName nonExistentPackageThisIsCabalBug LMainLibName)
+ (mkVersion [0])
+ instc =
+ InstantiatedComponent
+ { instc_insts = Map.toList insts
+ , instc_insts_deps = concatMap getDep (Map.elems insts)
+ , instc_provides = provides
+ , instc_includes = includes
+ -- NB: there is no dependency on the
+ -- indefinite version of this instantiated package here,
+ -- as (1) it doesn't go in depends in the
+ -- IPI: it's not a run time dep, and (2)
+ -- we don't have to tell GHC about it, it
+ -- will match up the ComponentId
+ -- automatically
+ }
+ return $
+ Just
+ ReadyComponent
+ { rc_ann_id = (lc_ann_id lc){ann_id = uid}
+ , rc_open_uid = DefiniteUnitId (unsafeMkDefUnitId uid)
+ , rc_cid = lc_cid lc
+ , rc_component = lc_component lc
+ , rc_exe_deps = exe_deps
+ , rc_public = lc_public lc
+ , rc_i = Right instc
+ }
| otherwise = return Nothing
substUnitId :: Map ModuleName Module -> OpenUnitId -> InstM DefUnitId
substUnitId _ (DefiniteUnitId uid) =
- return uid
+ return uid
substUnitId subst (IndefFullUnitId cid insts) = do
- insts' <- substSubst subst insts
- instantiateUnitId cid insts'
+ insts' <- substSubst subst insts
+ instantiateUnitId cid insts'
-- NB: NOT composition
- substSubst :: Map ModuleName Module
- -> Map ModuleName OpenModule
- -> InstM (Map ModuleName Module)
+ substSubst
+ :: Map ModuleName Module
+ -> Map ModuleName OpenModule
+ -> InstM (Map ModuleName Module)
substSubst subst insts = traverse (substModule subst) insts
substModule :: Map ModuleName Module -> OpenModule -> InstM Module
substModule subst (OpenModuleVar mod_name)
- | Just m <- Map.lookup mod_name subst = return m
- | otherwise = error "substModule: non-closing substitution"
+ | Just m <- Map.lookup mod_name subst = return m
+ | otherwise = error "substModule: non-closing substitution"
substModule subst (OpenModule uid mod_name) = do
- uid' <- substUnitId subst uid
- return (Module uid' mod_name)
+ uid' <- substUnitId subst uid
+ return (Module uid' mod_name)
- substExeDep :: Map ModuleName Module
- -> AnnotatedId OpenUnitId -> InstM (AnnotatedId UnitId)
+ substExeDep
+ :: Map ModuleName Module
+ -> AnnotatedId OpenUnitId
+ -> InstM (AnnotatedId UnitId)
substExeDep insts exe_aid = do
- exe_uid' <- substUnitId insts (ann_id exe_aid)
- return exe_aid { ann_id = unDefUnitId exe_uid' }
+ exe_uid' <- substUnitId insts (ann_id exe_aid)
+ return exe_aid{ann_id = unDefUnitId exe_uid'}
indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId cid = do
- let uid = newSimpleUnitId cid
- r <- indefiniteComponent uid cid
- InstM $ \s -> (uid, Map.insert uid r s)
+ let uid = newSimpleUnitId cid
+ r <- indefiniteComponent uid cid
+ InstM $ \s -> (uid, Map.insert uid r s)
indefiniteComponent :: UnitId -> ComponentId -> InstM (Maybe ReadyComponent)
indefiniteComponent uid cid
| Just lc <- Map.lookup cid cmap = do
- -- We're going to process includes, in case some of them
- -- are fully definite even without any substitution. We
- -- want to build those too; see #5634.
- inst_includes <- forM (lc_includes lc) $ \ci ->
- if Set.null (openUnitIdFreeHoles (ci_id ci))
- 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 <- traverse (substExeDep Map.empty) (lc_exe_deps lc)
- let indefc = IndefiniteComponent {
- indefc_requires = map fst (lc_insts lc),
- indefc_provides = modShapeProvides (lc_shape lc),
- indefc_includes = inst_includes ++ lc_sig_includes lc
- }
- return $ Just ReadyComponent {
- rc_ann_id = (lc_ann_id lc) { ann_id = uid },
- rc_cid = lc_cid lc,
- rc_open_uid = lc_uid lc,
- rc_component = lc_component lc,
- -- It's always fully built
- rc_exe_deps = exe_deps,
- rc_public = lc_public lc,
- rc_i = Left indefc
+ -- We're going to process includes, in case some of them
+ -- are fully definite even without any substitution. We
+ -- want to build those too; see #5634.
+ inst_includes <- forM (lc_includes lc) $ \ci ->
+ if Set.null (openUnitIdFreeHoles (ci_id ci))
+ 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 <- traverse (substExeDep Map.empty) (lc_exe_deps lc)
+ let indefc =
+ IndefiniteComponent
+ { indefc_requires = map fst (lc_insts lc)
+ , indefc_provides = modShapeProvides (lc_shape lc)
+ , indefc_includes = inst_includes ++ lc_sig_includes lc
+ }
+ return $
+ Just
+ ReadyComponent
+ { rc_ann_id = (lc_ann_id lc){ann_id = uid}
+ , rc_cid = lc_cid lc
+ , rc_open_uid = lc_uid lc
+ , rc_component = lc_component lc
+ , -- It's always fully built
+ rc_exe_deps = exe_deps
+ , rc_public = lc_public lc
+ , rc_i = Left indefc
}
| otherwise = return Nothing
ready_map = snd $ runInstM work Map.empty
work
- -- Top-level instantiation per subst0
- | not (Map.null subst0)
- , [lc] <- filter lc_public (Map.elems cmap)
- = do _ <- instantiateUnitId (lc_cid lc) subst0
- return ()
- | otherwise
- = forM_ (Map.elems cmap) $ \lc ->
+ -- Top-level instantiation per subst0
+ | not (Map.null subst0)
+ , [lc] <- filter lc_public (Map.elems cmap) =
+ do
+ _ <- instantiateUnitId (lc_cid lc) subst0
+ return ()
+ | otherwise =
+ forM_ (Map.elems cmap) $ \lc ->
if null (lc_insts lc)
- then instantiateUnitId (lc_cid lc) Map.empty >> return ()
- else indefiniteUnitId (lc_cid lc) >> return ()
+ then instantiateUnitId (lc_cid lc) Map.empty >> return ()
+ else indefiniteUnitId (lc_cid lc) >> return ()
diff --git a/Cabal/src/Distribution/Backpack/UnifyM.hs b/Cabal/src/Distribution/Backpack/UnifyM.hs
index 6b18a9d363a3f6bbe2c973581b264f553915c8ec..6e0f00d9f63a71837f09bc09c062b904e0b63bde 100644
--- a/Cabal/src/Distribution/Backpack/UnifyM.hs
+++ b/Cabal/src/Distribution/Backpack/UnifyM.hs
@@ -1,163 +1,163 @@
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
-module Distribution.Backpack.UnifyM (
- -- * Unification monad
- UnifyM,
- runUnifyM,
- failWith,
- addErr,
- failIfErrs,
- tryM,
- addErrContext,
- addErrContextM,
- liftST,
-
- UnifEnv(..),
- getUnifEnv,
+module Distribution.Backpack.UnifyM
+ ( -- * Unification monad
+ UnifyM
+ , runUnifyM
+ , failWith
+ , addErr
+ , failIfErrs
+ , tryM
+ , addErrContext
+ , addErrContextM
+ , liftST
+ , UnifEnv (..)
+ , getUnifEnv
-- * Modules and unit IDs
- ModuleU,
- ModuleU'(..),
- convertModule,
- convertModuleU,
-
- UnitIdU,
- UnitIdU'(..),
- convertUnitId,
- convertUnitIdU,
-
- ModuleSubstU,
- convertModuleSubstU,
- convertModuleSubst,
-
- ModuleScopeU,
- emptyModuleScopeU,
- convertModuleScopeU,
-
- ModuleWithSourceU,
-
- convertInclude,
- convertModuleProvides,
- convertModuleProvidesU,
+ , ModuleU
+ , ModuleU' (..)
+ , convertModule
+ , convertModuleU
+ , UnitIdU
+ , UnitIdU' (..)
+ , convertUnitId
+ , convertUnitIdU
+ , ModuleSubstU
+ , convertModuleSubstU
+ , convertModuleSubst
+ , ModuleScopeU
+ , emptyModuleScopeU
+ , convertModuleScopeU
+ , ModuleWithSourceU
+ , convertInclude
+ , convertModuleProvides
+ , convertModuleProvidesU
+ ) where
-) where
-
-import Prelude ()
import Distribution.Compat.Prelude hiding (mod)
+import Prelude ()
-import Distribution.Backpack.ModuleShape
-import Distribution.Backpack.ModuleScope
-import Distribution.Backpack.ModSubst
-import Distribution.Backpack.FullUnitId
import Distribution.Backpack
+import Distribution.Backpack.FullUnitId
+import Distribution.Backpack.ModSubst
+import Distribution.Backpack.ModuleScope
+import Distribution.Backpack.ModuleShape
-import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
import Distribution.Pretty
-import Distribution.Types.ComponentInclude
import Distribution.Types.AnnotatedId
+import Distribution.Types.ComponentInclude
+import qualified Distribution.Utils.UnionFind as UnionFind
import Distribution.Verbosity
-import Data.STRef
-import Data.Traversable
import Control.Monad.ST
-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.Map as Map
+import Data.STRef
+import qualified Data.Set as Set
+import Data.Traversable
import Text.PrettyPrint
-- TODO: more detailed trace output on high verbosity would probably
-- be appreciated by users debugging unification errors. Collect
-- some good examples!
-data ErrMsg = ErrMsg {
- err_msg :: Doc,
- err_ctx :: [Doc]
- }
+data ErrMsg = ErrMsg
+ { err_msg :: Doc
+ , err_ctx :: [Doc]
+ }
type MsgDoc = Doc
renderErrMsg :: ErrMsg -> MsgDoc
-renderErrMsg ErrMsg { err_msg = msg, err_ctx = ctx } =
- msg $$ vcat ctx
+renderErrMsg ErrMsg{err_msg = msg, err_ctx = ctx} =
+ msg $$ vcat ctx
-- | The unification monad, this monad encapsulates imperative
-- unification.
-newtype UnifyM s a = UnifyM { unUnifyM :: UnifEnv s -> ST s (Maybe a) }
+newtype UnifyM s a = UnifyM {unUnifyM :: UnifEnv s -> ST s (Maybe a)}
-- | Run a computation in the unification monad.
runUnifyM :: Verbosity -> ComponentId -> FullDb -> (forall s. UnifyM s a) -> Either [MsgDoc] a
-runUnifyM verbosity self_cid db m
- = runST $ do i <- newSTRef 0
- hmap <- newSTRef Map.empty
- errs <- newSTRef []
- mb_r <- unUnifyM m UnifEnv {
- unify_uniq = i,
- unify_reqs = hmap,
- unify_self_cid = self_cid,
- unify_verbosity = verbosity,
- unify_ctx = [],
- unify_db = db,
- unify_errs = errs }
- final_errs <- readSTRef errs
- case mb_r of
- Just x | null final_errs -> return (Right x)
- _ -> return (Left (map renderErrMsg (reverse final_errs)))
+runUnifyM verbosity self_cid db m =
+ runST $ do
+ i <- newSTRef 0
+ hmap <- newSTRef Map.empty
+ errs <- newSTRef []
+ mb_r <-
+ unUnifyM
+ m
+ UnifEnv
+ { unify_uniq = i
+ , unify_reqs = hmap
+ , unify_self_cid = self_cid
+ , unify_verbosity = verbosity
+ , unify_ctx = []
+ , unify_db = db
+ , unify_errs = errs
+ }
+ final_errs <- readSTRef errs
+ case mb_r of
+ Just x | null final_errs -> return (Right x)
+ _ -> return (Left (map renderErrMsg (reverse final_errs)))
+
-- NB: GHC 7.6 throws a hissy fit if you pattern match on 'm'.
type ErrCtx s = MsgDoc
-- | The unification environment.
-data UnifEnv s = UnifEnv {
- -- | A supply of unique integers to label 'UnitIdU'
- -- cells. This is used to determine loops in unit
- -- identifiers (which can happen with mutual recursion.)
- unify_uniq :: UnifRef s UnitIdUnique,
- -- | The set of requirements in scope. When
- -- a provision is brought into scope, we unify with
- -- the requirement at the same module name to fill it.
- -- This mapping grows monotonically.
- unify_reqs :: UnifRef s (Map ModuleName (ModuleU s)),
- -- | Component id of the unit we're linking. We use this
- -- to detect if we fill a requirement with a local module,
- -- which in principle should be OK but is not currently
- -- supported by GHC.
- unify_self_cid :: ComponentId,
- -- | How verbose the error message should be
- unify_verbosity :: Verbosity,
- -- | The error reporting context
- unify_ctx :: [ErrCtx s],
- -- | The package index for expanding unit identifiers
- unify_db :: FullDb,
- -- | Accumulated errors
- unify_errs :: UnifRef s [ErrMsg]
- }
+data UnifEnv s = UnifEnv
+ { unify_uniq :: UnifRef s UnitIdUnique
+ -- ^ A supply of unique integers to label 'UnitIdU'
+ -- cells. This is used to determine loops in unit
+ -- identifiers (which can happen with mutual recursion.)
+ , unify_reqs :: UnifRef s (Map ModuleName (ModuleU s))
+ -- ^ The set of requirements in scope. When
+ -- a provision is brought into scope, we unify with
+ -- the requirement at the same module name to fill it.
+ -- This mapping grows monotonically.
+ , unify_self_cid :: ComponentId
+ -- ^ Component id of the unit we're linking. We use this
+ -- to detect if we fill a requirement with a local module,
+ -- which in principle should be OK but is not currently
+ -- supported by GHC.
+ , unify_verbosity :: Verbosity
+ -- ^ How verbose the error message should be
+ , unify_ctx :: [ErrCtx s]
+ -- ^ The error reporting context
+ , unify_db :: FullDb
+ -- ^ The package index for expanding unit identifiers
+ , unify_errs :: UnifRef s [ErrMsg]
+ -- ^ Accumulated errors
+ }
instance Functor (UnifyM s) where
- fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)
+ fmap f (UnifyM m) = UnifyM (fmap (fmap (fmap f)) m)
instance Applicative (UnifyM s) where
- pure = UnifyM . pure . pure . pure
- UnifyM f <*> UnifyM x = UnifyM $ \r -> do
- f' <- f r
- case f' of
+ pure = UnifyM . pure . pure . pure
+ UnifyM f <*> UnifyM x = UnifyM $ \r -> do
+ f' <- f r
+ case f' of
+ Nothing -> return Nothing
+ Just f'' -> do
+ x' <- x r
+ case x' of
Nothing -> return Nothing
- Just f'' -> do
- x' <- x r
- case x' of
- Nothing -> return Nothing
- Just x'' -> return (Just (f'' x''))
+ Just x'' -> return (Just (f'' x''))
instance Monad (UnifyM s) where
- return = pure
- UnifyM m >>= f = UnifyM $ \r -> do
- x <- m r
- case x of
- Nothing -> return Nothing
- Just x' -> unUnifyM (f x') r
+ return = pure
+ UnifyM m >>= f = UnifyM $ \r -> do
+ x <- m r
+ case x of
+ Nothing -> return Nothing
+ Just x' -> unUnifyM (f x') r
-- | Lift a computation from 'ST' monad to 'UnifyM' monad.
-- Internal use only.
@@ -166,32 +166,35 @@ liftST m = UnifyM $ \_ -> fmap Just m
addErr :: MsgDoc -> UnifyM s ()
addErr msg = do
- env <- getUnifEnv
- let err = ErrMsg {
- err_msg = msg,
- err_ctx = unify_ctx env
- }
- liftST $ modifySTRef (unify_errs env) (\errs -> err:errs)
+ env <- getUnifEnv
+ let err =
+ ErrMsg
+ { err_msg = msg
+ , err_ctx = unify_ctx env
+ }
+ liftST $ modifySTRef (unify_errs env) (\errs -> err : errs)
failWith :: MsgDoc -> UnifyM s a
failWith msg = do
- addErr msg
- failM
+ addErr msg
+ failM
failM :: UnifyM s a
failM = UnifyM $ \_ -> return Nothing
failIfErrs :: UnifyM s ()
failIfErrs = do
- env <- getUnifEnv
- errs <- liftST $ readSTRef (unify_errs env)
- when (not (null errs)) failM
+ env <- getUnifEnv
+ errs <- liftST $ readSTRef (unify_errs env)
+ when (not (null errs)) failM
tryM :: UnifyM s a -> UnifyM s (Maybe a)
tryM m =
- UnifyM (\env -> do
+ UnifyM
+ ( \env -> do
mb_r <- unUnifyM m env
- return (Just mb_r))
+ return (Just mb_r)
+ )
{-
otherFail :: ErrMsg -> UnifyM s a
@@ -236,8 +239,7 @@ addErrContext ctx m = addErrContextM ctx m
-- | Add a message to the error context. It may make monadic queries.
addErrContextM :: ErrCtx s -> UnifyM s a -> UnifyM s a
addErrContextM ctx m =
- UnifyM $ \r -> unUnifyM m r { unify_ctx = ctx : unify_ctx r }
-
+ UnifyM $ \r -> unUnifyM m r{unify_ctx = ctx : unify_ctx r}
-----------------------------------------------------------------------
-- The "unifiable" variants of the data types
@@ -251,13 +253,13 @@ addErrContextM ctx m =
-- | Contents of a mutable 'ModuleU' reference.
data ModuleU' s
- = ModuleU (UnitIdU s) ModuleName
- | ModuleVarU ModuleName
+ = ModuleU (UnitIdU s) ModuleName
+ | ModuleVarU ModuleName
-- | Contents of a mutable 'UnitIdU' reference.
data UnitIdU' s
- = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))
- | UnitIdThunkU DefUnitId
+ = UnitIdU UnitIdUnique ComponentId (Map ModuleName (ModuleU s))
+ | UnitIdThunkU DefUnitId
-- | A mutable version of 'Module' which can be imperatively unified.
type ModuleU s = UnionFind.Point s (ModuleU' s)
@@ -273,7 +275,6 @@ type UnitIdU s = UnionFind.Point s (UnitIdU' s)
-- participate in unification!
type UnitIdUnique = Int
-
-----------------------------------------------------------------------
-- Conversion to the unifiable data types
@@ -286,7 +287,7 @@ type MuEnv s = (IntMap (UnitIdU s), Int)
extendMuEnv :: MuEnv s -> UnitIdU s -> MuEnv s
extendMuEnv (m, i) x =
- (IntMap.insert (i + 1) x m, i + 1)
+ (IntMap.insert (i + 1) x m, i + 1)
{-
lookupMuEnv :: MuEnv s -> Int {- de Bruijn index -} -> UnitIdU s
@@ -308,37 +309,42 @@ emptyMuEnv = (IntMap.empty, -1)
-- @hole:A@ binders.
-- * @MuEnv@ - the environment for mu-binders.
-convertUnitId' :: MuEnv s
- -> OpenUnitId
- -> UnifyM s (UnitIdU s)
+convertUnitId'
+ :: MuEnv s
+ -> OpenUnitId
+ -> UnifyM s (UnitIdU s)
-- TODO: this could be more lazy if we know there are no internal
-- references
convertUnitId' _ (DefiniteUnitId uid) =
- liftST $ UnionFind.fresh (UnitIdThunkU uid)
+ liftST $ UnionFind.fresh (UnitIdThunkU uid)
convertUnitId' stk (IndefFullUnitId cid insts) = do
- fs <- fmap unify_uniq getUnifEnv
- x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later
- insts_u <- for insts $ convertModule' (extendMuEnv stk x)
- u <- readUnifRef fs
- writeUnifRef fs (u+1)
- y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)
- liftST $ UnionFind.union x y
- return y
+ fs <- fmap unify_uniq getUnifEnv
+ x <- liftST $ UnionFind.fresh (error "convertUnitId") -- tie the knot later
+ insts_u <- for insts $ convertModule' (extendMuEnv stk x)
+ u <- readUnifRef fs
+ writeUnifRef fs (u + 1)
+ y <- liftST $ UnionFind.fresh (UnitIdU u cid insts_u)
+ liftST $ UnionFind.union x y
+ return y
+
-- convertUnitId' stk (UnitIdVar i) = return (lookupMuEnv stk i)
-convertModule' :: MuEnv s
- -> OpenModule -> UnifyM s (ModuleU s)
+convertModule'
+ :: MuEnv s
+ -> OpenModule
+ -> UnifyM s (ModuleU s)
convertModule' _stk (OpenModuleVar mod_name) = do
- hmap <- fmap unify_reqs getUnifEnv
- hm <- readUnifRef hmap
- case Map.lookup mod_name hm of
- Nothing -> do mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)
- writeUnifRef hmap (Map.insert mod_name mod hm)
- return mod
- Just mod -> return mod
+ hmap <- fmap unify_reqs getUnifEnv
+ hm <- readUnifRef hmap
+ case Map.lookup mod_name hm of
+ Nothing -> do
+ mod <- liftST $ UnionFind.fresh (ModuleVarU mod_name)
+ writeUnifRef hmap (Map.insert mod_name mod hm)
+ return mod
+ Just mod -> return mod
convertModule' stk (OpenModule uid mod_name) = do
- uid_u <- convertUnitId' stk uid
- liftST $ UnionFind.fresh (ModuleU uid_u mod_name)
+ uid_u <- convertUnitId' stk uid
+ liftST $ UnionFind.fresh (ModuleU uid_u mod_name)
convertUnitId :: OpenUnitId -> UnifyM s (UnitIdU s)
convertUnitId = convertUnitId' emptyMuEnv
@@ -346,8 +352,6 @@ convertUnitId = convertUnitId' emptyMuEnv
convertModule :: OpenModule -> UnifyM s (ModuleU s)
convertModule = convertModule' emptyMuEnv
-
-
-----------------------------------------------------------------------
-- Substitutions
@@ -380,9 +384,9 @@ extendMooEnv (m, i) k = (IntMap.insert k (i + 1) m, i + 1)
lookupMooEnv :: MooEnv -> UnitIdUnique -> Maybe Int
lookupMooEnv (m, i) k =
- case IntMap.lookup k m of
- Nothing -> Nothing
- Just v -> Just (i-v) -- de Bruijn indexize
+ case IntMap.lookup k m of
+ Nothing -> Nothing
+ Just v -> Just (i - v) -- de Bruijn indexize
-- The workhorse functions
@@ -390,34 +394,36 @@ lookupMooEnv (m, i) k =
-- | Otherwise returns a list of signatures instantiated by given `UnitIdU`.
convertUnitIdU' :: MooEnv -> UnitIdU s -> Doc -> UnifyM s OpenUnitId
convertUnitIdU' stk uid_u required_mod_name = do
- x <- liftST $ UnionFind.find uid_u
- case x of
- UnitIdThunkU uid -> return $ DefiniteUnitId uid
- UnitIdU u cid insts_u ->
- case lookupMooEnv stk u of
- Just _ ->
- let mod_names = Map.keys insts_u
- in failWithMutuallyRecursiveUnitsError required_mod_name mod_names
- Nothing -> do
- insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)
- return $ IndefFullUnitId cid insts
+ x <- liftST $ UnionFind.find uid_u
+ case x of
+ UnitIdThunkU uid -> return $ DefiniteUnitId uid
+ UnitIdU u cid insts_u ->
+ case lookupMooEnv stk u of
+ Just _ ->
+ let mod_names = Map.keys insts_u
+ in failWithMutuallyRecursiveUnitsError required_mod_name mod_names
+ Nothing -> do
+ insts <- for insts_u $ convertModuleU' (extendMooEnv stk u)
+ return $ IndefFullUnitId cid insts
convertModuleU' :: MooEnv -> ModuleU s -> UnifyM s OpenModule
convertModuleU' stk mod_u = do
- mod <- liftST $ UnionFind.find mod_u
- case mod of
- ModuleVarU mod_name -> return (OpenModuleVar mod_name)
- ModuleU uid_u mod_name -> do
- uid <- convertUnitIdU' stk uid_u (pretty mod_name)
- return (OpenModule uid mod_name)
+ mod <- liftST $ UnionFind.find mod_u
+ case mod of
+ ModuleVarU mod_name -> return (OpenModuleVar mod_name)
+ ModuleU uid_u mod_name -> do
+ uid <- convertUnitIdU' stk uid_u (pretty mod_name)
+ return (OpenModule uid mod_name)
failWithMutuallyRecursiveUnitsError :: Doc -> [ModuleName] -> UnifyM s a
failWithMutuallyRecursiveUnitsError required_mod_name mod_names =
- let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names in
- failWith $
- text "Cannot instantiate requirement" <+> quotes required_mod_name $$
- text "Ensure \"build-depends:\" doesn't include any library with signatures:" <+> sigsList $$
- text "as this creates a cyclic dependency, which GHC does not support."
+ let sigsList = hcat $ punctuate (text ", ") $ map (quotes . pretty) mod_names
+ in failWith $
+ text "Cannot instantiate requirement"
+ <+> quotes required_mod_name
+ $$ text "Ensure \"build-depends:\" doesn't include any library with signatures:"
+ <+> sigsList
+ $$ text "as this creates a cyclic dependency, which GHC does not support."
-- Helper functions
@@ -431,11 +437,12 @@ convertModuleU = convertModuleU' emptyMooEnv
emptyModuleScopeU :: ModuleScopeU s
emptyModuleScopeU = (Map.empty, Map.empty)
-
-- | The mutable counterpart of 'ModuleScope'.
type ModuleScopeU s = (ModuleProvidesU s, ModuleRequiresU s)
+
-- | The mutable counterpart of 'ModuleProvides'
type ModuleProvidesU s = Map ModuleName [ModuleWithSourceU s]
+
type ModuleRequiresU s = ModuleProvidesU s
type ModuleWithSourceU s = WithSource (ModuleU s)
@@ -447,33 +454,41 @@ ci_msg ci
where
pn = pkgName (ci_pkgid ci)
pp_pn =
- case ci_cname ci of
- CLibName LMainLibName -> pretty pn
- CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn
- -- Shouldn't happen
- cn -> pretty pn <+> parens (pretty cn)
+ case ci_cname ci of
+ CLibName LMainLibName -> pretty pn
+ CLibName (LSubLibName cn) -> pretty pn <<>> colon <<>> pretty cn
+ -- Shouldn't happen
+ cn -> pretty pn <+> parens (pretty cn)
-- | Convert a 'ModuleShape' into a 'ModuleScopeU', so we can do
-- unification on it.
convertInclude
- :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
- -> UnifyM s (ModuleScopeU s,
- Either (ComponentInclude (UnitIdU s) ModuleRenaming) {- normal -}
- (ComponentInclude (UnitIdU s) ModuleRenaming) {- sig -})
-convertInclude ci@(ComponentInclude {
- ci_ann_id = AnnotatedId {
- ann_id = (uid, ModuleShape provs reqs),
- ann_pid = pid,
- ann_cname = compname
- },
- ci_renaming = incl@(IncludeRenaming prov_rns req_rns),
- ci_implicit = implicit
- }) = addErrContext (text "In" <+> ci_msg ci) $ do
+ :: ComponentInclude (OpenUnitId, ModuleShape) IncludeRenaming
+ -> UnifyM
+ s
+ ( ModuleScopeU s
+ , Either
+ (ComponentInclude (UnitIdU s) ModuleRenaming {- normal -})
+ (ComponentInclude (UnitIdU s) ModuleRenaming {- sig -})
+ )
+convertInclude
+ ci@( ComponentInclude
+ { ci_ann_id =
+ AnnotatedId
+ { ann_id = (uid, ModuleShape provs reqs)
+ , ann_pid = pid
+ , ann_cname = compname
+ }
+ , ci_renaming = incl@(IncludeRenaming prov_rns req_rns)
+ , ci_implicit = implicit
+ }
+ ) = addErrContext (text "In" <+> ci_msg ci) $ do
let pn = packageName pid
- the_source | implicit
- = FromBuildDepends pn compname
- | otherwise
- = FromMixins pn compname incl
+ the_source
+ | implicit =
+ FromBuildDepends pn compname
+ | otherwise =
+ FromMixins pn compname incl
source = WithSource the_source
-- Suppose our package has two requirements A and B, and
@@ -498,27 +513,31 @@ convertInclude ci@(ComponentInclude {
case req_rns of
DefaultRenaming -> return []
HidingRenaming _ -> do
- -- Not valid here for requires!
- addErr $ text "Unsupported syntax" <+>
- quotes (text "requires hiding (...)")
- return []
+ -- Not valid here for requires!
+ addErr $
+ text "Unsupported syntax"
+ <+> quotes (text "requires hiding (...)")
+ return []
ModuleRenaming rns -> return rns
let req_rename_listmap :: Map ModuleName [ModuleName]
req_rename_listmap =
- Map.fromListWith (++) [ (k,[v]) | (k,v) <- req_rename_list ]
+ Map.fromListWith (++) [(k, [v]) | (k, v) <- req_rename_list]
req_rename <- sequenceA . flip Map.mapWithKey req_rename_listmap $ \k vs0 ->
case vs0 of
- [] -> error "req_rename"
+ [] -> error "req_rename"
[v] -> return v
- v:vs -> do addErr $
- text "Conflicting renamings of requirement" <+> quotes (pretty k) $$
- text "Renamed to: " <+> vcat (map pretty (v:vs))
- return v
+ v : vs -> do
+ addErr $
+ text "Conflicting renamings of requirement"
+ <+> quotes (pretty k)
+ $$ text "Renamed to: "
+ <+> vcat (map pretty (v : vs))
+ return v
let req_rename_fn k = case Map.lookup k req_rename of
- Nothing -> k
- Just v -> v
+ Nothing -> k
+ Just v -> v
-- Requirement substitution.
--
@@ -533,19 +552,25 @@ convertInclude ci@(ComponentInclude {
-- mappings.
--
-- A -> X ==> X -> <X>, B -> <B>
- reqs_u <- convertModuleRequires . Map.fromList $
- [ (k, [source (OpenModuleVar k)])
- | k <- map req_rename_fn (Set.toList reqs)
- ]
+ reqs_u <-
+ convertModuleRequires . Map.fromList $
+ [ (k, [source (OpenModuleVar k)])
+ | k <- map req_rename_fn (Set.toList reqs)
+ ]
-- Report errors if there were unused renamings
let leftover = Map.keysSet req_rename `Set.difference` reqs
unless (Set.null leftover) $
- addErr $
- hang (text "The" <+> text (showComponentName compname) <+>
- text "from package" <+> quotes (pretty pid)
- <+> text "does not require:") 4
- (vcat (map pretty (Set.toList leftover)))
+ addErr $
+ hang
+ ( text "The"
+ <+> text (showComponentName compname)
+ <+> text "from package"
+ <+> quotes (pretty pid)
+ <+> text "does not require:"
+ )
+ 4
+ (vcat (map pretty (Set.toList leftover)))
-- Provision computation is more complex.
-- For example, if we have:
@@ -569,56 +594,72 @@ convertInclude ci@(ComponentInclude {
-- Importantly, overlapping rename targets get accumulated
-- together. It's not an (immediate) error.
(pre_prov_scope, prov_rns') <-
- case prov_rns of
- DefaultRenaming -> return (Map.toList provs, prov_rns)
- HidingRenaming hides ->
- let hides_set = Set.fromList hides
- in let r = [ (k,v)
- | (k,v) <- Map.toList provs
- , not (k `Set.member` hides_set) ]
- -- GHC doesn't understand hiding, so expand it out!
- in return (r, ModuleRenaming (map ((\x -> (x,x)).fst) r))
- ModuleRenaming rns -> do
- r <- sequence
- [ case Map.lookup from provs of
- Just m -> return (to, m)
- Nothing -> failWith $
- text "Package" <+> quotes (pretty pid) <+>
- text "does not expose the module" <+> quotes (pretty from)
- | (from, to) <- rns ]
- return (r, prov_rns)
- let prov_scope = modSubst req_subst
- $ Map.fromListWith (++)
- [ (k, [source v])
- | (k, v) <- pre_prov_scope ]
+ case prov_rns of
+ DefaultRenaming -> return (Map.toList provs, prov_rns)
+ HidingRenaming hides ->
+ let hides_set = Set.fromList hides
+ in let r =
+ [ (k, v)
+ | (k, v) <- Map.toList provs
+ , not (k `Set.member` hides_set)
+ ]
+ in -- GHC doesn't understand hiding, so expand it out!
+ return (r, ModuleRenaming (map ((\x -> (x, x)) . fst) r))
+ ModuleRenaming rns -> do
+ r <-
+ sequence
+ [ case Map.lookup from provs of
+ Just m -> return (to, m)
+ Nothing ->
+ failWith $
+ text "Package"
+ <+> quotes (pretty pid)
+ <+> text "does not expose the module"
+ <+> quotes (pretty from)
+ | (from, to) <- rns
+ ]
+ return (r, prov_rns)
+ let prov_scope =
+ modSubst req_subst $
+ Map.fromListWith
+ (++)
+ [ (k, [source v])
+ | (k, v) <- pre_prov_scope
+ ]
provs_u <- convertModuleProvides prov_scope
-- TODO: Assert that provs_u is empty if provs was empty
- return ((provs_u, reqs_u),
- -- NB: We test that requirements is not null so that
- -- users can create packages with zero module exports
- -- that cause some C library to linked in, etc.
- (if Map.null provs && not (Set.null reqs)
- then Right -- is sig
- else Left) (ComponentInclude {
- ci_ann_id = AnnotatedId {
- ann_id = uid_u,
- ann_pid = pid,
- ann_cname = compname
- },
- ci_renaming = prov_rns',
- ci_implicit = ci_implicit ci
- }))
+ return
+ ( (provs_u, reqs_u)
+ , -- NB: We test that requirements is not null so that
+ -- users can create packages with zero module exports
+ -- that cause some C library to linked in, etc.
+ ( if Map.null provs && not (Set.null reqs)
+ then Right -- is sig
+ else Left
+ )
+ ( ComponentInclude
+ { ci_ann_id =
+ AnnotatedId
+ { ann_id = uid_u
+ , ann_pid = pid
+ , ann_cname = compname
+ }
+ , ci_renaming = prov_rns'
+ , ci_implicit = ci_implicit ci
+ }
+ )
+ )
-- | Convert a 'ModuleScopeU' to a 'ModuleScope'.
convertModuleScopeU :: ModuleScopeU s -> UnifyM s ModuleScope
convertModuleScopeU (provs_u, reqs_u) = do
- provs <- convertModuleProvidesU provs_u
- reqs <- convertModuleRequiresU reqs_u
- -- TODO: Test that the requirements are still free. If they
- -- are not, they got unified, and that's dodgy at best.
- return (ModuleScope provs reqs)
+ provs <- convertModuleProvidesU provs_u
+ reqs <- convertModuleRequiresU reqs_u
+ -- TODO: Test that the requirements are still free. If they
+ -- are not, they got unified, and that's dodgy at best.
+ return (ModuleScope provs reqs)
-- | Convert a 'ModuleProvides' to a 'ModuleProvidesU'
convertModuleProvides :: ModuleProvides -> UnifyM s (ModuleProvidesU s)
diff --git a/Cabal/src/Distribution/Compat/Async.hs b/Cabal/src/Distribution/Compat/Async.hs
index a2644974b091e5ebfb15d29b3cd5ffb32d5906ab..dbc22c58359079166f25110d674ae36bf31ce38f 100644
--- a/Cabal/src/Distribution/Compat/Async.hs
+++ b/Cabal/src/Distribution/Compat/Async.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
+
-- | 'Async', yet using 'MVar's.
--
-- Adopted from @async@ library
@@ -7,24 +8,38 @@
-- Licensed under BSD-3-Clause
--
-- @since 3.2.0.0
---
-module Distribution.Compat.Async (
- AsyncM,
- withAsync, waitCatch,
- wait, asyncThreadId,
- cancel, uninterruptibleCancel, AsyncCancelled (..),
+module Distribution.Compat.Async
+ ( AsyncM
+ , withAsync
+ , waitCatch
+ , wait
+ , asyncThreadId
+ , cancel
+ , uninterruptibleCancel
+ , AsyncCancelled (..)
+
-- * Cabal extras
- withAsyncNF,
- ) where
+ , withAsyncNF
+ ) where
-import Control.Concurrent (ThreadId, forkIO)
+import Control.Concurrent (ThreadId, forkIO)
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)
-import Control.DeepSeq (NFData, force)
+import Control.DeepSeq (NFData, force)
import Control.Exception
- (BlockedIndefinitelyOnMVar (..), Exception (..), SomeException (..), catch, evaluate, mask, throwIO, throwTo, try, uninterruptibleMask_)
-import Control.Monad (void)
-import Data.Typeable (Typeable)
-import GHC.Exts (inline)
+ ( BlockedIndefinitelyOnMVar (..)
+ , Exception (..)
+ , SomeException (..)
+ , catch
+ , evaluate
+ , mask
+ , throwIO
+ , throwTo
+ , try
+ , uninterruptibleMask_
+ )
+import Control.Monad (void)
+import Data.Typeable (Typeable)
+import GHC.Exts (inline)
#if MIN_VERSION_base(4,7,0)
import Control.Exception (asyncExceptionFromException, asyncExceptionToException)
@@ -33,9 +48,9 @@ import Control.Exception (asyncExceptionFromException, asyncExceptionToException
-- | Async, but based on 'MVar', as we don't depend on @stm@.
data AsyncM a = Async
{ asyncThreadId :: {-# UNPACK #-} !ThreadId
- -- ^ Returns the 'ThreadId' of the thread running
- -- the given 'Async'.
- , _asyncMVar :: MVar (Either SomeException a)
+ -- ^ Returns the 'ThreadId' of the thread running
+ -- the given 'Async'.
+ , _asyncMVar :: MVar (Either SomeException a)
}
-- | Spawn an asynchronous action in a separate thread, and pass its
@@ -52,12 +67,12 @@ data AsyncM a = Async
-- Note: a reference to the child thread is kept alive until the call
-- to `withAsync` returns, so nesting many `withAsync` calls requires
-- linear memory.
---
withAsync :: IO a -> (AsyncM a -> IO b) -> IO b
withAsync = inline withAsyncUsing forkIO
withAsyncNF :: NFData a => IO a -> (AsyncM a -> IO b) -> IO b
-withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF) where
+withAsyncNF m = inline withAsyncUsing forkIO (m >>= evaluateNF)
+ where
evaluateNF = evaluate . force
withAsyncUsing :: (IO () -> IO ThreadId) -> IO a -> (AsyncM a -> IO b) -> IO b
@@ -68,7 +83,8 @@ withAsyncUsing doFork = \action inner -> do
mask $ \restore -> do
t <- doFork $ try (restore action) >>= putMVar var
let a = Async t var
- r <- restore (inner a) `catchAll` \e -> do
+ r <-
+ restore (inner a) `catchAll` \e -> do
uninterruptibleCancel a
throwIO e
uninterruptibleCancel a
@@ -79,21 +95,19 @@ withAsyncUsing doFork = \action inner -> do
-- exception is re-thrown by 'wait'.
--
-- > wait = atomically . waitSTM
---
{-# INLINE wait #-}
wait :: AsyncM a -> IO a
wait a = do
- res <- waitCatch a
- case res of
- Left (SomeException e) -> throwIO e
- Right x -> return x
+ res <- waitCatch a
+ case res of
+ Left (SomeException e) -> throwIO e
+ Right x -> return x
-- | Wait for an asynchronous action to complete, and return either
-- @Left e@ if the action raised an exception @e@, or @Right a@ if it
-- returned a value @a@.
--
-- > waitCatch = atomically . waitCatchSTM
---
{-# INLINE waitCatch #-}
waitCatch :: AsyncM a -> IO (Either SomeException a)
waitCatch (Async _ var) = tryAgain (readMVar var)
@@ -123,15 +137,18 @@ catchAll = catch
{-# INLINE cancel #-}
cancel :: AsyncM a -> IO ()
cancel a@(Async t _) = do
- throwTo t AsyncCancelled
- void (waitCatch a)
+ throwTo t AsyncCancelled
+ void (waitCatch a)
-- | The exception thrown by `cancel` to terminate a thread.
data AsyncCancelled = AsyncCancelled
- deriving (Show, Eq
+ deriving
+ ( Show
+ , Eq
, Typeable
)
+{- FOURMOLU_DISABLE -}
instance Exception AsyncCancelled where
#if MIN_VERSION_base(4,7,0)
-- wraps in SomeAsyncException
@@ -139,6 +156,7 @@ instance Exception AsyncCancelled where
fromException = asyncExceptionFromException
toException = asyncExceptionToException
#endif
+{- FOURMOLU_ENABLE -}
-- | Cancel an asynchronous action
--
diff --git a/Cabal/src/Distribution/Compat/CopyFile.hs b/Cabal/src/Distribution/Compat/CopyFile.hs
index 8bed37b630af1ce06596e506e8491e1a05cfc54a..fccd593ef787228a09c9299d64947f2eb022597d 100644
--- a/Cabal/src/Distribution/Compat/CopyFile.hs
+++ b/Cabal/src/Distribution/Compat/CopyFile.hs
@@ -1,18 +1,19 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
-module Distribution.Compat.CopyFile (
- copyFile,
- copyFileChanged,
- filesEqual,
- copyOrdinaryFile,
- copyExecutableFile,
- setFileOrdinary,
- setFileExecutable,
- setDirOrdinary,
+
+module Distribution.Compat.CopyFile
+ ( copyFile
+ , copyFileChanged
+ , filesEqual
+ , copyOrdinaryFile
+ , copyExecutableFile
+ , setFileOrdinary
+ , setFileExecutable
+ , setDirOrdinary
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
#ifndef mingw32_HOST_OS
import Distribution.Compat.Internal.TempFile
@@ -66,7 +67,7 @@ import qualified System.Win32.File as Win32 ( copyFile )
#endif /* mingw32_HOST_OS */
copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
-copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
@@ -93,7 +94,7 @@ copyFile :: FilePath -> FilePath -> IO ()
copyFile fromFPath toFPath =
copy
`catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))
- where
+ where
#ifndef mingw32_HOST_OS
copy = withBinaryFile fromFPath ReadMode $ \hFrom ->
bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
@@ -239,8 +240,9 @@ filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual f1 f2 = do
ex1 <- doesFileExist f1
ex2 <- doesFileExist f2
- if not (ex1 && ex2) then return False else
- withBinaryFile f1 ReadMode $ \h1 ->
+ if not (ex1 && ex2)
+ then return False
+ else withBinaryFile f1 ReadMode $ \h1 ->
withBinaryFile f2 ReadMode $ \h2 -> do
s1 <- hFileSize h1
s2 <- hFileSize h2
diff --git a/Cabal/src/Distribution/Compat/Directory.hs b/Cabal/src/Distribution/Compat/Directory.hs
index 07330951c0167e78b2da386e456a05f691bca5d9..9698102842a8eb3d57ec6b25c1c37022a3b04abd 100644
--- a/Cabal/src/Distribution/Compat/Directory.hs
+++ b/Cabal/src/Distribution/Compat/Directory.hs
@@ -1,10 +1,10 @@
{-# LANGUAGE CPP #-}
module Distribution.Compat.Directory
-( listDirectory
-, makeAbsolute
-, doesPathExist
-) where
+ ( listDirectory
+ , makeAbsolute
+ , doesPathExist
+ ) where
#if MIN_VERSION_directory(1,2,7)
import System.Directory as Dir hiding (doesPathExist)
@@ -46,4 +46,3 @@ doesPathExist path = do
else doesFileExist path
#endif
-
diff --git a/Cabal/src/Distribution/Compat/Environment.hs b/Cabal/src/Distribution/Compat/Environment.hs
index fbf9cf41c420d7624ae4e1216ea6baa29380b337..ffe278bcc54b6d2172c4e0281ad6755af75830b1 100644
--- a/Cabal/src/Distribution/Compat/Environment.hs
+++ b/Cabal/src/Distribution/Compat/Environment.hs
@@ -3,16 +3,15 @@
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_HADDOCK hide #-}
-module Distribution.Compat.Environment
- ( getEnvironment, lookupEnv, setEnv, unsetEnv )
- where
+module Distribution.Compat.Environment (getEnvironment, lookupEnv, setEnv, unsetEnv)
+where
+import Distribution.Compat.Prelude
import Prelude ()
import qualified Prelude
-import Distribution.Compat.Prelude
-import qualified System.Environment as System
import System.Environment (lookupEnv, unsetEnv)
+import qualified System.Environment as System
import Distribution.Compat.Stack
@@ -61,6 +60,7 @@ setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
where
_ = callStack -- TODO: attach CallStack to exception
+{- FOURMOLU_DISABLE -}
# if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
@@ -83,3 +83,4 @@ setEnv_ key value = do
foreign import ccall unsafe "setenv"
c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt
#endif /* mingw32_HOST_OS */
+{- FOURMOLU_ENABLE -}
diff --git a/Cabal/src/Distribution/Compat/FilePath.hs b/Cabal/src/Distribution/Compat/FilePath.hs
index 8c5b11a726294e0504aa6130d730df7001d7b436..6e1c7961313269d186d7f8c3c3993f1f745579b2 100644
--- a/Cabal/src/Distribution/Compat/FilePath.hs
+++ b/Cabal/src/Distribution/Compat/FilePath.hs
@@ -1,13 +1,12 @@
{-# LANGUAGE CPP #-}
-
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
module Distribution.Compat.FilePath
-( isExtensionOf
-, stripExtension
-) where
+ ( isExtensionOf
+ , stripExtension
+ ) where
-import Data.List ( isSuffixOf, stripPrefix )
+import Data.List (isSuffixOf, stripPrefix)
import System.FilePath
#if !MIN_VERSION_filepath(1,4,2)
diff --git a/Cabal/src/Distribution/Compat/GetShortPathName.hs b/Cabal/src/Distribution/Compat/GetShortPathName.hs
index baf402c326bc7cae7a0d0307ed79c049679b52a9..f6c9517dd71a5efcc1321c8d9a5634710f5de494 100644
--- a/Cabal/src/Distribution/Compat/GetShortPathName.hs
+++ b/Cabal/src/Distribution/Compat/GetShortPathName.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compat.GetShortPathName
--
@@ -8,12 +9,11 @@
-- Portability : Windows-only
--
-- Win32 API 'GetShortPathName' function.
+module Distribution.Compat.GetShortPathName (getShortPathName)
+where
-module Distribution.Compat.GetShortPathName ( getShortPathName )
- where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
#ifdef mingw32_HOST_OS
@@ -22,6 +22,7 @@ import qualified System.Win32 as Win32
import System.Win32 (LPCTSTR, LPTSTR, DWORD)
import Foreign.Marshal.Array (allocaArray)
+{- FOURMOLU_DISABLE -}
#ifdef x86_64_HOST_ARCH
#define WINAPI ccall
#else
@@ -57,3 +58,4 @@ getShortPathName :: FilePath -> IO FilePath
getShortPathName path = return path
#endif
+{- FOURMOLU_ENABLE -}
diff --git a/Cabal/src/Distribution/Compat/Internal/TempFile.hs b/Cabal/src/Distribution/Compat/Internal/TempFile.hs
index bf967ec4dd86c8efbba2680c9db9631588520434..805df700229b829205550933a3e98475875fb7b8 100644
--- a/Cabal/src/Distribution/Compat/Internal/TempFile.hs
+++ b/Cabal/src/Distribution/Compat/Internal/TempFile.hs
@@ -1,17 +1,18 @@
{-# LANGUAGE CPP #-}
{-# OPTIONS_HADDOCK hide #-}
-module Distribution.Compat.Internal.TempFile (
- openTempFile,
- openBinaryTempFile,
- openNewBinaryFile,
- createTempDirectory,
+
+module Distribution.Compat.Internal.TempFile
+ ( openTempFile
+ , openBinaryTempFile
+ , openNewBinaryFile
+ , createTempDirectory
) where
import Distribution.Compat.Exception
-import System.FilePath ((</>))
+import System.FilePath ((</>))
-import System.IO (Handle, openTempFile, openBinaryTempFile)
+import System.IO (Handle, openBinaryTempFile, openTempFile)
#if defined(__IO_MANAGER_WINIO__)
import System.IO (openBinaryTempFileWithDefaultPermissions)
#else
@@ -23,8 +24,8 @@ import System.Posix.Internals (c_open, c_close, o_EXCL, o_BINARY, withFilePath,
o_CREAT, o_RDWR, o_NONBLOCK, o_NOCTTY)
#endif
+import System.IO.Error (isAlreadyExistsError)
import System.Posix.Internals (c_getpid)
-import System.IO.Error (isAlreadyExistsError)
#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
import System.Directory ( createDirectory )
@@ -33,7 +34,9 @@ import qualified System.Posix
#endif
-- ------------------------------------------------------------
+
-- * temporary files
+
-- ------------------------------------------------------------
-- This is here for Haskell implementations that do not come with
@@ -46,9 +49,10 @@ import qualified System.Posix
-- Windows when the new IO manager is used.
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile dir template = do
- -- This method can't be used under WINIO. Also the current implementation has
- -- thread safety issues depending on which GHC is used. On newer GHC's let's
- -- use the built in one.
+
+-- This method can't be used under WINIO. Also the current implementation has
+-- thread safety issues depending on which GHC is used. On newer GHC's let's
+-- use the built in one.
#if defined(__IO_MANAGER_WINIO__)
openBinaryTempFileWithDefaultPermissions dir template
#else
@@ -126,8 +130,9 @@ createTempDirectory dir template = do
r <- tryIO $ mkPrivateDir dirpath
case r of
Right _ -> return dirpath
- Left e | isAlreadyExistsError e -> findTempName (x+1)
- | otherwise -> ioError e
+ Left e
+ | isAlreadyExistsError e -> findTempName (x + 1)
+ | otherwise -> ioError e
mkPrivateDir :: String -> IO ()
#if defined(mingw32_HOST_OS) || defined(ghcjs_HOST_OS)
diff --git a/Cabal/src/Distribution/Compat/Prelude/Internal.hs b/Cabal/src/Distribution/Compat/Prelude/Internal.hs
index b3f998d331330dd45022f8b11272c28d3d044876..e13d86284ce9c8671ab1b93dd0b0d0583ab1c5c2 100644
--- a/Cabal/src/Distribution/Compat/Prelude/Internal.hs
+++ b/Cabal/src/Distribution/Compat/Prelude/Internal.hs
@@ -7,8 +7,8 @@
-- for @Setup.hs@ scripts since its API is /not/
-- stable.
module Distribution.Compat.Prelude.Internal
- {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}
- ( module Distribution.Compat.Prelude
- ) where
+ {-# WARNING "This modules' API is not stable. Use at your own risk, or better yet, use @base-compat@!" #-}
+ ( module Distribution.Compat.Prelude
+ ) where
import Distribution.Compat.Prelude
diff --git a/Cabal/src/Distribution/Compat/Process.hs b/Cabal/src/Distribution/Compat/Process.hs
index 24fc0c861c181b0f5499c2172d38bb2fcf47d523..f82fc6012870ed17a68ae60ec458ab10af536fe8 100644
--- a/Cabal/src/Distribution/Compat/Process.hs
+++ b/Cabal/src/Distribution/Compat/Process.hs
@@ -1,12 +1,14 @@
{-# LANGUAGE CPP #-}
-module Distribution.Compat.Process (
- -- * Redefined functions
- proc,
+
+module Distribution.Compat.Process
+ ( -- * Redefined functions
+ proc
+
-- * Additions
- enableProcessJobs,
- ) where
+ , enableProcessJobs
+ ) where
-import System.Process (CreateProcess)
+import System.Process (CreateProcess)
import qualified System.Process as Process
#if defined(mingw32_HOST_OS) && MIN_VERSION_process(1,6,9)
@@ -58,4 +60,4 @@ enableProcessJobs cp = cp
-- | 'System.Process.proc' with process jobs enabled when appropriate,
-- and defaulting 'delegate_ctlc' to 'True'.
proc :: FilePath -> [String] -> CreateProcess
-proc path args = enableProcessJobs (Process.proc path args) { Process.delegate_ctlc = True }
+proc path args = enableProcessJobs (Process.proc path args){Process.delegate_ctlc = True}
diff --git a/Cabal/src/Distribution/Compat/ResponseFile.hs b/Cabal/src/Distribution/Compat/ResponseFile.hs
index db0a92994c8e690d95e18cef9f21648215378fda..d16275fb0448ada01247d266de8cdea87ebf53fb 100644
--- a/Cabal/src/Distribution/Compat/ResponseFile.hs
+++ b/Cabal/src/Distribution/Compat/ResponseFile.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE CPP, RankNTypes, FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
-- Compatibility layer for GHC.ResponseFile
-- Implementation from base 4.12.0 is used.
@@ -56,11 +58,11 @@ expandResponse = go recursionLimit "."
go :: Int -> FilePath -> [String] -> IO [String]
go n dir
- | n >= 0 = fmap concat . traverse (expand n dir)
+ | n >= 0 = fmap concat . traverse (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 arg@('@' : f) = readRecursively n (dir </> f) `catchIOError` (const $ print "?" >> return [arg])
expand _n _dir x = return [x]
readRecursively :: Int -> FilePath -> IO [String]
diff --git a/Cabal/src/Distribution/Compat/SnocList.hs b/Cabal/src/Distribution/Compat/SnocList.hs
index c5679167aa10a13b0b155a8db2c46bac6f3788e2..d655b3028813b50a9d3538a034ccdcaf011617f1 100644
--- a/Cabal/src/Distribution/Compat/SnocList.hs
+++ b/Cabal/src/Distribution/Compat/SnocList.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Compat.SnocList
-- License : BSD3
@@ -8,14 +9,14 @@
-- Portability : portable
--
-- A very reversed list. Has efficient `snoc`
-module Distribution.Compat.SnocList (
- SnocList,
- runSnocList,
- snoc,
-) where
+module Distribution.Compat.SnocList
+ ( SnocList
+ , runSnocList
+ , snoc
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
newtype SnocList a = SnocList [a]
@@ -26,8 +27,8 @@ runSnocList :: SnocList a -> [a]
runSnocList (SnocList xs) = reverse xs
instance Semigroup (SnocList a) where
- SnocList xs <> SnocList ys = SnocList (ys <> xs)
+ SnocList xs <> SnocList ys = SnocList (ys <> xs)
instance Monoid (SnocList a) where
- mempty = SnocList []
- mappend = (<>)
+ mempty = SnocList []
+ mappend = (<>)
diff --git a/Cabal/src/Distribution/Compat/Stack.hs b/Cabal/src/Distribution/Compat/Stack.hs
index 0ed0da2e43ec8ab9f077afbc23dcf3859c40d7f2..41d4ff8b460a84ac24baf6e5de20104d12ddc087 100644
--- a/Cabal/src/Distribution/Compat/Stack.hs
+++ b/Cabal/src/Distribution/Compat/Stack.hs
@@ -1,16 +1,17 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ImplicitParams #-}
-module Distribution.Compat.Stack (
- WithCallStack,
- CallStack,
- annotateCallStackIO,
- withFrozenCallStack,
- withLexicalCallStack,
- callStack,
- prettyCallStack,
- parentSrcLocPrefix
-) where
+{-# LANGUAGE RankNTypes #-}
+
+module Distribution.Compat.Stack
+ ( WithCallStack
+ , CallStack
+ , annotateCallStackIO
+ , withFrozenCallStack
+ , withLexicalCallStack
+ , callStack
+ , prettyCallStack
+ , parentSrcLocPrefix
+ ) where
import System.IO.Error
@@ -106,8 +107,9 @@ withLexicalCallStack f = f
annotateCallStackIO :: WithCallStack (IO a -> IO a)
annotateCallStackIO = modifyIOError f
where
- f ioe = ioeSetErrorString ioe
- . wrapCallStack
- $ ioeGetErrorString ioe
+ f ioe =
+ ioeSetErrorString ioe
+ . wrapCallStack
+ $ ioeGetErrorString ioe
wrapCallStack s =
- prettyCallStack callStack ++ "\n" ++ s
+ prettyCallStack callStack ++ "\n" ++ s
diff --git a/Cabal/src/Distribution/Compat/Time.hs b/Cabal/src/Distribution/Compat/Time.hs
index ef73b4fc8a1a156e3e1ec070ae1603ca105313fb..168c2d919b43aca261c1c8b5107ee2ee486cd568 100644
--- a/Cabal/src/Distribution/Compat/Time.hs
+++ b/Cabal/src/Distribution/Compat/Time.hs
@@ -1,32 +1,33 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Compat.Time
- ( ModTime(..) -- Needed for testing
- , getModTime, getFileAge, getCurTime
- , posixSecondsToModTime
- , calibrateMtimeChangeDelay )
- where
+ ( ModTime (..) -- Needed for testing
+ , getModTime
+ , getFileAge
+ , getCurTime
+ , posixSecondsToModTime
+ , calibrateMtimeChangeDelay
+ )
+where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import System.Directory ( getModificationTime )
+import System.Directory (getModificationTime)
-import Distribution.Simple.Utils ( withTempDirectory )
-import Distribution.Verbosity ( silent )
+import Distribution.Simple.Utils (withTempDirectory)
+import Distribution.Verbosity (silent)
import System.FilePath
-import Data.Time.Clock.POSIX ( POSIXTime, getPOSIXTime )
-import Data.Time ( diffUTCTime, getCurrentTime )
-import Data.Time.Clock.POSIX ( posixDayLength )
-
+import Data.Time (diffUTCTime, getCurrentTime)
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixDayLength)
#if defined mingw32_HOST_OS
@@ -57,7 +58,7 @@ import System.Posix.Files ( modificationTime )
-- | An opaque type representing a file's modification time, represented
-- internally as a 64-bit unsigned integer in the Windows UTC format.
newtype ModTime = ModTime Word64
- deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)
+ deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)
instance Structured ModTime
@@ -101,6 +102,7 @@ getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
#endif
return $! ModTime (qwTime :: Word64)
+{- FOURMOLU_DISABLE -}
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
@@ -138,9 +140,10 @@ extractFileTime :: FileStatus -> ModTime
extractFileTime x = posixTimeToModTime (modificationTimeHiRes x)
#endif
+{- FOURMOLU_ENABLE -}
windowsTick, secToUnixEpoch :: Word64
-windowsTick = 10000000
+windowsTick = 10000000
secToUnixEpoch = 11644473600
-- | Convert POSIX seconds to ModTime.
@@ -150,8 +153,10 @@ posixSecondsToModTime s =
-- | Convert 'POSIXTime' to 'ModTime'.
posixTimeToModTime :: POSIXTime -> ModTime
-posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision
- + (secToUnixEpoch * windowsTick)
+posixTimeToModTime p =
+ ModTime $
+ (ceiling $ p * 1e7) -- 100 ns precision
+ + (secToUnixEpoch * windowsTick)
-- | Return age of given file in days.
getFileAge :: FilePath -> IO Double
@@ -174,15 +179,15 @@ calibrateMtimeChangeDelay :: IO (Int, Int)
calibrateMtimeChangeDelay =
withTempDirectory silent "." "calibration-" $ \dir -> do
let fileName = dir </> "probe"
- mtimes <- for [1..25] $ \(i::Int) -> time $ do
+ mtimes <- for [1 .. 25] $ \(i :: Int) -> time $ do
writeFile fileName $ show i
t0 <- getModTime fileName
let spin j = do
- writeFile fileName $ show (i,j)
+ writeFile fileName $ show (i, j)
t1 <- getModTime fileName
unless (t0 < t1) (spin $ j + 1)
- spin (0::Int)
- let mtimeChange = maximum mtimes
+ spin (0 :: Int)
+ let mtimeChange = maximum mtimes
mtimeChange' = min 1000000 $ (max 10000 mtimeChange) * 2
return (mtimeChange, mtimeChange')
where
diff --git a/Cabal/src/Distribution/GetOpt.hs b/Cabal/src/Distribution/GetOpt.hs
index 3dd28a1e462e35eee5c1f1dfea5cd14b1e8c8d19..3a02fede464f3a7c11b0efe09da7a1007a458d1c 100644
--- a/Cabal/src/Distribution/GetOpt.hs
+++ b/Cabal/src/Distribution/GetOpt.hs
@@ -1,4 +1,7 @@
+{-# LANGUAGE NamedFieldPuns #-}
-----------------------------------------------------------------------------
+{-# LANGUAGE TupleSections #-}
+
-- |
-- Module : Distribution.GetOpt
-- Copyright : (c) Sven Panne 2002-2005
@@ -20,78 +23,84 @@
-- * Parsing of option arguments is allowed to fail.
--
-- * 'ReturnInOrder' argument order is removed.
---
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE NamedFieldPuns #-}
-module Distribution.GetOpt (
- -- * GetOpt
- getOpt, getOpt',
- usageInfo,
- ArgOrder(..),
- OptDescr(..),
- ArgDescr(..),
-
- -- * Example
- -- | See "System.Console.GetOpt" for examples
-) where
+module Distribution.GetOpt
+ ( -- * GetOpt
+ getOpt
+ , getOpt'
+ , usageInfo
+ , ArgOrder (..)
+ , OptDescr (..)
+ , ArgDescr (..)
+
+ -- * Example
+
+ -- | See "System.Console.GetOpt" for examples
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- | What to do with options following non-options
data ArgOrder a
- = RequireOrder -- ^ no option processing after first non-option
- | Permute -- ^ freely intersperse options and non-options
-
-data OptDescr a = -- description of a single options:
- Option [Char] -- list of short option characters
- [String] -- list of long option strings (without "--")
- (ArgDescr a) -- argument descriptor
- String -- explanation of option for user
+ = -- | no option processing after first non-option
+ RequireOrder
+ | -- | freely intersperse options and non-options
+ Permute
+
+data OptDescr a -- description of a single options:
+ = Option
+ [Char] -- list of short option characters
+ [String] -- list of long option strings (without "--")
+ (ArgDescr a) -- argument descriptor
+ String -- explanation of option for user
instance Functor OptDescr where
- fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c
+ fmap f (Option a b argDescr c) = Option a b (fmap f argDescr) c
-- | Describes whether an option takes an argument or not, and if so
-- how the argument is parsed to a value of type @a@.
--
-- Compared to System.Console.GetOpt, we allow for parse errors.
data ArgDescr a
- = NoArg a -- ^ no argument expected
- | ReqArg (String -> Either String a) String -- ^ option requires argument
- | OptArg (Maybe String -> Either String a) String -- ^ optional argument
+ = -- | no argument expected
+ NoArg a
+ | -- | option requires argument
+ ReqArg (String -> Either String a) String
+ | -- | optional argument
+ OptArg (Maybe String -> Either String a) String
instance Functor ArgDescr where
- fmap f (NoArg a) = NoArg (f a)
- fmap f (ReqArg g s) = ReqArg (fmap f . g) s
- fmap f (OptArg g s) = OptArg (fmap f . g) s
-
-data OptKind a -- kind of cmd line arg (internal use only):
- = Opt a -- an option
- | UnreqOpt String -- an un-recognized option
- | NonOpt String -- a non-option
- | EndOfOpts -- end-of-options marker (i.e. "--")
- | OptErr String -- something went wrong...
-
-data OptHelp = OptHelp {
- optNames :: String,
- optHelp :: String
- }
+ fmap f (NoArg a) = NoArg (f a)
+ fmap f (ReqArg g s) = ReqArg (fmap f . g) s
+ fmap f (OptArg g s) = OptArg (fmap f . g) s
+
+data OptKind a -- kind of cmd line arg (internal use only):
+ = Opt a -- an option
+ | UnreqOpt String -- an un-recognized option
+ | NonOpt String -- a non-option
+ | EndOfOpts -- end-of-options marker (i.e. "--")
+ | OptErr String -- something went wrong...
+
+data OptHelp = OptHelp
+ { optNames :: String
+ , optHelp :: String
+ }
-- | Return a string describing the usage of a command, derived from
-- the header (first argument) and the options described by the
-- second argument.
-usageInfo :: String -- header
- -> [OptDescr a] -- option descriptors
- -> String -- nicely formatted description of options
+usageInfo
+ :: String -- header
+ -> [OptDescr a] -- option descriptors
+ -> String -- nicely formatted description of options
usageInfo header optDescr = unlines (header : table)
where
options = flip map optDescr $ \(Option sos los ad d) ->
OptHelp
{ optNames =
- intercalate ", " $
- map (fmtShort ad) sos ++
- map (fmtLong ad) (take 1 los)
+ intercalate ", " $
+ map (fmtShort ad) sos
+ ++ map (fmtLong ad) (take 1 los)
, optHelp = d
}
@@ -103,8 +112,9 @@ usageInfo header optDescr = unlines (header : table)
OptHelp{optNames, optHelp} <- options
let wrappedHelp = wrapText descolWidth optHelp
if length optNames >= maxOptNameWidth
- then [" " ++ optNames] ++
- renderColumns [] wrappedHelp
+ then
+ [" " ++ optNames]
+ ++ renderColumns [] wrappedHelp
else renderColumns [optNames] wrappedHelp
renderColumns :: [String] -> [String] -> [String]
@@ -112,146 +122,155 @@ usageInfo header optDescr = unlines (header : table)
(x, y) <- zipDefault "" "" xs ys
return $ " " ++ padTo maxOptNameWidth x ++ " " ++ y
- padTo n x = take n (x ++ repeat ' ')
+ padTo n x = take n (x ++ repeat ' ')
-zipDefault :: a -> b -> [a] -> [b] -> [(a,b)]
-zipDefault _ _ [] [] = []
-zipDefault _ bd (a:as) [] = (a,bd) : map (,bd) as
-zipDefault ad _ [] (b:bs) = (ad,b) : map (ad,) bs
-zipDefault ad bd (a:as) (b:bs) = (a,b) : zipDefault ad bd as bs
+zipDefault :: a -> b -> [a] -> [b] -> [(a, b)]
+zipDefault _ _ [] [] = []
+zipDefault _ bd (a : as) [] = (a, bd) : map (,bd) as
+zipDefault ad _ [] (b : bs) = (ad, b) : map (ad,) bs
+zipDefault ad bd (a : as) (b : bs) = (a, b) : zipDefault ad bd as bs
fmtShort :: ArgDescr a -> Char -> String
-fmtShort (NoArg _ ) so = "-" ++ [so]
-fmtShort (ReqArg _ _) so = "-" ++ [so]
-fmtShort (OptArg _ _) so = "-" ++ [so]
- -- unlike upstream GetOpt we omit the arg name for short options
+fmtShort (NoArg _) so = "-" ++ [so]
+fmtShort (ReqArg _ _) so = "-" ++ [so]
+fmtShort (OptArg _ _) so = "-" ++ [so]
+
+-- unlike upstream GetOpt we omit the arg name for short options
fmtLong :: ArgDescr a -> String -> String
-fmtLong (NoArg _ ) lo = "--" ++ lo
+fmtLong (NoArg _) lo = "--" ++ lo
fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
wrapText :: Int -> String -> [String]
wrapText width = map unwords . wrap 0 [] . words
- where wrap :: Int -> [String] -> [String] -> [[String]]
- wrap 0 [] (w:ws)
- | length w + 1 > width
- = wrap (length w) [w] ws
- wrap col line (w:ws)
- | col + length w + 1 > width
- = reverse line : wrap 0 [] (w:ws)
- wrap col line (w:ws)
- = let col' = col + length w + 1
- in wrap col' (w:line) ws
- wrap _ [] [] = []
- wrap _ line [] = [reverse line]
-
-{-|
-Process the command-line, and return the list of values that matched
-(and those that didn\'t). The arguments are:
-
-* The order requirements (see 'ArgOrder')
-
-* The option descriptions (see 'OptDescr')
-
-* The actual command line arguments (presumably got from
- 'System.Environment.getArgs').
-
-'getOpt' returns a triple consisting of the option arguments, a list
-of non-options, and a list of error messages.
--}
-getOpt :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the command-line arguments
- -> ([a],[String],[String]) -- (options,non-options,error messages)
-getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
- where (os,xs,us,es) = getOpt' ordering optDescr args
-
-{-|
-This is almost the same as 'getOpt', but returns a quadruple
-consisting of the option arguments, a list of non-options, a list of
-unrecognized options, and a list of error messages.
--}
-getOpt' :: ArgOrder a -- non-option handling
- -> [OptDescr a] -- option descriptors
- -> [String] -- the command-line arguments
- -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
-getOpt' _ _ [] = ([],[],[],[])
-getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
- where procNextOpt (Opt o) _ = (o:os,xs,us,es)
- procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
- procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
- procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
- procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
- procNextOpt EndOfOpts Permute = ([],rest,[],[])
- procNextOpt (OptErr e) _ = (os,xs,us,e:es)
-
- (opt,rest) = getNext arg args optDescr
- (os,xs,us,es) = getOpt' ordering optDescr rest
+ where
+ wrap :: Int -> [String] -> [String] -> [[String]]
+ wrap 0 [] (w : ws)
+ | length w + 1 > width =
+ wrap (length w) [w] ws
+ wrap col line (w : ws)
+ | col + length w + 1 > width =
+ reverse line : wrap 0 [] (w : ws)
+ wrap col line (w : ws) =
+ let col' = col + length w + 1
+ in wrap col' (w : line) ws
+ wrap _ [] [] = []
+ wrap _ line [] = [reverse line]
+
+-- |
+-- Process the command-line, and return the list of values that matched
+-- (and those that didn\'t). The arguments are:
+--
+-- * The order requirements (see 'ArgOrder')
+--
+-- * The option descriptions (see 'OptDescr')
+--
+-- * The actual command line arguments (presumably got from
+-- 'System.Environment.getArgs').
+--
+-- 'getOpt' returns a triple consisting of the option arguments, a list
+-- of non-options, and a list of error messages.
+getOpt
+ :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a], [String], [String]) -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os, xs, es ++ map errUnrec us)
+ where
+ (os, xs, us, es) = getOpt' ordering optDescr args
+
+-- |
+-- This is almost the same as 'getOpt', but returns a quadruple
+-- consisting of the option arguments, a list of non-options, a list of
+-- unrecognized options, and a list of error messages.
+getOpt'
+ :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a], [String], [String], [String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _ _ [] = ([], [], [], [])
+getOpt' ordering optDescr (arg : args) = procNextOpt opt ordering
+ where
+ procNextOpt (Opt o) _ = (o : os, xs, us, es)
+ procNextOpt (UnreqOpt u) _ = (os, xs, u : us, es)
+ procNextOpt (NonOpt x) RequireOrder = ([], x : rest, [], [])
+ procNextOpt (NonOpt x) Permute = (os, x : xs, us, es)
+ procNextOpt EndOfOpts RequireOrder = ([], rest, [], [])
+ procNextOpt EndOfOpts Permute = ([], rest, [], [])
+ procNextOpt (OptErr e) _ = (os, xs, us, e : es)
+
+ (opt, rest) = getNext arg args optDescr
+ (os, xs, us, es) = getOpt' ordering optDescr rest
-- take a look at the next cmd line arg and decide what to do with it
-getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
-getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
-getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
-getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
-getNext a rest _ = (NonOpt a,rest)
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])
+getNext ('-' : '-' : []) rest _ = (EndOfOpts, rest)
+getNext ('-' : '-' : xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-' : x : xs) rest optDescr = shortOpt x xs rest optDescr
+getNext a rest _ = (NonOpt a, rest)
-- handle long option
-longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a, [String])
longOpt ls rs optDescr = long ads arg rs
- where (opt,arg) = break (=='=') ls
- getWith p = [ o | o@(Option _ xs _ _) <- optDescr
- , isJust (find (p opt) xs)]
- exact = getWith (==)
- options = if null exact then getWith isPrefixOf else exact
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = "--" ++ opt
- fromRes = fromParseResult optStr
-
- long (_:_:_) _ rest = (errAmbig options optStr,rest)
- long [NoArg a ] [] rest = (Opt a,rest)
- long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
- long [ReqArg _ d] [] [] = (errReq d optStr,[])
- long [ReqArg f _] [] (r:rest) = (fromRes (f r),rest)
- long [ReqArg f _] ('=':xs) rest = (fromRes (f xs),rest)
- long [OptArg f _] [] rest = (fromRes (f Nothing),rest)
- long [OptArg f _] ('=':xs) rest = (fromRes (f (Just xs)),rest)
- long _ _ rest = (UnreqOpt ("--"++ls),rest)
+ where
+ (opt, arg) = break (== '=') ls
+ getWith p =
+ [ o | o@(Option _ xs _ _) <- optDescr, isJust (find (p opt) xs)
+ ]
+ exact = getWith (==)
+ options = if null exact then getWith isPrefixOf else exact
+ ads = [ad | Option _ _ ad _ <- options]
+ optStr = "--" ++ opt
+ fromRes = fromParseResult optStr
+
+ long (_ : _ : _) _ rest = (errAmbig options optStr, rest)
+ long [NoArg a] [] rest = (Opt a, rest)
+ long [NoArg _] ('=' : _) rest = (errNoArg optStr, rest)
+ long [ReqArg _ d] [] [] = (errReq d optStr, [])
+ long [ReqArg f _] [] (r : rest) = (fromRes (f r), rest)
+ long [ReqArg f _] ('=' : xs) rest = (fromRes (f xs), rest)
+ long [OptArg f _] [] rest = (fromRes (f Nothing), rest)
+ long [OptArg f _] ('=' : xs) rest = (fromRes (f (Just xs)), rest)
+ long _ _ rest = (UnreqOpt ("--" ++ ls), rest)
-- handle short option
-shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a, [String])
shortOpt y ys rs optDescr = short ads ys rs
- where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
- ads = [ ad | Option _ _ ad _ <- options ]
- optStr = '-':[y]
- fromRes = fromParseResult optStr
-
- short (_:_:_) _ rest = (errAmbig options optStr,rest)
- short (NoArg a :_) [] rest = (Opt a,rest)
- short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
- short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
- short (ReqArg f _:_) [] (r:rest) = (fromRes (f r),rest)
- short (ReqArg f _:_) xs rest = (fromRes (f xs),rest)
- short (OptArg f _:_) [] rest = (fromRes (f Nothing),rest)
- short (OptArg f _:_) xs rest = (fromRes (f (Just xs)),rest)
- short [] [] rest = (UnreqOpt optStr,rest)
- short [] xs rest = (UnreqOpt (optStr++xs),rest)
- -- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)
- -- Apparently this was part of the change so that flags that are
- -- not recognised as global flags are passed on to the sub-command.
- -- But why was no equivalent change required for longOpt? So could
- -- this change go upstream?
+ where
+ options = [o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s]
+ ads = [ad | Option _ _ ad _ <- options]
+ optStr = '-' : [y]
+ fromRes = fromParseResult optStr
+
+ short (_ : _ : _) _ rest = (errAmbig options optStr, rest)
+ short (NoArg a : _) [] rest = (Opt a, rest)
+ short (NoArg a : _) xs rest = (Opt a, ('-' : xs) : rest)
+ short (ReqArg _ d : _) [] [] = (errReq d optStr, [])
+ short (ReqArg f _ : _) [] (r : rest) = (fromRes (f r), rest)
+ short (ReqArg f _ : _) xs rest = (fromRes (f xs), rest)
+ short (OptArg f _ : _) [] rest = (fromRes (f Nothing), rest)
+ short (OptArg f _ : _) xs rest = (fromRes (f (Just xs)), rest)
+ short [] [] rest = (UnreqOpt optStr, rest)
+ short [] xs rest = (UnreqOpt (optStr ++ xs), rest)
+
+-- This is different vs upstream = (UnreqOpt optStr,('-':xs):rest)
+-- Apparently this was part of the change so that flags that are
+-- not recognised as global flags are passed on to the sub-command.
+-- But why was no equivalent change required for longOpt? So could
+-- this change go upstream?
fromParseResult :: String -> Either String a -> OptKind a
fromParseResult optStr res = case res of
- Right x -> Opt x
- Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")
+ Right x -> Opt x
+ Left err -> OptErr ("invalid argument to option `" ++ optStr ++ "': " ++ err ++ "\n")
-- miscellaneous error formatting
errAmbig :: [OptDescr a] -> String -> OptKind b
errAmbig ods optStr = OptErr (usageInfo header ods)
- where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+ where
+ header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
errReq :: String -> String -> OptKind a
errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
diff --git a/Cabal/src/Distribution/Lex.hs b/Cabal/src/Distribution/Lex.hs
index 4dbab5932fe1f9fc16dc7a0b0e070e46d9e5b356..4ca1f512ce5fecdb557886675c39c5155bdcedae 100644
--- a/Cabal/src/Distribution/Lex.hs
+++ b/Cabal/src/Distribution/Lex.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Lex
-- Copyright : Ben Gamari 2015-2019
@@ -7,34 +8,35 @@
-- Portability : portable
--
-- This module contains a simple lexer supporting quoted strings
+module Distribution.Lex
+ ( tokenizeQuotedWords
+ ) where
-module Distribution.Lex (
- tokenizeQuotedWords
- ) where
-
-import Prelude ()
-import Distribution.Compat.Prelude
import Distribution.Compat.DList
+import Distribution.Compat.Prelude
+import Prelude ()
tokenizeQuotedWords :: String -> [String]
tokenizeQuotedWords = filter (not . null) . go False mempty
where
- go :: Bool -- ^ in quoted region
- -> DList Char -- ^ accumulator
- -> String -- ^ string to be parsed
- -> [String] -- ^ parse result
+ go
+ :: Bool
+ -- \^ in quoted region
+ -> DList Char
+ -- \^ accumulator
+ -> String
+ -- \^ string to be parsed
+ -> [String]
+ -- \^ parse result
go _ accum []
| [] <- accum' = []
- | otherwise = [accum']
- where accum' = runDList accum
-
- go False accum (c:cs)
+ | otherwise = [accum']
+ where
+ accum' = runDList accum
+ go False accum (c : cs)
| isSpace c = runDList accum : go False mempty cs
- | c == '"' = go True accum cs
-
- go True accum (c:cs)
- | c == '"' = go False accum cs
-
- go quoted accum (c:cs)
- = go quoted (accum `mappend` singleton c) cs
-
+ | c == '"' = go True accum cs
+ go True accum (c : cs)
+ | c == '"' = go False accum cs
+ go quoted accum (c : cs) =
+ go quoted (accum `mappend` singleton c) cs
diff --git a/Cabal/src/Distribution/Make.hs b/Cabal/src/Distribution/Make.hs
index b5651d3b323989020017765d1f94ee8fa4e09843..716033e42a3e1e33fde776645ccf624d0d37b114 100644
--- a/Cabal/src/Distribution/Make.hs
+++ b/Cabal/src/Distribution/Make.hs
@@ -2,6 +2,11 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
+-- copy :
+-- $(MAKE) install prefix=$(destdir)/$(prefix) \
+-- bindir=$(destdir)/$(bindir) \
+
-- |
-- Module : Distribution.Make
-- Copyright : Martin Sjögren 2004
@@ -51,32 +56,28 @@
-- [UnregisterCmd] We assume there is an @unregister@ target.
--
-- [HaddockCmd] We assume there is a @docs@ or @doc@ target.
-
-
--- copy :
--- $(MAKE) install prefix=$(destdir)/$(prefix) \
--- bindir=$(destdir)/$(bindir) \
-
-module Distribution.Make (
- module Distribution.Package,
- License(..), Version,
- defaultMain, defaultMainArgs
+module Distribution.Make
+ ( module Distribution.Package
+ , License (..)
+ , Version
+ , defaultMain
+ , defaultMainArgs
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- local
import Distribution.Package
+import Distribution.Simple.Command
import Distribution.Simple.Program
import Distribution.Simple.Setup
-import Distribution.Simple.Command
import Distribution.Simple.Utils
import Distribution.License
-import Distribution.Version
import Distribution.Pretty
+import Distribution.Version
import System.Environment (getArgs, getProgName)
@@ -89,18 +90,18 @@ defaultMainArgs = defaultMainHelper
defaultMainHelper :: [String] -> IO ()
defaultMainHelper args =
case commandsRun (globalCommand commands) commands args of
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo (flags, commandParse) ->
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (flags, commandParse) ->
case commandParse of
- _ | fromFlag (globalVersion flags) -> printVersion
+ _
+ | fromFlag (globalVersion flags) -> printVersion
| fromFlag (globalNumericVersion flags) -> printNumericVersion
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo action -> action
-
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo action -> action
where
printHelp help = getProgName >>= putStr . help
printOptionsList = putStr . unlines
@@ -108,20 +109,22 @@ defaultMainHelper args =
putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printNumericVersion = putStrLn $ prettyShow cabalVersion
- printVersion = putStrLn $ "Cabal library version "
- ++ prettyShow cabalVersion
+ printVersion =
+ putStrLn $
+ "Cabal library version "
+ ++ prettyShow cabalVersion
progs = defaultProgramDb
commands =
- [configureCommand progs `commandAddAction` configureAction
- ,buildCommand progs `commandAddAction` buildAction
- ,installCommand `commandAddAction` installAction
- ,copyCommand `commandAddAction` copyAction
- ,haddockCommand `commandAddAction` haddockAction
- ,cleanCommand `commandAddAction` cleanAction
- ,sdistCommand `commandAddAction` sdistAction
- ,registerCommand `commandAddAction` registerAction
- ,unregisterCommand `commandAddAction` unregisterAction
+ [ configureCommand progs `commandAddAction` configureAction
+ , buildCommand progs `commandAddAction` buildAction
+ , installCommand `commandAddAction` installAction
+ , copyCommand `commandAddAction` copyAction
+ , haddockCommand `commandAddAction` haddockAction
+ , cleanCommand `commandAddAction` cleanAction
+ , sdistCommand `commandAddAction` sdistAction
+ , registerCommand `commandAddAction` registerAction
+ , unregisterCommand `commandAddAction` unregisterAction
]
configureAction :: ConfigFlags -> [String] -> IO ()
@@ -130,16 +133,17 @@ configureAction flags args = do
let verbosity = fromFlag (configVerbosity flags)
rawSystemExit verbosity "sh" $
"configure"
- : configureArgs backwardsCompatHack flags
- where backwardsCompatHack = True
+ : configureArgs backwardsCompatHack flags
+ where
+ backwardsCompatHack = True
copyAction :: CopyFlags -> [String] -> IO ()
copyAction flags args = do
noExtraFlags args
let destArgs = case fromFlag $ copyDest flags of
- NoCopyDest -> ["install"]
- CopyTo path -> ["copy", "destdir=" ++ path]
- CopyToDb _ -> error "CopyToDb not supported via Make"
+ NoCopyDest -> ["install"]
+ CopyTo path -> ["copy", "destdir=" ++ path]
+ CopyToDb _ -> error "CopyToDb not supported via Make"
rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs
@@ -154,7 +158,7 @@ haddockAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]
`catchIO` \_ ->
- rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]
+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]
buildAction :: BuildFlags -> [String] -> IO ()
buildAction flags args = do
@@ -172,7 +176,7 @@ sdistAction flags args = do
rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]
registerAction :: RegisterFlags -> [String] -> IO ()
-registerAction flags args = do
+registerAction flags args = do
noExtraFlags args
rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]
diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index e602a9a6ee3c9e2e9c378a276d1e2cda5d49dfa0..edb5d039f8775754ae55fe0d14d7401bef4c2422 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE LambdaCase #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.PackageDescription.Check
-- Copyright : Lennart Kolmodin 2008
@@ -21,86 +22,93 @@
-- reason for this is that we want to hold packages that are expected to be
-- distributed to a higher standard than packages that are only ever expected
-- to be used on the author's own environment.
-
-module Distribution.PackageDescription.Check (
- -- * Package Checking
- CheckExplanation(..),
- PackageCheck(..),
- checkPackage,
- checkConfiguredPackage,
- wrapParseWarning,
- ppPackageCheck,
- isHackageDistError,
-
- -- ** Checking package contents
- checkPackageFiles,
- checkPackageContent,
- CheckPackageContentOps(..),
- checkPackageFileNames,
+module Distribution.PackageDescription.Check
+ ( -- * Package Checking
+ CheckExplanation (..)
+ , PackageCheck (..)
+ , checkPackage
+ , checkConfiguredPackage
+ , wrapParseWarning
+ , ppPackageCheck
+ , isHackageDistError
+
+ -- ** Checking package contents
+ , checkPackageFiles
+ , checkPackageContent
+ , CheckPackageContentOps (..)
+ , checkPackageFileNames
) where
-import Data.Foldable (foldrM)
+import Data.Foldable (foldrM)
import Distribution.Compat.Prelude
import Prelude ()
-import Data.List (delete, group)
+import Data.List (delete, group)
import Distribution.CabalSpecVersion
import Distribution.Compat.Lens
import Distribution.Compiler
import Distribution.License
-import Distribution.ModuleName (ModuleName)
+import Distribution.ModuleName (ModuleName)
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
-import Distribution.Parsec.Warning (PWarning, showPWarning)
-import Distribution.Pretty (prettyShow)
-import Distribution.Simple.BuildPaths (autogenPackageInfoModuleName, autogenPathsModuleName)
+import Distribution.Parsec.Warning (PWarning, showPWarning)
+import Distribution.Pretty (prettyShow)
+import Distribution.Simple.BuildPaths (autogenPackageInfoModuleName, autogenPathsModuleName)
import Distribution.Simple.BuildToolDepends
import Distribution.Simple.CCompiler
import Distribution.Simple.Glob
-import Distribution.Simple.Utils hiding (findPackageDesc, notice)
+import Distribution.Simple.Utils hiding (findPackageDesc, notice)
import Distribution.System
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.PackageName.Magic
-import Distribution.Utils.Generic (isAscii)
+import Distribution.Utils.Generic (isAscii)
+import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
-import Distribution.Utils.Path
import Language.Haskell.Extension
import System.FilePath
- ( makeRelative, normalise, splitDirectories, splitExtension, splitPath
- , takeExtension, takeFileName, (<.>), (</>))
-
-import qualified Data.ByteString.Lazy as BS
-import qualified Data.Map as Map
+ ( makeRelative
+ , normalise
+ , splitDirectories
+ , splitExtension
+ , splitPath
+ , takeExtension
+ , takeFileName
+ , (<.>)
+ , (</>)
+ )
+
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.Map as Map
import qualified Distribution.Compat.DList as DList
-import qualified Distribution.SPDX as SPDX
-import qualified System.Directory as System
+import qualified Distribution.SPDX as SPDX
+import qualified System.Directory as System
-import qualified System.Directory (getDirectoryContents)
+import qualified System.Directory (getDirectoryContents)
import qualified System.FilePath.Windows as FilePath.Windows (isValid)
import qualified Data.Set as Set
import qualified Distribution.Utils.ShortText as ShortText
-import qualified Distribution.Types.BuildInfo.Lens as L
+import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
-import qualified Distribution.Types.PackageDescription.Lens as L
+import qualified Distribution.Types.PackageDescription.Lens as L
-- $setup
-- >>> import Control.Arrow ((&&&))
-- ------------------------------------------------------------
+
-- * Warning messages
+
-- ------------------------------------------------------------
-- | Which stanza does `CheckExplanation` refer to?
---
data CEType = CETLibrary | CETExecutable | CETTest | CETBenchmark
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show)
-- | Pretty printing `CEType`.
---
ppCE :: CEType -> String
ppCE CETLibrary = "library"
ppCE CETExecutable = "executable"
@@ -108,13 +116,15 @@ ppCE CETTest = "test suite"
ppCE CETBenchmark = "benchmark"
-- | Which field does `CheckExplanation` refer to?
---
-data CEField = CEFCategory | CEFMaintainer | CEFSynopsis
- | CEFDescription | CEFSynOrDesc
- deriving (Eq, Ord, Show)
+data CEField
+ = CEFCategory
+ | CEFMaintainer
+ | CEFSynopsis
+ | CEFDescription
+ | CEFSynOrDesc
+ deriving (Eq, Ord, Show)
-- | Pretty printing `CEField`.
---
ppCEField :: CEField -> String
ppCEField CEFCategory = "category"
ppCEField CEFMaintainer = "maintainer"
@@ -123,628 +133,745 @@ ppCEField CEFDescription = "description"
ppCEField CEFSynOrDesc = "synopsis' or 'description"
-- | Explanations of 'PackageCheck`'s errors/warnings.
---
-data CheckExplanation =
- ParseWarning FilePath PWarning
- | NoNameField
- | NoVersionField
- | NoTarget
- | UnnamedInternal
- | DuplicateSections [UnqualComponentName]
- | IllegalLibraryName PackageDescription
- | NoModulesExposed Library
- | SignaturesCabal2
- | AutogenNotExposed
- | AutogenIncludesNotIncluded
- | NoMainIs Executable
- | NoHsLhsMain
- | MainCCabal1_18
- | AutogenNoOther CEType UnqualComponentName
- | AutogenIncludesNotIncludedExe
- | TestsuiteTypeNotKnown TestType
- | TestsuiteNotSupported TestType
- | BenchmarkTypeNotKnown BenchmarkType
- | BenchmarkNotSupported BenchmarkType
- | NoHsLhsMainBench
- | InvalidNameWin PackageDescription
- | ZPrefix
- | NoBuildType
- | NoCustomSetup
- | UnknownCompilers [String]
- | UnknownLanguages [String]
- | UnknownExtensions [String]
- | LanguagesAsExtension [String]
- | DeprecatedExtensions [(Extension, Maybe Extension)]
- | MissingField CEField
- | SynopsisTooLong
- | ShortDesc
- | InvalidTestWith [Dependency]
- | ImpossibleInternalDep [Dependency]
- | ImpossibleInternalExe [ExeDependency]
- | MissingInternalExe [ExeDependency]
- | NONELicense
- | NoLicense
- | AllRightsReservedLicense
- | LicenseMessParse PackageDescription
- | UnrecognisedLicense String
- | UncommonBSD4
- | UnknownLicenseVersion License [Version]
- | NoLicenseFile
- | UnrecognisedSourceRepo String
- | MissingType
- | MissingLocation
- | MissingModule
- | MissingTag
- | SubdirRelPath
- | SubdirGoodRelPath String
- | OptFasm String
- | OptViaC String
- | OptHpc String
- | OptProf String
- | OptO String
- | OptHide String
- | OptMake String
- | OptONot String
- | OptOOne String
- | OptOTwo String
- | OptSplitSections String
- | OptSplitObjs String
- | OptWls String
- | OptExts String
- | OptRts String
- | OptWithRts String
- | COptONumber String String
- | COptCPP String
- | OptAlternatives String String [(String, String)]
- | RelativeOutside String FilePath
- | AbsolutePath String FilePath
- | BadRelativePAth String FilePath String
- | DistPoint (Maybe String) FilePath
- | GlobSyntaxError String String
- | RecursiveGlobInRoot String FilePath
- | InvalidOnWin [FilePath]
- | FilePathTooLong FilePath
- | FilePathNameTooLong FilePath
- | FilePathSplitTooLong FilePath
- | FilePathEmpty
- | CVTestSuite
- | CVDefaultLanguage
- | CVDefaultLanguageComponent
- | CVExtraDocFiles
- | CVMultiLib
- | CVReexported
- | CVMixins
- | CVExtraFrameworkDirs
- | CVDefaultExtensions
- | CVExtensionsDeprecated
- | CVSources
- | CVExtraDynamic [[String]]
- | CVVirtualModules
- | CVSourceRepository
- | CVExtensions CabalSpecVersion [Extension]
- | CVCustomSetup
- | CVExpliticDepsCustomSetup
- | CVAutogenPaths
- | CVAutogenPackageInfo
- | GlobNoMatch String String
- | GlobExactMatch String String FilePath
- | GlobNoDir String String FilePath
- | UnknownOS [String]
- | UnknownArch [String]
- | UnknownCompiler [String]
- | BaseNoUpperBounds
- | MissingUpperBounds [PackageName]
- | SuspiciousFlagName [String]
- | DeclaredUsedFlags (Set FlagName) (Set FlagName)
- | NonASCIICustomField [String]
- | RebindableClashPaths
- | RebindableClashPackageInfo
- | WErrorUnneeded String
- | JUnneeded String
- | FDeferTypeErrorsUnneeded String
- | DynamicUnneeded String
- | ProfilingUnneeded String
- | UpperBoundSetup String
- | DuplicateModule String [ModuleName]
- | PotentialDupModule String [ModuleName]
- | BOMStart FilePath
- | NotPackageName FilePath String
- | NoDesc
- | MultiDesc [String]
- | UnknownFile String (SymbolicPath PackageDir LicenseFile)
- | MissingSetupFile
- | MissingConfigureScript
- | UnknownDirectory String FilePath
- | MissingSourceControl
- | MissingExpectedDocFiles Bool [FilePath]
- | WrongFieldForExpectedDocFiles Bool String [FilePath]
- deriving (Eq, Ord, Show)
+data CheckExplanation
+ = ParseWarning FilePath PWarning
+ | NoNameField
+ | NoVersionField
+ | NoTarget
+ | UnnamedInternal
+ | DuplicateSections [UnqualComponentName]
+ | IllegalLibraryName PackageDescription
+ | NoModulesExposed Library
+ | SignaturesCabal2
+ | AutogenNotExposed
+ | AutogenIncludesNotIncluded
+ | NoMainIs Executable
+ | NoHsLhsMain
+ | MainCCabal1_18
+ | AutogenNoOther CEType UnqualComponentName
+ | AutogenIncludesNotIncludedExe
+ | TestsuiteTypeNotKnown TestType
+ | TestsuiteNotSupported TestType
+ | BenchmarkTypeNotKnown BenchmarkType
+ | BenchmarkNotSupported BenchmarkType
+ | NoHsLhsMainBench
+ | InvalidNameWin PackageDescription
+ | ZPrefix
+ | NoBuildType
+ | NoCustomSetup
+ | UnknownCompilers [String]
+ | UnknownLanguages [String]
+ | UnknownExtensions [String]
+ | LanguagesAsExtension [String]
+ | DeprecatedExtensions [(Extension, Maybe Extension)]
+ | MissingField CEField
+ | SynopsisTooLong
+ | ShortDesc
+ | InvalidTestWith [Dependency]
+ | ImpossibleInternalDep [Dependency]
+ | ImpossibleInternalExe [ExeDependency]
+ | MissingInternalExe [ExeDependency]
+ | NONELicense
+ | NoLicense
+ | AllRightsReservedLicense
+ | LicenseMessParse PackageDescription
+ | UnrecognisedLicense String
+ | UncommonBSD4
+ | UnknownLicenseVersion License [Version]
+ | NoLicenseFile
+ | UnrecognisedSourceRepo String
+ | MissingType
+ | MissingLocation
+ | MissingModule
+ | MissingTag
+ | SubdirRelPath
+ | SubdirGoodRelPath String
+ | OptFasm String
+ | OptViaC String
+ | OptHpc String
+ | OptProf String
+ | OptO String
+ | OptHide String
+ | OptMake String
+ | OptONot String
+ | OptOOne String
+ | OptOTwo String
+ | OptSplitSections String
+ | OptSplitObjs String
+ | OptWls String
+ | OptExts String
+ | OptRts String
+ | OptWithRts String
+ | COptONumber String String
+ | COptCPP String
+ | OptAlternatives String String [(String, String)]
+ | RelativeOutside String FilePath
+ | AbsolutePath String FilePath
+ | BadRelativePAth String FilePath String
+ | DistPoint (Maybe String) FilePath
+ | GlobSyntaxError String String
+ | RecursiveGlobInRoot String FilePath
+ | InvalidOnWin [FilePath]
+ | FilePathTooLong FilePath
+ | FilePathNameTooLong FilePath
+ | FilePathSplitTooLong FilePath
+ | FilePathEmpty
+ | CVTestSuite
+ | CVDefaultLanguage
+ | CVDefaultLanguageComponent
+ | CVExtraDocFiles
+ | CVMultiLib
+ | CVReexported
+ | CVMixins
+ | CVExtraFrameworkDirs
+ | CVDefaultExtensions
+ | CVExtensionsDeprecated
+ | CVSources
+ | CVExtraDynamic [[String]]
+ | CVVirtualModules
+ | CVSourceRepository
+ | CVExtensions CabalSpecVersion [Extension]
+ | CVCustomSetup
+ | CVExpliticDepsCustomSetup
+ | CVAutogenPaths
+ | CVAutogenPackageInfo
+ | GlobNoMatch String String
+ | GlobExactMatch String String FilePath
+ | GlobNoDir String String FilePath
+ | UnknownOS [String]
+ | UnknownArch [String]
+ | UnknownCompiler [String]
+ | BaseNoUpperBounds
+ | MissingUpperBounds [PackageName]
+ | SuspiciousFlagName [String]
+ | DeclaredUsedFlags (Set FlagName) (Set FlagName)
+ | NonASCIICustomField [String]
+ | RebindableClashPaths
+ | RebindableClashPackageInfo
+ | WErrorUnneeded String
+ | JUnneeded String
+ | FDeferTypeErrorsUnneeded String
+ | DynamicUnneeded String
+ | ProfilingUnneeded String
+ | UpperBoundSetup String
+ | DuplicateModule String [ModuleName]
+ | PotentialDupModule String [ModuleName]
+ | BOMStart FilePath
+ | NotPackageName FilePath String
+ | NoDesc
+ | MultiDesc [String]
+ | UnknownFile String (SymbolicPath PackageDir LicenseFile)
+ | MissingSetupFile
+ | MissingConfigureScript
+ | UnknownDirectory String FilePath
+ | MissingSourceControl
+ | MissingExpectedDocFiles Bool [FilePath]
+ | WrongFieldForExpectedDocFiles Bool String [FilePath]
+ deriving (Eq, Ord, Show)
-- | Wraps `ParseWarning` into `PackageCheck`.
---
wrapParseWarning :: FilePath -> PWarning -> PackageCheck
wrapParseWarning fp pw = PackageDistSuspicious (ParseWarning fp pw)
- -- TODO: as Jul 2022 there is no severity indication attached PWarnType.
- -- Once that is added, we can output something more appropriate
- -- than PackageDistSuspicious for every parse warning.
- -- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs)
+
+-- TODO: as Jul 2022 there is no severity indication attached PWarnType.
+-- Once that is added, we can output something more appropriate
+-- than PackageDistSuspicious for every parse warning.
+-- (see: Cabal-syntax/src/Distribution/Parsec/Warning.hs)
-- | Pretty printing `CheckExplanation`.
---
ppExplanation :: CheckExplanation -> String
ppExplanation (ParseWarning fp pp) = showPWarning fp pp
ppExplanation NoNameField = "No 'name' field."
ppExplanation NoVersionField = "No 'version' field."
ppExplanation NoTarget =
- "No executables, libraries, tests, or benchmarks found. Nothing to do."
+ "No executables, libraries, tests, or benchmarks found. Nothing to do."
ppExplanation UnnamedInternal =
- "Found one or more unnamed internal libraries. Only the non-internal"
- ++ " library can have the same name as the package."
+ "Found one or more unnamed internal libraries. Only the non-internal"
+ ++ " library can have the same name as the package."
ppExplanation (DuplicateSections duplicateNames) =
- "Duplicate sections: "
- ++ commaSep (map unUnqualComponentName duplicateNames)
- ++ ". The name of every library, executable, test suite,"
- ++ " and benchmark section in the package must be unique."
+ "Duplicate sections: "
+ ++ commaSep (map unUnqualComponentName duplicateNames)
+ ++ ". The name of every library, executable, test suite,"
+ ++ " and benchmark section in the package must be unique."
ppExplanation (IllegalLibraryName pkg) =
- "Illegal internal library name "
- ++ prettyShow (packageName pkg)
- ++ ". Internal libraries cannot have the same name as the package."
- ++ " Maybe you wanted a non-internal library?"
- ++ " If so, rewrite the section stanza"
- ++ " from 'library: '" ++ prettyShow (packageName pkg)
- ++ "' to 'library'."
+ "Illegal internal library name "
+ ++ prettyShow (packageName pkg)
+ ++ ". Internal libraries cannot have the same name as the package."
+ ++ " Maybe you wanted a non-internal library?"
+ ++ " If so, rewrite the section stanza"
+ ++ " from 'library: '"
+ ++ prettyShow (packageName pkg)
+ ++ "' to 'library'."
ppExplanation (NoModulesExposed lib) =
- showLibraryName (libName lib) ++ " does not expose any modules"
+ showLibraryName (libName lib) ++ " does not expose any modules"
ppExplanation SignaturesCabal2 =
- "To use the 'signatures' field the package needs to specify "
- ++ "at least 'cabal-version: 2.0'."
+ "To use the 'signatures' field the package needs to specify "
+ ++ "at least 'cabal-version: 2.0'."
ppExplanation AutogenNotExposed =
- "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'."
+ "An 'autogen-module' is neither on 'exposed-modules' or 'other-modules'."
ppExplanation AutogenIncludesNotIncluded =
- "An include in 'autogen-includes' is neither in 'includes' or "
- ++ "'install-includes'."
+ "An include in 'autogen-includes' is neither in 'includes' or "
+ ++ "'install-includes'."
ppExplanation (NoMainIs exe) =
- "No 'main-is' field found for executable " ++ prettyShow (exeName exe)
+ "No 'main-is' field found for executable " ++ prettyShow (exeName exe)
ppExplanation NoHsLhsMain =
- "The 'main-is' field must specify a '.hs' or '.lhs' file "
- ++ "(even if it is generated by a preprocessor), "
- ++ "or it may specify a C/C++/obj-C source file."
+ "The 'main-is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor), "
+ ++ "or it may specify a C/C++/obj-C source file."
ppExplanation MainCCabal1_18 =
- "The package uses a C/C++/obj-C source file for the 'main-is' field. "
- ++ "To use this feature you need to specify 'cabal-version: 1.18' or"
- ++ " higher."
+ "The package uses a C/C++/obj-C source file for the 'main-is' field. "
+ ++ "To use this feature you need to specify 'cabal-version: 1.18' or"
+ ++ " higher."
ppExplanation (AutogenNoOther ct ucn) =
- "On " ++ ppCE ct ++ " '" ++ prettyShow ucn ++ "' an 'autogen-module'"
- ++ " is not on 'other-modules'"
+ "On "
+ ++ ppCE ct
+ ++ " '"
+ ++ prettyShow ucn
+ ++ "' an 'autogen-module'"
+ ++ " is not on 'other-modules'"
ppExplanation AutogenIncludesNotIncludedExe =
- "An include in 'autogen-includes' is not in 'includes'."
+ "An include in 'autogen-includes' is not in 'includes'."
ppExplanation (TestsuiteTypeNotKnown tt) =
- quote (prettyShow tt) ++ " is not a known type of test suite. "
- ++ "Either remove the 'type' field or use a known type. "
- ++ "The known test suite types are: "
- ++ commaSep (map prettyShow knownTestTypes)
+ quote (prettyShow tt)
+ ++ " is not a known type of test suite. "
+ ++ "Either remove the 'type' field or use a known type. "
+ ++ "The known test suite types are: "
+ ++ commaSep (map prettyShow knownTestTypes)
ppExplanation (TestsuiteNotSupported tt) =
- quote (prettyShow tt) ++ " is not a supported test suite version. "
- ++ "Either remove the 'type' field or use a known type. "
- ++ "The known test suite types are: "
- ++ commaSep (map prettyShow knownTestTypes)
+ quote (prettyShow tt)
+ ++ " is not a supported test suite version. "
+ ++ "Either remove the 'type' field or use a known type. "
+ ++ "The known test suite types are: "
+ ++ commaSep (map prettyShow knownTestTypes)
ppExplanation (BenchmarkTypeNotKnown tt) =
- quote (prettyShow tt) ++ " is not a known type of benchmark. "
- ++ "Either remove the 'type' field or use a known type. "
- ++ "The known benchmark types are: "
- ++ commaSep (map prettyShow knownBenchmarkTypes)
+ quote (prettyShow tt)
+ ++ " is not a known type of benchmark. "
+ ++ "Either remove the 'type' field or use a known type. "
+ ++ "The known benchmark types are: "
+ ++ commaSep (map prettyShow knownBenchmarkTypes)
ppExplanation (BenchmarkNotSupported tt) =
- quote (prettyShow tt) ++ " is not a supported benchmark version. "
- ++ "Either remove the 'type' field or use a known type. "
- ++ "The known benchmark types are: "
- ++ commaSep (map prettyShow knownBenchmarkTypes)
+ quote (prettyShow tt)
+ ++ " is not a supported benchmark version. "
+ ++ "Either remove the 'type' field or use a known type. "
+ ++ "The known benchmark types are: "
+ ++ commaSep (map prettyShow knownBenchmarkTypes)
ppExplanation NoHsLhsMainBench =
- "The 'main-is' field must specify a '.hs' or '.lhs' file "
- ++ "(even if it is generated by a preprocessor)."
+ "The 'main-is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor)."
ppExplanation (InvalidNameWin pkg) =
- "The package name '" ++ prettyShow (packageName pkg) ++ "' is "
- ++ "invalid on Windows. Many tools need to convert package names to "
- ++ "file names so using this name would cause problems."
+ "The package name '"
+ ++ prettyShow (packageName pkg)
+ ++ "' is "
+ ++ "invalid on Windows. Many tools need to convert package names to "
+ ++ "file names so using this name would cause problems."
ppExplanation ZPrefix =
- "Package names with the prefix 'z-' are reserved by Cabal and "
- ++ "cannot be used."
+ "Package names with the prefix 'z-' are reserved by Cabal and "
+ ++ "cannot be used."
ppExplanation NoBuildType =
- "No 'build-type' specified. If you do not need a custom Setup.hs or "
- ++ "./configure script then use 'build-type: Simple'."
+ "No 'build-type' specified. If you do not need a custom Setup.hs or "
+ ++ "./configure script then use 'build-type: Simple'."
ppExplanation NoCustomSetup =
- "Ignoring the 'custom-setup' section because the 'build-type' is "
- ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "
- ++ "custom Setup.hs script."
+ "Ignoring the 'custom-setup' section because the 'build-type' is "
+ ++ "not 'Custom'. Use 'build-type: Custom' if you need to use a "
+ ++ "custom Setup.hs script."
ppExplanation (UnknownCompilers unknownCompilers) =
- "Unknown compiler " ++ commaSep (map quote unknownCompilers)
- ++ " in 'tested-with' field."
+ "Unknown compiler "
+ ++ commaSep (map quote unknownCompilers)
+ ++ " in 'tested-with' field."
ppExplanation (UnknownLanguages unknownLanguages) =
- "Unknown languages: " ++ commaSep unknownLanguages
+ "Unknown languages: " ++ commaSep unknownLanguages
ppExplanation (UnknownExtensions unknownExtensions) =
- "Unknown extensions: " ++ commaSep unknownExtensions
+ "Unknown extensions: " ++ commaSep unknownExtensions
ppExplanation (LanguagesAsExtension languagesUsedAsExtensions) =
- "Languages listed as extensions: "
- ++ commaSep languagesUsedAsExtensions
- ++ ". Languages must be specified in either the 'default-language' "
- ++ " or the 'other-languages' field."
+ "Languages listed as extensions: "
+ ++ commaSep languagesUsedAsExtensions
+ ++ ". Languages must be specified in either the 'default-language' "
+ ++ " or the 'other-languages' field."
ppExplanation (DeprecatedExtensions ourDeprecatedExtensions) =
- "Deprecated extensions: "
- ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions)
- ++ ". " ++ unwords
- [ "Instead of '" ++ prettyShow ext
- ++ "' use '" ++ prettyShow replacement ++ "'."
- | (ext, Just replacement) <- ourDeprecatedExtensions ]
+ "Deprecated extensions: "
+ ++ commaSep (map (quote . prettyShow . fst) ourDeprecatedExtensions)
+ ++ ". "
+ ++ unwords
+ [ "Instead of '"
+ ++ prettyShow ext
+ ++ "' use '"
+ ++ prettyShow replacement
+ ++ "'."
+ | (ext, Just replacement) <- ourDeprecatedExtensions
+ ]
ppExplanation (MissingField cef) =
- "No '" ++ ppCEField cef ++ "' field."
+ "No '" ++ ppCEField cef ++ "' field."
ppExplanation SynopsisTooLong =
- "The 'synopsis' field is rather long (max 80 chars is recommended)."
+ "The 'synopsis' field is rather long (max 80 chars is recommended)."
ppExplanation ShortDesc =
- "The 'description' field should be longer than the 'synopsis' field. "
- ++ "It's useful to provide an informative 'description' to allow "
- ++ "Haskell programmers who have never heard about your package to "
- ++ "understand the purpose of your package. "
- ++ "The 'description' field content is typically shown by tooling "
- ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which "
- ++ "serves as a headline. "
- ++ "Please refer to <https://cabal.readthedocs.io/en/stable/"
- ++ "cabal-package.html#package-properties> for more details."
+ "The 'description' field should be longer than the 'synopsis' field. "
+ ++ "It's useful to provide an informative 'description' to allow "
+ ++ "Haskell programmers who have never heard about your package to "
+ ++ "understand the purpose of your package. "
+ ++ "The 'description' field content is typically shown by tooling "
+ ++ "(e.g. 'cabal info', Haddock, Hackage) below the 'synopsis' which "
+ ++ "serves as a headline. "
+ ++ "Please refer to <https://cabal.readthedocs.io/en/stable/"
+ ++ "cabal-package.html#package-properties> for more details."
ppExplanation (InvalidTestWith testedWithImpossibleRanges) =
- "Invalid 'tested-with' version range: "
- ++ commaSep (map prettyShow testedWithImpossibleRanges)
- ++ ". To indicate that you have tested a package with multiple "
- ++ "different versions of the same compiler use multiple entries, "
- ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "
- ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."
+ "Invalid 'tested-with' version range: "
+ ++ commaSep (map prettyShow testedWithImpossibleRanges)
+ ++ ". To indicate that you have tested a package with multiple "
+ ++ "different versions of the same compiler use multiple entries, "
+ ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "
+ ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."
ppExplanation (ImpossibleInternalDep depInternalLibWithImpossibleVersion) =
- "The package has an impossible version range for a dependency on an "
- ++ "internal library: "
- ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion)
- ++ ". This version range does not include the current package, and must "
- ++ "be removed as the current package's library will always be used."
+ "The package has an impossible version range for a dependency on an "
+ ++ "internal library: "
+ ++ commaSep (map prettyShow depInternalLibWithImpossibleVersion)
+ ++ ". This version range does not include the current package, and must "
+ ++ "be removed as the current package's library will always be used."
ppExplanation (ImpossibleInternalExe depInternalExecWithImpossibleVersion) =
- "The package has an impossible version range for a dependency on an "
- ++ "internal executable: "
- ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion)
- ++ ". This version range does not include the current package, and must "
- ++ "be removed as the current package's executable will always be used."
+ "The package has an impossible version range for a dependency on an "
+ ++ "internal executable: "
+ ++ commaSep (map prettyShow depInternalExecWithImpossibleVersion)
+ ++ ". This version range does not include the current package, and must "
+ ++ "be removed as the current package's executable will always be used."
ppExplanation (MissingInternalExe depInternalExeWithImpossibleVersion) =
- "The package depends on a missing internal executable: "
- ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion)
+ "The package depends on a missing internal executable: "
+ ++ commaSep (map prettyShow depInternalExeWithImpossibleVersion)
ppExplanation NONELicense = "The 'license' field is missing or is NONE."
ppExplanation NoLicense = "The 'license' field is missing."
ppExplanation AllRightsReservedLicense =
- "The 'license' is AllRightsReserved. Is that really what you want?"
+ "The 'license' is AllRightsReserved. Is that really what you want?"
ppExplanation (LicenseMessParse pkg) =
- "Unfortunately the license " ++ quote (prettyShow (license pkg))
- ++ " messes up the parser in earlier Cabal versions so you need to "
- ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
- ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."
+ "Unfortunately the license "
+ ++ quote (prettyShow (license pkg))
+ ++ " messes up the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
+ ++ "compatibility with earlier Cabal versions then use 'OtherLicense'."
ppExplanation (UnrecognisedLicense l) =
- quote ("license: " ++ l) ++ " is not a recognised license. The "
- ++ "known licenses are: " ++ commaSep (map prettyShow knownLicenses)
+ quote ("license: " ++ l)
+ ++ " is not a recognised license. The "
+ ++ "known licenses are: "
+ ++ commaSep (map prettyShow knownLicenses)
ppExplanation UncommonBSD4 =
- "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "
- ++ "refers to the old 4-clause BSD license with the advertising "
- ++ "clause. 'BSD3' refers the new 3-clause BSD license."
+ "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "
+ ++ "refers to the old 4-clause BSD license with the advertising "
+ ++ "clause. 'BSD3' refers the new 3-clause BSD license."
ppExplanation (UnknownLicenseVersion lic known) =
- "'license: " ++ prettyShow lic ++ "' is not a known "
- ++ "version of that license. The known versions are "
- ++ commaSep (map prettyShow known)
- ++ ". If this is not a mistake and you think it should be a known "
- ++ "version then please file a ticket."
+ "'license: "
+ ++ prettyShow lic
+ ++ "' is not a known "
+ ++ "version of that license. The known versions are "
+ ++ commaSep (map prettyShow known)
+ ++ ". If this is not a mistake and you think it should be a known "
+ ++ "version then please file a ticket."
ppExplanation NoLicenseFile = "A 'license-file' is not specified."
ppExplanation (UnrecognisedSourceRepo kind) =
- quote kind ++ " is not a recognised kind of source-repository. "
- ++ "The repo kind is usually 'head' or 'this'"
+ quote kind
+ ++ " is not a recognised kind of source-repository. "
+ ++ "The repo kind is usually 'head' or 'this'"
ppExplanation MissingType =
- "The source-repository 'type' is a required field."
+ "The source-repository 'type' is a required field."
ppExplanation MissingLocation =
- "The source-repository 'location' is a required field."
+ "The source-repository 'location' is a required field."
ppExplanation MissingModule =
- "For a CVS source-repository, the 'module' is a required field."
+ "For a CVS source-repository, the 'module' is a required field."
ppExplanation MissingTag =
- "For the 'this' kind of source-repository, the 'tag' is a required "
- ++ "field. It should specify the tag corresponding to this version "
- ++ "or release of the package."
+ "For the 'this' kind of source-repository, the 'tag' is a required "
+ ++ "field. It should specify the tag corresponding to this version "
+ ++ "or release of the package."
ppExplanation SubdirRelPath =
- "The 'subdir' field of a source-repository must be a relative path."
+ "The 'subdir' field of a source-repository must be a relative path."
ppExplanation (SubdirGoodRelPath err) =
- "The 'subdir' field of a source-repository is not a good relative path: "
- ++ show err
+ "The 'subdir' field of a source-repository is not a good relative path: "
+ ++ show err
ppExplanation (OptFasm fieldName) =
- "'" ++ fieldName ++ ": -fasm' is unnecessary and will not work on CPU "
- ++ "architectures other than x86, x86-64, ppc or sparc."
+ "'"
+ ++ fieldName
+ ++ ": -fasm' is unnecessary and will not work on CPU "
+ ++ "architectures other than x86, x86-64, ppc or sparc."
ppExplanation (OptViaC fieldName) =
- "'" ++ fieldName ++": -fvia-C' is usually unnecessary. If your package "
- ++ "needs -via-C for correctness rather than performance then it "
- ++ "is using the FFI incorrectly and will probably not work with GHC "
- ++ "6.10 or later."
+ "'"
+ ++ fieldName
+ ++ ": -fvia-C' is usually unnecessary. If your package "
+ ++ "needs -via-C for correctness rather than performance then it "
+ ++ "is using the FFI incorrectly and will probably not work with GHC "
+ ++ "6.10 or later."
ppExplanation (OptHpc fieldName) =
- "'" ++ fieldName ++ ": -fhpc' is not necessary. Use the configure flag "
- ++ " --enable-coverage instead."
+ "'"
+ ++ fieldName
+ ++ ": -fhpc' is not necessary. Use the configure flag "
+ ++ " --enable-coverage instead."
ppExplanation (OptProf fieldName) =
- "'" ++ fieldName ++ ": -prof' is not necessary and will lead to problems "
- ++ "when used on a library. Use the configure flag "
- ++ "--enable-library-profiling and/or --enable-profiling."
+ "'"
+ ++ fieldName
+ ++ ": -prof' is not necessary and will lead to problems "
+ ++ "when used on a library. Use the configure flag "
+ ++ "--enable-library-profiling and/or --enable-profiling."
ppExplanation (OptO fieldName) =
- "'" ++ fieldName ++ ": -o' is not needed. "
- ++ "The output files are named automatically."
+ "'"
+ ++ fieldName
+ ++ ": -o' is not needed. "
+ ++ "The output files are named automatically."
ppExplanation (OptHide fieldName) =
- "'" ++ fieldName ++ ": -hide-package' is never needed. "
- ++ "Cabal hides all packages."
+ "'"
+ ++ fieldName
+ ++ ": -hide-package' is never needed. "
+ ++ "Cabal hides all packages."
ppExplanation (OptMake fieldName) =
- "'" ++ fieldName
- ++ ": --make' is never needed. Cabal uses this automatically."
+ "'"
+ ++ fieldName
+ ++ ": --make' is never needed. Cabal uses this automatically."
ppExplanation (OptONot fieldName) =
- "'" ++ fieldName ++ ": -O0' is not needed. "
- ++ "Use the --disable-optimization configure flag."
+ "'"
+ ++ fieldName
+ ++ ": -O0' is not needed. "
+ ++ "Use the --disable-optimization configure flag."
ppExplanation (OptOOne fieldName) =
- "'" ++ fieldName ++ ": -O' is not needed. "
- ++ "Cabal automatically adds the '-O' flag. "
- ++ "Setting it yourself interferes with the --disable-optimization flag."
+ "'"
+ ++ fieldName
+ ++ ": -O' is not needed. "
+ ++ "Cabal automatically adds the '-O' flag. "
+ ++ "Setting it yourself interferes with the --disable-optimization flag."
ppExplanation (OptOTwo fieldName) =
- "'" ++ fieldName ++ ": -O2' is rarely needed. "
- ++ "Check that it is giving a real benefit "
- ++ "and not just imposing longer compile times on your users."
+ "'"
+ ++ fieldName
+ ++ ": -O2' is rarely needed. "
+ ++ "Check that it is giving a real benefit "
+ ++ "and not just imposing longer compile times on your users."
ppExplanation (OptSplitSections fieldName) =
- "'" ++ fieldName ++ ": -split-sections' is not needed. "
- ++ "Use the --enable-split-sections configure flag."
+ "'"
+ ++ fieldName
+ ++ ": -split-sections' is not needed. "
+ ++ "Use the --enable-split-sections configure flag."
ppExplanation (OptSplitObjs fieldName) =
- "'" ++ fieldName ++ ": -split-objs' is not needed. "
- ++ "Use the --enable-split-objs configure flag."
+ "'"
+ ++ fieldName
+ ++ ": -split-objs' is not needed. "
+ ++ "Use the --enable-split-objs configure flag."
ppExplanation (OptWls fieldName) =
- "'" ++ fieldName ++ ": -optl-Wl,-s' is not needed and is not portable to"
- ++ " all operating systems. Cabal 1.4 and later automatically strip"
- ++ " executables. Cabal also has a flag --disable-executable-stripping"
- ++ " which is necessary when building packages for some Linux"
- ++ " distributions and using '-optl-Wl,-s' prevents that from working."
+ "'"
+ ++ fieldName
+ ++ ": -optl-Wl,-s' is not needed and is not portable to"
+ ++ " all operating systems. Cabal 1.4 and later automatically strip"
+ ++ " executables. Cabal also has a flag --disable-executable-stripping"
+ ++ " which is necessary when building packages for some Linux"
+ ++ " distributions and using '-optl-Wl,-s' prevents that from working."
ppExplanation (OptExts fieldName) =
- "Instead of '" ++ fieldName ++ ": -fglasgow-exts' it is preferable to use "
- ++ "the 'extensions' field."
+ "Instead of '"
+ ++ fieldName
+ ++ ": -fglasgow-exts' it is preferable to use "
+ ++ "the 'extensions' field."
ppExplanation (OptRts fieldName) =
- "'" ++ fieldName ++ ": -rtsopts' has no effect for libraries. It should "
- ++ "only be used for executables."
+ "'"
+ ++ fieldName
+ ++ ": -rtsopts' has no effect for libraries. It should "
+ ++ "only be used for executables."
ppExplanation (OptWithRts fieldName) =
- "'" ++ fieldName ++ ": -with-rtsopts' has no effect for libraries. It "
- ++ "should only be used for executables."
+ "'"
+ ++ fieldName
+ ++ ": -with-rtsopts' has no effect for libraries. It "
+ ++ "should only be used for executables."
ppExplanation (COptONumber prefix label) =
- "'" ++ prefix ++": -O[n]' is generally not needed. When building with "
- ++ " optimisations Cabal automatically adds '-O2' for " ++ label
- ++ " code. Setting it yourself interferes with the"
- ++ " --disable-optimization flag."
+ "'"
+ ++ prefix
+ ++ ": -O[n]' is generally not needed. When building with "
+ ++ " optimisations Cabal automatically adds '-O2' for "
+ ++ label
+ ++ " code. Setting it yourself interferes with the"
+ ++ " --disable-optimization flag."
ppExplanation (COptCPP opt) =
- "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag."
+ "'cpp-options: " ++ opt ++ "' is not a portable C-preprocessor flag."
ppExplanation (OptAlternatives badField goodField flags) =
- "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)
- ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)
- where (badFlags, goodFlags) = unzip flags
+ "Instead of "
+ ++ quote (badField ++ ": " ++ unwords badFlags)
+ ++ " use "
+ ++ quote (goodField ++ ": " ++ unwords goodFlags)
+ where
+ (badFlags, goodFlags) = unzip flags
ppExplanation (RelativeOutside field path) =
- quote (field ++ ": " ++ path)
- ++ " is a relative path outside of the source tree. "
- ++ "This will not work when generating a tarball with 'sdist'."
+ quote (field ++ ": " ++ path)
+ ++ " is a relative path outside of the source tree. "
+ ++ "This will not work when generating a tarball with 'sdist'."
ppExplanation (AbsolutePath field path) =
- quote (field ++ ": " ++ path) ++ " specifies an absolute path, but the "
- ++ quote field ++ " field must use relative paths."
+ quote (field ++ ": " ++ path)
+ ++ " specifies an absolute path, but the "
+ ++ quote field
+ ++ " field must use relative paths."
ppExplanation (BadRelativePAth field path err) =
- quote (field ++ ": " ++ path)
- ++ " is not a good relative path: " ++ show err
+ quote (field ++ ": " ++ path)
+ ++ " is not a good relative path: "
+ ++ show err
ppExplanation (DistPoint mfield path) =
- incipit ++ " points inside the 'dist' "
- ++ "directory. This is not reliable because the location of this "
- ++ "directory is configurable by the user (or package manager). In "
- ++ "addition the layout of the 'dist' directory is subject to change "
- ++ "in future versions of Cabal."
- where -- mfiled Nothing -> the path is inside `ghc-options`
- incipit = maybe ("'ghc-options' path " ++ quote path)
- (\field -> quote (field ++ ": " ++ path))
- mfield
+ incipit
+ ++ " points inside the 'dist' "
+ ++ "directory. This is not reliable because the location of this "
+ ++ "directory is configurable by the user (or package manager). In "
+ ++ "addition the layout of the 'dist' directory is subject to change "
+ ++ "in future versions of Cabal."
+ where
+ -- mfiled Nothing -> the path is inside `ghc-options`
+ incipit =
+ maybe
+ ("'ghc-options' path " ++ quote path)
+ (\field -> quote (field ++ ": " ++ path))
+ mfield
ppExplanation (GlobSyntaxError field expl) =
- "In the '" ++ field ++ "' field: " ++ expl
+ "In the '" ++ field ++ "' field: " ++ expl
ppExplanation (RecursiveGlobInRoot field glob) =
- "In the '" ++ field ++ "': glob '" ++ glob
+ "In the '"
+ ++ field
+ ++ "': glob '"
+ ++ glob
++ "' starts at project root directory, this might "
++ "include `.git/`, ``dist-newstyle/``, or other large directories!"
ppExplanation (InvalidOnWin paths) =
- "The " ++ quotes paths ++ " invalid on Windows, which "
- ++ "would cause portability problems for this package. Windows file "
- ++ "names cannot contain any of the characters \":*?<>|\" and there "
- ++ "a few reserved names including \"aux\", \"nul\", \"con\", "
- ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."
- where quotes [failed] = "path " ++ quote failed ++ " is"
- quotes failed = "paths " ++ intercalate ", " (map quote failed)
- ++ " are"
+ "The "
+ ++ quotes paths
+ ++ " invalid on Windows, which "
+ ++ "would cause portability problems for this package. Windows file "
+ ++ "names cannot contain any of the characters \":*?<>|\" and there "
+ ++ "a few reserved names including \"aux\", \"nul\", \"con\", "
+ ++ "\"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."
+ where
+ quotes [failed] = "path " ++ quote failed ++ " is"
+ quotes failed =
+ "paths "
+ ++ intercalate ", " (map quote failed)
+ ++ " are"
ppExplanation (FilePathTooLong path) =
- "The following file name is too long to store in a portable POSIX "
- ++ "format tar archive. The maximum length is 255 ASCII characters.\n"
- ++ "The file in question is:\n " ++ path
+ "The following file name is too long to store in a portable POSIX "
+ ++ "format tar archive. The maximum length is 255 ASCII characters.\n"
+ ++ "The file in question is:\n "
+ ++ path
ppExplanation (FilePathNameTooLong path) =
- "The following file name is too long to store in a portable POSIX "
- ++ "format tar archive. The maximum length for the name part (including "
- ++ "extension) is 100 ASCII characters. The maximum length for any "
- ++ "individual directory component is 155.\n"
- ++ "The file in question is:\n " ++ path
+ "The following file name is too long to store in a portable POSIX "
+ ++ "format tar archive. The maximum length for the name part (including "
+ ++ "extension) is 100 ASCII characters. The maximum length for any "
+ ++ "individual directory component is 155.\n"
+ ++ "The file in question is:\n "
+ ++ path
ppExplanation (FilePathSplitTooLong path) =
- "The following file name is too long to store in a portable POSIX "
- ++ "format tar archive. While the total length is less than 255 ASCII "
- ++ "characters, there are unfortunately further restrictions. It has to "
- ++ "be possible to split the file path on a directory separator into "
- ++ "two parts such that the first part fits in 155 characters or less "
- ++ "and the second part fits in 100 characters or less. Basically you "
- ++ "have to make the file name or directory names shorter, or you could "
- ++ "split a long directory name into nested subdirectories with shorter "
- ++ "names.\nThe file in question is:\n " ++ path
+ "The following file name is too long to store in a portable POSIX "
+ ++ "format tar archive. While the total length is less than 255 ASCII "
+ ++ "characters, there are unfortunately further restrictions. It has to "
+ ++ "be possible to split the file path on a directory separator into "
+ ++ "two parts such that the first part fits in 155 characters or less "
+ ++ "and the second part fits in 100 characters or less. Basically you "
+ ++ "have to make the file name or directory names shorter, or you could "
+ ++ "split a long directory name into nested subdirectories with shorter "
+ ++ "names.\nThe file in question is:\n "
+ ++ path
ppExplanation FilePathEmpty =
- "Encountered a file with an empty name, something is very wrong! "
- ++ "Files with an empty name cannot be stored in a tar archive or in "
- ++ "standard file systems."
+ "Encountered a file with an empty name, something is very wrong! "
+ ++ "Files with an empty name cannot be stored in a tar archive or in "
+ ++ "standard file systems."
ppExplanation CVTestSuite =
- "The 'test-suite' section is new in Cabal 1.10. "
- ++ "Unfortunately it messes up the parser in older Cabal versions "
- ++ "so you must specify at least 'cabal-version: >= 1.8', but note "
- ++ "that only Cabal 1.10 and later can actually run such test suites."
+ "The 'test-suite' section is new in Cabal 1.10. "
+ ++ "Unfortunately it messes up the parser in older Cabal versions "
+ ++ "so you must specify at least 'cabal-version: >= 1.8', but note "
+ ++ "that only Cabal 1.10 and later can actually run such test suites."
ppExplanation CVDefaultLanguage =
- "To use the 'default-language' field the package needs to specify "
- ++ "at least 'cabal-version: >= 1.10'."
+ "To use the 'default-language' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.10'."
ppExplanation CVDefaultLanguageComponent =
- "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' "
- ++ "must specify the 'default-language' field for each component (e.g. "
- ++ "Haskell98 or Haskell2010). If a component uses different languages "
- ++ "in different modules then list the other ones in the "
- ++ "'other-languages' field."
+ "Packages using 'cabal-version: >= 1.10' and before 'cabal-version: 3.4' "
+ ++ "must specify the 'default-language' field for each component (e.g. "
+ ++ "Haskell98 or Haskell2010). If a component uses different languages "
+ ++ "in different modules then list the other ones in the "
+ ++ "'other-languages' field."
ppExplanation CVExtraDocFiles =
- "To use the 'extra-doc-files' field the package needs to specify "
- ++ "'cabal-version: 1.18' or higher."
+ "To use the 'extra-doc-files' field the package needs to specify "
+ ++ "'cabal-version: 1.18' or higher."
ppExplanation CVMultiLib =
- "To use multiple 'library' sections or a named library section "
- ++ "the package needs to specify at least 'cabal-version: 2.0'."
+ "To use multiple 'library' sections or a named library section "
+ ++ "the package needs to specify at least 'cabal-version: 2.0'."
ppExplanation CVReexported =
- "To use the 'reexported-module' field the package needs to specify "
- ++ "'cabal-version: 1.22' or higher."
+ "To use the 'reexported-module' field the package needs to specify "
+ ++ "'cabal-version: 1.22' or higher."
ppExplanation CVMixins =
- "To use the 'mixins' field the package needs to specify "
- ++ "at least 'cabal-version: 2.0'."
+ "To use the 'mixins' field the package needs to specify "
+ ++ "at least 'cabal-version: 2.0'."
ppExplanation CVExtraFrameworkDirs =
- "To use the 'extra-framework-dirs' field the package needs to specify"
- ++ " 'cabal-version: 1.24' or higher."
+ "To use the 'extra-framework-dirs' field the package needs to specify"
+ ++ " 'cabal-version: 1.24' or higher."
ppExplanation CVDefaultExtensions =
- "To use the 'default-extensions' field the package needs to specify "
- ++ "at least 'cabal-version: >= 1.10'."
+ "To use the 'default-extensions' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.10'."
ppExplanation CVExtensionsDeprecated =
- "For packages using 'cabal-version: >= 1.10' the 'extensions' "
- ++ "field is deprecated. The new 'default-extensions' field lists "
- ++ "extensions that are used in all modules in the component, while "
- ++ "the 'other-extensions' field lists extensions that are used in "
- ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
+ "For packages using 'cabal-version: >= 1.10' the 'extensions' "
+ ++ "field is deprecated. The new 'default-extensions' field lists "
+ ++ "extensions that are used in all modules in the component, while "
+ ++ "the 'other-extensions' field lists extensions that are used in "
+ ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
ppExplanation CVSources =
- "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' "
- ++ " and 'extra-library-flavours' requires the package "
- ++ " to specify at least 'cabal-version: 3.0'."
+ "The use of 'asm-sources', 'cmm-sources', 'extra-bundled-libraries' "
+ ++ " and 'extra-library-flavours' requires the package "
+ ++ " to specify at least 'cabal-version: 3.0'."
ppExplanation (CVExtraDynamic flavs) =
- "The use of 'extra-dynamic-library-flavours' requires the package "
- ++ " to specify at least 'cabal-version: 3.0'. The flavours are: "
- ++ commaSep (concat flavs)
+ "The use of 'extra-dynamic-library-flavours' requires the package "
+ ++ " to specify at least 'cabal-version: 3.0'. The flavours are: "
+ ++ commaSep (concat flavs)
ppExplanation CVVirtualModules =
- "The use of 'virtual-modules' requires the package "
- ++ " to specify at least 'cabal-version: 2.2'."
+ "The use of 'virtual-modules' requires the package "
+ ++ " to specify at least 'cabal-version: 2.2'."
ppExplanation CVSourceRepository =
- "The 'source-repository' section is new in Cabal 1.6. "
- ++ "Unfortunately it messes up the parser in earlier Cabal versions "
- ++ "so you need to specify 'cabal-version: >= 1.6'."
+ "The 'source-repository' section is new in Cabal 1.6. "
+ ++ "Unfortunately it messes up the parser in earlier Cabal versions "
+ ++ "so you need to specify 'cabal-version: >= 1.6'."
ppExplanation (CVExtensions version extCab12) =
- "Unfortunately the language extensions "
- ++ commaSep (map (quote . prettyShow) extCab12)
- ++ " break the parser in earlier Cabal versions so you need to "
- ++ "specify 'cabal-version: >= " ++ showCabalSpecVersion version
- ++ "'. Alternatively if you require compatibility with earlier "
- ++ "Cabal versions then you may be able to use an equivalent "
- ++ "compiler-specific flag."
+ "Unfortunately the language extensions "
+ ++ commaSep (map (quote . prettyShow) extCab12)
+ ++ " break the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= "
+ ++ showCabalSpecVersion version
+ ++ "'. Alternatively if you require compatibility with earlier "
+ ++ "Cabal versions then you may be able to use an equivalent "
+ ++ "compiler-specific flag."
ppExplanation CVCustomSetup =
- "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' "
- ++ "must use a 'custom-setup' section with a 'setup-depends' field "
- ++ "that specifies the dependencies of the Setup.hs script itself. "
- ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
- ++ "so a simple example would be 'setup-depends: base, Cabal'."
+ "Packages using 'cabal-version: 1.24' or higher with 'build-type: Custom' "
+ ++ "must use a 'custom-setup' section with a 'setup-depends' field "
+ ++ "that specifies the dependencies of the Setup.hs script itself. "
+ ++ "The 'setup-depends' field uses the same syntax as 'build-depends', "
+ ++ "so a simple example would be 'setup-depends: base, Cabal'."
ppExplanation CVExpliticDepsCustomSetup =
- "From version 1.24 cabal supports specifying explicit dependencies "
- ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or "
- ++ "higher and adding a 'custom-setup' section with a 'setup-depends' "
- ++ "field that specifies the dependencies of the Setup.hs script "
- ++ "itself. The 'setup-depends' field uses the same syntax as "
- ++ "'build-depends', so a simple example would be 'setup-depends: base, "
- ++ "Cabal'."
+ "From version 1.24 cabal supports specifying explicit dependencies "
+ ++ "for Custom setup scripts. Consider using 'cabal-version: 1.24' or "
+ ++ "higher and adding a 'custom-setup' section with a 'setup-depends' "
+ ++ "field that specifies the dependencies of the Setup.hs script "
+ ++ "itself. The 'setup-depends' field uses the same syntax as "
+ ++ "'build-depends', so a simple example would be 'setup-depends: base, "
+ ++ "Cabal'."
ppExplanation CVAutogenPaths =
- "Packages using 'cabal-version: 2.0' and the autogenerated "
- ++ "module Paths_* must include it also on the 'autogen-modules' field "
- ++ "besides 'exposed-modules' and 'other-modules'. This specifies that "
- ++ "the module does not come with the package and is generated on "
- ++ "setup. Modules built with a custom Setup.hs script also go here "
- ++ "to ensure that commands like sdist don't fail."
+ "Packages using 'cabal-version: 2.0' and the autogenerated "
+ ++ "module Paths_* must include it also on the 'autogen-modules' field "
+ ++ "besides 'exposed-modules' and 'other-modules'. This specifies that "
+ ++ "the module does not come with the package and is generated on "
+ ++ "setup. Modules built with a custom Setup.hs script also go here "
+ ++ "to ensure that commands like sdist don't fail."
ppExplanation CVAutogenPackageInfo =
- "Packages using 'cabal-version: 2.0' and the autogenerated "
- ++ "module PackageInfo_* must include it in 'autogen-modules' as well as"
- ++ " 'exposed-modules' and 'other-modules'. This specifies that "
- ++ "the module does not come with the package and is generated on "
- ++ "setup. Modules built with a custom Setup.hs script also go here "
- ++ "to ensure that commands like sdist don't fail."
+ "Packages using 'cabal-version: 2.0' and the autogenerated "
+ ++ "module PackageInfo_* must include it in 'autogen-modules' as well as"
+ ++ " 'exposed-modules' and 'other-modules'. This specifies that "
+ ++ "the module does not come with the package and is generated on "
+ ++ "setup. Modules built with a custom Setup.hs script also go here "
+ ++ "to ensure that commands like sdist don't fail."
ppExplanation (GlobNoMatch field glob) =
- "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"
- ++ " match any files."
+ "In '"
+ ++ field
+ ++ "': the pattern '"
+ ++ glob
+ ++ "' does not"
+ ++ " match any files."
ppExplanation (GlobExactMatch field glob file) =
- "In '" ++ field ++ "': the pattern '" ++ glob ++ "' does not"
- ++ " match the file '" ++ file ++ "' because the extensions do not"
- ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."
- ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or"
- ++ " higher."
+ "In '"
+ ++ field
+ ++ "': the pattern '"
+ ++ glob
+ ++ "' does not"
+ ++ " match the file '"
+ ++ file
+ ++ "' because the extensions do not"
+ ++ " exactly match (e.g., foo.en.html does not exactly match *.html)."
+ ++ " To enable looser suffix-only matching, set 'cabal-version: 2.4' or"
+ ++ " higher."
ppExplanation (GlobNoDir field glob dir) =
- "In '" ++ field ++ "': the pattern '" ++ glob ++ "' attempts to"
- ++ " match files in the directory '" ++ dir ++ "', but there is no"
- ++ " directory by that name."
+ "In '"
+ ++ field
+ ++ "': the pattern '"
+ ++ glob
+ ++ "' attempts to"
+ ++ " match files in the directory '"
+ ++ dir
+ ++ "', but there is no"
+ ++ " directory by that name."
ppExplanation (UnknownOS unknownOSs) =
- "Unknown operating system name " ++ commaSep (map quote unknownOSs)
+ "Unknown operating system name " ++ commaSep (map quote unknownOSs)
ppExplanation (UnknownArch unknownArches) =
- "Unknown architecture name " ++ commaSep (map quote unknownArches)
+ "Unknown architecture name " ++ commaSep (map quote unknownArches)
ppExplanation (UnknownCompiler unknownImpls) =
- "Unknown compiler name " ++ commaSep (map quote unknownImpls)
+ "Unknown compiler name " ++ commaSep (map quote unknownImpls)
ppExplanation (MissingUpperBounds names) =
- let separator = "\n - "
- in
- "These packages miss upper bounds:" ++ separator
- ++ (intercalate separator (unPackageName <$> names)) ++ "\n"
- ++ "Please add them, using `cabal gen-bounds` for suggestions."
- ++ " For more information see: "
- ++ " https://pvp.haskell.org/"
+ let separator = "\n - "
+ in "These packages miss upper bounds:"
+ ++ separator
+ ++ (intercalate separator (unPackageName <$> names))
+ ++ "\n"
+ ++ "Please add them, using `cabal gen-bounds` for suggestions."
+ ++ " For more information see: "
+ ++ " https://pvp.haskell.org/"
ppExplanation BaseNoUpperBounds =
- "The dependency 'build-depends: base' does not specify an upper "
- ++ "bound on the version number. Each major release of the 'base' "
- ++ "package changes the API in various ways and most packages will "
- ++ "need some changes to compile with it. The recommended practice "
- ++ "is to specify an upper bound on the version of the 'base' "
- ++ "package. This ensures your package will continue to build when a "
- ++ "new major version of the 'base' package is released. If you are "
- ++ "not sure what upper bound to use then use the next major "
- ++ "version. For example if you have tested your package with 'base' "
- ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."
+ "The dependency 'build-depends: base' does not specify an upper "
+ ++ "bound on the version number. Each major release of the 'base' "
+ ++ "package changes the API in various ways and most packages will "
+ ++ "need some changes to compile with it. The recommended practice "
+ ++ "is to specify an upper bound on the version of the 'base' "
+ ++ "package. This ensures your package will continue to build when a "
+ ++ "new major version of the 'base' package is released. If you are "
+ ++ "not sure what upper bound to use then use the next major "
+ ++ "version. For example if you have tested your package with 'base' "
+ ++ "version 4.5 and 4.6 then use 'build-depends: base >= 4.5 && < 4.7'."
ppExplanation (SuspiciousFlagName invalidFlagNames) =
- "Suspicious flag names: " ++ unwords invalidFlagNames ++ ". "
- ++ "To avoid ambiguity in command line interfaces, flag shouldn't "
- ++ "start with a dash. Also for better compatibility, flag names "
- ++ "shouldn't contain non-ascii characters."
+ "Suspicious flag names: "
+ ++ unwords invalidFlagNames
+ ++ ". "
+ ++ "To avoid ambiguity in command line interfaces, flag shouldn't "
+ ++ "start with a dash. Also for better compatibility, flag names "
+ ++ "shouldn't contain non-ascii characters."
ppExplanation (DeclaredUsedFlags declared used) =
- "Declared and used flag sets differ: "
- ++ s declared ++ " /= " ++ s used ++ ". "
- where s :: Set.Set FlagName -> String
- s = commaSep . map unFlagName . Set.toList
+ "Declared and used flag sets differ: "
+ ++ s declared
+ ++ " /= "
+ ++ s used
+ ++ ". "
+ where
+ s :: Set.Set FlagName -> String
+ s = commaSep . map unFlagName . Set.toList
ppExplanation (NonASCIICustomField nonAsciiXFields) =
- "Non ascii custom fields: " ++ unwords nonAsciiXFields ++ ". "
- ++ "For better compatibility, custom field names "
- ++ "shouldn't contain non-ascii characters."
+ "Non ascii custom fields: "
+ ++ unwords nonAsciiXFields
+ ++ ". "
+ ++ "For better compatibility, custom field names "
+ ++ "shouldn't contain non-ascii characters."
ppExplanation RebindableClashPaths =
- "Packages using RebindableSyntax with OverloadedStrings or"
- ++ " OverloadedLists in default-extensions, in conjunction with the"
- ++ " autogenerated module Paths_*, are known to cause compile failures"
- ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*"
- ++ " autogen module, specify at least 'cabal-version: 2.2'."
+ "Packages using RebindableSyntax with OverloadedStrings or"
+ ++ " OverloadedLists in default-extensions, in conjunction with the"
+ ++ " autogenerated module Paths_*, are known to cause compile failures"
+ ++ " with Cabal < 2.2. To use these default-extensions with a Paths_*"
+ ++ " autogen module, specify at least 'cabal-version: 2.2'."
ppExplanation RebindableClashPackageInfo =
- "Packages using RebindableSyntax with OverloadedStrings or"
- ++ " OverloadedLists in default-extensions, in conjunction with the"
- ++ " autogenerated module PackageInfo_*, are known to cause compile failures"
- ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*"
- ++ " autogen module, specify at least 'cabal-version: 2.2'."
-ppExplanation (WErrorUnneeded fieldName) = addConditionalExp $
- "'" ++ fieldName ++ ": -Werror' makes the package easy to "
+ "Packages using RebindableSyntax with OverloadedStrings or"
+ ++ " OverloadedLists in default-extensions, in conjunction with the"
+ ++ " autogenerated module PackageInfo_*, are known to cause compile failures"
+ ++ " with Cabal < 2.2. To use these default-extensions with a PackageInfo_*"
+ ++ " autogen module, specify at least 'cabal-version: 2.2'."
+ppExplanation (WErrorUnneeded fieldName) =
+ addConditionalExp $
+ "'"
+ ++ fieldName
+ ++ ": -Werror' makes the package easy to "
++ "break with future GHC versions because new GHC versions often "
++ "add new warnings."
-ppExplanation (JUnneeded fieldName) = addConditionalExp $
- "'" ++ fieldName ++ ": -j[N]' can make sense for specific user's setup,"
+ppExplanation (JUnneeded fieldName) =
+ addConditionalExp $
+ "'"
+ ++ fieldName
+ ++ ": -j[N]' can make sense for specific user's setup,"
++ " but it is not appropriate for a distributed package."
-ppExplanation (FDeferTypeErrorsUnneeded fieldName) = addConditionalExp $
- "'" ++ fieldName ++ ": -fdefer-type-errors' is fine during development "
+ppExplanation (FDeferTypeErrorsUnneeded fieldName) =
+ addConditionalExp $
+ "'"
+ ++ fieldName
+ ++ ": -fdefer-type-errors' is fine during development "
++ "but is not appropriate for a distributed package."
-ppExplanation (DynamicUnneeded fieldName) = addConditionalExp $
- "'" ++ fieldName ++ ": -d*' debug flags are not appropriate "
+ppExplanation (DynamicUnneeded fieldName) =
+ addConditionalExp $
+ "'"
+ ++ fieldName
+ ++ ": -d*' debug flags are not appropriate "
++ "for a distributed package."
-ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $
- "'" ++ fieldName ++ ": -fprof*' profiling flags are typically not "
+ppExplanation (ProfilingUnneeded fieldName) =
+ addConditionalExp $
+ "'"
+ ++ fieldName
+ ++ ": -fprof*' profiling flags are typically not "
++ "appropriate for a distributed library package. These flags are "
++ "useful to profile this package, but when profiling other packages "
++ "that use this one these flags clutter the profile output with "
@@ -752,66 +879,93 @@ ppExplanation (ProfilingUnneeded fieldName) = addConditionalExp $
++ "cost centres from this package then use '-fprof-auto-exported' "
++ "which puts cost centres only on exported functions."
ppExplanation (UpperBoundSetup nm) =
- "The dependency 'setup-depends: '"++nm++"' does not specify an "
- ++ "upper bound on the version number. Each major release of the "
- ++ "'"++nm++"' package changes the API in various ways and most "
- ++ "packages will need some changes to compile with it. If you are "
- ++ "not sure what upper bound to use then use the next major "
- ++ "version."
+ "The dependency 'setup-depends: '"
+ ++ nm
+ ++ "' does not specify an "
+ ++ "upper bound on the version number. Each major release of the "
+ ++ "'"
+ ++ nm
+ ++ "' package changes the API in various ways and most "
+ ++ "packages will need some changes to compile with it. If you are "
+ ++ "not sure what upper bound to use then use the next major "
+ ++ "version."
ppExplanation (DuplicateModule s dupLibsLax) =
- "Duplicate modules in " ++ s ++ ": "
- ++ commaSep (map prettyShow dupLibsLax)
+ "Duplicate modules in "
+ ++ s
+ ++ ": "
+ ++ commaSep (map prettyShow dupLibsLax)
ppExplanation (PotentialDupModule s dupLibsStrict) =
- "Potential duplicate modules (subject to conditionals) in " ++ s
- ++ ": " ++ commaSep (map prettyShow dupLibsStrict)
+ "Potential duplicate modules (subject to conditionals) in "
+ ++ s
+ ++ ": "
+ ++ commaSep (map prettyShow dupLibsStrict)
ppExplanation (BOMStart pdfile) =
- pdfile ++ " starts with an Unicode byte order mark (BOM)."
- ++ " This may cause problems with older cabal versions."
+ pdfile
+ ++ " starts with an Unicode byte order mark (BOM)."
+ ++ " This may cause problems with older cabal versions."
ppExplanation (NotPackageName pdfile expectedCabalname) =
- "The filename " ++ quote pdfile ++ " does not match package name "
- ++ "(expected: " ++ quote expectedCabalname ++ ")"
+ "The filename "
+ ++ quote pdfile
+ ++ " does not match package name "
+ ++ "(expected: "
+ ++ quote expectedCabalname
+ ++ ")"
ppExplanation NoDesc =
- "No cabal file found.\n"
- ++ "Please create a package description file <pkgname>.cabal"
+ "No cabal file found.\n"
+ ++ "Please create a package description file <pkgname>.cabal"
ppExplanation (MultiDesc multiple) =
- "Multiple cabal files found while checking.\n"
- ++ "Please use only one of: "
- ++ intercalate ", " multiple
+ "Multiple cabal files found while checking.\n"
+ ++ "Please use only one of: "
+ ++ intercalate ", " multiple
ppExplanation (UnknownFile fieldname file) =
- "The '" ++ fieldname ++ "' field refers to the file "
- ++ quote (getSymbolicPath file) ++ " which does not exist."
+ "The '"
+ ++ fieldname
+ ++ "' field refers to the file "
+ ++ quote (getSymbolicPath file)
+ ++ " which does not exist."
ppExplanation MissingSetupFile =
- "The package is missing a Setup.hs or Setup.lhs script."
+ "The package is missing a Setup.hs or Setup.lhs script."
ppExplanation MissingConfigureScript =
- "The 'build-type' is 'Configure' but there is no 'configure' script. "
- ++ "You probably need to run 'autoreconf -i' to generate it."
+ "The 'build-type' is 'Configure' but there is no 'configure' script. "
+ ++ "You probably need to run 'autoreconf -i' to generate it."
ppExplanation (UnknownDirectory kind dir) =
- quote (kind ++ ": " ++ dir)
- ++ " specifies a directory which does not exist."
+ quote (kind ++ ": " ++ dir)
+ ++ " specifies a directory which does not exist."
ppExplanation MissingSourceControl =
- "When distributing packages it is encouraged to specify source "
- ++ "control information in the .cabal file using one or more "
- ++ "'source-repository' sections. See the Cabal user guide for "
- ++ "details."
+ "When distributing packages it is encouraged to specify source "
+ ++ "control information in the .cabal file using one or more "
+ ++ "'source-repository' sections. See the Cabal user guide for "
+ ++ "details."
ppExplanation (MissingExpectedDocFiles extraDocFileSupport paths) =
- "Please consider including the " ++ quotes paths
- ++ " in the '" ++ targetField ++ "' section of the .cabal file "
- ++ "if it contains useful information for users of the package."
- where quotes [p] = "file " ++ quote p
- quotes ps = "files " ++ intercalate ", " (map quote ps)
- targetField = if extraDocFileSupport
- then "extra-doc-files"
- else "extra-source-files"
+ "Please consider including the "
+ ++ quotes paths
+ ++ " in the '"
+ ++ targetField
+ ++ "' section of the .cabal file "
+ ++ "if it contains useful information for users of the package."
+ where
+ quotes [p] = "file " ++ quote p
+ quotes ps = "files " ++ intercalate ", " (map quote ps)
+ targetField =
+ if extraDocFileSupport
+ then "extra-doc-files"
+ else "extra-source-files"
ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) =
- "Please consider moving the " ++ quotes paths
- ++ " from the '" ++ field ++ "' section of the .cabal file "
- ++ "to the section '" ++ targetField ++ "'."
- where quotes [p] = "file " ++ quote p
- quotes ps = "files " ++ intercalate ", " (map quote ps)
- targetField = if extraDocFileSupport
- then "extra-doc-files"
- else "extra-source-files"
-
+ "Please consider moving the "
+ ++ quotes paths
+ ++ " from the '"
+ ++ field
+ ++ "' section of the .cabal file "
+ ++ "to the section '"
+ ++ targetField
+ ++ "'."
+ where
+ quotes [p] = "file " ++ quote p
+ quotes ps = "files " ++ intercalate ", " (map quote ps)
+ targetField =
+ if extraDocFileSupport
+ then "extra-doc-files"
+ else "extra-source-files"
-- | Results of some kind of failed package check.
--
@@ -819,65 +973,64 @@ ppExplanation (WrongFieldForExpectedDocFiles extraDocFileSupport field paths) =
-- All of them come with a human readable explanation. In future we may augment
-- them with more machine readable explanations, for example to help an IDE
-- suggest automatic corrections.
---
-data PackageCheck =
-
- -- | This package description is no good. There's no way it's going to
- -- build sensibly. This should give an error at configure time.
- PackageBuildImpossible { explanation :: CheckExplanation }
-
- -- | A problem that is likely to affect building the package, or an
- -- issue that we'd like every package author to be aware of, even if
- -- the package is never distributed.
- | PackageBuildWarning { explanation :: CheckExplanation }
-
- -- | An issue that might not be a problem for the package author but
- -- might be annoying or detrimental when the package is distributed to
- -- users. We should encourage distributed packages to be free from these
- -- issues, but occasionally there are justifiable reasons so we cannot
- -- ban them entirely.
- | PackageDistSuspicious { explanation :: CheckExplanation }
-
- -- | Like PackageDistSuspicious but will only display warnings
- -- rather than causing abnormal exit when you run 'cabal check'.
- | PackageDistSuspiciousWarn { explanation :: CheckExplanation }
-
- -- | An issue that is OK in the author's environment but is almost
- -- certain to be a portability problem for other environments. We can
- -- quite legitimately refuse to publicly distribute packages with these
- -- problems.
- | PackageDistInexcusable { explanation :: CheckExplanation }
+data PackageCheck
+ = -- | This package description is no good. There's no way it's going to
+ -- build sensibly. This should give an error at configure time.
+ PackageBuildImpossible {explanation :: CheckExplanation}
+ | -- | A problem that is likely to affect building the package, or an
+ -- issue that we'd like every package author to be aware of, even if
+ -- the package is never distributed.
+ PackageBuildWarning {explanation :: CheckExplanation}
+ | -- | An issue that might not be a problem for the package author but
+ -- might be annoying or detrimental when the package is distributed to
+ -- users. We should encourage distributed packages to be free from these
+ -- issues, but occasionally there are justifiable reasons so we cannot
+ -- ban them entirely.
+ PackageDistSuspicious {explanation :: CheckExplanation}
+ | -- | Like PackageDistSuspicious but will only display warnings
+ -- rather than causing abnormal exit when you run 'cabal check'.
+ PackageDistSuspiciousWarn {explanation :: CheckExplanation}
+ | -- | An issue that is OK in the author's environment but is almost
+ -- certain to be a portability problem for other environments. We can
+ -- quite legitimately refuse to publicly distribute packages with these
+ -- problems.
+ PackageDistInexcusable {explanation :: CheckExplanation}
deriving (Eq, Ord)
-- | Would Hackage refuse a package because of this error?
isHackageDistError :: PackageCheck -> Bool
isHackageDistError = \case
- (PackageBuildImpossible {}) -> True
- (PackageBuildWarning {}) -> True
- (PackageDistInexcusable {}) -> True
- (PackageDistSuspicious {}) -> False
- (PackageDistSuspiciousWarn {}) -> False
+ (PackageBuildImpossible{}) -> True
+ (PackageBuildWarning{}) -> True
+ (PackageDistInexcusable{}) -> True
+ (PackageDistSuspicious{}) -> False
+ (PackageDistSuspiciousWarn{}) -> False
-- | Pretty printing 'PackageCheck'.
---
ppPackageCheck :: PackageCheck -> String
ppPackageCheck e = ppExplanation (explanation e)
instance Show PackageCheck where
- show notice = ppPackageCheck notice
+ show notice = ppPackageCheck notice
check :: Bool -> PackageCheck -> Maybe PackageCheck
-check False _ = Nothing
-check True pc = Just pc
-
-checkSpecVersion :: PackageDescription -> CabalSpecVersion -> Bool -> PackageCheck
- -> Maybe PackageCheck
+check False _ = Nothing
+check True pc = Just pc
+
+checkSpecVersion
+ :: PackageDescription
+ -> CabalSpecVersion
+ -> Bool
+ -> PackageCheck
+ -> Maybe PackageCheck
checkSpecVersion pkg specver cond pc
- | specVersion pkg >= specver = Nothing
- | otherwise = check cond pc
+ | specVersion pkg >= specver = Nothing
+ | otherwise = check cond pc
-- ------------------------------------------------------------
+
-- * Standard checks
+
-- ------------------------------------------------------------
-- | Check for common mistakes and problems in package descriptions.
@@ -889,84 +1042,85 @@ checkSpecVersion pkg specver cond pc
-- It requires the 'GenericPackageDescription' and optionally a particular
-- configuration of that package. If you pass 'Nothing' then we just check
-- a version of the generic description using 'flattenPackageDescription'.
---
-checkPackage :: GenericPackageDescription
- -> Maybe PackageDescription
- -> [PackageCheck]
+checkPackage
+ :: GenericPackageDescription
+ -> Maybe PackageDescription
+ -> [PackageCheck]
checkPackage gpkg mpkg =
- checkConfiguredPackage pkg
- ++ checkConditionals gpkg
- ++ checkPackageVersions gpkg
- ++ checkDevelopmentOnlyFlags gpkg
- ++ checkFlagNames gpkg
- ++ checkUnusedFlags gpkg
- ++ checkUnicodeXFields gpkg
- ++ checkPathsModuleExtensions pkg
- ++ checkPackageInfoModuleExtensions pkg
- ++ checkSetupVersions gpkg
- ++ checkDuplicateModules gpkg
+ checkConfiguredPackage pkg
+ ++ checkConditionals gpkg
+ ++ checkPackageVersions gpkg
+ ++ checkDevelopmentOnlyFlags gpkg
+ ++ checkFlagNames gpkg
+ ++ checkUnusedFlags gpkg
+ ++ checkUnicodeXFields gpkg
+ ++ checkPathsModuleExtensions pkg
+ ++ checkPackageInfoModuleExtensions pkg
+ ++ checkSetupVersions gpkg
+ ++ checkDuplicateModules gpkg
where
pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
---TODO: make this variant go away
+-- TODO: make this variant go away
-- we should always know the GenericPackageDescription
checkConfiguredPackage :: PackageDescription -> [PackageCheck]
checkConfiguredPackage pkg =
- checkSanity pkg
- ++ checkFields pkg
- ++ checkLicense pkg
- ++ checkSourceRepos pkg
- ++ checkAllGhcOptions pkg
- ++ checkCCOptions pkg
- ++ checkCxxOptions pkg
- ++ checkCPPOptions pkg
- ++ checkPaths pkg
- ++ checkCabalVersion pkg
-
+ checkSanity pkg
+ ++ checkFields pkg
+ ++ checkLicense pkg
+ ++ checkSourceRepos pkg
+ ++ checkAllGhcOptions pkg
+ ++ checkCCOptions pkg
+ ++ checkCxxOptions pkg
+ ++ checkCPPOptions pkg
+ ++ checkPaths pkg
+ ++ checkCabalVersion pkg
-- ------------------------------------------------------------
+
-- * Basic sanity checks
+
-- ------------------------------------------------------------
-- | Check that this package description is sane.
---
checkSanity :: PackageDescription -> [PackageCheck]
checkSanity pkg =
- catMaybes [
-
- check (null . unPackageName . packageName $ pkg) $
- PackageBuildImpossible NoNameField
-
- , check (nullVersion == packageVersion pkg) $
- PackageBuildImpossible NoVersionField
-
- , check (all ($ pkg) [ null . executables
- , null . testSuites
- , null . benchmarks
- , null . allLibraries
- , null . foreignLibs ]) $
- PackageBuildImpossible NoTarget
-
- , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $
- PackageBuildImpossible UnnamedInternal
-
- , check (not (null duplicateNames)) $
- PackageBuildImpossible (DuplicateSections duplicateNames)
-
- -- NB: but it's OK for executables to have the same name!
- -- TODO shouldn't need to compare on the string level
- , check (any (== prettyShow (packageName pkg))
- (prettyShow <$> subLibNames)) $
- PackageBuildImpossible (IllegalLibraryName pkg)
- ]
- --TODO: check for name clashes case insensitively: windows file systems cannot
- --cope.
-
- ++ concatMap (checkLibrary pkg) (allLibraries pkg)
- ++ concatMap (checkExecutable pkg) (executables pkg)
- ++ concatMap (checkTestSuite pkg) (testSuites pkg)
- ++ concatMap (checkBenchmark pkg) (benchmarks pkg)
+ catMaybes
+ [ check (null . unPackageName . packageName $ pkg) $
+ PackageBuildImpossible NoNameField
+ , check (nullVersion == packageVersion pkg) $
+ PackageBuildImpossible NoVersionField
+ , check
+ ( all
+ ($ pkg)
+ [ null . executables
+ , null . testSuites
+ , null . benchmarks
+ , null . allLibraries
+ , null . foreignLibs
+ ]
+ )
+ $ PackageBuildImpossible NoTarget
+ , check (any (== LMainLibName) (map libName $ subLibraries pkg)) $
+ PackageBuildImpossible UnnamedInternal
+ , check (not (null duplicateNames)) $
+ PackageBuildImpossible (DuplicateSections duplicateNames)
+ , -- NB: but it's OK for executables to have the same name!
+ -- TODO shouldn't need to compare on the string level
+ check
+ ( any
+ (== prettyShow (packageName pkg))
+ (prettyShow <$> subLibNames)
+ )
+ $ PackageBuildImpossible (IllegalLibraryName pkg)
+ ]
+ -- TODO: check for name clashes case insensitively: windows file systems cannot
+ -- cope.
+ ++ concatMap (checkLibrary pkg) (allLibraries pkg)
+ ++ concatMap (checkExecutable pkg) (executables pkg)
+ ++ concatMap (checkTestSuite pkg) (testSuites pkg)
+ ++ concatMap (checkBenchmark pkg) (benchmarks pkg)
where
-- The public 'library' gets special dispensation, because it
-- is common practice to export a library and name the executable
@@ -979,251 +1133,228 @@ checkSanity pkg =
checkLibrary :: PackageDescription -> Library -> [PackageCheck]
checkLibrary pkg lib =
- catMaybes [
-
- -- TODO: This check is bogus if a required-signature was passed through
- check (null (explicitLibModules lib) && null (reexportedModules lib)) $
- PackageDistSuspiciousWarn (NoModulesExposed lib)
-
- -- check use of signatures sections
- , checkVersion CabalSpecV2_0 (not (null (signatures lib))) $
- PackageDistInexcusable SignaturesCabal2
-
- -- check that all autogen-modules appear on other-modules or exposed-modules
- , check
- (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib)) $
- PackageBuildImpossible AutogenNotExposed
-
- -- check that all autogen-includes appear on includes or install-includes
- , check
- (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib)) $
- PackageBuildImpossible AutogenIncludesNotIncluded
- ]
-
+ catMaybes
+ [ -- TODO: This check is bogus if a required-signature was passed through
+ check (null (explicitLibModules lib) && null (reexportedModules lib)) $
+ PackageDistSuspiciousWarn (NoModulesExposed lib)
+ , -- check use of signatures sections
+ checkVersion CabalSpecV2_0 (not (null (signatures lib))) $
+ PackageDistInexcusable SignaturesCabal2
+ , -- check that all autogen-modules appear on other-modules or exposed-modules
+ check
+ (not $ and $ map (flip elem (explicitLibModules lib)) (libModulesAutogen lib))
+ $ PackageBuildImpossible AutogenNotExposed
+ , -- check that all autogen-includes appear on includes or install-includes
+ check
+ (not $ and $ map (flip elem (allExplicitIncludes lib)) (view L.autogenIncludes lib))
+ $ PackageBuildImpossible AutogenIncludesNotIncluded
+ ]
where
checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck
checkVersion ver cond pc
| specVersion pkg >= ver = Nothing
- | otherwise = check cond pc
+ | otherwise = check cond pc
allExplicitIncludes :: L.HasBuildInfo a => a -> [FilePath]
allExplicitIncludes x = view L.includes x ++ view L.installIncludes x
checkExecutable :: PackageDescription -> Executable -> [PackageCheck]
checkExecutable pkg exe =
- catMaybes [
-
- check (null (modulePath exe)) $
- PackageBuildImpossible (NoMainIs exe)
-
- -- This check does not apply to scripts.
- , check (package pkg /= fakePackageId
- && not (null (modulePath exe))
- && not (fileExtensionSupportedLanguage $ modulePath exe)) $
- PackageBuildImpossible NoHsLhsMain
-
- , checkSpecVersion pkg CabalSpecV1_18
- (fileExtensionSupportedLanguage (modulePath exe)
- && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
- PackageDistInexcusable MainCCabal1_18
-
- -- check that all autogen-modules appear on other-modules
- , check
- (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe)) $
- PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe))
-
- -- check that all autogen-includes appear on includes
- , check
- (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe)) $
- PackageBuildImpossible AutogenIncludesNotIncludedExe
- ]
+ catMaybes
+ [ check (null (modulePath exe)) $
+ PackageBuildImpossible (NoMainIs exe)
+ , -- This check does not apply to scripts.
+ check
+ ( package pkg /= fakePackageId
+ && not (null (modulePath exe))
+ && not (fileExtensionSupportedLanguage $ modulePath exe)
+ )
+ $ PackageBuildImpossible NoHsLhsMain
+ , checkSpecVersion
+ pkg
+ CabalSpecV1_18
+ ( fileExtensionSupportedLanguage (modulePath exe)
+ && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]
+ )
+ $ PackageDistInexcusable MainCCabal1_18
+ , -- check that all autogen-modules appear on other-modules
+ check
+ (not $ and $ map (flip elem (exeModules exe)) (exeModulesAutogen exe))
+ $ PackageBuildImpossible (AutogenNoOther CETExecutable (exeName exe))
+ , -- check that all autogen-includes appear on includes
+ check
+ (not $ and $ map (flip elem (view L.includes exe)) (view L.autogenIncludes exe))
+ $ PackageBuildImpossible AutogenIncludesNotIncludedExe
+ ]
checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]
checkTestSuite pkg test =
- catMaybes [
-
- case testInterface test of
- TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $
- PackageBuildWarning (TestsuiteTypeNotKnown tt)
-
- TestSuiteUnsupported tt -> Just $
- PackageBuildWarning (TestsuiteNotSupported tt)
- _ -> Nothing
-
- , check mainIsWrongExt $
- PackageBuildImpossible NoHsLhsMain
-
- , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $
- PackageDistInexcusable MainCCabal1_18
-
- -- check that all autogen-modules appear on other-modules
- , check
- (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test)) $
- PackageBuildImpossible (AutogenNoOther CETTest (testName test))
-
- -- check that all autogen-includes appear on includes
- , check
- (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test)) $
- PackageBuildImpossible AutogenIncludesNotIncludedExe
- ]
+ catMaybes
+ [ case testInterface test of
+ TestSuiteUnsupported tt@(TestTypeUnknown _ _) ->
+ Just $
+ PackageBuildWarning (TestsuiteTypeNotKnown tt)
+ TestSuiteUnsupported tt ->
+ Just $
+ PackageBuildWarning (TestsuiteNotSupported tt)
+ _ -> Nothing
+ , check mainIsWrongExt $
+ PackageBuildImpossible NoHsLhsMain
+ , checkSpecVersion pkg CabalSpecV1_18 (mainIsNotHsExt && not mainIsWrongExt) $
+ PackageDistInexcusable MainCCabal1_18
+ , -- check that all autogen-modules appear on other-modules
+ check
+ (not $ and $ map (flip elem (testModules test)) (testModulesAutogen test))
+ $ PackageBuildImpossible (AutogenNoOther CETTest (testName test))
+ , -- check that all autogen-includes appear on includes
+ check
+ (not $ and $ map (flip elem (view L.includes test)) (view L.autogenIncludes test))
+ $ PackageBuildImpossible AutogenIncludesNotIncludedExe
+ ]
where
mainIsWrongExt = case testInterface test of
TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f
- _ -> False
+ _ -> False
mainIsNotHsExt = case testInterface test of
TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
- _ -> False
+ _ -> False
checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]
checkBenchmark _pkg bm =
- catMaybes [
-
- case benchmarkInterface bm of
- BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $
- PackageBuildWarning (BenchmarkTypeNotKnown tt)
-
- BenchmarkUnsupported tt -> Just $
- PackageBuildWarning (BenchmarkNotSupported tt)
- _ -> Nothing
-
- , check mainIsWrongExt $
- PackageBuildImpossible NoHsLhsMainBench
-
- -- check that all autogen-modules appear on other-modules
- , check
- (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm)) $
- PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm))
-
- -- check that all autogen-includes appear on includes
- , check
- (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm)) $
- PackageBuildImpossible AutogenIncludesNotIncludedExe
- ]
+ catMaybes
+ [ case benchmarkInterface bm of
+ BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) ->
+ Just $
+ PackageBuildWarning (BenchmarkTypeNotKnown tt)
+ BenchmarkUnsupported tt ->
+ Just $
+ PackageBuildWarning (BenchmarkNotSupported tt)
+ _ -> Nothing
+ , check mainIsWrongExt $
+ PackageBuildImpossible NoHsLhsMainBench
+ , -- check that all autogen-modules appear on other-modules
+ check
+ (not $ and $ map (flip elem (benchmarkModules bm)) (benchmarkModulesAutogen bm))
+ $ PackageBuildImpossible (AutogenNoOther CETBenchmark (benchmarkName bm))
+ , -- check that all autogen-includes appear on includes
+ check
+ (not $ and $ map (flip elem (view L.includes bm)) (view L.autogenIncludes bm))
+ $ PackageBuildImpossible AutogenIncludesNotIncludedExe
+ ]
where
mainIsWrongExt = case benchmarkInterface bm of
BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
- _ -> False
+ _ -> False
-- ------------------------------------------------------------
+
-- * Additional pure checks
+
-- ------------------------------------------------------------
checkFields :: PackageDescription -> [PackageCheck]
checkFields pkg =
- catMaybes [
-
- check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $
- PackageDistInexcusable (InvalidNameWin pkg)
-
- , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $
- PackageDistInexcusable ZPrefix
-
- , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $
- PackageBuildWarning NoBuildType
-
- , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $
- PackageBuildWarning NoCustomSetup
-
- , check (not (null unknownCompilers)) $
- PackageBuildWarning (UnknownCompilers unknownCompilers)
-
- , check (not (null unknownLanguages)) $
- PackageBuildWarning (UnknownLanguages unknownLanguages)
-
- , check (not (null unknownExtensions)) $
- PackageBuildWarning (UnknownExtensions unknownExtensions)
-
- , check (not (null languagesUsedAsExtensions)) $
- PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions)
-
- , check (not (null ourDeprecatedExtensions)) $
- PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions)
-
- , check (ShortText.null (category pkg)) $
- PackageDistSuspicious (MissingField CEFCategory)
-
- , check (ShortText.null (maintainer pkg)) $
- PackageDistSuspicious (MissingField CEFMaintainer)
-
- , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $
- PackageDistInexcusable (MissingField CEFSynOrDesc)
-
- , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $
- PackageDistSuspicious (MissingField CEFDescription)
-
- , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $
- PackageDistSuspicious (MissingField CEFSynopsis)
-
- --TODO: recommend the bug reports URL, author and homepage fields
- --TODO: recommend not using the stability field
- --TODO: recommend specifying a source repo
-
- , check (ShortText.length (synopsis pkg) > 80) $
- PackageDistSuspicious SynopsisTooLong
-
- -- See also https://github.com/haskell/cabal/pull/3479
- , check (not (ShortText.null (description pkg))
- && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)) $
- PackageDistSuspicious ShortDesc
-
- -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"
- , check (not (null testedWithImpossibleRanges)) $
- PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges)
-
- -- for more details on why the following was commented out,
- -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507
- -- , check (not (null depInternalLibraryWithExtraVersion)) $
- -- PackageBuildWarning $
- -- "The package has an extraneous version range for a dependency on an "
- -- ++ "internal library: "
- -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion)
- -- ++ ". This version range includes the current package but isn't needed "
- -- ++ "as the current package's library will always be used."
-
- , check (not (null depInternalLibraryWithImpossibleVersion)) $
- PackageBuildImpossible
- (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion)
-
- -- , check (not (null depInternalExecutableWithExtraVersion)) $
- -- PackageBuildWarning $
- -- "The package has an extraneous version range for a dependency on an "
- -- ++ "internal executable: "
- -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion)
- -- ++ ". This version range includes the current package but isn't needed "
- -- ++ "as the current package's executable will always be used."
-
- , check (not (null depInternalExecutableWithImpossibleVersion)) $
- PackageBuildImpossible
- (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion)
-
- , check (not (null depMissingInternalExecutable)) $
- PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable)
- ]
+ catMaybes
+ [ check (not . FilePath.Windows.isValid . prettyShow . packageName $ pkg) $
+ PackageDistInexcusable (InvalidNameWin pkg)
+ , check (isPrefixOf "z-" . prettyShow . packageName $ pkg) $
+ PackageDistInexcusable ZPrefix
+ , check (isNothing (buildTypeRaw pkg) && specVersion pkg < CabalSpecV2_2) $
+ PackageBuildWarning NoBuildType
+ , check (isJust (setupBuildInfo pkg) && buildType pkg /= Custom) $
+ PackageBuildWarning NoCustomSetup
+ , check (not (null unknownCompilers)) $
+ PackageBuildWarning (UnknownCompilers unknownCompilers)
+ , check (not (null unknownLanguages)) $
+ PackageBuildWarning (UnknownLanguages unknownLanguages)
+ , check (not (null unknownExtensions)) $
+ PackageBuildWarning (UnknownExtensions unknownExtensions)
+ , check (not (null languagesUsedAsExtensions)) $
+ PackageBuildWarning (LanguagesAsExtension languagesUsedAsExtensions)
+ , check (not (null ourDeprecatedExtensions)) $
+ PackageDistSuspicious (DeprecatedExtensions ourDeprecatedExtensions)
+ , check (ShortText.null (category pkg)) $
+ PackageDistSuspicious (MissingField CEFCategory)
+ , check (ShortText.null (maintainer pkg)) $
+ PackageDistSuspicious (MissingField CEFMaintainer)
+ , check (ShortText.null (synopsis pkg) && ShortText.null (description pkg)) $
+ PackageDistInexcusable (MissingField CEFSynOrDesc)
+ , check (ShortText.null (description pkg) && not (ShortText.null (synopsis pkg))) $
+ PackageDistSuspicious (MissingField CEFDescription)
+ , check (ShortText.null (synopsis pkg) && not (ShortText.null (description pkg))) $
+ PackageDistSuspicious (MissingField CEFSynopsis)
+ , -- TODO: recommend the bug reports URL, author and homepage fields
+ -- TODO: recommend not using the stability field
+ -- TODO: recommend specifying a source repo
+
+ check (ShortText.length (synopsis pkg) > 80) $
+ PackageDistSuspicious SynopsisTooLong
+ , -- See also https://github.com/haskell/cabal/pull/3479
+ check
+ ( not (ShortText.null (description pkg))
+ && ShortText.length (description pkg) <= ShortText.length (synopsis pkg)
+ )
+ $ PackageDistSuspicious ShortDesc
+ , -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"
+ check (not (null testedWithImpossibleRanges)) $
+ PackageDistInexcusable (InvalidTestWith testedWithImpossibleRanges)
+ , -- for more details on why the following was commented out,
+ -- check https://github.com/haskell/cabal/pull/7470#issuecomment-875878507
+ -- , check (not (null depInternalLibraryWithExtraVersion)) $
+ -- PackageBuildWarning $
+ -- "The package has an extraneous version range for a dependency on an "
+ -- ++ "internal library: "
+ -- ++ commaSep (map prettyShow depInternalLibraryWithExtraVersion)
+ -- ++ ". This version range includes the current package but isn't needed "
+ -- ++ "as the current package's library will always be used."
+
+ check (not (null depInternalLibraryWithImpossibleVersion)) $
+ PackageBuildImpossible
+ (ImpossibleInternalDep depInternalLibraryWithImpossibleVersion)
+ , -- , check (not (null depInternalExecutableWithExtraVersion)) $
+ -- PackageBuildWarning $
+ -- "The package has an extraneous version range for a dependency on an "
+ -- ++ "internal executable: "
+ -- ++ commaSep (map prettyShow depInternalExecutableWithExtraVersion)
+ -- ++ ". This version range includes the current package but isn't needed "
+ -- ++ "as the current package's executable will always be used."
+
+ check (not (null depInternalExecutableWithImpossibleVersion)) $
+ PackageBuildImpossible
+ (ImpossibleInternalExe depInternalExecutableWithImpossibleVersion)
+ , check (not (null depMissingInternalExecutable)) $
+ PackageBuildImpossible (MissingInternalExe depMissingInternalExecutable)
+ ]
where
- unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ]
- unknownLanguages = [ name | bi <- allBuildInfo pkg
- , UnknownLanguage name <- allLanguages bi ]
- unknownExtensions = [ name | bi <- allBuildInfo pkg
- , UnknownExtension name <- allExtensions bi
- , name `notElem` map prettyShow knownLanguages ]
- ourDeprecatedExtensions = nub $ catMaybes
- [ find ((==ext) . fst) deprecatedExtensions
- | bi <- allBuildInfo pkg
- , ext <- allExtensions bi ]
+ unknownCompilers = [name | (OtherCompiler name, _) <- testedWith pkg]
+ unknownLanguages =
+ [ name | bi <- allBuildInfo pkg, UnknownLanguage name <- allLanguages bi
+ ]
+ unknownExtensions =
+ [ name | bi <- allBuildInfo pkg, UnknownExtension name <- allExtensions bi, name `notElem` map prettyShow knownLanguages
+ ]
+ ourDeprecatedExtensions =
+ nub $
+ catMaybes
+ [ find ((== ext) . fst) deprecatedExtensions
+ | bi <- allBuildInfo pkg
+ , ext <- allExtensions bi
+ ]
languagesUsedAsExtensions =
- [ name | bi <- allBuildInfo pkg
- , UnknownExtension name <- allExtensions bi
- , name `elem` map prettyShow knownLanguages ]
+ [ name | bi <- allBuildInfo pkg, UnknownExtension name <- allExtensions bi, name `elem` map prettyShow knownLanguages
+ ]
testedWithImpossibleRanges =
[ Dependency (mkPackageName (prettyShow compiler)) vr mainLibSet
| (compiler, vr) <- testedWith pkg
- , isNoVersion vr ]
+ , isNoVersion vr
+ ]
internalLibraries =
- map (maybe (packageName pkg) unqualComponentNameToPackageName . libraryNameString . libName)
- (allLibraries pkg)
+ map
+ (maybe (packageName pkg) unqualComponentNameToPackageName . libraryNameString . libName)
+ (allLibraries pkg)
internalExecutables = map exeName $ executables pkg
@@ -1275,217 +1406,236 @@ checkFields pkg =
checkLicense :: PackageDescription -> [PackageCheck]
checkLicense pkg = case licenseRaw pkg of
- Right l -> checkOldLicense pkg l
- Left l -> checkNewLicense pkg l
+ Right l -> checkOldLicense pkg l
+ Left l -> checkNewLicense pkg l
checkNewLicense :: PackageDescription -> SPDX.License -> [PackageCheck]
-checkNewLicense _pkg lic = catMaybes
+checkNewLicense _pkg lic =
+ catMaybes
[ check (lic == SPDX.NONE) $
- PackageDistInexcusable NONELicense ]
+ PackageDistInexcusable NONELicense
+ ]
checkOldLicense :: PackageDescription -> License -> [PackageCheck]
-checkOldLicense pkg lic = catMaybes
- [ check (lic == UnspecifiedLicense) $
- PackageDistInexcusable NoLicense
-
- , check (lic == AllRightsReserved) $
- PackageDistSuspicious AllRightsReservedLicense
-
- , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $
- PackageDistInexcusable (LicenseMessParse pkg)
-
- , case lic of
- UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l)
- _ -> Nothing
-
- , check (lic == BSD4) $
- PackageDistSuspicious UncommonBSD4
-
- , case unknownLicenseVersion lic of
- Just knownVersions -> Just $
- PackageDistSuspicious (UnknownLicenseVersion lic knownVersions)
- _ -> Nothing
-
- , check (lic `notElem` [ AllRightsReserved
- , UnspecifiedLicense, PublicDomain]
- -- AllRightsReserved and PublicDomain are not strictly
- -- licenses so don't need license files.
- && null (licenseFiles pkg)) $
- PackageDistSuspicious NoLicenseFile
- ]
+checkOldLicense pkg lic =
+ catMaybes
+ [ check (lic == UnspecifiedLicense) $
+ PackageDistInexcusable NoLicense
+ , check (lic == AllRightsReserved) $
+ PackageDistSuspicious AllRightsReservedLicense
+ , checkVersion CabalSpecV1_4 (lic `notElem` compatLicenses) $
+ PackageDistInexcusable (LicenseMessParse pkg)
+ , case lic of
+ UnknownLicense l -> Just $ PackageBuildWarning (UnrecognisedLicense l)
+ _ -> Nothing
+ , check (lic == BSD4) $
+ PackageDistSuspicious UncommonBSD4
+ , case unknownLicenseVersion lic of
+ Just knownVersions ->
+ Just $
+ PackageDistSuspicious (UnknownLicenseVersion lic knownVersions)
+ _ -> Nothing
+ , check
+ ( lic
+ `notElem` [ AllRightsReserved
+ , UnspecifiedLicense
+ , PublicDomain
+ ]
+ -- AllRightsReserved and PublicDomain are not strictly
+ -- licenses so don't need license files.
+ && null (licenseFiles pkg)
+ )
+ $ PackageDistSuspicious NoLicenseFile
+ ]
where
- unknownLicenseVersion (GPL (Just v))
+ unknownLicenseVersion (GPL (Just v))
| v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | GPL (Just v') <- knownLicenses ]
+ where
+ knownVersions = [v' | GPL (Just v') <- knownLicenses]
unknownLicenseVersion (LGPL (Just v))
| v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]
+ where
+ knownVersions = [v' | LGPL (Just v') <- knownLicenses]
unknownLicenseVersion (AGPL (Just v))
| v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]
- unknownLicenseVersion (Apache (Just v))
+ where
+ knownVersions = [v' | AGPL (Just v') <- knownLicenses]
+ unknownLicenseVersion (Apache (Just v))
| v `notElem` knownVersions = Just knownVersions
- where knownVersions = [ v' | Apache (Just v') <- knownLicenses ]
+ where
+ knownVersions = [v' | Apache (Just v') <- knownLicenses]
unknownLicenseVersion _ = Nothing
checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck
checkVersion ver cond pc
- | specVersion pkg >= ver = Nothing
- | otherwise = check cond pc
-
- compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4
- , PublicDomain, AllRightsReserved
- , UnspecifiedLicense, OtherLicense ]
+ | specVersion pkg >= ver = Nothing
+ | otherwise = check cond pc
+
+ compatLicenses =
+ [ GPL Nothing
+ , LGPL Nothing
+ , AGPL Nothing
+ , BSD3
+ , BSD4
+ , PublicDomain
+ , AllRightsReserved
+ , UnspecifiedLicense
+ , OtherLicense
+ ]
checkSourceRepos :: PackageDescription -> [PackageCheck]
checkSourceRepos pkg =
- catMaybes $ concat [[
-
- case repoKind repo of
- RepoKindUnknown kind -> Just $ PackageDistInexcusable $
- UnrecognisedSourceRepo kind
- _ -> Nothing
-
- , check (isNothing (repoType repo)) $
- PackageDistInexcusable MissingType
-
- , check (isNothing (repoLocation repo)) $
- PackageDistInexcusable MissingLocation
-
- , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $
- PackageDistInexcusable MissingModule
-
- , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $
- PackageDistInexcusable MissingTag
-
- , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $
- PackageDistInexcusable SubdirRelPath
-
- , do
- subdir <- repoSubdir repo
- err <- isGoodRelativeDirectoryPath subdir
- return $ PackageDistInexcusable (SubdirGoodRelPath err)
- ]
- | repo <- sourceRepos pkg ]
+ catMaybes $
+ concat
+ [ [ case repoKind repo of
+ RepoKindUnknown kind ->
+ Just $
+ PackageDistInexcusable $
+ UnrecognisedSourceRepo kind
+ _ -> Nothing
+ , check (isNothing (repoType repo)) $
+ PackageDistInexcusable MissingType
+ , check (isNothing (repoLocation repo)) $
+ PackageDistInexcusable MissingLocation
+ , check (repoType repo == Just (KnownRepoType CVS) && isNothing (repoModule repo)) $
+ PackageDistInexcusable MissingModule
+ , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $
+ PackageDistInexcusable MissingTag
+ , check (maybe False isAbsoluteOnAnyPlatform (repoSubdir repo)) $
+ PackageDistInexcusable SubdirRelPath
+ , do
+ subdir <- repoSubdir repo
+ err <- isGoodRelativeDirectoryPath subdir
+ return $ PackageDistInexcusable (SubdirGoodRelPath err)
+ ]
+ | repo <- sourceRepos pkg
+ ]
---TODO: check location looks like a URL for some repo types.
+-- TODO: check location looks like a URL for some repo types.
-- | Checks GHC options from all ghc-*-options fields in the given
-- PackageDescription and reports commonly misused or non-portable flags
checkAllGhcOptions :: PackageDescription -> [PackageCheck]
checkAllGhcOptions pkg =
- checkGhcOptions "ghc-options" (hcOptions GHC) pkg
- ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg
- ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg
+ checkGhcOptions "ghc-options" (hcOptions GHC) pkg
+ ++ checkGhcOptions "ghc-prof-options" (hcProfOptions GHC) pkg
+ ++ checkGhcOptions "ghc-shared-options" (hcSharedOptions GHC) pkg
-- | Extracts GHC options belonging to the given field from the given
-- PackageDescription using given function and checks them for commonly misused
-- or non-portable flags
checkGhcOptions :: String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck]
checkGhcOptions fieldName getOptions pkg =
- catMaybes [
-
- checkFlags ["-fasm"] $
- PackageDistInexcusable (OptFasm fieldName)
-
- , checkFlags ["-fvia-C"] $
- PackageDistSuspicious (OptViaC fieldName)
-
- , checkFlags ["-fhpc"] $
- PackageDistInexcusable (OptHpc fieldName)
-
- , checkFlags ["-prof"] $
- PackageBuildWarning (OptProf fieldName)
-
- , checkFlags ["-o"] $
- PackageBuildWarning (OptO fieldName)
-
- , checkFlags ["-hide-package"] $
- PackageBuildWarning (OptHide fieldName)
-
- , checkFlags ["--make"] $
- PackageBuildWarning (OptMake fieldName)
-
- , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $
- PackageDistSuspicious (OptONot fieldName)
-
- , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $
- PackageDistSuspiciousWarn (OptONot fieldName)
-
- , checkFlags [ "-O", "-O1"] $
- PackageDistInexcusable (OptOOne fieldName)
-
- , checkFlags ["-O2"] $
- PackageDistSuspiciousWarn (OptOTwo fieldName)
-
- , checkFlags ["-split-sections"] $
- PackageBuildWarning (OptSplitSections fieldName)
-
- , checkFlags ["-split-objs"] $
- PackageBuildWarning (OptSplitObjs fieldName)
-
- , checkFlags ["-optl-Wl,-s", "-optl-s"] $
- PackageDistInexcusable (OptWls fieldName)
-
- , checkFlags ["-fglasgow-exts"] $
- PackageDistSuspicious (OptExts fieldName)
-
- , check ("-rtsopts" `elem` lib_ghc_options) $
- PackageBuildWarning (OptRts fieldName)
-
- , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $
- PackageBuildWarning (OptWithRts fieldName)
-
- , checkAlternatives fieldName "extensions"
- [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts
- , Just extension <- [ghcExtension flag] ]
-
- , checkAlternatives fieldName "extensions"
- [ (flag, extension) | flag@('-':'X':extension) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "cpp-options" $
- [ (flag, flag) | flag@('-':'D':_) <- ghc_options_no_rtsopts ]
- ++ [ (flag, flag) | flag@('-':'U':_) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "include-dirs"
- [ (flag, dir) | flag@('-':'I':dir) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "extra-libraries"
- [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "extra-libraries-static"
- [ (flag, lib) | flag@('-':'l':lib) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "extra-lib-dirs"
- [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "extra-lib-dirs-static"
- [ (flag, dir) | flag@('-':'L':dir) <- ghc_options_no_rtsopts ]
-
- , checkAlternatives fieldName "frameworks"
- [ (flag, fmwk) | (flag@"-framework", fmwk) <-
- zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ]
-
- , checkAlternatives fieldName "extra-framework-dirs"
- [ (flag, dir) | (flag@"-framework-path", dir) <-
- zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts) ]
- ]
-
+ catMaybes
+ [ checkFlags ["-fasm"] $
+ PackageDistInexcusable (OptFasm fieldName)
+ , checkFlags ["-fvia-C"] $
+ PackageDistSuspicious (OptViaC fieldName)
+ , checkFlags ["-fhpc"] $
+ PackageDistInexcusable (OptHpc fieldName)
+ , checkFlags ["-prof"] $
+ PackageBuildWarning (OptProf fieldName)
+ , checkFlags ["-o"] $
+ PackageBuildWarning (OptO fieldName)
+ , checkFlags ["-hide-package"] $
+ PackageBuildWarning (OptHide fieldName)
+ , checkFlags ["--make"] $
+ PackageBuildWarning (OptMake fieldName)
+ , checkNonTestAndBenchmarkFlags ["-O0", "-Onot"] $
+ PackageDistSuspicious (OptONot fieldName)
+ , checkTestAndBenchmarkFlags ["-O0", "-Onot"] $
+ PackageDistSuspiciousWarn (OptONot fieldName)
+ , checkFlags ["-O", "-O1"] $
+ PackageDistInexcusable (OptOOne fieldName)
+ , checkFlags ["-O2"] $
+ PackageDistSuspiciousWarn (OptOTwo fieldName)
+ , checkFlags ["-split-sections"] $
+ PackageBuildWarning (OptSplitSections fieldName)
+ , checkFlags ["-split-objs"] $
+ PackageBuildWarning (OptSplitObjs fieldName)
+ , checkFlags ["-optl-Wl,-s", "-optl-s"] $
+ PackageDistInexcusable (OptWls fieldName)
+ , checkFlags ["-fglasgow-exts"] $
+ PackageDistSuspicious (OptExts fieldName)
+ , check ("-rtsopts" `elem` lib_ghc_options) $
+ PackageBuildWarning (OptRts fieldName)
+ , check (any (\opt -> "-with-rtsopts" `isPrefixOf` opt) lib_ghc_options) $
+ PackageBuildWarning (OptWithRts fieldName)
+ , checkAlternatives
+ fieldName
+ "extensions"
+ [ (flag, prettyShow extension) | flag <- ghc_options_no_rtsopts, Just extension <- [ghcExtension flag]
+ ]
+ , checkAlternatives
+ fieldName
+ "extensions"
+ [(flag, extension) | flag@('-' : 'X' : extension) <- ghc_options_no_rtsopts]
+ , checkAlternatives fieldName "cpp-options" $
+ [(flag, flag) | flag@('-' : 'D' : _) <- ghc_options_no_rtsopts]
+ ++ [(flag, flag) | flag@('-' : 'U' : _) <- ghc_options_no_rtsopts]
+ , checkAlternatives
+ fieldName
+ "include-dirs"
+ [(flag, dir) | flag@('-' : 'I' : dir) <- ghc_options_no_rtsopts]
+ , checkAlternatives
+ fieldName
+ "extra-libraries"
+ [(flag, lib) | flag@('-' : 'l' : lib) <- ghc_options_no_rtsopts]
+ , checkAlternatives
+ fieldName
+ "extra-libraries-static"
+ [(flag, lib) | flag@('-' : 'l' : lib) <- ghc_options_no_rtsopts]
+ , checkAlternatives
+ fieldName
+ "extra-lib-dirs"
+ [(flag, dir) | flag@('-' : 'L' : dir) <- ghc_options_no_rtsopts]
+ , checkAlternatives
+ fieldName
+ "extra-lib-dirs-static"
+ [(flag, dir) | flag@('-' : 'L' : dir) <- ghc_options_no_rtsopts]
+ , checkAlternatives
+ fieldName
+ "frameworks"
+ [ (flag, fmwk)
+ | (flag@"-framework", fmwk) <-
+ zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts)
+ ]
+ , checkAlternatives
+ fieldName
+ "extra-framework-dirs"
+ [ (flag, dir)
+ | (flag@"-framework-path", dir) <-
+ zip ghc_options_no_rtsopts (safeTail ghc_options_no_rtsopts)
+ ]
+ ]
where
- all_ghc_options = concatMap getOptions (allBuildInfo pkg)
+ all_ghc_options = concatMap getOptions (allBuildInfo pkg)
ghc_options_no_rtsopts = rmRtsOpts all_ghc_options
- lib_ghc_options = concatMap (getOptions . libBuildInfo)
- (allLibraries pkg)
- test_ghc_options = concatMap (getOptions . testBuildInfo)
- (testSuites pkg)
- benchmark_ghc_options = concatMap (getOptions . benchmarkBuildInfo)
- (benchmarks pkg)
- test_and_benchmark_ghc_options = test_ghc_options ++
- benchmark_ghc_options
- non_test_and_benchmark_ghc_options = concatMap getOptions
- (allBuildInfo (pkg { testSuites = []
- , benchmarks = []
- }))
+ lib_ghc_options =
+ concatMap
+ (getOptions . libBuildInfo)
+ (allLibraries pkg)
+ test_ghc_options =
+ concatMap
+ (getOptions . testBuildInfo)
+ (testSuites pkg)
+ benchmark_ghc_options =
+ concatMap
+ (getOptions . benchmarkBuildInfo)
+ (benchmarks pkg)
+ test_and_benchmark_ghc_options =
+ test_ghc_options
+ ++ benchmark_ghc_options
+ non_test_and_benchmark_ghc_options =
+ concatMap
+ getOptions
+ ( allBuildInfo
+ ( pkg
+ { testSuites = []
+ , benchmarks = []
+ }
+ )
+ )
checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkFlags flags = check (any (`elem` flags) all_ghc_options)
@@ -1496,50 +1646,49 @@ checkGhcOptions fieldName getOptions pkg =
checkNonTestAndBenchmarkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkNonTestAndBenchmarkFlags flags = check (any (`elem` flags) non_test_and_benchmark_ghc_options)
- ghcExtension ('-':'f':name) = case name of
- "allow-overlapping-instances" -> enable OverlappingInstances
+ ghcExtension ('-' : 'f' : name) = case name of
+ "allow-overlapping-instances" -> enable OverlappingInstances
"no-allow-overlapping-instances" -> disable OverlappingInstances
- "th" -> enable TemplateHaskell
- "no-th" -> disable TemplateHaskell
- "ffi" -> enable ForeignFunctionInterface
- "no-ffi" -> disable ForeignFunctionInterface
- "fi" -> enable ForeignFunctionInterface
- "no-fi" -> disable ForeignFunctionInterface
- "monomorphism-restriction" -> enable MonomorphismRestriction
- "no-monomorphism-restriction" -> disable MonomorphismRestriction
- "mono-pat-binds" -> enable MonoPatBinds
- "no-mono-pat-binds" -> disable MonoPatBinds
- "allow-undecidable-instances" -> enable UndecidableInstances
+ "th" -> enable TemplateHaskell
+ "no-th" -> disable TemplateHaskell
+ "ffi" -> enable ForeignFunctionInterface
+ "no-ffi" -> disable ForeignFunctionInterface
+ "fi" -> enable ForeignFunctionInterface
+ "no-fi" -> disable ForeignFunctionInterface
+ "monomorphism-restriction" -> enable MonomorphismRestriction
+ "no-monomorphism-restriction" -> disable MonomorphismRestriction
+ "mono-pat-binds" -> enable MonoPatBinds
+ "no-mono-pat-binds" -> disable MonoPatBinds
+ "allow-undecidable-instances" -> enable UndecidableInstances
"no-allow-undecidable-instances" -> disable UndecidableInstances
- "allow-incoherent-instances" -> enable IncoherentInstances
- "no-allow-incoherent-instances" -> disable IncoherentInstances
- "arrows" -> enable Arrows
- "no-arrows" -> disable Arrows
- "generics" -> enable Generics
- "no-generics" -> disable Generics
- "implicit-prelude" -> enable ImplicitPrelude
- "no-implicit-prelude" -> disable ImplicitPrelude
- "implicit-params" -> enable ImplicitParams
- "no-implicit-params" -> disable ImplicitParams
- "bang-patterns" -> enable BangPatterns
- "no-bang-patterns" -> disable BangPatterns
- "scoped-type-variables" -> enable ScopedTypeVariables
- "no-scoped-type-variables" -> disable ScopedTypeVariables
- "extended-default-rules" -> enable ExtendedDefaultRules
- "no-extended-default-rules" -> disable ExtendedDefaultRules
- _ -> Nothing
- ghcExtension "-cpp" = enable CPP
- ghcExtension _ = Nothing
-
- enable e = Just (EnableExtension e)
+ "allow-incoherent-instances" -> enable IncoherentInstances
+ "no-allow-incoherent-instances" -> disable IncoherentInstances
+ "arrows" -> enable Arrows
+ "no-arrows" -> disable Arrows
+ "generics" -> enable Generics
+ "no-generics" -> disable Generics
+ "implicit-prelude" -> enable ImplicitPrelude
+ "no-implicit-prelude" -> disable ImplicitPrelude
+ "implicit-params" -> enable ImplicitParams
+ "no-implicit-params" -> disable ImplicitParams
+ "bang-patterns" -> enable BangPatterns
+ "no-bang-patterns" -> disable BangPatterns
+ "scoped-type-variables" -> enable ScopedTypeVariables
+ "no-scoped-type-variables" -> disable ScopedTypeVariables
+ "extended-default-rules" -> enable ExtendedDefaultRules
+ "no-extended-default-rules" -> disable ExtendedDefaultRules
+ _ -> Nothing
+ ghcExtension "-cpp" = enable CPP
+ ghcExtension _ = Nothing
+
+ enable e = Just (EnableExtension e)
disable e = Just (DisableExtension e)
rmRtsOpts :: [String] -> [String]
- rmRtsOpts ("-with-rtsopts":_:xs) = rmRtsOpts xs
- rmRtsOpts (x:xs) = x : rmRtsOpts xs
+ rmRtsOpts ("-with-rtsopts" : _ : xs) = rmRtsOpts xs
+ rmRtsOpts (x : xs) = x : rmRtsOpts xs
rmRtsOpts [] = []
-
checkCCOptions :: PackageDescription -> [PackageCheck]
checkCCOptions = checkCLikeOptions "C" "cc-options" ccOptions
@@ -1548,283 +1697,294 @@ checkCxxOptions = checkCLikeOptions "C++" "cxx-options" cxxOptions
checkCLikeOptions :: String -> String -> (BuildInfo -> [String]) -> PackageDescription -> [PackageCheck]
checkCLikeOptions label prefix accessor pkg =
- catMaybes [
-
- checkAlternatives prefix "include-dirs"
- [ (flag, dir) | flag@('-':'I':dir) <- all_cLikeOptions ]
-
- , checkAlternatives prefix "extra-libraries"
- [ (flag, lib) | flag@('-':'l':lib) <- all_cLikeOptions ]
-
- , checkAlternatives prefix "extra-lib-dirs"
- [ (flag, dir) | flag@('-':'L':dir) <- all_cLikeOptions ]
-
- , checkAlternatives "ld-options" "extra-libraries"
- [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]
-
- , checkAlternatives "ld-options" "extra-lib-dirs"
- [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]
-
- , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $
- PackageDistSuspicious (COptONumber prefix label)
- ]
-
- where all_cLikeOptions = [ opts | bi <- allBuildInfo pkg
- , opts <- accessor bi ]
- all_ldOptions = [ opts | bi <- allBuildInfo pkg
- , opts <- ldOptions bi ]
+ catMaybes
+ [ checkAlternatives
+ prefix
+ "include-dirs"
+ [(flag, dir) | flag@('-' : 'I' : dir) <- all_cLikeOptions]
+ , checkAlternatives
+ prefix
+ "extra-libraries"
+ [(flag, lib) | flag@('-' : 'l' : lib) <- all_cLikeOptions]
+ , checkAlternatives
+ prefix
+ "extra-lib-dirs"
+ [(flag, dir) | flag@('-' : 'L' : dir) <- all_cLikeOptions]
+ , checkAlternatives
+ "ld-options"
+ "extra-libraries"
+ [(flag, lib) | flag@('-' : 'l' : lib) <- all_ldOptions]
+ , checkAlternatives
+ "ld-options"
+ "extra-lib-dirs"
+ [(flag, dir) | flag@('-' : 'L' : dir) <- all_ldOptions]
+ , checkCCFlags ["-O", "-Os", "-O0", "-O1", "-O2", "-O3"] $
+ PackageDistSuspicious (COptONumber prefix label)
+ ]
+ where
+ all_cLikeOptions =
+ [ opts | bi <- allBuildInfo pkg, opts <- accessor bi
+ ]
+ all_ldOptions =
+ [ opts | bi <- allBuildInfo pkg, opts <- ldOptions bi
+ ]
- checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
- checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions)
+ checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+ checkCCFlags flags = check (any (`elem` flags) all_cLikeOptions)
checkCPPOptions :: PackageDescription -> [PackageCheck]
-checkCPPOptions pkg = catMaybes
- [ checkAlternatives "cpp-options" "include-dirs"
- [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions ]
- ]
- ++
- [ PackageBuildWarning (COptCPP opt)
- | opt <- all_cppOptions
- -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF
- , not $ any (`isPrefixOf` opt) ["-D", "-U", "-I" ]
+checkCPPOptions pkg =
+ catMaybes
+ [ checkAlternatives
+ "cpp-options"
+ "include-dirs"
+ [(flag, dir) | flag@('-' : 'I' : dir) <- all_cppOptions]
]
+ ++ [ PackageBuildWarning (COptCPP opt)
+ | opt <- all_cppOptions
+ , -- "-I" is handled above, we allow only -DNEWSTUFF and -UOLDSTUFF
+ not $ any (`isPrefixOf` opt) ["-D", "-U", "-I"]
+ ]
where
- all_cppOptions = [ opts | bi <- allBuildInfo pkg, opts <- cppOptions bi ]
+ all_cppOptions = [opts | bi <- allBuildInfo pkg, opts <- cppOptions bi]
-checkAlternatives :: String -> String -> [(String, String)]
- -> Maybe PackageCheck
+checkAlternatives
+ :: String
+ -> String
+ -> [(String, String)]
+ -> Maybe PackageCheck
checkAlternatives badField goodField flags =
check (not (null badFlags)) $
PackageBuildWarning (OptAlternatives badField goodField flags)
- where (badFlags, _) = unzip flags
+ where
+ (badFlags, _) = unzip flags
data PathKind
- = PathKindFile
- | PathKindDirectory
- | PathKindGlob
+ = PathKindFile
+ | PathKindDirectory
+ | PathKindGlob
deriving (Eq)
checkPaths :: PackageDescription -> [PackageCheck]
checkPaths pkg =
checkPackageFileNamesWithGlob
- [ (kind == PathKindGlob, path)
- | (path, _, kind) <- relPaths ++ absPaths
- ]
- ++
- [ PackageBuildWarning (RelativeOutside field path)
- | (path, field, _) <- relPaths ++ absPaths
- , isOutsideTree path ]
- ++
- [ PackageDistInexcusable (AbsolutePath field path)
- | (path, field, _) <- relPaths
- , isAbsoluteOnAnyPlatform path ]
- ++
- [ PackageDistInexcusable (BadRelativePAth field path err)
- | (path, field, kind) <- relPaths
- -- these are not paths, but globs...
- , err <- maybeToList $ case kind of
- PathKindFile -> isGoodRelativeFilePath path
- PathKindGlob -> isGoodRelativeGlob path
- PathKindDirectory -> isGoodRelativeDirectoryPath path
- ]
- ++
- [ PackageDistInexcusable $ DistPoint (Just field) path
- | (path, field, _) <- relPaths ++ absPaths
- , isInsideDist path ]
- ++
- [ PackageDistInexcusable (DistPoint Nothing path)
- | bi <- allBuildInfo pkg
- , (GHC, flags) <- perCompilerFlavorToList $ options bi
- , path <- flags
- , isInsideDist path ]
- ++
- [ PackageDistInexcusable $
- GlobSyntaxError "data-files" (explainGlobSyntaxError pat err)
- | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg
- ]
- ++
- [ PackageDistInexcusable
- (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err))
- | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg
- ]
- ++
- [ PackageDistInexcusable $
- GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err)
- | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg
- ]
- ++
- [ PackageDistSuspiciousWarn $
- RecursiveGlobInRoot "data-files" pat
- | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg
- , isRecursiveInRoot glob
- ]
- ++
- [ PackageDistSuspiciousWarn $
- RecursiveGlobInRoot "extra-source-files" pat
- | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg
- , isRecursiveInRoot glob
- ]
- ++
- [ PackageDistSuspiciousWarn $
- RecursiveGlobInRoot "extra-doc-files" pat
- | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg
- , isRecursiveInRoot glob
- ]
+ [ (kind == PathKindGlob, path)
+ | (path, _, kind) <- relPaths ++ absPaths
+ ]
+ ++ [ PackageBuildWarning (RelativeOutside field path)
+ | (path, field, _) <- relPaths ++ absPaths
+ , isOutsideTree path
+ ]
+ ++ [ PackageDistInexcusable (AbsolutePath field path)
+ | (path, field, _) <- relPaths
+ , isAbsoluteOnAnyPlatform path
+ ]
+ ++ [ PackageDistInexcusable (BadRelativePAth field path err)
+ | (path, field, kind) <- relPaths
+ , -- these are not paths, but globs...
+ err <- maybeToList $ case kind of
+ PathKindFile -> isGoodRelativeFilePath path
+ PathKindGlob -> isGoodRelativeGlob path
+ PathKindDirectory -> isGoodRelativeDirectoryPath path
+ ]
+ ++ [ PackageDistInexcusable $ DistPoint (Just field) path
+ | (path, field, _) <- relPaths ++ absPaths
+ , isInsideDist path
+ ]
+ ++ [ PackageDistInexcusable (DistPoint Nothing path)
+ | bi <- allBuildInfo pkg
+ , (GHC, flags) <- perCompilerFlavorToList $ options bi
+ , path <- flags
+ , isInsideDist path
+ ]
+ ++ [ PackageDistInexcusable $
+ GlobSyntaxError "data-files" (explainGlobSyntaxError pat err)
+ | (Left err, pat) <- zip globsDataFiles $ dataFiles pkg
+ ]
+ ++ [ PackageDistInexcusable
+ (GlobSyntaxError "extra-source-files" (explainGlobSyntaxError pat err))
+ | (Left err, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg
+ ]
+ ++ [ PackageDistInexcusable $
+ GlobSyntaxError "extra-doc-files" (explainGlobSyntaxError pat err)
+ | (Left err, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg
+ ]
+ ++ [ PackageDistSuspiciousWarn $
+ RecursiveGlobInRoot "data-files" pat
+ | (Right glob, pat) <- zip globsDataFiles $ dataFiles pkg
+ , isRecursiveInRoot glob
+ ]
+ ++ [ PackageDistSuspiciousWarn $
+ RecursiveGlobInRoot "extra-source-files" pat
+ | (Right glob, pat) <- zip globsExtraSrcFiles $ extraSrcFiles pkg
+ , isRecursiveInRoot glob
+ ]
+ ++ [ PackageDistSuspiciousWarn $
+ RecursiveGlobInRoot "extra-doc-files" pat
+ | (Right glob, pat) <- zip globsExtraDocFiles $ extraDocFiles pkg
+ , isRecursiveInRoot glob
+ ]
where
isOutsideTree path = case splitDirectories path of
- "..":_ -> True
- ".":"..":_ -> True
- _ -> False
+ ".." : _ -> True
+ "." : ".." : _ -> True
+ _ -> False
isInsideDist path = case map lowercase (splitDirectories path) of
- "dist" :_ -> True
- ".":"dist":_ -> True
- _ -> False
+ "dist" : _ -> True
+ "." : "dist" : _ -> True
+ _ -> False
-- paths that must be relative
relPaths :: [(FilePath, String, PathKind)]
relPaths =
- [ (path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg ] ++
- [ (path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg ] ++
- [ (path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg ] ++
- [ (path, "data-files", PathKindGlob) | path <- dataFiles pkg ] ++
- [ (path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]] ++
- [ (path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg ] ++
- concat
- [ [ (path, "asm-sources", PathKindFile) | path <- asmSources bi ] ++
- [ (path, "cmm-sources", PathKindFile) | path <- cmmSources bi ] ++
- [ (path, "c-sources", PathKindFile) | path <- cSources bi ] ++
- [ (path, "cxx-sources", PathKindFile) | path <- cxxSources bi ] ++
- [ (path, "js-sources", PathKindFile) | path <- jsSources bi ] ++
- [ (path, "install-includes", PathKindFile) | path <- installIncludes bi ] ++
- [ (path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi ]
- | bi <- allBuildInfo pkg
- ]
+ [(path, "extra-source-files", PathKindGlob) | path <- extraSrcFiles pkg]
+ ++ [(path, "extra-tmp-files", PathKindFile) | path <- extraTmpFiles pkg]
+ ++ [(path, "extra-doc-files", PathKindGlob) | path <- extraDocFiles pkg]
+ ++ [(path, "data-files", PathKindGlob) | path <- dataFiles pkg]
+ ++ [(path, "data-dir", PathKindDirectory) | path <- [dataDir pkg]]
+ ++ [(path, "license-file", PathKindFile) | path <- map getSymbolicPath $ licenseFiles pkg]
+ ++ concat
+ [ [(path, "asm-sources", PathKindFile) | path <- asmSources bi]
+ ++ [(path, "cmm-sources", PathKindFile) | path <- cmmSources bi]
+ ++ [(path, "c-sources", PathKindFile) | path <- cSources bi]
+ ++ [(path, "cxx-sources", PathKindFile) | path <- cxxSources bi]
+ ++ [(path, "js-sources", PathKindFile) | path <- jsSources bi]
+ ++ [(path, "install-includes", PathKindFile) | path <- installIncludes bi]
+ ++ [(path, "hs-source-dirs", PathKindDirectory) | path <- map getSymbolicPath $ hsSourceDirs bi]
+ | bi <- allBuildInfo pkg
+ ]
-- paths that are allowed to be absolute
absPaths :: [(FilePath, String, PathKind)]
- absPaths = concat
- [ [ (path, "includes", PathKindFile) | path <- includes bi ] ++
- [ (path, "include-dirs", PathKindDirectory) | path <- includeDirs bi ] ++
- [ (path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi ] ++
- [ (path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi ]
- | bi <- allBuildInfo pkg
- ]
+ absPaths =
+ concat
+ [ [(path, "includes", PathKindFile) | path <- includes bi]
+ ++ [(path, "include-dirs", PathKindDirectory) | path <- includeDirs bi]
+ ++ [(path, "extra-lib-dirs", PathKindDirectory) | path <- extraLibDirs bi]
+ ++ [(path, "extra-lib-dirs-static", PathKindDirectory) | path <- extraLibDirsStatic bi]
+ | bi <- allBuildInfo pkg
+ ]
globsDataFiles :: [Either GlobSyntaxError Glob]
- globsDataFiles = parseFileGlob (specVersion pkg) <$> dataFiles pkg
+ globsDataFiles = parseFileGlob (specVersion pkg) <$> dataFiles pkg
globsExtraSrcFiles :: [Either GlobSyntaxError Glob]
- globsExtraSrcFiles = parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg
+ globsExtraSrcFiles = parseFileGlob (specVersion pkg) <$> extraSrcFiles pkg
globsExtraDocFiles :: [Either GlobSyntaxError Glob]
- globsExtraDocFiles = parseFileGlob (specVersion pkg) <$> extraDocFiles pkg
+ globsExtraDocFiles = parseFileGlob (specVersion pkg) <$> extraDocFiles pkg
---TODO: check sets of paths that would be interpreted differently between Unix
+-- TODO: check sets of paths that would be interpreted differently between Unix
-- and windows, ie case-sensitive or insensitive. Things that might clash, or
-- conversely be distinguished.
---TODO: use the tar path checks on all the above paths
+-- TODO: use the tar path checks on all the above paths
-- | Check that the package declares the version in the @\"cabal-version\"@
-- field correctly.
---
checkCabalVersion :: PackageDescription -> [PackageCheck]
checkCabalVersion pkg =
- catMaybes [
-
- -- check use of test suite sections
- checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $
- PackageDistInexcusable CVTestSuite
-
- -- check use of default-language field
- -- note that we do not need to do an equivalent check for the
- -- other-language field since that one does not change behaviour
- , checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $
- PackageBuildWarning CVDefaultLanguage
-
- , check (specVersion pkg >= CabalSpecV1_10 && specVersion pkg < CabalSpecV3_4
- && any isNothing (buildInfoField defaultLanguage)) $
- PackageBuildWarning CVDefaultLanguageComponent
-
- , checkVersion CabalSpecV1_18
- (not . null $ extraDocFiles pkg) $
- PackageDistInexcusable CVExtraDocFiles
-
- , checkVersion CabalSpecV2_0
- (not (null (subLibraries pkg))) $
- PackageDistInexcusable CVMultiLib
-
- -- check use of reexported-modules sections
- , checkVersion CabalSpecV1_22
- (any (not.null.reexportedModules) (allLibraries pkg)) $
- PackageDistInexcusable CVReexported
-
- -- check use of thinning and renaming
- , checkVersion CabalSpecV2_0 usesBackpackIncludes $
- PackageDistInexcusable CVMixins
-
- -- check use of 'extra-framework-dirs' field
- , checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $
- -- Just a warning, because this won't break on old Cabal versions.
- PackageDistSuspiciousWarn CVExtraFrameworkDirs
-
- -- check use of default-extensions field
- -- don't need to do the equivalent check for other-extensions
- , checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $
- PackageBuildWarning CVDefaultExtensions
-
- -- check use of extensions field
- , check (specVersion pkg >= CabalSpecV1_10
- && any (not . null) (buildInfoField oldExtensions)) $
- PackageBuildWarning CVExtensionsDeprecated
-
- , checkVersion CabalSpecV3_0 (any (not . null)
- (concatMap buildInfoField
- [ asmSources
- , cmmSources
- , extraBundledLibs
- , extraLibFlavours ])) $
- PackageDistInexcusable CVSources
-
- , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $
- PackageDistInexcusable
- (CVExtraDynamic $ buildInfoField extraDynLibFlavours)
-
- , checkVersion CabalSpecV2_2 (any (not . null)
- (buildInfoField virtualModules)) $
- PackageDistInexcusable CVVirtualModules
-
- -- check use of "source-repository" section
- , checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $
- PackageDistInexcusable CVSourceRepository
-
- -- check for new language extensions
- , checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $
- PackageDistInexcusable
- (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12)
-
- , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $
- PackageDistInexcusable
- (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14)
-
- , check (specVersion pkg >= CabalSpecV1_24
- && isNothing (setupBuildInfo pkg)
- && buildType pkg == Custom) $
- PackageBuildWarning CVCustomSetup
-
- , check (specVersion pkg < CabalSpecV1_24
- && isNothing (setupBuildInfo pkg)
- && buildType pkg == Custom) $
- PackageDistSuspiciousWarn CVExpliticDepsCustomSetup
-
- , check (specVersion pkg >= CabalSpecV2_0
- && elem (autogenPathsModuleName pkg) allModuleNames
- && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen) ) $
- PackageDistInexcusable CVAutogenPaths
-
- , check (specVersion pkg >= CabalSpecV2_0
- && elem (autogenPackageInfoModuleName pkg) allModuleNames
- && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen) ) $
- PackageDistInexcusable CVAutogenPackageInfo
-
- ]
+ catMaybes
+ [ -- check use of test suite sections
+ checkVersion CabalSpecV1_8 (not (null $ testSuites pkg)) $
+ PackageDistInexcusable CVTestSuite
+ , -- check use of default-language field
+ -- note that we do not need to do an equivalent check for the
+ -- other-language field since that one does not change behaviour
+ checkVersion CabalSpecV1_10 (any isJust (buildInfoField defaultLanguage)) $
+ PackageBuildWarning CVDefaultLanguage
+ , check
+ ( specVersion pkg >= CabalSpecV1_10
+ && specVersion pkg < CabalSpecV3_4
+ && any isNothing (buildInfoField defaultLanguage)
+ )
+ $ PackageBuildWarning CVDefaultLanguageComponent
+ , checkVersion
+ CabalSpecV1_18
+ (not . null $ extraDocFiles pkg)
+ $ PackageDistInexcusable CVExtraDocFiles
+ , checkVersion
+ CabalSpecV2_0
+ (not (null (subLibraries pkg)))
+ $ PackageDistInexcusable CVMultiLib
+ , -- check use of reexported-modules sections
+ checkVersion
+ CabalSpecV1_22
+ (any (not . null . reexportedModules) (allLibraries pkg))
+ $ PackageDistInexcusable CVReexported
+ , -- check use of thinning and renaming
+ checkVersion CabalSpecV2_0 usesBackpackIncludes $
+ PackageDistInexcusable CVMixins
+ , -- check use of 'extra-framework-dirs' field
+ checkVersion CabalSpecV1_24 (any (not . null) (buildInfoField extraFrameworkDirs)) $
+ -- Just a warning, because this won't break on old Cabal versions.
+ PackageDistSuspiciousWarn CVExtraFrameworkDirs
+ , -- check use of default-extensions field
+ -- don't need to do the equivalent check for other-extensions
+ checkVersion CabalSpecV1_10 (any (not . null) (buildInfoField defaultExtensions)) $
+ PackageBuildWarning CVDefaultExtensions
+ , -- check use of extensions field
+ check
+ ( specVersion pkg >= CabalSpecV1_10
+ && any (not . null) (buildInfoField oldExtensions)
+ )
+ $ PackageBuildWarning CVExtensionsDeprecated
+ , checkVersion
+ CabalSpecV3_0
+ ( any
+ (not . null)
+ ( concatMap
+ buildInfoField
+ [ asmSources
+ , cmmSources
+ , extraBundledLibs
+ , extraLibFlavours
+ ]
+ )
+ )
+ $ PackageDistInexcusable CVSources
+ , checkVersion CabalSpecV3_0 (any (not . null) $ buildInfoField extraDynLibFlavours) $
+ PackageDistInexcusable
+ (CVExtraDynamic $ buildInfoField extraDynLibFlavours)
+ , checkVersion
+ CabalSpecV2_2
+ ( any
+ (not . null)
+ (buildInfoField virtualModules)
+ )
+ $ PackageDistInexcusable CVVirtualModules
+ , -- check use of "source-repository" section
+ checkVersion CabalSpecV1_6 (not (null (sourceRepos pkg))) $
+ PackageDistInexcusable CVSourceRepository
+ , -- check for new language extensions
+ checkVersion CabalSpecV1_2 (not (null mentionedExtensionsThatNeedCabal12)) $
+ PackageDistInexcusable
+ (CVExtensions CabalSpecV1_2 mentionedExtensionsThatNeedCabal12)
+ , checkVersion CabalSpecV1_4 (not (null mentionedExtensionsThatNeedCabal14)) $
+ PackageDistInexcusable
+ (CVExtensions CabalSpecV1_4 mentionedExtensionsThatNeedCabal14)
+ , check
+ ( specVersion pkg >= CabalSpecV1_24
+ && isNothing (setupBuildInfo pkg)
+ && buildType pkg == Custom
+ )
+ $ PackageBuildWarning CVCustomSetup
+ , check
+ ( specVersion pkg < CabalSpecV1_24
+ && isNothing (setupBuildInfo pkg)
+ && buildType pkg == Custom
+ )
+ $ PackageDistSuspiciousWarn CVExpliticDepsCustomSetup
+ , check
+ ( specVersion pkg >= CabalSpecV2_0
+ && elem (autogenPathsModuleName pkg) allModuleNames
+ && not (elem (autogenPathsModuleName pkg) allModuleNamesAutogen)
+ )
+ $ PackageDistInexcusable CVAutogenPaths
+ , check
+ ( specVersion pkg >= CabalSpecV2_0
+ && elem (autogenPackageInfoModuleName pkg) allModuleNames
+ && not (elem (autogenPackageInfoModuleName pkg) allModuleNamesAutogen)
+ )
+ $ PackageDistInexcusable CVAutogenPackageInfo
+ ]
where
-- Perform a check on packages that use a version of the spec less than
-- the version given. This is for cases where a new Cabal version adds
@@ -1833,14 +1993,15 @@ checkCabalVersion pkg =
checkVersion :: CabalSpecVersion -> Bool -> PackageCheck -> Maybe PackageCheck
checkVersion ver cond pc
| specVersion pkg >= ver = Nothing
- | otherwise = check cond pc
+ | otherwise = check cond pc
- buildInfoField field = map field (allBuildInfo pkg)
+ buildInfoField field = map field (allBuildInfo pkg)
usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg)
- mentionedExtensions = [ ext | bi <- allBuildInfo pkg
- , ext <- allExtensions bi ]
+ mentionedExtensions =
+ [ ext | bi <- allBuildInfo pkg, ext <- allExtensions bi
+ ]
mentionedExtensionsThatNeedCabal12 =
nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)
@@ -1851,152 +2012,190 @@ checkCabalVersion pkg =
-- The known extensions in Cabal-1.2.3
compatExtensions =
- map EnableExtension
- [ OverlappingInstances, UndecidableInstances, IncoherentInstances
- , RecursiveDo, ParallelListComp, MultiParamTypeClasses
- , FunctionalDependencies, Rank2Types
- , RankNTypes, PolymorphicComponents, ExistentialQuantification
- , ScopedTypeVariables, ImplicitParams, FlexibleContexts
- , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns
- , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface
- , Arrows, Generics, NamedFieldPuns, PatternGuards
- , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms
- , HereDocuments] ++
- map DisableExtension
- [MonomorphismRestriction, ImplicitPrelude] ++
- compatExtensionsExtra
+ map
+ EnableExtension
+ [ OverlappingInstances
+ , UndecidableInstances
+ , IncoherentInstances
+ , RecursiveDo
+ , ParallelListComp
+ , MultiParamTypeClasses
+ , FunctionalDependencies
+ , Rank2Types
+ , RankNTypes
+ , PolymorphicComponents
+ , ExistentialQuantification
+ , ScopedTypeVariables
+ , ImplicitParams
+ , FlexibleContexts
+ , FlexibleInstances
+ , EmptyDataDecls
+ , CPP
+ , BangPatterns
+ , TypeSynonymInstances
+ , TemplateHaskell
+ , ForeignFunctionInterface
+ , Arrows
+ , Generics
+ , NamedFieldPuns
+ , PatternGuards
+ , GeneralizedNewtypeDeriving
+ , ExtensibleRecords
+ , RestrictedTypeSynonyms
+ , HereDocuments
+ ]
+ ++ map
+ DisableExtension
+ [MonomorphismRestriction, ImplicitPrelude]
+ ++ compatExtensionsExtra
-- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6
-- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)
compatExtensionsExtra =
- map EnableExtension
- [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving
- , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms
- , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields
- , OverloadedStrings, GADTs, RelaxedPolyRec
- , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable
- , ConstrainedClassMethods
- ] ++
- map DisableExtension
- [MonoPatBinds]
+ map
+ EnableExtension
+ [ KindSignatures
+ , MagicHash
+ , TypeFamilies
+ , StandaloneDeriving
+ , UnicodeSyntax
+ , PatternSignatures
+ , UnliftedFFITypes
+ , LiberalTypeSynonyms
+ , TypeOperators
+ , RecordWildCards
+ , RecordPuns
+ , DisambiguateRecordFields
+ , OverloadedStrings
+ , GADTs
+ , RelaxedPolyRec
+ , ExtendedDefaultRules
+ , UnboxedTuples
+ , DeriveDataTypeable
+ , ConstrainedClassMethods
+ ]
+ ++ map
+ DisableExtension
+ [MonoPatBinds]
allModuleNames =
- (case library pkg of
- Nothing -> []
- (Just lib) -> explicitLibModules lib
- )
- ++ concatMap otherModules (allBuildInfo pkg)
+ ( case library pkg of
+ Nothing -> []
+ (Just lib) -> explicitLibModules lib
+ )
+ ++ concatMap otherModules (allBuildInfo pkg)
allModuleNamesAutogen = concatMap autogenModules (allBuildInfo pkg)
-- ------------------------------------------------------------
+
-- * Checks on the GenericPackageDescription
+
-- ------------------------------------------------------------
-- | Check the build-depends fields for any weirdness or bad practice.
---
checkPackageVersions :: GenericPackageDescription -> [PackageCheck]
checkPackageVersions pkg =
-- if others is empty,
-- the error will still fire but listing no dependencies.
-- so we have to check
if length others > 0
- then
- PackageDistSuspiciousWarn (MissingUpperBounds others) : baseErrors
- else
- baseErrors
+ then PackageDistSuspiciousWarn (MissingUpperBounds others) : baseErrors
+ else baseErrors
where
baseErrors = PackageDistInexcusable BaseNoUpperBounds <$ bases
deps = toDependencyVersionsMap allBuildDepends pkg
-- base gets special treatment (it's more critical)
- (bases, others) = partition (("base" ==) . unPackageName) $
- [ name
- | (name, vr) <- Map.toList deps
- , not (hasUpperBound vr)
- ]
+ (bases, others) =
+ partition (("base" ==) . unPackageName) $
+ [ name
+ | (name, vr) <- Map.toList deps
+ , not (hasUpperBound vr)
+ ]
checkConditionals :: GenericPackageDescription -> [PackageCheck]
checkConditionals pkg =
- catMaybes [
-
- check (not $ null unknownOSs) $
- PackageDistInexcusable (UnknownOS unknownOSs)
-
- , check (not $ null unknownArches) $
- PackageDistInexcusable (UnknownArch unknownArches)
-
- , check (not $ null unknownImpls) $
- PackageDistInexcusable (UnknownCompiler unknownImpls)
- ]
+ catMaybes
+ [ check (not $ null unknownOSs) $
+ PackageDistInexcusable (UnknownOS unknownOSs)
+ , check (not $ null unknownArches) $
+ PackageDistInexcusable (UnknownArch unknownArches)
+ , check (not $ null unknownImpls) $
+ PackageDistInexcusable (UnknownCompiler unknownImpls)
+ ]
where
- unknownOSs = [ os | OS (OtherOS os) <- conditions ]
- unknownArches = [ arch | Arch (OtherArch arch) <- conditions ]
- unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ]
- conditions = concatMap fvs (maybeToList (condLibrary pkg))
- ++ concatMap (fvs . snd) (condSubLibraries pkg)
- ++ concatMap (fvs . snd) (condForeignLibs pkg)
- ++ concatMap (fvs . snd) (condExecutables pkg)
- ++ concatMap (fvs . snd) (condTestSuites pkg)
- ++ concatMap (fvs . snd) (condBenchmarks pkg)
+ unknownOSs = [os | OS (OtherOS os) <- conditions]
+ unknownArches = [arch | Arch (OtherArch arch) <- conditions]
+ unknownImpls = [impl | Impl (OtherCompiler impl) _ <- conditions]
+ conditions =
+ concatMap fvs (maybeToList (condLibrary pkg))
+ ++ concatMap (fvs . snd) (condSubLibraries pkg)
+ ++ concatMap (fvs . snd) (condForeignLibs pkg)
+ ++ concatMap (fvs . snd) (condExecutables pkg)
+ ++ concatMap (fvs . snd) (condTestSuites pkg)
+ ++ concatMap (fvs . snd) (condBenchmarks pkg)
fvs (CondNode _ _ ifs) = concatMap compfv ifs -- free variables
compfv (CondBranch c ct mct) = condfv c ++ fvs ct ++ maybe [] fvs mct
condfv c = case c of
- Var v -> [v]
- Lit _ -> []
- CNot c1 -> condfv c1
- COr c1 c2 -> condfv c1 ++ condfv c2
+ Var v -> [v]
+ Lit _ -> []
+ CNot c1 -> condfv c1
+ COr c1 c2 -> condfv c1 ++ condfv c2
CAnd c1 c2 -> condfv c1 ++ condfv c2
checkFlagNames :: GenericPackageDescription -> [PackageCheck]
checkFlagNames gpd
- | null invalidFlagNames = []
- | otherwise =
- [ PackageDistInexcusable (SuspiciousFlagName invalidFlagNames) ]
+ | null invalidFlagNames = []
+ | otherwise =
+ [PackageDistInexcusable (SuspiciousFlagName invalidFlagNames)]
where
invalidFlagNames =
- [ fn
- | flag <- genPackageFlags gpd
- , let fn = unFlagName (flagName flag)
- , invalidFlagName fn
- ]
+ [ fn
+ | flag <- genPackageFlags gpd
+ , let fn = unFlagName (flagName flag)
+ , invalidFlagName fn
+ ]
-- starts with dash
- invalidFlagName ('-':_) = True
+ invalidFlagName ('-' : _) = True
-- mon ascii letter
invalidFlagName cs = any (not . isAscii) cs
checkUnusedFlags :: GenericPackageDescription -> [PackageCheck]
checkUnusedFlags gpd
- | declared == used = []
- | otherwise =
- [ PackageDistSuspicious (DeclaredUsedFlags declared used) ]
+ | declared == used = []
+ | otherwise =
+ [PackageDistSuspicious (DeclaredUsedFlags declared used)]
where
declared :: Set.Set FlagName
declared = toSetOf (L.genPackageFlags . traverse . L.flagName) gpd
used :: Set.Set FlagName
- used = mconcat
- [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd
+ used =
+ mconcat
+ [ toSetOf (L.condLibrary . traverse . traverseCondTreeV . L._PackageFlag) gpd
, toSetOf (L.condSubLibraries . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
- , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
- , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
- , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
- , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
+ , toSetOf (L.condForeignLibs . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
+ , toSetOf (L.condExecutables . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
+ , toSetOf (L.condTestSuites . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
+ , toSetOf (L.condBenchmarks . traverse . _2 . traverseCondTreeV . L._PackageFlag) gpd
]
checkUnicodeXFields :: GenericPackageDescription -> [PackageCheck]
checkUnicodeXFields gpd
- | null nonAsciiXFields = []
- | otherwise =
- [ PackageDistInexcusable (NonASCIICustomField nonAsciiXFields) ]
+ | null nonAsciiXFields = []
+ | otherwise =
+ [PackageDistInexcusable (NonASCIICustomField nonAsciiXFields)]
where
nonAsciiXFields :: [String]
- nonAsciiXFields = [ n | (n, _) <- xfields, any (not . isAscii) n ]
-
- xfields :: [(String,String)]
- xfields = DList.runDList $ mconcat
- [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd
- , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd
- ]
+ nonAsciiXFields = [n | (n, _) <- xfields, any (not . isAscii) n]
+
+ xfields :: [(String, String)]
+ xfields =
+ DList.runDList $
+ mconcat
+ [ toDListOf (L.packageDescription . L.customFieldsPD . traverse) gpd
+ , toDListOf (L.traverseBuildInfos . L.customFieldsBI . traverse) gpd
+ ]
-- | cabal-version <2.2 + Paths_module + default-extensions: doesn't build.
checkPathsModuleExtensions :: PackageDescription -> [PackageCheck]
@@ -2007,16 +2206,16 @@ checkPackageInfoModuleExtensions :: PackageDescription -> [PackageCheck]
checkPackageInfoModuleExtensions = checkAutogenModuleExtensions autogenPackageInfoModuleName RebindableClashPackageInfo
-- | cabal-version <2.2 + *_module + default-extensions: doesn't build.
-checkAutogenModuleExtensions ::
- (PackageDescription -> ModuleName) ->
- CheckExplanation ->
- PackageDescription ->
- [PackageCheck]
+checkAutogenModuleExtensions
+ :: (PackageDescription -> ModuleName)
+ -> CheckExplanation
+ -> PackageDescription
+ -> [PackageCheck]
checkAutogenModuleExtensions autogenModuleName rebindableClashExplanation pd
- | specVersion pd >= CabalSpecV2_2 = []
- | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd)
- = return (PackageBuildImpossible rebindableClashExplanation)
- | otherwise = []
+ | specVersion pd >= CabalSpecV2_2 = []
+ | any checkBI (allBuildInfo pd) || any checkLib (allLibraries pd) =
+ return (PackageBuildImpossible rebindableClashExplanation)
+ | otherwise = []
where
mn = autogenModuleName pd
@@ -2025,137 +2224,148 @@ checkAutogenModuleExtensions autogenModuleName rebindableClashExplanation pd
checkBI :: BuildInfo -> Bool
checkBI bi =
- (mn `elem` otherModules bi || mn `elem` autogenModules bi) &&
- checkExts (bi ^. L.defaultExtensions)
+ (mn `elem` otherModules bi || mn `elem` autogenModules bi)
+ && checkExts (bi ^. L.defaultExtensions)
checkExts exts = rebind `elem` exts && (strings `elem` exts || lists `elem` exts)
where
- rebind = EnableExtension RebindableSyntax
+ rebind = EnableExtension RebindableSyntax
strings = EnableExtension OverloadedStrings
- lists = EnableExtension OverloadedLists
+ lists = EnableExtension OverloadedLists
-- | Checks GHC options from all ghc-*-options fields from the given BuildInfo
-- and reports flags that are OK during development process, but are
-- unacceptable in a distributed package
checkDevelopmentOnlyFlagsBuildInfo :: BuildInfo -> [PackageCheck]
checkDevelopmentOnlyFlagsBuildInfo bi =
- checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi)
- ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi)
- ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi)
+ checkDevelopmentOnlyFlagsOptions "ghc-options" (hcOptions GHC bi)
+ ++ checkDevelopmentOnlyFlagsOptions "ghc-prof-options" (hcProfOptions GHC bi)
+ ++ checkDevelopmentOnlyFlagsOptions "ghc-shared-options" (hcSharedOptions GHC bi)
-- | Checks the given list of flags belonging to the given field and reports
-- flags that are OK during development process, but are unacceptable in a
-- distributed package
checkDevelopmentOnlyFlagsOptions :: String -> [String] -> [PackageCheck]
checkDevelopmentOnlyFlagsOptions fieldName ghcOptions =
- catMaybes [
-
- check has_Werror $
- PackageDistInexcusable (WErrorUnneeded fieldName)
-
- , check has_J $
- PackageDistInexcusable (JUnneeded fieldName)
-
- , checkFlags ["-fdefer-type-errors"] $
- PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName)
-
- -- -dynamic is not a debug flag
- , check (any (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")
- ghcOptions) $
- PackageDistInexcusable (DynamicUnneeded fieldName)
-
- , checkFlags ["-fprof-auto", "-fprof-auto-top", "-fprof-auto-calls",
- "-fprof-cafs", "-fno-prof-count-entries",
- "-auto-all", "-auto", "-caf-all"] $
- PackageDistSuspicious (ProfilingUnneeded fieldName)
- ]
+ catMaybes
+ [ check has_Werror $
+ PackageDistInexcusable (WErrorUnneeded fieldName)
+ , check has_J $
+ PackageDistInexcusable (JUnneeded fieldName)
+ , checkFlags ["-fdefer-type-errors"] $
+ PackageDistInexcusable (FDeferTypeErrorsUnneeded fieldName)
+ , -- -dynamic is not a debug flag
+ check
+ ( any
+ (\opt -> "-d" `isPrefixOf` opt && opt /= "-dynamic")
+ ghcOptions
+ )
+ $ PackageDistInexcusable (DynamicUnneeded fieldName)
+ , checkFlags
+ [ "-fprof-auto"
+ , "-fprof-auto-top"
+ , "-fprof-auto-calls"
+ , "-fprof-cafs"
+ , "-fno-prof-count-entries"
+ , "-auto-all"
+ , "-auto"
+ , "-caf-all"
+ ]
+ $ PackageDistSuspicious (ProfilingUnneeded fieldName)
+ ]
where
-
- has_Werror = "-Werror" `elem` ghcOptions
- has_J = any
- (\o -> case o of
- "-j" -> True
- ('-' : 'j' : d : _) -> isDigit d
- _ -> False
- )
- ghcOptions
+ has_Werror = "-Werror" `elem` ghcOptions
+ has_J =
+ any
+ ( \o -> case o of
+ "-j" -> True
+ ('-' : 'j' : d : _) -> isDigit d
+ _ -> False
+ )
+ ghcOptions
checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
checkFlags flags = check (any (`elem` flags) ghcOptions)
checkDevelopmentOnlyFlags :: GenericPackageDescription -> [PackageCheck]
checkDevelopmentOnlyFlags pkg =
- concatMap checkDevelopmentOnlyFlagsBuildInfo
- [ bi
- | (conditions, bi) <- allConditionalBuildInfo
- , not (any guardedByManualFlag conditions) ]
+ concatMap
+ checkDevelopmentOnlyFlagsBuildInfo
+ [ bi
+ | (conditions, bi) <- allConditionalBuildInfo
+ , not (any guardedByManualFlag conditions)
+ ]
where
guardedByManualFlag = definitelyFalse
-- We've basically got three-values logic here: True, False or unknown
-- hence this pattern to propagate the unknown cases properly.
definitelyFalse (Var (PackageFlag n)) = maybe False not (Map.lookup n manualFlags)
- definitelyFalse (Var _) = False
- definitelyFalse (Lit b) = not b
- definitelyFalse (CNot c) = definitelyTrue c
- definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2
- definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2
+ definitelyFalse (Var _) = False
+ definitelyFalse (Lit b) = not b
+ definitelyFalse (CNot c) = definitelyTrue c
+ definitelyFalse (COr c1 c2) = definitelyFalse c1 && definitelyFalse c2
+ definitelyFalse (CAnd c1 c2) = definitelyFalse c1 || definitelyFalse c2
definitelyTrue (Var (PackageFlag n)) = fromMaybe False (Map.lookup n manualFlags)
- definitelyTrue (Var _) = False
- definitelyTrue (Lit b) = b
- definitelyTrue (CNot c) = definitelyFalse c
- definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2
- definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2
-
- manualFlags = Map.fromList
- [ (flagName flag, flagDefault flag)
- | flag <- genPackageFlags pkg
- , flagManual flag ]
+ definitelyTrue (Var _) = False
+ definitelyTrue (Lit b) = b
+ definitelyTrue (CNot c) = definitelyFalse c
+ definitelyTrue (COr c1 c2) = definitelyTrue c1 || definitelyTrue c2
+ definitelyTrue (CAnd c1 c2) = definitelyTrue c1 && definitelyTrue c2
+
+ manualFlags =
+ Map.fromList
+ [ (flagName flag, flagDefault flag)
+ | flag <- genPackageFlags pkg
+ , flagManual flag
+ ]
allConditionalBuildInfo :: [([Condition ConfVar], BuildInfo)]
allConditionalBuildInfo =
- concatMap (collectCondTreePaths libBuildInfo)
- (maybeToList (condLibrary pkg))
-
- ++ concatMap (collectCondTreePaths libBuildInfo . snd)
- (condSubLibraries pkg)
-
- ++ concatMap (collectCondTreePaths buildInfo . snd)
- (condExecutables pkg)
-
- ++ concatMap (collectCondTreePaths testBuildInfo . snd)
- (condTestSuites pkg)
-
- ++ concatMap (collectCondTreePaths benchmarkBuildInfo . snd)
- (condBenchmarks pkg)
+ concatMap
+ (collectCondTreePaths libBuildInfo)
+ (maybeToList (condLibrary pkg))
+ ++ concatMap
+ (collectCondTreePaths libBuildInfo . snd)
+ (condSubLibraries pkg)
+ ++ concatMap
+ (collectCondTreePaths buildInfo . snd)
+ (condExecutables pkg)
+ ++ concatMap
+ (collectCondTreePaths testBuildInfo . snd)
+ (condTestSuites pkg)
+ ++ concatMap
+ (collectCondTreePaths benchmarkBuildInfo . snd)
+ (condBenchmarks pkg)
-- get all the leaf BuildInfo, paired up with the path (in the tree sense)
-- of if-conditions that guard it
- collectCondTreePaths :: (a -> b)
- -> CondTree v c a
- -> [([Condition v], b)]
+ collectCondTreePaths
+ :: (a -> b)
+ -> CondTree v c a
+ -> [([Condition v], b)]
collectCondTreePaths mapData = go []
where
go conditions condNode =
- -- the data at this level in the tree:
- (reverse conditions, mapData (condTreeData condNode))
-
- : concat
- [ go (condition:conditions) ifThen
- | (CondBranch condition ifThen _) <- condTreeComponents condNode ]
-
- ++ concat
- [ go (condition:conditions) elseThen
- | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode ]
-
+ -- the data at this level in the tree:
+ (reverse conditions, mapData (condTreeData condNode))
+ : concat
+ [ go (condition : conditions) ifThen
+ | (CondBranch condition ifThen _) <- condTreeComponents condNode
+ ]
+ ++ concat
+ [ go (condition : conditions) elseThen
+ | (CondBranch condition _ (Just elseThen)) <- condTreeComponents condNode
+ ]
-- ------------------------------------------------------------
+
-- * Checks involving files in the package
+
-- ------------------------------------------------------------
-- | Sanity check things that requires IO. It looks at the files in the
-- package and expects to find the package unpacked in at the given file path.
---
checkPackageFiles :: Verbosity -> PackageDescription -> FilePath -> IO [PackageCheck]
checkPackageFiles verbosity pkg root = do
contentChecks <- checkPackageContent checkFilesIO pkg
@@ -2165,22 +2375,22 @@ checkPackageFiles verbosity pkg root = do
-- stable for test output.
return (sort contentChecks ++ sort preDistributionChecks)
where
- checkFilesIO = CheckPackageContentOps {
- doesFileExist = System.doesFileExist . relative,
- doesDirectoryExist = System.doesDirectoryExist . relative,
- getDirectoryContents = System.Directory.getDirectoryContents . relative,
- getFileContents = BS.readFile . relative
- }
+ checkFilesIO =
+ CheckPackageContentOps
+ { doesFileExist = System.doesFileExist . relative
+ , doesDirectoryExist = System.doesDirectoryExist . relative
+ , getDirectoryContents = System.Directory.getDirectoryContents . relative
+ , getFileContents = BS.readFile . relative
+ }
relative path = root </> path
-- | A record of operations needed to check the contents of packages.
-- Used by 'checkPackageContent'.
---
-data CheckPackageContentOps m = CheckPackageContentOps {
- doesFileExist :: FilePath -> m Bool,
- doesDirectoryExist :: FilePath -> m Bool,
- getDirectoryContents :: FilePath -> m [FilePath],
- getFileContents :: FilePath -> m BS.ByteString
+data CheckPackageContentOps m = CheckPackageContentOps
+ { doesFileExist :: FilePath -> m Bool
+ , doesDirectoryExist :: FilePath -> m Bool
+ , getDirectoryContents :: FilePath -> m [FilePath]
+ , getFileContents :: FilePath -> m BS.ByteString
}
-- | Sanity check things that requires looking at files in the package.
@@ -2189,27 +2399,30 @@ data CheckPackageContentOps m = CheckPackageContentOps {
--
-- The point of this extra generality is to allow doing checks in some virtual
-- file system, for example a tarball in memory.
---
-checkPackageContent :: (Monad m, Applicative m)
- => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
+checkPackageContent
+ :: (Monad m, Applicative m)
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
checkPackageContent ops pkg = do
- cabalBomError <- checkCabalFileBOM ops
- cabalNameError <- checkCabalFileName ops pkg
- licenseErrors <- checkLicensesExist ops pkg
- setupError <- checkSetupExists ops pkg
- configureError <- checkConfigureExists ops pkg
+ cabalBomError <- checkCabalFileBOM ops
+ cabalNameError <- checkCabalFileName ops pkg
+ licenseErrors <- checkLicensesExist ops pkg
+ setupError <- checkSetupExists ops pkg
+ configureError <- checkConfigureExists ops pkg
localPathErrors <- checkLocalPathsExist ops pkg
- vcsLocation <- checkMissingVcsInfo ops pkg
-
- return $ licenseErrors
- ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError]
- ++ localPathErrors
- ++ vcsLocation
-
-checkCabalFileBOM :: Monad m => CheckPackageContentOps m
- -> m (Maybe PackageCheck)
+ vcsLocation <- checkMissingVcsInfo ops pkg
+
+ return $
+ licenseErrors
+ ++ catMaybes [cabalBomError, cabalNameError, setupError, configureError]
+ ++ localPathErrors
+ ++ vcsLocation
+
+checkCabalFileBOM
+ :: Monad m
+ => CheckPackageContentOps m
+ -> m (Maybe PackageCheck)
checkCabalFileBOM ops = do
epdfile <- findPackageDesc ops
case epdfile of
@@ -2219,18 +2432,21 @@ checkCabalFileBOM ops = do
-- But this can be an issue, see #3552 and also when
-- --cabal-file is specified. So if you can't find the file,
-- just don't bother with this check.
- Left _ -> return Nothing
- Right pdfile -> (flip check pc . BS.isPrefixOf bomUtf8)
- `liftM` getFileContents ops pdfile
- where pc = PackageDistInexcusable (BOMStart pdfile)
-
+ Left _ -> return Nothing
+ Right pdfile ->
+ (flip check pc . BS.isPrefixOf bomUtf8)
+ `liftM` getFileContents ops pdfile
+ where
+ pc = PackageDistInexcusable (BOMStart pdfile)
where
bomUtf8 :: BS.ByteString
- bomUtf8 = BS.pack [0xef,0xbb,0xbf] -- U+FEFF encoded as UTF8
+ bomUtf8 = BS.pack [0xef, 0xbb, 0xbf] -- U+FEFF encoded as UTF8
-checkCabalFileName :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m (Maybe PackageCheck)
+checkCabalFileName
+ :: Monad m
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m (Maybe PackageCheck)
checkCabalFileName ops pkg = do
-- findPackageDesc already takes care to detect missing/multiple
-- .cabal files; we don't include this check in 'findPackageDesc' in
@@ -2238,121 +2454,152 @@ checkCabalFileName ops pkg = do
epdfile <- findPackageDesc ops
case epdfile of
-- see "MASSIVE HACK" note in 'checkCabalFileBOM'
- Left _ -> return Nothing
+ Left _ -> return Nothing
Right pdfile
| takeFileName pdfile == expectedCabalname -> return Nothing
- | otherwise -> return $ Just $ PackageDistInexcusable
- (NotPackageName pdfile expectedCabalname)
+ | otherwise ->
+ return $
+ Just $
+ PackageDistInexcusable
+ (NotPackageName pdfile expectedCabalname)
where
pkgname = unPackageName . packageName $ pkg
expectedCabalname = pkgname <.> "cabal"
+-- | Find a package description file in the given directory. Looks for
+-- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc',
+-- but generalized over monads.
+findPackageDesc
+ :: Monad m
+ => CheckPackageContentOps m
+ -> m (Either PackageCheck FilePath)
+ -- ^ <pkgname>.cabal
+findPackageDesc ops =
+ do
+ let dir = "."
+ files <- getDirectoryContents ops dir
+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
+ -- file we filter to exclude dirs and null base file names:
+ cabalFiles <-
+ filterM
+ (doesFileExist ops)
+ [ dir </> file
+ | file <- files
+ , let (name, ext) = splitExtension file
+ , not (null name) && ext == ".cabal"
+ ]
+ case cabalFiles of
+ [] -> return (Left $ PackageBuildImpossible NoDesc)
+ [cabalFile] -> return (Right cabalFile)
+ multiple ->
+ return
+ ( Left $
+ PackageBuildImpossible
+ (MultiDesc multiple)
+ )
--- |Find a package description file in the given directory. Looks for
--- @.cabal@ files. Like 'Distribution.Simple.Utils.findPackageDesc',
--- but generalized over monads.
-findPackageDesc :: Monad m => CheckPackageContentOps m
- -> m (Either PackageCheck FilePath) -- ^<pkgname>.cabal
-findPackageDesc ops
- = do let dir = "."
- files <- getDirectoryContents ops dir
- -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
- -- file we filter to exclude dirs and null base file names:
- cabalFiles <- filterM (doesFileExist ops)
- [ dir </> file
- | file <- files
- , let (name, ext) = splitExtension file
- , not (null name) && ext == ".cabal" ]
- case cabalFiles of
- [] -> return (Left $ PackageBuildImpossible NoDesc)
- [cabalFile] -> return (Right cabalFile)
- multiple -> return (Left $ PackageBuildImpossible
- (MultiDesc multiple))
-
-checkLicensesExist :: (Monad m, Applicative m)
- => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
+checkLicensesExist
+ :: (Monad m, Applicative m)
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
checkLicensesExist ops pkg = do
- exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg)
- return
- [ PackageBuildWarning (UnknownFile fieldname file)
- | (file, False) <- zip (licenseFiles pkg) exists ]
+ exists <- traverse (doesFileExist ops . getSymbolicPath) (licenseFiles pkg)
+ return
+ [ PackageBuildWarning (UnknownFile fieldname file)
+ | (file, False) <- zip (licenseFiles pkg) exists
+ ]
where
- fieldname | length (licenseFiles pkg) == 1 = "license-file"
- | otherwise = "license-files"
-
-checkSetupExists :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m (Maybe PackageCheck)
+ fieldname
+ | length (licenseFiles pkg) == 1 = "license-file"
+ | otherwise = "license-files"
+
+checkSetupExists
+ :: Monad m
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m (Maybe PackageCheck)
checkSetupExists ops pkg = do
let simpleBuild = buildType pkg == Simple
- hsexists <- doesFileExist ops "Setup.hs"
+ hsexists <- doesFileExist ops "Setup.hs"
lhsexists <- doesFileExist ops "Setup.lhs"
- return $ check (not simpleBuild && not hsexists && not lhsexists) $
- PackageDistInexcusable MissingSetupFile
-
-checkConfigureExists :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m (Maybe PackageCheck)
+ return $
+ check (not simpleBuild && not hsexists && not lhsexists) $
+ PackageDistInexcusable MissingSetupFile
+
+checkConfigureExists
+ :: Monad m
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m (Maybe PackageCheck)
checkConfigureExists ops pd
| buildType pd == Configure = do
exists <- doesFileExist ops "configure"
- return $ check (not exists) $
- PackageBuildWarning MissingConfigureScript
+ return $
+ check (not exists) $
+ PackageBuildWarning MissingConfigureScript
| otherwise = return Nothing
-checkLocalPathsExist :: Monad m => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
+checkLocalPathsExist
+ :: Monad m
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
checkLocalPathsExist ops pkg = do
- let dirs = [ (dir, kind)
- | bi <- allBuildInfo pkg
- , (dir, kind) <-
- [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]
- ++ [ (dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi ]
- ++ [ (dir, "extra-framework-dirs")
- | dir <- extraFrameworkDirs bi ]
- ++ [ (dir, "include-dirs") | dir <- includeDirs bi ]
- ++ [ (getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]
- , isRelativeOnAnyPlatform dir ]
+ let dirs =
+ [ (dir, kind)
+ | bi <- allBuildInfo pkg
+ , (dir, kind) <-
+ [(dir, "extra-lib-dirs") | dir <- extraLibDirs bi]
+ ++ [(dir, "extra-lib-dirs-static") | dir <- extraLibDirsStatic bi]
+ ++ [ (dir, "extra-framework-dirs")
+ | dir <- extraFrameworkDirs bi
+ ]
+ ++ [(dir, "include-dirs") | dir <- includeDirs bi]
+ ++ [(getSymbolicPath dir, "hs-source-dirs") | dir <- hsSourceDirs bi]
+ , isRelativeOnAnyPlatform dir
+ ]
missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs
- return [ PackageBuildWarning (UnknownDirectory kind dir)
- | (dir, kind) <- missing ]
+ return
+ [ PackageBuildWarning (UnknownDirectory kind dir)
+ | (dir, kind) <- missing
+ ]
-checkMissingVcsInfo :: (Monad m, Applicative m)
- => CheckPackageContentOps m
- -> PackageDescription
- -> m [PackageCheck]
+checkMissingVcsInfo
+ :: (Monad m, Applicative m)
+ => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do
- vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames
- if vcsInUse
- then return [ PackageDistSuspicious MissingSourceControl ]
- else return []
+ vcsInUse <- liftM or $ traverse (doesDirectoryExist ops) repoDirnames
+ if vcsInUse
+ then return [PackageDistSuspicious MissingSourceControl]
+ else return []
where
- repoDirnames = [ dirname | repo <- knownRepoTypes
- , dirname <- repoTypeDirname repo]
-
+ repoDirnames =
+ [ dirname | repo <- knownRepoTypes, dirname <- repoTypeDirname repo
+ ]
checkMissingVcsInfo _ _ = return []
repoTypeDirname :: KnownRepoType -> [FilePath]
-repoTypeDirname Darcs = ["_darcs"]
-repoTypeDirname Git = [".git"]
-repoTypeDirname SVN = [".svn"]
-repoTypeDirname CVS = ["CVS"]
+repoTypeDirname Darcs = ["_darcs"]
+repoTypeDirname Git = [".git"]
+repoTypeDirname SVN = [".svn"]
+repoTypeDirname CVS = ["CVS"]
repoTypeDirname Mercurial = [".hg"]
-repoTypeDirname GnuArch = [".arch-params"]
-repoTypeDirname Bazaar = [".bzr"]
-repoTypeDirname Monotone = ["_MTN"]
-repoTypeDirname Pijul = [".pijul"]
+repoTypeDirname GnuArch = [".arch-params"]
+repoTypeDirname Bazaar = [".bzr"]
+repoTypeDirname Monotone = ["_MTN"]
+repoTypeDirname Pijul = [".pijul"]
-- ------------------------------------------------------------
+
-- * Checks involving files in the package
+
-- ------------------------------------------------------------
-- | Check the names of all files in a package for portability problems. This
-- should be done for example when creating or validating a package tarball.
---
checkPackageFileNames :: [FilePath] -> [PackageCheck]
checkPackageFileNames = checkPackageFileNamesWithGlob . zip (repeat True)
@@ -2360,24 +2607,26 @@ checkPackageFileNamesWithGlob :: [(Bool, FilePath)] -> [PackageCheck]
checkPackageFileNamesWithGlob files =
catMaybes $
checkWindowsPaths files
- :
- [ checkTarPath file
- | (_, file) <- files
- ]
+ : [ checkTarPath file
+ | (_, file) <- files
+ ]
checkWindowsPaths :: [(Bool, FilePath)] -> Maybe PackageCheck
checkWindowsPaths paths =
- case filter (not . FilePath.Windows.isValid . escape) paths of
- [] -> Nothing
- ps -> Just $
+ case filter (not . FilePath.Windows.isValid . escape) paths of
+ [] -> Nothing
+ ps ->
+ Just $
PackageDistInexcusable (InvalidOnWin $ map snd ps)
where
-- force a relative name to catch invalid file names like "f:oo" which
-- otherwise parse as file "oo" in the current directory on the 'f' drive.
- escape (isGlob, path) = (".\\" ++)
- -- glob paths will be expanded before being dereferenced, so asterisks
- -- shouldn't count against them.
- $ map (\c -> if c == '*' && isGlob then 'x' else c) path
+ escape (isGlob, path) =
+ (".\\" ++)
+ -- glob paths will be expanded before being dereferenced, so asterisks
+ -- shouldn't count against them.
+ $
+ map (\c -> if c == '*' && isGlob then 'x' else c) path
-- | Check a file name is valid for the portable POSIX tar format.
--
@@ -2386,36 +2635,36 @@ checkWindowsPaths paths =
-- restriction is that either the whole path be 100 characters or less, or it
-- be possible to split the path on a directory separator such that the first
-- part is 155 characters or less and the second part 100 characters or less.
---
checkTarPath :: FilePath -> Maybe PackageCheck
checkTarPath path
- | length path > 255 = Just longPath
+ | length path > 255 = Just longPath
| otherwise = case pack nameMax (reverse (splitPath path)) of
- Left err -> Just err
- Right [] -> Nothing
- Right (h:rest) -> case pack prefixMax remainder of
- Left err -> Just err
- Right [] -> Nothing
- Right (_:_) -> Just noSplit
- where
- -- drop the '/' between the name and prefix:
- remainder = safeInit h : rest
-
+ Left err -> Just err
+ Right [] -> Nothing
+ Right (h : rest) -> case pack prefixMax remainder of
+ Left err -> Just err
+ Right [] -> Nothing
+ Right (_ : _) -> Just noSplit
+ where
+ -- drop the '/' between the name and prefix:
+ remainder = safeInit h : rest
where
nameMax, prefixMax :: Int
- nameMax = 100
+ nameMax = 100
prefixMax = 155
- pack _ [] = Left emptyName
- pack maxLen (c:cs)
- | n > maxLen = Left longName
- | otherwise = Right (pack' maxLen n cs)
- where n = length c
+ pack _ [] = Left emptyName
+ pack maxLen (c : cs)
+ | n > maxLen = Left longName
+ | otherwise = Right (pack' maxLen n cs)
+ where
+ n = length c
- pack' maxLen n (c:cs)
+ pack' maxLen n (c : cs)
| n' <= maxLen = pack' maxLen n' cs
- where n' = n + length c
- pack' _ _ cs = cs
+ where
+ n' = n + length c
+ pack' _ _ cs = cs
longPath = PackageDistInexcusable (FilePathTooLong path)
longName = PackageDistInexcusable (FilePathNameTooLong path)
@@ -2423,7 +2672,9 @@ checkTarPath path
emptyName = PackageDistInexcusable FilePathEmpty
-- --------------------------------------------------------------
+
-- * Checks for missing content and other pre-distribution checks
+
-- --------------------------------------------------------------
-- | Similar to 'checkPackageContent', 'checkPackageFilesPreDistribution'
@@ -2442,49 +2693,56 @@ checkPackageFilesPreDistribution :: Verbosity -> PackageDescription -> FilePath
checkPackageFilesPreDistribution = checkGlobFiles
-- | Discover problems with the package's wildcards.
-checkGlobFiles :: Verbosity
- -> PackageDescription
- -> FilePath
- -> IO [PackageCheck]
+checkGlobFiles
+ :: Verbosity
+ -> PackageDescription
+ -> FilePath
+ -> IO [PackageCheck]
checkGlobFiles verbosity pkg root = do
-- Get the desirable doc files from package’s directory
rootContents <- System.Directory.getDirectoryContents root
- docFiles0 <- filterM System.doesFileExist
- [ file
- | file <- rootContents
- , isDesirableExtraDocFile desirableDocFiles file
- ]
+ docFiles0 <-
+ filterM
+ System.doesFileExist
+ [ file
+ | file <- rootContents
+ , isDesirableExtraDocFile desirableDocFiles file
+ ]
-- Check the globs
(warnings, unlisted) <- foldrM checkGlob ([], docFiles0) allGlobs
- return $ if null unlisted
- -- No missing desirable file
- then warnings
- -- Some missing desirable files
- else warnings ++
- let unlisted' = (root </>) <$> unlisted
- in [ PackageDistSuspiciousWarn
- (MissingExpectedDocFiles extraDocFilesSupport unlisted')
- ]
+ return $
+ if null unlisted
+ then -- No missing desirable file
+ warnings
+ else -- Some missing desirable files
+
+ warnings
+ ++ let unlisted' = (root </>) <$> unlisted
+ in [ PackageDistSuspiciousWarn
+ (MissingExpectedDocFiles extraDocFilesSupport unlisted')
+ ]
where
-- `extra-doc-files` is supported only from version 1.18
extraDocFilesSupport = specVersion pkg >= CabalSpecV1_18
adjustedDataDir = if null (dataDir pkg) then root else root </> dataDir pkg
-- Cabal fields with globs
allGlobs :: [(String, Bool, FilePath, FilePath)]
- allGlobs = concat
- [ (,,,) "extra-source-files" (not extraDocFilesSupport) root <$>
- extraSrcFiles pkg
- , (,,,) "extra-doc-files" True root <$> extraDocFiles pkg
- , (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg
- ]
+ allGlobs =
+ concat
+ [ (,,,) "extra-source-files" (not extraDocFilesSupport) root
+ <$> extraSrcFiles pkg
+ , (,,,) "extra-doc-files" True root <$> extraDocFiles pkg
+ , (,,,) "data-files" False adjustedDataDir <$> dataFiles pkg
+ ]
-- For each field with globs (see allGlobs), look for:
-- • errors (missing directory, no match)
-- • omitted documentation files (changelog)
- checkGlob :: (String, Bool, FilePath, FilePath)
- -> ([PackageCheck], [FilePath])
- -> IO ([PackageCheck], [FilePath])
+ checkGlob
+ :: (String, Bool, FilePath, FilePath)
+ -> ([PackageCheck], [FilePath])
+ -> IO ([PackageCheck], [FilePath])
checkGlob (field, isDocField, dir, glob) acc@(warnings, docFiles1) =
-- Note: we just skip over parse errors here; they're reported elsewhere.
case parseFileGlob (specVersion pkg) glob of
@@ -2494,64 +2752,72 @@ checkGlobFiles verbosity pkg root = do
let acc0 = (warnings, True, docFiles1, [])
return $ case foldr checkGlobResult acc0 results of
(individualWarn, noMatchesWarn, docFiles1', wrongPaths) ->
- let wrongFieldWarnings = [ PackageDistSuspiciousWarn
- (WrongFieldForExpectedDocFiles
- extraDocFilesSupport
- field wrongPaths)
- | not (null wrongPaths) ]
- in
- ( if noMatchesWarn
- then [PackageDistSuspiciousWarn (GlobNoMatch field glob)] ++
- individualWarn ++
- wrongFieldWarnings
- else individualWarn ++ wrongFieldWarnings
- , docFiles1'
- )
+ let wrongFieldWarnings =
+ [ PackageDistSuspiciousWarn
+ ( WrongFieldForExpectedDocFiles
+ extraDocFilesSupport
+ field
+ wrongPaths
+ )
+ | not (null wrongPaths)
+ ]
+ in ( if noMatchesWarn
+ then
+ [PackageDistSuspiciousWarn (GlobNoMatch field glob)]
+ ++ individualWarn
+ ++ wrongFieldWarnings
+ else individualWarn ++ wrongFieldWarnings
+ , docFiles1'
+ )
where
- checkGlobResult :: GlobResult FilePath
- -> ([PackageCheck], Bool, [FilePath], [FilePath])
- -> ([PackageCheck], Bool, [FilePath], [FilePath])
+ checkGlobResult
+ :: GlobResult FilePath
+ -> ([PackageCheck], Bool, [FilePath], [FilePath])
+ -> ([PackageCheck], Bool, [FilePath], [FilePath])
checkGlobResult result (ws, noMatchesWarn, docFiles2, wrongPaths) =
- let noMatchesWarn' = noMatchesWarn &&
- not (suppressesNoMatchesWarning result)
- in case getWarning field glob result of
- -- No match: add warning and do no further check
- Left w ->
- ( w : ws
- , noMatchesWarn'
- , docFiles2
- , wrongPaths
- )
- -- Match: check doc files
- Right path ->
- let path' = makeRelative root (normalise path)
- (docFiles2', wrongPaths') = checkDoc isDocField
- path'
- docFiles2
- wrongPaths
- in
- ( ws
- , noMatchesWarn'
- , docFiles2'
- , wrongPaths'
- )
+ let noMatchesWarn' =
+ noMatchesWarn
+ && not (suppressesNoMatchesWarning result)
+ in case getWarning field glob result of
+ -- No match: add warning and do no further check
+ Left w ->
+ ( w : ws
+ , noMatchesWarn'
+ , docFiles2
+ , wrongPaths
+ )
+ -- Match: check doc files
+ Right path ->
+ let path' = makeRelative root (normalise path)
+ (docFiles2', wrongPaths') =
+ checkDoc
+ isDocField
+ path'
+ docFiles2
+ wrongPaths
+ in ( ws
+ , noMatchesWarn'
+ , docFiles2'
+ , wrongPaths'
+ )
-- Check whether a path is a desirable doc: if so, check if it is in the
-- field "extra-doc-files".
- checkDoc :: Bool -- Is it "extra-doc-files" ?
- -> FilePath -- Path to test
- -> [FilePath] -- Pending doc files to check
- -> [FilePath] -- Previous wrong paths
- -> ([FilePath], [FilePath]) -- Updated paths
+ checkDoc
+ :: Bool -- Is it "extra-doc-files" ?
+ -> FilePath -- Path to test
+ -> [FilePath] -- Pending doc files to check
+ -> [FilePath] -- Previous wrong paths
+ -> ([FilePath], [FilePath]) -- Updated paths
checkDoc isDocField path docFiles wrongFieldPaths =
if path `elem` docFiles
- -- Found desirable doc file
- then
+ then -- Found desirable doc file
+
( delete path docFiles
, if isDocField then wrongFieldPaths else path : wrongFieldPaths
)
- -- Not a desirable doc file
- else
+ else -- Not a desirable doc file
+
( docFiles
, wrongFieldPaths
)
@@ -2591,10 +2857,11 @@ checkGlobFiles verbosity pkg root = do
suppressesNoMatchesWarning (GlobWarnMultiDot _) = False
suppressesNoMatchesWarning (GlobMissingDirectory _) = True
- getWarning :: String
- -> FilePath
- -> GlobResult FilePath
- -> Either PackageCheck FilePath
+ getWarning
+ :: String
+ -> FilePath
+ -> GlobResult FilePath
+ -> Either PackageCheck FilePath
getWarning _ _ (GlobMatch path) =
Right path
-- Before Cabal 2.4, the extensions of globs had to match the file
@@ -2610,12 +2877,12 @@ checkGlobFiles verbosity pkg root = do
-- In particular, @base@ and @Cabal@ upper bounds are mandatory.
checkSetupVersions :: GenericPackageDescription -> [PackageCheck]
checkSetupVersions pkg =
- [ emitError nameStr
- | (name, vr) <- Map.toList deps
- , not (hasUpperBound vr)
- , let nameStr = unPackageName name
- , nameStr `elem` criticalPkgs
- ]
+ [ emitError nameStr
+ | (name, vr) <- Map.toList deps
+ , not (hasUpperBound vr)
+ , let nameStr = unPackageName name
+ , nameStr `elem` criticalPkgs
+ ]
where
criticalPkgs = ["Cabal", "base"]
deps = toDependencyVersionsMap (foldMap setupDepends . setupBuildInfo) pkg
@@ -2624,56 +2891,64 @@ checkSetupVersions pkg =
checkDuplicateModules :: GenericPackageDescription -> [PackageCheck]
checkDuplicateModules pkg =
- concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg)
- ++ concatMap checkExe (map snd $ condExecutables pkg)
- ++ concatMap checkTest (map snd $ condTestSuites pkg)
- ++ concatMap checkBench (map snd $ condBenchmarks pkg)
+ concatMap checkLib (maybe id (:) (condLibrary pkg) . map snd $ condSubLibraries pkg)
+ ++ concatMap checkExe (map snd $ condExecutables pkg)
+ ++ concatMap checkTest (map snd $ condTestSuites pkg)
+ ++ concatMap checkBench (map snd $ condBenchmarks pkg)
where
-- the duplicate modules check is has not been thoroughly vetted for backpack
- checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l))
- checkExe = checkDups "executable" exeModules
- checkTest = checkDups "test suite" testModules
- checkBench = checkDups "benchmark" benchmarkModules
+ checkLib = checkDups "library" (\l -> explicitLibModules l ++ map moduleReexportName (reexportedModules l))
+ checkExe = checkDups "executable" exeModules
+ checkTest = checkDups "test suite" testModules
+ checkBench = checkDups "benchmark" benchmarkModules
checkDups s getModules t =
- let sumPair (x,x') (y,y') = (x + x' :: Int, y + y' :: Int)
- mergePair (x, x') (y, y') = (x + x', max y y')
- maxPair (x, x') (y, y') = (max x x', max y y')
- libMap = foldCondTree Map.empty
- (\(_,v) -> Map.fromListWith sumPair . map (\x -> (x,(1, 1))) $ getModules v )
- (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely.
- (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches
- t
- dupLibsStrict = Map.keys $ Map.filter ((>1) . fst) libMap
- dupLibsLax = Map.keys $ Map.filter ((>1) . snd) libMap
- in if not (null dupLibsLax)
- then [PackageBuildImpossible
- (DuplicateModule s dupLibsLax)]
- else if not (null dupLibsStrict)
- then [PackageDistSuspicious
- (PotentialDupModule s dupLibsStrict)]
- else []
+ let sumPair (x, x') (y, y') = (x + x' :: Int, y + y' :: Int)
+ mergePair (x, x') (y, y') = (x + x', max y y')
+ maxPair (x, x') (y, y') = (max x x', max y y')
+ libMap =
+ foldCondTree
+ Map.empty
+ (\(_, v) -> Map.fromListWith sumPair . map (\x -> (x, (1, 1))) $ getModules v)
+ (Map.unionWith mergePair) -- if a module may occur in nonexclusive branches count it twice strictly and once loosely.
+ (Map.unionWith maxPair) -- a module occurs the max of times it might appear in exclusive branches
+ t
+ dupLibsStrict = Map.keys $ Map.filter ((> 1) . fst) libMap
+ dupLibsLax = Map.keys $ Map.filter ((> 1) . snd) libMap
+ in if not (null dupLibsLax)
+ then
+ [ PackageBuildImpossible
+ (DuplicateModule s dupLibsLax)
+ ]
+ else
+ if not (null dupLibsStrict)
+ then
+ [ PackageDistSuspicious
+ (PotentialDupModule s dupLibsStrict)
+ ]
+ else []
-- ------------------------------------------------------------
+
-- * Utils
+
-- ------------------------------------------------------------
toDependencyVersionsMap :: (PackageDescription -> [Dependency]) -> GenericPackageDescription -> Map PackageName VersionRange
toDependencyVersionsMap selectDependencies pkg = case typicalPkg pkg of
- Right (pkgs', _) ->
- let
- self :: PackageName
- self = pkgName $ package pkgs'
- in
- Map.fromListWith intersectVersionRanges $
- [ (pname, vr)
- | Dependency pname vr _ <- selectDependencies pkgs'
- , pname /= self
- ]
- -- Just in case finalizePD fails for any reason,
- -- or if the package doesn't depend on the base package at all,
- -- no deps is no checks.
- _ -> Map.empty
-
+ Right (pkgs', _) ->
+ let
+ self :: PackageName
+ self = pkgName $ package pkgs'
+ in
+ Map.fromListWith intersectVersionRanges $
+ [ (pname, vr)
+ | Dependency pname vr _ <- selectDependencies pkgs'
+ , pname /= self
+ ]
+ -- Just in case finalizePD fails for any reason,
+ -- or if the package doesn't depend on the base package at all,
+ -- no deps is no checks.
+ _ -> Map.empty
quote :: String -> String
quote s = "'" ++ s ++ "'"
@@ -2682,15 +2957,15 @@ commaSep :: [String] -> String
commaSep = intercalate ", "
dups :: Ord a => [a] -> [a]
-dups xs = [ x | (x:_:_) <- group (sort xs) ]
+dups xs = [x | (x : _ : _) <- group (sort xs)]
fileExtensionSupportedLanguage :: FilePath -> Bool
fileExtensionSupportedLanguage path =
- isHaskell || isC
+ isHaskell || isC
where
extension = takeExtension path
isHaskell = extension `elem` [".hs", ".lhs"]
- isC = isJust (filenameCDialect extension)
+ isC = isJust (filenameCDialect extension)
-- | Whether a path is a good relative path. We aren't worried about perfect
-- cross-platform compatibility here; this function just checks the paths in
@@ -2731,94 +3006,106 @@ fileExtensionSupportedLanguage path =
--
-- >>> traverse_ (print . isGoodRelativeGlob) ["foo/../bar"]
-- Just "parent directory segment: .."
---
isGoodRelativeFilePath :: FilePath -> Maybe String
isGoodRelativeFilePath = state0
where
-- initial state
- state0 [] = Just "empty path"
- state0 (c:cs) | c == '.' = state1 cs
- | c == '/' = Just "posix absolute path"
- | otherwise = state5 cs
+ state0 [] = Just "empty path"
+ state0 (c : cs)
+ | c == '.' = state1 cs
+ | c == '/' = Just "posix absolute path"
+ | otherwise = state5 cs
-- after initial .
- state1 [] = Just "trailing dot segment"
- state1 (c:cs) | c == '.' = state4 cs
- | c == '/' = state2 cs
- | otherwise = state5 cs
+ state1 [] = Just "trailing dot segment"
+ state1 (c : cs)
+ | c == '.' = state4 cs
+ | c == '/' = state2 cs
+ | otherwise = state5 cs
-- after ./ or after / between segments
- state2 [] = Just "trailing slash"
- state2 (c:cs) | c == '.' = state3 cs
- | c == '/' = Just "empty path segment"
- | otherwise = state5 cs
+ state2 [] = Just "trailing slash"
+ state2 (c : cs)
+ | c == '.' = state3 cs
+ | c == '/' = Just "empty path segment"
+ | otherwise = state5 cs
-- after non-first segment's .
- state3 [] = Just "trailing same directory segment: ."
- state3 (c:cs) | c == '.' = state4 cs
- | c == '/' = Just "same directory segment: ."
- | otherwise = state5 cs
+ state3 [] = Just "trailing same directory segment: ."
+ state3 (c : cs)
+ | c == '.' = state4 cs
+ | c == '/' = Just "same directory segment: ."
+ | otherwise = state5 cs
-- after ..
- state4 [] = Just "trailing parent directory segment: .."
- state4 (c:cs) | c == '.' = state5 cs
- | c == '/' = Just "parent directory segment: .."
- | otherwise = state5 cs
+ state4 [] = Just "trailing parent directory segment: .."
+ state4 (c : cs)
+ | c == '.' = state5 cs
+ | c == '/' = Just "parent directory segment: .."
+ | otherwise = state5 cs
-- in a segment which is ok.
- state5 [] = Nothing
- state5 (c:cs) | c == '.' = state5 cs
- | c == '/' = state2 cs
- | otherwise = state5 cs
+ state5 [] = Nothing
+ state5 (c : cs)
+ | c == '.' = state5 cs
+ | c == '/' = state2 cs
+ | otherwise = state5 cs
-- | See 'isGoodRelativeFilePath'.
--
-- This is barebones function. We check whether the glob is a valid file
-- by replacing stars @*@ with @x@ses.
isGoodRelativeGlob :: FilePath -> Maybe String
-isGoodRelativeGlob = isGoodRelativeFilePath . map f where
+isGoodRelativeGlob = isGoodRelativeFilePath . map f
+ where
f '*' = 'x'
- f c = c
+ f c = c
-- | See 'isGoodRelativeFilePath'.
isGoodRelativeDirectoryPath :: FilePath -> Maybe String
isGoodRelativeDirectoryPath = state0
where
-- initial state
- state0 [] = Just "empty path"
- state0 (c:cs) | c == '.' = state5 cs
- | c == '/' = Just "posix absolute path"
- | otherwise = state4 cs
+ state0 [] = Just "empty path"
+ state0 (c : cs)
+ | c == '.' = state5 cs
+ | c == '/' = Just "posix absolute path"
+ | otherwise = state4 cs
-- after initial ./ or after / between segments
- state1 [] = Nothing
- state1 (c:cs) | c == '.' = state2 cs
- | c == '/' = Just "empty path segment"
- | otherwise = state4 cs
+ state1 [] = Nothing
+ state1 (c : cs)
+ | c == '.' = state2 cs
+ | c == '/' = Just "empty path segment"
+ | otherwise = state4 cs
-- after non-first setgment's .
- state2 [] = Just "trailing same directory segment: ."
- state2 (c:cs) | c == '.' = state3 cs
- | c == '/' = Just "same directory segment: ."
- | otherwise = state4 cs
+ state2 [] = Just "trailing same directory segment: ."
+ state2 (c : cs)
+ | c == '.' = state3 cs
+ | c == '/' = Just "same directory segment: ."
+ | otherwise = state4 cs
-- after ..
- state3 [] = Just "trailing parent directory segment: .."
- state3 (c:cs) | c == '.' = state4 cs
- | c == '/' = Just "parent directory segment: .."
- | otherwise = state4 cs
+ state3 [] = Just "trailing parent directory segment: .."
+ state3 (c : cs)
+ | c == '.' = state4 cs
+ | c == '/' = Just "parent directory segment: .."
+ | otherwise = state4 cs
-- in a segment which is ok.
- state4 [] = Nothing
- state4 (c:cs) | c == '.' = state4 cs
- | c == '/' = state1 cs
- | otherwise = state4 cs
+ state4 [] = Nothing
+ state4 (c : cs)
+ | c == '.' = state4 cs
+ | c == '/' = state1 cs
+ | otherwise = state4 cs
-- after initial .
- state5 [] = Nothing -- "."
- state5 (c:cs) | c == '.' = state3 cs
- | c == '/' = state1 cs
- | otherwise = state4 cs
+ state5 [] = Nothing -- "."
+ state5 (c : cs)
+ | c == '.' = state3 cs
+ | c == '/' = state1 cs
+ | otherwise = state4 cs
-- [Note: Good relative paths]
--
@@ -2913,18 +3200,24 @@ isGoodRelativeDirectoryPath = state0
-- pick a single "typical" configuration and check if that has an
-- open upper bound. To get a typical configuration we finalise
-- using no package index and the current platform.
-typicalPkg :: GenericPackageDescription
- -> Either [Dependency] (PackageDescription, FlagAssignment)
-typicalPkg = finalizePD
- mempty defaultComponentRequestedSpec (const True)
- buildPlatform
- (unknownCompilerInfo
- (CompilerId buildCompilerFlavor nullVersion)
- NoAbiTag)
- []
+typicalPkg
+ :: GenericPackageDescription
+ -> Either [Dependency] (PackageDescription, FlagAssignment)
+typicalPkg =
+ finalizePD
+ mempty
+ defaultComponentRequestedSpec
+ (const True)
+ buildPlatform
+ ( unknownCompilerInfo
+ (CompilerId buildCompilerFlavor nullVersion)
+ NoAbiTag
+ )
+ []
addConditionalExp :: String -> String
-addConditionalExp expl = expl ++
- " Alternatively, if you want to use this, make it conditional based "
- ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "
- ++ "False') and enable that flag during development."
+addConditionalExp expl =
+ expl
+ ++ " Alternatively, if you want to use this, make it conditional based "
+ ++ "on a Cabal configuration flag (with 'manual: True' and 'default: "
+ ++ "False') and enable that flag during development."
diff --git a/Cabal/src/Distribution/ReadE.hs b/Cabal/src/Distribution/ReadE.hs
index a3d60fe6813a1a5c6d5e5c3fdf6c94fdf7b1dfd8..072dee990440836f56f8e21f168d66c1f70bbf64 100644
--- a/Cabal/src/Distribution/ReadE.hs
+++ b/Cabal/src/Distribution/ReadE.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE LambdaCase #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.ReadE
-- Copyright : Jose Iborra 2008
@@ -9,32 +11,37 @@
-- Portability : portable
--
-- Simple parsing with failure
+module Distribution.ReadE
+ ( -- * ReadE
+ ReadE (..)
+ , succeedReadE
+ , failReadE
+
+ -- * Projections
+ , parsecToReadE
+ , parsecToReadEErr
-module Distribution.ReadE (
- -- * ReadE
- ReadE(..), succeedReadE, failReadE,
- -- * Projections
- parsecToReadE, parsecToReadEErr,
- -- * Parse Errors
- unexpectMsgString,
+ -- * Parse Errors
+ , unexpectMsgString
) where
+import qualified Data.Bifunctor as Bi (first)
import Distribution.Compat.Prelude
import Prelude ()
-import qualified Data.Bifunctor as Bi (first)
import Distribution.Parsec
-import qualified Text.Parsec.Error as Parsec
import Distribution.Parsec.FieldLineStream
+import qualified Text.Parsec.Error as Parsec
-- | Parser with simple error reporting
newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}
-type ErrorMsg = String
+
+type ErrorMsg = String
instance Functor ReadE where
fmap f (ReadE p) = ReadE $ \txt -> case p txt of
- Right a -> Right (f a)
- Left err -> Left err
+ Right a -> Right (f a)
+ Left err -> Left err
succeedReadE :: (String -> a) -> ReadE a
succeedReadE f = ReadE (Right . f)
@@ -44,20 +51,21 @@ failReadE = ReadE . const . Left
runParsecFromString :: ParsecParser a -> String -> Either Parsec.ParseError a
runParsecFromString p txt =
- runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt)
+ runParsecParser p "<parsecToReadE>" (fieldLineStreamFromString txt)
parsecToReadE :: (String -> ErrorMsg) -> ParsecParser a -> ReadE a
parsecToReadE err p = ReadE $ \txt ->
- (const $ err txt) `Bi.first` runParsecFromString p txt
+ (const $ err txt) `Bi.first` runParsecFromString p txt
parsecToReadEErr :: (Parsec.ParseError -> ErrorMsg) -> ParsecParser a -> ReadE a
-parsecToReadEErr err p = ReadE $
+parsecToReadEErr err p =
+ ReadE $
Bi.first err . runParsecFromString p
-- Show only unexpected error messages
unexpectMsgString :: Parsec.ParseError -> String
-unexpectMsgString = unlines
- . map Parsec.messageString
- . filter (\case { Parsec.UnExpect _ -> True; _ -> False })
- . Parsec.errorMessages
-
+unexpectMsgString =
+ unlines
+ . map Parsec.messageString
+ . filter (\case Parsec.UnExpect _ -> True; _ -> False)
+ . Parsec.errorMessages
diff --git a/Cabal/src/Distribution/Simple.hs b/Cabal/src/Distribution/Simple.hs
index 77ba089fa982b9eab09b4302a6e8d1cda930b667..10b1c9fb50eeff6141df3e7fb000a4d2d4d0ef99 100644
--- a/Cabal/src/Distribution/Simple.hs
+++ b/Cabal/src/Distribution/Simple.hs
@@ -1,8 +1,17 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+{-
+Work around this warning:
+libraries/Cabal/Distribution/Simple.hs:78:0:
+ Warning: In the use of `runTests'
+ (imported from Distribution.Simple.UserHooks):
+ Deprecated: "Please use the new testing interface instead!"
+-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
-- |
-- Module : Distribution.Simple
-- Copyright : Isaac Jones 2003-2005
@@ -28,79 +37,83 @@
-- The original idea was that there could be different build systems that all
-- presented the same compatible command line interfaces. There is still a
-- "Distribution.Make" system but in practice no packages use it.
-
-{-
-Work around this warning:
-libraries/Cabal/Distribution/Simple.hs:78:0:
- Warning: In the use of `runTests'
- (imported from Distribution.Simple.UserHooks):
- Deprecated: "Please use the new testing interface instead!"
--}
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
-
-module Distribution.Simple (
- module Distribution.Package,
- module Distribution.Version,
- module Distribution.License,
- module Distribution.Simple.Compiler,
- module Language.Haskell.Extension,
- -- * Simple interface
- defaultMain, defaultMainNoRead, defaultMainArgs,
- -- * Customization
- UserHooks(..), Args,
- defaultMainWithHooks, defaultMainWithHooksArgs,
- defaultMainWithHooksNoRead, defaultMainWithHooksNoReadArgs,
- -- ** Standard sets of hooks
- simpleUserHooks,
- autoconfUserHooks,
- emptyUserHooks,
+module Distribution.Simple
+ ( module Distribution.Package
+ , module Distribution.Version
+ , module Distribution.License
+ , module Distribution.Simple.Compiler
+ , module Language.Haskell.Extension
+
+ -- * Simple interface
+ , defaultMain
+ , defaultMainNoRead
+ , defaultMainArgs
+
+ -- * Customization
+ , UserHooks (..)
+ , Args
+ , defaultMainWithHooks
+ , defaultMainWithHooksArgs
+ , defaultMainWithHooksNoRead
+ , defaultMainWithHooksNoReadArgs
+
+ -- ** Standard sets of hooks
+ , simpleUserHooks
+ , autoconfUserHooks
+ , emptyUserHooks
) where
import Control.Exception (try)
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- local
-import Distribution.Simple.Compiler
-import Distribution.Simple.UserHooks
+
import Distribution.Package
import Distribution.PackageDescription
import Distribution.PackageDescription.Configuration
+import Distribution.Simple.Command
+import Distribution.Simple.Compiler
import Distribution.Simple.PackageDescription
-import Distribution.Simple.Program
import Distribution.Simple.PreProcess
+import Distribution.Simple.Program
import Distribution.Simple.Setup
-import Distribution.Simple.Command
+import Distribution.Simple.UserHooks
import Distribution.Simple.Build
-import Distribution.Simple.SrcDist
import Distribution.Simple.Register
+import Distribution.Simple.SrcDist
import Distribution.Simple.Configure
-import Distribution.Simple.ConfigureScript
-import Distribution.Simple.LocalBuildInfo
+import Distribution.License
+import Distribution.Pretty
import Distribution.Simple.Bench
import Distribution.Simple.BuildPaths
-import Distribution.Simple.Test
-import Distribution.Simple.Install
+import Distribution.Simple.ConfigureScript
import Distribution.Simple.Haddock
+import Distribution.Simple.Install
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.Test
import Distribution.Simple.Utils
import Distribution.Verbosity
-import Language.Haskell.Extension
import Distribution.Version
-import Distribution.License
-import Distribution.Pretty
+import Language.Haskell.Extension
-- Base
-import System.Environment (getArgs, getProgName)
-import System.Directory (removeFile, doesFileExist
- ,doesDirectoryExist, removeDirectoryRecursive)
-import System.FilePath (takeDirectory, (</>))
+
import Distribution.Compat.ResponseFile (expandResponse)
+import System.Directory
+ ( doesDirectoryExist
+ , doesFileExist
+ , removeDirectoryRecursive
+ , removeFile
+ )
+import System.Environment (getArgs, getProgName)
+import System.FilePath (takeDirectory, (</>))
-import Data.List (unionBy, (\\))
+import Data.List (unionBy, (\\))
-- | A simple implementation of @main@ for a Cabal setup script.
-- It reads the package description file using IO, and performs the
@@ -130,8 +143,8 @@ defaultMainNoRead = defaultMainWithHooksNoRead simpleUserHooks
-- | A customizable version of 'defaultMainNoRead'.
defaultMainWithHooksNoRead :: UserHooks -> GenericPackageDescription -> IO ()
defaultMainWithHooksNoRead hooks pkg_descr =
- getArgs >>=
- defaultMainHelper hooks { readDesc = return (Just pkg_descr) }
+ getArgs
+ >>= defaultMainHelper hooks{readDesc = return (Just pkg_descr)}
-- | A customizable version of 'defaultMainNoRead' that also takes the
-- command line arguments.
@@ -139,24 +152,24 @@ defaultMainWithHooksNoRead hooks pkg_descr =
-- @since 2.2.0.0
defaultMainWithHooksNoReadArgs :: UserHooks -> GenericPackageDescription -> [String] -> IO ()
defaultMainWithHooksNoReadArgs hooks pkg_descr =
- defaultMainHelper hooks { readDesc = return (Just pkg_descr) }
+ defaultMainHelper hooks{readDesc = return (Just pkg_descr)}
defaultMainHelper :: UserHooks -> Args -> IO ()
defaultMainHelper hooks args = topHandler $ do
args' <- expandResponse args
case commandsRun (globalCommand commands) commands args' of
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo (flags, commandParse) ->
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (flags, commandParse) ->
case commandParse of
- _ | fromFlag (globalVersion flags) -> printVersion
+ _
+ | fromFlag (globalVersion flags) -> printVersion
| fromFlag (globalNumericVersion flags) -> printNumericVersion
- CommandHelp help -> printHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo action -> action
-
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo action -> action
where
printHelp help = getProgName >>= putStr . help
printOptionsList = putStr . unlines
@@ -164,109 +177,135 @@ defaultMainHelper hooks args = topHandler $ do
putStr (intercalate "\n" errs)
exitWith (ExitFailure 1)
printNumericVersion = putStrLn $ prettyShow cabalVersion
- printVersion = putStrLn $ "Cabal library version "
- ++ prettyShow cabalVersion
+ printVersion =
+ putStrLn $
+ "Cabal library version "
+ ++ prettyShow cabalVersion
progs = addKnownPrograms (hookedPrograms hooks) defaultProgramDb
commands =
- [configureCommand progs `commandAddAction`
- \fs as -> configureAction hooks fs as >> return ()
- ,buildCommand progs `commandAddAction` buildAction hooks
- ,replCommand progs `commandAddAction` replAction hooks
- ,installCommand `commandAddAction` installAction hooks
- ,copyCommand `commandAddAction` copyAction hooks
- ,haddockCommand `commandAddAction` haddockAction hooks
- ,cleanCommand `commandAddAction` cleanAction hooks
- ,sdistCommand `commandAddAction` sdistAction hooks
- ,hscolourCommand `commandAddAction` hscolourAction hooks
- ,registerCommand `commandAddAction` registerAction hooks
- ,unregisterCommand `commandAddAction` unregisterAction hooks
- ,testCommand `commandAddAction` testAction hooks
- ,benchmarkCommand `commandAddAction` benchAction hooks
+ [ configureCommand progs
+ `commandAddAction` \fs as -> configureAction hooks fs as >> return ()
+ , buildCommand progs `commandAddAction` buildAction hooks
+ , replCommand progs `commandAddAction` replAction hooks
+ , installCommand `commandAddAction` installAction hooks
+ , copyCommand `commandAddAction` copyAction hooks
+ , haddockCommand `commandAddAction` haddockAction hooks
+ , cleanCommand `commandAddAction` cleanAction hooks
+ , sdistCommand `commandAddAction` sdistAction hooks
+ , hscolourCommand `commandAddAction` hscolourAction hooks
+ , registerCommand `commandAddAction` registerAction hooks
+ , unregisterCommand `commandAddAction` unregisterAction hooks
+ , testCommand `commandAddAction` testAction hooks
+ , benchmarkCommand `commandAddAction` benchAction hooks
]
-- | Combine the preprocessors in the given hooks with the
-- preprocessors built into cabal.
-allSuffixHandlers :: UserHooks
- -> [PPSuffixHandler]
-allSuffixHandlers hooks
- = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers
- where
- overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]
- overridesPP = unionBy (\x y -> fst x == fst y)
+allSuffixHandlers
+ :: UserHooks
+ -> [PPSuffixHandler]
+allSuffixHandlers hooks =
+ overridesPP (hookedPreProcessors hooks) knownSuffixHandlers
+ where
+ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]
+ overridesPP = unionBy (\x y -> fst x == fst y)
configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo
configureAction hooks flags args = do
- distPref <- findDistPrefOrDefault (configDistPref flags)
- let flags' = flags { configDistPref = toFlag distPref
- , configArgs = args }
+ distPref <- findDistPrefOrDefault (configDistPref flags)
+ let flags' =
+ flags
+ { configDistPref = toFlag distPref
+ , configArgs = args
+ }
- -- See docs for 'HookedBuildInfo'
- pbi <- preConf hooks args flags'
+ -- See docs for 'HookedBuildInfo'
+ pbi <- preConf hooks args flags'
- (mb_pd_file, pkg_descr0) <- confPkgDescr hooks verbosity
- (flagToMaybe (configCabalFilePath flags))
+ (mb_pd_file, pkg_descr0) <-
+ confPkgDescr
+ hooks
+ verbosity
+ (flagToMaybe (configCabalFilePath flags))
- let epkg_descr = (pkg_descr0, pbi)
+ let epkg_descr = (pkg_descr0, pbi)
- localbuildinfo0 <- confHook hooks epkg_descr flags'
+ localbuildinfo0 <- confHook hooks epkg_descr flags'
- -- remember the .cabal filename if we know it
- -- and all the extra command line args
- let localbuildinfo = localbuildinfo0 {
- pkgDescrFile = mb_pd_file,
- extraConfigArgs = args
- }
- writePersistBuildConfig distPref localbuildinfo
+ -- remember the .cabal filename if we know it
+ -- and all the extra command line args
+ let localbuildinfo =
+ localbuildinfo0
+ { pkgDescrFile = mb_pd_file
+ , extraConfigArgs = args
+ }
+ writePersistBuildConfig distPref localbuildinfo
- let pkg_descr = localPkgDescr localbuildinfo
- postConf hooks args flags' pkg_descr localbuildinfo
- return localbuildinfo
+ let pkg_descr = localPkgDescr localbuildinfo
+ postConf hooks args flags' pkg_descr localbuildinfo
+ return localbuildinfo
where
verbosity = fromFlag (configVerbosity flags)
-confPkgDescr :: UserHooks -> Verbosity -> Maybe FilePath
- -> IO (Maybe FilePath, GenericPackageDescription)
+confPkgDescr
+ :: UserHooks
+ -> Verbosity
+ -> Maybe FilePath
+ -> IO (Maybe FilePath, GenericPackageDescription)
confPkgDescr hooks verbosity mb_path = do
mdescr <- readDesc hooks
case mdescr of
Just descr -> return (Nothing, descr)
Nothing -> do
- pdfile <- case mb_path of
- Nothing -> defaultPackageDesc verbosity
- Just path -> return path
- info verbosity "Using Parsec parser"
- descr <- readGenericPackageDescription verbosity pdfile
- return (Just pdfile, descr)
+ pdfile <- case mb_path of
+ Nothing -> defaultPackageDesc verbosity
+ Just path -> return path
+ info verbosity "Using Parsec parser"
+ descr <- readGenericPackageDescription verbosity pdfile
+ return (Just pdfile, descr)
buildAction :: UserHooks -> BuildFlags -> Args -> IO ()
buildAction hooks flags args = do
distPref <- findDistPrefOrDefault (buildDistPref flags)
let verbosity = fromFlag $ buildVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { buildDistPref = toFlag distPref
- , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)}
-
- progs <- reconfigurePrograms verbosity
- (buildProgramPaths flags')
- (buildProgramArgs flags')
- (withPrograms lbi)
+ let flags' =
+ flags
+ { buildDistPref = toFlag distPref
+ , buildCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
- hookedAction verbosity preBuild buildHook postBuild
- (return lbi { withPrograms = progs })
- hooks flags' { buildArgs = args } args
+ progs <-
+ reconfigurePrograms
+ verbosity
+ (buildProgramPaths flags')
+ (buildProgramArgs flags')
+ (withPrograms lbi)
+
+ hookedAction
+ verbosity
+ preBuild
+ buildHook
+ postBuild
+ (return lbi{withPrograms = progs})
+ hooks
+ flags'{buildArgs = args}
+ args
replAction :: UserHooks -> ReplFlags -> Args -> IO ()
replAction hooks flags args = do
distPref <- findDistPrefOrDefault (replDistPref flags)
let verbosity = fromFlag $ replVerbosity flags
- flags' = flags { replDistPref = toFlag distPref }
+ flags' = flags{replDistPref = toFlag distPref}
lbi <- getBuildConfig hooks verbosity distPref
- progs <- reconfigurePrograms verbosity
- (replProgramPaths flags')
- (replProgramArgs flags')
- (withPrograms lbi)
+ progs <-
+ reconfigurePrograms
+ verbosity
+ (replProgramPaths flags')
+ (replProgramArgs flags')
+ (withPrograms lbi)
-- As far as I can tell, the only reason this doesn't use
-- 'hookedActionWithArgs' is because the arguments of 'replHook'
@@ -275,211 +314,329 @@ replAction hooks flags args = do
let pkg_descr0 = localPkgDescr lbi
sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
let pkg_descr = updatePackageDescription pbi pkg_descr0
- lbi' = lbi { withPrograms = progs
- , localPkgDescr = pkg_descr }
+ lbi' =
+ lbi
+ { withPrograms = progs
+ , localPkgDescr = pkg_descr
+ }
replHook hooks pkg_descr lbi' hooks flags' args
postRepl hooks args flags' pkg_descr lbi'
hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()
hscolourAction hooks flags args = do
- distPref <- findDistPrefOrDefault (hscolourDistPref flags)
- let verbosity = fromFlag $ hscolourVerbosity flags
- lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { hscolourDistPref = toFlag distPref
- , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)}
+ distPref <- findDistPrefOrDefault (hscolourDistPref flags)
+ let verbosity = fromFlag $ hscolourVerbosity flags
+ lbi <- getBuildConfig hooks verbosity distPref
+ let flags' =
+ flags
+ { hscolourDistPref = toFlag distPref
+ , hscolourCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
- hookedAction verbosity preHscolour hscolourHook postHscolour
- (getBuildConfig hooks verbosity distPref)
- hooks flags' args
+ hookedAction
+ verbosity
+ preHscolour
+ hscolourHook
+ postHscolour
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'
+ args
haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()
haddockAction hooks flags args = do
distPref <- findDistPrefOrDefault (haddockDistPref flags)
let verbosity = fromFlag $ haddockVerbosity flags
lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { haddockDistPref = toFlag distPref
- , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)}
-
- progs <- reconfigurePrograms verbosity
- (haddockProgramPaths flags')
- (haddockProgramArgs flags')
- (withPrograms lbi)
+ let flags' =
+ flags
+ { haddockDistPref = toFlag distPref
+ , haddockCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
- hookedAction verbosity preHaddock haddockHook postHaddock
- (return lbi { withPrograms = progs })
- hooks flags' { haddockArgs = args } args
+ progs <-
+ reconfigurePrograms
+ verbosity
+ (haddockProgramPaths flags')
+ (haddockProgramArgs flags')
+ (withPrograms lbi)
+
+ hookedAction
+ verbosity
+ preHaddock
+ haddockHook
+ postHaddock
+ (return lbi{withPrograms = progs})
+ hooks
+ flags'{haddockArgs = args}
+ args
cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()
cleanAction hooks flags args = do
- distPref <- findDistPrefOrDefault (cleanDistPref flags)
-
- elbi <- tryGetBuildConfig hooks verbosity distPref
- let flags' = flags { cleanDistPref = toFlag distPref
- , cleanCabalFilePath = case elbi of
- Left _ -> mempty
- Right lbi -> maybeToFlag (cabalFilePath lbi)}
-
- pbi <- preClean hooks args flags'
-
- (_, ppd) <- confPkgDescr hooks verbosity Nothing
- -- It might seem like we are doing something clever here
- -- but we're really not: if you look at the implementation
- -- of 'clean' in the end all the package description is
- -- used for is to clear out @extra-tmp-files@. IMO,
- -- the configure script goo should go into @dist@ too!
- -- -- ezyang
- let pkg_descr0 = flattenPackageDescription ppd
- -- We don't sanity check for clean as an error
- -- here would prevent cleaning:
- --sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
- let pkg_descr = updatePackageDescription pbi pkg_descr0
+ distPref <- findDistPrefOrDefault (cleanDistPref flags)
+
+ elbi <- tryGetBuildConfig hooks verbosity distPref
+ let flags' =
+ flags
+ { cleanDistPref = toFlag distPref
+ , cleanCabalFilePath = case elbi of
+ Left _ -> mempty
+ Right lbi -> maybeToFlag (cabalFilePath lbi)
+ }
+
+ pbi <- preClean hooks args flags'
+
+ (_, ppd) <- confPkgDescr hooks verbosity Nothing
+ -- It might seem like we are doing something clever here
+ -- but we're really not: if you look at the implementation
+ -- of 'clean' in the end all the package description is
+ -- used for is to clear out @extra-tmp-files@. IMO,
+ -- the configure script goo should go into @dist@ too!
+ -- -- ezyang
+ let pkg_descr0 = flattenPackageDescription ppd
+ -- We don't sanity check for clean as an error
+ -- here would prevent cleaning:
+ -- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
+ let pkg_descr = updatePackageDescription pbi pkg_descr0
- cleanHook hooks pkg_descr () hooks flags'
- postClean hooks args flags' pkg_descr ()
+ cleanHook hooks pkg_descr () hooks flags'
+ postClean hooks args flags' pkg_descr ()
where
verbosity = fromFlag (cleanVerbosity flags)
copyAction :: UserHooks -> CopyFlags -> Args -> IO ()
copyAction hooks flags args = do
- distPref <- findDistPrefOrDefault (copyDistPref flags)
- let verbosity = fromFlag $ copyVerbosity flags
- lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { copyDistPref = toFlag distPref
- , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)}
- hookedAction verbosity preCopy copyHook postCopy
- (getBuildConfig hooks verbosity distPref)
- hooks flags' { copyArgs = args } args
+ distPref <- findDistPrefOrDefault (copyDistPref flags)
+ let verbosity = fromFlag $ copyVerbosity flags
+ lbi <- getBuildConfig hooks verbosity distPref
+ let flags' =
+ flags
+ { copyDistPref = toFlag distPref
+ , copyCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
+ hookedAction
+ verbosity
+ preCopy
+ copyHook
+ postCopy
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'{copyArgs = args}
+ args
installAction :: UserHooks -> InstallFlags -> Args -> IO ()
installAction hooks flags args = do
- distPref <- findDistPrefOrDefault (installDistPref flags)
- let verbosity = fromFlag $ installVerbosity flags
- lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { installDistPref = toFlag distPref
- , installCabalFilePath = maybeToFlag (cabalFilePath lbi)}
- hookedAction verbosity preInst instHook postInst
- (getBuildConfig hooks verbosity distPref)
- hooks flags' args
+ distPref <- findDistPrefOrDefault (installDistPref flags)
+ let verbosity = fromFlag $ installVerbosity flags
+ lbi <- getBuildConfig hooks verbosity distPref
+ let flags' =
+ flags
+ { installDistPref = toFlag distPref
+ , installCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
+ hookedAction
+ verbosity
+ preInst
+ instHook
+ postInst
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'
+ args
-- Since Cabal-3.4 UserHooks are completely ignored
sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()
sdistAction _hooks flags _args = do
- (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing
- let pkg_descr = flattenPackageDescription ppd
- sdist pkg_descr flags srcPref knownSuffixHandlers
+ (_, ppd) <- confPkgDescr emptyUserHooks verbosity Nothing
+ let pkg_descr = flattenPackageDescription ppd
+ sdist pkg_descr flags srcPref knownSuffixHandlers
where
verbosity = fromFlag (sDistVerbosity flags)
testAction :: UserHooks -> TestFlags -> Args -> IO ()
testAction hooks flags args = do
- distPref <- findDistPrefOrDefault (testDistPref flags)
- let verbosity = fromFlag $ testVerbosity flags
- flags' = flags { testDistPref = toFlag distPref }
-
- hookedActionWithArgs verbosity preTest testHook postTest
- (getBuildConfig hooks verbosity distPref)
- hooks flags' args
+ distPref <- findDistPrefOrDefault (testDistPref flags)
+ let verbosity = fromFlag $ testVerbosity flags
+ flags' = flags{testDistPref = toFlag distPref}
+
+ hookedActionWithArgs
+ verbosity
+ preTest
+ testHook
+ postTest
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'
+ args
benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()
benchAction hooks flags args = do
- distPref <- findDistPrefOrDefault (benchmarkDistPref flags)
- let verbosity = fromFlag $ benchmarkVerbosity flags
- flags' = flags { benchmarkDistPref = toFlag distPref }
- hookedActionWithArgs verbosity preBench benchHook postBench
- (getBuildConfig hooks verbosity distPref)
- hooks flags' args
+ distPref <- findDistPrefOrDefault (benchmarkDistPref flags)
+ let verbosity = fromFlag $ benchmarkVerbosity flags
+ flags' = flags{benchmarkDistPref = toFlag distPref}
+ hookedActionWithArgs
+ verbosity
+ preBench
+ benchHook
+ postBench
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'
+ args
registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()
registerAction hooks flags args = do
- distPref <- findDistPrefOrDefault (regDistPref flags)
- let verbosity = fromFlag $ regVerbosity flags
- lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { regDistPref = toFlag distPref
- , regCabalFilePath = maybeToFlag (cabalFilePath lbi)}
- hookedAction verbosity preReg regHook postReg
- (getBuildConfig hooks verbosity distPref)
- hooks flags' { regArgs = args } args
+ distPref <- findDistPrefOrDefault (regDistPref flags)
+ let verbosity = fromFlag $ regVerbosity flags
+ lbi <- getBuildConfig hooks verbosity distPref
+ let flags' =
+ flags
+ { regDistPref = toFlag distPref
+ , regCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
+ hookedAction
+ verbosity
+ preReg
+ regHook
+ postReg
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'{regArgs = args}
+ args
unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()
unregisterAction hooks flags args = do
- distPref <- findDistPrefOrDefault (regDistPref flags)
- let verbosity = fromFlag $ regVerbosity flags
- lbi <- getBuildConfig hooks verbosity distPref
- let flags' = flags { regDistPref = toFlag distPref
- , regCabalFilePath = maybeToFlag (cabalFilePath lbi)}
- hookedAction verbosity preUnreg unregHook postUnreg
- (getBuildConfig hooks verbosity distPref)
- hooks flags' args
+ distPref <- findDistPrefOrDefault (regDistPref flags)
+ let verbosity = fromFlag $ regVerbosity flags
+ lbi <- getBuildConfig hooks verbosity distPref
+ let flags' =
+ flags
+ { regDistPref = toFlag distPref
+ , regCabalFilePath = maybeToFlag (cabalFilePath lbi)
+ }
+ hookedAction
+ verbosity
+ preUnreg
+ unregHook
+ postUnreg
+ (getBuildConfig hooks verbosity distPref)
+ hooks
+ flags'
+ args
hookedAction
:: Verbosity
-> (UserHooks -> Args -> flags -> IO HookedBuildInfo)
- -> (UserHooks -> PackageDescription -> LocalBuildInfo
- -> UserHooks -> flags -> IO ())
- -> (UserHooks -> Args -> flags -> PackageDescription
- -> LocalBuildInfo -> IO ())
+ -> ( UserHooks
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> flags
+ -> IO ()
+ )
+ -> ( UserHooks
+ -> Args
+ -> flags
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> IO ()
+ )
-> IO LocalBuildInfo
- -> UserHooks -> flags -> Args -> IO ()
+ -> UserHooks
+ -> flags
+ -> Args
+ -> IO ()
hookedAction verbosity pre_hook cmd_hook =
- hookedActionWithArgs verbosity pre_hook
- (\h _ pd lbi uh flags ->
- cmd_hook h pd lbi uh flags)
+ hookedActionWithArgs
+ verbosity
+ pre_hook
+ ( \h _ pd lbi uh flags ->
+ cmd_hook h pd lbi uh flags
+ )
hookedActionWithArgs
:: Verbosity
-> (UserHooks -> Args -> flags -> IO HookedBuildInfo)
- -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo
- -> UserHooks -> flags -> IO ())
- -> (UserHooks -> Args -> flags -> PackageDescription
- -> LocalBuildInfo -> IO ())
+ -> ( UserHooks
+ -> Args
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> flags
+ -> IO ()
+ )
+ -> ( UserHooks
+ -> Args
+ -> flags
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> IO ()
+ )
-> IO LocalBuildInfo
- -> UserHooks -> flags -> Args -> IO ()
-hookedActionWithArgs verbosity pre_hook cmd_hook post_hook
- get_build_config hooks flags args = do
- pbi <- pre_hook hooks args flags
- lbi0 <- get_build_config
- let pkg_descr0 = localPkgDescr lbi0
- sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
- let pkg_descr = updatePackageDescription pbi pkg_descr0
- lbi = lbi0 { localPkgDescr = pkg_descr }
- cmd_hook hooks args pkg_descr lbi hooks flags
- post_hook hooks args flags pkg_descr lbi
+ -> UserHooks
+ -> flags
+ -> Args
+ -> IO ()
+hookedActionWithArgs
+ verbosity
+ pre_hook
+ cmd_hook
+ post_hook
+ get_build_config
+ hooks
+ flags
+ args = do
+ pbi <- pre_hook hooks args flags
+ lbi0 <- get_build_config
+ let pkg_descr0 = localPkgDescr lbi0
+ sanityCheckHookedBuildInfo verbosity pkg_descr0 pbi
+ let pkg_descr = updatePackageDescription pbi pkg_descr0
+ lbi = lbi0{localPkgDescr = pkg_descr}
+ cmd_hook hooks args pkg_descr lbi hooks flags
+ post_hook hooks args flags pkg_descr lbi
sanityCheckHookedBuildInfo
:: Verbosity -> PackageDescription -> HookedBuildInfo -> IO ()
-sanityCheckHookedBuildInfo verbosity
- (PackageDescription { library = Nothing }) (Just _,_)
- = die' verbosity $ "The buildinfo contains info for a library, "
- ++ "but the package does not have a library."
-
+sanityCheckHookedBuildInfo
+ verbosity
+ (PackageDescription{library = Nothing})
+ (Just _, _) =
+ die' verbosity $
+ "The buildinfo contains info for a library, "
+ ++ "but the package does not have a library."
sanityCheckHookedBuildInfo verbosity pkg_descr (_, hookExes)
- | exe1 : _ <- nonExistant
- = die' verbosity $ "The buildinfo contains info for an executable called '"
- ++ prettyShow exe1 ++ "' but the package does not have a "
- ++ "executable with that name."
+ | exe1 : _ <- nonExistant =
+ die' verbosity $
+ "The buildinfo contains info for an executable called '"
+ ++ prettyShow exe1
+ ++ "' but the package does not have a "
+ ++ "executable with that name."
where
- pkgExeNames = nub (map exeName (executables pkg_descr))
+ pkgExeNames = nub (map exeName (executables pkg_descr))
hookExeNames = nub (map fst hookExes)
- nonExistant = hookExeNames \\ pkgExeNames
-
+ nonExistant = hookExeNames \\ pkgExeNames
sanityCheckHookedBuildInfo _ _ _ = return ()
-- | Try to read the 'localBuildInfoFile'
-tryGetBuildConfig :: UserHooks -> Verbosity -> FilePath
- -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetBuildConfig
+ :: UserHooks
+ -> Verbosity
+ -> FilePath
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetBuildConfig u v = try . getBuildConfig u v
-
-- | Read the 'localBuildInfoFile' or throw an exception.
getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo
getBuildConfig hooks verbosity distPref = do
lbi_wo_programs <- getPersistBuildConfig distPref
-- Restore info about unconfigured programs, since it is not serialized
- let lbi = lbi_wo_programs {
- withPrograms = restoreProgramDb
- (builtinPrograms ++ hookedPrograms hooks)
- (withPrograms lbi_wo_programs)
- }
+ let lbi =
+ lbi_wo_programs
+ { withPrograms =
+ restoreProgramDb
+ (builtinPrograms ++ hookedPrograms hooks)
+ (withPrograms lbi_wo_programs)
+ }
case pkgDescrFile lbi of
Nothing -> return lbi
@@ -488,60 +645,64 @@ getBuildConfig hooks verbosity distPref = do
if outdated
then reconfigure pkg_descr_file lbi
else return lbi
-
where
reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
reconfigure pkg_descr_file lbi = do
- notice verbosity $ pkg_descr_file ++ " has been changed. "
- ++ "Re-configuring with most recently used options. "
- ++ "If this fails, please run configure manually.\n"
+ notice verbosity $
+ pkg_descr_file
+ ++ " has been changed. "
+ ++ "Re-configuring with most recently used options. "
+ ++ "If this fails, please run configure manually.\n"
let cFlags = configFlags lbi
- let cFlags' = cFlags {
- -- Since the list of unconfigured programs is not serialized,
- -- restore it to the same value as normally used at the beginning
- -- of a configure run:
- configPrograms_ = fmap (restoreProgramDb
- (builtinPrograms ++ hookedPrograms hooks))
- `fmap` configPrograms_ cFlags,
-
- -- Use the current, not saved verbosity level:
- configVerbosity = Flag verbosity
- }
+ let cFlags' =
+ cFlags
+ { -- Since the list of unconfigured programs is not serialized,
+ -- restore it to the same value as normally used at the beginning
+ -- of a configure run:
+ configPrograms_ =
+ fmap
+ ( restoreProgramDb
+ (builtinPrograms ++ hookedPrograms hooks)
+ )
+ `fmap` configPrograms_ cFlags
+ , -- Use the current, not saved verbosity level:
+ configVerbosity = Flag verbosity
+ }
configureAction hooks cFlags' (extraConfigArgs lbi)
-
-- --------------------------------------------------------------------------
-- Cleaning
clean :: PackageDescription -> CleanFlags -> IO ()
clean pkg_descr flags = do
- let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags
- notice verbosity "cleaning..."
-
- maybeConfig <- if fromFlag (cleanSaveConf flags)
- then maybeGetPersistBuildConfig distPref
- else return Nothing
+ let distPref = fromFlagOrDefault defaultDistPref $ cleanDistPref flags
+ notice verbosity "cleaning..."
- -- remove the whole dist/ directory rather than tracking exactly what files
- -- we created in there.
- chattyTry "removing dist/" $ do
- exists <- doesDirectoryExist distPref
- when exists (removeDirectoryRecursive distPref)
+ maybeConfig <-
+ if fromFlag (cleanSaveConf flags)
+ then maybeGetPersistBuildConfig distPref
+ else return Nothing
- -- Any extra files the user wants to remove
- traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)
+ -- remove the whole dist/ directory rather than tracking exactly what files
+ -- we created in there.
+ chattyTry "removing dist/" $ do
+ exists <- doesDirectoryExist distPref
+ when exists (removeDirectoryRecursive distPref)
- -- If the user wanted to save the config, write it back
- traverse_ (writePersistBuildConfig distPref) maybeConfig
+ -- Any extra files the user wants to remove
+ traverse_ removeFileOrDirectory (extraTmpFiles pkg_descr)
+ -- If the user wanted to save the config, write it back
+ traverse_ (writePersistBuildConfig distPref) maybeConfig
where
- removeFileOrDirectory :: FilePath -> IO ()
- removeFileOrDirectory fname = do
- isDir <- doesDirectoryExist fname
- isFile <- doesFileExist fname
- if isDir then removeDirectoryRecursive fname
- else when isFile $ removeFile fname
- verbosity = fromFlag (cleanVerbosity flags)
+ removeFileOrDirectory :: FilePath -> IO ()
+ removeFileOrDirectory fname = do
+ isDir <- doesDirectoryExist fname
+ isFile <- doesFileExist fname
+ if isDir
+ then removeDirectoryRecursive fname
+ else when isFile $ removeFile fname
+ verbosity = fromFlag (cleanVerbosity flags)
-- --------------------------------------------------------------------------
-- Default hooks
@@ -550,22 +711,22 @@ clean pkg_descr flags = do
-- \"simple\" build system
simpleUserHooks :: UserHooks
simpleUserHooks =
- emptyUserHooks {
- confHook = configure,
- postConf = finalChecks,
- buildHook = defaultBuildHook,
- replHook = defaultReplHook,
- copyHook = \desc lbi _ f -> install desc lbi f,
- -- 'install' has correct 'copy' behavior with params
- testHook = defaultTestHook,
- benchHook = defaultBenchHook,
- instHook = defaultInstallHook,
- cleanHook = \p _ _ f -> clean p f,
- hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,
- haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f,
- regHook = defaultRegHook,
- unregHook = \p l _ f -> unregister p l f
- }
+ emptyUserHooks
+ { confHook = configure
+ , postConf = finalChecks
+ , buildHook = defaultBuildHook
+ , replHook = defaultReplHook
+ , copyHook = \desc lbi _ f -> install desc lbi f
+ , -- 'install' has correct 'copy' behavior with params
+ testHook = defaultTestHook
+ , benchHook = defaultBenchHook
+ , instHook = defaultInstallHook
+ , cleanHook = \p _ _ f -> clean p f
+ , hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f
+ , haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f
+ , regHook = defaultRegHook
+ , unregHook = \p l _ f -> unregister p l f
+ }
where
finalChecks _args flags pkg_descr lbi =
checkForeignDeps pkg_descr lbi (lessVerbose verbosity)
@@ -582,109 +743,155 @@ simpleUserHooks =
--
-- Thus @configure@ can use local system information to generate
-- /package/@.buildinfo@ and possibly other files.
-
autoconfUserHooks :: UserHooks
-autoconfUserHooks
- = simpleUserHooks
- {
- postConf = defaultPostConf,
- preBuild = readHookWithArgs buildVerbosity buildDistPref, -- buildCabalFilePath,
- preCopy = readHookWithArgs copyVerbosity copyDistPref,
- preClean = readHook cleanVerbosity cleanDistPref,
- preInst = readHook installVerbosity installDistPref,
- preHscolour = readHook hscolourVerbosity hscolourDistPref,
- preHaddock = readHookWithArgs haddockVerbosity haddockDistPref,
- preReg = readHook regVerbosity regDistPref,
- preUnreg = readHook regVerbosity regDistPref
- }
- where defaultPostConf :: Args -> ConfigFlags -> PackageDescription
- -> LocalBuildInfo -> IO ()
- defaultPostConf args flags pkg_descr lbi
- = do let verbosity = fromFlag (configVerbosity flags)
- baseDir lbi' = fromMaybe ""
- (takeDirectory <$> cabalFilePath lbi')
- confExists <- doesFileExist $ (baseDir lbi) </> "configure"
- if confExists
- then runConfigureScript verbosity
- flags lbi
- else die' verbosity "configure script not found."
-
- pbi <- getHookedBuildInfo verbosity (buildDir lbi)
- sanityCheckHookedBuildInfo verbosity pkg_descr pbi
- let pkg_descr' = updatePackageDescription pbi pkg_descr
- lbi' = lbi { localPkgDescr = pkg_descr' }
- postConf simpleUserHooks args flags pkg_descr' lbi'
-
- readHookWithArgs :: (a -> Flag Verbosity)
- -> (a -> Flag FilePath)
- -> Args -> a
- -> IO HookedBuildInfo
- readHookWithArgs get_verbosity get_dist_pref _ flags = do
- dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
- getHookedBuildInfo verbosity (dist_dir </> "build")
- where
- verbosity = fromFlag (get_verbosity flags)
-
- readHook :: (a -> Flag Verbosity)
- -> (a -> Flag FilePath)
- -> Args -> a -> IO HookedBuildInfo
- readHook get_verbosity get_dist_pref a flags = do
- noExtraFlags a
- dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
- getHookedBuildInfo verbosity (dist_dir </> "build")
- where
- verbosity = fromFlag (get_verbosity flags)
+autoconfUserHooks =
+ simpleUserHooks
+ { postConf = defaultPostConf
+ , preBuild = readHookWithArgs buildVerbosity buildDistPref -- buildCabalFilePath,
+ , preCopy = readHookWithArgs copyVerbosity copyDistPref
+ , preClean = readHook cleanVerbosity cleanDistPref
+ , preInst = readHook installVerbosity installDistPref
+ , preHscolour = readHook hscolourVerbosity hscolourDistPref
+ , preHaddock = readHookWithArgs haddockVerbosity haddockDistPref
+ , preReg = readHook regVerbosity regDistPref
+ , preUnreg = readHook regVerbosity regDistPref
+ }
+ where
+ defaultPostConf
+ :: Args
+ -> ConfigFlags
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> IO ()
+ defaultPostConf args flags pkg_descr lbi =
+ do
+ let verbosity = fromFlag (configVerbosity flags)
+ baseDir lbi' =
+ fromMaybe
+ ""
+ (takeDirectory <$> cabalFilePath lbi')
+ confExists <- doesFileExist $ (baseDir lbi) </> "configure"
+ if confExists
+ then
+ runConfigureScript
+ verbosity
+ flags
+ lbi
+ else die' verbosity "configure script not found."
+
+ pbi <- getHookedBuildInfo verbosity (buildDir lbi)
+ sanityCheckHookedBuildInfo verbosity pkg_descr pbi
+ let pkg_descr' = updatePackageDescription pbi pkg_descr
+ lbi' = lbi{localPkgDescr = pkg_descr'}
+ postConf simpleUserHooks args flags pkg_descr' lbi'
+
+ readHookWithArgs
+ :: (a -> Flag Verbosity)
+ -> (a -> Flag FilePath)
+ -> Args
+ -> a
+ -> IO HookedBuildInfo
+ readHookWithArgs get_verbosity get_dist_pref _ flags = do
+ dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
+ getHookedBuildInfo verbosity (dist_dir </> "build")
+ where
+ verbosity = fromFlag (get_verbosity flags)
+
+ readHook
+ :: (a -> Flag Verbosity)
+ -> (a -> Flag FilePath)
+ -> Args
+ -> a
+ -> IO HookedBuildInfo
+ readHook get_verbosity get_dist_pref a flags = do
+ noExtraFlags a
+ dist_dir <- findDistPrefOrDefault (get_dist_pref flags)
+ getHookedBuildInfo verbosity (dist_dir </> "build")
+ where
+ verbosity = fromFlag (get_verbosity flags)
getHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
getHookedBuildInfo verbosity build_dir = do
maybe_infoFile <- findHookedPackageDesc verbosity build_dir
case maybe_infoFile of
- Nothing -> return emptyHookedBuildInfo
+ Nothing -> return emptyHookedBuildInfo
Just infoFile -> do
info verbosity $ "Reading parameters from " ++ infoFile
readHookedBuildInfo verbosity infoFile
-defaultTestHook :: Args -> PackageDescription -> LocalBuildInfo
- -> UserHooks -> TestFlags -> IO ()
+defaultTestHook
+ :: Args
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> TestFlags
+ -> IO ()
defaultTestHook args pkg_descr localbuildinfo _ flags =
- test args pkg_descr localbuildinfo flags
-
-defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
- -> UserHooks -> BenchmarkFlags -> IO ()
+ test args pkg_descr localbuildinfo flags
+
+defaultBenchHook
+ :: Args
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> BenchmarkFlags
+ -> IO ()
defaultBenchHook args pkg_descr localbuildinfo _ flags =
- bench args pkg_descr localbuildinfo flags
-
-defaultInstallHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> InstallFlags -> IO ()
+ bench args pkg_descr localbuildinfo flags
+
+defaultInstallHook
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> InstallFlags
+ -> IO ()
defaultInstallHook pkg_descr localbuildinfo _ flags = do
- let copyFlags = defaultCopyFlags {
- copyDistPref = installDistPref flags,
- copyDest = installDest flags,
- copyVerbosity = installVerbosity flags
- }
+ let copyFlags =
+ defaultCopyFlags
+ { copyDistPref = installDistPref flags
+ , copyDest = installDest flags
+ , copyVerbosity = installVerbosity flags
+ }
install pkg_descr localbuildinfo copyFlags
- let registerFlags = defaultRegisterFlags {
- regDistPref = installDistPref flags,
- regInPlace = installInPlace flags,
- regPackageDB = installPackageDB flags,
- regVerbosity = installVerbosity flags
- }
+ let registerFlags =
+ defaultRegisterFlags
+ { regDistPref = installDistPref flags
+ , regInPlace = installInPlace flags
+ , regPackageDB = installPackageDB flags
+ , regVerbosity = installVerbosity flags
+ }
when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags
-defaultBuildHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> BuildFlags -> IO ()
+defaultBuildHook
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> BuildFlags
+ -> IO ()
defaultBuildHook pkg_descr localbuildinfo hooks flags =
build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)
-defaultReplHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> ReplFlags -> [String] -> IO ()
+defaultReplHook
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> ReplFlags
+ -> [String]
+ -> IO ()
defaultReplHook pkg_descr localbuildinfo hooks flags args =
repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args
-defaultRegHook :: PackageDescription -> LocalBuildInfo
- -> UserHooks -> RegisterFlags -> IO ()
+defaultRegHook
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> UserHooks
+ -> RegisterFlags
+ -> IO ()
defaultRegHook pkg_descr localbuildinfo _ flags =
- if hasLibs pkg_descr
+ if hasLibs pkg_descr
then register pkg_descr localbuildinfo flags
- else setupMessage (fromFlag (regVerbosity flags))
- "Package contains no library to register:" (packageId pkg_descr)
+ else
+ setupMessage
+ (fromFlag (regVerbosity flags))
+ "Package contains no library to register:"
+ (packageId pkg_descr)
diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs
index 6484654c0cae68ec49c4c6c2b768c96b507a771e..77b3d1a1227aa6faee7a2d67ea53d8145056d190 100644
--- a/Cabal/src/Distribution/Simple/Bench.hs
+++ b/Cabal/src/Distribution/Simple/Bench.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Bench
-- Copyright : Johan Tibell 2011
@@ -13,114 +14,135 @@
-- This is the entry point into running the benchmarks in a built
-- package. It performs the \"@.\/setup bench@\" action. It runs
-- benchmarks designated in the package description.
-
module Distribution.Simple.Bench
- ( bench
- ) where
+ ( bench
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
import qualified Distribution.PackageDescription as PD
+import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
+import Distribution.Simple.Flag (fromFlag)
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
-import Distribution.Simple.Flag ( fromFlag )
import Distribution.Simple.Setup.Benchmark
import Distribution.Simple.UserHooks
import Distribution.Simple.Utils
-import Distribution.Pretty
+import Distribution.Types.UnqualComponentName
-import System.Directory ( doesFileExist )
-import System.FilePath ( (</>), (<.>) )
+import System.Directory (doesFileExist)
+import System.FilePath ((<.>), (</>))
-- | Perform the \"@.\/setup bench@\" action.
-bench :: Args -- ^positional command-line arguments
- -> PD.PackageDescription -- ^information from the .cabal file
- -> LBI.LocalBuildInfo -- ^information from the configure step
- -> BenchmarkFlags -- ^flags sent to benchmark
- -> IO ()
+bench
+ :: Args
+ -- ^ positional command-line arguments
+ -> PD.PackageDescription
+ -- ^ information from the .cabal file
+ -> LBI.LocalBuildInfo
+ -- ^ information from the configure step
+ -> BenchmarkFlags
+ -- ^ flags sent to benchmark
+ -> IO ()
bench args pkg_descr lbi flags = do
- let verbosity = fromFlag $ benchmarkVerbosity flags
- benchmarkNames = args
- pkgBenchmarks = PD.benchmarks pkg_descr
- enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)
+ let verbosity = fromFlag $ benchmarkVerbosity flags
+ benchmarkNames = args
+ pkgBenchmarks = PD.benchmarks pkg_descr
+ enabledBenchmarks = map fst (LBI.enabledBenchLBIs pkg_descr lbi)
- -- Run the benchmark
- doBench :: PD.Benchmark -> IO ExitCode
- doBench bm =
- case PD.benchmarkInterface bm of
- PD.BenchmarkExeV10 _ _ -> do
- let cmd = LBI.buildDir lbi </> name </> name <.> exeExtension (LBI.hostPlatform lbi)
- options = map (benchOption pkg_descr lbi bm) $
- benchmarkOptions flags
- -- Check that the benchmark executable exists.
- exists <- doesFileExist cmd
- unless exists $ die' verbosity $
- "Could not find benchmark program \""
- ++ cmd ++ "\". Did you build the package first?"
+ -- Run the benchmark
+ doBench :: PD.Benchmark -> IO ExitCode
+ doBench bm =
+ case PD.benchmarkInterface bm of
+ PD.BenchmarkExeV10 _ _ -> do
+ let cmd = LBI.buildDir lbi </> name </> name <.> exeExtension (LBI.hostPlatform lbi)
+ options =
+ map (benchOption pkg_descr lbi bm) $
+ benchmarkOptions flags
+ -- Check that the benchmark executable exists.
+ exists <- doesFileExist cmd
+ unless exists $
+ die' verbosity $
+ "Could not find benchmark program \""
+ ++ cmd
+ ++ "\". Did you build the package first?"
- notice verbosity $ startMessage name
- -- This will redirect the child process
- -- stdout/stderr to the parent process.
- exitcode <- rawSystemExitCode verbosity cmd options
- notice verbosity $ finishMessage name exitcode
- return exitcode
+ notice verbosity $ startMessage name
+ -- This will redirect the child process
+ -- stdout/stderr to the parent process.
+ exitcode <- rawSystemExitCode verbosity cmd options
+ notice verbosity $ finishMessage name exitcode
+ return exitcode
+ _ -> do
+ notice verbosity $
+ "No support for running "
+ ++ "benchmark "
+ ++ name
+ ++ " of type: "
+ ++ prettyShow (PD.benchmarkType bm)
+ exitFailure
+ where
+ name = unUnqualComponentName $ PD.benchmarkName bm
- _ -> do
- notice verbosity $ "No support for running "
- ++ "benchmark " ++ name ++ " of type: "
- ++ prettyShow (PD.benchmarkType bm)
- exitFailure
- where name = unUnqualComponentName $ PD.benchmarkName bm
+ unless (PD.hasBenchmarks pkg_descr) $ do
+ notice verbosity "Package has no benchmarks."
+ exitSuccess
- unless (PD.hasBenchmarks pkg_descr) $ do
- notice verbosity "Package has no benchmarks."
- exitSuccess
+ when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
+ die' verbosity $
+ "No benchmarks enabled. Did you remember to configure with "
+ ++ "\'--enable-benchmarks\'?"
- when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
- die' verbosity $ "No benchmarks enabled. Did you remember to configure with "
- ++ "\'--enable-benchmarks\'?"
+ bmsToRun <- case benchmarkNames of
+ [] -> return enabledBenchmarks
+ names -> for names $ \bmName ->
+ let benchmarkMap = zip enabledNames enabledBenchmarks
+ enabledNames = map PD.benchmarkName enabledBenchmarks
+ allNames = map PD.benchmarkName pkgBenchmarks
+ in case lookup (mkUnqualComponentName bmName) benchmarkMap of
+ Just t -> return t
+ _
+ | mkUnqualComponentName bmName `elem` allNames ->
+ die' verbosity $
+ "Package configured with benchmark "
+ ++ bmName
+ ++ " disabled."
+ | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName
- bmsToRun <- case benchmarkNames of
- [] -> return enabledBenchmarks
- names -> for names $ \bmName ->
- let benchmarkMap = zip enabledNames enabledBenchmarks
- enabledNames = map PD.benchmarkName enabledBenchmarks
- allNames = map PD.benchmarkName pkgBenchmarks
- in case lookup (mkUnqualComponentName bmName) benchmarkMap of
- Just t -> return t
- _ | mkUnqualComponentName bmName `elem` allNames ->
- die' verbosity $ "Package configured with benchmark "
- ++ bmName ++ " disabled."
- | otherwise -> die' verbosity $ "no such benchmark: " ++ bmName
-
- let totalBenchmarks = length bmsToRun
- notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
- exitcodes <- traverse doBench bmsToRun
- let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
- unless allOk exitFailure
+ let totalBenchmarks = length bmsToRun
+ notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
+ exitcodes <- traverse doBench bmsToRun
+ let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
+ unless allOk exitFailure
where
startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"
- finishMessage name exitcode = "Benchmark " ++ name ++ ": "
- ++ (case exitcode of
- ExitSuccess -> "FINISH"
- ExitFailure _ -> "ERROR")
-
+ finishMessage name exitcode =
+ "Benchmark "
+ ++ name
+ ++ ": "
+ ++ ( case exitcode of
+ ExitSuccess -> "FINISH"
+ ExitFailure _ -> "ERROR"
+ )
-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't
-- necessarily a path.
-benchOption :: PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> PD.Benchmark
- -> PathTemplate
- -> String
+benchOption
+ :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> PD.Benchmark
+ -> PathTemplate
+ -> String
benchOption pkg_descr lbi bm template =
- fromPathTemplate $ substPathTemplate env template
+ fromPathTemplate $ substPathTemplate env template
where
- env = initialPathTemplateEnv
- (PD.package pkg_descr) (LBI.localUnitId lbi)
- (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
- [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]
+ env =
+ initialPathTemplateEnv
+ (PD.package pkg_descr)
+ (LBI.localUnitId lbi)
+ (compilerInfo $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
+ ++ [(BenchmarkNameVar, toPathTemplate $ unUnqualComponentName $ PD.benchmarkName bm)]
diff --git a/Cabal/src/Distribution/Simple/Build.hs b/Cabal/src/Distribution/Simple/Build.hs
index 04659830f1258079aeb2a16686d5ac500fefe337..c2e421045bf1802a1273c4931931400760d9b6c6 100644
--- a/Cabal/src/Distribution/Simple/Build.hs
+++ b/Cabal/src/Distribution/Simple/Build.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Build
-- Copyright : Isaac Jones 2003-2005,
@@ -16,21 +17,19 @@
-- doesn't actually do much itself, most of the work is delegated to
-- compiler-specific actions. It does do some non-compiler specific bits like
-- running pre-processors.
---
-
-module Distribution.Simple.Build (
- build, repl,
- startInterpreter,
-
- initialBuildSteps,
- createInternalPackageDB,
- componentInitialBuildSteps,
- writeAutogenFiles,
+module Distribution.Simple.Build
+ ( build
+ , repl
+ , startInterpreter
+ , initialBuildSteps
+ , createInternalPackageDB
+ , componentInitialBuildSteps
+ , writeAutogenFiles
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Utils.Generic
+import Prelude ()
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
@@ -39,79 +38,88 @@ import Distribution.Types.ExecutableScope
import Distribution.Types.ForeignLib
import Distribution.Types.LibraryVisibility
import Distribution.Types.LocalBuildInfo
+import Distribution.Types.ModuleRenaming
import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
-import Distribution.Types.ModuleRenaming
import Distribution.Types.TargetInfo
import Distribution.Utils.Path
-import Distribution.Package
import Distribution.Backpack
import Distribution.Backpack.DescribeUnitId
-import qualified Distribution.Simple.GHC as GHC
+import Distribution.Package
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
-import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import qualified Distribution.Simple.PackageIndex as Index
+import qualified Distribution.Simple.UHC as UHC
-import Distribution.Simple.Build.Macros (generateCabalMacrosHeader)
+import Distribution.Simple.Build.Macros (generateCabalMacrosHeader)
import Distribution.Simple.Build.PackageInfoModule (generatePackageInfoModule)
import Distribution.Simple.Build.PathsModule (generatePathsModule)
import qualified Distribution.Simple.Program.HcPkg as HcPkg
-import Distribution.Simple.Compiler
-import Distribution.PackageDescription
-import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.ModuleName as ModuleName
+import Distribution.PackageDescription
+import Distribution.Simple.Compiler
-import Distribution.Simple.Flag
-import Distribution.Simple.Setup.Build
-import Distribution.Simple.Setup.Config
-import Distribution.Simple.Setup.Repl
+import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
import Distribution.Simple.BuildToolDepends
-import Distribution.Simple.PreProcess
+import Distribution.Simple.Configure
+import Distribution.Simple.Flag
import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.PreProcess
import Distribution.Simple.Program
import Distribution.Simple.Program.Builtin (haskellSuiteProgram)
-import qualified Distribution.Simple.Program.GHC as GHC
+import qualified Distribution.Simple.Program.GHC as GHC
import Distribution.Simple.Program.Types
-import Distribution.Simple.ShowBuildInfo
-import Distribution.Simple.BuildPaths
-import Distribution.Simple.Configure
import Distribution.Simple.Register
+import Distribution.Simple.Setup.Build
+import Distribution.Simple.Setup.Config
+import Distribution.Simple.Setup.Repl
+import Distribution.Simple.ShowBuildInfo
import Distribution.Simple.Test.LibV09
import Distribution.Simple.Utils
import Distribution.Utils.Json
-import Distribution.System
import Distribution.Pretty
+import Distribution.System
import Distribution.Verbosity
import Distribution.Version (thisVersion)
-import Distribution.Compat.Graph (IsNode(..))
+import Distribution.Compat.Graph (IsNode (..))
import Control.Monad
import qualified Data.ByteString.Lazy as LBS
-import System.FilePath ( (</>), (<.>), takeDirectory )
-import System.Directory ( getCurrentDirectory, removeFile, doesFileExist )
+import System.Directory (doesFileExist, getCurrentDirectory, removeFile)
+import System.FilePath (takeDirectory, (<.>), (</>))
-- -----------------------------------------------------------------------------
--- |Build the libraries and executables in this package.
-build :: PackageDescription -- ^ Mostly information from the .cabal file
- -> LocalBuildInfo -- ^ Configuration information
- -> BuildFlags -- ^ Flags that the user passed to build
- -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling
- -> IO ()
+-- | Build the libraries and executables in this package.
+build
+ :: PackageDescription
+ -- ^ Mostly information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ Configuration information
+ -> BuildFlags
+ -- ^ Flags that the user passed to build
+ -> [PPSuffixHandler]
+ -- ^ preprocessors to run before compiling
+ -> IO ()
build pkg_descr lbi flags suffixes = do
targets <- readTargetInfos verbosity pkg_descr lbi (buildArgs flags)
let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets)
- info verbosity $ "Component build order: "
- ++ intercalate ", "
- (map (showComponentName . componentLocalName . targetCLBI)
- componentsToBuild)
+ info verbosity $
+ "Component build order: "
+ ++ intercalate
+ ", "
+ ( map
+ (showComponentName . componentLocalName . targetCLBI)
+ componentsToBuild
+ )
when (null targets) $
-- Only bother with this message if we're building the whole package
@@ -129,22 +137,30 @@ build pkg_descr lbi flags suffixes = do
let comp = targetComponent target
clbi = targetCLBI target
componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
- let bi = componentBuildInfo comp
+ let bi = componentBuildInfo comp
progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
- lbi' = lbi {
- withPrograms = progs',
- withPackageDB = withPackageDB lbi ++ [internalPackageDB],
- installedPkgs = index
- }
- mb_ipi <- buildComponent verbosity (buildNumJobs flags) pkg_descr
- lbi' suffixes comp clbi distPref
+ lbi' =
+ lbi
+ { withPrograms = progs'
+ , withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+ , installedPkgs = index
+ }
+ mb_ipi <-
+ buildComponent
+ verbosity
+ (buildNumJobs flags)
+ pkg_descr
+ lbi'
+ suffixes
+ comp
+ clbi
+ distPref
return (maybe index (Index.insert `flip` index) mb_ipi)
return ()
- where
- distPref = fromFlag (buildDistPref flags)
- verbosity = fromFlag (buildVerbosity flags)
-
+ where
+ distPref = fromFlag (buildDistPref flags)
+ verbosity = fromFlag (buildVerbosity flags)
-- | Write available build information for 'LocalBuildInfo' to disk.
--
@@ -152,34 +168,47 @@ build pkg_descr lbi flags suffixes = do
-- Build information contains basics such as compiler details, but also
-- lists what modules a component contains and how to compile the component, assuming
-- lib:Cabal made sure that dependencies are up-to-date.
-dumpBuildInfo :: Verbosity
- -> FilePath -- ^ To which directory should the build-info be dumped?
- -> Flag DumpBuildInfo -- ^ Should we dump detailed build information for this component?
- -> PackageDescription -- ^ Mostly information from the .cabal file
- -> LocalBuildInfo -- ^ Configuration information
- -> BuildFlags -- ^ Flags that the user passed to build
- -> IO ()
+dumpBuildInfo
+ :: Verbosity
+ -> FilePath
+ -- ^ To which directory should the build-info be dumped?
+ -> Flag DumpBuildInfo
+ -- ^ Should we dump detailed build information for this component?
+ -> PackageDescription
+ -- ^ Mostly information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ Configuration information
+ -> BuildFlags
+ -- ^ Flags that the user passed to build
+ -> IO ()
dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
when shouldDumpBuildInfo $ do
-- Changing this line might break consumers of the dumped build info.
-- Announce changes on mailing lists!
let activeTargets = allTargetsInBuildOrder' pkg_descr lbi
- info verbosity $ "Dump build information for: "
- ++ intercalate ", "
- (map (showComponentName . componentLocalName . targetCLBI)
- activeTargets)
+ info verbosity $
+ "Dump build information for: "
+ ++ intercalate
+ ", "
+ ( map
+ (showComponentName . componentLocalName . targetCLBI)
+ activeTargets
+ )
pwd <- getCurrentDirectory
(compilerProg, _) <- case flavorToProgram (compilerFlavor (compiler lbi)) of
- Nothing -> die' verbosity $ "dumpBuildInfo: Unknown compiler flavor: "
- ++ show (compilerFlavor (compiler lbi))
+ Nothing ->
+ die' verbosity $
+ "dumpBuildInfo: Unknown compiler flavor: "
+ ++ show (compilerFlavor (compiler lbi))
Just program -> requireProgram verbosity program (withPrograms lbi)
let (warns, json) = mkBuildInfo pwd pkg_descr lbi flags (compilerProg, compiler lbi) activeTargets
buildInfoText = renderJson json
unless (null warns) $
- warn verbosity $ "Encountered warnings while dumping build-info:\n"
- ++ unlines warns
+ warn verbosity $
+ "Encountered warnings while dumping build-info:\n"
+ ++ unlines warns
LBS.writeFile (buildInfoPref distPref) buildInfoText
when (not shouldDumpBuildInfo) $ do
@@ -189,58 +218,80 @@ dumpBuildInfo verbosity distPref dumpBuildInfoFlag pkg_descr lbi flags = do
where
shouldDumpBuildInfo = fromFlagOrDefault NoDumpBuildInfo dumpBuildInfoFlag == DumpBuildInfo
- -- | Given the flavor of the compiler, try to find out
+ -- \| Given the flavor of the compiler, try to find out
-- which program we need.
flavorToProgram :: CompilerFlavor -> Maybe Program
- flavorToProgram GHC = Just ghcProgram
- flavorToProgram GHCJS = Just ghcjsProgram
- flavorToProgram UHC = Just uhcProgram
- flavorToProgram JHC = Just jhcProgram
- flavorToProgram HaskellSuite {} = Just haskellSuiteProgram
- flavorToProgram _ = Nothing
-
-
-repl :: PackageDescription -- ^ Mostly information from the .cabal file
- -> LocalBuildInfo -- ^ Configuration information
- -> ReplFlags -- ^ Flags that the user passed to build
- -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling
- -> [String]
- -> IO ()
+ flavorToProgram GHC = Just ghcProgram
+ flavorToProgram GHCJS = Just ghcjsProgram
+ flavorToProgram UHC = Just uhcProgram
+ flavorToProgram JHC = Just jhcProgram
+ flavorToProgram HaskellSuite{} = Just haskellSuiteProgram
+ flavorToProgram _ = Nothing
+
+repl
+ :: PackageDescription
+ -- ^ Mostly information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ Configuration information
+ -> ReplFlags
+ -- ^ Flags that the user passed to build
+ -> [PPSuffixHandler]
+ -- ^ preprocessors to run before compiling
+ -> [String]
+ -> IO ()
repl pkg_descr lbi flags suffixes args = do
- let distPref = fromFlag (replDistPref flags)
+ let distPref = fromFlag (replDistPref flags)
verbosity = fromFlag (replVerbosity flags)
- target <- readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of
- -- This seems DEEPLY questionable.
- [] -> case allTargetsInBuildOrder' pkg_descr lbi of
- (target:_) -> return target
- [] -> die' verbosity $ "Failed to determine target."
- [target] -> return target
- _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once."
+ target <-
+ readTargetInfos verbosity pkg_descr lbi args >>= \r -> case r of
+ -- This seems DEEPLY questionable.
+ [] -> case allTargetsInBuildOrder' pkg_descr lbi of
+ (target : _) -> return target
+ [] -> die' verbosity $ "Failed to determine target."
+ [target] -> return target
+ _ -> die' verbosity $ "The 'repl' command does not support multiple targets at once."
let componentsToBuild = neededTargetsInBuildOrder' pkg_descr lbi [nodeKey target]
- debug verbosity $ "Component build order: "
- ++ intercalate ", "
- (map (showComponentName . componentLocalName . targetCLBI)
- componentsToBuild)
+ debug verbosity $
+ "Component build order: "
+ ++ intercalate
+ ", "
+ ( map
+ (showComponentName . componentLocalName . targetCLBI)
+ componentsToBuild
+ )
internalPackageDB <- createInternalPackageDB verbosity lbi distPref
let lbiForComponent comp lbi' =
- lbi' {
- withPackageDB = withPackageDB lbi ++ [internalPackageDB],
- withPrograms = addInternalBuildTools pkg_descr lbi'
- (componentBuildInfo comp) (withPrograms lbi')
- }
+ lbi'
+ { withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+ , withPrograms =
+ addInternalBuildTools
+ pkg_descr
+ lbi'
+ (componentBuildInfo comp)
+ (withPrograms lbi')
+ }
-- build any dependent components
sequence_
- [ do let clbi = targetCLBI subtarget
- comp = targetComponent subtarget
- lbi' = lbiForComponent comp lbi
- componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
- buildComponent verbosity NoFlag
- pkg_descr lbi' suffixes comp clbi distPref
- | subtarget <- safeInit componentsToBuild ]
+ [ do
+ let clbi = targetCLBI subtarget
+ comp = targetComponent subtarget
+ lbi' = lbiForComponent comp lbi
+ componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
+ buildComponent
+ verbosity
+ NoFlag
+ pkg_descr
+ lbi'
+ suffixes
+ comp
+ clbi
+ distPref
+ | subtarget <- safeInit componentsToBuild
+ ]
-- REPL for target components
let clbi = targetCLBI target
@@ -250,39 +301,58 @@ repl pkg_descr lbi flags suffixes args = do
componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
replComponent replFlags verbosity pkg_descr lbi' suffixes comp clbi distPref
-
-- | Start an interpreter without loading any package files.
-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform
- -> PackageDBStack -> IO ()
+startInterpreter
+ :: Verbosity
+ -> ProgramDb
+ -> Compiler
+ -> Platform
+ -> PackageDBStack
+ -> IO ()
startInterpreter verbosity programDb comp platform packageDBs =
case compilerFlavor comp of
- GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs
+ GHC -> GHC.startInterpreter verbosity programDb comp platform packageDBs
GHCJS -> GHCJS.startInterpreter verbosity programDb comp platform packageDBs
- _ -> die' verbosity "A REPL is not supported with this compiler."
-
-buildComponent :: Verbosity
- -> Flag (Maybe Int)
- -> PackageDescription
- -> LocalBuildInfo
- -> [PPSuffixHandler]
- -> Component
- -> ComponentLocalBuildInfo
- -> FilePath
- -> IO (Maybe InstalledPackageInfo)
-buildComponent verbosity numJobs pkg_descr lbi suffixes
- comp@(CLib lib) clbi distPref = do
+ _ -> die' verbosity "A REPL is not supported with this compiler."
+
+buildComponent
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> Component
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> IO (Maybe InstalledPackageInfo)
+buildComponent
+ verbosity
+ numJobs
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CLib lib)
+ clbi
+ distPref = do
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
- setupMessage' verbosity "Building" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+ setupMessage'
+ verbosity
+ "Building"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
let libbi = libBuildInfo lib
- lib' = lib { libBuildInfo = flip addExtraAsmSources extras
- $ flip addExtraCmmSources extras
- $ flip addExtraCxxSources extras
- $ flip addExtraCSources extras
- $ flip addExtraJsSources extras
- $ libbi
- }
+ lib' =
+ lib
+ { libBuildInfo =
+ flip addExtraAsmSources extras $
+ flip addExtraCmmSources extras $
+ flip addExtraCxxSources extras $
+ flip addExtraCSources extras $
+ flip addExtraJsSources extras $
+ libbi
+ }
buildLib verbosity numJobs pkg_descr lbi lib' clbi
@@ -296,262 +366,382 @@ buildComponent verbosity numJobs pkg_descr lbi suffixes
-- Register the library in-place, so exes can depend
-- on internally defined libraries.
pwd <- getCurrentDirectory
- let -- The in place registration uses the "-inplace" suffix, not an ABI hash
- installedPkgInfo = inplaceInstalledPackageInfo pwd distPref pkg_descr
- -- NB: Use a fake ABI hash to avoid
- -- needing to recompute it every build.
- (mkAbiHash "inplace") lib' lbi clbi
+ let
+ -- The in place registration uses the "-inplace" suffix, not an ABI hash
+ installedPkgInfo =
+ inplaceInstalledPackageInfo
+ pwd
+ distPref
+ pkg_descr
+ -- NB: Use a fake ABI hash to avoid
+ -- needing to recompute it every build.
+ (mkAbiHash "inplace")
+ lib'
+ lbi
+ clbi
debug verbosity $ "Registering inplace:\n" ++ (IPI.showInstalledPackageInfo installedPkgInfo)
- registerPackage verbosity (compiler lbi) (withPrograms lbi)
- (withPackageDB lbi) installedPkgInfo
- HcPkg.defaultRegisterOptions {
- HcPkg.registerMultiInstance = True
- }
+ registerPackage
+ verbosity
+ (compiler lbi)
+ (withPrograms lbi)
+ (withPackageDB lbi)
+ installedPkgInfo
+ HcPkg.defaultRegisterOptions
+ { HcPkg.registerMultiInstance = True
+ }
return (Just installedPkgInfo)
else return Nothing
-
-buildComponent verbosity numJobs pkg_descr lbi suffixes
- comp@(CFLib flib) clbi _distPref = do
+buildComponent
+ verbosity
+ numJobs
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CFLib flib)
+ clbi
+ _distPref = do
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
- setupMessage' verbosity "Building" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+ setupMessage'
+ verbosity
+ "Building"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
buildFLib verbosity numJobs pkg_descr lbi flib clbi
return Nothing
-
-buildComponent verbosity numJobs pkg_descr lbi suffixes
- comp@(CExe exe) clbi _ = do
+buildComponent
+ verbosity
+ numJobs
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CExe exe)
+ clbi
+ _ = do
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
- setupMessage' verbosity "Building" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+ setupMessage'
+ verbosity
+ "Building"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
let ebi = buildInfo exe
- exe' = exe { buildInfo = addExtraCSources ebi extras }
+ exe' = exe{buildInfo = addExtraCSources ebi extras}
buildExe verbosity numJobs pkg_descr lbi exe' clbi
return Nothing
-
-
-buildComponent verbosity numJobs pkg_descr lbi suffixes
- comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })
- clbi _distPref = do
+buildComponent
+ verbosity
+ numJobs
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CTest test@TestSuite{testInterface = TestSuiteExeV10{}})
+ clbi
+ _distPref = do
let exe = testSuiteExeV10AsExe test
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
(genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity
- setupMessage' verbosity "Building" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+ setupMessage'
+ verbosity
+ "Building"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
let ebi = buildInfo exe
- exe' = exe { buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir } -- todo extend hssrcdirs
+ exe' = exe{buildInfo = addSrcDir (addExtraOtherModules (addExtraCSources ebi extras) generatedExtras) genDir} -- todo extend hssrcdirs
buildExe verbosity numJobs pkg_descr lbi exe' clbi
return Nothing
-
-buildComponent verbosity numJobs pkg_descr lbi0 suffixes
- comp@(CTest
- test@TestSuite { testInterface = TestSuiteLibV09{} })
- clbi -- This ComponentLocalBuildInfo corresponds to a detailed
- -- test suite and not a real component. It should not
- -- be used, except to construct the CLBIs for the
- -- library and stub executable that will actually be
- -- built.
- distPref = do
+buildComponent
+ verbosity
+ numJobs
+ pkg_descr
+ lbi0
+ suffixes
+ comp@( CTest
+ test@TestSuite{testInterface = TestSuiteLibV09{}}
+ )
+ clbi -- This ComponentLocalBuildInfo corresponds to a detailed
+ -- test suite and not a real component. It should not
+ -- be used, except to construct the CLBIs for the
+ -- library and stub executable that will actually be
+ -- built.
+ distPref = do
pwd <- getCurrentDirectory
let (pkg, lib, libClbi, lbi, ipi, exe, exeClbi) =
testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi -- TODO find cpphs processed files
(genDir, generatedExtras) <- generateCode (testCodeGenerators test) (testName test) pkg_descr (testBuildInfo test) lbi clbi verbosity
- setupMessage' verbosity "Building" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+ setupMessage'
+ verbosity
+ "Building"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
let libbi = libBuildInfo lib
- lib' = lib { libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir }
+ lib' = lib{libBuildInfo = addSrcDir (addExtraOtherModules libbi generatedExtras) genDir}
buildLib verbosity numJobs pkg lbi lib' libClbi
-- NB: need to enable multiple instances here, because on 7.10+
-- the package name is the same as the library, and we still
-- want the registration to go through.
- registerPackage verbosity (compiler lbi) (withPrograms lbi)
- (withPackageDB lbi) ipi
- HcPkg.defaultRegisterOptions {
- HcPkg.registerMultiInstance = True
- }
+ registerPackage
+ verbosity
+ (compiler lbi)
+ (withPrograms lbi)
+ (withPackageDB lbi)
+ ipi
+ HcPkg.defaultRegisterOptions
+ { HcPkg.registerMultiInstance = True
+ }
let ebi = buildInfo exe
-- NB: The stub executable is linked against the test-library
-- which already contains all `other-modules`, so we need
-- to remove those from the stub-exe's build-info
- exe' = exe { buildInfo = (addExtraCSources ebi extras) { otherModules = [] } }
+ exe' = exe{buildInfo = (addExtraCSources ebi extras){otherModules = []}}
buildExe verbosity numJobs pkg_descr lbi exe' exeClbi
return Nothing -- Can't depend on test suite
-
-
-buildComponent verbosity _ _ _ _
- (CTest TestSuite { testInterface = TestSuiteUnsupported tt })
- _ _ =
+buildComponent
+ verbosity
+ _
+ _
+ _
+ _
+ (CTest TestSuite{testInterface = TestSuiteUnsupported tt})
+ _
+ _ =
die' verbosity $ "No support for building test suite type " ++ prettyShow tt
-
-
-buildComponent verbosity numJobs pkg_descr lbi suffixes
- comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })
- clbi _distPref = do
+buildComponent
+ verbosity
+ numJobs
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}})
+ clbi
+ _distPref = do
let exe = benchmarkExeV10asExe bm
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
- setupMessage' verbosity "Building" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
+ setupMessage'
+ verbosity
+ "Building"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
let ebi = buildInfo exe
- exe' = exe { buildInfo = addExtraCSources ebi extras }
+ exe' = exe{buildInfo = addExtraCSources ebi extras}
buildExe verbosity numJobs pkg_descr lbi exe' clbi
return Nothing
-
-
-buildComponent verbosity _ _ _ _
- (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })
- _ _ =
+buildComponent
+ verbosity
+ _
+ _
+ _
+ _
+ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt})
+ _
+ _ =
die' verbosity $ "No support for building benchmark type " ++ prettyShow tt
-
-
generateCode
- :: [String]
- -> UnqualComponentName
- -> PackageDescription
- -> BuildInfo
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Verbosity
- -> IO (FilePath, [ModuleName.ModuleName])
+ :: [String]
+ -> UnqualComponentName
+ -> PackageDescription
+ -> BuildInfo
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Verbosity
+ -> IO (FilePath, [ModuleName.ModuleName])
generateCode codeGens nm pdesc bi lbi clbi verbosity = do
- when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir
- (\x -> (tgtDir,x)) . concat <$> mapM go codeGens
- where
- allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc)
- dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi
- srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs
- nm' = unUnqualComponentName nm
- tgtDir = buildDir lbi </> nm' </> nm' ++ "-gen"
- go :: String -> IO [ModuleName.ModuleName]
- go codeGenProg = fmap fromString . lines <$> getDbProgramOutput verbosity (simpleProgram codeGenProg) (withPrograms lbi)
- ((tgtDir : map getSymbolicPath srcDirs) ++
- ("--" :
- GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir)))
-
+ when (not . null $ codeGens) $ createDirectoryIfMissingVerbose verbosity True tgtDir
+ (\x -> (tgtDir, x)) . concat <$> mapM go codeGens
+ where
+ allLibs = (maybe id (:) $ library pdesc) (subLibraries pdesc)
+ dependencyLibs = filter (const True) allLibs -- intersect with componentPackageDeps of clbi
+ srcDirs = concatMap (hsSourceDirs . libBuildInfo) dependencyLibs
+ nm' = unUnqualComponentName nm
+ tgtDir = buildDir lbi </> nm' </> nm' ++ "-gen"
+ go :: String -> IO [ModuleName.ModuleName]
+ go codeGenProg =
+ fmap fromString . lines
+ <$> getDbProgramOutput
+ verbosity
+ (simpleProgram codeGenProg)
+ (withPrograms lbi)
+ ( (tgtDir : map getSymbolicPath srcDirs)
+ ++ ( "--"
+ : GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) (GHC.componentGhcOptions verbosity lbi bi clbi tgtDir)
+ )
+ )
-- | Add extra C sources generated by preprocessing to build
-- information.
addExtraCSources :: BuildInfo -> [FilePath] -> BuildInfo
-addExtraCSources bi extras = bi { cSources = new }
- where new = ordNub (extras ++ cSources bi)
+addExtraCSources bi extras = bi{cSources = new}
+ where
+ new = ordNub (extras ++ cSources bi)
-- | Add extra C++ sources generated by preprocessing to build
-- information.
addExtraCxxSources :: BuildInfo -> [FilePath] -> BuildInfo
-addExtraCxxSources bi extras = bi { cxxSources = new }
- where new = ordNub (extras ++ cxxSources bi)
+addExtraCxxSources bi extras = bi{cxxSources = new}
+ where
+ new = ordNub (extras ++ cxxSources bi)
-- | Add extra C-- sources generated by preprocessing to build
-- information.
addExtraCmmSources :: BuildInfo -> [FilePath] -> BuildInfo
-addExtraCmmSources bi extras = bi { cmmSources = new }
- where new = ordNub (extras ++ cmmSources bi)
+addExtraCmmSources bi extras = bi{cmmSources = new}
+ where
+ new = ordNub (extras ++ cmmSources bi)
-- | Add extra ASM sources generated by preprocessing to build
-- information.
addExtraAsmSources :: BuildInfo -> [FilePath] -> BuildInfo
-addExtraAsmSources bi extras = bi { asmSources = new }
- where new = ordNub (extras ++ asmSources bi)
+addExtraAsmSources bi extras = bi{asmSources = new}
+ where
+ new = ordNub (extras ++ asmSources bi)
-- | Add extra JS sources generated by preprocessing to build
-- information.
addExtraJsSources :: BuildInfo -> [FilePath] -> BuildInfo
-addExtraJsSources bi extras = bi { jsSources = new }
- where new = ordNub (extras ++ jsSources bi)
-
+addExtraJsSources bi extras = bi{jsSources = new}
+ where
+ new = ordNub (extras ++ jsSources bi)
-- | Add extra HS modules generated by preprocessing to build
-- information.
addExtraOtherModules :: BuildInfo -> [ModuleName.ModuleName] -> BuildInfo
-addExtraOtherModules bi extras = bi { otherModules = new }
- where new = ordNub (extras ++ otherModules bi)
+addExtraOtherModules bi extras = bi{otherModules = new}
+ where
+ new = ordNub (extras ++ otherModules bi)
-- | Add extra source dir for generated modules.
addSrcDir :: BuildInfo -> FilePath -> BuildInfo
-addSrcDir bi extra = bi { hsSourceDirs = new }
- where new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi)
-
-replComponent :: ReplOptions
- -> Verbosity
- -> PackageDescription
- -> LocalBuildInfo
- -> [PPSuffixHandler]
- -> Component
- -> ComponentLocalBuildInfo
- -> FilePath
- -> IO ()
-replComponent replFlags verbosity pkg_descr lbi suffixes
- comp@(CLib lib) clbi _ = do
+addSrcDir bi extra = bi{hsSourceDirs = new}
+ where
+ new = ordNub (unsafeMakeSymbolicPath extra : hsSourceDirs bi)
+
+replComponent
+ :: ReplOptions
+ -> Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> Component
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> IO ()
+replComponent
+ replFlags
+ verbosity
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CLib lib)
+ clbi
+ _ = do
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
let libbi = libBuildInfo lib
- lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }
+ lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}
replLib replFlags verbosity pkg_descr lbi lib' clbi
-
-replComponent replFlags verbosity pkg_descr lbi suffixes
- comp@(CFLib flib) clbi _ = do
+replComponent
+ replFlags
+ verbosity
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CFLib flib)
+ clbi
+ _ = do
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
replFLib replFlags verbosity pkg_descr lbi flib clbi
-
-replComponent replFlags verbosity pkg_descr lbi suffixes
- comp@(CExe exe) clbi _ = do
+replComponent
+ replFlags
+ verbosity
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CExe exe)
+ clbi
+ _ = do
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
let ebi = buildInfo exe
- exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+ exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}
replExe replFlags verbosity pkg_descr lbi exe' clbi
-
-
-replComponent replFlags verbosity pkg_descr lbi suffixes
- comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })
- clbi _distPref = do
+replComponent
+ replFlags
+ verbosity
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CTest test@TestSuite{testInterface = TestSuiteExeV10{}})
+ clbi
+ _distPref = do
let exe = testSuiteExeV10AsExe test
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
let ebi = buildInfo exe
- exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+ exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}
replExe replFlags verbosity pkg_descr lbi exe' clbi
-
-
-replComponent replFlags verbosity pkg_descr lbi0 suffixes
- comp@(CTest
- test@TestSuite { testInterface = TestSuiteLibV09{} })
- clbi distPref = do
+replComponent
+ replFlags
+ verbosity
+ pkg_descr
+ lbi0
+ suffixes
+ comp@( CTest
+ test@TestSuite{testInterface = TestSuiteLibV09{}}
+ )
+ clbi
+ distPref = do
pwd <- getCurrentDirectory
let (pkg, lib, libClbi, lbi, _, _, _) =
testSuiteLibV09AsLibAndExe pkg_descr test clbi lbi0 distPref pwd
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
let libbi = libBuildInfo lib
- lib' = lib { libBuildInfo = libbi { cSources = cSources libbi ++ extras } }
+ lib' = lib{libBuildInfo = libbi{cSources = cSources libbi ++ extras}}
replLib replFlags verbosity pkg lbi lib' libClbi
-
-
-replComponent _ verbosity _ _ _
- (CTest TestSuite { testInterface = TestSuiteUnsupported tt })
- _ _ =
+replComponent
+ _
+ verbosity
+ _
+ _
+ _
+ (CTest TestSuite{testInterface = TestSuiteUnsupported tt})
+ _
+ _ =
die' verbosity $ "No support for building test suite type " ++ prettyShow tt
-
-
-replComponent replFlags verbosity pkg_descr lbi suffixes
- comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })
- clbi _distPref = do
+replComponent
+ replFlags
+ verbosity
+ pkg_descr
+ lbi
+ suffixes
+ comp@(CBench bm@Benchmark{benchmarkInterface = BenchmarkExeV10{}})
+ clbi
+ _distPref = do
let exe = benchmarkExeV10asExe bm
preprocessComponent pkg_descr comp lbi clbi False verbosity suffixes
extras <- preprocessExtras verbosity comp lbi
let ebi = buildInfo exe
- exe' = exe { buildInfo = ebi { cSources = cSources ebi ++ extras } }
+ exe' = exe{buildInfo = ebi{cSources = cSources ebi ++ extras}}
replExe replFlags verbosity pkg_descr lbi exe' clbi
-
-
-replComponent _ verbosity _ _ _
- (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })
- _ _ =
+replComponent
+ _
+ verbosity
+ _
+ _
+ _
+ (CBench Benchmark{benchmarkInterface = BenchmarkUnsupported tt})
+ _
+ _ =
die' verbosity $ "No support for building benchmark type " ++ prettyShow tt
----------------------------------------------------
@@ -560,272 +750,349 @@ replComponent _ verbosity _ _ _
-- | Translate a exe-style 'TestSuite' component into an exe for building
testSuiteExeV10AsExe :: TestSuite -> Executable
-testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =
- Executable {
- exeName = testName test,
- modulePath = mainFile,
- exeScope = ExecutablePublic,
- buildInfo = testBuildInfo test
+testSuiteExeV10AsExe test@TestSuite{testInterface = TestSuiteExeV10 _ mainFile} =
+ Executable
+ { exeName = testName test
+ , modulePath = mainFile
+ , exeScope = ExecutablePublic
+ , buildInfo = testBuildInfo test
}
testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"
-- | Translate a exe-style 'Benchmark' component into an exe for building
benchmarkExeV10asExe :: Benchmark -> Executable
-benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } =
- Executable {
- exeName = benchmarkName bm,
- modulePath = mainFile,
- exeScope = ExecutablePublic,
- buildInfo = benchmarkBuildInfo bm
+benchmarkExeV10asExe bm@Benchmark{benchmarkInterface = BenchmarkExeV10 _ mainFile} =
+ Executable
+ { exeName = benchmarkName bm
+ , modulePath = mainFile
+ , exeScope = ExecutablePublic
+ , buildInfo = benchmarkBuildInfo bm
}
benchmarkExeV10asExe Benchmark{} = error "benchmarkExeV10asExe: wrong kind"
-- | Translate a lib-style 'TestSuite' component into a lib + exe for building
-testSuiteLibV09AsLibAndExe :: PackageDescription
- -> TestSuite
- -> ComponentLocalBuildInfo
- -> LocalBuildInfo
- -> FilePath
- -> FilePath
- -> (PackageDescription,
- Library, ComponentLocalBuildInfo,
- LocalBuildInfo,
- IPI.InstalledPackageInfo,
- Executable, ComponentLocalBuildInfo)
-testSuiteLibV09AsLibAndExe pkg_descr
- test@TestSuite { testInterface = TestSuiteLibV09 _ m }
- clbi lbi distPref pwd =
+testSuiteLibV09AsLibAndExe
+ :: PackageDescription
+ -> TestSuite
+ -> ComponentLocalBuildInfo
+ -> LocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> ( PackageDescription
+ , Library
+ , ComponentLocalBuildInfo
+ , LocalBuildInfo
+ , IPI.InstalledPackageInfo
+ , Executable
+ , ComponentLocalBuildInfo
+ )
+testSuiteLibV09AsLibAndExe
+ pkg_descr
+ test@TestSuite{testInterface = TestSuiteLibV09 _ m}
+ clbi
+ lbi
+ distPref
+ pwd =
(pkg, lib, libClbi, lbi, ipi, exe, exeClbi)
- where
- bi = testBuildInfo test
- lib = Library {
- libName = LMainLibName,
- exposedModules = [ m ],
- reexportedModules = [],
- signatures = [],
- libExposed = True,
- libVisibility = LibraryVisibilityPrivate,
- libBuildInfo = bi
+ where
+ bi = testBuildInfo test
+ lib =
+ Library
+ { libName = LMainLibName
+ , exposedModules = [m]
+ , reexportedModules = []
+ , signatures = []
+ , libExposed = True
+ , libVisibility = LibraryVisibilityPrivate
+ , libBuildInfo = bi
}
- -- This is, like, the one place where we use a CTestName for a library.
- -- Should NOT use library name, since that could conflict!
- PackageIdentifier pkg_name pkg_ver = package pkg_descr
- -- Note: we do make internal library from the test!
- compat_name = MungedPackageName pkg_name (LSubLibName (testName test))
- compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)
- libClbi = LibComponentLocalBuildInfo
- { componentPackageDeps = componentPackageDeps clbi
- , componentInternalDeps = componentInternalDeps clbi
- , componentIsIndefinite_ = False
- , componentExeDeps = componentExeDeps clbi
- , componentLocalName = CLibName $ LSubLibName $ testName test
- , componentIsPublic = False
- , componentIncludes = componentIncludes clbi
- , componentUnitId = componentUnitId clbi
- , componentComponentId = componentComponentId clbi
- , componentInstantiatedWith = []
- , componentCompatPackageName = compat_name
- , componentCompatPackageKey = compat_key
- , componentExposedModules = [IPI.ExposedModule m Nothing]
- }
- pkgName' = mkPackageName $ prettyShow compat_name
- pkg = pkg_descr {
- package = (package pkg_descr) { pkgName = pkgName' }
- , executables = []
- , testSuites = []
+ -- This is, like, the one place where we use a CTestName for a library.
+ -- Should NOT use library name, since that could conflict!
+ PackageIdentifier pkg_name pkg_ver = package pkg_descr
+ -- Note: we do make internal library from the test!
+ compat_name = MungedPackageName pkg_name (LSubLibName (testName test))
+ compat_key = computeCompatPackageKey (compiler lbi) compat_name pkg_ver (componentUnitId clbi)
+ libClbi =
+ LibComponentLocalBuildInfo
+ { componentPackageDeps = componentPackageDeps clbi
+ , componentInternalDeps = componentInternalDeps clbi
+ , componentIsIndefinite_ = False
+ , componentExeDeps = componentExeDeps clbi
+ , componentLocalName = CLibName $ LSubLibName $ testName test
+ , componentIsPublic = False
+ , componentIncludes = componentIncludes clbi
+ , componentUnitId = componentUnitId clbi
+ , componentComponentId = componentComponentId clbi
+ , componentInstantiatedWith = []
+ , componentCompatPackageName = compat_name
+ , componentCompatPackageKey = compat_key
+ , componentExposedModules = [IPI.ExposedModule m Nothing]
+ }
+ pkgName' = mkPackageName $ prettyShow compat_name
+ pkg =
+ pkg_descr
+ { package = (package pkg_descr){pkgName = pkgName'}
+ , executables = []
+ , testSuites = []
, subLibraries = [lib]
}
- ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi
- testDir = buildDir lbi </> stubName test
- </> stubName test ++ "-tmp"
- testLibDep = Dependency
- pkgName'
- (thisVersion $ pkgVersion $ package pkg_descr)
- mainLibSet
- exe = Executable {
- exeName = mkUnqualComponentName $ stubName test,
- modulePath = stubFilePath test,
- exeScope = ExecutablePublic,
- buildInfo = (testBuildInfo test) {
- hsSourceDirs = [ unsafeMakeSymbolicPath testDir ],
- targetBuildDepends = testLibDep
- : (targetBuildDepends $ testBuildInfo test)
- }
+ ipi = inplaceInstalledPackageInfo pwd distPref pkg (mkAbiHash "") lib lbi libClbi
+ testDir =
+ buildDir lbi
+ </> stubName test
+ </> stubName test
+ ++ "-tmp"
+ testLibDep =
+ Dependency
+ pkgName'
+ (thisVersion $ pkgVersion $ package pkg_descr)
+ mainLibSet
+ exe =
+ Executable
+ { exeName = mkUnqualComponentName $ stubName test
+ , modulePath = stubFilePath test
+ , exeScope = ExecutablePublic
+ , buildInfo =
+ (testBuildInfo test)
+ { hsSourceDirs = [unsafeMakeSymbolicPath testDir]
+ , targetBuildDepends =
+ testLibDep
+ : (targetBuildDepends $ testBuildInfo test)
+ }
+ }
+ -- \| The stub executable needs a new 'ComponentLocalBuildInfo'
+ -- that exposes the relevant test suite library.
+ deps =
+ (IPI.installedUnitId ipi, mungedId ipi)
+ : ( filter
+ ( \(_, x) ->
+ let name = prettyShow $ mungedName x
+ in name == "Cabal" || name == "base"
+ )
+ (componentPackageDeps clbi)
+ )
+ exeClbi =
+ ExeComponentLocalBuildInfo
+ { -- TODO: this is a hack, but as long as this is unique
+ -- (doesn't clobber something) we won't run into trouble
+ componentUnitId = mkUnitId (stubName test)
+ , componentComponentId = mkComponentId (stubName test)
+ , componentInternalDeps = [componentUnitId clbi]
+ , componentExeDeps = []
+ , componentLocalName = CExeName $ mkUnqualComponentName $ stubName test
+ , componentPackageDeps = deps
+ , -- Assert DefUnitId invariant!
+ -- Executable can't be indefinite, so dependencies must
+ -- be definite packages.
+ componentIncludes =
+ zip
+ (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps)
+ (repeat defaultRenaming)
}
- -- | The stub executable needs a new 'ComponentLocalBuildInfo'
- -- that exposes the relevant test suite library.
- deps = (IPI.installedUnitId ipi, mungedId ipi)
- : (filter (\(_, x) -> let name = prettyShow $ mungedName x
- in name == "Cabal" || name == "base")
- (componentPackageDeps clbi))
- exeClbi = ExeComponentLocalBuildInfo {
- -- TODO: this is a hack, but as long as this is unique
- -- (doesn't clobber something) we won't run into trouble
- componentUnitId = mkUnitId (stubName test),
- componentComponentId = mkComponentId (stubName test),
- componentInternalDeps = [componentUnitId clbi],
- componentExeDeps = [],
- componentLocalName = CExeName $ mkUnqualComponentName $ stubName test,
- componentPackageDeps = deps,
- -- Assert DefUnitId invariant!
- -- Executable can't be indefinite, so dependencies must
- -- be definite packages.
- componentIncludes = zip (map (DefiniteUnitId . unsafeMkDefUnitId . fst) deps)
- (repeat defaultRenaming)
- }
testSuiteLibV09AsLibAndExe _ TestSuite{} _ _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"
-
-- | Initialize a new package db file for libraries defined
-- internally to the package.
-createInternalPackageDB :: Verbosity -> LocalBuildInfo -> FilePath
- -> IO PackageDB
+createInternalPackageDB
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -> IO PackageDB
createInternalPackageDB verbosity lbi distPref = do
- existsAlready <- doesPackageDBExist dbPath
- when existsAlready $ deletePackageDB dbPath
- createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
- return (SpecificPackageDB dbPath)
+ existsAlready <- doesPackageDBExist dbPath
+ when existsAlready $ deletePackageDB dbPath
+ createPackageDB verbosity (compiler lbi) (withPrograms lbi) False dbPath
+ return (SpecificPackageDB dbPath)
where
dbPath = internalPackageDBPath lbi distPref
-addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
- -> ProgramDb -> ProgramDb
+addInternalBuildTools
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ProgramDb
+ -> ProgramDb
addInternalBuildTools pkg lbi bi progs =
- foldr updateProgram progs internalBuildTools
+ foldr updateProgram progs internalBuildTools
where
internalBuildTools =
[ simpleConfiguredProgram toolName' (FoundOnSystem toolLocation)
| toolName <- getAllInternalToolDependencies pkg bi
, let toolName' = unUnqualComponentName toolName
- , let toolLocation = buildDir lbi </> toolName' </> toolName' <.> exeExtension (hostPlatform lbi) ]
-
+ , let toolLocation = buildDir lbi </> toolName' </> toolName' <.> exeExtension (hostPlatform lbi)
+ ]
-- TODO: build separate libs in separate dirs so that we can build
-- multiple libs, e.g. for 'LibTest' library-style test suites
-buildLib :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO ()
+buildLib
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildLib verbosity numJobs pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi
+ GHC -> GHC.buildLib verbosity numJobs pkg_descr lbi lib clbi
GHCJS -> GHCJS.buildLib verbosity numJobs pkg_descr lbi lib clbi
- UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
- HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
- _ -> die' verbosity "Building is not supported with this compiler."
+ UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
+ HaskellSuite{} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi
+ _ -> die' verbosity "Building is not supported with this compiler."
-- | Build a foreign library
--
-- NOTE: We assume that we already checked that we can actually build the
-- foreign library in configure.
-buildFLib :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> ForeignLib -> ComponentLocalBuildInfo -> IO ()
+buildFLib
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildFLib verbosity numJobs pkg_descr lbi flib clbi =
- case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi
- _ -> die' verbosity "Building is not supported with this compiler."
-
-buildExe :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> Executable -> ComponentLocalBuildInfo -> IO ()
+ case compilerFlavor (compiler lbi) of
+ GHC -> GHC.buildFLib verbosity numJobs pkg_descr lbi flib clbi
+ _ -> die' verbosity "Building is not supported with this compiler."
+
+buildExe
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildExe verbosity numJobs pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi
+ GHC -> GHC.buildExe verbosity numJobs pkg_descr lbi exe clbi
GHCJS -> GHCJS.buildExe verbosity numJobs pkg_descr lbi exe clbi
- UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
- _ -> die' verbosity "Building is not supported with this compiler."
-
-replLib :: ReplOptions -> Verbosity -> PackageDescription
- -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
- -> IO ()
+ UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
+ _ -> die' verbosity "Building is not supported with this compiler."
+
+replLib
+ :: ReplOptions
+ -> Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
replLib replFlags verbosity pkg_descr lbi lib clbi =
case compilerFlavor (compiler lbi) of
-- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass
-- NoFlag as the numJobs parameter.
- GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi
+ GHC -> GHC.replLib replFlags verbosity NoFlag pkg_descr lbi lib clbi
GHCJS -> GHCJS.replLib (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi lib clbi
- _ -> die' verbosity "A REPL is not supported for this compiler."
-
-replExe :: ReplOptions -> Verbosity -> PackageDescription
- -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo
- -> IO ()
+ _ -> die' verbosity "A REPL is not supported for this compiler."
+
+replExe
+ :: ReplOptions
+ -> Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
replExe replFlags verbosity pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
- GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi
+ GHC -> GHC.replExe replFlags verbosity NoFlag pkg_descr lbi exe clbi
GHCJS -> GHCJS.replExe (replOptionsFlags replFlags) verbosity NoFlag pkg_descr lbi exe clbi
- _ -> die' verbosity "A REPL is not supported for this compiler."
-
-replFLib :: ReplOptions -> Verbosity -> PackageDescription
- -> LocalBuildInfo -> ForeignLib -> ComponentLocalBuildInfo
- -> IO ()
+ _ -> die' verbosity "A REPL is not supported for this compiler."
+
+replFLib
+ :: ReplOptions
+ -> Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO ()
replFLib replFlags verbosity pkg_descr lbi exe clbi =
case compilerFlavor (compiler lbi) of
GHC -> GHC.replFLib replFlags verbosity NoFlag pkg_descr lbi exe clbi
- _ -> die' verbosity "A REPL is not supported for this compiler."
+ _ -> die' verbosity "A REPL is not supported for this compiler."
-- | Runs 'componentInitialBuildSteps' on every configured component.
-initialBuildSteps :: FilePath -- ^"dist" prefix
- -> PackageDescription -- ^mostly information from the .cabal file
- -> LocalBuildInfo -- ^Configuration information
- -> Verbosity -- ^The verbosity to use
- -> IO ()
+initialBuildSteps
+ :: FilePath
+ -- ^ "dist" prefix
+ -> PackageDescription
+ -- ^ mostly information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ Configuration information
+ -> Verbosity
+ -- ^ The verbosity to use
+ -> IO ()
initialBuildSteps distPref pkg_descr lbi verbosity =
- withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi ->
- componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
+ withAllComponentsInBuildOrder pkg_descr lbi $ \_comp clbi ->
+ componentInitialBuildSteps distPref pkg_descr lbi clbi verbosity
-- | Creates the autogenerated files for a particular configured component.
-componentInitialBuildSteps :: FilePath -- ^"dist" prefix
- -> PackageDescription -- ^mostly information from the .cabal file
- -> LocalBuildInfo -- ^Configuration information
- -> ComponentLocalBuildInfo
- -> Verbosity -- ^The verbosity to use
- -> IO ()
+componentInitialBuildSteps
+ :: FilePath
+ -- ^ "dist" prefix
+ -> PackageDescription
+ -- ^ mostly information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ Configuration information
+ -> ComponentLocalBuildInfo
+ -> Verbosity
+ -- ^ The verbosity to use
+ -> IO ()
componentInitialBuildSteps _distPref pkg_descr lbi clbi verbosity = do
createDirectoryIfMissingVerbose verbosity True (componentBuildDir lbi clbi)
writeAutogenFiles verbosity pkg_descr lbi clbi
-- | Generate and write out the Paths_<pkg>.hs, PackageInfo_<pkg>.hs, and cabal_macros.h files
---
-writeAutogenFiles :: Verbosity
- -> PackageDescription
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> IO ()
+writeAutogenFiles
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> IO ()
writeAutogenFiles verbosity pkg lbi clbi = do
createDirectoryIfMissingVerbose verbosity True (autogenComponentModulesDir lbi clbi)
- let pathsModulePath = autogenComponentModulesDir lbi clbi
- </> ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs"
+ let pathsModulePath =
+ autogenComponentModulesDir lbi clbi
+ </> ModuleName.toFilePath (autogenPathsModuleName pkg) <.> "hs"
pathsModuleDir = takeDirectory pathsModulePath
-- Ensure that the directory exists!
createDirectoryIfMissingVerbose verbosity True pathsModuleDir
rewriteFileEx verbosity pathsModulePath (generatePathsModule pkg lbi clbi)
- let packageInfoModulePath = autogenComponentModulesDir lbi clbi
- </> ModuleName.toFilePath (autogenPackageInfoModuleName pkg) <.> "hs"
+ let packageInfoModulePath =
+ autogenComponentModulesDir lbi clbi
+ </> ModuleName.toFilePath (autogenPackageInfoModuleName pkg) <.> "hs"
packageInfoModuleDir = takeDirectory packageInfoModulePath
-- Ensure that the directory exists!
createDirectoryIfMissingVerbose verbosity True packageInfoModuleDir
rewriteFileEx verbosity packageInfoModulePath (generatePackageInfoModule pkg lbi)
- --TODO: document what we're doing here, and move it to its own function
+ -- TODO: document what we're doing here, and move it to its own function
case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->
- -- Write out empty hsig files for all requirements, so that GHC
- -- has a source file to look at it when it needs to typecheck
- -- a signature. It's harmless to write these out even when
- -- there is a real hsig file written by the user, since
- -- include path ordering ensures that the real hsig file
- -- will always be picked up before the autogenerated one.
- for_ (map fst insts) $ \mod_name -> do
- let sigPath = autogenComponentModulesDir lbi clbi
- </> ModuleName.toFilePath mod_name <.> "hsig"
- createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath)
- rewriteFileEx verbosity sigPath $
- "{-# OPTIONS_GHC -w #-}\n" ++
- "{-# LANGUAGE NoImplicitPrelude #-}\n" ++
- "signature " ++ prettyShow mod_name ++ " where"
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
+ -- Write out empty hsig files for all requirements, so that GHC
+ -- has a source file to look at it when it needs to typecheck
+ -- a signature. It's harmless to write these out even when
+ -- there is a real hsig file written by the user, since
+ -- include path ordering ensures that the real hsig file
+ -- will always be picked up before the autogenerated one.
+ for_ (map fst insts) $ \mod_name -> do
+ let sigPath =
+ autogenComponentModulesDir lbi clbi
+ </> ModuleName.toFilePath mod_name <.> "hsig"
+ createDirectoryIfMissingVerbose verbosity True (takeDirectory sigPath)
+ rewriteFileEx verbosity sigPath $
+ "{-# OPTIONS_GHC -w #-}\n"
+ ++ "{-# LANGUAGE NoImplicitPrelude #-}\n"
+ ++ "signature "
+ ++ prettyShow mod_name
+ ++ " where"
_ -> return ()
let cppHeaderPath = autogenComponentModulesDir lbi clbi </> cppHeaderName
diff --git a/Cabal/src/Distribution/Simple/Build/Macros.hs b/Cabal/src/Distribution/Simple/Build/Macros.hs
index db0e75a8a0c5632d3cafb3b4ac8af0ac459f1308..3dbce8616fc5b59c91ab708848c8ff13f6cabb7b 100644
--- a/Cabal/src/Distribution/Simple/Build/Macros.hs
+++ b/Cabal/src/Distribution/Simple/Build/Macros.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Build.Macros
-- Copyright : Simon Marlow 2008
@@ -19,92 +20,95 @@
--
-- TODO Figure out what to do about backpack and internal libraries. It is very
-- suspicious that this stuff works with munged package identifiers
-module Distribution.Simple.Build.Macros (
- generateCabalMacrosHeader,
- generatePackageVersionMacros,
+module Distribution.Simple.Build.Macros
+ ( generateCabalMacrosHeader
+ , generatePackageVersionMacros
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Version
import Distribution.PackageDescription
+import Distribution.Pretty
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Types
import Distribution.Types.MungedPackageId
import Distribution.Types.MungedPackageName
-import Distribution.Pretty
+import Distribution.Version
import qualified Distribution.Simple.Build.Macros.Z as Z
-- | The contents of the @cabal_macros.h@ for the given configured package.
---
generateCabalMacrosHeader :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String
-generateCabalMacrosHeader pkg_descr lbi clbi = Z.render Z.Z
- { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi)
- , Z.zTools =
- [ Z.ZTool
- { Z.ztoolName = programId prog
+generateCabalMacrosHeader pkg_descr lbi clbi =
+ Z.render
+ Z.Z
+ { Z.zPackages = map mkZPackage $ package pkg_descr : map getPid (componentPackageDeps clbi)
+ , Z.zTools =
+ [ Z.ZTool
+ { Z.ztoolName = programId prog
, Z.ztoolVersion = ver
- , Z.ztoolX = major1
- , Z.ztoolY = major2
- , Z.ztoolZ = minor
+ , Z.ztoolX = major1
+ , Z.ztoolY = major2
+ , Z.ztoolZ = minor
}
- | prog <- configuredPrograms $ withPrograms lbi
- , ver <- maybeToList (programVersion prog)
- , let (major1,major2,minor) = majorMinor ver
- ]
- , Z.zPackageKey = case clbi of
- LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi
- _ -> ""
- , Z.zComponentId = prettyShow (componentComponentId clbi)
- , Z.zPackageVersion = pkgVersion (package pkg_descr)
- , Z.zNotNull = not . null
- , Z.zManglePkgName = map fixchar . unPackageName
- , Z.zMangleStr = map fixchar
- }
+ | prog <- configuredPrograms $ withPrograms lbi
+ , ver <- maybeToList (programVersion prog)
+ , let (major1, major2, minor) = majorMinor ver
+ ]
+ , Z.zPackageKey = case clbi of
+ LibComponentLocalBuildInfo{} -> componentCompatPackageKey clbi
+ _ -> ""
+ , Z.zComponentId = prettyShow (componentComponentId clbi)
+ , Z.zPackageVersion = pkgVersion (package pkg_descr)
+ , Z.zNotNull = not . null
+ , Z.zManglePkgName = map fixchar . unPackageName
+ , Z.zMangleStr = map fixchar
+ }
where
getPid (_, MungedPackageId (MungedPackageName pn _) v) =
- -- NB: Drop the library name! We're just reporting package versions.
- -- This would have to be revisited if you are allowed to depend
- -- on different versions of the same package
- PackageIdentifier pn v
+ -- NB: Drop the library name! We're just reporting package versions.
+ -- This would have to be revisited if you are allowed to depend
+ -- on different versions of the same package
+ PackageIdentifier pn v
-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@
-- macros for a list of package ids (usually used with the specific deps of
-- a configured package).
---
generatePackageVersionMacros :: Version -> [PackageId] -> String
-generatePackageVersionMacros ver pkgids = Z.render Z.Z
- { Z.zPackages = map mkZPackage pkgids
- , Z.zTools = []
- , Z.zPackageKey = ""
- , Z.zComponentId = ""
- , Z.zPackageVersion = ver
- , Z.zNotNull = not . null
- , Z.zManglePkgName = map fixchar . unPackageName
- , Z.zMangleStr = map fixchar
- }
+generatePackageVersionMacros ver pkgids =
+ Z.render
+ Z.Z
+ { Z.zPackages = map mkZPackage pkgids
+ , Z.zTools = []
+ , Z.zPackageKey = ""
+ , Z.zComponentId = ""
+ , Z.zPackageVersion = ver
+ , Z.zNotNull = not . null
+ , Z.zManglePkgName = map fixchar . unPackageName
+ , Z.zMangleStr = map fixchar
+ }
mkZPackage :: PackageId -> Z.ZPackage
-mkZPackage (PackageIdentifier name ver) = Z.ZPackage
- { Z.zpkgName = name
+mkZPackage (PackageIdentifier name ver) =
+ Z.ZPackage
+ { Z.zpkgName = name
, Z.zpkgVersion = ver
- , Z.zpkgX = major1
- , Z.zpkgY = major2
- , Z.zpkgZ = minor
+ , Z.zpkgX = major1
+ , Z.zpkgY = major2
+ , Z.zpkgZ = minor
}
where
- (major1,major2,minor) = majorMinor ver
+ (major1, major2, minor) = majorMinor ver
majorMinor :: Version -> (String, String, String)
majorMinor ver = case map show (versionNumbers ver) of
- [] -> ("0", "0", "0")
- [x] -> (x, "0", "0")
- [x,y] -> (x, y, "0")
- (x:y:z:_) -> (x, y, z)
+ [] -> ("0", "0", "0")
+ [x] -> (x, "0", "0")
+ [x, y] -> (x, y, "0")
+ (x : y : z : _) -> (x, y, z)
fixchar :: Char -> Char
fixchar '-' = '_'
-fixchar c = c
+fixchar c = c
diff --git a/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs b/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs
index 6b33c0c84c0f6417c50595c784b468e9b6c6cac4..66b4af7b05b7bd02157de4384e0c28d463f322e9 100644
--- a/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs
+++ b/Cabal/src/Distribution/Simple/Build/PackageInfoModule.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Build.PackageInfoModule
-- Copyright :
@@ -10,9 +11,8 @@
--
-- This is a module that Cabal generates for the benefit of packages. It
-- enables them to find their package informations.
---
-module Distribution.Simple.Build.PackageInfoModule (
- generatePackageInfoModule
+module Distribution.Simple.Build.PackageInfoModule
+ ( generatePackageInfoModule
) where
import Distribution.Compat.Prelude
@@ -28,29 +28,33 @@ import Distribution.Version
import qualified Distribution.Simple.Build.PackageInfoModule.Z as Z
-- ------------------------------------------------------------
+
-- * Building Paths_<pkg>.hs
+
-- ------------------------------------------------------------
generatePackageInfoModule :: PackageDescription -> LocalBuildInfo -> String
-generatePackageInfoModule pkg_descr lbi = Z.render Z.Z
- { Z.zPackageName = showPkgName $ packageName pkg_descr
- , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr
- , Z.zSynopsis = fromShortText $ synopsis pkg_descr
- , Z.zCopyright = fromShortText $ copyright pkg_descr
- , Z.zHomepage = fromShortText $ homepage pkg_descr
- , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax
- }
+generatePackageInfoModule pkg_descr lbi =
+ Z.render
+ Z.Z
+ { Z.zPackageName = showPkgName $ packageName pkg_descr
+ , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr
+ , Z.zSynopsis = fromShortText $ synopsis pkg_descr
+ , Z.zCopyright = fromShortText $ copyright pkg_descr
+ , Z.zHomepage = fromShortText $ homepage pkg_descr
+ , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax
+ }
where
- supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1])
+ supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1])
ghc_newer_than minVersion =
- case compilerCompatVersion GHC (compiler lbi) of
- Nothing -> False
- Just version -> version `withinRange` orLaterVersion minVersion
+ case compilerCompatVersion GHC (compiler lbi) of
+ Nothing -> False
+ Just version -> version `withinRange` orLaterVersion minVersion
showPkgName :: PackageName -> String
showPkgName = map fixchar . unPackageName
fixchar :: Char -> Char
fixchar '-' = '_'
-fixchar c = c
+fixchar c = c
diff --git a/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs b/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
index e96ed923045cb1dfc782c79637a2c58c7b8e371d..6bc973148092631ccd2fc799059cc805025a6bac 100644
--- a/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
+++ b/Cabal/src/Distribution/Simple/Build/PackageInfoModule/Z.hs
@@ -5,23 +5,23 @@ module Distribution.Simple.Build.PackageInfoModule.Z (render, Z (..)) where
import Distribution.ZinzaPrelude
data Z = Z
- { zPackageName :: String,
- zVersionDigits :: String,
- zSynopsis :: String,
- zCopyright :: String,
- zHomepage :: String,
- zSupportsNoRebindableSyntax :: Bool
+ { zPackageName :: String
+ , zVersionDigits :: String
+ , zSynopsis :: String
+ , zCopyright :: String
+ , zHomepage :: String
+ , zSupportsNoRebindableSyntax :: Bool
}
deriving (Generic)
render :: Z -> String
render z_root = execWriter $ do
if (zSupportsNoRebindableSyntax z_root)
- then do
- tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
- return ()
- else do
- return ()
+ then do
+ tell "{-# LANGUAGE NoRebindableSyntax #-}\n"
+ return ()
+ else do
+ return ()
tell "{-# OPTIONS_GHC -fno-warn-missing-import-lists #-}\n"
tell "{-# OPTIONS_GHC -w #-}\n"
tell "module PackageInfo_"
diff --git a/Cabal/src/Distribution/Simple/Build/PathsModule.hs b/Cabal/src/Distribution/Simple/Build/PathsModule.hs
index b2be7e1a8fc4dceab36c634a219aa91277d439ec..892e5bd384fc4f7028814c5393502249a28db55b 100644
--- a/Cabal/src/Distribution/Simple/Build/PathsModule.hs
+++ b/Cabal/src/Distribution/Simple/Build/PathsModule.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Build.Macros
-- Copyright : Isaac Jones 2003-2005,
@@ -13,9 +14,9 @@
-- This is a module that Cabal generates for the benefit of packages. It
-- enables them to find their version number and find any installed data files
-- at runtime. This code should probably be split off into another module.
---
-module Distribution.Simple.Build.PathsModule (
- generatePathsModule, pkgPathEnvVar
+module Distribution.Simple.Build.PathsModule
+ ( generatePathsModule
+ , pkgPathEnvVar
) where
import Distribution.Compat.Prelude
@@ -25,121 +26,124 @@ import Distribution.Package
import Distribution.PackageDescription
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.Utils (shortRelativePath)
+import Distribution.Simple.Utils (shortRelativePath)
import Distribution.System
import Distribution.Version
import qualified Distribution.Simple.Build.PathsModule.Z as Z
-- ------------------------------------------------------------
+
-- * Building Paths_<pkg>.hs
+
-- ------------------------------------------------------------
generatePathsModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> String
-generatePathsModule pkg_descr lbi clbi = Z.render Z.Z
- { Z.zPackageName = packageName pkg_descr
- , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr
- , Z.zSupportsCpp = supports_cpp
- , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax
- , Z.zAbsolute = absolute
- , Z.zRelocatable = relocatable lbi
- , Z.zIsWindows = isWindows
- , Z.zIsI386 = buildArch == I386
- , Z.zIsX8664 = buildArch == X86_64
- , Z.zNot = not
- , Z.zManglePkgName = showPkgName
-
- , Z.zPrefix = show flat_prefix
- , Z.zBindir = zBindir
- , Z.zLibdir = zLibdir
- , Z.zDynlibdir = zDynlibdir
- , Z.zDatadir = zDatadir
- , Z.zLibexecdir = zLibexecdir
- , Z.zSysconfdir = zSysconfdir
- }
+generatePathsModule pkg_descr lbi clbi =
+ Z.render
+ Z.Z
+ { Z.zPackageName = packageName pkg_descr
+ , Z.zVersionDigits = show $ versionNumbers $ packageVersion pkg_descr
+ , Z.zSupportsCpp = supports_cpp
+ , Z.zSupportsNoRebindableSyntax = supports_rebindable_syntax
+ , Z.zAbsolute = absolute
+ , Z.zRelocatable = relocatable lbi
+ , Z.zIsWindows = isWindows
+ , Z.zIsI386 = buildArch == I386
+ , Z.zIsX8664 = buildArch == X86_64
+ , Z.zNot = not
+ , Z.zManglePkgName = showPkgName
+ , Z.zPrefix = show flat_prefix
+ , Z.zBindir = zBindir
+ , Z.zLibdir = zLibdir
+ , Z.zDynlibdir = zDynlibdir
+ , Z.zDatadir = zDatadir
+ , Z.zLibexecdir = zLibexecdir
+ , Z.zSysconfdir = zSysconfdir
+ }
where
- supports_cpp = supports_language_pragma
- supports_rebindable_syntax = ghc_newer_than (mkVersion [7,0,1])
- supports_language_pragma = ghc_newer_than (mkVersion [6,6,1])
+ supports_cpp = supports_language_pragma
+ supports_rebindable_syntax = ghc_newer_than (mkVersion [7, 0, 1])
+ supports_language_pragma = ghc_newer_than (mkVersion [6, 6, 1])
ghc_newer_than minVersion =
- case compilerCompatVersion GHC (compiler lbi) of
- Nothing -> False
- Just version -> version `withinRange` orLaterVersion minVersion
+ case compilerCompatVersion GHC (compiler lbi) of
+ Nothing -> False
+ Just version -> version `withinRange` orLaterVersion minVersion
-- In several cases we cannot make relocatable installations
absolute =
- hasLibs pkg_descr -- we can only make progs relocatable
- || isNothing flat_bindirrel -- if the bin dir is an absolute path
- || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))
+ hasLibs pkg_descr -- we can only make progs relocatable
+ || isNothing flat_bindirrel -- if the bin dir is an absolute path
+ || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))
-- TODO: Here, and with zIsI386 & zIs8664 we should use TARGET platform
isWindows = case buildOS of
- Windows -> True
- _ -> False
+ Windows -> True
+ _ -> False
- supportsRelocatableProgs GHC = isWindows
+ supportsRelocatableProgs GHC = isWindows
supportsRelocatableProgs GHCJS = isWindows
- supportsRelocatableProgs _ = False
+ supportsRelocatableProgs _ = False
cid = componentUnitId clbi
InstallDirs
- { bindir = flat_bindir
- , libdir = flat_libdir
- , dynlibdir = flat_dynlibdir
- , datadir = flat_datadir
- , libexecdir = flat_libexecdir
- , sysconfdir = flat_sysconfdir
- , prefix = flat_prefix
- } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest
+ { bindir = flat_bindir
+ , libdir = flat_libdir
+ , dynlibdir = flat_dynlibdir
+ , datadir = flat_datadir
+ , libexecdir = flat_libexecdir
+ , sysconfdir = flat_sysconfdir
+ , prefix = flat_prefix
+ } = absoluteInstallCommandDirs pkg_descr lbi cid NoCopyDest
InstallDirs
- { bindir = flat_bindirrel
- , libdir = flat_libdirrel
- , dynlibdir = flat_dynlibdirrel
- , datadir = flat_datadirrel
- , libexecdir = flat_libexecdirrel
- , sysconfdir = flat_sysconfdirrel
- } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid
+ { bindir = flat_bindirrel
+ , libdir = flat_libdirrel
+ , dynlibdir = flat_dynlibdirrel
+ , datadir = flat_datadirrel
+ , libexecdir = flat_libexecdirrel
+ , sysconfdir = flat_sysconfdirrel
+ } = prefixRelativeComponentInstallDirs (packageId pkg_descr) lbi cid
zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir :: String
(zBindir, zLibdir, zDynlibdir, zDatadir, zLibexecdir, zSysconfdir)
- | relocatable lbi =
- ( show flat_bindir_reloc
- , show flat_libdir_reloc
- , show flat_dynlibdir_reloc
- , show flat_datadir_reloc
- , show flat_libexecdir_reloc
- , show flat_sysconfdir_reloc
- )
- | absolute =
- ( show flat_bindir
- , show flat_libdir
- , show flat_dynlibdir
- , show flat_datadir
- , show flat_libexecdir
- , show flat_sysconfdir
- )
- | isWindows =
- ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")"
- , mkGetDir flat_libdir flat_libdirrel
- , mkGetDir flat_dynlibdir flat_dynlibdirrel
- , mkGetDir flat_datadir flat_datadirrel
- , mkGetDir flat_libexecdir flat_libexecdirrel
- , mkGetDir flat_sysconfdir flat_sysconfdirrel
- )
- | otherwise =
- error "panic! generatePathsModule: should never happen"
+ | relocatable lbi =
+ ( show flat_bindir_reloc
+ , show flat_libdir_reloc
+ , show flat_dynlibdir_reloc
+ , show flat_datadir_reloc
+ , show flat_libexecdir_reloc
+ , show flat_sysconfdir_reloc
+ )
+ | absolute =
+ ( show flat_bindir
+ , show flat_libdir
+ , show flat_dynlibdir
+ , show flat_datadir
+ , show flat_libexecdir
+ , show flat_sysconfdir
+ )
+ | isWindows =
+ ( "maybe (error \"PathsModule.generate\") id (" ++ show flat_bindirrel ++ ")"
+ , mkGetDir flat_libdir flat_libdirrel
+ , mkGetDir flat_dynlibdir flat_dynlibdirrel
+ , mkGetDir flat_datadir flat_datadirrel
+ , mkGetDir flat_libexecdir flat_libexecdirrel
+ , mkGetDir flat_sysconfdir flat_sysconfdirrel
+ )
+ | otherwise =
+ error "panic! generatePathsModule: should never happen"
mkGetDir :: FilePath -> Maybe FilePath -> String
- mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel
- mkGetDir dir Nothing = "return " ++ show dir
+ mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel
+ mkGetDir dir Nothing = "return " ++ show dir
- flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir
- flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir
- flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir
- flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir
+ flat_bindir_reloc = shortRelativePath flat_prefix flat_bindir
+ flat_libdir_reloc = shortRelativePath flat_prefix flat_libdir
+ flat_dynlibdir_reloc = shortRelativePath flat_prefix flat_dynlibdir
+ flat_datadir_reloc = shortRelativePath flat_prefix flat_datadir
flat_libexecdir_reloc = shortRelativePath flat_prefix flat_libexecdir
flat_sysconfdir_reloc = shortRelativePath flat_prefix flat_sysconfdir
@@ -149,15 +153,17 @@ generatePathsModule pkg_descr lbi clbi = Z.render Z.Z
-- Note: The format of these strings is part of Cabal's public API;
-- changing this function constitutes a *backwards-compatibility* break.
pkgPathEnvVar
- :: PackageDescription
- -> String -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\"
- -> String -- ^ environment variable name
+ :: PackageDescription
+ -> String
+ -- ^ path component; one of \"bindir\", \"libdir\", -- \"datadir\", \"libexecdir\", or \"sysconfdir\"
+ -> String
+ -- ^ environment variable name
pkgPathEnvVar pkg_descr var =
- showPkgName (packageName pkg_descr) ++ "_" ++ var
+ showPkgName (packageName pkg_descr) ++ "_" ++ var
showPkgName :: PackageName -> String
showPkgName = map fixchar . unPackageName
fixchar :: Char -> Char
fixchar '-' = '_'
-fixchar c = c
+fixchar c = c
diff --git a/Cabal/src/Distribution/Simple/BuildPaths.hs b/Cabal/src/Distribution/Simple/BuildPaths.hs
index f909078a1bfe91c5a26f284fe8fd3e6d55002222..ce1b350d8c567c0ebae6c23231c8859e5126731a 100644
--- a/Cabal/src/Distribution/Simple/BuildPaths.hs
+++ b/Cabal/src/Distribution/Simple/BuildPaths.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.BuildPaths
-- Copyright : Isaac Jones 2003-2004,
@@ -11,54 +13,58 @@
-- Portability : portable
--
-- A bunch of dirs, paths and file names used for intermediate build steps.
---
+module Distribution.Simple.BuildPaths
+ ( defaultDistPref
+ , srcPref
+ , buildInfoPref
+ , haddockDirName
+ , hscolourPref
+ , haddockPref
+ , autogenPackageModulesDir
+ , autogenComponentModulesDir
+ , autogenPathsModuleName
+ , autogenPackageInfoModuleName
+ , cppHeaderName
+ , haddockName
+ , mkGenericStaticLibName
+ , mkLibName
+ , mkProfLibName
+ , mkGenericSharedLibName
+ , mkSharedLibName
+ , mkStaticLibName
+ , mkGenericSharedBundledLibName
+ , exeExtension
+ , objExtension
+ , dllExtension
+ , staticLibExtension
-module Distribution.Simple.BuildPaths (
- defaultDistPref, srcPref,
- buildInfoPref, haddockDirName, hscolourPref, haddockPref,
- autogenPackageModulesDir,
- autogenComponentModulesDir,
-
- autogenPathsModuleName,
- autogenPackageInfoModuleName,
- cppHeaderName,
- haddockName,
-
- mkGenericStaticLibName,
- mkLibName,
- mkProfLibName,
- mkGenericSharedLibName,
- mkSharedLibName,
- mkStaticLibName,
- mkGenericSharedBundledLibName,
-
- exeExtension,
- objExtension,
- dllExtension,
- staticLibExtension,
-- * Source files & build directories
- getSourceFiles, getLibSourceFiles, getExeSourceFiles,
- getFLibSourceFiles, exeBuildDir, flibBuildDir,
+ , getSourceFiles
+ , getLibSourceFiles
+ , getExeSourceFiles
+ , getFLibSourceFiles
+ , exeBuildDir
+ , flibBuildDir
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Package
-import Distribution.ModuleName as ModuleName
import Distribution.Compiler
+import Distribution.ModuleName as ModuleName
+import Distribution.Package
import Distribution.PackageDescription
+import Distribution.Pretty
import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.Setup.Haddock (HaddockTarget(..))
import Distribution.Simple.Setup.Common (defaultDistPref)
-import Distribution.Pretty
-import Distribution.System
-import Distribution.Verbosity
+import Distribution.Simple.Setup.Haddock (HaddockTarget (..))
import Distribution.Simple.Utils
+import Distribution.System
import Distribution.Utils.Path
+import Distribution.Verbosity
import Data.List (stripPrefix)
-import System.FilePath ((</>), (<.>), normalise)
+import System.FilePath (normalise, (<.>), (</>))
-- ---------------------------------------------------------------------------
-- Build directories and files
@@ -81,8 +87,8 @@ haddockDirName ForHackage = (++ "-docs") . prettyShow . packageId
-- | The directory to which generated haddock documentation should be written.
haddockPref :: HaddockTarget -> FilePath -> PackageDescription -> FilePath
-haddockPref haddockTarget distPref pkg_descr
- = distPref </> "doc" </> "html" </> haddockDirName haddockTarget pkg_descr
+haddockPref haddockTarget distPref pkg_descr =
+ distPref </> "doc" </> "html" </> haddockDirName haddockTarget pkg_descr
-- | The directory in which we put auto-generated modules for EVERY
-- component in the package.
@@ -93,6 +99,7 @@ autogenPackageModulesDir lbi = buildDir lbi </> "global-autogen"
-- particular component.
autogenComponentModulesDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> String
autogenComponentModulesDir lbi clbi = componentBuildDir lbi clbi </> "autogen"
+
-- NB: Look at 'checkForeignDeps' for where a simplified version of this
-- has been copy-pasted.
@@ -104,16 +111,18 @@ autogenPathsModuleName :: PackageDescription -> ModuleName
autogenPathsModuleName pkg_descr =
ModuleName.fromString $
"Paths_" ++ map fixchar (prettyShow (packageName pkg_descr))
- where fixchar '-' = '_'
- fixchar c = c
+ where
+ fixchar '-' = '_'
+ fixchar c = c
-- | The name of the auto-generated PackageInfo_* module associated with a package
autogenPackageInfoModuleName :: PackageDescription -> ModuleName
autogenPackageInfoModuleName pkg_descr =
ModuleName.fromString $
"PackageInfo_" ++ map fixchar (prettyShow (packageName pkg_descr))
- where fixchar '-' = '_'
- fixchar c = c
+ where
+ fixchar '-' = '_'
+ fixchar c = c
haddockName :: PackageDescription -> FilePath
haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock"
@@ -121,52 +130,65 @@ haddockName pkg_descr = prettyShow (packageName pkg_descr) <.> "haddock"
-- -----------------------------------------------------------------------------
-- Source File helper
-getLibSourceFiles :: Verbosity
- -> LocalBuildInfo
- -> Library
- -> ComponentLocalBuildInfo
- -> IO [(ModuleName.ModuleName, FilePath)]
+getLibSourceFiles
+ :: Verbosity
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO [(ModuleName.ModuleName, FilePath)]
getLibSourceFiles verbosity lbi lib clbi = getSourceFiles verbosity searchpaths modules
where
- bi = libBuildInfo lib
- modules = allLibModules lib clbi
- searchpaths = componentBuildDir lbi clbi : map getSymbolicPath (hsSourceDirs bi) ++
- [ autogenComponentModulesDir lbi clbi
- , autogenPackageModulesDir lbi ]
-
-getExeSourceFiles :: Verbosity
- -> LocalBuildInfo
- -> Executable
- -> ComponentLocalBuildInfo
- -> IO [(ModuleName.ModuleName, FilePath)]
+ bi = libBuildInfo lib
+ modules = allLibModules lib clbi
+ searchpaths =
+ componentBuildDir lbi clbi
+ : map getSymbolicPath (hsSourceDirs bi)
+ ++ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ ]
+
+getExeSourceFiles
+ :: Verbosity
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO [(ModuleName.ModuleName, FilePath)]
getExeSourceFiles verbosity lbi exe clbi = do
- moduleFiles <- getSourceFiles verbosity searchpaths modules
- srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe)
- return ((ModuleName.main, srcMainPath) : moduleFiles)
+ moduleFiles <- getSourceFiles verbosity searchpaths modules
+ srcMainPath <- findFileEx verbosity (map getSymbolicPath $ hsSourceDirs bi) (modulePath exe)
+ return ((ModuleName.main, srcMainPath) : moduleFiles)
where
- bi = buildInfo exe
- modules = otherModules bi
- searchpaths = autogenComponentModulesDir lbi clbi
- : autogenPackageModulesDir lbi
- : exeBuildDir lbi exe : map getSymbolicPath (hsSourceDirs bi)
-
-getFLibSourceFiles :: Verbosity
- -> LocalBuildInfo
- -> ForeignLib
- -> ComponentLocalBuildInfo
- -> IO [(ModuleName.ModuleName, FilePath)]
+ bi = buildInfo exe
+ modules = otherModules bi
+ searchpaths =
+ autogenComponentModulesDir lbi clbi
+ : autogenPackageModulesDir lbi
+ : exeBuildDir lbi exe
+ : map getSymbolicPath (hsSourceDirs bi)
+
+getFLibSourceFiles
+ :: Verbosity
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO [(ModuleName.ModuleName, FilePath)]
getFLibSourceFiles verbosity lbi flib clbi = getSourceFiles verbosity searchpaths modules
where
- bi = foreignLibBuildInfo flib
- modules = otherModules bi
- searchpaths = autogenComponentModulesDir lbi clbi
- : autogenPackageModulesDir lbi
- : flibBuildDir lbi flib : map getSymbolicPath (hsSourceDirs bi)
-
-getSourceFiles :: Verbosity -> [FilePath]
- -> [ModuleName.ModuleName]
- -> IO [(ModuleName.ModuleName, FilePath)]
-getSourceFiles verbosity dirs modules = flip traverse modules $ \m -> fmap ((,) m) $
+ bi = foreignLibBuildInfo flib
+ modules = otherModules bi
+ searchpaths =
+ autogenComponentModulesDir lbi clbi
+ : autogenPackageModulesDir lbi
+ : flibBuildDir lbi flib
+ : map getSymbolicPath (hsSourceDirs bi)
+
+getSourceFiles
+ :: Verbosity
+ -> [FilePath]
+ -> [ModuleName.ModuleName]
+ -> IO [(ModuleName.ModuleName, FilePath)]
+getSourceFiles verbosity dirs modules = flip traverse modules $ \m ->
+ fmap ((,) m) $
findFileWithExtension ["hs", "lhs", "hsig", "lhsig"] dirs (ModuleName.toFilePath m)
>>= maybe (notFound m) (return . normalise)
where
@@ -196,29 +218,31 @@ mkLibName :: UnitId -> String
mkLibName lib = mkGenericStaticLibName (getHSLibraryName lib)
mkProfLibName :: UnitId -> String
-mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p")
+mkProfLibName lib = mkGenericStaticLibName (getHSLibraryName lib ++ "_p")
-- | Create a library name for a shared library from a given name.
-- Prepends @lib@ and appends the @-\<compilerFlavour\>\<compilerVersion\>@
-- as well as the shared library extension.
mkGenericSharedLibName :: Platform -> CompilerId -> String -> String
-mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib
- = mconcat [ "lib", lib, "-", comp <.> dllExtension platform ]
- where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion
+mkGenericSharedLibName platform (CompilerId compilerFlavor compilerVersion) lib =
+ mconcat ["lib", lib, "-", comp <.> dllExtension platform]
+ where
+ comp = prettyShow compilerFlavor ++ prettyShow compilerVersion
-- Implement proper name mangling for dynamical shared objects
-- @libHS\<packagename\>-\<compilerFlavour\>\<compilerVersion\>@
-- e.g. @libHSbase-2.1-ghc6.6.1.so@
mkSharedLibName :: Platform -> CompilerId -> UnitId -> String
-mkSharedLibName platform comp lib
- = mkGenericSharedLibName platform comp (getHSLibraryName lib)
+mkSharedLibName platform comp lib =
+ mkGenericSharedLibName platform comp (getHSLibraryName lib)
-- Static libs are named the same as shared libraries, only with
-- a different extension.
mkStaticLibName :: Platform -> CompilerId -> UnitId -> String
-mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib
- = "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform
- where comp = prettyShow compilerFlavor ++ prettyShow compilerVersion
+mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib =
+ "lib" ++ getHSLibraryName lib ++ "-" ++ comp <.> staticLibExtension platform
+ where
+ comp = prettyShow compilerFlavor ++ prettyShow compilerVersion
-- | Create a library name for a bundled shared library from a given name.
-- This matches the naming convention for shared libraries as implemented in
@@ -231,24 +255,26 @@ mkStaticLibName platform (CompilerId compilerFlavor compilerVersion) lib
-- "Cffi" -> "libffi.so"
mkGenericSharedBundledLibName :: Platform -> CompilerId -> String -> String
mkGenericSharedBundledLibName platform comp lib
- | "HS" `isPrefixOf` lib
- = mkGenericSharedLibName platform comp lib
- | Just lib' <- stripPrefix "C" lib
- = "lib" ++ lib' <.> dllExtension platform
- | otherwise
- = error ("Don't understand library name " ++ lib)
+ | "HS" `isPrefixOf` lib =
+ mkGenericSharedLibName platform comp lib
+ | Just lib' <- stripPrefix "C" lib =
+ "lib" ++ lib' <.> dllExtension platform
+ | otherwise =
+ error ("Don't understand library name " ++ lib)
-- ------------------------------------------------------------
+
-- * Platform file extensions
+
-- ------------------------------------------------------------
-- | Default extension for executable files on the current platform.
-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
exeExtension :: Platform -> String
exeExtension platform = case platform of
- Platform _ Windows -> "exe"
- Platform Wasm32 _ -> "wasm"
- _ -> ""
+ Platform _ Windows -> "exe"
+ Platform Wasm32 _ -> "wasm"
+ _ -> ""
-- | Extension for object files. For GHC the extension is @\"o\"@.
objExtension :: String
@@ -257,10 +283,10 @@ objExtension = "o"
-- | Extension for dynamically linked (or shared) libraries
-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)
dllExtension :: Platform -> String
-dllExtension (Platform _arch os)= case os of
- Windows -> "dll"
- OSX -> "dylib"
- _ -> "so"
+dllExtension (Platform _arch os) = case os of
+ Windows -> "dll"
+ OSX -> "dylib"
+ _ -> "so"
-- | Extension for static libraries
--
@@ -268,5 +294,5 @@ dllExtension (Platform _arch os)= case os of
-- interested in, not the build OS.
staticLibExtension :: Platform -> String
staticLibExtension (Platform _arch os) = case os of
- Windows -> "lib"
- _ -> "a"
+ Windows -> "lib"
+ _ -> "a"
diff --git a/Cabal/src/Distribution/Simple/BuildTarget.hs b/Cabal/src/Distribution/Simple/BuildTarget.hs
index 71f1cf402baedaa1cce8a8f1e1ef1c23596e1be5..0096487813083b4062a7429c90f5a9156dabe063 100644
--- a/Cabal/src/Distribution/Simple/BuildTarget.hs
+++ b/Cabal/src/Distribution/Simple/BuildTarget.hs
@@ -3,6 +3,9 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.BuildTargets
-- Copyright : (c) Duncan Coutts 2012
@@ -11,133 +14,126 @@
-- Maintainer : duncan@community.haskell.org
--
-- Handling for user-specified build targets
------------------------------------------------------------------------------
-module Distribution.Simple.BuildTarget (
- -- * Main interface
- readTargetInfos,
- readBuildTargets, -- in case you don't have LocalBuildInfo
+module Distribution.Simple.BuildTarget
+ ( -- * Main interface
+ readTargetInfos
+ , readBuildTargets -- in case you don't have LocalBuildInfo
-- * Build targets
- BuildTarget(..),
- showBuildTarget,
- QualLevel(..),
- buildTargetComponentName,
+ , BuildTarget (..)
+ , showBuildTarget
+ , QualLevel (..)
+ , buildTargetComponentName
-- * Parsing user build targets
- UserBuildTarget,
- readUserBuildTargets,
- showUserBuildTarget,
- UserBuildTargetProblem(..),
- reportUserBuildTargetProblems,
+ , UserBuildTarget
+ , readUserBuildTargets
+ , showUserBuildTarget
+ , UserBuildTargetProblem (..)
+ , reportUserBuildTargetProblems
-- * Resolving build targets
- resolveBuildTargets,
- BuildTargetProblem(..),
- reportBuildTargetProblems,
+ , resolveBuildTargets
+ , BuildTargetProblem (..)
+ , reportBuildTargetProblems
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.TargetInfo
-import Distribution.Types.LocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
import Distribution.Types.ForeignLib
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.TargetInfo
import Distribution.Types.UnqualComponentName
+import Distribution.ModuleName
import Distribution.Package
import Distribution.PackageDescription
-import Distribution.ModuleName
-import Distribution.Simple.LocalBuildInfo
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
-import Distribution.Verbosity
import Distribution.Utils.Path
+import Distribution.Verbosity
import qualified Distribution.Compat.CharParsing as P
-import Control.Arrow ( (&&&) )
-import Control.Monad ( msum )
-import Data.List ( stripPrefix, groupBy )
+import Control.Arrow ((&&&))
+import Control.Monad (msum)
+import Data.List (groupBy, stripPrefix)
import qualified Data.List.NonEmpty as NE
-import System.FilePath as FilePath
- ( dropExtension, normalise, splitDirectories, joinPath, splitPath
- , hasTrailingPathSeparator )
-import System.Directory ( doesFileExist, doesDirectoryExist )
import qualified Data.Map as Map
+import System.Directory (doesDirectoryExist, doesFileExist)
+import System.FilePath as FilePath
+ ( dropExtension
+ , hasTrailingPathSeparator
+ , joinPath
+ , normalise
+ , splitDirectories
+ , splitPath
+ )
-- | Take a list of 'String' build targets, and parse and validate them
-- into actual 'TargetInfo's to be built/registered/whatever.
readTargetInfos :: Verbosity -> PackageDescription -> LocalBuildInfo -> [String] -> IO [TargetInfo]
readTargetInfos verbosity pkg_descr lbi args = do
- build_targets <- readBuildTargets verbosity pkg_descr args
- checkBuildTargets verbosity pkg_descr lbi build_targets
+ build_targets <- readBuildTargets verbosity pkg_descr args
+ checkBuildTargets verbosity pkg_descr lbi build_targets
-- ------------------------------------------------------------
+
-- * User build targets
+
-- ------------------------------------------------------------
-- | Various ways that a user may specify a build target.
---
-data UserBuildTarget =
-
- -- | A target specified by a single name. This could be a component
- -- module or file.
- --
- -- > cabal build foo
- -- > cabal build Data.Foo
- -- > cabal build Data/Foo.hs Data/Foo.hsc
- --
- UserBuildTargetSingle String
-
- -- | A target specified by a qualifier and name. This could be a component
- -- name qualified by the component namespace kind, or a module or file
- -- qualified by the component name.
- --
- -- > cabal build lib:foo exe:foo
- -- > cabal build foo:Data.Foo
- -- > cabal build foo:Data/Foo.hs
- --
- | UserBuildTargetDouble String String
-
- -- | A fully qualified target, either a module or file qualified by a
- -- component name with the component namespace kind.
- --
- -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
- -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
- --
- | UserBuildTargetTriple String String String
+data UserBuildTarget
+ = -- | A target specified by a single name. This could be a component
+ -- module or file.
+ --
+ -- > cabal build foo
+ -- > cabal build Data.Foo
+ -- > cabal build Data/Foo.hs Data/Foo.hsc
+ UserBuildTargetSingle String
+ | -- | A target specified by a qualifier and name. This could be a component
+ -- name qualified by the component namespace kind, or a module or file
+ -- qualified by the component name.
+ --
+ -- > cabal build lib:foo exe:foo
+ -- > cabal build foo:Data.Foo
+ -- > cabal build foo:Data/Foo.hs
+ UserBuildTargetDouble String String
+ | -- | A fully qualified target, either a module or file qualified by a
+ -- component name with the component namespace kind.
+ --
+ -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs
+ -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo
+ UserBuildTargetTriple String String String
deriving (Show, Eq, Ord)
-
-- ------------------------------------------------------------
+
-- * Resolved build targets
+
-- ------------------------------------------------------------
-- | A fully resolved build target.
---
-data BuildTarget =
-
- -- | A specific component
- --
- BuildTargetComponent ComponentName
-
- -- | A specific module within a specific component.
- --
- | BuildTargetModule ComponentName ModuleName
-
- -- | A specific file within a specific component.
- --
- | BuildTargetFile ComponentName FilePath
+data BuildTarget
+ = -- | A specific component
+ BuildTargetComponent ComponentName
+ | -- | A specific module within a specific component.
+ BuildTargetModule ComponentName ModuleName
+ | -- | A specific file within a specific component.
+ BuildTargetFile ComponentName FilePath
deriving (Eq, Show, Generic)
instance Binary BuildTarget
buildTargetComponentName :: BuildTarget -> ComponentName
-buildTargetComponentName (BuildTargetComponent cn) = cn
-buildTargetComponentName (BuildTargetModule cn _) = cn
-buildTargetComponentName (BuildTargetFile cn _) = cn
+buildTargetComponentName (BuildTargetComponent cn) = cn
+buildTargetComponentName (BuildTargetModule cn _) = cn
+buildTargetComponentName (BuildTargetFile cn _) = cn
-- | Read a list of user-supplied build target strings and resolve them to
-- 'BuildTarget's according to a 'PackageDescription'. If there are problems
@@ -145,40 +141,43 @@ buildTargetComponentName (BuildTargetFile cn _) = cn
-- 'IOException'.
readBuildTargets :: Verbosity -> PackageDescription -> [String] -> IO [BuildTarget]
readBuildTargets verbosity pkg targetStrs = do
- let (uproblems, utargets) = readUserBuildTargets targetStrs
- reportUserBuildTargetProblems verbosity uproblems
+ let (uproblems, utargets) = readUserBuildTargets targetStrs
+ reportUserBuildTargetProblems verbosity uproblems
- utargets' <- traverse checkTargetExistsAsFile utargets
+ utargets' <- traverse checkTargetExistsAsFile utargets
- let (bproblems, btargets) = resolveBuildTargets pkg utargets'
- reportBuildTargetProblems verbosity bproblems
+ let (bproblems, btargets) = resolveBuildTargets pkg utargets'
+ reportBuildTargetProblems verbosity bproblems
- return btargets
+ return btargets
checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile t = do
- fexists <- existsAsFile (fileComponentOfTarget t)
- return (t, fexists)
-
+ fexists <- existsAsFile (fileComponentOfTarget t)
+ return (t, fexists)
where
existsAsFile f = do
exists <- doesFileExist f
case splitPath f of
- (d:_) | hasTrailingPathSeparator d -> doesDirectoryExist d
- (d:_:_) | not exists -> doesDirectoryExist d
- _ -> return exists
+ (d : _) | hasTrailingPathSeparator d -> doesDirectoryExist d
+ (d : _ : _) | not exists -> doesDirectoryExist d
+ _ -> return exists
- fileComponentOfTarget (UserBuildTargetSingle s1) = s1
- fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2
+ fileComponentOfTarget (UserBuildTargetSingle s1) = s1
+ fileComponentOfTarget (UserBuildTargetDouble _ s2) = s2
fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3
-
-- ------------------------------------------------------------
+
-- * Parsing user targets
+
-- ------------------------------------------------------------
-readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]
- ,[UserBuildTarget])
+readUserBuildTargets
+ :: [String]
+ -> ( [UserBuildTargetProblem]
+ , [UserBuildTarget]
+ )
readUserBuildTargets = partitionEithers . map readUserBuildTarget
-- |
@@ -206,81 +205,87 @@ readUserBuildTargets = partitionEithers . map readUserBuildTarget
--
-- >>> readUserBuildTarget "pkg:\"lib\":comp"
-- Left (UserBuildTargetUnrecognised "pkg:\"lib\":comp")
---
-readUserBuildTarget :: String -> Either UserBuildTargetProblem
- UserBuildTarget
+readUserBuildTarget
+ :: String
+ -> Either
+ UserBuildTargetProblem
+ UserBuildTarget
readUserBuildTarget targetstr =
- case explicitEitherParsec parseTargetApprox targetstr of
- Left _ -> Left (UserBuildTargetUnrecognised targetstr)
- Right tgt -> Right tgt
-
+ case explicitEitherParsec parseTargetApprox targetstr of
+ Left _ -> Left (UserBuildTargetUnrecognised targetstr)
+ Right tgt -> Right tgt
where
parseTargetApprox :: CabalParsing m => m UserBuildTarget
parseTargetApprox = do
- -- read one, two, or three tokens, where last could be "hs-string"
- ts <- tokens
- return $ case ts of
- (a, Nothing) -> UserBuildTargetSingle a
- (a, Just (b, Nothing)) -> UserBuildTargetDouble a b
- (a, Just (b, Just c)) -> UserBuildTargetTriple a b c
+ -- read one, two, or three tokens, where last could be "hs-string"
+ ts <- tokens
+ return $ case ts of
+ (a, Nothing) -> UserBuildTargetSingle a
+ (a, Just (b, Nothing)) -> UserBuildTargetDouble a b
+ (a, Just (b, Just c)) -> UserBuildTargetTriple a b c
tokens :: CabalParsing m => m (String, Maybe (String, Maybe String))
- tokens = (\s -> (s, Nothing)) <$> parsecHaskellString
+ tokens =
+ (\s -> (s, Nothing)) <$> parsecHaskellString
<|> (,) <$> token <*> P.optional (P.char ':' *> tokens2)
tokens2 :: CabalParsing m => m (String, Maybe String)
- tokens2 = (\s -> (s, Nothing)) <$> parsecHaskellString
+ tokens2 =
+ (\s -> (s, Nothing)) <$> parsecHaskellString
<|> (,) <$> token <*> P.optional (P.char ':' *> (parsecHaskellString <|> token))
token :: CabalParsing m => m String
- token = P.munch1 (\x -> not (isSpace x) && x /= ':')
+ token = P.munch1 (\x -> not (isSpace x) && x /= ':')
data UserBuildTargetProblem
- = UserBuildTargetUnrecognised String
- deriving Show
+ = UserBuildTargetUnrecognised String
+ deriving (Show)
reportUserBuildTargetProblems :: Verbosity -> [UserBuildTargetProblem] -> IO ()
reportUserBuildTargetProblems verbosity problems = do
- case [ target | UserBuildTargetUnrecognised target <- problems ] of
- [] -> return ()
- target ->
- die' verbosity $ unlines
- [ "Unrecognised build target '" ++ name ++ "'."
- | name <- target ]
- ++ "Examples:\n"
- ++ " - build foo -- component name "
- ++ "(library, executable, test-suite or benchmark)\n"
- ++ " - build Data.Foo -- module name\n"
- ++ " - build Data/Foo.hsc -- file name\n"
- ++ " - build lib:foo exe:foo -- component qualified by kind\n"
- ++ " - build foo:Data.Foo -- module qualified by component\n"
- ++ " - build foo:Data/Foo.hsc -- file qualified by component"
+ case [target | UserBuildTargetUnrecognised target <- problems] of
+ [] -> return ()
+ target ->
+ die' verbosity $
+ unlines
+ [ "Unrecognised build target '" ++ name ++ "'."
+ | name <- target
+ ]
+ ++ "Examples:\n"
+ ++ " - build foo -- component name "
+ ++ "(library, executable, test-suite or benchmark)\n"
+ ++ " - build Data.Foo -- module name\n"
+ ++ " - build Data/Foo.hsc -- file name\n"
+ ++ " - build lib:foo exe:foo -- component qualified by kind\n"
+ ++ " - build foo:Data.Foo -- module qualified by component\n"
+ ++ " - build foo:Data/Foo.hsc -- file qualified by component"
showUserBuildTarget :: UserBuildTarget -> String
showUserBuildTarget = intercalate ":" . getComponents
where
- getComponents (UserBuildTargetSingle s1) = [s1]
- getComponents (UserBuildTargetDouble s1 s2) = [s1,s2]
- getComponents (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]
+ getComponents (UserBuildTargetSingle s1) = [s1]
+ getComponents (UserBuildTargetDouble s1 s2) = [s1, s2]
+ getComponents (UserBuildTargetTriple s1 s2 s3) = [s1, s2, s3]
-- | Unless you use 'QL1', this function is PARTIAL;
-- use 'showBuildTarget' instead.
showBuildTarget' :: QualLevel -> PackageId -> BuildTarget -> String
showBuildTarget' ql pkgid bt =
- showUserBuildTarget (renderBuildTarget ql bt pkgid)
+ showUserBuildTarget (renderBuildTarget ql bt pkgid)
-- | Unambiguously render a 'BuildTarget', so that it can
-- be parsed in all situations.
showBuildTarget :: PackageId -> BuildTarget -> String
showBuildTarget pkgid t =
- showBuildTarget' (qlBuildTarget t) pkgid t
+ showBuildTarget' (qlBuildTarget t) pkgid t
where
qlBuildTarget BuildTargetComponent{} = QL2
- qlBuildTarget _ = QL3
-
+ qlBuildTarget _ = QL3
-- ------------------------------------------------------------
+
-- * Resolving user targets to build targets
+
-- ------------------------------------------------------------
{-
@@ -299,219 +304,253 @@ Just ex_pkgid = simpleParse "thelib"
-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
---
-resolveBuildTargets :: PackageDescription
- -> [(UserBuildTarget, Bool)]
- -> ([BuildTargetProblem], [BuildTarget])
-resolveBuildTargets pkg = partitionEithers
- . map (uncurry (resolveBuildTarget pkg))
-
-resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool
- -> Either BuildTargetProblem BuildTarget
+resolveBuildTargets
+ :: PackageDescription
+ -> [(UserBuildTarget, Bool)]
+ -> ([BuildTargetProblem], [BuildTarget])
+resolveBuildTargets pkg =
+ partitionEithers
+ . map (uncurry (resolveBuildTarget pkg))
+
+resolveBuildTarget
+ :: PackageDescription
+ -> UserBuildTarget
+ -> Bool
+ -> Either BuildTargetProblem BuildTarget
resolveBuildTarget pkg userTarget fexists =
- case findMatch (matchBuildTarget pkg userTarget fexists) of
- Unambiguous target -> Right target
- Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets')
- where targets' = disambiguateBuildTargets
- (packageId pkg)
- userTarget
- targets
- None errs -> Left (classifyMatchErrors errs)
-
+ case findMatch (matchBuildTarget pkg userTarget fexists) of
+ Unambiguous target -> Right target
+ Ambiguous targets -> Left (BuildTargetAmbiguous userTarget targets')
+ where
+ targets' =
+ disambiguateBuildTargets
+ (packageId pkg)
+ userTarget
+ targets
+ None errs -> Left (classifyMatchErrors errs)
where
classifyMatchErrors errs
- | Just expected' <- NE.nonEmpty expected
- = let unzip' = fmap fst &&& fmap snd
- (things, got:|_) = unzip' expected' in
- BuildTargetExpected userTarget (NE.toList things) got
- | not (null nosuch) = BuildTargetNoSuch userTarget nosuch
+ | Just expected' <- NE.nonEmpty expected =
+ let unzip' = fmap fst &&& fmap snd
+ (things, got :| _) = unzip' expected'
+ in BuildTargetExpected userTarget (NE.toList things) got
+ | not (null nosuch) = BuildTargetNoSuch userTarget nosuch
| otherwise = error $ "resolveBuildTarget: internal error in matching"
where
- expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]
- nosuch = [ (thing, got) | MatchErrorNoSuch thing got <- errs ]
-
+ expected = [(thing, got) | MatchErrorExpected thing got <- errs]
+ nosuch = [(thing, got) | MatchErrorNoSuch thing got <- errs]
data BuildTargetProblem
- = BuildTargetExpected UserBuildTarget [String] String
- -- ^ [expected thing] (actually got)
- | BuildTargetNoSuch UserBuildTarget [(String, String)]
- -- ^ [(no such thing, actually got)]
- | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
- deriving Show
-
-
-disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]
- -> [(UserBuildTarget, BuildTarget)]
+ = -- | [expected thing] (actually got)
+ BuildTargetExpected UserBuildTarget [String] String
+ | -- | [(no such thing, actually got)]
+ BuildTargetNoSuch UserBuildTarget [(String, String)]
+ | BuildTargetAmbiguous UserBuildTarget [(UserBuildTarget, BuildTarget)]
+ deriving (Show)
+
+disambiguateBuildTargets
+ :: PackageId
+ -> UserBuildTarget
+ -> [BuildTarget]
+ -> [(UserBuildTarget, BuildTarget)]
disambiguateBuildTargets pkgid original =
- disambiguate (userTargetQualLevel original)
+ disambiguate (userTargetQualLevel original)
where
disambiguate ql ts
- | null amb = unamb
- | otherwise = unamb ++ disambiguate (succ ql) amb
+ | null amb = unamb
+ | otherwise = unamb ++ disambiguate (succ ql) amb
where
(amb, unamb) = step ql ts
- userTargetQualLevel (UserBuildTargetSingle _ ) = QL1
- userTargetQualLevel (UserBuildTargetDouble _ _ ) = QL2
+ userTargetQualLevel (UserBuildTargetSingle _) = QL1
+ userTargetQualLevel (UserBuildTargetDouble _ _) = QL2
userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3
- step :: QualLevel -> [BuildTarget]
- -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
- step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
- . partition (\g -> length g > 1)
- . groupBy (equating fst)
- . sortBy (comparing fst)
- . map (\t -> (renderBuildTarget ql t pkgid, t))
+ step
+ :: QualLevel
+ -> [BuildTarget]
+ -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])
+ step ql =
+ (\(amb, unamb) -> (map snd $ concat amb, concat unamb))
+ . partition (\g -> length g > 1)
+ . groupBy (equating fst)
+ . sortBy (comparing fst)
+ . map (\t -> (renderBuildTarget ql t pkgid, t))
data QualLevel = QL1 | QL2 | QL3
deriving (Enum, Show)
renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget
renderBuildTarget ql target pkgid =
- case ql of
- QL1 -> UserBuildTargetSingle s1 where s1 = single target
- QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target
- QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target
-
+ case ql of
+ QL1 -> UserBuildTargetSingle s1 where s1 = single target
+ QL2 -> UserBuildTargetDouble s1 s2 where (s1, s2) = double target
+ QL3 -> UserBuildTargetTriple s1 s2 s3 where (s1, s2, s3) = triple target
where
- single (BuildTargetComponent cn ) = dispCName cn
- single (BuildTargetModule _ m) = prettyShow m
- single (BuildTargetFile _ f) = f
+ single (BuildTargetComponent cn) = dispCName cn
+ single (BuildTargetModule _ m) = prettyShow m
+ single (BuildTargetFile _ f) = f
- double (BuildTargetComponent cn ) = (dispKind cn, dispCName cn)
- double (BuildTargetModule cn m) = (dispCName cn, prettyShow m)
- double (BuildTargetFile cn f) = (dispCName cn, f)
+ double (BuildTargetComponent cn) = (dispKind cn, dispCName cn)
+ double (BuildTargetModule cn m) = (dispCName cn, prettyShow m)
+ double (BuildTargetFile cn f) = (dispCName cn, f)
- triple (BuildTargetComponent _ ) = error "triple BuildTargetComponent"
- triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m)
- triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f)
+ triple (BuildTargetComponent _) = error "triple BuildTargetComponent"
+ triple (BuildTargetModule cn m) = (dispKind cn, dispCName cn, prettyShow m)
+ triple (BuildTargetFile cn f) = (dispKind cn, dispCName cn, f)
dispCName = componentStringName pkgid
- dispKind = showComponentKindShort . componentKind
+ dispKind = showComponentKindShort . componentKind
reportBuildTargetProblems :: Verbosity -> [BuildTargetProblem] -> IO ()
reportBuildTargetProblems verbosity problems = do
-
- case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
- [ "Unrecognised build target '" ++ showUserBuildTarget target
+ case [(t, e, g) | BuildTargetExpected t e g <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
+ [ "Unrecognised build target '"
+ ++ showUserBuildTarget target
++ "'.\n"
- ++ "Expected a " ++ intercalate " or " expected
- ++ ", rather than '" ++ got ++ "'."
- | (target, expected, got) <- targets ]
-
- case [ (t, e) | BuildTargetNoSuch t e <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
- [ "Unknown build target '" ++ showUserBuildTarget target
+ ++ "Expected a "
+ ++ intercalate " or " expected
+ ++ ", rather than '"
+ ++ got
+ ++ "'."
+ | (target, expected, got) <- targets
+ ]
+
+ case [(t, e) | BuildTargetNoSuch t e <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
+ [ "Unknown build target '"
+ ++ showUserBuildTarget target
++ "'.\nThere is no "
- ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"
- | (thing, got) <- nosuch ] ++ "."
- | (target, nosuch) <- targets ]
- where
- mungeThing "file" = "file target"
- mungeThing thing = thing
-
- case [ (t, ts) | BuildTargetAmbiguous t ts <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
- [ "Ambiguous build target '" ++ showUserBuildTarget target
+ ++ intercalate
+ " or "
+ [ mungeThing thing ++ " '" ++ got ++ "'"
+ | (thing, got) <- nosuch
+ ]
+ ++ "."
+ | (target, nosuch) <- targets
+ ]
+ where
+ mungeThing "file" = "file target"
+ mungeThing thing = thing
+
+ case [(t, ts) | BuildTargetAmbiguous t ts <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
+ [ "Ambiguous build target '"
+ ++ showUserBuildTarget target
++ "'. It could be:\n "
- ++ unlines [ " "++ showUserBuildTarget ut ++
- " (" ++ showBuildTargetKind bt ++ ")"
- | (ut, bt) <- amb ]
- | (target, amb) <- targets ]
-
+ ++ unlines
+ [ " "
+ ++ showUserBuildTarget ut
+ ++ " ("
+ ++ showBuildTargetKind bt
+ ++ ")"
+ | (ut, bt) <- amb
+ ]
+ | (target, amb) <- targets
+ ]
where
- showBuildTargetKind (BuildTargetComponent _ ) = "component"
- showBuildTargetKind (BuildTargetModule _ _) = "module"
- showBuildTargetKind (BuildTargetFile _ _) = "file"
-
+ showBuildTargetKind (BuildTargetComponent _) = "component"
+ showBuildTargetKind (BuildTargetModule _ _) = "module"
+ showBuildTargetKind (BuildTargetFile _ _) = "file"
----------------------------------
-- Top level BuildTarget matcher
--
-matchBuildTarget :: PackageDescription
- -> UserBuildTarget -> Bool -> Match BuildTarget
+matchBuildTarget
+ :: PackageDescription
+ -> UserBuildTarget
+ -> Bool
+ -> Match BuildTarget
matchBuildTarget pkg = \utarget fexists ->
- case utarget of
- UserBuildTargetSingle str1 ->
- matchBuildTarget1 cinfo str1 fexists
-
- UserBuildTargetDouble str1 str2 ->
- matchBuildTarget2 cinfo str1 str2 fexists
-
- UserBuildTargetTriple str1 str2 str3 ->
- matchBuildTarget3 cinfo str1 str2 str3 fexists
+ case utarget of
+ UserBuildTargetSingle str1 ->
+ matchBuildTarget1 cinfo str1 fexists
+ UserBuildTargetDouble str1 str2 ->
+ matchBuildTarget2 cinfo str1 str2 fexists
+ UserBuildTargetTriple str1 str2 str3 ->
+ matchBuildTarget3 cinfo str1 str2 str3 fexists
where
cinfo = pkgComponentInfo pkg
matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchBuildTarget1 cinfo str1 fexists =
- matchComponent1 cinfo str1
- `matchPlusShadowing` matchModule1 cinfo str1
- `matchPlusShadowing` matchFile1 cinfo str1 fexists
-
-
-matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool
- -> Match BuildTarget
+ matchComponent1 cinfo str1
+ `matchPlusShadowing` matchModule1 cinfo str1
+ `matchPlusShadowing` matchFile1 cinfo str1 fexists
+
+matchBuildTarget2
+ :: [ComponentInfo]
+ -> String
+ -> String
+ -> Bool
+ -> Match BuildTarget
matchBuildTarget2 cinfo str1 str2 fexists =
- matchComponent2 cinfo str1 str2
- `matchPlusShadowing` matchModule2 cinfo str1 str2
- `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists
-
-
-matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool
- -> Match BuildTarget
+ matchComponent2 cinfo str1 str2
+ `matchPlusShadowing` matchModule2 cinfo str1 str2
+ `matchPlusShadowing` matchFile2 cinfo str1 str2 fexists
+
+matchBuildTarget3
+ :: [ComponentInfo]
+ -> String
+ -> String
+ -> String
+ -> Bool
+ -> Match BuildTarget
matchBuildTarget3 cinfo str1 str2 str3 fexists =
- matchModule3 cinfo str1 str2 str3
- `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists
-
-
-data ComponentInfo = ComponentInfo {
- cinfoName :: ComponentName,
- cinfoStrName :: ComponentStringName,
- cinfoSrcDirs :: [FilePath],
- cinfoModules :: [ModuleName],
- cinfoHsFiles :: [FilePath], -- other hs files (like main.hs)
- cinfoAsmFiles:: [FilePath],
- cinfoCmmFiles:: [FilePath],
- cinfoCFiles :: [FilePath],
- cinfoCxxFiles:: [FilePath],
- cinfoJsFiles :: [FilePath]
- }
+ matchModule3 cinfo str1 str2 str3
+ `matchPlusShadowing` matchFile3 cinfo str1 str2 str3 fexists
+
+data ComponentInfo = ComponentInfo
+ { cinfoName :: ComponentName
+ , cinfoStrName :: ComponentStringName
+ , cinfoSrcDirs :: [FilePath]
+ , cinfoModules :: [ModuleName]
+ , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)
+ , cinfoAsmFiles :: [FilePath]
+ , cinfoCmmFiles :: [FilePath]
+ , cinfoCFiles :: [FilePath]
+ , cinfoCxxFiles :: [FilePath]
+ , cinfoJsFiles :: [FilePath]
+ }
type ComponentStringName = String
pkgComponentInfo :: PackageDescription -> [ComponentInfo]
pkgComponentInfo pkg =
- [ ComponentInfo {
- cinfoName = componentName c,
- cinfoStrName = componentStringName pkg (componentName c),
- cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi,
- cinfoModules = componentModules c,
- cinfoHsFiles = componentHsFiles c,
- cinfoAsmFiles= asmSources bi,
- cinfoCmmFiles= cmmSources bi,
- cinfoCFiles = cSources bi,
- cinfoCxxFiles= cxxSources bi,
- cinfoJsFiles = jsSources bi
- }
- | c <- pkgComponents pkg
- , let bi = componentBuildInfo c ]
+ [ ComponentInfo
+ { cinfoName = componentName c
+ , cinfoStrName = componentStringName pkg (componentName c)
+ , cinfoSrcDirs = map getSymbolicPath $ hsSourceDirs bi
+ , cinfoModules = componentModules c
+ , cinfoHsFiles = componentHsFiles c
+ , cinfoAsmFiles = asmSources bi
+ , cinfoCmmFiles = cmmSources bi
+ , cinfoCFiles = cSources bi
+ , cinfoCxxFiles = cxxSources bi
+ , cinfoJsFiles = jsSources bi
+ }
+ | c <- pkgComponents pkg
+ , let bi = componentBuildInfo c
+ ]
componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName
-componentStringName pkg (CLibName LMainLibName ) = prettyShow (packageName pkg)
-componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name
-componentStringName _ (CFLibName name) = unUnqualComponentName name
-componentStringName _ (CExeName name) = unUnqualComponentName name
-componentStringName _ (CTestName name) = unUnqualComponentName name
-componentStringName _ (CBenchName name) = unUnqualComponentName name
+componentStringName pkg (CLibName LMainLibName) = prettyShow (packageName pkg)
+componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name
+componentStringName _ (CFLibName name) = unUnqualComponentName name
+componentStringName _ (CExeName name) = unUnqualComponentName name
+componentStringName _ (CTestName name) = unUnqualComponentName name
+componentStringName _ (CBenchName name) = unUnqualComponentName name
componentModules :: Component -> [ModuleName]
-- TODO: Use of 'explicitLibModules' here is a bit wrong:
@@ -521,21 +560,27 @@ componentModules :: Component -> [ModuleName]
-- Fortunately, this is only used by 'pkgComponentInfo'
-- Please don't export this function unless you plan on fixing
-- this.
-componentModules (CLib lib) = explicitLibModules lib
-componentModules (CFLib flib) = foreignLibModules flib
-componentModules (CExe exe) = exeModules exe
-componentModules (CTest test) = testModules test
+componentModules (CLib lib) = explicitLibModules lib
+componentModules (CFLib flib) = foreignLibModules flib
+componentModules (CExe exe) = exeModules exe
+componentModules (CTest test) = testModules test
componentModules (CBench bench) = benchmarkModules bench
componentHsFiles :: Component -> [FilePath]
componentHsFiles (CExe exe) = [modulePath exe]
-componentHsFiles (CTest TestSuite {
- testInterface = TestSuiteExeV10 _ mainfile
- }) = [mainfile]
-componentHsFiles (CBench Benchmark {
- benchmarkInterface = BenchmarkExeV10 _ mainfile
- }) = [mainfile]
-componentHsFiles _ = []
+componentHsFiles
+ ( CTest
+ TestSuite
+ { testInterface = TestSuiteExeV10 _ mainfile
+ }
+ ) = [mainfile]
+componentHsFiles
+ ( CBench
+ Benchmark
+ { benchmarkInterface = BenchmarkExeV10 _ mainfile
+ }
+ ) = [mainfile]
+componentHsFiles _ = []
{-
ex_cs :: [ComponentInfo]
@@ -559,10 +604,10 @@ data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind
deriving (Eq, Ord, Show, Enum, Bounded)
componentKind :: ComponentName -> ComponentKind
-componentKind (CLibName _) = LibKind
-componentKind (CFLibName _) = FLibKind
-componentKind (CExeName _) = ExeKind
-componentKind (CTestName _) = TestKind
+componentKind (CLibName _) = LibKind
+componentKind (CFLibName _) = FLibKind
+componentKind (CExeName _) = ExeKind
+componentKind (CTestName _) = TestKind
componentKind (CBenchName _) = BenchKind
cinfoKind :: ComponentInfo -> ComponentKind
@@ -570,27 +615,27 @@ cinfoKind = componentKind . cinfoName
matchComponentKind :: String -> Match ComponentKind
matchComponentKind s
- | s `elem` ["lib", "library"] = return' LibKind
+ | s `elem` ["lib", "library"] = return' LibKind
| s `elem` ["flib", "foreign-lib", "foreign-library"] = return' FLibKind
- | s `elem` ["exe", "executable"] = return' ExeKind
- | s `elem` ["tst", "test", "test-suite"] = return' TestKind
- | s `elem` ["bench", "benchmark"] = return' BenchKind
+ | s `elem` ["exe", "executable"] = return' ExeKind
+ | s `elem` ["tst", "test", "test-suite"] = return' TestKind
+ | s `elem` ["bench", "benchmark"] = return' BenchKind
| otherwise = matchErrorExpected "component kind" s
where
return' ck = increaseConfidence >> return ck
showComponentKind :: ComponentKind -> String
-showComponentKind LibKind = "library"
-showComponentKind FLibKind = "foreign-library"
-showComponentKind ExeKind = "executable"
-showComponentKind TestKind = "test-suite"
+showComponentKind LibKind = "library"
+showComponentKind FLibKind = "foreign-library"
+showComponentKind ExeKind = "executable"
+showComponentKind TestKind = "test-suite"
showComponentKind BenchKind = "benchmark"
showComponentKindShort :: ComponentKind -> String
-showComponentKindShort LibKind = "lib"
-showComponentKindShort FLibKind = "flib"
-showComponentKindShort ExeKind = "exe"
-showComponentKindShort TestKind = "test"
+showComponentKindShort LibKind = "lib"
+showComponentKindShort FLibKind = "flib"
+showComponentKindShort ExeKind = "exe"
+showComponentKindShort TestKind = "test"
showComponentKindShort BenchKind = "bench"
------------------------------
@@ -599,45 +644,54 @@ showComponentKindShort BenchKind = "bench"
matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget
matchComponent1 cs = \str1 -> do
- guardComponentName str1
- c <- matchComponentName cs str1
- return (BuildTargetComponent (cinfoName c))
+ guardComponentName str1
+ c <- matchComponentName cs str1
+ return (BuildTargetComponent (cinfoName c))
matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
matchComponent2 cs = \str1 str2 -> do
- ckind <- matchComponentKind str1
- guardComponentName str2
- c <- matchComponentKindAndName cs ckind str2
- return (BuildTargetComponent (cinfoName c))
+ ckind <- matchComponentKind str1
+ guardComponentName str2
+ c <- matchComponentKindAndName cs ckind str2
+ return (BuildTargetComponent (cinfoName c))
-- utils:
guardComponentName :: String -> Match ()
guardComponentName s
| all validComponentChar s
- && not (null s) = increaseConfidence
- | otherwise = matchErrorExpected "component name" s
+ && not (null s) =
+ increaseConfidence
+ | otherwise = matchErrorExpected "component name" s
where
- validComponentChar c = isAlphaNum c || c == '.'
- || c == '_' || c == '-' || c == '\''
+ validComponentChar c =
+ isAlphaNum c
+ || c == '.'
+ || c == '_'
+ || c == '-'
+ || c == '\''
matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo
matchComponentName cs str =
- orNoSuchThing "component" str
- $ increaseConfidenceFor
- $ matchInexactly caseFold
- [ (cinfoStrName c, c) | c <- cs ]
- str
-
-matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String
- -> Match ComponentInfo
+ orNoSuchThing "component" str $
+ increaseConfidenceFor $
+ matchInexactly
+ caseFold
+ [(cinfoStrName c, c) | c <- cs]
+ str
+
+matchComponentKindAndName
+ :: [ComponentInfo]
+ -> ComponentKind
+ -> String
+ -> Match ComponentInfo
matchComponentKindAndName cs ckind str =
- orNoSuchThing (showComponentKind ckind ++ " component") str
- $ increaseConfidenceFor
- $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))
- [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]
- (ckind, str)
-
+ orNoSuchThing (showComponentKind ckind ++ " component") str $
+ increaseConfidenceFor $
+ matchInexactly
+ (\(ck, cn) -> (ck, caseFold cn))
+ [((cinfoKind c, cinfoStrName c), c) | c <- cs]
+ (ckind, str)
------------------------------
-- Matching module targets
@@ -645,52 +699,58 @@ matchComponentKindAndName cs ckind str =
matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget
matchModule1 cs = \str1 -> do
- guardModuleName str1
- nubMatchErrors $ do
- c <- tryEach cs
- let ms = cinfoModules c
- m <- matchModuleName ms str1
- return (BuildTargetModule (cinfoName c) m)
-
-matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
-matchModule2 cs = \str1 str2 -> do
- guardComponentName str1
- guardModuleName str2
- c <- matchComponentName cs str1
+ guardModuleName str1
+ nubMatchErrors $ do
+ c <- tryEach cs
let ms = cinfoModules c
- m <- matchModuleName ms str2
+ m <- matchModuleName ms str1
return (BuildTargetModule (cinfoName c) m)
-matchModule3 :: [ComponentInfo] -> String -> String -> String
- -> Match BuildTarget
+matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget
+matchModule2 cs = \str1 str2 -> do
+ guardComponentName str1
+ guardModuleName str2
+ c <- matchComponentName cs str1
+ let ms = cinfoModules c
+ m <- matchModuleName ms str2
+ return (BuildTargetModule (cinfoName c) m)
+
+matchModule3
+ :: [ComponentInfo]
+ -> String
+ -> String
+ -> String
+ -> Match BuildTarget
matchModule3 cs str1 str2 str3 = do
- ckind <- matchComponentKind str1
- guardComponentName str2
- c <- matchComponentKindAndName cs ckind str2
- guardModuleName str3
- let ms = cinfoModules c
- m <- matchModuleName ms str3
- return (BuildTargetModule (cinfoName c) m)
+ ckind <- matchComponentKind str1
+ guardComponentName str2
+ c <- matchComponentKindAndName cs ckind str2
+ guardModuleName str3
+ let ms = cinfoModules c
+ m <- matchModuleName ms str3
+ return (BuildTargetModule (cinfoName c) m)
-- utils:
guardModuleName :: String -> Match ()
guardModuleName s
| all validModuleChar s
- && not (null s) = increaseConfidence
- | otherwise = matchErrorExpected "module name" s
+ && not (null s) =
+ increaseConfidence
+ | otherwise = matchErrorExpected "module name" s
where
validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''
matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms str =
- orNoSuchThing "module" str
- $ increaseConfidenceFor
- $ matchInexactly caseFold
- [ (prettyShow m, m)
- | m <- ms ]
- str
-
+ orNoSuchThing "module" str $
+ increaseConfidenceFor $
+ matchInexactly
+ caseFold
+ [ (prettyShow m, m)
+ | m <- ms
+ ]
+ str
------------------------------
-- Matching file targets
@@ -698,105 +758,115 @@ matchModuleName ms str =
matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget
matchFile1 cs str1 exists =
- nubMatchErrors $ do
- c <- tryEach cs
- filepath <- matchComponentFile c str1 exists
- return (BuildTargetFile (cinfoName c) filepath)
-
+ nubMatchErrors $ do
+ c <- tryEach cs
+ filepath <- matchComponentFile c str1 exists
+ return (BuildTargetFile (cinfoName c) filepath)
matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget
matchFile2 cs str1 str2 exists = do
- guardComponentName str1
- c <- matchComponentName cs str1
- filepath <- matchComponentFile c str2 exists
- return (BuildTargetFile (cinfoName c) filepath)
-
-
-matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool
- -> Match BuildTarget
+ guardComponentName str1
+ c <- matchComponentName cs str1
+ filepath <- matchComponentFile c str2 exists
+ return (BuildTargetFile (cinfoName c) filepath)
+
+matchFile3
+ :: [ComponentInfo]
+ -> String
+ -> String
+ -> String
+ -> Bool
+ -> Match BuildTarget
matchFile3 cs str1 str2 str3 exists = do
- ckind <- matchComponentKind str1
- guardComponentName str2
- c <- matchComponentKindAndName cs ckind str2
- filepath <- matchComponentFile c str3 exists
- return (BuildTargetFile (cinfoName c) filepath)
-
+ ckind <- matchComponentKind str1
+ guardComponentName str2
+ c <- matchComponentKindAndName cs ckind str2
+ filepath <- matchComponentFile c str3 exists
+ return (BuildTargetFile (cinfoName c) filepath)
matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath
matchComponentFile c str fexists =
- expecting "file" str $
- matchPlus
- (matchFileExists str fexists)
- (matchPlusShadowing
- (msum [ matchModuleFileRooted dirs ms str
- , matchOtherFileRooted dirs hsFiles str ])
- (msum [ matchModuleFileUnrooted ms str
- , matchOtherFileUnrooted hsFiles str
- , matchOtherFileUnrooted cFiles str
- , matchOtherFileUnrooted jsFiles str ]))
+ expecting "file" str $
+ matchPlus
+ (matchFileExists str fexists)
+ ( matchPlusShadowing
+ ( msum
+ [ matchModuleFileRooted dirs ms str
+ , matchOtherFileRooted dirs hsFiles str
+ ]
+ )
+ ( msum
+ [ matchModuleFileUnrooted ms str
+ , matchOtherFileUnrooted hsFiles str
+ , matchOtherFileUnrooted cFiles str
+ , matchOtherFileUnrooted jsFiles str
+ ]
+ )
+ )
where
dirs = cinfoSrcDirs c
- ms = cinfoModules c
+ ms = cinfoModules c
hsFiles = cinfoHsFiles c
- cFiles = cinfoCFiles c
+ cFiles = cinfoCFiles c
jsFiles = cinfoJsFiles c
-
-- utils
matchFileExists :: FilePath -> Bool -> Match a
-matchFileExists _ False = mzero
-matchFileExists fname True = do increaseConfidence
- matchErrorNoSuch "file" fname
+matchFileExists _ False = mzero
+matchFileExists fname True = do
+ increaseConfidence
+ matchErrorNoSuch "file" fname
matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath
matchModuleFileUnrooted ms str = do
- let filepath = normalise str
- _ <- matchModuleFileStem ms filepath
- return filepath
+ let filepath = normalise str
+ _ <- matchModuleFileStem ms filepath
+ return filepath
matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath
matchModuleFileRooted dirs ms str = nubMatches $ do
- let filepath = normalise str
- filepath' <- matchDirectoryPrefix dirs filepath
- _ <- matchModuleFileStem ms filepath'
- return filepath
+ let filepath = normalise str
+ filepath' <- matchDirectoryPrefix dirs filepath
+ _ <- matchModuleFileStem ms filepath'
+ return filepath
matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName
matchModuleFileStem ms =
- increaseConfidenceFor
- . matchInexactly caseFold
- [ (toFilePath m, m) | m <- ms ]
+ increaseConfidenceFor
+ . matchInexactly
+ caseFold
+ [(toFilePath m, m) | m <- ms]
. dropExtension
matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath
matchOtherFileRooted dirs fs str = do
- let filepath = normalise str
- filepath' <- matchDirectoryPrefix dirs filepath
- _ <- matchFile fs filepath'
- return filepath
+ let filepath = normalise str
+ filepath' <- matchDirectoryPrefix dirs filepath
+ _ <- matchFile fs filepath'
+ return filepath
matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath
matchOtherFileUnrooted fs str = do
- let filepath = normalise str
- _ <- matchFile fs filepath
- return filepath
+ let filepath = normalise str
+ _ <- matchFile fs filepath
+ return filepath
matchFile :: [FilePath] -> FilePath -> Match FilePath
-matchFile fs = increaseConfidenceFor
- . matchInexactly caseFold [ (f, f) | f <- fs ]
+matchFile fs =
+ increaseConfidenceFor
+ . matchInexactly caseFold [(f, f) | f <- fs]
matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath
matchDirectoryPrefix dirs filepath =
- exactMatches $
- catMaybes
- [ stripDirectory (normalise dir) filepath | dir <- dirs ]
+ exactMatches $
+ catMaybes
+ [stripDirectory (normalise dir) filepath | dir <- dirs]
where
stripDirectory :: FilePath -> FilePath -> Maybe FilePath
stripDirectory dir fp =
joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)
-
------------------------------
-- Matching monad
--
@@ -807,23 +877,22 @@ matchDirectoryPrefix dirs filepath =
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('ambiguousWith', 'shadows') and finally we can
-- run a matcher against an input using 'findMatch'.
---
-
-data Match a = NoMatch Confidence [MatchError]
- | ExactMatch Confidence [a]
- | InexactMatch Confidence [a]
- deriving Show
+data Match a
+ = NoMatch Confidence [MatchError]
+ | ExactMatch Confidence [a]
+ | InexactMatch Confidence [a]
+ deriving (Show)
type Confidence = Int
-data MatchError = MatchErrorExpected String String
- | MatchErrorNoSuch String String
+data MatchError
+ = MatchErrorExpected String String
+ | MatchErrorNoSuch String String
deriving (Show, Eq)
-
instance Alternative Match where
- empty = mzero
- (<|>) = mplus
+ empty = mzero
+ (<|>) = mplus
instance MonadPlus Match where
mzero = matchZero
@@ -835,34 +904,32 @@ matchZero = NoMatch 0 []
-- | Combine two matchers. Exact matches are used over inexact matches
-- but if we have multiple exact, or inexact then the we collect all the
-- ambiguous matches.
---
matchPlus :: Match a -> Match a -> Match a
-matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =
+matchPlus (ExactMatch d1 xs) (ExactMatch d2 xs') =
ExactMatch (max d1 d2) (xs ++ xs')
-matchPlus a@(ExactMatch _ _ ) (InexactMatch _ _ ) = a
-matchPlus a@(ExactMatch _ _ ) (NoMatch _ _ ) = a
-matchPlus (InexactMatch _ _ ) b@(ExactMatch _ _ ) = b
-matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') =
+matchPlus a@(ExactMatch _ _) (InexactMatch _ _) = a
+matchPlus a@(ExactMatch _ _) (NoMatch _ _) = a
+matchPlus (InexactMatch _ _) b@(ExactMatch _ _) = b
+matchPlus (InexactMatch d1 xs) (InexactMatch d2 xs') =
InexactMatch (max d1 d2) (xs ++ xs')
-matchPlus a@(InexactMatch _ _ ) (NoMatch _ _ ) = a
-matchPlus (NoMatch _ _ ) b@(ExactMatch _ _ ) = b
-matchPlus (NoMatch _ _ ) b@(InexactMatch _ _ ) = b
-matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')
- | d1 > d2 = a
- | d1 < d2 = b
- | otherwise = NoMatch d1 (ms ++ ms')
+matchPlus a@(InexactMatch _ _) (NoMatch _ _) = a
+matchPlus (NoMatch _ _) b@(ExactMatch _ _) = b
+matchPlus (NoMatch _ _) b@(InexactMatch _ _) = b
+matchPlus a@(NoMatch d1 ms) b@(NoMatch d2 ms')
+ | d1 > d2 = a
+ | d1 < d2 = b
+ | otherwise = NoMatch d1 (ms ++ ms')
-- | Combine two matchers. This is similar to 'ambiguousWith' with the
-- difference that an exact match from the left matcher shadows any exact
-- match on the right. Inexact matches are still collected however.
---
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a
-matchPlusShadowing a b = matchPlus a b
+matchPlusShadowing a b = matchPlus a b
instance Functor Match where
- fmap _ (NoMatch d ms) = NoMatch d ms
- fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs)
+ fmap _ (NoMatch d ms) = NoMatch d ms
+ fmap f (ExactMatch d xs) = ExactMatch d (fmap f xs)
fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)
instance Applicative Match where
@@ -872,20 +939,22 @@ instance Applicative Match where
instance Monad Match where
return = pure
- NoMatch d ms >>= _ = NoMatch d ms
- ExactMatch d xs >>= f = addDepth d
- $ foldr matchPlus matchZero (map f xs)
- InexactMatch d xs >>= f = addDepth d . forceInexact
- $ foldr matchPlus matchZero (map f xs)
+ NoMatch d ms >>= _ = NoMatch d ms
+ ExactMatch d xs >>= f =
+ addDepth d $
+ foldr matchPlus matchZero (map f xs)
+ InexactMatch d xs >>= f =
+ addDepth d . forceInexact $
+ foldr matchPlus matchZero (map f xs)
addDepth :: Confidence -> Match a -> Match a
-addDepth d' (NoMatch d msgs) = NoMatch (d'+d) msgs
-addDepth d' (ExactMatch d xs) = ExactMatch (d'+d) xs
-addDepth d' (InexactMatch d xs) = InexactMatch (d'+d) xs
+addDepth d' (NoMatch d msgs) = NoMatch (d' + d) msgs
+addDepth d' (ExactMatch d xs) = ExactMatch (d' + d) xs
+addDepth d' (InexactMatch d xs) = InexactMatch (d' + d) xs
forceInexact :: Match a -> Match a
forceInexact (ExactMatch d ys) = InexactMatch d ys
-forceInexact m = m
+forceInexact m = m
------------------------------
-- Various match primitives
@@ -893,15 +962,15 @@ forceInexact m = m
matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a
matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
-matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got]
+matchErrorNoSuch thing got = NoMatch 0 [MatchErrorNoSuch thing got]
expecting :: String -> String -> Match a -> Match a
expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
-expecting _ _ m = m
+expecting _ _ m = m
orNoSuchThing :: String -> String -> Match a -> Match a
orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got
-orNoSuchThing _ _ m = m
+orNoSuchThing _ _ m = m
increaseConfidence :: Match ()
increaseConfidence = ExactMatch 1 [()]
@@ -910,29 +979,25 @@ increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r
nubMatches :: Eq a => Match a -> Match a
-nubMatches (NoMatch d msgs) = NoMatch d msgs
-nubMatches (ExactMatch d xs) = ExactMatch d (nub xs)
-nubMatches (InexactMatch d xs) = InexactMatch d (nub xs)
+nubMatches (NoMatch d msgs) = NoMatch d msgs
+nubMatches (ExactMatch d xs) = ExactMatch d (nub xs)
+nubMatches (InexactMatch d xs) = InexactMatch d (nub xs)
nubMatchErrors :: Match a -> Match a
-nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)
-nubMatchErrors (ExactMatch d xs) = ExactMatch d xs
-nubMatchErrors (InexactMatch d xs) = InexactMatch d xs
+nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)
+nubMatchErrors (ExactMatch d xs) = ExactMatch d xs
+nubMatchErrors (InexactMatch d xs) = InexactMatch d xs
-- | Lift a list of matches to an exact match.
---
exactMatches, inexactMatches :: [a] -> Match a
-
exactMatches [] = matchZero
exactMatches xs = ExactMatch 0 xs
-
inexactMatches [] = matchZero
inexactMatches xs = InexactMatch 0 xs
tryEach :: [a] -> Match a
tryEach = exactMatches
-
------------------------------
-- Top level match runner
--
@@ -940,21 +1005,19 @@ tryEach = exactMatches
-- | Given a matcher and a key to look up, use the matcher to find all the
-- possible matches. There may be 'None', a single 'Unambiguous' match or
-- you may have an 'Ambiguous' match with several possibilities.
---
findMatch :: Eq b => Match b -> MaybeAmbiguous b
findMatch match =
- case match of
- NoMatch _ msgs -> None (nub msgs)
- ExactMatch _ xs -> checkAmbiguous xs
- InexactMatch _ xs -> checkAmbiguous xs
+ case match of
+ NoMatch _ msgs -> None (nub msgs)
+ ExactMatch _ xs -> checkAmbiguous xs
+ InexactMatch _ xs -> checkAmbiguous xs
where
checkAmbiguous xs = case nub xs of
- [x] -> Unambiguous x
- xs' -> Ambiguous xs'
+ [x] -> Unambiguous x
+ xs' -> Ambiguous xs'
data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous [a]
- deriving Show
-
+ deriving (Show)
------------------------------
-- Basic matchers
@@ -982,24 +1045,23 @@ matchExactly xs =
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
---
-matchInexactly :: (Ord a, Ord a') =>
- (a -> a') ->
- [(a, b)] -> (a -> Match b)
+matchInexactly
+ :: (Ord a, Ord a')
+ => (a -> a')
+ -> [(a, b)]
+ -> (a -> Match b)
matchInexactly cannonicalise xs =
- \x -> case Map.lookup x m of
- Just ys -> exactMatches ys
- Nothing -> case Map.lookup (cannonicalise x) m' of
- Just ys -> inexactMatches ys
- Nothing -> matchZero
+ \x -> case Map.lookup x m of
+ Just ys -> exactMatches ys
+ Nothing -> case Map.lookup (cannonicalise x) m' of
+ Just ys -> inexactMatches ys
+ Nothing -> matchZero
where
- m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]
+ m = Map.fromListWith (++) [(k, [x]) | (k, x) <- xs]
-- the map of canonicalised keys to groups of inexact matches
m' = Map.mapKeysWith (++) cannonicalise m
-
-
------------------------------
-- Utils
--
@@ -1007,60 +1069,75 @@ matchInexactly cannonicalise xs =
caseFold :: String -> String
caseFold = lowercase
-
-- | Check that the given build targets are valid in the current context.
--
-- Also swizzle into a more convenient form.
---
-checkBuildTargets :: Verbosity -> PackageDescription -> LocalBuildInfo -> [BuildTarget]
- -> IO [TargetInfo]
-checkBuildTargets _ pkg_descr lbi [] =
- return (allTargetsInBuildOrder' pkg_descr lbi)
-
+checkBuildTargets
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [BuildTarget]
+ -> IO [TargetInfo]
+checkBuildTargets _ pkg_descr lbi [] =
+ return (allTargetsInBuildOrder' pkg_descr lbi)
checkBuildTargets verbosity pkg_descr lbi targets = do
-
- let (enabled, disabled) =
- partitionEithers
- [ case componentDisabledReason (componentEnabledSpec lbi) comp of
- Nothing -> Left target'
- Just reason -> Right (cname, reason)
- | target <- targets
- , let target'@(cname,_) = swizzleTarget target
- , let comp = getComponent pkg_descr cname ]
-
- case disabled of
- [] -> return ()
- ((cname,reason):_) -> die' verbosity $ formatReason (showComponentName cname) reason
-
- for_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->
- warn verbosity $ "Ignoring '" ++ either prettyShow id t ++ ". The whole "
- ++ showComponentName c ++ " will be processed. (Support for "
- ++ "module and file targets has not been implemented yet.)"
-
- -- Pick out the actual CLBIs for each of these cnames
- enabled' <- for enabled $ \(cname, _) -> do
- case componentNameTargets' pkg_descr lbi cname of
- [] -> error "checkBuildTargets: nothing enabled"
- [target] -> return target
- _targets -> error "checkBuildTargets: multiple copies enabled"
-
- return enabled'
-
+ let (enabled, disabled) =
+ partitionEithers
+ [ case componentDisabledReason (componentEnabledSpec lbi) comp of
+ Nothing -> Left target'
+ Just reason -> Right (cname, reason)
+ | target <- targets
+ , let target'@(cname, _) = swizzleTarget target
+ , let comp = getComponent pkg_descr cname
+ ]
+
+ case disabled of
+ [] -> return ()
+ ((cname, reason) : _) -> die' verbosity $ formatReason (showComponentName cname) reason
+
+ for_ [(c, t) | (c, Just t) <- enabled] $ \(c, t) ->
+ warn verbosity $
+ "Ignoring '"
+ ++ either prettyShow id t
+ ++ ". The whole "
+ ++ showComponentName c
+ ++ " will be processed. (Support for "
+ ++ "module and file targets has not been implemented yet.)"
+
+ -- Pick out the actual CLBIs for each of these cnames
+ enabled' <- for enabled $ \(cname, _) -> do
+ case componentNameTargets' pkg_descr lbi cname of
+ [] -> error "checkBuildTargets: nothing enabled"
+ [target] -> return target
+ _targets -> error "checkBuildTargets: multiple copies enabled"
+
+ return enabled'
where
- swizzleTarget (BuildTargetComponent c) = (c, Nothing)
- swizzleTarget (BuildTargetModule c m) = (c, Just (Left m))
- swizzleTarget (BuildTargetFile c f) = (c, Just (Right f))
+ swizzleTarget (BuildTargetComponent c) = (c, Nothing)
+ swizzleTarget (BuildTargetModule c m) = (c, Just (Left m))
+ swizzleTarget (BuildTargetFile c f) = (c, Just (Right f))
formatReason cn DisabledComponent =
- "Cannot process the " ++ cn ++ " because the component is marked "
- ++ "as disabled in the .cabal file."
+ "Cannot process the "
+ ++ cn
+ ++ " because the component is marked "
+ ++ "as disabled in the .cabal file."
formatReason cn DisabledAllTests =
- "Cannot process the " ++ cn ++ " because test suites are not "
- ++ "enabled. Run configure with the flag --enable-tests"
+ "Cannot process the "
+ ++ cn
+ ++ " because test suites are not "
+ ++ "enabled. Run configure with the flag --enable-tests"
formatReason cn DisabledAllBenchmarks =
- "Cannot process the " ++ cn ++ " because benchmarks are not "
- ++ "enabled. Re-run configure with the flag --enable-benchmarks"
+ "Cannot process the "
+ ++ cn
+ ++ " because benchmarks are not "
+ ++ "enabled. Re-run configure with the flag --enable-benchmarks"
formatReason cn (DisabledAllButOne cn') =
- "Cannot process the " ++ cn ++ " because this package was "
- ++ "configured only to build " ++ cn' ++ ". Re-run configure "
- ++ "with the argument " ++ cn
+ "Cannot process the "
+ ++ cn
+ ++ " because this package was "
+ ++ "configured only to build "
+ ++ cn'
+ ++ ". Re-run configure "
+ ++ "with the argument "
+ ++ cn
diff --git a/Cabal/src/Distribution/Simple/BuildToolDepends.hs b/Cabal/src/Distribution/Simple/BuildToolDepends.hs
index d482bfb65bc47271c9da1f048a0e7957a5db3bbd..486cd2049d9ef76f313e3049ab6613efacf1af59 100644
--- a/Cabal/src/Distribution/Simple/BuildToolDepends.hs
+++ b/Cabal/src/Distribution/Simple/BuildToolDepends.hs
@@ -5,13 +5,13 @@
-- the functions contained to access those fields directly.
module Distribution.Simple.BuildToolDepends where
-import Prelude ()
-import Distribution.Compat.Prelude
+import Distribution.Compat.Prelude
+import Prelude ()
import qualified Data.Map as Map
-import Distribution.Package
-import Distribution.PackageDescription
+import Distribution.Package
+import Distribution.PackageDescription
-- | Desugar a "build-tools" entry into proper a executable dependency if
-- possible.
@@ -26,21 +26,30 @@ import Distribution.PackageDescription
-- the same, but the hard-coding could just as well be per-key.
--
-- The first cases matches first.
-desugarBuildTool :: PackageDescription
- -> LegacyExeDependency
- -> Maybe ExeDependency
+desugarBuildTool
+ :: PackageDescription
+ -> LegacyExeDependency
+ -> Maybe ExeDependency
desugarBuildTool pkg led =
if foundLocal
- then Just $ ExeDependency (packageName pkg) toolName reqVer
- else Map.lookup name whiteMap
+ then Just $ ExeDependency (packageName pkg) toolName reqVer
+ else Map.lookup name whiteMap
where
LegacyExeDependency name reqVer = led
toolName = mkUnqualComponentName name
foundLocal = toolName `elem` map exeName (executables pkg)
- whitelist = [ "hscolour", "haddock", "happy", "alex", "hsc2hs", "c2hs"
- , "cpphs", "greencard", "hspec-discover"
- ]
- whiteMap = Map.fromList $ flip map whitelist $ \n ->
+ whitelist =
+ [ "hscolour"
+ , "haddock"
+ , "happy"
+ , "alex"
+ , "hsc2hs"
+ , "c2hs"
+ , "cpphs"
+ , "greencard"
+ , "hspec-discover"
+ ]
+ whiteMap = Map.fromList $ flip map whitelist $ \n ->
(n, ExeDependency (mkPackageName n) (mkUnqualComponentName n) reqVer)
-- | Get everything from "build-tool-depends", along with entries from
@@ -48,9 +57,10 @@ desugarBuildTool pkg led =
--
-- This should almost always be used instead of just accessing the
-- `buildToolDepends` field directly.
-getAllToolDependencies :: PackageDescription
- -> BuildInfo
- -> [ExeDependency]
+getAllToolDependencies
+ :: PackageDescription
+ -> BuildInfo
+ -> [ExeDependency]
getAllToolDependencies pkg bi =
buildToolDepends bi ++ mapMaybe (desugarBuildTool pkg) (buildTools bi)
@@ -78,14 +88,14 @@ getAllToolDependencies pkg bi =
isInternal :: PackageDescription -> ExeDependency -> Bool
isInternal pkg (ExeDependency n _ _) = n == packageName pkg
-
-- | Get internal "build-tool-depends", along with internal "build-tools"
--
-- This is a tiny function, but used in a number of places. The same
-- restrictions that apply to `isInternal` also apply to this function.
-getAllInternalToolDependencies :: PackageDescription
- -> BuildInfo
- -> [UnqualComponentName]
+getAllInternalToolDependencies
+ :: PackageDescription
+ -> BuildInfo
+ -> [UnqualComponentName]
getAllInternalToolDependencies pkg bi =
[ toolname
| dep@(ExeDependency _ toolname _) <- getAllToolDependencies pkg bi
diff --git a/Cabal/src/Distribution/Simple/CCompiler.hs b/Cabal/src/Distribution/Simple/CCompiler.hs
index 6ed7895a3747b42cf6c427a8f2b8ac97396ff236..1b2c63ceb69e89c825954c361763b1b87c03a5eb 100644
--- a/Cabal/src/Distribution/Simple/CCompiler.hs
+++ b/Cabal/src/Distribution/Simple/CCompiler.hs
@@ -1,14 +1,4 @@
-----------------------------------------------------------------------------
--- |
--- Module : Distribution.Simple.CCompiler
--- Copyright : 2011, Dan Knapp
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- This simple package provides types and functions for interacting with
--- C compilers. Currently it's just a type enumerating extant C-like
--- languages, which we call dialects.
{-
Redistribution and use in source and binary forms, with or without
@@ -39,85 +29,109 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
-module Distribution.Simple.CCompiler (
- CDialect(..),
- cSourceExtensions,
- cDialectFilenameExtension,
- filenameCDialect
+-- |
+-- Module : Distribution.Simple.CCompiler
+-- Copyright : 2011, Dan Knapp
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This simple package provides types and functions for interacting with
+-- C compilers. Currently it's just a type enumerating extant C-like
+-- languages, which we call dialects.
+module Distribution.Simple.CCompiler
+ ( CDialect (..)
+ , cSourceExtensions
+ , cDialectFilenameExtension
+ , filenameCDialect
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import System.FilePath
- ( takeExtension )
-
+ ( takeExtension
+ )
-- | Represents a dialect of C. The Monoid instance expresses backward
-- compatibility, in the sense that 'mappend a b' is the least inclusive
-- dialect which both 'a' and 'b' can be correctly interpreted as.
-data CDialect = C
- | ObjectiveC
- | CPlusPlus
- | ObjectiveCPlusPlus
- deriving (Eq, Show)
+data CDialect
+ = C
+ | ObjectiveC
+ | CPlusPlus
+ | ObjectiveCPlusPlus
+ deriving (Eq, Show)
instance Monoid CDialect where
mempty = C
mappend = (<>)
instance Semigroup CDialect where
- C <> anything = anything
- ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus
- CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus
- _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus
- ObjectiveC <> _ = ObjectiveC
- CPlusPlus <> _ = CPlusPlus
- ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus
+ C <> anything = anything
+ ObjectiveC <> CPlusPlus = ObjectiveCPlusPlus
+ CPlusPlus <> ObjectiveC = ObjectiveCPlusPlus
+ _ <> ObjectiveCPlusPlus = ObjectiveCPlusPlus
+ ObjectiveC <> _ = ObjectiveC
+ CPlusPlus <> _ = CPlusPlus
+ ObjectiveCPlusPlus <> _ = ObjectiveCPlusPlus
-- | A list of all file extensions which are recognized as possibly containing
-- some dialect of C code. Note that this list is only for source files,
-- not for header files.
cSourceExtensions :: [String]
-cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp",
- "cxx", "cpp", "CPP", "c++", "C"]
-
+cSourceExtensions =
+ [ "c"
+ , "i"
+ , "ii"
+ , "m"
+ , "mi"
+ , "mm"
+ , "M"
+ , "mii"
+ , "cc"
+ , "cp"
+ , "cxx"
+ , "cpp"
+ , "CPP"
+ , "c++"
+ , "C"
+ ]
-- | Takes a dialect of C and whether code is intended to be passed through
-- the preprocessor, and returns a filename extension for containing that
-- code.
cDialectFilenameExtension :: CDialect -> Bool -> String
-cDialectFilenameExtension C True = "c"
+cDialectFilenameExtension C True = "c"
cDialectFilenameExtension C False = "i"
-cDialectFilenameExtension ObjectiveC True = "m"
+cDialectFilenameExtension ObjectiveC True = "m"
cDialectFilenameExtension ObjectiveC False = "mi"
-cDialectFilenameExtension CPlusPlus True = "cpp"
-cDialectFilenameExtension CPlusPlus False = "ii"
-cDialectFilenameExtension ObjectiveCPlusPlus True = "mm"
+cDialectFilenameExtension CPlusPlus True = "cpp"
+cDialectFilenameExtension CPlusPlus False = "ii"
+cDialectFilenameExtension ObjectiveCPlusPlus True = "mm"
cDialectFilenameExtension ObjectiveCPlusPlus False = "mii"
-
-- | Infers from a filename's extension the dialect of C which it contains,
-- and whether it is intended to be passed through the preprocessor.
filenameCDialect :: String -> Maybe (CDialect, Bool)
filenameCDialect filename = do
extension <- case takeExtension filename of
- '.':ext -> Just ext
- _ -> Nothing
+ '.' : ext -> Just ext
+ _ -> Nothing
case extension of
- "c" -> return (C, True)
- "i" -> return (C, False)
- "ii" -> return (CPlusPlus, False)
- "m" -> return (ObjectiveC, True)
- "mi" -> return (ObjectiveC, False)
- "mm" -> return (ObjectiveCPlusPlus, True)
- "M" -> return (ObjectiveCPlusPlus, True)
+ "c" -> return (C, True)
+ "i" -> return (C, False)
+ "ii" -> return (CPlusPlus, False)
+ "m" -> return (ObjectiveC, True)
+ "mi" -> return (ObjectiveC, False)
+ "mm" -> return (ObjectiveCPlusPlus, True)
+ "M" -> return (ObjectiveCPlusPlus, True)
"mii" -> return (ObjectiveCPlusPlus, False)
- "cc" -> return (CPlusPlus, True)
- "cp" -> return (CPlusPlus, True)
+ "cc" -> return (CPlusPlus, True)
+ "cp" -> return (CPlusPlus, True)
"cxx" -> return (CPlusPlus, True)
"cpp" -> return (CPlusPlus, True)
"CPP" -> return (CPlusPlus, True)
"c++" -> return (CPlusPlus, True)
- "C" -> return (CPlusPlus, True)
- _ -> Nothing
+ "C" -> return (CPlusPlus, True)
+ _ -> Nothing
diff --git a/Cabal/src/Distribution/Simple/Command.hs b/Cabal/src/Distribution/Simple/Command.hs
index 505d3d0d5845c48c623279346c3f481291bd866b..f4ba63f991c3459202a953cd34462155bd152410 100644
--- a/Cabal/src/Distribution/Simple/Command.hs
+++ b/Cabal/src/Distribution/Simple/Command.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Command
-- Copyright : Duncan Coutts 2007
@@ -18,88 +19,99 @@
-- run. It handles some common stuff automatically, like the @--help@ and
-- command line completion flags. It is designed to allow other tools make
-- derived commands. This feature is used heavily in @cabal-install@.
-
-module Distribution.Simple.Command (
-
- -- * Command interface
- CommandUI(..),
- commandShowOptions,
- CommandParse(..),
- commandParseArgs,
- getNormalCommandDescriptions,
- helpCommandUI,
-
- -- ** Constructing commands
- ShowOrParseArgs(..),
- usageDefault,
- usageAlternatives,
- mkCommandUI,
- hiddenCommand,
-
- -- ** Associating actions with commands
- Command,
- commandAddAction,
- noExtraFlags,
-
- -- ** Building lists of commands
- CommandType(..),
- CommandSpec(..),
- commandFromSpec,
-
- -- ** Running commands
- commandsRun,
-
--- * Option Fields
- OptionField(..), Name,
-
--- ** Constructing Option Fields
- option, multiOption,
-
--- ** Liftings & Projections
- liftOption, liftOptionL,
-
--- * Option Descriptions
- OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder,
-
--- ** OptDescr 'smart' constructors
- MkOptDescr,
- reqArg, reqArg', optArg, optArg', noArg,
- boolOpt, boolOpt', choiceOpt, choiceOptFromEnum
-
+module Distribution.Simple.Command
+ ( -- * Command interface
+ CommandUI (..)
+ , commandShowOptions
+ , CommandParse (..)
+ , commandParseArgs
+ , getNormalCommandDescriptions
+ , helpCommandUI
+
+ -- ** Constructing commands
+ , ShowOrParseArgs (..)
+ , usageDefault
+ , usageAlternatives
+ , mkCommandUI
+ , hiddenCommand
+
+ -- ** Associating actions with commands
+ , Command
+ , commandAddAction
+ , noExtraFlags
+
+ -- ** Building lists of commands
+ , CommandType (..)
+ , CommandSpec (..)
+ , commandFromSpec
+
+ -- ** Running commands
+ , commandsRun
+
+ -- * Option Fields
+ , OptionField (..)
+ , Name
+
+ -- ** Constructing Option Fields
+ , option
+ , multiOption
+
+ -- ** Liftings & Projections
+ , liftOption
+ , liftOptionL
+
+ -- * Option Descriptions
+ , OptDescr (..)
+ , Description
+ , SFlags
+ , LFlags
+ , OptFlags
+ , ArgPlaceHolder
+
+ -- ** OptDescr 'smart' constructors
+ , MkOptDescr
+ , reqArg
+ , reqArg'
+ , optArg
+ , optArg'
+ , noArg
+ , boolOpt
+ , boolOpt'
+ , choiceOpt
+ , choiceOptFromEnum
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import qualified Data.Array as Array
import qualified Data.List as List
+import Distribution.Compat.Lens (ALens', (#~), (^#))
import qualified Distribution.GetOpt as GetOpt
import Distribution.ReadE
import Distribution.Simple.Utils
-import Distribution.Compat.Lens (ALens', (^#), (#~))
-
-
-data CommandUI flags = CommandUI {
- -- | The name of the command as it would be entered on the command line.
- -- For example @\"build\"@.
- commandName :: String,
- -- | A short, one line description of the command to use in help texts.
- commandSynopsis :: String,
- -- | A function that maps a program name to a usage summary for this
- -- command.
- commandUsage :: String -> String,
- -- | Additional explanation of the command to use in help texts.
- commandDescription :: Maybe (String -> String),
- -- | Post-Usage notes and examples in help texts
- commandNotes :: Maybe (String -> String),
- -- | Initial \/ empty flags
- commandDefaultFlags :: flags,
- -- | All the Option fields for this command
- commandOptions :: ShowOrParseArgs -> [OptionField flags]
+
+data CommandUI flags = CommandUI
+ { commandName :: String
+ -- ^ The name of the command as it would be entered on the command line.
+ -- For example @\"build\"@.
+ , commandSynopsis :: String
+ -- ^ A short, one line description of the command to use in help texts.
+ , commandUsage :: String -> String
+ -- ^ A function that maps a program name to a usage summary for this
+ -- command.
+ , commandDescription :: Maybe (String -> String)
+ -- ^ Additional explanation of the command to use in help texts.
+ , commandNotes :: Maybe (String -> String)
+ -- ^ Post-Usage notes and examples in help texts
+ , commandDefaultFlags :: flags
+ -- ^ Initial \/ empty flags
+ , commandOptions :: ShowOrParseArgs -> [OptionField flags]
+ -- ^ All the Option fields for this command
}
data ShowOrParseArgs = ShowArgs | ParseArgs
-type Name = String
+type Name = String
type Description = String
-- | We usually have a data type for storing configuration values, where
@@ -107,30 +119,43 @@ type Description = String
-- the value either via command line flags or a configuration file.
-- An individual OptionField models such a field, and we usually
-- build a list of options associated to a configuration data type.
-data OptionField a = OptionField {
- optionName :: Name,
- optionDescr :: [OptDescr a] }
+data OptionField a = OptionField
+ { optionName :: Name
+ , optionDescr :: [OptDescr a]
+ }
-- | An OptionField takes one or more OptDescrs, describing the command line
-- interface for the field.
-data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder
- (ReadE (a->a)) (a -> [String])
-
- | OptArg Description OptFlags ArgPlaceHolder
- (ReadE (a->a)) (a->a) (a -> [Maybe String])
-
- | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]
-
- | BoolOpt Description OptFlags{-True-} OptFlags{-False-}
- (Bool -> a -> a) (a-> Maybe Bool)
+data OptDescr a
+ = ReqArg
+ Description
+ OptFlags
+ ArgPlaceHolder
+ (ReadE (a -> a))
+ (a -> [String])
+ | OptArg
+ Description
+ OptFlags
+ ArgPlaceHolder
+ (ReadE (a -> a))
+ (a -> a)
+ (a -> [Maybe String])
+ | ChoiceOpt [(Description, OptFlags, a -> a, a -> Bool)]
+ | BoolOpt
+ Description
+ OptFlags {-True-}
+ OptFlags {-False-}
+ (Bool -> a -> a)
+ (a -> Maybe Bool)
-- | Short command line option strings
-type SFlags = [Char]
+type SFlags = [Char]
+
-- | Long command line option strings
-type LFlags = [String]
-type OptFlags = (SFlags,LFlags)
-type ArgPlaceHolder = String
+type LFlags = [String]
+type OptFlags = (SFlags, LFlags)
+type ArgPlaceHolder = String
-- | Create an option taking a single OptDescr.
-- No explicit Name is given for the Option, the name is the first LFlag given.
@@ -142,23 +167,40 @@ type ArgPlaceHolder = String
-- * @get@: Get the current value of the flag.
-- * @set@: Set the value of the flag. Gets the current value of the flag as a
-- parameter.
-option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a
- -> OptionField a
-option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]
-option _ _ _ _ _ _ = error $ "Distribution.command.option: "
- ++ "An OptionField must have at least one LFlag"
+option
+ :: SFlags
+ -> LFlags
+ -> Description
+ -> get
+ -> set
+ -> MkOptDescr get set a
+ -> OptionField a
+option sf lf@(n : _) d get set arg = OptionField n [arg sf lf d get set]
+option _ _ _ _ _ _ =
+ error $
+ "Distribution.command.option: "
+ ++ "An OptionField must have at least one LFlag"
-- | Create an option taking several OptDescrs.
-- You will have to give the flags and description individually to the
-- OptDescr constructor.
-multiOption :: Name -> get -> set
- -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially
- -- applied to flags and description.
- -> OptionField a
+multiOption
+ :: Name
+ -> get
+ -> set
+ -> [get -> set -> OptDescr a]
+ -- ^ MkOptDescr constructors partially
+ -- applied to flags and description.
+ -> OptionField a
multiOption n get set args = OptionField n [arg get set | arg <- args]
-type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set
- -> OptDescr a
+type MkOptDescr get set a =
+ SFlags
+ -> LFlags
+ -> Description
+ -> get
+ -> set
+ -> OptDescr a
-- | Create a string-valued command line interface.
-- Usually called in the context of 'option' or 'multiOption'.
@@ -170,296 +212,391 @@ type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set
-- * @mkflag@: How to parse the argument into the option.
-- * @showflag@: If parsing goes wrong, display a useful error message to
-- the user.
-reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])
- -> MkOptDescr (a -> b) (b -> a -> a) a
+reqArg
+ :: Monoid b
+ => ArgPlaceHolder
+ -> ReadE b
+ -> (b -> [String])
+ -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg ad mkflag showflag sf lf d get set =
- ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)
- (showflag . get)
+ ReqArg
+ d
+ (sf, lf)
+ ad
+ (fmap (\a b -> set (get b `mappend` a) b) mkflag)
+ (showflag . get)
-- | Create a string-valued command line interface with a default value.
-optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])
- -> MkOptDescr (a -> b) (b -> a -> a) a
-optArg ad mkflag def showflag sf lf d get set =
- OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)
- (\b -> set (get b `mappend` def) b)
- (showflag . get)
+optArg
+ :: Monoid b
+ => ArgPlaceHolder
+ -> ReadE b
+ -> b
+ -> (b -> [Maybe String])
+ -> MkOptDescr (a -> b) (b -> a -> a) a
+optArg ad mkflag def showflag sf lf d get set =
+ OptArg
+ d
+ (sf, lf)
+ ad
+ (fmap (\a b -> set (get b `mappend` a) b) mkflag)
+ (\b -> set (get b `mappend` def) b)
+ (showflag . get)
-- | (String -> a) variant of "reqArg"
-reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String])
- -> MkOptDescr (a -> b) (b -> a -> a) a
+reqArg'
+ :: Monoid b
+ => ArgPlaceHolder
+ -> (String -> b)
+ -> (b -> [String])
+ -> MkOptDescr (a -> b) (b -> a -> a) a
reqArg' ad mkflag showflag =
- reqArg ad (succeedReadE mkflag) showflag
+ reqArg ad (succeedReadE mkflag) showflag
-- | (String -> a) variant of "optArg"
-optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)
- -> (b -> [Maybe String])
- -> MkOptDescr (a -> b) (b -> a -> a) a
+optArg'
+ :: Monoid b
+ => ArgPlaceHolder
+ -> (Maybe String -> b)
+ -> (b -> [Maybe String])
+ -> MkOptDescr (a -> b) (b -> a -> a) a
optArg' ad mkflag showflag =
- optArg ad (succeedReadE (mkflag . Just)) def showflag
- where def = mkflag Nothing
-
-noArg :: (Eq b) => b -> MkOptDescr (a -> b) (b -> a -> a) a
-noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d
-
-boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags
- -> MkOptDescr (a -> b) (b -> a -> a) a
-boolOpt g s sfT sfF _sf _lf@(n:_) d get set =
- BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)
-boolOpt _ _ _ _ _ _ _ _ _ = error
- "Distribution.Simple.Setup.boolOpt: unreachable"
-
-boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags
- -> MkOptDescr (a -> b) (b -> a -> a) a
-boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)
+ optArg ad (succeedReadE (mkflag . Just)) def showflag
+ where
+ def = mkflag Nothing
+
+noArg :: Eq b => b -> MkOptDescr (a -> b) (b -> a -> a) a
+noArg flag sf lf d = choiceOpt [(flag, (sf, lf), d)] sf lf d
+
+boolOpt
+ :: (b -> Maybe Bool)
+ -> (Bool -> b)
+ -> SFlags
+ -> SFlags
+ -> MkOptDescr (a -> b) (b -> a -> a) a
+boolOpt g s sfT sfF _sf _lf@(n : _) d get set =
+ BoolOpt d (sfT, ["enable-" ++ n]) (sfF, ["disable-" ++ n]) (set . s) (g . get)
+boolOpt _ _ _ _ _ _ _ _ _ =
+ error
+ "Distribution.Simple.Setup.boolOpt: unreachable"
+
+boolOpt'
+ :: (b -> Maybe Bool)
+ -> (Bool -> b)
+ -> OptFlags
+ -> OptFlags
+ -> MkOptDescr (a -> b) (b -> a -> a) a
+boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set . s) (g . get)
-- | create a Choice option
-choiceOpt :: Eq b => [(b,OptFlags,Description)]
- -> MkOptDescr (a -> b) (b -> a -> a) a
-choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts
- where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]
+choiceOpt
+ :: Eq b
+ => [(b, OptFlags, Description)]
+ -> MkOptDescr (a -> b) (b -> a -> a) a
+choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts
+ where
+ alts = [(d, flags, set alt, (== alt) . get) | (alt, flags, d) <- aa_ff]
-- | create a Choice option out of an enumeration type.
-- As long flags, the Show output is used. As short flags, the first character
-- which does not conflict with a previous one is used.
-choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>
- MkOptDescr (a -> b) (b -> a -> a) a
+choiceOptFromEnum
+ :: (Bounded b, Enum b, Show b, Eq b)
+ => MkOptDescr (a -> b) (b -> a -> a) a
choiceOptFromEnum _sf _lf d get =
- choiceOpt [ (x, (sf, [map toLower $ show x]), d')
- | (x, sf) <- sflags'
- , let d' = d ++ show x]
- _sf _lf d get
- where sflags' = foldl f [] [firstOne..]
- f prev x = let prevflags = concatMap snd prev in
- prev ++ take 1 [(x, [toLower sf])
- | sf <- show x, isAlpha sf
- , toLower sf `notElem` prevflags]
- firstOne = minBound `asTypeOf` get undefined
-
-commandGetOpts :: ShowOrParseArgs -> CommandUI flags
- -> [GetOpt.OptDescr (flags -> flags)]
+ choiceOpt
+ [ (x, (sf, [map toLower $ show x]), d')
+ | (x, sf) <- sflags'
+ , let d' = d ++ show x
+ ]
+ _sf
+ _lf
+ d
+ get
+ where
+ sflags' = foldl f [] [firstOne ..]
+ f prev x =
+ let prevflags = concatMap snd prev
+ in prev
+ ++ take
+ 1
+ [ (x, [toLower sf])
+ | sf <- show x
+ , isAlpha sf
+ , toLower sf `notElem` prevflags
+ ]
+ firstOne = minBound `asTypeOf` get undefined
+
+commandGetOpts
+ :: ShowOrParseArgs
+ -> CommandUI flags
+ -> [GetOpt.OptDescr (flags -> flags)]
commandGetOpts showOrParse command =
- concatMap viewAsGetOpt (commandOptions command showOrParse)
+ concatMap viewAsGetOpt (commandOptions command showOrParse)
viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a -> a)]
viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa
where
- optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) =
- [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]
- optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) =
- [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]
- where set' Nothing = Right def
- set' (Just txt) = runReadE set txt
+ optDescrToGetOpt (ReqArg d (cs, ss) arg_desc set _) =
+ [GetOpt.Option cs ss (GetOpt.ReqArg (runReadE set) arg_desc) d]
+ optDescrToGetOpt (OptArg d (cs, ss) arg_desc set def _) =
+ [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d]
+ where
+ set' Nothing = Right def
+ set' (Just txt) = runReadE set txt
optDescrToGetOpt (ChoiceOpt alts) =
- [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ]
- optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =
- [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d ]
- optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =
- [ GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d ]
- optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) =
- [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
- , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ]
+ [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d, (sf, lf), set, _) <- alts]
+ optDescrToGetOpt (BoolOpt d (sfT, lfT) ([], []) set _) =
+ [GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) d]
+ optDescrToGetOpt (BoolOpt d ([], []) (sfF, lfF) set _) =
+ [GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) d]
+ optDescrToGetOpt (BoolOpt d (sfT, lfT) (sfF, lfF) set _) =
+ [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d)
+ , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d)
+ ]
getCurrentChoice :: OptDescr a -> a -> [String]
getCurrentChoice (ChoiceOpt alts) a =
- [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a]
-
+ [lf | (_, (_sf, lf : _), _, currentChoice) <- alts, currentChoice a]
getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr"
-
liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b
liftOption get' set' opt =
- opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}
+ opt{optionDescr = liftOptDescr get' set' `map` optionDescr opt}
-- | @since 3.4.0.0
liftOptionL :: ALens' b a -> OptionField a -> OptionField b
liftOptionL l = liftOption (^# l) (l #~)
-
liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b
liftOptDescr get' set' (ChoiceOpt opts) =
- ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get'))
- | (d, ff, set, get) <- opts]
-
+ ChoiceOpt
+ [ (d, ff, liftSet get' set' set, (get . get'))
+ | (d, ff, set, get) <- opts
+ ]
liftOptDescr get' set' (OptArg d ff ad set def get) =
- OptArg d ff ad (liftSet get' set' `fmap` set)
- (liftSet get' set' def) (get . get')
-
+ OptArg
+ d
+ ff
+ ad
+ (liftSet get' set' `fmap` set)
+ (liftSet get' set' def)
+ (get . get')
liftOptDescr get' set' (ReqArg d ff ad set get) =
- ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')
-
+ ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')
liftOptDescr get' set' (BoolOpt d ffT ffF set get) =
- BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')
+ BoolOpt d ffT ffF (liftSet get' set' . set) (get . get')
liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b
liftSet get' set' set x = set' (set $ get' x) x
-- | Show flags in the standard long option command line format
commandShowOptions :: CommandUI flags -> flags -> [String]
-commandShowOptions command v = concat
- [ showOptDescr v od | o <- commandOptions command ParseArgs
- , od <- optionDescr o]
+commandShowOptions command v =
+ concat
+ [ showOptDescr v od | o <- commandOptions command ParseArgs, od <- optionDescr o
+ ]
where
- maybePrefix [] = []
- maybePrefix (lOpt:_) = ["--" ++ lOpt]
+ maybePrefix [] = []
+ maybePrefix (lOpt : _) = ["--" ++ lOpt]
showOptDescr :: a -> OptDescr a -> [String]
- showOptDescr x (BoolOpt _ (_,lfTs) (_,lfFs) _ enabled)
- = case enabled x of
- Nothing -> []
- Just True -> maybePrefix lfTs
- Just False -> maybePrefix lfFs
- showOptDescr x c@ChoiceOpt{}
- = ["--" ++ val | val <- getCurrentChoice c x]
- showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag)
- = [ "--"++lf++"="++flag
- | flag <- showflag x ]
- showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag)
- = [ case flag of
- Just s -> "--"++lf++"="++s
- Nothing -> "--"++lf
- | flag <- showflag x ]
- showOptDescr _ _
- = error "Distribution.Simple.Command.showOptDescr: unreachable"
-
+ showOptDescr x (BoolOpt _ (_, lfTs) (_, lfFs) _ enabled) =
+ case enabled x of
+ Nothing -> []
+ Just True -> maybePrefix lfTs
+ Just False -> maybePrefix lfFs
+ showOptDescr x c@ChoiceOpt{} =
+ ["--" ++ val | val <- getCurrentChoice c x]
+ showOptDescr x (ReqArg _ (_ssff, lf : _) _ _ showflag) =
+ [ "--" ++ lf ++ "=" ++ flag
+ | flag <- showflag x
+ ]
+ showOptDescr x (OptArg _ (_ssff, lf : _) _ _ _ showflag) =
+ [ case flag of
+ Just s -> "--" ++ lf ++ "=" ++ s
+ Nothing -> "--" ++ lf
+ | flag <- showflag x
+ ]
+ showOptDescr _ _ =
+ error "Distribution.Simple.Command.showOptDescr: unreachable"
commandListOptions :: CommandUI flags -> [String]
commandListOptions command =
concatMap listOption $
addCommonFlags ShowArgs $ -- This is a slight hack, we don't want
- -- "--list-options" showing up in the
- -- list options output, so use ShowArgs
+ -- "--list-options" showing up in the
+ -- list options output, so use ShowArgs
commandGetOpts ShowArgs command
where
listOption (GetOpt.Option shortNames longNames _ _) =
- [ "-" ++ [name] | name <- shortNames ]
- ++ [ "--" ++ name | name <- longNames ]
+ ["-" ++ [name] | name <- shortNames]
+ ++ ["--" ++ name | name <- longNames]
-- | The help text for this command with descriptions of all the options.
commandHelp :: CommandUI flags -> String -> String
commandHelp command pname =
- commandSynopsis command
- ++ "\n\n"
- ++ commandUsage command pname
- ++ ( case commandDescription command of
- Nothing -> ""
- Just desc -> '\n': desc pname)
- ++ "\n"
- ++ ( if cname == ""
- then "Global flags:"
- else "Flags for " ++ cname ++ ":" )
- ++ ( GetOpt.usageInfo ""
- . addCommonFlags ShowArgs
- $ commandGetOpts ShowArgs command )
- ++ ( case commandNotes command of
- Nothing -> ""
- Just notes -> '\n': notes pname)
- where cname = commandName command
+ commandSynopsis command
+ ++ "\n\n"
+ ++ commandUsage command pname
+ ++ ( case commandDescription command of
+ Nothing -> ""
+ Just desc -> '\n' : desc pname
+ )
+ ++ "\n"
+ ++ ( if cname == ""
+ then "Global flags:"
+ else "Flags for " ++ cname ++ ":"
+ )
+ ++ ( GetOpt.usageInfo ""
+ . addCommonFlags ShowArgs
+ $ commandGetOpts ShowArgs command
+ )
+ ++ ( case commandNotes command of
+ Nothing -> ""
+ Just notes -> '\n' : notes pname
+ )
+ where
+ cname = commandName command
-- | Default "usage" documentation text for commands.
usageDefault :: String -> String -> String
usageDefault name pname =
- "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"
- ++ "Flags for " ++ name ++ ":"
+ "Usage: "
+ ++ pname
+ ++ " "
+ ++ name
+ ++ " [FLAGS]\n\n"
+ ++ "Flags for "
+ ++ name
+ ++ ":"
-- | Create "usage" documentation from a list of parameter
-- configurations.
usageAlternatives :: String -> [String] -> String -> String
-usageAlternatives name strs pname = unlines
- [ start ++ pname ++ " " ++ name ++ " " ++ s
- | let starts = "Usage: " : repeat " or: "
- , (start, s) <- zip starts strs
- ]
+usageAlternatives name strs pname =
+ unlines
+ [ start ++ pname ++ " " ++ name ++ " " ++ s
+ | let starts = "Usage: " : repeat " or: "
+ , (start, s) <- zip starts strs
+ ]
-- | Make a Command from standard 'GetOpt' options.
-mkCommandUI :: String -- ^ name
- -> String -- ^ synopsis
- -> [String] -- ^ usage alternatives
- -> flags -- ^ initial\/empty flags
- -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options
- -> CommandUI flags
-mkCommandUI name synopsis usages flags options = CommandUI
- { commandName = name
- , commandSynopsis = synopsis
- , commandDescription = Nothing
- , commandNotes = Nothing
- , commandUsage = usageAlternatives name usages
- , commandDefaultFlags = flags
- , commandOptions = options
- }
+mkCommandUI
+ :: String
+ -- ^ name
+ -> String
+ -- ^ synopsis
+ -> [String]
+ -- ^ usage alternatives
+ -> flags
+ -- ^ initial\/empty flags
+ -> (ShowOrParseArgs -> [OptionField flags])
+ -- ^ options
+ -> CommandUI flags
+mkCommandUI name synopsis usages flags options =
+ CommandUI
+ { commandName = name
+ , commandSynopsis = synopsis
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = usageAlternatives name usages
+ , commandDefaultFlags = flags
+ , commandOptions = options
+ }
-- | Common flags that apply to every command
data CommonFlag = HelpFlag | ListOptionsFlag
commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag]
commonFlags showOrParseArgs = case showOrParseArgs of
- ShowArgs -> [help]
+ ShowArgs -> [help]
ParseArgs -> [help, list]
- where
- help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag)
- "Show this help text"
+ where
+ help =
+ GetOpt.Option
+ helpShortFlags
+ ["help"]
+ (GetOpt.NoArg HelpFlag)
+ "Show this help text"
helpShortFlags = case showOrParseArgs of
- ShowArgs -> ['h']
+ ShowArgs -> ['h']
ParseArgs -> ['h', '?']
- list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag)
- "Print a list of command line flags"
-
-addCommonFlags :: ShowOrParseArgs
- -> [GetOpt.OptDescr a]
- -> [GetOpt.OptDescr (Either CommonFlag a)]
+ list =
+ GetOpt.Option
+ []
+ ["list-options"]
+ (GetOpt.NoArg ListOptionsFlag)
+ "Print a list of command line flags"
+
+addCommonFlags
+ :: ShowOrParseArgs
+ -> [GetOpt.OptDescr a]
+ -> [GetOpt.OptDescr (Either CommonFlag a)]
addCommonFlags showOrParseArgs options =
- map (fmap Left) (commonFlags showOrParseArgs)
- ++ map (fmap Right) options
+ map (fmap Left) (commonFlags showOrParseArgs)
+ ++ map (fmap Right) options
-- | Parse a bunch of command line arguments
---
-commandParseArgs :: CommandUI flags
- -> Bool -- ^ Is the command a global or subcommand?
- -> [String]
- -> CommandParse (flags -> flags, [String])
+commandParseArgs
+ :: CommandUI flags
+ -> Bool
+ -- ^ Is the command a global or subcommand?
+ -> [String]
+ -> CommandParse (flags -> flags, [String])
commandParseArgs command global args =
- let options = addCommonFlags ParseArgs
- $ commandGetOpts ParseArgs command
- order | global = GetOpt.RequireOrder
- | otherwise = GetOpt.Permute
- in case GetOpt.getOpt' order options args of
- (flags, _, _, _)
- | any listFlag flags -> CommandList (commandListOptions command)
- | any helpFlag flags -> CommandHelp (commandHelp command)
- where listFlag (Left ListOptionsFlag) = True; listFlag _ = False
- helpFlag (Left HelpFlag) = True; helpFlag _ = False
- (flags, opts, opts', [])
- | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')
- | otherwise -> CommandErrors (unrecognised opts')
- (_, _, _, errs) -> CommandErrors errs
-
- where -- Note: It is crucial to use reverse function composition here or to
- -- reverse the flags here as we want to process the flags left to right
- -- but data flow in function composition is right to left.
- accum flags = foldr (flip (.)) id [ f | Right f <- flags ]
- unrecognised opts = [ "unrecognized "
- ++ "'" ++ (commandName command) ++ "'"
- ++ " option `" ++ opt ++ "'\n"
- | opt <- opts ]
- -- For unrecognised global flags we put them in the position just after
- -- the command, if there is one. This gives us a chance to parse them
- -- as sub-command rather than global flags.
- mix [] ys = ys
- mix (x:xs) ys = x:ys++xs
-
-data CommandParse flags = CommandHelp (String -> String)
- | CommandList [String]
- | CommandErrors [String]
- | CommandReadyToGo flags
+ let options =
+ addCommonFlags ParseArgs $
+ commandGetOpts ParseArgs command
+ order
+ | global = GetOpt.RequireOrder
+ | otherwise = GetOpt.Permute
+ in case GetOpt.getOpt' order options args of
+ (flags, _, _, _)
+ | any listFlag flags -> CommandList (commandListOptions command)
+ | any helpFlag flags -> CommandHelp (commandHelp command)
+ where
+ listFlag (Left ListOptionsFlag) = True; listFlag _ = False
+ helpFlag (Left HelpFlag) = True; helpFlag _ = False
+ (flags, opts, opts', [])
+ | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts')
+ | otherwise -> CommandErrors (unrecognised opts')
+ (_, _, _, errs) -> CommandErrors errs
+ where
+ -- Note: It is crucial to use reverse function composition here or to
+ -- reverse the flags here as we want to process the flags left to right
+ -- but data flow in function composition is right to left.
+ accum flags = foldr (flip (.)) id [f | Right f <- flags]
+ unrecognised opts =
+ [ "unrecognized "
+ ++ "'"
+ ++ (commandName command)
+ ++ "'"
+ ++ " option `"
+ ++ opt
+ ++ "'\n"
+ | opt <- opts
+ ]
+ -- For unrecognised global flags we put them in the position just after
+ -- the command, if there is one. This gives us a chance to parse them
+ -- as sub-command rather than global flags.
+ mix [] ys = ys
+ mix (x : xs) ys = x : ys ++ xs
+
+data CommandParse flags
+ = CommandHelp (String -> String)
+ | CommandList [String]
+ | CommandErrors [String]
+ | CommandReadyToGo flags
instance Functor CommandParse where
- fmap _ (CommandHelp help) = CommandHelp help
- fmap _ (CommandList opts) = CommandList opts
- fmap _ (CommandErrors errs) = CommandErrors errs
+ fmap _ (CommandHelp help) = CommandHelp help
+ fmap _ (CommandList opts) = CommandList opts
+ fmap _ (CommandErrors errs) = CommandErrors errs
fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags)
-
data CommandType = NormalCommand | HiddenCommand
-data Command action =
- Command String String ([String] -> CommandParse action) CommandType
+data Command action
+ = Command String String ([String] -> CommandParse action) CommandType
-- | Mark command as hidden. Hidden commands don't show up in the 'progname
-- help' or 'progname --help' output.
@@ -467,132 +604,145 @@ hiddenCommand :: Command action -> Command action
hiddenCommand (Command name synopsys f _cmdType) =
Command name synopsys f HiddenCommand
-commandAddAction :: CommandUI flags
- -> (flags -> [String] -> action)
- -> Command action
+commandAddAction
+ :: CommandUI flags
+ -> (flags -> [String] -> action)
+ -> Command action
commandAddAction command action =
- Command (commandName command)
- (commandSynopsis command)
- (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
- NormalCommand
-
- where applyDefaultArgs mkflags args =
- let flags = mkflags (commandDefaultFlags command)
- in action flags args
-
-commandsRun :: CommandUI a
- -> [Command action]
- -> [String]
- -> CommandParse (a, CommandParse action)
+ Command
+ (commandName command)
+ (commandSynopsis command)
+ (fmap (uncurry applyDefaultArgs) . commandParseArgs command False)
+ NormalCommand
+ where
+ applyDefaultArgs mkflags args =
+ let flags = mkflags (commandDefaultFlags command)
+ in action flags args
+
+commandsRun
+ :: CommandUI a
+ -> [Command action]
+ -> [String]
+ -> CommandParse (a, CommandParse action)
commandsRun globalCommand commands args =
case commandParseArgs globalCommand True args of
- CommandHelp help -> CommandHelp help
- CommandList opts -> CommandList (opts ++ commandNames)
- CommandErrors errs -> CommandErrors errs
+ CommandHelp help -> CommandHelp help
+ CommandList opts -> CommandList (opts ++ commandNames)
+ CommandErrors errs -> CommandErrors errs
CommandReadyToGo (mkflags, args') -> case args' of
- ("help":cmdArgs) -> handleHelpCommand cmdArgs
- (name:cmdArgs) -> case lookupCommand name of
- [Command _ _ action _]
- -> CommandReadyToGo (flags, action cmdArgs)
+ ("help" : cmdArgs) -> handleHelpCommand cmdArgs
+ (name : cmdArgs) -> case lookupCommand name of
+ [Command _ _ action _] ->
+ CommandReadyToGo (flags, action cmdArgs)
_ -> CommandReadyToGo (flags, badCommand name)
- [] -> CommandReadyToGo (flags, noCommand)
- where flags = mkflags (commandDefaultFlags globalCommand)
-
- where
- lookupCommand cname = [ cmd | cmd@(Command cname' _ _ _) <- commands'
- , cname' == cname ]
- noCommand = CommandErrors ["no command given (try --help)\n"]
+ [] -> CommandReadyToGo (flags, noCommand)
+ where
+ flags = mkflags (commandDefaultFlags globalCommand)
+ where
+ lookupCommand cname =
+ [ cmd | cmd@(Command cname' _ _ _) <- commands', cname' == cname
+ ]
+ noCommand = CommandErrors ["no command given (try --help)\n"]
-- Print suggested command if edit distance is < 5
badCommand :: String -> CommandParse a
badCommand cname =
case eDists of
[] -> CommandErrors [unErr]
- (s:_) -> CommandErrors [ unErr
- , "Maybe you meant `" ++ s ++ "`?\n"]
+ (s : _) ->
+ CommandErrors
+ [ unErr
+ , "Maybe you meant `" ++ s ++ "`?\n"
+ ]
where
- eDists = map fst . List.sortBy (comparing snd) $
- [ (cname', dist)
- | (Command cname' _ _ _) <- commands'
- , let dist = editDistance cname' cname
- , dist < 5 ]
+ eDists =
+ map fst . List.sortBy (comparing snd) $
+ [ (cname', dist)
+ | (Command cname' _ _ _) <- commands'
+ , let dist = editDistance cname' cname
+ , dist < 5
+ ]
unErr = "unrecognised command: " ++ cname ++ " (try --help)"
- commands' = commands ++ [commandAddAction helpCommandUI undefined]
- commandNames = [ name | (Command name _ _ NormalCommand) <- commands' ]
+ commands' = commands ++ [commandAddAction helpCommandUI undefined]
+ commandNames = [name | (Command name _ _ NormalCommand) <- commands']
-- A bit of a hack: support "prog help" as a synonym of "prog --help"
-- furthermore, support "prog help command" as "prog command --help"
handleHelpCommand cmdArgs =
case commandParseArgs helpCommandUI True cmdArgs of
- CommandHelp help -> CommandHelp help
- CommandList list -> CommandList (list ++ commandNames)
- CommandErrors _ -> CommandHelp globalHelp
- CommandReadyToGo (_,[]) -> CommandHelp globalHelp
- CommandReadyToGo (_,(name:cmdArgs')) ->
+ CommandHelp help -> CommandHelp help
+ CommandList list -> CommandList (list ++ commandNames)
+ CommandErrors _ -> CommandHelp globalHelp
+ CommandReadyToGo (_, []) -> CommandHelp globalHelp
+ CommandReadyToGo (_, (name : cmdArgs')) ->
case lookupCommand name of
[Command _ _ action _] ->
- case action ("--help":cmdArgs') of
+ case action ("--help" : cmdArgs') of
CommandHelp help -> CommandHelp help
- CommandList _ -> CommandList []
- _ -> CommandHelp globalHelp
- _ -> badCommand name
-
- where globalHelp = commandHelp globalCommand
+ CommandList _ -> CommandList []
+ _ -> CommandHelp globalHelp
+ _ -> badCommand name
+ where
+ globalHelp = commandHelp globalCommand
-- Levenshtein distance, from https://wiki.haskell.org/Edit_distance
-- (Author: JeanPhilippeBernardy, Simple Permissive Licence)
editDistance :: Eq a => [a] -> [a] -> Int
-editDistance xs ys = table Array.! (m,n)
+editDistance xs ys = table Array.! (m, n)
where
- (m,n) = (length xs, length ys)
- x = Array.array (1,m) (zip [1..] xs)
- y = Array.array (1,n) (zip [1..] ys)
+ (m, n) = (length xs, length ys)
+ x = Array.array (1, m) (zip [1 ..] xs)
+ y = Array.array (1, n) (zip [1 ..] ys)
- table :: Array.Array (Int,Int) Int
+ table :: Array.Array (Int, Int) Int
table = Array.array bnds [(ij, dist ij) | ij <- Array.range bnds]
- bnds = ((0,0),(m,n))
-
- dist (0,j) = j
- dist (i,0) = i
- dist (i,j) = minimum
- [ table Array.! (i-1,j) + 1
- , table Array.! (i,j-1) + 1
- , if x Array.! i == y Array.! j
- then table Array.! (i-1,j-1)
- else 1 + table Array.! (i-1,j-1)
- ]
+ bnds = ((0, 0), (m, n))
+
+ dist (0, j) = j
+ dist (i, 0) = i
+ dist (i, j) =
+ minimum
+ [ table Array.! (i - 1, j) + 1
+ , table Array.! (i, j - 1) + 1
+ , if x Array.! i == y Array.! j
+ then table Array.! (i - 1, j - 1)
+ else 1 + table Array.! (i - 1, j - 1)
+ ]
-- | Utility function, many commands do not accept additional flags. This
-- action fails with a helpful error message if the user supplies any extra.
---
noExtraFlags :: [String] -> IO ()
noExtraFlags [] = return ()
noExtraFlags extraFlags =
dieNoVerbosity $ "Unrecognised flags: " ++ intercalate ", " extraFlags
---TODO: eliminate this function and turn it into a variant on commandAddAction
+
+-- TODO: eliminate this function and turn it into a variant on commandAddAction
-- instead like commandAddActionNoArgs that doesn't supply the [String]
-- | Helper function for creating globalCommand description
getNormalCommandDescriptions :: [Command action] -> [(String, String)]
getNormalCommandDescriptions cmds =
[ (name, description)
- | Command name description _ NormalCommand <- cmds ]
+ | Command name description _ NormalCommand <- cmds
+ ]
helpCommandUI :: CommandUI ()
helpCommandUI =
- (mkCommandUI
- "help"
- "Help about commands."
- ["[FLAGS]", "COMMAND [FLAGS]"]
- ()
- (const []))
- {
- commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " help help\n"
- ++ " Oh, apparently you already know this.\n"
- }
+ ( mkCommandUI
+ "help"
+ "Help about commands."
+ ["[FLAGS]", "COMMAND [FLAGS]"]
+ ()
+ (const [])
+ )
+ { commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " help help\n"
+ ++ " Oh, apparently you already know this.\n"
+ }
-- | wraps a @CommandUI@ together with a function that turns it into a @Command@.
-- By hiding the type of flags for the UI allows construction of a list of all UIs at the
diff --git a/Cabal/src/Distribution/Simple/Compiler.hs b/Cabal/src/Distribution/Simple/Compiler.hs
index 71275e52a8a2aa4a151134dd6392fbdf1e2a81f7..074f2f38b5c97591800df549fca309d567966066 100644
--- a/Cabal/src/Distribution/Simple/Compiler.hs
+++ b/Cabal/src/Distribution/Simple/Compiler.hs
@@ -1,7 +1,8 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Compiler
-- Copyright : Isaac Jones 2003-2004
@@ -20,88 +21,89 @@
-- only know about a single global package collection but GHC has a global and
-- per-user one and it lets you create arbitrary other package databases. We do
-- not yet fully support this latter feature.
-
-module Distribution.Simple.Compiler (
- -- * Haskell implementations
- module Distribution.Compiler,
- Compiler(..),
- showCompilerId, showCompilerIdWithAbi,
- compilerFlavor, compilerVersion,
- compilerCompatFlavor,
- compilerCompatVersion,
- compilerInfo,
-
- -- * Support for package databases
- PackageDB(..),
- PackageDBStack,
- registrationPackageDB,
- absolutePackageDBPaths,
- absolutePackageDBPath,
-
- -- * Support for optimisation levels
- OptimisationLevel(..),
- flagToOptimisationLevel,
-
- -- * Support for debug info levels
- DebugInfoLevel(..),
- flagToDebugInfoLevel,
-
- -- * Support for language extensions
- CompilerFlag,
- languageToFlags,
- unsupportedLanguages,
- extensionsToFlags,
- unsupportedExtensions,
- parmakeSupported,
- reexportedModulesSupported,
- renamingPackageFlagsSupported,
- unifiedIPIDRequired,
- packageKeySupported,
- unitIdSupported,
- coverageSupported,
- profilingSupported,
- backpackSupported,
- arResponseFilesSupported,
- arDashLSupported,
- libraryDynDirSupported,
- libraryVisibilitySupported,
-
- -- * Support for profiling detail levels
- ProfDetailLevel(..),
- knownProfDetailLevels,
- flagToProfDetailLevel,
- showProfDetailLevel,
+module Distribution.Simple.Compiler
+ ( -- * Haskell implementations
+ module Distribution.Compiler
+ , Compiler (..)
+ , showCompilerId
+ , showCompilerIdWithAbi
+ , compilerFlavor
+ , compilerVersion
+ , compilerCompatFlavor
+ , compilerCompatVersion
+ , compilerInfo
+
+ -- * Support for package databases
+ , PackageDB (..)
+ , PackageDBStack
+ , registrationPackageDB
+ , absolutePackageDBPaths
+ , absolutePackageDBPath
+
+ -- * Support for optimisation levels
+ , OptimisationLevel (..)
+ , flagToOptimisationLevel
+
+ -- * Support for debug info levels
+ , DebugInfoLevel (..)
+ , flagToDebugInfoLevel
+
+ -- * Support for language extensions
+ , CompilerFlag
+ , languageToFlags
+ , unsupportedLanguages
+ , extensionsToFlags
+ , unsupportedExtensions
+ , parmakeSupported
+ , reexportedModulesSupported
+ , renamingPackageFlagsSupported
+ , unifiedIPIDRequired
+ , packageKeySupported
+ , unitIdSupported
+ , coverageSupported
+ , profilingSupported
+ , backpackSupported
+ , arResponseFilesSupported
+ , arDashLSupported
+ , libraryDynDirSupported
+ , libraryVisibilitySupported
+
+ -- * Support for profiling detail levels
+ , ProfDetailLevel (..)
+ , knownProfDetailLevels
+ , flagToProfDetailLevel
+ , showProfDetailLevel
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Pretty
+import Prelude ()
import Distribution.Compiler
+import Distribution.Simple.Utils
import Distribution.Version
import Language.Haskell.Extension
-import Distribution.Simple.Utils
import qualified Data.Map as Map (lookup)
import System.Directory (canonicalizePath)
-data Compiler = Compiler {
- compilerId :: CompilerId,
- -- ^ Compiler flavour and version.
- compilerAbiTag :: AbiTag,
- -- ^ Tag for distinguishing incompatible ABI's on the same
- -- architecture/os.
- compilerCompat :: [CompilerId],
- -- ^ Other implementations that this compiler claims to be
- -- compatible with.
- compilerLanguages :: [(Language, CompilerFlag)],
- -- ^ Supported language standards.
- compilerExtensions :: [(Extension, Maybe CompilerFlag)],
- -- ^ Supported extensions.
- compilerProperties :: Map String String
- -- ^ A key-value map for properties not covered by the above fields.
- }
- deriving (Eq, Generic, Typeable, Show, Read)
+data Compiler = Compiler
+ { compilerId :: CompilerId
+ -- ^ Compiler flavour and version.
+ , compilerAbiTag :: AbiTag
+ -- ^ Tag for distinguishing incompatible ABI's on the same
+ -- architecture/os.
+ , compilerCompat :: [CompilerId]
+ -- ^ Other implementations that this compiler claims to be
+ -- compatible with.
+ , compilerLanguages :: [(Language, CompilerFlag)]
+ -- ^ Supported language standards.
+ , compilerExtensions :: [(Extension, Maybe CompilerFlag)]
+ -- ^ Supported extensions.
+ , compilerProperties :: Map String String
+ -- ^ A key-value map for properties not covered by the above fields.
+ }
+ deriving (Eq, Generic, Typeable, Show, Read)
instance Binary Compiler
instance Structured Compiler
@@ -111,30 +113,27 @@ showCompilerId = prettyShow . compilerId
showCompilerIdWithAbi :: Compiler -> String
showCompilerIdWithAbi comp =
- prettyShow (compilerId comp) ++
- case compilerAbiTag comp of
- NoAbiTag -> []
- AbiTag xs -> '-':xs
+ prettyShow (compilerId comp)
+ ++ case compilerAbiTag comp of
+ NoAbiTag -> []
+ AbiTag xs -> '-' : xs
-compilerFlavor :: Compiler -> CompilerFlavor
+compilerFlavor :: Compiler -> CompilerFlavor
compilerFlavor = (\(CompilerId f _) -> f) . compilerId
compilerVersion :: Compiler -> Version
compilerVersion = (\(CompilerId _ v) -> v) . compilerId
-
-- | Is this compiler compatible with the compiler flavour we're interested in?
--
-- For example this checks if the compiler is actually GHC or is another
-- compiler that claims to be compatible with some version of GHC, e.g. GHCJS.
--
-- > if compilerCompatFlavor GHC compiler then ... else ...
---
compilerCompatFlavor :: CompilerFlavor -> Compiler -> Bool
compilerCompatFlavor flavor comp =
- flavor == compilerFlavor comp
- || flavor `elem` [ flavor' | CompilerId flavor' _ <- compilerCompat comp ]
-
+ flavor == compilerFlavor comp
+ || flavor `elem` [flavor' | CompilerId flavor' _ <- compilerCompat comp]
-- | Is this compiler compatible with the compiler flavour we're interested in,
-- and if so what version does it claim to be compatible with.
@@ -145,35 +144,38 @@ compilerCompatFlavor flavor comp =
-- > case compilerCompatVersion GHC compiler of
-- > Just (Version (7:_)) -> ...
-- > _ -> ...
---
compilerCompatVersion :: CompilerFlavor -> Compiler -> Maybe Version
compilerCompatVersion flavor comp
| compilerFlavor comp == flavor = Just (compilerVersion comp)
- | otherwise =
- listToMaybe [ v | CompilerId fl v <- compilerCompat comp, fl == flavor ]
+ | otherwise =
+ listToMaybe [v | CompilerId fl v <- compilerCompat comp, fl == flavor]
compilerInfo :: Compiler -> CompilerInfo
-compilerInfo c = CompilerInfo (compilerId c)
- (compilerAbiTag c)
- (Just . compilerCompat $ c)
- (Just . map fst . compilerLanguages $ c)
- (Just . map fst . compilerExtensions $ c)
+compilerInfo c =
+ CompilerInfo
+ (compilerId c)
+ (compilerAbiTag c)
+ (Just . compilerCompat $ c)
+ (Just . map fst . compilerLanguages $ c)
+ (Just . map fst . compilerExtensions $ c)
-- ------------------------------------------------------------
+
-- * Package databases
+
-- ------------------------------------------------------------
--- |Some compilers have a notion of a database of available packages.
--- For some there is just one global db of packages, other compilers
--- support a per-user or an arbitrary db specified at some location in
--- the file system. This can be used to build isolated environments of
--- packages, for example to build a collection of related packages
--- without installing them globally.
---
-data PackageDB = GlobalPackageDB
- | UserPackageDB
- | SpecificPackageDB FilePath
- deriving (Eq, Generic, Ord, Show, Read, Typeable)
+-- | Some compilers have a notion of a database of available packages.
+-- For some there is just one global db of packages, other compilers
+-- support a per-user or an arbitrary db specified at some location in
+-- the file system. This can be used to build isolated environments of
+-- packages, for example to build a collection of related packages
+-- without installing them globally.
+data PackageDB
+ = GlobalPackageDB
+ | UserPackageDB
+ | SpecificPackageDB FilePath
+ deriving (Eq, Generic, Ord, Show, Read, Typeable)
instance Binary PackageDB
instance Structured PackageDB
@@ -193,114 +195,126 @@ instance Structured PackageDB
-- we can use several custom package dbs and the user package db together.
--
-- When it comes to writing, the top most (last) package is used.
---
type PackageDBStack = [PackageDB]
-- | Return the package that we should register into. This is the package db at
-- the top of the stack.
---
registrationPackageDB :: PackageDBStack -> PackageDB
-registrationPackageDB dbs = case safeLast dbs of
+registrationPackageDB dbs = case safeLast dbs of
Nothing -> error "internal error: empty package db set"
- Just p -> p
+ Just p -> p
-- | Make package paths absolute
-
-
absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths = traverse absolutePackageDBPath
absolutePackageDBPath :: PackageDB -> IO PackageDB
-absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
-absolutePackageDBPath UserPackageDB = return UserPackageDB
+absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
+absolutePackageDBPath UserPackageDB = return UserPackageDB
absolutePackageDBPath (SpecificPackageDB db) =
SpecificPackageDB `liftM` canonicalizePath db
-- ------------------------------------------------------------
+
-- * Optimisation levels
+
-- ------------------------------------------------------------
-- | Some compilers support optimising. Some have different levels.
-- For compilers that do not the level is just capped to the level
-- they do support.
---
-data OptimisationLevel = NoOptimisation
- | NormalOptimisation
- | MaximumOptimisation
- deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
+data OptimisationLevel
+ = NoOptimisation
+ | NormalOptimisation
+ | MaximumOptimisation
+ deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
instance Binary OptimisationLevel
instance Structured OptimisationLevel
flagToOptimisationLevel :: Maybe String -> OptimisationLevel
-flagToOptimisationLevel Nothing = NormalOptimisation
+flagToOptimisationLevel Nothing = NormalOptimisation
flagToOptimisationLevel (Just s) = case reads s of
[(i, "")]
| i >= fromEnum (minBound :: OptimisationLevel)
- && i <= fromEnum (maxBound :: OptimisationLevel)
- -> toEnum i
- | otherwise -> error $ "Bad optimisation level: " ++ show i
- ++ ". Valid values are 0..2"
- _ -> error $ "Can't parse optimisation level " ++ s
+ && i <= fromEnum (maxBound :: OptimisationLevel) ->
+ toEnum i
+ | otherwise ->
+ error $
+ "Bad optimisation level: "
+ ++ show i
+ ++ ". Valid values are 0..2"
+ _ -> error $ "Can't parse optimisation level " ++ s
-- ------------------------------------------------------------
+
-- * Debug info levels
+
-- ------------------------------------------------------------
-- | Some compilers support emitting debug info. Some have different
-- levels. For compilers that do not the level is just capped to the
-- level they do support.
---
-data DebugInfoLevel = NoDebugInfo
- | MinimalDebugInfo
- | NormalDebugInfo
- | MaximalDebugInfo
- deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
+data DebugInfoLevel
+ = NoDebugInfo
+ | MinimalDebugInfo
+ | NormalDebugInfo
+ | MaximalDebugInfo
+ deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
instance Binary DebugInfoLevel
instance Structured DebugInfoLevel
flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
-flagToDebugInfoLevel Nothing = NormalDebugInfo
+flagToDebugInfoLevel Nothing = NormalDebugInfo
flagToDebugInfoLevel (Just s) = case reads s of
[(i, "")]
| i >= fromEnum (minBound :: DebugInfoLevel)
- && i <= fromEnum (maxBound :: DebugInfoLevel)
- -> toEnum i
- | otherwise -> error $ "Bad debug info level: " ++ show i
- ++ ". Valid values are 0..3"
- _ -> error $ "Can't parse debug info level " ++ s
+ && i <= fromEnum (maxBound :: DebugInfoLevel) ->
+ toEnum i
+ | otherwise ->
+ error $
+ "Bad debug info level: "
+ ++ show i
+ ++ ". Valid values are 0..3"
+ _ -> error $ "Can't parse debug info level " ++ s
-- ------------------------------------------------------------
+
-- * Languages and Extensions
+
-- ------------------------------------------------------------
unsupportedLanguages :: Compiler -> [Language] -> [Language]
unsupportedLanguages comp langs =
- [ lang | lang <- langs
- , isNothing (languageToFlag comp lang) ]
+ [ lang | lang <- langs, isNothing (languageToFlag comp lang)
+ ]
languageToFlags :: Compiler -> Maybe Language -> [CompilerFlag]
-languageToFlags comp = filter (not . null)
- . catMaybes . map (languageToFlag comp)
- . maybe [Haskell98] (\x->[x])
+languageToFlags comp =
+ filter (not . null)
+ . catMaybes
+ . map (languageToFlag comp)
+ . maybe [Haskell98] (\x -> [x])
languageToFlag :: Compiler -> Language -> Maybe CompilerFlag
languageToFlag comp ext = lookup ext (compilerLanguages comp)
-
--- |For the given compiler, return the extensions it does not support.
+-- | For the given compiler, return the extensions it does not support.
unsupportedExtensions :: Compiler -> [Extension] -> [Extension]
unsupportedExtensions comp exts =
- [ ext | ext <- exts
- , isNothing (extensionToFlag' comp ext) ]
+ [ ext | ext <- exts, isNothing (extensionToFlag' comp ext)
+ ]
type CompilerFlag = String
--- |For the given compiler, return the flags for the supported extensions.
+-- | For the given compiler, return the flags for the supported extensions.
extensionsToFlags :: Compiler -> [Extension] -> [CompilerFlag]
-extensionsToFlags comp = nub . filter (not . null)
- . catMaybes . map (extensionToFlag comp)
+extensionsToFlags comp =
+ nub
+ . filter (not . null)
+ . catMaybes
+ . map (extensionToFlag comp)
-- | Looks up the flag for a given extension, for a given compiler.
-- Ignores the subtlety of extensions which lack associated flags.
@@ -329,8 +343,9 @@ reexportedModulesSupported = ghcSupported "Support reexported-modules"
-- | Does this compiler support thinning/renaming on package flags?
renamingPackageFlagsSupported :: Compiler -> Bool
-renamingPackageFlagsSupported = ghcSupported
- "Support thinning and renaming package flags"
+renamingPackageFlagsSupported =
+ ghcSupported
+ "Support thinning and renaming package flags"
-- | Does this compiler have unified IPIDs (so no package keys)
unifiedIPIDRequired :: Compiler -> Bool
@@ -353,13 +368,14 @@ backpackSupported = ghcSupported "Support Backpack"
libraryDynDirSupported :: Compiler -> Bool
libraryDynDirSupported comp = case compilerFlavor comp of
GHC ->
- -- Not just v >= mkVersion [8,0,1,20161022], as there
- -- are many GHC 8.1 nightlies which don't support this.
- ((v >= mkVersion [8,0,1,20161022] && v < mkVersion [8,1]) ||
- v >= mkVersion [8,1,20161021])
- _ -> False
- where
- v = compilerVersion comp
+ -- Not just v >= mkVersion [8,0,1,20161022], as there
+ -- are many GHC 8.1 nightlies which don't support this.
+ ( (v >= mkVersion [8, 0, 1, 20161022] && v < mkVersion [8, 1])
+ || v >= mkVersion [8, 1, 20161021]
+ )
+ _ -> False
+ where
+ v = compilerVersion comp
-- | Does this compiler's "ar" command supports response file
-- arguments (i.e. @file-style arguments).
@@ -376,41 +392,44 @@ arDashLSupported = ghcSupported "ar supports -L"
coverageSupported :: Compiler -> Bool
coverageSupported comp =
case compilerFlavor comp of
- GHC -> True
+ GHC -> True
GHCJS -> True
- _ -> False
+ _ -> False
-- | Does this compiler support profiling?
profilingSupported :: Compiler -> Bool
profilingSupported comp =
case compilerFlavor comp of
- GHC -> True
+ GHC -> True
GHCJS -> True
- _ -> False
+ _ -> False
-- | Does this compiler support a package database entry with:
-- "visibility"?
libraryVisibilitySupported :: Compiler -> Bool
libraryVisibilitySupported comp = case compilerFlavor comp of
- GHC -> v >= mkVersion [8,8]
- _ -> False
- where
- v = compilerVersion comp
+ GHC -> v >= mkVersion [8, 8]
+ _ -> False
+ where
+ v = compilerVersion comp
-- | Utility function for GHC only features
ghcSupported :: String -> Compiler -> Bool
ghcSupported key comp =
case compilerFlavor comp of
- GHC -> checkProp
+ GHC -> checkProp
GHCJS -> checkProp
- _ -> False
- where checkProp =
- case Map.lookup key (compilerProperties comp) of
- Just "YES" -> True
- _ -> False
+ _ -> False
+ where
+ checkProp =
+ case Map.lookup key (compilerProperties comp) of
+ Just "YES" -> True
+ _ -> False
-- ------------------------------------------------------------
+
-- * Profiling detail level
+
-- ------------------------------------------------------------
-- | Some compilers (notably GHC) support profiling and can instrument
@@ -419,45 +438,47 @@ ghcSupported key comp =
-- For compilers that do not support this notion or the particular detail
-- levels, this is either ignored or just capped to some similar level
-- they do support.
---
-data ProfDetailLevel = ProfDetailNone
- | ProfDetailDefault
- | ProfDetailExportedFunctions
- | ProfDetailToplevelFunctions
- | ProfDetailAllFunctions
- | ProfDetailTopLate
- | ProfDetailOther String
- deriving (Eq, Generic, Read, Show, Typeable)
+data ProfDetailLevel
+ = ProfDetailNone
+ | ProfDetailDefault
+ | ProfDetailExportedFunctions
+ | ProfDetailToplevelFunctions
+ | ProfDetailAllFunctions
+ | ProfDetailTopLate
+ | ProfDetailOther String
+ deriving (Eq, Generic, Read, Show, Typeable)
instance Binary ProfDetailLevel
instance Structured ProfDetailLevel
flagToProfDetailLevel :: String -> ProfDetailLevel
flagToProfDetailLevel "" = ProfDetailDefault
-flagToProfDetailLevel s =
- case lookup (lowercase s)
- [ (name, value)
- | (primary, aliases, value) <- knownProfDetailLevels
- , name <- primary : aliases ]
- of Just value -> value
- Nothing -> ProfDetailOther s
+flagToProfDetailLevel s =
+ case lookup
+ (lowercase s)
+ [ (name, value)
+ | (primary, aliases, value) <- knownProfDetailLevels
+ , name <- primary : aliases
+ ] of
+ Just value -> value
+ Nothing -> ProfDetailOther s
knownProfDetailLevels :: [(String, [String], ProfDetailLevel)]
knownProfDetailLevels =
- [ ("default", [], ProfDetailDefault)
- , ("none", [], ProfDetailNone)
- , ("exported-functions", ["exported"], ProfDetailExportedFunctions)
+ [ ("default", [], ProfDetailDefault)
+ , ("none", [], ProfDetailNone)
+ , ("exported-functions", ["exported"], ProfDetailExportedFunctions)
, ("toplevel-functions", ["toplevel", "top"], ProfDetailToplevelFunctions)
- , ("all-functions", ["all"], ProfDetailAllFunctions)
- , ("late-toplevel", ["late"], ProfDetailTopLate)
+ , ("all-functions", ["all"], ProfDetailAllFunctions)
+ , ("late-toplevel", ["late"], ProfDetailTopLate)
]
showProfDetailLevel :: ProfDetailLevel -> String
showProfDetailLevel dl = case dl of
- ProfDetailNone -> "none"
- ProfDetailDefault -> "default"
- ProfDetailExportedFunctions -> "exported-functions"
- ProfDetailToplevelFunctions -> "toplevel-functions"
- ProfDetailAllFunctions -> "all-functions"
- ProfDetailTopLate -> "late-toplevel"
- ProfDetailOther other -> other
+ ProfDetailNone -> "none"
+ ProfDetailDefault -> "default"
+ ProfDetailExportedFunctions -> "exported-functions"
+ ProfDetailToplevelFunctions -> "toplevel-functions"
+ ProfDetailAllFunctions -> "all-functions"
+ ProfDetailTopLate -> "late-toplevel"
+ ProfDetailOther other -> other
diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs
index 03a1d45973d848ebcd5e0731f76f0a749a157da6..1224661a36e6bc9e85c593fc3c8cda29f460903f 100644
--- a/Cabal/src/Distribution/Simple/Configure.hs
+++ b/Cabal/src/Distribution/Simple/Configure.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Configure
-- Copyright : Isaac Jones 2003-2005
@@ -27,7 +28,6 @@
-- it out to the @dist\/setup-config@ file. It also displays various details to
-- the user, the amount of information displayed depending on the verbosity
-- level.
-
module Distribution.Simple.Configure
( configure
, writePersistBuildConfig
@@ -36,7 +36,8 @@ module Distribution.Simple.Configure
, checkPersistBuildConfigOutdated
, tryGetPersistBuildConfig
, maybeGetPersistBuildConfig
- , findDistPref, findDistPrefOrDefault
+ , findDistPref
+ , findDistPrefOrDefault
, getInternalLibraries
, computeComponentId
, computeCompatPackageKey
@@ -44,203 +45,258 @@ module Distribution.Simple.Configure
, getInstalledPackages
, getInstalledPackagesMonitorFiles
, getPackageDBContents
- , configCompilerEx, configCompilerAuxEx
+ , configCompilerEx
+ , configCompilerAuxEx
, computeEffectiveProfiling
, ccLdOptionsBuildInfo
, checkForeignDeps
, interpretPackageDbFlags
- , ConfigStateFileError(..)
+ , ConfigStateFileError (..)
, tryGetConfigStateFile
- , platformDefines,
+ , platformDefines
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
+import Distribution.Backpack.Configure
+import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour)
+import Distribution.Backpack.DescribeUnitId
+import Distribution.Backpack.Id
+import Distribution.Backpack.PreExistingComponent
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compat.Stack
import Distribution.Compiler
-import Distribution.Types.IncludeRenaming
-import Distribution.Utils.NubList
-import Distribution.Simple.Compiler
-import Distribution.Simple.PreProcess
-import Distribution.Package
-import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.InstalledPackageInfo as IPI
+import Distribution.Package
import Distribution.PackageDescription
-import Distribution.PackageDescription.PrettyPrint
-import Distribution.PackageDescription.Configuration
import Distribution.PackageDescription.Check hiding (doesFileExist)
+import Distribution.PackageDescription.Configuration
+import Distribution.PackageDescription.PrettyPrint
+import Distribution.Simple.BuildTarget
import Distribution.Simple.BuildToolDepends
+import Distribution.Simple.Compiler
+import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.PreProcess
import Distribution.Simple.Program
-import Distribution.Simple.Setup.Config as Setup
import Distribution.Simple.Setup.Common as Setup
-import Distribution.Simple.BuildTarget
-import Distribution.Simple.LocalBuildInfo
-import Distribution.Types.PackageVersionConstraint
-import Distribution.Types.LocalBuildInfo
-import Distribution.Types.ComponentRequestedSpec
-import Distribution.Types.GivenComponent
+import Distribution.Simple.Setup.Config as Setup
import Distribution.Simple.Utils
import Distribution.System
-import Distribution.Version
-import Distribution.Verbosity
-import qualified Distribution.Compat.Graph as Graph
-import Distribution.Compat.Stack
-import Distribution.Backpack.Configure
-import Distribution.Backpack.DescribeUnitId
-import Distribution.Backpack.PreExistingComponent
-import Distribution.Backpack.ConfiguredComponent (newPackageDepsBehaviour)
-import Distribution.Backpack.Id
+import Distribution.Types.ComponentRequestedSpec
+import Distribution.Types.GivenComponent
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.PackageVersionConstraint
import Distribution.Utils.LogProgress
+import Distribution.Utils.NubList
+import Distribution.Verbosity
+import Distribution.Version
-import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
-import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
+import qualified Distribution.Simple.UHC as UHC
import Control.Exception
- ( try )
-import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode )
-import Distribution.Compat.Directory ( listDirectory )
-import Data.ByteString.Lazy ( ByteString )
-import qualified Data.ByteString as BS
+ ( try
+ )
+import qualified Data.ByteString as BS
+import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.List
- ( (\\), stripPrefix, intersect)
+ ( intersect
+ , stripPrefix
+ , (\\)
+ )
import qualified Data.List.NonEmpty as NEL
import qualified Data.Map as Map
+import Distribution.Compat.Directory
+ ( doesPathExist
+ , listDirectory
+ )
+import Distribution.Compat.Environment (lookupEnv)
+import Distribution.Parsec
+ ( simpleParsec
+ )
+import Distribution.Pretty
+ ( defaultStyle
+ , pretty
+ , prettyShow
+ )
+import Distribution.Utils.Structured (structuredDecodeOrFailIO, structuredEncode)
import System.Directory
- ( canonicalizePath, createDirectoryIfMissing, doesFileExist
- , getTemporaryDirectory, removeFile)
+ ( canonicalizePath
+ , createDirectoryIfMissing
+ , doesFileExist
+ , getTemporaryDirectory
+ , removeFile
+ )
import System.FilePath
- ( (</>), isAbsolute, takeDirectory )
-import Distribution.Compat.Directory
- ( doesPathExist )
-import qualified System.Info
- ( compilerName, compilerVersion )
+ ( isAbsolute
+ , takeDirectory
+ , (</>)
+ )
import System.IO
- ( hPutStrLn, hClose )
-import Distribution.Pretty
- ( pretty, defaultStyle, prettyShow )
-import Distribution.Parsec
- ( simpleParsec )
+ ( hClose
+ , hPutStrLn
+ )
+import qualified System.Info
+ ( compilerName
+ , compilerVersion
+ )
import Text.PrettyPrint
- ( Doc, ($+$), char, comma, hsep, nest
- , punctuate, quotes, render, renderStyle, sep, text )
-import Distribution.Compat.Environment ( lookupEnv )
+ ( Doc
+ , char
+ , comma
+ , hsep
+ , nest
+ , punctuate
+ , quotes
+ , render
+ , renderStyle
+ , sep
+ , text
+ , ($+$)
+ )
import qualified Data.Maybe as M
import qualified Data.Set as Set
import qualified Distribution.Compat.NonEmptySet as NES
-
type UseExternalInternalDeps = Bool
-- | The errors that can be thrown when reading the @setup-config@ file.
data ConfigStateFileError
- = ConfigStateFileNoHeader -- ^ No header found.
- | ConfigStateFileBadHeader -- ^ Incorrect header.
- | ConfigStateFileNoParse -- ^ Cannot parse file contents.
- | ConfigStateFileMissing -- ^ No file!
- | ConfigStateFileBadVersion PackageIdentifier PackageIdentifier
- (Either ConfigStateFileError LocalBuildInfo) -- ^ Mismatched version.
+ = -- | No header found.
+ ConfigStateFileNoHeader
+ | -- | Incorrect header.
+ ConfigStateFileBadHeader
+ | -- | Cannot parse file contents.
+ ConfigStateFileNoParse
+ | -- | No file!
+ ConfigStateFileMissing
+ | -- | Mismatched version.
+ ConfigStateFileBadVersion
+ PackageIdentifier
+ PackageIdentifier
+ (Either ConfigStateFileError LocalBuildInfo)
deriving (Typeable)
-- | Format a 'ConfigStateFileError' as a user-facing error message.
dispConfigStateFileError :: ConfigStateFileError -> Doc
dispConfigStateFileError ConfigStateFileNoHeader =
- text "Saved package config file header is missing."
+ text "Saved package config file header is missing."
<+> text "Re-run the 'configure' command."
dispConfigStateFileError ConfigStateFileBadHeader =
- text "Saved package config file header is corrupt."
+ text "Saved package config file header is corrupt."
<+> text "Re-run the 'configure' command."
dispConfigStateFileError ConfigStateFileNoParse =
- text "Saved package config file is corrupt."
+ text "Saved package config file is corrupt."
<+> text "Re-run the 'configure' command."
dispConfigStateFileError ConfigStateFileMissing =
- text "Run the 'configure' command first."
+ text "Run the 'configure' command first."
dispConfigStateFileError (ConfigStateFileBadVersion oldCabal oldCompiler _) =
- text "Saved package config file is outdated:"
- $+$ badCabal $+$ badCompiler
+ text "Saved package config file is outdated:"
+ $+$ badCabal
+ $+$ badCompiler
$+$ text "Re-run the 'configure' command."
- where
- badCabal =
- text "• the Cabal version changed from"
- <+> pretty oldCabal <+> "to" <+> pretty currentCabalId
- badCompiler
- | oldCompiler == currentCompilerId = mempty
- | otherwise =
- text "• the compiler changed from"
- <+> pretty oldCompiler <+> "to" <+> pretty currentCompilerId
+ where
+ badCabal =
+ text "• the Cabal version changed from"
+ <+> pretty oldCabal
+ <+> "to"
+ <+> pretty currentCabalId
+ badCompiler
+ | oldCompiler == currentCompilerId = mempty
+ | otherwise =
+ text "• the compiler changed from"
+ <+> pretty oldCompiler
+ <+> "to"
+ <+> pretty currentCompilerId
instance Show ConfigStateFileError where
- show = renderStyle defaultStyle . dispConfigStateFileError
+ show = renderStyle defaultStyle . dispConfigStateFileError
instance Exception ConfigStateFileError
-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
-- missing, if the file cannot be read, or if the file was created by an older
-- version of Cabal.
-getConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.
- -> IO LocalBuildInfo
+getConfigStateFile
+ :: FilePath
+ -- ^ The file path of the @setup-config@ file.
+ -> IO LocalBuildInfo
getConfigStateFile filename = do
- exists <- doesFileExist filename
- unless exists $ throwIO ConfigStateFileMissing
- -- Read the config file into a strict ByteString to avoid problems with
- -- lazy I/O, then convert to lazy because the binary package needs that.
- contents <- BS.readFile filename
- let (header, body) = BLC8.span (/='\n') (BLC8.fromChunks [contents])
-
- (cabalId, compId) <- parseHeader header
-
- let getStoredValue = do
- result <- structuredDecodeOrFailIO (BLC8.tail body)
- case result of
- Left _ -> throwIO ConfigStateFileNoParse
- Right x -> return x
- deferErrorIfBadVersion act
- | cabalId /= currentCabalId = do
- eResult <- try act
- throwIO $ ConfigStateFileBadVersion cabalId compId eResult
- | otherwise = act
- deferErrorIfBadVersion getStoredValue
+ exists <- doesFileExist filename
+ unless exists $ throwIO ConfigStateFileMissing
+ -- Read the config file into a strict ByteString to avoid problems with
+ -- lazy I/O, then convert to lazy because the binary package needs that.
+ contents <- BS.readFile filename
+ let (header, body) = BLC8.span (/= '\n') (BLC8.fromChunks [contents])
+
+ (cabalId, compId) <- parseHeader header
+
+ let getStoredValue = do
+ result <- structuredDecodeOrFailIO (BLC8.tail body)
+ case result of
+ Left _ -> throwIO ConfigStateFileNoParse
+ Right x -> return x
+ deferErrorIfBadVersion act
+ | cabalId /= currentCabalId = do
+ eResult <- try act
+ throwIO $ ConfigStateFileBadVersion cabalId compId eResult
+ | otherwise = act
+ deferErrorIfBadVersion getStoredValue
where
_ = callStack -- TODO: attach call stack to exception
-- | Read the 'localBuildInfoFile', returning either an error or the local build
-- info.
-tryGetConfigStateFile :: FilePath -- ^ The file path of the @setup-config@ file.
- -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetConfigStateFile
+ :: FilePath
+ -- ^ The file path of the @setup-config@ file.
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetConfigStateFile = try . getConfigStateFile
-- | Try to read the 'localBuildInfoFile'.
-tryGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
- -> IO (Either ConfigStateFileError LocalBuildInfo)
+tryGetPersistBuildConfig
+ :: FilePath
+ -- ^ The @dist@ directory path.
+ -> IO (Either ConfigStateFileError LocalBuildInfo)
tryGetPersistBuildConfig = try . getPersistBuildConfig
-- | Read the 'localBuildInfoFile'. Throw an exception if the file is
-- missing, if the file cannot be read, or if the file was created by an older
-- version of Cabal.
-getPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
- -> IO LocalBuildInfo
+getPersistBuildConfig
+ :: FilePath
+ -- ^ The @dist@ directory path.
+ -> IO LocalBuildInfo
getPersistBuildConfig = getConfigStateFile . localBuildInfoFile
-- | Try to read the 'localBuildInfoFile'.
-maybeGetPersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
- -> IO (Maybe LocalBuildInfo)
+maybeGetPersistBuildConfig
+ :: FilePath
+ -- ^ The @dist@ directory path.
+ -> IO (Maybe LocalBuildInfo)
maybeGetPersistBuildConfig =
- liftM (either (const Nothing) Just) . tryGetPersistBuildConfig
+ liftM (either (const Nothing) Just) . tryGetPersistBuildConfig
-- | After running configure, output the 'LocalBuildInfo' to the
-- 'localBuildInfoFile'.
-writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
- -> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.
- -> IO ()
+writePersistBuildConfig
+ :: FilePath
+ -- ^ The @dist@ directory path.
+ -> LocalBuildInfo
+ -- ^ The 'LocalBuildInfo' to write.
+ -> IO ()
writePersistBuildConfig distPref lbi = do
- createDirectoryIfMissing False distPref
- writeFileAtomic (localBuildInfoFile distPref) $
- BLC8.unlines [showHeader pkgId, structuredEncode lbi]
+ createDirectoryIfMissing False distPref
+ writeFileAtomic (localBuildInfoFile distPref) $
+ BLC8.unlines [showHeader pkgId, structuredEncode lbi]
where
pkgId = localPackage lbi
@@ -250,30 +306,50 @@ currentCabalId = PackageIdentifier (mkPackageName "Cabal") cabalVersion
-- | Identifier of the current compiler package.
currentCompilerId :: PackageIdentifier
-currentCompilerId = PackageIdentifier (mkPackageName System.Info.compilerName)
- (mkVersion' System.Info.compilerVersion)
+currentCompilerId =
+ PackageIdentifier
+ (mkPackageName System.Info.compilerName)
+ (mkVersion' System.Info.compilerVersion)
-- | Parse the @setup-config@ file header, returning the package identifiers
-- for Cabal and the compiler.
-parseHeader :: ByteString -- ^ The file contents.
- -> IO (PackageIdentifier, PackageIdentifier)
+parseHeader
+ :: ByteString
+ -- ^ The file contents.
+ -> IO (PackageIdentifier, PackageIdentifier)
parseHeader header = case BLC8.words header of
- ["Saved", "package", "config", "for", pkgId, "written", "by", cabalId,
- "using", compId] ->
+ [ "Saved"
+ , "package"
+ , "config"
+ , "for"
+ , pkgId
+ , "written"
+ , "by"
+ , cabalId
+ , "using"
+ , compId
+ ] ->
maybe (throwIO ConfigStateFileBadHeader) return $ do
- _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier
- cabalId' <- simpleParsec (BLC8.unpack cabalId)
- compId' <- simpleParsec (BLC8.unpack compId)
- return (cabalId', compId')
+ _ <- simpleParsec (fromUTF8LBS pkgId) :: Maybe PackageIdentifier
+ cabalId' <- simpleParsec (BLC8.unpack cabalId)
+ compId' <- simpleParsec (BLC8.unpack compId)
+ return (cabalId', compId')
_ -> throwIO ConfigStateFileNoHeader
-- | Generate the @setup-config@ file header.
-showHeader :: PackageIdentifier -- ^ The processed package.
- -> ByteString
-showHeader pkgId = BLC8.unwords
- [ "Saved", "package", "config", "for"
+showHeader
+ :: PackageIdentifier
+ -- ^ The processed package.
+ -> ByteString
+showHeader pkgId =
+ BLC8.unwords
+ [ "Saved"
+ , "package"
+ , "config"
+ , "for"
, toUTF8LBS $ prettyShow pkgId
- , "written", "by"
+ , "written"
+ , "by"
, BLC8.pack $ prettyShow currentCabalId
, "using"
, BLC8.pack $ prettyShow currentCompilerId
@@ -286,23 +362,30 @@ checkPersistBuildConfigOutdated distPref pkg_descr_file =
pkg_descr_file `moreRecentFile` localBuildInfoFile distPref
-- | Get the path of @dist\/setup-config@.
-localBuildInfoFile :: FilePath -- ^ The @dist@ directory path.
- -> FilePath
+localBuildInfoFile
+ :: FilePath
+ -- ^ The @dist@ directory path.
+ -> FilePath
localBuildInfoFile distPref = distPref </> "setup-config"
-- -----------------------------------------------------------------------------
+
-- * Configuration
+
-- -----------------------------------------------------------------------------
-- | Return the \"dist/\" prefix, or the default prefix. The prefix is taken
-- from (in order of highest to lowest preference) the override prefix, the
-- \"CABAL_BUILDDIR\" environment variable, or the default prefix.
-findDistPref :: FilePath -- ^ default \"dist\" prefix
- -> Setup.Flag FilePath -- ^ override \"dist\" prefix
- -> IO FilePath
+findDistPref
+ :: FilePath
+ -- ^ default \"dist\" prefix
+ -> Setup.Flag FilePath
+ -- ^ override \"dist\" prefix
+ -> IO FilePath
findDistPref defDistPref overrideDistPref = do
- envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")
- return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)
+ envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")
+ return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)
where
parseEnvDistPref env =
case env of
@@ -315,376 +398,441 @@ findDistPref defDistPref overrideDistPref = do
-- this function to resolve a @*DistPref@ flag whenever it is not known to be
-- set. (The @*DistPref@ flags are always set to a definite value before
-- invoking 'UserHooks'.)
-findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix
- -> IO FilePath
+findDistPrefOrDefault
+ :: Setup.Flag FilePath
+ -- ^ override \"dist\" prefix
+ -> IO FilePath
findDistPrefOrDefault = findDistPref defaultDistPref
--- |Perform the \"@.\/setup configure@\" action.
--- Returns the @.setup-config@ file.
-configure :: (GenericPackageDescription, HookedBuildInfo)
- -> ConfigFlags -> IO LocalBuildInfo
+-- | Perform the \"@.\/setup configure@\" action.
+-- Returns the @.setup-config@ file.
+configure
+ :: (GenericPackageDescription, HookedBuildInfo)
+ -> ConfigFlags
+ -> IO LocalBuildInfo
configure (pkg_descr0, pbi) cfg = do
- -- Determine the component we are configuring, if a user specified
- -- one on the command line. We use a fake, flattened version of
- -- the package since at this point, we're not really sure what
- -- components we *can* configure. @Nothing@ means that we should
- -- configure everything (the old behavior).
- (mb_cname :: Maybe ComponentName) <- do
- let flat_pkg_descr = flattenPackageDescription pkg_descr0
- targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg)
- -- TODO: bleat if you use the module/file syntax
- let targets' = [ cname | BuildTargetComponent cname <- targets ]
- case targets' of
- _ | null (configArgs cfg) -> return Nothing
- [cname] -> return (Just cname)
- [] -> die' verbosity "No valid component targets found"
- _ -> die' verbosity
- "Can only configure either single component or all of them"
-
- let use_external_internal_deps = isJust mb_cname
- case mb_cname of
- Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0)
- Just cname -> setupMessage' verbosity "Configuring" (packageId pkg_descr0)
- cname (Just (configInstantiateWith cfg))
-
- -- configCID is only valid for per-component configure
- when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $
- die' verbosity "--cid is only supported for per-component configure"
-
- checkDeprecatedFlags verbosity cfg
- checkExactConfiguration verbosity pkg_descr0 cfg
-
- -- Where to build the package
- let buildDir :: FilePath -- e.g. dist/build
- -- fromFlag OK due to Distribution.Simple calling
- -- findDistPrefOrDefault to fill it in
- buildDir = fromFlag (configDistPref cfg) </> "build"
- createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir
-
- -- What package database(s) to use
- let packageDbs :: PackageDBStack
- packageDbs
- = interpretPackageDbFlags
- (fromFlag (configUserInstall cfg))
- (configPackageDBs cfg)
-
- -- comp: the compiler we're building with
- -- compPlatform: the platform we're building for
- -- programDb: location and args of all programs we're
- -- building with
- (comp :: Compiler,
- compPlatform :: Platform,
- programDb :: ProgramDb)
- <- configCompilerEx
- (flagToMaybe (configHcFlavor cfg))
- (flagToMaybe (configHcPath cfg))
- (flagToMaybe (configHcPkg cfg))
- (mkProgramDb cfg (configPrograms cfg))
- (lessVerbose verbosity)
-
- -- The InstalledPackageIndex of all installed packages
- installedPackageSet :: InstalledPackageIndex
- <- getInstalledPackages (lessVerbose verbosity) comp
- packageDbs programDb
-
- -- The set of package names which are "shadowed" by internal
- -- packages, and which component they map to
- let internalPackageSet :: Set LibraryName
- internalPackageSet = getInternalLibraries pkg_descr0
-
- -- Make a data structure describing what components are enabled.
- let enabled :: ComponentRequestedSpec
- enabled = case mb_cname of
- Just cname -> OneComponentRequestedSpec cname
- Nothing -> ComponentRequestedSpec
- -- The flag name (@--enable-tests@) is a
- -- little bit of a misnomer, because
- -- just passing this flag won't
- -- "enable", in our internal
- -- nomenclature; it's just a request; a
- -- @buildable: False@ might make it
- -- not possible to enable.
- { testsRequested = fromFlag (configTests cfg)
- , benchmarksRequested =
- fromFlag (configBenchmarks cfg) }
- -- Some sanity checks related to enabling components.
- when (isJust mb_cname
- && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))) $
- die' verbosity $
- "--enable-tests/--enable-benchmarks are incompatible with" ++
- " explicitly specifying a component to configure."
-
- -- Some sanity checks related to dynamic/static linking.
- when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $
- die' verbosity $
- "--enable-executable-dynamic and --enable-executable-static" ++
- " are incompatible with each other."
-
- -- allConstraints: The set of all 'Dependency's we have. Used ONLY
- -- to 'configureFinalizedPackage'.
- -- requiredDepsMap: A map from 'PackageName' to the specifically
- -- required 'InstalledPackageInfo', due to --dependency
- --
- -- NB: These constraints are to be applied to ALL components of
- -- a package. Thus, it's not an error if allConstraints contains
- -- more constraints than is necessary for a component (another
- -- component might need it.)
- --
- -- NB: The fact that we bundle all the constraints together means
- -- that is not possible to configure a test-suite to use one
- -- version of a dependency, and the executable to use another.
- (allConstraints :: [PackageVersionConstraint],
- requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo)
- <- either (die' verbosity) return $
- combinedConstraints (configConstraints cfg)
- (configDependencies cfg)
- installedPackageSet
-
- -- pkg_descr: The resolved package description, that does not contain any
- -- conditionals, because we have an assignment for
- -- every flag, either picking them ourselves using a
- -- simple naive algorithm, or having them be passed to
- -- us by 'configConfigurationsFlags')
- -- flags: The 'FlagAssignment' that the conditionals were
- -- resolved with.
- --
- -- NB: Why doesn't finalizing a package also tell us what the
- -- dependencies are (e.g. when we run the naive algorithm,
- -- we are checking if dependencies are satisfiable)? The
- -- primary reason is that we may NOT have done any solving:
- -- if the flags are all chosen for us, this step is a simple
- -- matter of flattening according to that assignment. It's
- -- cleaner to then configure the dependencies afterwards.
- (pkg_descr :: PackageDescription,
- flags :: FlagAssignment)
- <- configureFinalizedPackage verbosity cfg enabled
- allConstraints
- (dependencySatisfiable
- use_external_internal_deps
- (fromFlagOrDefault False (configExactConfiguration cfg))
- (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg))
- (packageName pkg_descr0)
- installedPackageSet
- internalPackageSet
- requiredDepsMap)
- comp
- compPlatform
- pkg_descr0
-
- debug verbosity $ "Finalized package description:\n"
- ++ showPackageDescription pkg_descr
-
- let cabalFileDir = maybe "." takeDirectory $
+ -- Determine the component we are configuring, if a user specified
+ -- one on the command line. We use a fake, flattened version of
+ -- the package since at this point, we're not really sure what
+ -- components we *can* configure. @Nothing@ means that we should
+ -- configure everything (the old behavior).
+ (mb_cname :: Maybe ComponentName) <- do
+ let flat_pkg_descr = flattenPackageDescription pkg_descr0
+ targets <- readBuildTargets verbosity flat_pkg_descr (configArgs cfg)
+ -- TODO: bleat if you use the module/file syntax
+ let targets' = [cname | BuildTargetComponent cname <- targets]
+ case targets' of
+ _ | null (configArgs cfg) -> return Nothing
+ [cname] -> return (Just cname)
+ [] -> die' verbosity "No valid component targets found"
+ _ ->
+ die'
+ verbosity
+ "Can only configure either single component or all of them"
+
+ let use_external_internal_deps = isJust mb_cname
+ case mb_cname of
+ Nothing -> setupMessage verbosity "Configuring" (packageId pkg_descr0)
+ Just cname ->
+ setupMessage'
+ verbosity
+ "Configuring"
+ (packageId pkg_descr0)
+ cname
+ (Just (configInstantiateWith cfg))
+
+ -- configCID is only valid for per-component configure
+ when (isJust (flagToMaybe (configCID cfg)) && isNothing mb_cname) $
+ die' verbosity "--cid is only supported for per-component configure"
+
+ checkDeprecatedFlags verbosity cfg
+ checkExactConfiguration verbosity pkg_descr0 cfg
+
+ -- Where to build the package
+ let buildDir :: FilePath -- e.g. dist/build
+ -- fromFlag OK due to Distribution.Simple calling
+ -- findDistPrefOrDefault to fill it in
+ buildDir = fromFlag (configDistPref cfg) </> "build"
+ createDirectoryIfMissingVerbose (lessVerbose verbosity) True buildDir
+
+ -- What package database(s) to use
+ let packageDbs :: PackageDBStack
+ packageDbs =
+ interpretPackageDbFlags
+ (fromFlag (configUserInstall cfg))
+ (configPackageDBs cfg)
+
+ -- comp: the compiler we're building with
+ -- compPlatform: the platform we're building for
+ -- programDb: location and args of all programs we're
+ -- building with
+ ( comp :: Compiler
+ , compPlatform :: Platform
+ , programDb :: ProgramDb
+ ) <-
+ configCompilerEx
+ (flagToMaybe (configHcFlavor cfg))
+ (flagToMaybe (configHcPath cfg))
+ (flagToMaybe (configHcPkg cfg))
+ (mkProgramDb cfg (configPrograms cfg))
+ (lessVerbose verbosity)
+
+ -- The InstalledPackageIndex of all installed packages
+ installedPackageSet :: InstalledPackageIndex <-
+ getInstalledPackages
+ (lessVerbose verbosity)
+ comp
+ packageDbs
+ programDb
+
+ -- The set of package names which are "shadowed" by internal
+ -- packages, and which component they map to
+ let internalPackageSet :: Set LibraryName
+ internalPackageSet = getInternalLibraries pkg_descr0
+
+ -- Make a data structure describing what components are enabled.
+ let enabled :: ComponentRequestedSpec
+ enabled = case mb_cname of
+ Just cname -> OneComponentRequestedSpec cname
+ Nothing ->
+ ComponentRequestedSpec
+ { -- The flag name (@--enable-tests@) is a
+ -- little bit of a misnomer, because
+ -- just passing this flag won't
+ -- "enable", in our internal
+ -- nomenclature; it's just a request; a
+ -- @buildable: False@ might make it
+ -- not possible to enable.
+ testsRequested = fromFlag (configTests cfg)
+ , benchmarksRequested =
+ fromFlag (configBenchmarks cfg)
+ }
+ -- Some sanity checks related to enabling components.
+ when
+ ( isJust mb_cname
+ && (fromFlag (configTests cfg) || fromFlag (configBenchmarks cfg))
+ )
+ $ die' verbosity
+ $ "--enable-tests/--enable-benchmarks are incompatible with"
+ ++ " explicitly specifying a component to configure."
+
+ -- Some sanity checks related to dynamic/static linking.
+ when (fromFlag (configDynExe cfg) && fromFlag (configFullyStaticExe cfg)) $
+ die' verbosity $
+ "--enable-executable-dynamic and --enable-executable-static"
+ ++ " are incompatible with each other."
+
+ -- allConstraints: The set of all 'Dependency's we have. Used ONLY
+ -- to 'configureFinalizedPackage'.
+ -- requiredDepsMap: A map from 'PackageName' to the specifically
+ -- required 'InstalledPackageInfo', due to --dependency
+ --
+ -- NB: These constraints are to be applied to ALL components of
+ -- a package. Thus, it's not an error if allConstraints contains
+ -- more constraints than is necessary for a component (another
+ -- component might need it.)
+ --
+ -- NB: The fact that we bundle all the constraints together means
+ -- that is not possible to configure a test-suite to use one
+ -- version of a dependency, and the executable to use another.
+ ( allConstraints :: [PackageVersionConstraint]
+ , requiredDepsMap :: Map (PackageName, ComponentName) InstalledPackageInfo
+ ) <-
+ either (die' verbosity) return $
+ combinedConstraints
+ (configConstraints cfg)
+ (configDependencies cfg)
+ installedPackageSet
+
+ -- pkg_descr: The resolved package description, that does not contain any
+ -- conditionals, because we have an assignment for
+ -- every flag, either picking them ourselves using a
+ -- simple naive algorithm, or having them be passed to
+ -- us by 'configConfigurationsFlags')
+ -- flags: The 'FlagAssignment' that the conditionals were
+ -- resolved with.
+ --
+ -- NB: Why doesn't finalizing a package also tell us what the
+ -- dependencies are (e.g. when we run the naive algorithm,
+ -- we are checking if dependencies are satisfiable)? The
+ -- primary reason is that we may NOT have done any solving:
+ -- if the flags are all chosen for us, this step is a simple
+ -- matter of flattening according to that assignment. It's
+ -- cleaner to then configure the dependencies afterwards.
+ ( pkg_descr :: PackageDescription
+ , flags :: FlagAssignment
+ ) <-
+ configureFinalizedPackage
+ verbosity
+ cfg
+ enabled
+ allConstraints
+ ( dependencySatisfiable
+ use_external_internal_deps
+ (fromFlagOrDefault False (configExactConfiguration cfg))
+ (fromFlagOrDefault False (configAllowDependingOnPrivateLibs cfg))
+ (packageName pkg_descr0)
+ installedPackageSet
+ internalPackageSet
+ requiredDepsMap
+ )
+ comp
+ compPlatform
+ pkg_descr0
+
+ debug verbosity $
+ "Finalized package description:\n"
+ ++ showPackageDescription pkg_descr
+
+ let cabalFileDir =
+ maybe "." takeDirectory $
flagToMaybe (configCabalFilePath cfg)
- checkCompilerProblems verbosity comp pkg_descr enabled
- checkPackageProblems verbosity cabalFileDir pkg_descr0
- (updatePackageDescription pbi pkg_descr)
-
- -- The list of 'InstalledPackageInfo' recording the selected
- -- dependencies on external packages.
- --
- -- Invariant: For any package name, there is at most one package
- -- in externalPackageDeps which has that name.
- --
- -- NB: The dependency selection is global over ALL components
- -- in the package (similar to how allConstraints and
- -- requiredDepsMap are global over all components). In particular,
- -- if *any* component (post-flag resolution) has an unsatisfiable
- -- dependency, we will fail. This can sometimes be undesirable
- -- for users, see #1786 (benchmark conflicts with executable),
- --
- -- In the presence of Backpack, these package dependencies are
- -- NOT complete: they only ever include the INDEFINITE
- -- dependencies. After we apply an instantiation, we'll get
- -- definite references which constitute extra dependencies.
- -- (Why not have cabal-install pass these in explicitly?
- -- For one it's deterministic; for two, we need to associate
- -- them with renamings which would require a far more complicated
- -- input scheme than what we have today.)
- externalPkgDeps :: [PreExistingComponent]
- <- configureDependencies
- verbosity
- use_external_internal_deps
- internalPackageSet
- installedPackageSet
- requiredDepsMap
- pkg_descr
- enabled
-
- -- Compute installation directory templates, based on user
- -- configuration.
- --
- -- TODO: Move this into a helper function.
- defaultDirs :: InstallDirTemplates
- <- defaultInstallDirs' use_external_internal_deps
- (compilerFlavor comp)
- (fromFlag (configUserInstall cfg))
- (hasLibs pkg_descr)
- let installDirs :: InstallDirTemplates
- installDirs = combineInstallDirs fromFlagOrDefault
- defaultDirs (configInstallDirs cfg)
-
- -- Check languages and extensions
- -- TODO: Move this into a helper function.
- let langlist = nub $ catMaybes $ map defaultLanguage
- (enabledBuildInfos pkg_descr enabled)
- let langs = unsupportedLanguages comp langlist
- when (not (null langs)) $
- die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0)
- ++ " requires the following languages which are not "
- ++ "supported by " ++ prettyShow (compilerId comp) ++ ": "
- ++ intercalate ", " (map prettyShow langs)
- let extlist = nub $ concatMap allExtensions
- (enabledBuildInfos pkg_descr enabled)
- let exts = unsupportedExtensions comp extlist
- when (not (null exts)) $
- die' verbosity $ "The package " ++ prettyShow (packageId pkg_descr0)
- ++ " requires the following language extensions which are not "
- ++ "supported by " ++ prettyShow (compilerId comp) ++ ": "
- ++ intercalate ", " (map prettyShow exts)
-
- -- Check foreign library build requirements
- let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled]
- let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs
- when (not (null unsupportedFLibs)) $
- die' verbosity $ "Cannot build some foreign libraries: "
- ++ intercalate "," unsupportedFLibs
-
- -- Configure certain external build tools, see below for which ones.
- let requiredBuildTools = do
- bi <- enabledBuildInfos pkg_descr enabled
- -- First, we collect any tool dep that we know is external. This is,
- -- in practice:
- --
- -- 1. `build-tools` entries on the whitelist
- --
- -- 2. `build-tool-depends` that aren't from the current package.
- let externBuildToolDeps =
- [ LegacyExeDependency (unUnqualComponentName eName) versionRange
- | buildTool@(ExeDependency _ eName versionRange)
- <- getAllToolDependencies pkg_descr bi
- , not $ isInternal pkg_descr buildTool ]
- -- Second, we collect any build-tools entry we don't know how to
- -- desugar. We'll never have any idea how to build them, so we just
- -- hope they are already on the PATH.
- let unknownBuildTools =
- [ buildTool
- | buildTool <- buildTools bi
- , Nothing == desugarBuildTool pkg_descr buildTool ]
- externBuildToolDeps ++ unknownBuildTools
-
- programDb' <-
- configureAllKnownPrograms (lessVerbose verbosity) programDb
+ checkCompilerProblems verbosity comp pkg_descr enabled
+ checkPackageProblems
+ verbosity
+ cabalFileDir
+ pkg_descr0
+ (updatePackageDescription pbi pkg_descr)
+
+ -- The list of 'InstalledPackageInfo' recording the selected
+ -- dependencies on external packages.
+ --
+ -- Invariant: For any package name, there is at most one package
+ -- in externalPackageDeps which has that name.
+ --
+ -- NB: The dependency selection is global over ALL components
+ -- in the package (similar to how allConstraints and
+ -- requiredDepsMap are global over all components). In particular,
+ -- if *any* component (post-flag resolution) has an unsatisfiable
+ -- dependency, we will fail. This can sometimes be undesirable
+ -- for users, see #1786 (benchmark conflicts with executable),
+ --
+ -- In the presence of Backpack, these package dependencies are
+ -- NOT complete: they only ever include the INDEFINITE
+ -- dependencies. After we apply an instantiation, we'll get
+ -- definite references which constitute extra dependencies.
+ -- (Why not have cabal-install pass these in explicitly?
+ -- For one it's deterministic; for two, we need to associate
+ -- them with renamings which would require a far more complicated
+ -- input scheme than what we have today.)
+ externalPkgDeps :: [PreExistingComponent] <-
+ configureDependencies
+ verbosity
+ use_external_internal_deps
+ internalPackageSet
+ installedPackageSet
+ requiredDepsMap
+ pkg_descr
+ enabled
+
+ -- Compute installation directory templates, based on user
+ -- configuration.
+ --
+ -- TODO: Move this into a helper function.
+ defaultDirs :: InstallDirTemplates <-
+ defaultInstallDirs'
+ use_external_internal_deps
+ (compilerFlavor comp)
+ (fromFlag (configUserInstall cfg))
+ (hasLibs pkg_descr)
+ let installDirs :: InstallDirTemplates
+ installDirs =
+ combineInstallDirs
+ fromFlagOrDefault
+ defaultDirs
+ (configInstallDirs cfg)
+
+ -- Check languages and extensions
+ -- TODO: Move this into a helper function.
+ let langlist =
+ nub $
+ catMaybes $
+ map
+ defaultLanguage
+ (enabledBuildInfos pkg_descr enabled)
+ let langs = unsupportedLanguages comp langlist
+ when (not (null langs)) $
+ die' verbosity $
+ "The package "
+ ++ prettyShow (packageId pkg_descr0)
+ ++ " requires the following languages which are not "
+ ++ "supported by "
+ ++ prettyShow (compilerId comp)
+ ++ ": "
+ ++ intercalate ", " (map prettyShow langs)
+ let extlist =
+ nub $
+ concatMap
+ allExtensions
+ (enabledBuildInfos pkg_descr enabled)
+ let exts = unsupportedExtensions comp extlist
+ when (not (null exts)) $
+ die' verbosity $
+ "The package "
+ ++ prettyShow (packageId pkg_descr0)
+ ++ " requires the following language extensions which are not "
+ ++ "supported by "
+ ++ prettyShow (compilerId comp)
+ ++ ": "
+ ++ intercalate ", " (map prettyShow exts)
+
+ -- Check foreign library build requirements
+ let flibs = [flib | CFLib flib <- enabledComponents pkg_descr enabled]
+ let unsupportedFLibs = unsupportedForeignLibs comp compPlatform flibs
+ when (not (null unsupportedFLibs)) $
+ die' verbosity $
+ "Cannot build some foreign libraries: "
+ ++ intercalate "," unsupportedFLibs
+
+ -- Configure certain external build tools, see below for which ones.
+ let requiredBuildTools = do
+ bi <- enabledBuildInfos pkg_descr enabled
+ -- First, we collect any tool dep that we know is external. This is,
+ -- in practice:
+ --
+ -- 1. `build-tools` entries on the whitelist
+ --
+ -- 2. `build-tool-depends` that aren't from the current package.
+ let externBuildToolDeps =
+ [ LegacyExeDependency (unUnqualComponentName eName) versionRange
+ | buildTool@(ExeDependency _ eName versionRange) <-
+ getAllToolDependencies pkg_descr bi
+ , not $ isInternal pkg_descr buildTool
+ ]
+ -- Second, we collect any build-tools entry we don't know how to
+ -- desugar. We'll never have any idea how to build them, so we just
+ -- hope they are already on the PATH.
+ let unknownBuildTools =
+ [ buildTool
+ | buildTool <- buildTools bi
+ , Nothing == desugarBuildTool pkg_descr buildTool
+ ]
+ externBuildToolDeps ++ unknownBuildTools
+
+ programDb' <-
+ configureAllKnownPrograms (lessVerbose verbosity) programDb
>>= configureRequiredPrograms verbosity requiredBuildTools
- (pkg_descr', programDb'') <-
- configurePkgconfigPackages verbosity pkg_descr programDb' enabled
+ (pkg_descr', programDb'') <-
+ configurePkgconfigPackages verbosity pkg_descr programDb' enabled
- -- Compute internal component graph
- --
- -- The general idea is that we take a look at all the source level
- -- components (which may build-depends on each other) and form a graph.
- -- From there, we build a ComponentLocalBuildInfo for each of the
- -- components, which lets us actually build each component.
- -- internalPackageSet
- -- use_external_internal_deps
- (buildComponents :: [ComponentLocalBuildInfo],
- packageDependsIndex :: InstalledPackageIndex) <-
- runLogProgress verbosity $ configureComponentLocalBuildInfos
+ -- Compute internal component graph
+ --
+ -- The general idea is that we take a look at all the source level
+ -- components (which may build-depends on each other) and form a graph.
+ -- From there, we build a ComponentLocalBuildInfo for each of the
+ -- components, which lets us actually build each component.
+ -- internalPackageSet
+ -- use_external_internal_deps
+ ( buildComponents :: [ComponentLocalBuildInfo]
+ , packageDependsIndex :: InstalledPackageIndex
+ ) <-
+ runLogProgress verbosity $
+ configureComponentLocalBuildInfos
+ verbosity
+ use_external_internal_deps
+ enabled
+ (fromFlagOrDefault False (configDeterministic cfg))
+ (configIPID cfg)
+ (configCID cfg)
+ pkg_descr
+ externalPkgDeps
+ (configConfigurationsFlags cfg)
+ (configInstantiateWith cfg)
+ installedPackageSet
+ comp
+
+ -- Decide if we're going to compile with split sections.
+ split_sections :: Bool <-
+ if not (fromFlag $ configSplitSections cfg)
+ then return False
+ else case compilerFlavor comp of
+ GHC
+ | compilerVersion comp >= mkVersion [8, 0] ->
+ return True
+ GHCJS ->
+ return True
+ _ -> do
+ warn
verbosity
- use_external_internal_deps
- enabled
- (fromFlagOrDefault False (configDeterministic cfg))
- (configIPID cfg)
- (configCID cfg)
- pkg_descr
- externalPkgDeps
- (configConfigurationsFlags cfg)
- (configInstantiateWith cfg)
- installedPackageSet
- comp
-
- -- Decide if we're going to compile with split sections.
- split_sections :: Bool <-
- if not (fromFlag $ configSplitSections cfg)
- then return False
- else case compilerFlavor comp of
- GHC | compilerVersion comp >= mkVersion [8,0]
- -> return True
- GHCJS
- -> return True
- _ -> do warn verbosity
- ("this compiler does not support " ++
- "--enable-split-sections; ignoring")
- return False
-
- -- Decide if we're going to compile with split objects.
- split_objs :: Bool <-
- if not (fromFlag $ configSplitObjs cfg)
- then return False
- else case compilerFlavor comp of
- _ | split_sections
- -> do warn verbosity
- ("--enable-split-sections and " ++
- "--enable-split-objs are mutually " ++
- "exclusive; ignoring the latter")
- return False
- GHC
- -> return True
- GHCJS
- -> return True
- _ -> do warn verbosity
- ("this compiler does not support " ++
- "--enable-split-objs; ignoring")
- return False
-
- let compilerSupportsGhciLibs :: Bool
- compilerSupportsGhciLibs =
- case compilerId comp of
- CompilerId GHC version
- | version > mkVersion [9,3] && windows ->
- False
- CompilerId GHC _ ->
- True
- CompilerId GHCJS _ ->
- True
- _ -> False
- where
- windows = case compPlatform of
- Platform _ Windows -> True
- Platform _ _ -> False
-
- let ghciLibByDefault =
- case compilerId comp of
- CompilerId GHC _ ->
- -- If ghc is non-dynamic, then ghci needs object files,
- -- so we build one by default.
- --
- -- Technically, archive files should be sufficient for ghci,
- -- but because of GHC bug #8942, it has never been safe to
- -- rely on them. By the time that bug was fixed, ghci had
- -- been changed to read shared libraries instead of archive
- -- files (see next code block).
- not (GHC.isDynamic comp)
- CompilerId GHCJS _ ->
- not (GHCJS.isDynamic comp)
- _ -> False
+ ( "this compiler does not support "
+ ++ "--enable-split-sections; ignoring"
+ )
+ return False
- withGHCiLib_ <-
- case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of
- True | not compilerSupportsGhciLibs -> do
- warn verbosity $
- "--enable-library-for-ghci is no longer supported on Windows with"
- ++ " GHC 9.4 and later; ignoring..."
+ -- Decide if we're going to compile with split objects.
+ split_objs :: Bool <-
+ if not (fromFlag $ configSplitObjs cfg)
+ then return False
+ else case compilerFlavor comp of
+ _ | split_sections ->
+ do
+ warn
+ verbosity
+ ( "--enable-split-sections and "
+ ++ "--enable-split-objs are mutually "
+ ++ "exclusive; ignoring the latter"
+ )
+ return False
+ GHC ->
+ return True
+ GHCJS ->
+ return True
+ _ -> do
+ warn
+ verbosity
+ ( "this compiler does not support "
+ ++ "--enable-split-objs; ignoring"
+ )
return False
- v -> return v
-
- let sharedLibsByDefault
- | fromFlag (configDynExe cfg) =
- -- build a shared library if dynamically-linked
- -- executables are requested
- True
- | otherwise = case compilerId comp of
+
+ let compilerSupportsGhciLibs :: Bool
+ compilerSupportsGhciLibs =
+ case compilerId comp of
+ CompilerId GHC version
+ | version > mkVersion [9, 3] && windows ->
+ False
+ CompilerId GHC _ ->
+ True
+ CompilerId GHCJS _ ->
+ True
+ _ -> False
+ where
+ windows = case compPlatform of
+ Platform _ Windows -> True
+ Platform _ _ -> False
+
+ let ghciLibByDefault =
+ case compilerId comp of
+ CompilerId GHC _ ->
+ -- If ghc is non-dynamic, then ghci needs object files,
+ -- so we build one by default.
+ --
+ -- Technically, archive files should be sufficient for ghci,
+ -- but because of GHC bug #8942, it has never been safe to
+ -- rely on them. By the time that bug was fixed, ghci had
+ -- been changed to read shared libraries instead of archive
+ -- files (see next code block).
+ not (GHC.isDynamic comp)
+ CompilerId GHCJS _ ->
+ not (GHCJS.isDynamic comp)
+ _ -> False
+
+ withGHCiLib_ <-
+ case fromFlagOrDefault ghciLibByDefault (configGHCiLib cfg) of
+ True | not compilerSupportsGhciLibs -> do
+ warn verbosity $
+ "--enable-library-for-ghci is no longer supported on Windows with"
+ ++ " GHC 9.4 and later; ignoring..."
+ return False
+ v -> return v
+
+ let sharedLibsByDefault
+ | fromFlag (configDynExe cfg) =
+ -- build a shared library if dynamically-linked
+ -- executables are requested
+ True
+ | otherwise = case compilerId comp of
CompilerId GHC _ ->
-- if ghc is dynamic, then ghci needs a shared
-- library, so we build one by default.
@@ -692,168 +840,189 @@ configure (pkg_descr0, pbi) cfg = do
CompilerId GHCJS _ ->
GHCJS.isDynamic comp
_ -> False
- withSharedLib_ =
- -- build shared libraries if required by GHC or by the
- -- executable linking mode, but allow the user to force
- -- building only static library archives with
- -- --disable-shared.
- fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg
+ withSharedLib_ =
+ -- build shared libraries if required by GHC or by the
+ -- executable linking mode, but allow the user to force
+ -- building only static library archives with
+ -- --disable-shared.
+ fromFlagOrDefault sharedLibsByDefault $ configSharedLib cfg
- withStaticLib_ =
- -- build a static library (all dependent libraries rolled
- -- into a huge .a archive) via GHCs -staticlib flag.
- fromFlagOrDefault False $ configStaticLib cfg
+ withStaticLib_ =
+ -- build a static library (all dependent libraries rolled
+ -- into a huge .a archive) via GHCs -staticlib flag.
+ fromFlagOrDefault False $ configStaticLib cfg
- withDynExe_ = fromFlag $ configDynExe cfg
+ withDynExe_ = fromFlag $ configDynExe cfg
- withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg
+ withFullyStaticExe_ = fromFlag $ configFullyStaticExe cfg
- when (withDynExe_ && not withSharedLib_) $ warn verbosity $
- "Executables will use dynamic linking, but a shared library "
+ when (withDynExe_ && not withSharedLib_) $
+ warn verbosity $
+ "Executables will use dynamic linking, but a shared library "
++ "is not being built. Linking will fail if any executables "
++ "depend on the library."
- setProfLBI <- configureProfiling verbosity cfg comp
-
- setCoverageLBI <- configureCoverage verbosity cfg comp
-
-
-
- -- Turn off library and executable stripping when `debug-info` is set
- -- to anything other than zero.
- let
- strip_libexe s f =
- let defaultStrip = fromFlagOrDefault True (f cfg)
- in case fromFlag (configDebugInfo cfg) of
- NoDebugInfo -> return defaultStrip
- _ -> case f cfg of
- Flag True -> do
- warn verbosity $ "Setting debug-info implies "
- ++ s ++ "-stripping: False"
- return False
-
- _ -> return False
-
- strip_lib <- strip_libexe "library" configStripLibs
- strip_exe <- strip_libexe "executable" configStripExes
-
-
- let reloc = fromFlagOrDefault False $ configRelocatable cfg
-
- let buildComponentsMap =
- foldl' (\m clbi -> Map.insertWith (++)
- (componentLocalName clbi) [clbi] m)
- Map.empty buildComponents
-
- let lbi = (setCoverageLBI . setProfLBI)
- LocalBuildInfo {
- configFlags = cfg,
- flagAssignment = flags,
- componentEnabledSpec = enabled,
- extraConfigArgs = [], -- Currently configure does not
- -- take extra args, but if it
- -- did they would go here.
- installDirTemplates = installDirs,
- compiler = comp,
- hostPlatform = compPlatform,
- buildDir = buildDir,
- cabalFilePath = flagToMaybe (configCabalFilePath cfg),
- componentGraph = Graph.fromDistinctList buildComponents,
- componentNameMap = buildComponentsMap,
- installedPkgs = packageDependsIndex,
- pkgDescrFile = Nothing,
- localPkgDescr = pkg_descr',
- withPrograms = programDb'',
- withVanillaLib = fromFlag $ configVanillaLib cfg,
- withSharedLib = withSharedLib_,
- withStaticLib = withStaticLib_,
- withDynExe = withDynExe_,
- withFullyStaticExe = withFullyStaticExe_,
- withProfLib = False,
- withProfLibDetail = ProfDetailNone,
- withProfExe = False,
- withProfExeDetail = ProfDetailNone,
- withOptimization = fromFlag $ configOptimization cfg,
- withDebugInfo = fromFlag $ configDebugInfo cfg,
- withGHCiLib = withGHCiLib_,
- splitSections = split_sections,
- splitObjs = split_objs,
- stripExes = strip_exe,
- stripLibs = strip_lib,
- exeCoverage = False,
- libCoverage = False,
- withPackageDB = packageDbs,
- progPrefix = fromFlag $ configProgPrefix cfg,
- progSuffix = fromFlag $ configProgSuffix cfg,
- relocatable = reloc
- }
-
- when reloc (checkRelocatable verbosity pkg_descr lbi)
-
- -- TODO: This is not entirely correct, because the dirs may vary
- -- across libraries/executables
- let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
- relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi
-
- -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to
- -- cabal configure, is only a hidden option. It allows packages
- -- to be relocatable with their package database. This however
- -- breaks when the Paths_* or other includes are used that
- -- contain hard coded paths. This is still an open TODO.
- --
- -- Allowing ${pkgroot} here, however requires less custom hooks
- -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872
- unless (isAbsolute (prefix dirs)
- || "${pkgroot}" `isPrefixOf` prefix dirs) $ die' verbosity $
- "expected an absolute directory name for --prefix: " ++ prefix dirs
-
- when ("${pkgroot}" `isPrefixOf` prefix dirs) $
- warn verbosity $ "Using ${pkgroot} in prefix " ++ prefix dirs
- ++ " will not work if you rely on the Path_* module "
- ++ " or other hard coded paths. Cabal does not yet "
- ++ " support fully relocatable builds! "
- ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909"
- ++ " #4097 #4291 #4872"
-
- info verbosity $ "Using " ++ prettyShow currentCabalId
- ++ " compiled by " ++ prettyShow currentCompilerId
- info verbosity $ "Using compiler: " ++ showCompilerId comp
- info verbosity $ "Using install prefix: " ++ prefix dirs
-
- let dirinfo name dir isPrefixRelative =
- info verbosity $ name ++ " installed in: " ++ dir ++ relNote
- where relNote = case buildOS of
- Windows | not (hasLibs pkg_descr)
- && isNothing isPrefixRelative
- -> " (fixed location)"
- _ -> ""
-
- dirinfo "Executables" (bindir dirs) (bindir relative)
- dirinfo "Libraries" (libdir dirs) (libdir relative)
- dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative)
- dirinfo "Private executables" (libexecdir dirs) (libexecdir relative)
- dirinfo "Data files" (datadir dirs) (datadir relative)
- dirinfo "Documentation" (docdir dirs) (docdir relative)
- dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)
-
- sequence_ [ reportProgram verbosity prog configuredProg
- | (prog, configuredProg) <- knownPrograms programDb'' ]
-
- return lbi
+ setProfLBI <- configureProfiling verbosity cfg comp
+
+ setCoverageLBI <- configureCoverage verbosity cfg comp
+
+ -- Turn off library and executable stripping when `debug-info` is set
+ -- to anything other than zero.
+ let
+ strip_libexe s f =
+ let defaultStrip = fromFlagOrDefault True (f cfg)
+ in case fromFlag (configDebugInfo cfg) of
+ NoDebugInfo -> return defaultStrip
+ _ -> case f cfg of
+ Flag True -> do
+ warn verbosity $
+ "Setting debug-info implies "
+ ++ s
+ ++ "-stripping: False"
+ return False
+ _ -> return False
+
+ strip_lib <- strip_libexe "library" configStripLibs
+ strip_exe <- strip_libexe "executable" configStripExes
+
+ let reloc = fromFlagOrDefault False $ configRelocatable cfg
+
+ let buildComponentsMap =
+ foldl'
+ ( \m clbi ->
+ Map.insertWith
+ (++)
+ (componentLocalName clbi)
+ [clbi]
+ m
+ )
+ Map.empty
+ buildComponents
+
+ let lbi =
+ (setCoverageLBI . setProfLBI)
+ LocalBuildInfo
+ { configFlags = cfg
+ , flagAssignment = flags
+ , componentEnabledSpec = enabled
+ , extraConfigArgs = [] -- Currently configure does not
+ -- take extra args, but if it
+ -- did they would go here.
+ , installDirTemplates = installDirs
+ , compiler = comp
+ , hostPlatform = compPlatform
+ , buildDir = buildDir
+ , cabalFilePath = flagToMaybe (configCabalFilePath cfg)
+ , componentGraph = Graph.fromDistinctList buildComponents
+ , componentNameMap = buildComponentsMap
+ , installedPkgs = packageDependsIndex
+ , pkgDescrFile = Nothing
+ , localPkgDescr = pkg_descr'
+ , withPrograms = programDb''
+ , withVanillaLib = fromFlag $ configVanillaLib cfg
+ , withSharedLib = withSharedLib_
+ , withStaticLib = withStaticLib_
+ , withDynExe = withDynExe_
+ , withFullyStaticExe = withFullyStaticExe_
+ , withProfLib = False
+ , withProfLibDetail = ProfDetailNone
+ , withProfExe = False
+ , withProfExeDetail = ProfDetailNone
+ , withOptimization = fromFlag $ configOptimization cfg
+ , withDebugInfo = fromFlag $ configDebugInfo cfg
+ , withGHCiLib = withGHCiLib_
+ , splitSections = split_sections
+ , splitObjs = split_objs
+ , stripExes = strip_exe
+ , stripLibs = strip_lib
+ , exeCoverage = False
+ , libCoverage = False
+ , withPackageDB = packageDbs
+ , progPrefix = fromFlag $ configProgPrefix cfg
+ , progSuffix = fromFlag $ configProgSuffix cfg
+ , relocatable = reloc
+ }
+
+ when reloc (checkRelocatable verbosity pkg_descr lbi)
+
+ -- TODO: This is not entirely correct, because the dirs may vary
+ -- across libraries/executables
+ let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest
+ relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi
+
+ -- PKGROOT: allowing ${pkgroot} to be passed as --prefix to
+ -- cabal configure, is only a hidden option. It allows packages
+ -- to be relocatable with their package database. This however
+ -- breaks when the Paths_* or other includes are used that
+ -- contain hard coded paths. This is still an open TODO.
+ --
+ -- Allowing ${pkgroot} here, however requires less custom hooks
+ -- in scripts that *really* want ${pkgroot}. See haskell/cabal/#4872
+ unless
+ ( isAbsolute (prefix dirs)
+ || "${pkgroot}" `isPrefixOf` prefix dirs
+ )
+ $ die' verbosity
+ $ "expected an absolute directory name for --prefix: " ++ prefix dirs
+
+ when ("${pkgroot}" `isPrefixOf` prefix dirs) $
+ warn verbosity $
+ "Using ${pkgroot} in prefix "
+ ++ prefix dirs
+ ++ " will not work if you rely on the Path_* module "
+ ++ " or other hard coded paths. Cabal does not yet "
+ ++ " support fully relocatable builds! "
+ ++ " See #462 #2302 #2994 #3305 #3473 #3586 #3909"
+ ++ " #4097 #4291 #4872"
+
+ info verbosity $
+ "Using "
+ ++ prettyShow currentCabalId
+ ++ " compiled by "
+ ++ prettyShow currentCompilerId
+ info verbosity $ "Using compiler: " ++ showCompilerId comp
+ info verbosity $ "Using install prefix: " ++ prefix dirs
+
+ let dirinfo name dir isPrefixRelative =
+ info verbosity $ name ++ " installed in: " ++ dir ++ relNote
+ where
+ relNote = case buildOS of
+ Windows
+ | not (hasLibs pkg_descr)
+ && isNothing isPrefixRelative ->
+ " (fixed location)"
+ _ -> ""
+
+ dirinfo "Executables" (bindir dirs) (bindir relative)
+ dirinfo "Libraries" (libdir dirs) (libdir relative)
+ dirinfo "Dynamic Libraries" (dynlibdir dirs) (dynlibdir relative)
+ dirinfo "Private executables" (libexecdir dirs) (libexecdir relative)
+ dirinfo "Data files" (datadir dirs) (datadir relative)
+ dirinfo "Documentation" (docdir dirs) (docdir relative)
+ dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)
+
+ sequence_
+ [ reportProgram verbosity prog configuredProg
+ | (prog, configuredProg) <- knownPrograms programDb''
+ ]
- where
- verbosity = fromFlag (configVerbosity cfg)
+ return lbi
+ where
+ verbosity = fromFlag (configVerbosity cfg)
mkProgramDb :: ConfigFlags -> ProgramDb -> ProgramDb
mkProgramDb cfg initialProgramDb = programDb
where
- programDb = userSpecifyArgss (configProgramArgs cfg)
- . userSpecifyPaths (configProgramPaths cfg)
- . setProgramSearchPath searchpath
- $ initialProgramDb
- searchpath = map ProgramSearchPathDir
- (fromNubList $ configProgramPathExtra cfg)
- ++ getProgramSearchPath initialProgramDb
+ programDb =
+ userSpecifyArgss (configProgramArgs cfg)
+ . userSpecifyPaths (configProgramPaths cfg)
+ . setProgramSearchPath searchpath
+ $ initialProgramDb
+ searchpath =
+ map
+ ProgramSearchPathDir
+ (fromNubList $ configProgramPathExtra cfg)
+ ++ getProgramSearchPath initialProgramDb
-- -----------------------------------------------------------------------------
-- Helper functions for configure
@@ -861,33 +1030,48 @@ mkProgramDb cfg initialProgramDb = programDb
-- | Check if the user used any deprecated flags.
checkDeprecatedFlags :: Verbosity -> ConfigFlags -> IO ()
checkDeprecatedFlags verbosity cfg = do
- unless (configProfExe cfg == NoFlag) $ do
- let enable | fromFlag (configProfExe cfg) = "enable"
- | otherwise = "disable"
- warn verbosity
- ("The flag --" ++ enable ++ "-executable-profiling is deprecated. "
- ++ "Please use --" ++ enable ++ "-profiling instead.")
-
- unless (configLibCoverage cfg == NoFlag) $ do
- let enable | fromFlag (configLibCoverage cfg) = "enable"
- | otherwise = "disable"
- warn verbosity
- ("The flag --" ++ enable ++ "-library-coverage is deprecated. "
- ++ "Please use --" ++ enable ++ "-coverage instead.")
+ unless (configProfExe cfg == NoFlag) $ do
+ let enable
+ | fromFlag (configProfExe cfg) = "enable"
+ | otherwise = "disable"
+ warn
+ verbosity
+ ( "The flag --"
+ ++ enable
+ ++ "-executable-profiling is deprecated. "
+ ++ "Please use --"
+ ++ enable
+ ++ "-profiling instead."
+ )
+
+ unless (configLibCoverage cfg == NoFlag) $ do
+ let enable
+ | fromFlag (configLibCoverage cfg) = "enable"
+ | otherwise = "disable"
+ warn
+ verbosity
+ ( "The flag --"
+ ++ enable
+ ++ "-library-coverage is deprecated. "
+ ++ "Please use --"
+ ++ enable
+ ++ "-coverage instead."
+ )
-- | Sanity check: if '--exact-configuration' was given, ensure that the
-- complete flag assignment was specified on the command line.
checkExactConfiguration
:: Verbosity -> GenericPackageDescription -> ConfigFlags -> IO ()
checkExactConfiguration verbosity pkg_descr0 cfg =
- when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do
- let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg))
- allFlags = map flagName . genPackageFlags $ pkg_descr0
- diffFlags = allFlags \\ cmdlineFlags
- when (not . null $ diffFlags) $
- die' verbosity $ "'--exact-configuration' was given, "
- ++ "but the following flags were not specified: "
- ++ intercalate ", " (map show diffFlags)
+ when (fromFlagOrDefault False (configExactConfiguration cfg)) $ do
+ let cmdlineFlags = map fst (unFlagAssignment (configConfigurationsFlags cfg))
+ allFlags = map flagName . genPackageFlags $ pkg_descr0
+ diffFlags = allFlags \\ cmdlineFlags
+ when (not . null $ diffFlags) $
+ die' verbosity $
+ "'--exact-configuration' was given, "
+ ++ "but the following flags were not specified: "
+ ++ intercalate ", " (map show diffFlags)
-- | Create a PackageIndex that makes *any libraries that might be*
-- defined internally to this package look like installed packages, in
@@ -898,97 +1082,110 @@ checkExactConfiguration verbosity pkg_descr0 cfg =
-- file, and we haven't resolved them yet. finalizePD
-- does the resolution of conditionals, and it takes internalPackageSet
-- as part of its input.
-getInternalLibraries :: GenericPackageDescription
- -> Set LibraryName
+getInternalLibraries
+ :: GenericPackageDescription
+ -> Set LibraryName
getInternalLibraries pkg_descr0 =
- -- TODO: some day, executables will be fair game here too!
- let pkg_descr = flattenPackageDescription pkg_descr0
- in Set.fromList (map libName (allLibraries pkg_descr))
+ -- TODO: some day, executables will be fair game here too!
+ let pkg_descr = flattenPackageDescription pkg_descr0
+ in Set.fromList (map libName (allLibraries pkg_descr))
-- | Returns true if a dependency is satisfiable. This function may
-- report a dependency satisfiable even when it is not, but not vice
-- versa. This is to be passed to finalize
dependencySatisfiable
- :: Bool -- ^ use external internal deps?
- -> Bool -- ^ exact configuration?
- -> Bool -- ^ allow depending on private libs?
- -> PackageName
- -> InstalledPackageIndex -- ^ installed set
- -> Set LibraryName -- ^ library components
- -> Map (PackageName, ComponentName) InstalledPackageInfo
- -- ^ required dependencies
- -> (Dependency -> Bool)
+ :: Bool
+ -- ^ use external internal deps?
+ -> Bool
+ -- ^ exact configuration?
+ -> Bool
+ -- ^ allow depending on private libs?
+ -> PackageName
+ -> InstalledPackageIndex
+ -- ^ installed set
+ -> Set LibraryName
+ -- ^ library components
+ -> Map (PackageName, ComponentName) InstalledPackageInfo
+ -- ^ required dependencies
+ -> (Dependency -> Bool)
dependencySatisfiable
use_external_internal_deps
exact_config
allow_private_deps
- pn installedPackageSet packageLibraries requiredDepsMap
+ pn
+ installedPackageSet
+ packageLibraries
+ requiredDepsMap
(Dependency depName vr sublibs)
- | exact_config
- -- When we're given '--exact-configuration', we assume that all
- -- dependencies and flags are exactly specified on the command
- -- line. Thus we only consult the 'requiredDepsMap'. Note that
- -- we're not doing the version range check, so if there's some
- -- dependency that wasn't specified on the command line,
- -- 'finalizePD' will fail.
- -- TODO: mention '--exact-configuration' in the error message
- -- when this fails?
- = if isInternalDep && not use_external_internal_deps
- -- Except for internal deps, when we're NOT per-component mode;
- -- those are just True.
- then internalDepSatisfiable
- else
- -- Backward compatibility for the old sublibrary syntax
- (sublibs == mainLibSet
- && Map.member
- (pn, CLibName $ LSubLibName $
- packageNameToUnqualComponentName depName)
- requiredDepsMap)
-
- || all visible sublibs
-
- | isInternalDep
- = if use_external_internal_deps
- -- When we are doing per-component configure, we now need to
- -- test if the internal dependency is in the index. This has
- -- DIFFERENT semantics from normal dependency satisfiability.
- then internalDepSatisfiableExternally
- -- If a 'PackageName' is defined by an internal component, the dep is
- -- satisfiable (we're going to build it ourselves)
- else internalDepSatisfiable
-
- | otherwise
- = depSatisfiable
-
- where
- -- Internal dependency is when dependency is the same as package.
- isInternalDep = pn == depName
+ | exact_config =
+ -- When we're given '--exact-configuration', we assume that all
+ -- dependencies and flags are exactly specified on the command
+ -- line. Thus we only consult the 'requiredDepsMap'. Note that
+ -- we're not doing the version range check, so if there's some
+ -- dependency that wasn't specified on the command line,
+ -- 'finalizePD' will fail.
+ -- TODO: mention '--exact-configuration' in the error message
+ -- when this fails?
+ if isInternalDep && not use_external_internal_deps
+ then -- Except for internal deps, when we're NOT per-component mode;
+ -- those are just True.
+ internalDepSatisfiable
+ else -- Backward compatibility for the old sublibrary syntax
+
+ ( sublibs == mainLibSet
+ && Map.member
+ ( pn
+ , CLibName $
+ LSubLibName $
+ packageNameToUnqualComponentName depName
+ )
+ requiredDepsMap
+ )
+ || all visible sublibs
+ | isInternalDep =
+ if use_external_internal_deps
+ then -- When we are doing per-component configure, we now need to
+ -- test if the internal dependency is in the index. This has
+ -- DIFFERENT semantics from normal dependency satisfiability.
+ internalDepSatisfiableExternally
+ else -- If a 'PackageName' is defined by an internal component, the dep is
+ -- satisfiable (we're going to build it ourselves)
+ internalDepSatisfiable
+ | otherwise =
+ depSatisfiable
+ where
+ -- Internal dependency is when dependency is the same as package.
+ isInternalDep = pn == depName
- depSatisfiable =
+ depSatisfiable =
not . null $ PackageIndex.lookupDependency installedPackageSet depName vr
- internalDepSatisfiable =
+ internalDepSatisfiable =
Set.isSubsetOf (NES.toSet sublibs) packageLibraries
- internalDepSatisfiableExternally =
+ internalDepSatisfiableExternally =
all (\ln -> not $ null $ PackageIndex.lookupInternalDependency installedPackageSet pn vr ln) sublibs
- -- Check whether a library exists and is visible.
- -- We don't disambiguate between dependency on non-existent or private
- -- library yet, so we just return a bool and later report a generic error.
- visible lib = maybe
- False -- Does not even exist (wasn't in the depsMap)
- (\ipi -> IPI.libVisibility ipi == LibraryVisibilityPublic
- -- If the override is enabled, the visibility does
- -- not matter (it's handled externally)
- || allow_private_deps
- -- If it's a library of the same package then it's
- -- always visible.
- -- This is only triggered when passing a component
- -- of the same package as --dependency, such as in:
- -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs
- || pkgName (IPI.sourcePackageId ipi) == pn)
- maybeIPI
- where maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap
+ -- Check whether a library exists and is visible.
+ -- We don't disambiguate between dependency on non-existent or private
+ -- library yet, so we just return a bool and later report a generic error.
+ visible lib =
+ maybe
+ False -- Does not even exist (wasn't in the depsMap)
+ ( \ipi ->
+ IPI.libVisibility ipi == LibraryVisibilityPublic
+ -- If the override is enabled, the visibility does
+ -- not matter (it's handled externally)
+ || allow_private_deps
+ -- If it's a library of the same package then it's
+ -- always visible.
+ -- This is only triggered when passing a component
+ -- of the same package as --dependency, such as in:
+ -- cabal-testsuite/PackageTests/ConfigureComponent/SubLib/setup-explicit.test.hs
+ || pkgName (IPI.sourcePackageId ipi) == pn
+ )
+ maybeIPI
+ where
+ maybeIPI = Map.lookup (depName, CLibName lib) requiredDepsMap
-- | Finalize a generic package description. The workhorse is
-- 'finalizePD' but there's a bit of other nattering
@@ -997,130 +1194,199 @@ dependencySatisfiable
-- TODO: what exactly is the business with @flaggedTests@ and
-- @flaggedBenchmarks@?
configureFinalizedPackage
- :: Verbosity
- -> ConfigFlags
- -> ComponentRequestedSpec
- -> [PackageVersionConstraint]
- -> (Dependency -> Bool) -- ^ tests if a dependency is satisfiable.
- -- Might say it's satisfiable even when not.
- -> Compiler
- -> Platform
- -> GenericPackageDescription
- -> IO (PackageDescription, FlagAssignment)
-configureFinalizedPackage verbosity cfg enabled
- allConstraints satisfies comp compPlatform pkg_descr0 = do
-
+ :: Verbosity
+ -> ConfigFlags
+ -> ComponentRequestedSpec
+ -> [PackageVersionConstraint]
+ -> (Dependency -> Bool)
+ -- ^ tests if a dependency is satisfiable.
+ -- Might say it's satisfiable even when not.
+ -> Compiler
+ -> Platform
+ -> GenericPackageDescription
+ -> IO (PackageDescription, FlagAssignment)
+configureFinalizedPackage
+ verbosity
+ cfg
+ enabled
+ allConstraints
+ satisfies
+ comp
+ compPlatform
+ pkg_descr0 = do
(pkg_descr0', flags) <-
- case finalizePD
- (configConfigurationsFlags cfg)
- enabled
- satisfies
- compPlatform
- (compilerInfo comp)
- allConstraints
- pkg_descr0
- of Right r -> return r
- Left missing ->
- die' verbosity $ "Encountered missing or private dependencies:\n"
- ++ (render . nest 4 . sep . punctuate comma
- . map (pretty . simplifyDependency)
- $ missing)
+ case finalizePD
+ (configConfigurationsFlags cfg)
+ enabled
+ satisfies
+ compPlatform
+ (compilerInfo comp)
+ allConstraints
+ pkg_descr0 of
+ Right r -> return r
+ Left missing ->
+ die' verbosity $
+ "Encountered missing or private dependencies:\n"
+ ++ ( render
+ . nest 4
+ . sep
+ . punctuate comma
+ . map (pretty . simplifyDependency)
+ $ missing
+ )
-- add extra include/lib dirs as specified in cfg
-- we do it here so that those get checked too
let pkg_descr = addExtraIncludeLibDirs pkg_descr0'
unless (nullFlagAssignment flags) $
- info verbosity $ "Flags chosen: "
- ++ intercalate ", " [ unFlagName fn ++ "=" ++ prettyShow value
- | (fn, value) <- unFlagAssignment flags ]
+ info verbosity $
+ "Flags chosen: "
+ ++ intercalate
+ ", "
+ [ unFlagName fn ++ "=" ++ prettyShow value
+ | (fn, value) <- unFlagAssignment flags
+ ]
return (pkg_descr, flags)
- where
- addExtraIncludeLibDirs pkg_descr =
- let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg
- , extraLibDirsStatic = configExtraLibDirsStatic cfg
- , extraFrameworkDirs = configExtraFrameworkDirs cfg
- , includeDirs = configExtraIncludeDirs cfg}
- modifyLib l = l{ libBuildInfo = libBuildInfo l
- `mappend` extraBi }
- modifyExecutable e = e{ buildInfo = buildInfo e
- `mappend` extraBi}
- modifyForeignLib f = f{ foreignLibBuildInfo = foreignLibBuildInfo f
- `mappend` extraBi}
- modifyTestsuite t = t{ testBuildInfo = testBuildInfo t
- `mappend` extraBi}
- modifyBenchmark b = b{ benchmarkBuildInfo = benchmarkBuildInfo b
- `mappend` extraBi}
- in pkg_descr
- { library = modifyLib `fmap` library pkg_descr
- , subLibraries = modifyLib `map` subLibraries pkg_descr
- , executables = modifyExecutable `map` executables pkg_descr
- , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr
- , testSuites = modifyTestsuite `map` testSuites pkg_descr
- , benchmarks = modifyBenchmark `map` benchmarks pkg_descr
- }
+ where
+ addExtraIncludeLibDirs pkg_descr =
+ let extraBi =
+ mempty
+ { extraLibDirs = configExtraLibDirs cfg
+ , extraLibDirsStatic = configExtraLibDirsStatic cfg
+ , extraFrameworkDirs = configExtraFrameworkDirs cfg
+ , includeDirs = configExtraIncludeDirs cfg
+ }
+ modifyLib l =
+ l
+ { libBuildInfo =
+ libBuildInfo l
+ `mappend` extraBi
+ }
+ modifyExecutable e =
+ e
+ { buildInfo =
+ buildInfo e
+ `mappend` extraBi
+ }
+ modifyForeignLib f =
+ f
+ { foreignLibBuildInfo =
+ foreignLibBuildInfo f
+ `mappend` extraBi
+ }
+ modifyTestsuite t =
+ t
+ { testBuildInfo =
+ testBuildInfo t
+ `mappend` extraBi
+ }
+ modifyBenchmark b =
+ b
+ { benchmarkBuildInfo =
+ benchmarkBuildInfo b
+ `mappend` extraBi
+ }
+ in pkg_descr
+ { library = modifyLib `fmap` library pkg_descr
+ , subLibraries = modifyLib `map` subLibraries pkg_descr
+ , executables = modifyExecutable `map` executables pkg_descr
+ , foreignLibs = modifyForeignLib `map` foreignLibs pkg_descr
+ , testSuites = modifyTestsuite `map` testSuites pkg_descr
+ , benchmarks = modifyBenchmark `map` benchmarks pkg_descr
+ }
-- | Check for use of Cabal features which require compiler support
checkCompilerProblems
:: Verbosity -> Compiler -> PackageDescription -> ComponentRequestedSpec -> IO ()
checkCompilerProblems verbosity comp pkg_descr enabled = do
- unless (renamingPackageFlagsSupported comp ||
- all (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins)
- (enabledBuildInfos pkg_descr enabled)) $
- die' verbosity $
- "Your compiler does not support thinning and renaming on "
- ++ "package flags. To use this feature you must use "
- ++ "GHC 7.9 or later."
-
- when (any (not.null.reexportedModules) (allLibraries pkg_descr)
- && not (reexportedModulesSupported comp)) $
- die' verbosity $
- "Your compiler does not support module re-exports. To use "
- ++ "this feature you must use GHC 7.9 or later."
-
- when (any (not.null.signatures) (allLibraries pkg_descr)
- && not (backpackSupported comp)) $
- die' verbosity $
- "Your compiler does not support Backpack. To use "
- ++ "this feature you must use GHC 8.1 or later."
+ unless
+ ( renamingPackageFlagsSupported comp
+ || all
+ (all (isDefaultIncludeRenaming . mixinIncludeRenaming) . mixins)
+ (enabledBuildInfos pkg_descr enabled)
+ )
+ $ die' verbosity
+ $ "Your compiler does not support thinning and renaming on "
+ ++ "package flags. To use this feature you must use "
+ ++ "GHC 7.9 or later."
+
+ when
+ ( any (not . null . reexportedModules) (allLibraries pkg_descr)
+ && not (reexportedModulesSupported comp)
+ )
+ $ die' verbosity
+ $ "Your compiler does not support module re-exports. To use "
+ ++ "this feature you must use GHC 7.9 or later."
+
+ when
+ ( any (not . null . signatures) (allLibraries pkg_descr)
+ && not (backpackSupported comp)
+ )
+ $ die' verbosity
+ $ "Your compiler does not support Backpack. To use "
+ ++ "this feature you must use GHC 8.1 or later."
-- | Select dependencies for the package.
configureDependencies
- :: Verbosity
- -> UseExternalInternalDeps
- -> Set LibraryName
- -> InstalledPackageIndex -- ^ installed packages
- -> Map (PackageName, ComponentName) InstalledPackageInfo -- ^ required deps
- -> PackageDescription
- -> ComponentRequestedSpec
- -> IO [PreExistingComponent]
-configureDependencies verbosity use_external_internal_deps
- packageLibraries installedPackageSet requiredDepsMap pkg_descr enableSpec = do
+ :: Verbosity
+ -> UseExternalInternalDeps
+ -> Set LibraryName
+ -> InstalledPackageIndex
+ -- ^ installed packages
+ -> Map (PackageName, ComponentName) InstalledPackageInfo
+ -- ^ required deps
+ -> PackageDescription
+ -> ComponentRequestedSpec
+ -> IO [PreExistingComponent]
+configureDependencies
+ verbosity
+ use_external_internal_deps
+ packageLibraries
+ installedPackageSet
+ requiredDepsMap
+ pkg_descr
+ enableSpec = do
let failedDeps :: [FailedDependency]
allPkgDeps :: [ResolvedDependency]
- (failedDeps, allPkgDeps) = partitionEithers $ concat
- [ fmap (\s -> (dep, s)) <$> status
- | dep <- enabledBuildDepends pkg_descr enableSpec
- , let status = selectDependency (package pkg_descr)
- packageLibraries installedPackageSet
- requiredDepsMap use_external_internal_deps dep ]
-
- internalPkgDeps = [ pkgid
- | (_, InternalDependency pkgid) <- allPkgDeps ]
+ (failedDeps, allPkgDeps) =
+ partitionEithers $
+ concat
+ [ fmap (\s -> (dep, s)) <$> status
+ | dep <- enabledBuildDepends pkg_descr enableSpec
+ , let status =
+ selectDependency
+ (package pkg_descr)
+ packageLibraries
+ installedPackageSet
+ requiredDepsMap
+ use_external_internal_deps
+ dep
+ ]
+
+ internalPkgDeps =
+ [ pkgid
+ | (_, InternalDependency pkgid) <- allPkgDeps
+ ]
-- NB: we have to SAVE the package name, because this is the only
-- way we can be able to resolve package names in the package
-- description.
- externalPkgDeps = [ pec
- | (_, ExternalDependency pec) <- allPkgDeps ]
+ externalPkgDeps =
+ [ pec
+ | (_, ExternalDependency pec) <- allPkgDeps
+ ]
- when (not (null internalPkgDeps)
- && not (newPackageDepsBehaviour pkg_descr)) $
- die' verbosity $ "The field 'build-depends: "
- ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps)
- ++ "' refers to a library which is defined within the same "
- ++ "package. To use this feature the package must specify at "
- ++ "least 'cabal-version: >= 1.8'."
+ when
+ ( not (null internalPkgDeps)
+ && not (newPackageDepsBehaviour pkg_descr)
+ )
+ $ die' verbosity
+ $ "The field 'build-depends: "
+ ++ intercalate ", " (map (prettyShow . packageName) internalPkgDeps)
+ ++ "' refers to a library which is defined within the same "
+ ++ "package. To use this feature the package must specify at "
+ ++ "least 'cabal-version: >= 1.8'."
reportFailedDependencies verbosity failedDeps
reportSelectedDependencies verbosity allPkgDeps
@@ -1129,26 +1395,40 @@ configureDependencies verbosity use_external_internal_deps
-- | Select and apply coverage settings for the build based on the
-- 'ConfigFlags' and 'Compiler'.
-configureCoverage :: Verbosity -> ConfigFlags -> Compiler
- -> IO (LocalBuildInfo -> LocalBuildInfo)
+configureCoverage
+ :: Verbosity
+ -> ConfigFlags
+ -> Compiler
+ -> IO (LocalBuildInfo -> LocalBuildInfo)
configureCoverage verbosity cfg comp = do
- let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg)
- tryLibCoverage = fromFlagOrDefault tryExeCoverage
- (mappend (configCoverage cfg) (configLibCoverage cfg))
- if coverageSupported comp
- then do
- let apply lbi = lbi { libCoverage = tryLibCoverage
- , exeCoverage = tryExeCoverage
- }
- return apply
- else do
- let apply lbi = lbi { libCoverage = False
- , exeCoverage = False
- }
- when (tryExeCoverage || tryLibCoverage) $ warn verbosity
- ("The compiler " ++ showCompilerId comp ++ " does not support "
- ++ "program coverage. Program coverage has been disabled.")
- return apply
+ let tryExeCoverage = fromFlagOrDefault False (configCoverage cfg)
+ tryLibCoverage =
+ fromFlagOrDefault
+ tryExeCoverage
+ (mappend (configCoverage cfg) (configLibCoverage cfg))
+ if coverageSupported comp
+ then do
+ let apply lbi =
+ lbi
+ { libCoverage = tryLibCoverage
+ , exeCoverage = tryExeCoverage
+ }
+ return apply
+ else do
+ let apply lbi =
+ lbi
+ { libCoverage = False
+ , exeCoverage = False
+ }
+ when (tryExeCoverage || tryLibCoverage) $
+ warn
+ verbosity
+ ( "The compiler "
+ ++ showCompilerId comp
+ ++ " does not support "
+ ++ "program coverage. Program coverage has been disabled."
+ )
+ return apply
-- | Compute the effective value of the profiling flags
-- @--enable-library-profiling@ and @--enable-executable-profiling@
@@ -1168,61 +1448,89 @@ computeEffectiveProfiling cfg =
--
-- The --profiling-detail and --library-profiling-detail flags behave
-- similarly
- let tryExeProfiling = fromFlagOrDefault False
- (mappend (configProf cfg) (configProfExe cfg))
- tryLibProfiling = fromFlagOrDefault tryExeProfiling
- (mappend (configProf cfg) (configProfLib cfg))
- in (tryLibProfiling, tryExeProfiling)
+ let tryExeProfiling =
+ fromFlagOrDefault
+ False
+ (mappend (configProf cfg) (configProfExe cfg))
+ tryLibProfiling =
+ fromFlagOrDefault
+ tryExeProfiling
+ (mappend (configProf cfg) (configProfLib cfg))
+ in (tryLibProfiling, tryExeProfiling)
-- | Select and apply profiling settings for the build based on the
-- 'ConfigFlags' and 'Compiler'.
-configureProfiling :: Verbosity -> ConfigFlags -> Compiler
- -> IO (LocalBuildInfo -> LocalBuildInfo)
+configureProfiling
+ :: Verbosity
+ -> ConfigFlags
+ -> Compiler
+ -> IO (LocalBuildInfo -> LocalBuildInfo)
configureProfiling verbosity cfg comp = do
let (tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling cfg
- tryExeProfileLevel = fromFlagOrDefault ProfDetailDefault
- (configProfDetail cfg)
- tryLibProfileLevel = fromFlagOrDefault ProfDetailDefault
- (mappend
- (configProfDetail cfg)
- (configProfLibDetail cfg))
+ tryExeProfileLevel =
+ fromFlagOrDefault
+ ProfDetailDefault
+ (configProfDetail cfg)
+ tryLibProfileLevel =
+ fromFlagOrDefault
+ ProfDetailDefault
+ ( mappend
+ (configProfDetail cfg)
+ (configProfLibDetail cfg)
+ )
checkProfileLevel (ProfDetailOther other) = do
- warn verbosity
- ("Unknown profiling detail level '" ++ other
- ++ "', using default.\nThe profiling detail levels are: "
- ++ intercalate ", "
- [ name | (name, _, _) <- knownProfDetailLevels ])
+ warn
+ verbosity
+ ( "Unknown profiling detail level '"
+ ++ other
+ ++ "', using default.\nThe profiling detail levels are: "
+ ++ intercalate
+ ", "
+ [name | (name, _, _) <- knownProfDetailLevels]
+ )
return ProfDetailDefault
checkProfileLevel other = return other
(exeProfWithoutLibProf, applyProfiling) <-
if profilingSupported comp
- then do
- exeLevel <- checkProfileLevel tryExeProfileLevel
- libLevel <- checkProfileLevel tryLibProfileLevel
- let apply lbi = lbi { withProfLib = tryLibProfiling
- , withProfLibDetail = libLevel
- , withProfExe = tryExeProfiling
- , withProfExeDetail = exeLevel
- }
- return (tryExeProfiling && not tryLibProfiling, apply)
- else do
- let apply lbi = lbi { withProfLib = False
- , withProfLibDetail = ProfDetailNone
- , withProfExe = False
- , withProfExeDetail = ProfDetailNone
- }
- when (tryExeProfiling || tryLibProfiling) $ warn verbosity
- ("The compiler " ++ showCompilerId comp ++ " does not support "
- ++ "profiling. Profiling has been disabled.")
- return (False, apply)
-
- when exeProfWithoutLibProf $ warn verbosity
- ("Executables will be built with profiling, but library "
- ++ "profiling is disabled. Linking will fail if any executables "
- ++ "depend on the library.")
+ then do
+ exeLevel <- checkProfileLevel tryExeProfileLevel
+ libLevel <- checkProfileLevel tryLibProfileLevel
+ let apply lbi =
+ lbi
+ { withProfLib = tryLibProfiling
+ , withProfLibDetail = libLevel
+ , withProfExe = tryExeProfiling
+ , withProfExeDetail = exeLevel
+ }
+ return (tryExeProfiling && not tryLibProfiling, apply)
+ else do
+ let apply lbi =
+ lbi
+ { withProfLib = False
+ , withProfLibDetail = ProfDetailNone
+ , withProfExe = False
+ , withProfExeDetail = ProfDetailNone
+ }
+ when (tryExeProfiling || tryLibProfiling) $
+ warn
+ verbosity
+ ( "The compiler "
+ ++ showCompilerId comp
+ ++ " does not support "
+ ++ "profiling. Profiling has been disabled."
+ )
+ return (False, apply)
+
+ when exeProfWithoutLibProf $
+ warn
+ verbosity
+ ( "Executables will be built with profiling, but library "
+ ++ "profiling is disabled. Linking will fail if any executables "
+ ++ "depend on the library."
+ )
return applyProfiling
@@ -1230,16 +1538,17 @@ configureProfiling verbosity cfg comp = do
-- Configuring package dependencies
reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO ()
-reportProgram verbosity prog Nothing
- = info verbosity $ "No " ++ programName prog ++ " found"
-reportProgram verbosity prog (Just configuredProg)
- = info verbosity $ "Using " ++ programName prog ++ version ++ location
- where location = case programLocation configuredProg of
- FoundOnSystem p -> " found on system at: " ++ p
- UserSpecified p -> " given by user at: " ++ p
- version = case programVersion configuredProg of
- Nothing -> ""
- Just v -> " version " ++ prettyShow v
+reportProgram verbosity prog Nothing =
+ info verbosity $ "No " ++ programName prog ++ " found"
+reportProgram verbosity prog (Just configuredProg) =
+ info verbosity $ "Using " ++ programName prog ++ version ++ location
+ where
+ location = case programLocation configuredProg of
+ FoundOnSystem p -> " found on system at: " ++ p
+ UserSpecified p -> " given by user at: " ++ p
+ version = case programVersion configuredProg of
+ Nothing -> ""
+ Just v -> " version " ++ prettyShow v
hackageUrl :: String
hackageUrl = "http://hackage.haskell.org/package/"
@@ -1247,157 +1556,183 @@ hackageUrl = "http://hackage.haskell.org/package/"
type ResolvedDependency = (Dependency, DependencyResolution)
data DependencyResolution
- -- | An external dependency from the package database, OR an
+ = -- | An external dependency from the package database, OR an
-- internal dependency which we are getting from the package
-- database.
- = ExternalDependency PreExistingComponent
- -- | An internal dependency ('PackageId' should be a library name)
+ ExternalDependency PreExistingComponent
+ | -- | An internal dependency ('PackageId' should be a library name)
-- which we are going to have to build. (The
-- 'PackageId' here is a hack to get a modest amount of
-- polymorphism out of the 'Package' typeclass.)
- | InternalDependency PackageId
+ InternalDependency PackageId
-data FailedDependency = DependencyNotExists PackageName
- | DependencyMissingInternal PackageName LibraryName
- | DependencyNoVersion Dependency
+data FailedDependency
+ = DependencyNotExists PackageName
+ | DependencyMissingInternal PackageName LibraryName
+ | DependencyNoVersion Dependency
-- | Test for a package dependency and record the version we have installed.
-selectDependency :: PackageId -- ^ Package id of current package
- -> Set LibraryName -- ^ package libraries
- -> InstalledPackageIndex -- ^ Installed packages
- -> Map (PackageName, ComponentName) InstalledPackageInfo
- -- ^ Packages for which we have been given specific deps to
- -- use
- -> UseExternalInternalDeps -- ^ Are we configuring a
- -- single component?
- -> Dependency
- -> [Either FailedDependency DependencyResolution]
-selectDependency pkgid internalIndex installedIndex requiredDepsMap
+selectDependency
+ :: PackageId
+ -- ^ Package id of current package
+ -> Set LibraryName
+ -- ^ package libraries
+ -> InstalledPackageIndex
+ -- ^ Installed packages
+ -> Map (PackageName, ComponentName) InstalledPackageInfo
+ -- ^ Packages for which we have been given specific deps to
+ -- use
+ -> UseExternalInternalDeps
+ -- ^ Are we configuring a
+ -- single component?
+ -> Dependency
+ -> [Either FailedDependency DependencyResolution]
+selectDependency
+ pkgid
+ internalIndex
+ installedIndex
+ requiredDepsMap
use_external_internal_deps
(Dependency dep_pkgname vr libs) =
- -- If the dependency specification matches anything in the internal package
- -- index, then we prefer that match to anything in the second.
- -- For example:
- --
- -- Name: MyLibrary
- -- Version: 0.1
- -- Library
- -- ..
- -- Executable my-exec
- -- build-depends: MyLibrary
- --
- -- We want "build-depends: MyLibrary" always to match the internal library
- -- even if there is a newer installed library "MyLibrary-0.2".
- if dep_pkgname == pn
- then
- if use_external_internal_deps
- then do_external_internal <$> NES.toList libs
- else do_internal <$> NES.toList libs
- else
- do_external_external <$> NES.toList libs
- where
- pn = packageName pkgid
-
- -- It's an internal library, and we're not per-component build
- do_internal lib
- | Set.member lib internalIndex
- = Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid
-
- | otherwise
- = Left $ DependencyMissingInternal dep_pkgname lib
-
- -- We have to look it up externally
- do_external_external :: LibraryName -> Either FailedDependency DependencyResolution
- do_external_external lib = do
- ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of
- -- If we know the exact pkg to use, then use it.
- Just pkginstance -> Right pkginstance
- -- Otherwise we just pick an arbitrary instance of the latest version.
- Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of
- Nothing -> Left (DependencyNotExists dep_pkgname)
- Just pkg -> Right pkg
- return $ ExternalDependency $ ipiToPreExistingComponent ipi
-
- do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution
- do_external_internal lib = do
- ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of
- -- If we know the exact pkg to use, then use it.
- Just pkginstance -> Right pkginstance
- Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of
- -- It's an internal library, being looked up externally
- Nothing -> Left (DependencyMissingInternal dep_pkgname lib)
- Just pkg -> Right pkg
- return $ ExternalDependency $ ipiToPreExistingComponent ipi
-
- pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo
- pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs
-
-reportSelectedDependencies :: Verbosity
- -> [ResolvedDependency] -> IO ()
+ -- If the dependency specification matches anything in the internal package
+ -- index, then we prefer that match to anything in the second.
+ -- For example:
+ --
+ -- Name: MyLibrary
+ -- Version: 0.1
+ -- Library
+ -- ..
+ -- Executable my-exec
+ -- build-depends: MyLibrary
+ --
+ -- We want "build-depends: MyLibrary" always to match the internal library
+ -- even if there is a newer installed library "MyLibrary-0.2".
+ if dep_pkgname == pn
+ then
+ if use_external_internal_deps
+ then do_external_internal <$> NES.toList libs
+ else do_internal <$> NES.toList libs
+ else do_external_external <$> NES.toList libs
+ where
+ pn = packageName pkgid
+
+ -- It's an internal library, and we're not per-component build
+ do_internal lib
+ | Set.member lib internalIndex =
+ Right $ InternalDependency $ PackageIdentifier dep_pkgname $ packageVersion pkgid
+ | otherwise =
+ Left $ DependencyMissingInternal dep_pkgname lib
+
+ -- We have to look it up externally
+ do_external_external :: LibraryName -> Either FailedDependency DependencyResolution
+ do_external_external lib = do
+ ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of
+ -- If we know the exact pkg to use, then use it.
+ Just pkginstance -> Right pkginstance
+ -- Otherwise we just pick an arbitrary instance of the latest version.
+ Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex dep_pkgname vr lib of
+ Nothing -> Left (DependencyNotExists dep_pkgname)
+ Just pkg -> Right pkg
+ return $ ExternalDependency $ ipiToPreExistingComponent ipi
+
+ do_external_internal :: LibraryName -> Either FailedDependency DependencyResolution
+ do_external_internal lib = do
+ ipi <- case Map.lookup (dep_pkgname, CLibName lib) requiredDepsMap of
+ -- If we know the exact pkg to use, then use it.
+ Just pkginstance -> Right pkginstance
+ Nothing -> case pickLastIPI $ PackageIndex.lookupInternalDependency installedIndex pn vr lib of
+ -- It's an internal library, being looked up externally
+ Nothing -> Left (DependencyMissingInternal dep_pkgname lib)
+ Just pkg -> Right pkg
+ return $ ExternalDependency $ ipiToPreExistingComponent ipi
+
+ pickLastIPI :: [(Version, [InstalledPackageInfo])] -> Maybe InstalledPackageInfo
+ pickLastIPI pkgs = safeHead . snd . last =<< nonEmpty pkgs
+
+reportSelectedDependencies
+ :: Verbosity
+ -> [ResolvedDependency]
+ -> IO ()
reportSelectedDependencies verbosity deps =
- info verbosity $ unlines
- [ "Dependency " ++ prettyShow (simplifyDependency dep)
- ++ ": using " ++ prettyShow pkgid
- | (dep, resolution) <- deps
- , let pkgid = case resolution of
- ExternalDependency pkg' -> packageId pkg'
- InternalDependency pkgid' -> pkgid' ]
+ info verbosity $
+ unlines
+ [ "Dependency "
+ ++ prettyShow (simplifyDependency dep)
+ ++ ": using "
+ ++ prettyShow pkgid
+ | (dep, resolution) <- deps
+ , let pkgid = case resolution of
+ ExternalDependency pkg' -> packageId pkg'
+ InternalDependency pkgid' -> pkgid'
+ ]
reportFailedDependencies :: Verbosity -> [FailedDependency] -> IO ()
-reportFailedDependencies _ [] = return ()
+reportFailedDependencies _ [] = return ()
reportFailedDependencies verbosity failed =
- die' verbosity (intercalate "\n\n" (map reportFailedDependency failed))
-
+ die' verbosity (intercalate "\n\n" (map reportFailedDependency failed))
where
reportFailedDependency (DependencyNotExists pkgname) =
- "there is no version of " ++ prettyShow pkgname ++ " installed.\n"
- ++ "Perhaps you need to download and install it from\n"
- ++ hackageUrl ++ prettyShow pkgname ++ "?"
-
+ "there is no version of "
+ ++ prettyShow pkgname
+ ++ " installed.\n"
+ ++ "Perhaps you need to download and install it from\n"
+ ++ hackageUrl
+ ++ prettyShow pkgname
+ ++ "?"
reportFailedDependency (DependencyMissingInternal pkgname lib) =
- "internal dependency " ++ prettyShow (prettyLibraryNameComponent lib) ++ " not installed.\n"
- ++ "Perhaps you need to configure and install it first?\n"
- ++ "(This library was defined by " ++ prettyShow pkgname ++ ")"
-
+ "internal dependency "
+ ++ prettyShow (prettyLibraryNameComponent lib)
+ ++ " not installed.\n"
+ ++ "Perhaps you need to configure and install it first?\n"
+ ++ "(This library was defined by "
+ ++ prettyShow pkgname
+ ++ ")"
reportFailedDependency (DependencyNoVersion dep) =
- "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n"
+ "cannot satisfy dependency " ++ prettyShow (simplifyDependency dep) ++ "\n"
-- | List all installed packages in the given package databases.
-- Non-existent package databases do not cause errors, they just get skipped
-- with a warning and treated as empty ones, since technically they do not
-- contain any package.
-getInstalledPackages :: Verbosity -> Compiler
- -> PackageDBStack -- ^ The stack of package databases.
- -> ProgramDb
- -> IO InstalledPackageIndex
+getInstalledPackages
+ :: Verbosity
+ -> Compiler
+ -> PackageDBStack
+ -- ^ The stack of package databases.
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity comp packageDBs progdb = do
when (null packageDBs) $
- die' verbosity $ "No package databases have been specified. If you use "
- ++ "--package-db=clear, you must follow it with --package-db= "
- ++ "with 'global', 'user' or a specific file."
+ die' verbosity $
+ "No package databases have been specified. If you use "
+ ++ "--package-db=clear, you must follow it with --package-db= "
+ ++ "with 'global', 'user' or a specific file."
info verbosity "Reading installed packages..."
-- do not check empty packagedbs (ghc-pkg would error out)
packageDBs' <- filterM packageDBExists packageDBs
case compilerFlavor comp of
- GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb
+ GHC -> GHC.getInstalledPackages verbosity comp packageDBs' progdb
GHCJS -> GHCJS.getInstalledPackages verbosity packageDBs' progdb
- UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb
- HaskellSuite {} ->
+ UHC -> UHC.getInstalledPackages verbosity comp packageDBs' progdb
+ HaskellSuite{} ->
HaskellSuite.getInstalledPackages verbosity packageDBs' progdb
- flv -> die' verbosity $ "don't know how to find the installed packages for "
- ++ prettyShow flv
+ flv ->
+ die' verbosity $
+ "don't know how to find the installed packages for "
+ ++ prettyShow flv
where
packageDBExists (SpecificPackageDB path) = do
exists <- doesPathExist path
unless exists $
- warn verbosity $ "Package db " <> path <> " does not exist yet"
+ warn verbosity $
+ "Package db " <> path <> " does not exist yet"
return exists
-- Checking the user and global package dbs is more complicated and needs
-- way more data. Also ghc-pkg won't error out unless the user/global
-- pkgdb is overridden with an empty one, so we just don't check for them.
- packageDBExists UserPackageDB = pure True
- packageDBExists GlobalPackageDB = pure True
+ packageDBExists UserPackageDB = pure True
+ packageDBExists GlobalPackageDB = pure True
-- | Like 'getInstalledPackages', but for a single package DB.
--
@@ -1405,49 +1740,59 @@ getInstalledPackages verbosity comp packageDBs progdb = do
-- That is because 'getInstalledPackages' performs some sanity checks
-- on the package database stack in question. However, when sandboxes
-- are involved these sanity checks are not desirable.
-getPackageDBContents :: Verbosity -> Compiler
- -> PackageDB -> ProgramDb
- -> IO InstalledPackageIndex
+getPackageDBContents
+ :: Verbosity
+ -> Compiler
+ -> PackageDB
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getPackageDBContents verbosity comp packageDB progdb = do
info verbosity "Reading installed packages..."
case compilerFlavor comp of
GHC -> GHC.getPackageDBContents verbosity packageDB progdb
GHCJS -> GHCJS.getPackageDBContents verbosity packageDB progdb
-- For other compilers, try to fall back on 'getInstalledPackages'.
- _ -> getInstalledPackages verbosity comp [packageDB] progdb
-
+ _ -> getInstalledPackages verbosity comp [packageDB] progdb
-- | A set of files (or directories) that can be monitored to detect when
-- there might have been a change in the installed packages.
---
-getInstalledPackagesMonitorFiles :: Verbosity -> Compiler
- -> PackageDBStack
- -> ProgramDb -> Platform
- -> IO [FilePath]
+getInstalledPackagesMonitorFiles
+ :: Verbosity
+ -> Compiler
+ -> PackageDBStack
+ -> ProgramDb
+ -> Platform
+ -> IO [FilePath]
getInstalledPackagesMonitorFiles verbosity comp packageDBs progdb platform =
case compilerFlavor comp of
- GHC -> GHC.getInstalledPackagesMonitorFiles
- verbosity platform progdb packageDBs
+ GHC ->
+ GHC.getInstalledPackagesMonitorFiles
+ verbosity
+ platform
+ progdb
+ packageDBs
other -> do
- warn verbosity $ "don't know how to find change monitoring files for "
- ++ "the installed package databases for " ++ prettyShow other
+ warn verbosity $
+ "don't know how to find change monitoring files for "
+ ++ "the installed package databases for "
+ ++ prettyShow other
return []
-- | The user interface specifies the package dbs to use with a combination of
-- @--global@, @--user@ and @--package-db=global|user|clear|$file@.
-- This function combines the global/user flag and interprets the package-db
-- flag into a single package db stack.
---
interpretPackageDbFlags :: Bool -> [Maybe PackageDB] -> PackageDBStack
interpretPackageDbFlags userInstall specificDBs =
- extra initialStack specificDBs
+ extra initialStack specificDBs
where
- initialStack | userInstall = [GlobalPackageDB, UserPackageDB]
- | otherwise = [GlobalPackageDB]
+ initialStack
+ | userInstall = [GlobalPackageDB, UserPackageDB]
+ | otherwise = [GlobalPackageDB]
- extra dbs' [] = dbs'
- extra _ (Nothing:dbs) = extra [] dbs
- extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs
+ extra dbs' [] = dbs'
+ extra _ (Nothing : dbs) = extra [] dbs
+ extra dbs' (Just db : dbs) = extra (dbs' ++ [db]) dbs
-- We are given both --constraint="foo < 2.0" style constraints and also
-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".
@@ -1463,40 +1808,54 @@ combinedConstraints
:: [PackageVersionConstraint]
-> [GivenComponent]
-> InstalledPackageIndex
- -> Either String ([PackageVersionConstraint],
- Map (PackageName, ComponentName) InstalledPackageInfo)
+ -> Either
+ String
+ ( [PackageVersionConstraint]
+ , Map (PackageName, ComponentName) InstalledPackageInfo
+ )
combinedConstraints constraints dependencies installedPackages = do
+ when (not (null badComponentIds)) $
+ Left $
+ render $
+ text "The following package dependencies were requested"
+ $+$ nest 4 (dispDependencies badComponentIds)
+ $+$ text "however the given installed package instance does not exist."
- when (not (null badComponentIds)) $
- Left $ render $ text "The following package dependencies were requested"
- $+$ nest 4 (dispDependencies badComponentIds)
- $+$ text "however the given installed package instance does not exist."
-
- --TODO: we don't check that all dependencies are used!
-
- return (allConstraints, idConstraintMap)
+ -- TODO: we don't check that all dependencies are used!
+ return (allConstraints, idConstraintMap)
where
allConstraints :: [PackageVersionConstraint]
- allConstraints = constraints
- ++ [ thisPackageVersionConstraint (packageId pkg)
- | (_, _, _, Just pkg) <- dependenciesPkgInfo ]
+ allConstraints =
+ constraints
+ ++ [ thisPackageVersionConstraint (packageId pkg)
+ | (_, _, _, Just pkg) <- dependenciesPkgInfo
+ ]
idConstraintMap :: Map (PackageName, ComponentName) InstalledPackageInfo
- idConstraintMap = Map.fromList
- -- NB: do NOT use the packageName from
- -- dependenciesPkgInfo!
- [ ((pn, cname), pkg)
- | (pn, cname, _, Just pkg) <- dependenciesPkgInfo ]
+ idConstraintMap =
+ Map.fromList
+ -- NB: do NOT use the packageName from
+ -- dependenciesPkgInfo!
+ [ ((pn, cname), pkg)
+ | (pn, cname, _, Just pkg) <- dependenciesPkgInfo
+ ]
-- The dependencies along with the installed package info, if it exists
- dependenciesPkgInfo :: [(PackageName, ComponentName, ComponentId,
- Maybe InstalledPackageInfo)]
+ dependenciesPkgInfo
+ :: [ ( PackageName
+ , ComponentName
+ , ComponentId
+ , Maybe InstalledPackageInfo
+ )
+ ]
dependenciesPkgInfo =
[ (pkgname, CLibName lname, cid, mpkg)
| GivenComponent pkgname lname cid <- dependencies
- , let mpkg = PackageIndex.lookupComponentId
- installedPackages cid
+ , let mpkg =
+ PackageIndex.lookupComponentId
+ installedPackages
+ cid
]
-- If we looked up a package specified by an installed package id
@@ -1504,25 +1863,32 @@ combinedConstraints constraints dependencies installedPackages = do
-- an error.
badComponentIds =
[ (pkgname, cname, cid)
- | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo ]
+ | (pkgname, cname, cid, Nothing) <- dependenciesPkgInfo
+ ]
dispDependencies deps =
- hsep [ text "--dependency="
- <<>> quotes
- (pretty pkgname
- <<>> case cname of
- CLibName LMainLibName -> ""
- CLibName (LSubLibName n) -> ":" <<>> pretty n
- _ -> ":" <<>> pretty cname
- <<>> char '='
- <<>> pretty cid)
- | (pkgname, cname, cid) <- deps ]
+ hsep
+ [ text "--dependency="
+ <<>> quotes
+ ( pretty pkgname
+ <<>> case cname of
+ CLibName LMainLibName -> ""
+ CLibName (LSubLibName n) -> ":" <<>> pretty n
+ _ -> ":" <<>> pretty cname
+ <<>> char '='
+ <<>> pretty cid
+ )
+ | (pkgname, cname, cid) <- deps
+ ]
-- -----------------------------------------------------------------------------
-- Configuring program dependencies
-configureRequiredPrograms :: Verbosity -> [LegacyExeDependency] -> ProgramDb
- -> IO ProgramDb
+configureRequiredPrograms
+ :: Verbosity
+ -> [LegacyExeDependency]
+ -> ProgramDb
+ -> IO ProgramDb
configureRequiredPrograms verbosity deps progdb =
foldM (configureRequiredProgram verbosity) progdb deps
@@ -1532,111 +1898,140 @@ configureRequiredPrograms verbosity deps progdb =
-- known (exists in the input 'ProgramDb'), we will make sure that the
-- program matches the required version; otherwise we will accept
-- any version of the program and assume that it is a simpleProgram.
-configureRequiredProgram :: Verbosity -> ProgramDb -> LegacyExeDependency
- -> IO ProgramDb
-configureRequiredProgram verbosity progdb
+configureRequiredProgram
+ :: Verbosity
+ -> ProgramDb
+ -> LegacyExeDependency
+ -> IO ProgramDb
+configureRequiredProgram
+ verbosity
+ progdb
(LegacyExeDependency progName verRange) =
- case lookupKnownProgram progName progdb of
- Nothing ->
- -- Try to configure it as a 'simpleProgram' automatically
- --
- -- There's a bit of a story behind this line. In old versions
- -- of Cabal, there were only internal build-tools dependencies. So the
- -- behavior in this case was:
- --
- -- - If a build-tool dependency was internal, don't do
- -- any checking.
- --
- -- - If it was external, call 'configureRequiredProgram' to
- -- "configure" the executable. In particular, if
- -- the program was not "known" (present in 'ProgramDb'),
- -- then we would just error. This was fine, because
- -- the only way a program could be executed from 'ProgramDb'
- -- is if some library code from Cabal actually called it,
- -- and the pre-existing Cabal code only calls known
- -- programs from 'defaultProgramDb', and so if it
- -- is calling something else, you have a Custom setup
- -- script, and in that case you are expected to register
- -- the program you want to call in the ProgramDb.
- --
- -- OK, so that was fine, until I (ezyang, in 2016) refactored
- -- Cabal to support per-component builds. In this case, what
- -- was previously an internal build-tool dependency now became
- -- an external one, and now previously "internal" dependencies
- -- are now external. But these are permitted to exist even
- -- when they are not previously configured (something that
- -- can only occur by a Custom script.)
- --
- -- So, I decided, "Fine, let's just accept these in any
- -- case." Thus this line. The alternative would have been to
- -- somehow detect when a build-tools dependency was "internal" (by
- -- looking at the unflattened package description) but this
- -- would also be incompatible with future work to support
- -- external executable dependencies: we definitely cannot
- -- assume they will be preinitialized in the 'ProgramDb'.
- configureProgram verbosity (simpleProgram progName) progdb
- Just prog
- -- requireProgramVersion always requires the program have a version
- -- but if the user says "build-depends: foo" ie no version constraint
- -- then we should not fail if we cannot discover the program version.
- | verRange == anyVersion -> do
- (_, progdb') <- requireProgram verbosity prog progdb
- return progdb'
- | otherwise -> do
- (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb
- return progdb'
+ case lookupKnownProgram progName progdb of
+ Nothing ->
+ -- Try to configure it as a 'simpleProgram' automatically
+ --
+ -- There's a bit of a story behind this line. In old versions
+ -- of Cabal, there were only internal build-tools dependencies. So the
+ -- behavior in this case was:
+ --
+ -- - If a build-tool dependency was internal, don't do
+ -- any checking.
+ --
+ -- - If it was external, call 'configureRequiredProgram' to
+ -- "configure" the executable. In particular, if
+ -- the program was not "known" (present in 'ProgramDb'),
+ -- then we would just error. This was fine, because
+ -- the only way a program could be executed from 'ProgramDb'
+ -- is if some library code from Cabal actually called it,
+ -- and the pre-existing Cabal code only calls known
+ -- programs from 'defaultProgramDb', and so if it
+ -- is calling something else, you have a Custom setup
+ -- script, and in that case you are expected to register
+ -- the program you want to call in the ProgramDb.
+ --
+ -- OK, so that was fine, until I (ezyang, in 2016) refactored
+ -- Cabal to support per-component builds. In this case, what
+ -- was previously an internal build-tool dependency now became
+ -- an external one, and now previously "internal" dependencies
+ -- are now external. But these are permitted to exist even
+ -- when they are not previously configured (something that
+ -- can only occur by a Custom script.)
+ --
+ -- So, I decided, "Fine, let's just accept these in any
+ -- case." Thus this line. The alternative would have been to
+ -- somehow detect when a build-tools dependency was "internal" (by
+ -- looking at the unflattened package description) but this
+ -- would also be incompatible with future work to support
+ -- external executable dependencies: we definitely cannot
+ -- assume they will be preinitialized in the 'ProgramDb'.
+ configureProgram verbosity (simpleProgram progName) progdb
+ Just prog
+ -- requireProgramVersion always requires the program have a version
+ -- but if the user says "build-depends: foo" ie no version constraint
+ -- then we should not fail if we cannot discover the program version.
+ | verRange == anyVersion -> do
+ (_, progdb') <- requireProgram verbosity prog progdb
+ return progdb'
+ | otherwise -> do
+ (_, _, progdb') <- requireProgramVersion verbosity prog verRange progdb
+ return progdb'
-- -----------------------------------------------------------------------------
-- Configuring pkg-config package dependencies
-configurePkgconfigPackages :: Verbosity -> PackageDescription
- -> ProgramDb -> ComponentRequestedSpec
- -> IO (PackageDescription, ProgramDb)
+configurePkgconfigPackages
+ :: Verbosity
+ -> PackageDescription
+ -> ProgramDb
+ -> ComponentRequestedSpec
+ -> IO (PackageDescription, ProgramDb)
configurePkgconfigPackages verbosity pkg_descr progdb enabled
| null allpkgs = return (pkg_descr, progdb)
- | otherwise = do
- (_, _, progdb') <- requireProgramVersion
- (lessVerbose verbosity) pkgConfigProgram
- (orLaterVersion $ mkVersion [0,9,0]) progdb
- traverse_ requirePkg allpkgs
- mlib' <- traverse addPkgConfigBILib (library pkg_descr)
- libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr)
- exes' <- traverse addPkgConfigBIExe (executables pkg_descr)
- tests' <- traverse addPkgConfigBITest (testSuites pkg_descr)
- benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr)
- let pkg_descr' = pkg_descr { library = mlib',
- subLibraries = libs', executables = exes',
- testSuites = tests', benchmarks = benches' }
- return (pkg_descr', progdb')
-
+ | otherwise = do
+ (_, _, progdb') <-
+ requireProgramVersion
+ (lessVerbose verbosity)
+ pkgConfigProgram
+ (orLaterVersion $ mkVersion [0, 9, 0])
+ progdb
+ traverse_ requirePkg allpkgs
+ mlib' <- traverse addPkgConfigBILib (library pkg_descr)
+ libs' <- traverse addPkgConfigBILib (subLibraries pkg_descr)
+ exes' <- traverse addPkgConfigBIExe (executables pkg_descr)
+ tests' <- traverse addPkgConfigBITest (testSuites pkg_descr)
+ benches' <- traverse addPkgConfigBIBench (benchmarks pkg_descr)
+ let pkg_descr' =
+ pkg_descr
+ { library = mlib'
+ , subLibraries = libs'
+ , executables = exes'
+ , testSuites = tests'
+ , benchmarks = benches'
+ }
+ return (pkg_descr', progdb')
where
allpkgs = concatMap pkgconfigDepends (enabledBuildInfos pkg_descr enabled)
- pkgconfig = getDbProgramOutput (lessVerbose verbosity)
- pkgConfigProgram progdb
+ pkgconfig =
+ getDbProgramOutput
+ (lessVerbose verbosity)
+ pkgConfigProgram
+ progdb
requirePkg dep@(PkgconfigDependency pkgn range) = do
- version <- pkgconfig ["--modversion", pkg]
- `catchIO` (\_ -> die' verbosity notFound)
- `catchExit` (\_ -> die' verbosity notFound)
+ version <-
+ pkgconfig ["--modversion", pkg]
+ `catchIO` (\_ -> die' verbosity notFound)
+ `catchExit` (\_ -> die' verbosity notFound)
let trim = dropWhile isSpace . dropWhileEnd isSpace
let v = PkgconfigVersion (toUTF8BS $ trim version)
if not (withinPkgconfigVersionRange v range)
- then die' verbosity (badVersion v)
- else info verbosity (depSatisfied v)
+ then die' verbosity (badVersion v)
+ else info verbosity (depSatisfied v)
where
- notFound = "The pkg-config package '" ++ pkg ++ "'"
- ++ versionRequirement
- ++ " is required but it could not be found."
- badVersion v = "The pkg-config package '" ++ pkg ++ "'"
- ++ versionRequirement
- ++ " is required but the version installed on the"
- ++ " system is version " ++ prettyShow v
- depSatisfied v = "Dependency " ++ prettyShow dep
- ++ ": using version " ++ prettyShow v
+ notFound =
+ "The pkg-config package '"
+ ++ pkg
+ ++ "'"
+ ++ versionRequirement
+ ++ " is required but it could not be found."
+ badVersion v =
+ "The pkg-config package '"
+ ++ pkg
+ ++ "'"
+ ++ versionRequirement
+ ++ " is required but the version installed on the"
+ ++ " system is version "
+ ++ prettyShow v
+ depSatisfied v =
+ "Dependency "
+ ++ prettyShow dep
+ ++ ": using version "
+ ++ prettyShow v
versionRequirement
| isAnyPkgconfigVersion range = ""
- | otherwise = " version " ++ prettyShow range
+ | otherwise = " version " ++ prettyShow range
pkg = unPkgconfigName pkgn
@@ -1647,27 +2042,27 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled
-- Adds pkgconfig dependencies to the build info for a library
addPkgConfigBILib = addPkgConfigBI libBuildInfo $
- \lib bi -> lib { libBuildInfo = bi }
+ \lib bi -> lib{libBuildInfo = bi}
-- Adds pkgconfig dependencies to the build info for an executable
addPkgConfigBIExe = addPkgConfigBI buildInfo $
- \exe bi -> exe { buildInfo = bi }
+ \exe bi -> exe{buildInfo = bi}
-- Adds pkgconfig dependencies to the build info for a test suite
addPkgConfigBITest = addPkgConfigBI testBuildInfo $
- \test bi -> test { testBuildInfo = bi }
+ \test bi -> test{testBuildInfo = bi}
-- Adds pkgconfig dependencies to the build info for a benchmark
addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $
- \bench bi -> bench { benchmarkBuildInfo = bi }
+ \bench bi -> bench{benchmarkBuildInfo = bi}
pkgconfigBuildInfo :: [PkgconfigDependency] -> IO BuildInfo
- pkgconfigBuildInfo [] = return mempty
+ pkgconfigBuildInfo [] = return mempty
pkgconfigBuildInfo pkgdeps = do
- let pkgs = nub [ prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps ]
+ let pkgs = nub [prettyShow pkg | PkgconfigDependency pkg _ <- pkgdeps]
ccflags <- pkgconfig ("--cflags" : pkgs)
- ldflags <- pkgconfig ("--libs" : pkgs)
- ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs)
+ ldflags <- pkgconfig ("--libs" : pkgs)
+ ldflags_static <- pkgconfig ("--libs" : "--static" : pkgs)
return (ccLdOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static))
-- | Makes a 'BuildInfo' from C compiler and linker flags.
@@ -1680,48 +2075,54 @@ configurePkgconfigPackages verbosity pkg_descr progdb enabled
-- > ldflags <- getDbProgramOutput verbosity prog progdb ["--libs"]
-- > ldflags_static <- getDbProgramOutput verbosity prog progdb ["--libs", "--static"]
-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags) (words ldflags_static))
---
ccLdOptionsBuildInfo :: [String] -> [String] -> [String] -> BuildInfo
ccLdOptionsBuildInfo cflags ldflags ldflags_static =
- let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags
- (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags
+ let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags
+ (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags
(extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags'
- (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static
- (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static
- in mempty {
- includeDirs = map (drop 2) includeDirs',
- extraLibs = map (drop 2) extraLibs',
- extraLibDirs = map (drop 2) extraLibDirs',
- extraLibsStatic = map (drop 2) extraLibsStatic',
- extraLibDirsStatic = map (drop 2) extraLibDirsStatic',
- ccOptions = cflags',
- ldOptions = ldflags''
- }
+ (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static
+ (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static
+ in mempty
+ { includeDirs = map (drop 2) includeDirs'
+ , extraLibs = map (drop 2) extraLibs'
+ , extraLibDirs = map (drop 2) extraLibDirs'
+ , extraLibsStatic = map (drop 2) extraLibsStatic'
+ , extraLibDirsStatic = map (drop 2) extraLibDirsStatic'
+ , ccOptions = cflags'
+ , ldOptions = ldflags''
+ }
-- -----------------------------------------------------------------------------
-- Determining the compiler details
-configCompilerAuxEx :: ConfigFlags
- -> IO (Compiler, Platform, ProgramDb)
-configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)
- (flagToMaybe $ configHcPath cfg)
- (flagToMaybe $ configHcPkg cfg)
- programDb
- (fromFlag (configVerbosity cfg))
+configCompilerAuxEx
+ :: ConfigFlags
+ -> IO (Compiler, Platform, ProgramDb)
+configCompilerAuxEx cfg =
+ configCompilerEx
+ (flagToMaybe $ configHcFlavor cfg)
+ (flagToMaybe $ configHcPath cfg)
+ (flagToMaybe $ configHcPkg cfg)
+ programDb
+ (fromFlag (configVerbosity cfg))
where
programDb = mkProgramDb cfg defaultProgramDb
-configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath
- -> ProgramDb -> Verbosity
- -> IO (Compiler, Platform, ProgramDb)
+configCompilerEx
+ :: Maybe CompilerFlavor
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> ProgramDb
+ -> Verbosity
+ -> IO (Compiler, Platform, ProgramDb)
configCompilerEx Nothing _ _ _ verbosity = die' verbosity "Unknown compiler"
configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do
(comp, maybePlatform, programDb) <- case hcFlavor of
- GHC -> GHC.configure verbosity hcPath hcPkg progdb
+ GHC -> GHC.configure verbosity hcPath hcPkg progdb
GHCJS -> GHCJS.configure verbosity hcPath hcPkg progdb
- UHC -> UHC.configure verbosity hcPath hcPkg progdb
- HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg progdb
- _ -> die' verbosity "Unknown compiler"
+ UHC -> UHC.configure verbosity hcPath hcPkg progdb
+ HaskellSuite{} -> HaskellSuite.configure verbosity hcPath hcPkg progdb
+ _ -> die' verbosity "Unknown compiler"
return (comp, fromMaybe buildPlatform maybePlatform, programDb)
-- -----------------------------------------------------------------------------
@@ -1734,235 +2135,282 @@ configCompilerEx (Just hcFlavor) hcPath hcPkg progdb verbosity = do
-- TODO: produce a log file from the compiler errors, if any.
checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()
checkForeignDeps pkg lbi verbosity =
- ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling
- -- lucky
- (return ())
- (do missingLibs <- findMissingLibs
- missingHdr <- findOffendingHdr
- explainErrors missingHdr missingLibs)
- where
- allHeaders = collectField includes
- allLibs = collectField $
- if withFullyStaticExe lbi
+ ifBuildsWith
+ allHeaders
+ (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling
+ -- lucky
+ (return ())
+ ( do
+ missingLibs <- findMissingLibs
+ missingHdr <- findOffendingHdr
+ explainErrors missingHdr missingLibs
+ )
+ where
+ allHeaders = collectField includes
+ allLibs =
+ collectField $
+ if withFullyStaticExe lbi
then extraLibsStatic
else extraLibs
- ifBuildsWith headers args success failure = do
- checkDuplicateHeaders
- ok <- builds (makeProgram headers) args
- if ok then success else failure
+ ifBuildsWith headers args success failure = do
+ checkDuplicateHeaders
+ ok <- builds (makeProgram headers) args
+ if ok then success else failure
- -- Ensure that there is only one header with a given name
- -- in either the generated (most likely by `configure`)
- -- build directory (e.g. `dist/build`) or in the source directory.
- --
- -- If it exists in both, we'll remove the one in the source
- -- directory, as the generated should take precedence.
- --
- -- C compilers like to prefer source local relative includes,
- -- so the search paths provided to the compiler via -I are
- -- ignored if the included file can be found relative to the
- -- including file. As such we need to take drastic measures
- -- and delete the offending file in the source directory.
- checkDuplicateHeaders = do
- let relIncDirs = filter (not . isAbsolute) (collectField includeDirs)
- isHeader = isSuffixOf ".h"
- genHeaders <- for relIncDirs $ \dir ->
- fmap (dir </>) . filter isHeader <$>
- listDirectory (buildDir lbi </> dir) `catchIO` (\_ -> return [])
- srcHeaders <- for relIncDirs $ \dir ->
- fmap (dir </>) . filter isHeader <$>
- listDirectory (baseDir lbi </> dir) `catchIO` (\_ -> return [])
- let commonHeaders = concat genHeaders `intersect` concat srcHeaders
- for_ commonHeaders $ \hdr -> do
- warn verbosity $ "Duplicate header found in "
- ++ (buildDir lbi </> hdr)
- ++ " and "
- ++ (baseDir lbi </> hdr)
- ++ "; removing "
- ++ (baseDir lbi </> hdr)
- removeFile (baseDir lbi </> hdr)
-
- findOffendingHdr =
- ifBuildsWith allHeaders ccArgs
- (return Nothing)
- (go . tail . NEL.inits $ allHeaders)
- where
- go [] = return Nothing -- cannot happen
- go (hdrs:hdrsInits) =
- -- Try just preprocessing first
- ifBuildsWith hdrs cppArgs
- -- If that works, try compiling too
- (ifBuildsWith hdrs ccArgs
- (go hdrsInits)
- (return . fmap Right . safeLast $ hdrs))
- (return . fmap Left . safeLast $ hdrs)
-
-
- cppArgs = "-E":commonCppArgs -- preprocess only
- ccArgs = "-c":commonCcArgs -- don't try to link
-
- findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs)
- (return [])
- (filterM (fmap not . libExists) allLibs)
-
- libExists lib = builds (makeProgram []) (makeLdArgs [lib])
-
- baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi')
-
- commonCppArgs = platformDefines lbi
- -- TODO: This is a massive hack, to work around the
- -- fact that the test performed here should be
- -- PER-component (c.f. the "I'm Feeling Lucky"; we
- -- should NOT be glomming everything together.)
- ++ [ "-I" ++ buildDir lbi </> "autogen" ]
- -- `configure' may generate headers in the build directory
- ++ [ "-I" ++ buildDir lbi </> dir
- | dir <- ordNub (collectField includeDirs)
- , not (isAbsolute dir)]
- -- we might also reference headers from the
- -- packages directory.
- ++ [ "-I" ++ baseDir lbi </> dir
- | dir <- ordNub (collectField includeDirs)
- , not (isAbsolute dir)]
- ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs)
- , isAbsolute dir]
- ++ ["-I" ++ baseDir lbi]
- ++ collectField cppOptions
- ++ collectField ccOptions
- ++ [ "-I" ++ dir
- | dir <- ordNub [ dir
- | dep <- deps
- , dir <- IPI.includeDirs dep ]
- -- dedupe include dirs of dependencies
- -- to prevent quadratic blow-up
- ]
- ++ [ opt
- | dep <- deps
- , opt <- IPI.ccOptions dep ]
-
- commonCcArgs = commonCppArgs
- ++ collectField ccOptions
- ++ [ opt
- | dep <- deps
- , opt <- IPI.ccOptions dep ]
-
- commonLdArgs = [ "-L" ++ dir
- | dir <- ordNub $ collectField (if withFullyStaticExe lbi
- then extraLibDirsStatic
- else extraLibDirs
- ) ]
- ++ collectField ldOptions
- ++ [ "-L" ++ dir
- | dir <- ordNub [ dir
- | dep <- deps
- , dir <- if withFullyStaticExe lbi
- then IPI.libraryDirsStatic dep
- else IPI.libraryDirs dep ]
- ]
- --TODO: do we also need dependent packages' ld options?
- makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs
-
- makeProgram hdrs = unlines $
- [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++
- ["int main(int argc, char** argv) { return 0; }"]
-
- collectField f = concatMap f allBi
- allBi = enabledBuildInfos pkg (componentEnabledSpec lbi)
- deps = PackageIndex.topologicalOrder (installedPkgs lbi)
-
- builds program args = do
- tempDir <- getTemporaryDirectory
- withTempFile tempDir ".c" $ \cName cHnd ->
- withTempFile tempDir "" $ \oNname oHnd -> do
- hPutStrLn cHnd program
- hClose cHnd
- hClose oHnd
- _ <- getDbProgramOutput verbosity
- gccProgram (withPrograms lbi) (cName:"-o":oNname:args)
- return True
- `catchIO` (\_ -> return False)
- `catchExit` (\_ -> return False)
-
- explainErrors Nothing [] = return () -- should be impossible!
- explainErrors _ _
- | isNothing . lookupProgram gccProgram . withPrograms $ lbi
-
- = die' verbosity $ unlines
- [ "No working gcc",
- "This package depends on foreign library but we cannot "
- ++ "find a working C compiler. If you have it in a "
- ++ "non-standard location you can use the --with-gcc "
- ++ "flag to specify it." ]
-
- explainErrors hdr libs = die' verbosity $ unlines $
- [ if plural
- then "Missing dependencies on foreign libraries:"
- else "Missing dependency on a foreign library:"
- | missing ]
- ++ case hdr of
- Just (Left h) -> ["* Missing (or bad) header file: " ++ h ]
- _ -> []
- ++ case libs of
- [] -> []
- [lib] -> ["* Missing (or bad) C library: " ++ lib]
- _ -> ["* Missing (or bad) C libraries: " ++
- intercalate ", " libs]
- ++ [if plural then messagePlural else messageSingular | missing]
- ++ case hdr of
- Just (Left _) -> [ headerCppMessage ]
- Just (Right h) -> [ (if missing then "* " else "")
- ++ "Bad header file: " ++ h
- , headerCcMessage ]
- _ -> []
-
- where
- plural = length libs >= 2
- -- Is there something missing? (as opposed to broken)
- missing = not (null libs)
- || case hdr of Just (Left _) -> True; _ -> False
-
- messageSingular =
- "This problem can usually be solved by installing the system "
- ++ "package that provides this library (you may need the "
- ++ "\"-dev\" version). If the library is already installed "
- ++ "but in a non-standard location then you can use the flags "
- ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "
- ++ "where it is."
- ++ "If the library file does exist, it may contain errors that "
- ++ "are caught by the C compiler at the preprocessing stage. "
- ++ "In this case you can re-run configure with the verbosity "
- ++ "flag -v3 to see the error messages."
- messagePlural =
- "This problem can usually be solved by installing the system "
- ++ "packages that provide these libraries (you may need the "
- ++ "\"-dev\" versions). If the libraries are already installed "
- ++ "but in a non-standard location then you can use the flags "
- ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "
- ++ "where they are."
- ++ "If the library files do exist, it may contain errors that "
- ++ "are caught by the C compiler at the preprocessing stage. "
- ++ "In this case you can re-run configure with the verbosity "
- ++ "flag -v3 to see the error messages."
- headerCppMessage =
- "If the header file does exist, it may contain errors that "
- ++ "are caught by the C compiler at the preprocessing stage. "
- ++ "In this case you can re-run configure with the verbosity "
- ++ "flag -v3 to see the error messages."
- headerCcMessage =
- "The header file contains a compile error. "
- ++ "You can re-run configure with the verbosity flag "
- ++ "-v3 to see the error messages from the C compiler."
+ -- Ensure that there is only one header with a given name
+ -- in either the generated (most likely by `configure`)
+ -- build directory (e.g. `dist/build`) or in the source directory.
+ --
+ -- If it exists in both, we'll remove the one in the source
+ -- directory, as the generated should take precedence.
+ --
+ -- C compilers like to prefer source local relative includes,
+ -- so the search paths provided to the compiler via -I are
+ -- ignored if the included file can be found relative to the
+ -- including file. As such we need to take drastic measures
+ -- and delete the offending file in the source directory.
+ checkDuplicateHeaders = do
+ let relIncDirs = filter (not . isAbsolute) (collectField includeDirs)
+ isHeader = isSuffixOf ".h"
+ genHeaders <- for relIncDirs $ \dir ->
+ fmap (dir </>) . filter isHeader
+ <$> listDirectory (buildDir lbi </> dir) `catchIO` (\_ -> return [])
+ srcHeaders <- for relIncDirs $ \dir ->
+ fmap (dir </>) . filter isHeader
+ <$> listDirectory (baseDir lbi </> dir) `catchIO` (\_ -> return [])
+ let commonHeaders = concat genHeaders `intersect` concat srcHeaders
+ for_ commonHeaders $ \hdr -> do
+ warn verbosity $
+ "Duplicate header found in "
+ ++ (buildDir lbi </> hdr)
+ ++ " and "
+ ++ (baseDir lbi </> hdr)
+ ++ "; removing "
+ ++ (baseDir lbi </> hdr)
+ removeFile (baseDir lbi </> hdr)
+
+ findOffendingHdr =
+ ifBuildsWith
+ allHeaders
+ ccArgs
+ (return Nothing)
+ (go . tail . NEL.inits $ allHeaders)
+ where
+ go [] = return Nothing -- cannot happen
+ go (hdrs : hdrsInits) =
+ -- Try just preprocessing first
+ ifBuildsWith
+ hdrs
+ cppArgs
+ -- If that works, try compiling too
+ ( ifBuildsWith
+ hdrs
+ ccArgs
+ (go hdrsInits)
+ (return . fmap Right . safeLast $ hdrs)
+ )
+ (return . fmap Left . safeLast $ hdrs)
+
+ cppArgs = "-E" : commonCppArgs -- preprocess only
+ ccArgs = "-c" : commonCcArgs -- don't try to link
+ findMissingLibs =
+ ifBuildsWith
+ []
+ (makeLdArgs allLibs)
+ (return [])
+ (filterM (fmap not . libExists) allLibs)
+
+ libExists lib = builds (makeProgram []) (makeLdArgs [lib])
+
+ baseDir lbi' = fromMaybe "." (takeDirectory <$> cabalFilePath lbi')
+
+ commonCppArgs =
+ platformDefines lbi
+ -- TODO: This is a massive hack, to work around the
+ -- fact that the test performed here should be
+ -- PER-component (c.f. the "I'm Feeling Lucky"; we
+ -- should NOT be glomming everything together.)
+ ++ ["-I" ++ buildDir lbi </> "autogen"]
+ -- `configure' may generate headers in the build directory
+ ++ [ "-I" ++ buildDir lbi </> dir
+ | dir <- ordNub (collectField includeDirs)
+ , not (isAbsolute dir)
+ ]
+ -- we might also reference headers from the
+ -- packages directory.
+ ++ [ "-I" ++ baseDir lbi </> dir
+ | dir <- ordNub (collectField includeDirs)
+ , not (isAbsolute dir)
+ ]
+ ++ [ "-I" ++ dir | dir <- ordNub (collectField includeDirs), isAbsolute dir
+ ]
+ ++ ["-I" ++ baseDir lbi]
+ ++ collectField cppOptions
+ ++ collectField ccOptions
+ ++ [ "-I" ++ dir
+ | dir <-
+ ordNub
+ [ dir
+ | dep <- deps
+ , dir <- IPI.includeDirs dep
+ ]
+ -- dedupe include dirs of dependencies
+ -- to prevent quadratic blow-up
+ ]
+ ++ [ opt
+ | dep <- deps
+ , opt <- IPI.ccOptions dep
+ ]
+
+ commonCcArgs =
+ commonCppArgs
+ ++ collectField ccOptions
+ ++ [ opt
+ | dep <- deps
+ , opt <- IPI.ccOptions dep
+ ]
+
+ commonLdArgs =
+ [ "-L" ++ dir
+ | dir <-
+ ordNub $
+ collectField
+ ( if withFullyStaticExe lbi
+ then extraLibDirsStatic
+ else extraLibDirs
+ )
+ ]
+ ++ collectField ldOptions
+ ++ [ "-L" ++ dir
+ | dir <-
+ ordNub
+ [ dir
+ | dep <- deps
+ , dir <-
+ if withFullyStaticExe lbi
+ then IPI.libraryDirsStatic dep
+ else IPI.libraryDirs dep
+ ]
+ ]
+ -- TODO: do we also need dependent packages' ld options?
+ makeLdArgs libs = ["-l" ++ lib | lib <- libs] ++ commonLdArgs
+
+ makeProgram hdrs =
+ unlines $
+ ["#include \"" ++ hdr ++ "\"" | hdr <- hdrs]
+ ++ ["int main(int argc, char** argv) { return 0; }"]
+
+ collectField f = concatMap f allBi
+ allBi = enabledBuildInfos pkg (componentEnabledSpec lbi)
+ deps = PackageIndex.topologicalOrder (installedPkgs lbi)
+
+ builds program args =
+ do
+ tempDir <- getTemporaryDirectory
+ withTempFile tempDir ".c" $ \cName cHnd ->
+ withTempFile tempDir "" $ \oNname oHnd -> do
+ hPutStrLn cHnd program
+ hClose cHnd
+ hClose oHnd
+ _ <-
+ getDbProgramOutput
+ verbosity
+ gccProgram
+ (withPrograms lbi)
+ (cName : "-o" : oNname : args)
+ return True
+ `catchIO` (\_ -> return False)
+ `catchExit` (\_ -> return False)
+
+ explainErrors Nothing [] = return () -- should be impossible!
+ explainErrors _ _
+ | isNothing . lookupProgram gccProgram . withPrograms $ lbi =
+ die' verbosity $
+ unlines
+ [ "No working gcc"
+ , "This package depends on foreign library but we cannot "
+ ++ "find a working C compiler. If you have it in a "
+ ++ "non-standard location you can use the --with-gcc "
+ ++ "flag to specify it."
+ ]
+ explainErrors hdr libs =
+ die' verbosity $
+ unlines $
+ [ if plural
+ then "Missing dependencies on foreign libraries:"
+ else "Missing dependency on a foreign library:"
+ | missing
+ ]
+ ++ case hdr of
+ Just (Left h) -> ["* Missing (or bad) header file: " ++ h]
+ _ -> []
+ ++ case libs of
+ [] -> []
+ [lib] -> ["* Missing (or bad) C library: " ++ lib]
+ _ ->
+ [ "* Missing (or bad) C libraries: "
+ ++ intercalate ", " libs
+ ]
+ ++ [if plural then messagePlural else messageSingular | missing]
+ ++ case hdr of
+ Just (Left _) -> [headerCppMessage]
+ Just (Right h) ->
+ [ (if missing then "* " else "")
+ ++ "Bad header file: "
+ ++ h
+ , headerCcMessage
+ ]
+ _ -> []
+ where
+ plural = length libs >= 2
+ -- Is there something missing? (as opposed to broken)
+ missing =
+ not (null libs)
+ || case hdr of Just (Left _) -> True; _ -> False
+
+ messageSingular =
+ "This problem can usually be solved by installing the system "
+ ++ "package that provides this library (you may need the "
+ ++ "\"-dev\" version). If the library is already installed "
+ ++ "but in a non-standard location then you can use the flags "
+ ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "
+ ++ "where it is."
+ ++ "If the library file does exist, it may contain errors that "
+ ++ "are caught by the C compiler at the preprocessing stage. "
+ ++ "In this case you can re-run configure with the verbosity "
+ ++ "flag -v3 to see the error messages."
+ messagePlural =
+ "This problem can usually be solved by installing the system "
+ ++ "packages that provide these libraries (you may need the "
+ ++ "\"-dev\" versions). If the libraries are already installed "
+ ++ "but in a non-standard location then you can use the flags "
+ ++ "--extra-include-dirs= and --extra-lib-dirs= to specify "
+ ++ "where they are."
+ ++ "If the library files do exist, it may contain errors that "
+ ++ "are caught by the C compiler at the preprocessing stage. "
+ ++ "In this case you can re-run configure with the verbosity "
+ ++ "flag -v3 to see the error messages."
+ headerCppMessage =
+ "If the header file does exist, it may contain errors that "
+ ++ "are caught by the C compiler at the preprocessing stage. "
+ ++ "In this case you can re-run configure with the verbosity "
+ ++ "flag -v3 to see the error messages."
+ headerCcMessage =
+ "The header file contains a compile error. "
+ ++ "You can re-run configure with the verbosity flag "
+ ++ "-v3 to see the error messages from the C compiler."
-- | Output package check warnings and errors. Exit if any errors.
-checkPackageProblems :: Verbosity
- -> FilePath
- -- ^ Path to the @.cabal@ file's directory
- -> GenericPackageDescription
- -> PackageDescription
- -> IO ()
+checkPackageProblems
+ :: Verbosity
+ -> FilePath
+ -- ^ Path to the @.cabal@ file's directory
+ -> GenericPackageDescription
+ -> PackageDescription
+ -> IO ()
checkPackageProblems verbosity dir gpkg pkg = do
- ioChecks <- checkPackageFiles verbosity pkg dir
+ ioChecks <- checkPackageFiles verbosity pkg dir
let pureChecks = checkPackage gpkg (Just pkg)
(errors, warnings) =
partitionEithers (M.mapMaybe classEW $ pureChecks ++ ioChecks)
@@ -1979,158 +2427,193 @@ checkPackageProblems verbosity dir gpkg pkg = do
classEW (PackageDistInexcusable _) = Nothing
-- | Preform checks if a relocatable build is allowed
-checkRelocatable :: Verbosity
- -> PackageDescription
- -> LocalBuildInfo
- -> IO ()
-checkRelocatable verbosity pkg lbi
- = sequence_ [ checkOS
- , checkCompiler
- , packagePrefixRelative
- , depsPrefixRelative
- ]
+checkRelocatable
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> IO ()
+checkRelocatable verbosity pkg lbi =
+ sequence_
+ [ checkOS
+ , checkCompiler
+ , packagePrefixRelative
+ , depsPrefixRelative
+ ]
where
-- Check if the OS support relocatable builds.
--
-- If you add new OS' to this list, and your OS supports dynamic libraries
-- and RPATH, make sure you add your OS to RPATH-support list of:
-- Distribution.Simple.GHC.getRPaths
- checkOS
- = unless (os `elem` [ OSX, Linux ])
- $ die' verbosity $ "Operating system: " ++ prettyShow os ++
- ", does not support relocatable builds"
+ checkOS =
+ unless (os `elem` [OSX, Linux]) $
+ die' verbosity $
+ "Operating system: "
+ ++ prettyShow os
+ ++ ", does not support relocatable builds"
where
(Platform _ os) = hostPlatform lbi
-- Check if the Compiler support relocatable builds
- checkCompiler
- = unless (compilerFlavor comp `elem` [ GHC ])
- $ die' verbosity $ "Compiler: " ++ show comp ++
- ", does not support relocatable builds"
+ checkCompiler =
+ unless (compilerFlavor comp `elem` [GHC]) $
+ die' verbosity $
+ "Compiler: "
+ ++ show comp
+ ++ ", does not support relocatable builds"
where
comp = compiler lbi
-- Check if all the install dirs are relative to same prefix
- packagePrefixRelative
- = unless (relativeInstallDirs installDirs)
- $ die' verbosity $ "Installation directories are not prefix_relative:\n" ++
- show installDirs
+ packagePrefixRelative =
+ unless (relativeInstallDirs installDirs) $
+ die' verbosity $
+ "Installation directories are not prefix_relative:\n"
+ ++ show installDirs
where
-- NB: should be good enough to check this against the default
-- component ID, but if we wanted to be strictly correct we'd
-- check for each ComponentId.
installDirs = absoluteInstallDirs pkg lbi NoCopyDest
- p = prefix installDirs
- relativeInstallDirs (InstallDirs {..}) =
- all isJust
- (fmap (stripPrefix p)
- [ bindir, libdir, dynlibdir, libexecdir, includedir, datadir
- , docdir, mandir, htmldir, haddockdir, sysconfdir] )
+ p = prefix installDirs
+ relativeInstallDirs (InstallDirs{..}) =
+ all
+ isJust
+ ( fmap
+ (stripPrefix p)
+ [ bindir
+ , libdir
+ , dynlibdir
+ , libexecdir
+ , includedir
+ , datadir
+ , docdir
+ , mandir
+ , htmldir
+ , haddockdir
+ , sysconfdir
+ ]
+ )
-- Check if the library dirs of the dependencies that are in the package
-- database to which the package is installed are relative to the
-- prefix of the package
depsPrefixRelative = do
- pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi))
- traverse_ (doCheck pkgr) ipkgs
+ pkgr <- GHC.pkgRoot verbosity lbi (registrationPackageDB (withPackageDB lbi))
+ traverse_ (doCheck pkgr) ipkgs
where
doCheck pkgr ipkg
- | maybe False (== pkgr) (IPI.pkgRoot ipkg)
- = for_ (IPI.libraryDirs ipkg) $ \libdir -> do
- -- When @prefix@ is not under @pkgroot@,
- -- @shortRelativePath prefix pkgroot@ will return a path with
- -- @..@s and following check will fail without @canonicalizePath@.
- canonicalized <- canonicalizePath libdir
- unless (p `isPrefixOf` canonicalized) $
- die' verbosity $ msg libdir
- | otherwise
- = return ()
+ | maybe False (== pkgr) (IPI.pkgRoot ipkg) =
+ for_ (IPI.libraryDirs ipkg) $ \libdir -> do
+ -- When @prefix@ is not under @pkgroot@,
+ -- @shortRelativePath prefix pkgroot@ will return a path with
+ -- @..@s and following check will fail without @canonicalizePath@.
+ canonicalized <- canonicalizePath libdir
+ unless (p `isPrefixOf` canonicalized) $
+ die' verbosity $
+ msg libdir
+ | otherwise =
+ return ()
-- NB: should be good enough to check this against the default
-- component ID, but if we wanted to be strictly correct we'd
-- check for each ComponentId.
- installDirs = absoluteInstallDirs pkg lbi NoCopyDest
- p = prefix installDirs
- ipkgs = PackageIndex.allPackages (installedPkgs lbi)
- msg l = "Library directory of a dependency: " ++ show l ++
- "\nis not relative to the installation prefix:\n" ++
- show p
+ installDirs = absoluteInstallDirs pkg lbi NoCopyDest
+ p = prefix installDirs
+ ipkgs = PackageIndex.allPackages (installedPkgs lbi)
+ msg l =
+ "Library directory of a dependency: "
+ ++ show l
+ ++ "\nis not relative to the installation prefix:\n"
+ ++ show p
-- -----------------------------------------------------------------------------
-- Testing foreign library requirements
unsupportedForeignLibs :: Compiler -> Platform -> [ForeignLib] -> [String]
unsupportedForeignLibs comp platform =
- mapMaybe (checkForeignLibSupported comp platform)
+ mapMaybe (checkForeignLibSupported comp platform)
checkForeignLibSupported :: Compiler -> Platform -> ForeignLib -> Maybe String
checkForeignLibSupported comp platform flib = go (compilerFlavor comp)
where
go :: CompilerFlavor -> Maybe String
go GHC
- | compilerVersion comp < mkVersion [7,8] = unsupported [
- "Building foreign libraries is only supported with GHC >= 7.8"
- ]
+ | compilerVersion comp < mkVersion [7, 8] =
+ unsupported
+ [ "Building foreign libraries is only supported with GHC >= 7.8"
+ ]
| otherwise = goGhcPlatform platform
- go _ = unsupported [
- "Building foreign libraries is currently only supported with ghc"
- ]
+ go _ =
+ unsupported
+ [ "Building foreign libraries is currently only supported with ghc"
+ ]
goGhcPlatform :: Platform -> Maybe String
- goGhcPlatform (Platform _ OSX ) = goGhcOsx (foreignLibType flib)
- goGhcPlatform (Platform _ Linux ) = goGhcLinux (foreignLibType flib)
- goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib)
+ goGhcPlatform (Platform _ OSX) = goGhcOsx (foreignLibType flib)
+ goGhcPlatform (Platform _ Linux) = goGhcLinux (foreignLibType flib)
+ goGhcPlatform (Platform I386 Windows) = goGhcWindows (foreignLibType flib)
goGhcPlatform (Platform X86_64 Windows) = goGhcWindows (foreignLibType flib)
- goGhcPlatform _ = unsupported [
- "Building foreign libraries is currently only supported on Mac OS, "
- , "Linux and Windows"
- ]
+ goGhcPlatform _ =
+ unsupported
+ [ "Building foreign libraries is currently only supported on Mac OS, "
+ , "Linux and Windows"
+ ]
goGhcOsx :: ForeignLibType -> Maybe String
goGhcOsx ForeignLibNativeShared
- | not (null (foreignLibModDefFile flib)) = unsupported [
- "Module definition file not supported on OSX"
- ]
- | not (null (foreignLibVersionInfo flib)) = unsupported [
- "Foreign library versioning not currently supported on OSX"
- ]
+ | not (null (foreignLibModDefFile flib)) =
+ unsupported
+ [ "Module definition file not supported on OSX"
+ ]
+ | not (null (foreignLibVersionInfo flib)) =
+ unsupported
+ [ "Foreign library versioning not currently supported on OSX"
+ ]
| otherwise =
Nothing
- goGhcOsx _ = unsupported [
- "We can currently only build shared foreign libraries on OSX"
- ]
+ goGhcOsx _ =
+ unsupported
+ [ "We can currently only build shared foreign libraries on OSX"
+ ]
goGhcLinux :: ForeignLibType -> Maybe String
goGhcLinux ForeignLibNativeShared
- | not (null (foreignLibModDefFile flib)) = unsupported [
- "Module definition file not supported on Linux"
- ]
+ | not (null (foreignLibModDefFile flib)) =
+ unsupported
+ [ "Module definition file not supported on Linux"
+ ]
| not (null (foreignLibVersionInfo flib))
- && not (null (foreignLibVersionLinux flib)) = unsupported [
- "You must not specify both lib-version-info and lib-version-linux"
- ]
+ && not (null (foreignLibVersionLinux flib)) =
+ unsupported
+ [ "You must not specify both lib-version-info and lib-version-linux"
+ ]
| otherwise =
Nothing
- goGhcLinux _ = unsupported [
- "We can currently only build shared foreign libraries on Linux"
- ]
+ goGhcLinux _ =
+ unsupported
+ [ "We can currently only build shared foreign libraries on Linux"
+ ]
goGhcWindows :: ForeignLibType -> Maybe String
goGhcWindows ForeignLibNativeShared
- | not standalone = unsupported [
- "We can currently only build standalone libraries on Windows. Use\n"
- , " if os(Windows)\n"
- , " options: standalone\n"
- , "in your foreign-library stanza."
- ]
- | not (null (foreignLibVersionInfo flib)) = unsupported [
- "Foreign library versioning not currently supported on Windows.\n"
- , "You can specify module definition files in the mod-def-file field."
- ]
+ | not standalone =
+ unsupported
+ [ "We can currently only build standalone libraries on Windows. Use\n"
+ , " if os(Windows)\n"
+ , " options: standalone\n"
+ , "in your foreign-library stanza."
+ ]
+ | not (null (foreignLibVersionInfo flib)) =
+ unsupported
+ [ "Foreign library versioning not currently supported on Windows.\n"
+ , "You can specify module definition files in the mod-def-file field."
+ ]
| otherwise =
- Nothing
- goGhcWindows _ = unsupported [
- "We can currently only build shared foreign libraries on Windows"
- ]
+ Nothing
+ goGhcWindows _ =
+ unsupported
+ [ "We can currently only build shared foreign libraries on Windows"
+ ]
standalone :: Bool
standalone = ForeignLibStandalone `elem` foreignLibOptions flib
diff --git a/Cabal/src/Distribution/Simple/ConfigureScript.hs b/Cabal/src/Distribution/Simple/ConfigureScript.hs
index 23ad94f0d7516abe1d716c4fcb5ba034435a800f..a97e9dbed468e9b385039f85c893a250681384e1 100644
--- a/Cabal/src/Distribution/Simple/ConfigureScript.hs
+++ b/Cabal/src/Distribution/Simple/ConfigureScript.hs
@@ -1,9 +1,11 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
-- |
-- Module : Distribution.Simple.ConfigureScript
-- Copyright : Isaac Jones 2003-2005
@@ -11,15 +13,12 @@
--
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
---
-{-# OPTIONS_GHC -fno-warn-deprecations #-}
-
-module Distribution.Simple.ConfigureScript (
- runConfigureScript
+module Distribution.Simple.ConfigureScript
+ ( runConfigureScript
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-- local
import Distribution.PackageDescription
@@ -28,28 +27,36 @@ import Distribution.Simple.Program.Db
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Config
+import Distribution.Pretty
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Utils
+import Distribution.System (buildPlatform)
import Distribution.Utils.NubList
import Distribution.Verbosity
-import Distribution.Pretty
-import Distribution.System (buildPlatform)
-- Base
-import System.FilePath (searchPathSeparator, takeDirectory, (</>),
- splitDirectories, dropDrive)
+import System.FilePath
+ ( dropDrive
+ , searchPathSeparator
+ , splitDirectories
+ , takeDirectory
+ , (</>)
+ )
#ifdef mingw32_HOST_OS
import System.FilePath (normalise, splitDrive)
#endif
-import Distribution.Compat.Directory (makeAbsolute)
-import Distribution.Compat.Environment (getEnvironment)
+import Distribution.Compat.Directory (makeAbsolute)
+import Distribution.Compat.Environment (getEnvironment)
import Distribution.Compat.GetShortPathName (getShortPathName)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
-runConfigureScript :: Verbosity -> ConfigFlags -> LocalBuildInfo
- -> IO ()
+runConfigureScript
+ :: Verbosity
+ -> ConfigFlags
+ -> LocalBuildInfo
+ -> IO ()
runConfigureScript verbosity flags lbi = do
env <- getEnvironment
let programDb = withPrograms lbi
@@ -61,8 +68,9 @@ runConfigureScript verbosity flags lbi = do
-- to ccFlags
-- We don't try and tell configure which ld to use, as we don't have
-- a way to pass its flags too
- configureFile <- makeAbsolute $
- fromMaybe "." (takeDirectory <$> cabalFilePath lbi) </> "configure"
+ configureFile <-
+ makeAbsolute $
+ fromMaybe "." (takeDirectory <$> cabalFilePath lbi) </> "configure"
-- autoconf is fussy about filenames, and has a set of forbidden
-- characters that can't appear in the build directory, etc:
-- https://www.gnu.org/software/autoconf/manual/autoconf.html#File-System-Conventions
@@ -79,30 +87,40 @@ runConfigureScript verbosity flags lbi = do
let configureFile' = toUnix configureFile
for_ badAutoconfCharacters $ \(c, cname) ->
when (c `elem` dropDrive configureFile') $
- warn verbosity $ concat
- [ "The path to the './configure' script, '", configureFile'
- , "', contains the character '", [c], "' (", cname, ")."
- , " This may cause the script to fail with an obscure error, or for"
- , " building the package to fail later."
- ]
+ warn verbosity $
+ concat
+ [ "The path to the './configure' script, '"
+ , configureFile'
+ , "', contains the character '"
+ , [c]
+ , "' ("
+ , cname
+ , ")."
+ , " This may cause the script to fail with an obscure error, or for"
+ , " building the package to fail later."
+ ]
- let -- Convert a flag name to name of environment variable to represent its
- -- value for the configure script.
- flagEnvVar :: FlagName -> String
- flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag)
- where f c
- | isAlphaNum c = c
- | otherwise = '_'
- -- A map from such env vars to every flag name and value where the name
- -- name maps to that that env var.
- cabalFlagMap :: Map String (NonEmpty (FlagName, Bool))
- cabalFlagMap = Map.fromListWith (<>)
- [ (flagEnvVar flag, (flag, bool) :| [])
- | (flag, bool) <- unFlagAssignment $ flagAssignment lbi
- ]
+ let
+ -- Convert a flag name to name of environment variable to represent its
+ -- value for the configure script.
+ flagEnvVar :: FlagName -> String
+ flagEnvVar flag = "CABAL_FLAG_" ++ map f (unFlagName flag)
+ where
+ f c
+ | isAlphaNum c = c
+ | otherwise = '_'
+ -- A map from such env vars to every flag name and value where the name
+ -- name maps to that that env var.
+ cabalFlagMap :: Map String (NonEmpty (FlagName, Bool))
+ cabalFlagMap =
+ Map.fromListWith
+ (<>)
+ [ (flagEnvVar flag, (flag, bool) :| [])
+ | (flag, bool) <- unFlagAssignment $ flagAssignment lbi
+ ]
-- A map from env vars to flag names to the single flag we will go with
cabalFlagMapDeconflicted :: Map String (FlagName, Bool) <-
- flip Map.traverseWithKey cabalFlagMap $ \ envVar -> \case
+ flip Map.traverseWithKey cabalFlagMap $ \envVar -> \case
-- No conflict: no problem
singleFlag :| [] -> pure singleFlag
-- Conflict: warn and discard all but first
@@ -110,52 +128,71 @@ runConfigureScript verbosity flags lbi = do
let quote s = "'" ++ s ++ "'"
toName = quote . unFlagName . fst
renderedList = intercalate ", " $ NonEmpty.toList $ toName <$> collidingFlags
- warn verbosity $ unwords
- [ "Flags", renderedList, "all map to the same environment variable"
- , quote envVar, "causing a collision."
- , "The value first flag", toName firstFlag, "will be used."
- ]
+ warn verbosity $
+ unwords
+ [ "Flags"
+ , renderedList
+ , "all map to the same environment variable"
+ , quote envVar
+ , "causing a collision."
+ , "The value first flag"
+ , toName firstFlag
+ , "will be used."
+ ]
pure firstFlag
- let cabalFlagEnv = [ (envVar, Just val)
- | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted
- , let val = if bool then "1" else "0"
- ] ++
- [ ( "CABAL_FLAGS"
- , Just $ unwords [ showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi ]
- )
- ]
+ let cabalFlagEnv =
+ [ (envVar, Just val)
+ | (envVar, (_, bool)) <- Map.toList cabalFlagMapDeconflicted
+ , let val = if bool then "1" else "0"
+ ]
+ ++ [
+ ( "CABAL_FLAGS"
+ , Just $ unwords [showFlagValue fv | fv <- unFlagAssignment $ flagAssignment lbi]
+ )
+ ]
let extraPath = fromNubList $ configProgramPathExtra flags
- let cflagsEnv = maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags))
- $ lookup "CFLAGS" env
+ let cflagsEnv =
+ maybe (unwords ccFlags) (++ (" " ++ unwords ccFlags)) $
+ lookup "CFLAGS" env
spSep = [searchPathSeparator]
- pathEnv = maybe (intercalate spSep extraPath)
- ((intercalate spSep extraPath ++ spSep)++) $ lookup "PATH" env
- overEnv = ("CFLAGS", Just cflagsEnv) :
- [("PATH", Just pathEnv) | not (null extraPath)] ++
- cabalFlagEnv
+ pathEnv =
+ maybe
+ (intercalate spSep extraPath)
+ ((intercalate spSep extraPath ++ spSep) ++)
+ $ lookup "PATH" env
+ overEnv =
+ ("CFLAGS", Just cflagsEnv)
+ : [("PATH", Just pathEnv) | not (null extraPath)]
+ ++ cabalFlagEnv
hp = hostPlatform lbi
maybeHostFlag = if hp == buildPlatform then [] else ["--host=" ++ show (pretty hp)]
- args' = configureFile':args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag
+ args' = configureFile' : args ++ ["CC=" ++ ccProgShort] ++ maybeHostFlag
shProg = simpleProgram "sh"
- progDb = modifyProgramSearchPath
- (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
- shConfiguredProg <- lookupProgram shProg
- `fmap` configureProgram verbosity shProg progDb
+ progDb =
+ modifyProgramSearchPath
+ (\p -> map ProgramSearchPathDir extraPath ++ p)
+ emptyProgramDb
+ shConfiguredProg <-
+ lookupProgram shProg
+ `fmap` configureProgram verbosity shProg progDb
case shConfiguredProg of
- Just sh -> runProgramInvocation verbosity $
- (programInvocation (sh {programOverrideEnv = overEnv}) args')
- { progInvokeCwd = Just (buildDir lbi) }
- Nothing -> die' verbosity notFoundMsg
+ Just sh ->
+ runProgramInvocation verbosity $
+ (programInvocation (sh{programOverrideEnv = overEnv}) args')
+ { progInvokeCwd = Just (buildDir lbi)
+ }
+ Nothing -> die' verbosity notFoundMsg
where
args = configureArgs backwardsCompatHack flags
backwardsCompatHack = False
- notFoundMsg = "The package has a './configure' script. "
- ++ "If you are on Windows, This requires a "
- ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
- ++ "If you are not on Windows, ensure that an 'sh' command "
- ++ "is discoverable in your path."
+ notFoundMsg =
+ "The package has a './configure' script. "
+ ++ "If you are on Windows, This requires a "
+ ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin. "
+ ++ "If you are not on Windows, ensure that an 'sh' command "
+ ++ "is discoverable in your path."
-- | Convert Windows path to Unix ones
toUnix :: String -> String
diff --git a/Cabal/src/Distribution/Simple/Flag.hs b/Cabal/src/Distribution/Simple/Flag.hs
index 705be2eb55797bc257609df2022a01f66ee622ea..aa35c904c4f6fa6cf94ea8b9172eb519e4738448 100644
--- a/Cabal/src/Distribution/Simple/Flag.hs
+++ b/Cabal/src/Distribution/Simple/Flag.hs
@@ -2,7 +2,9 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Flag
-- Copyright : Isaac Jones 2003-2004
@@ -17,24 +19,27 @@
-- for an explanation.
--
-- Split off from "Distribution.Simple.Setup" to break import cycles.
-module Distribution.Simple.Flag (
- Flag(..),
- allFlags,
- toFlag,
- fromFlag,
- fromFlagOrDefault,
- flagElim,
- flagToMaybe,
- flagToList,
- maybeToFlag,
- BooleanFlag(..) ) where
+module Distribution.Simple.Flag
+ ( Flag (..)
+ , allFlags
+ , toFlag
+ , fromFlag
+ , fromFlagOrDefault
+ , flagElim
+ , flagToMaybe
+ , flagToList
+ , maybeToFlag
+ , BooleanFlag (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
import Distribution.Compat.Stack
+import Prelude ()
-- ------------------------------------------------------------
+
-- * Flag type
+
-- ------------------------------------------------------------
-- | All flags are monoids, they come in two flavours:
@@ -53,7 +58,6 @@ import Distribution.Compat.Stack
-- So this Flag type is for the latter singular kind of flag.
-- Its monoid instance gives us the behaviour where it starts out as
-- 'NoFlag' and later flags override earlier ones.
---
data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable, Foldable, Traversable)
instance Binary a => Binary (Flag a)
@@ -61,11 +65,11 @@ instance Structured a => Structured (Flag a)
instance Functor Flag where
fmap f (Flag x) = Flag (f x)
- fmap _ NoFlag = NoFlag
+ fmap _ NoFlag = NoFlag
instance Applicative Flag where
(Flag x) <*> y = x <$> y
- NoFlag <*> _ = NoFlag
+ NoFlag <*> _ = NoFlag
pure = Flag
instance Monoid (Flag a) where
@@ -74,7 +78,7 @@ instance Monoid (Flag a) where
instance Semigroup (Flag a) where
_ <> f@(Flag _) = f
- f <> NoFlag = f
+ f <> NoFlag = f
instance Bounded a => Bounded (Flag a) where
minBound = toFlag minBound
@@ -82,52 +86,53 @@ instance Bounded a => Bounded (Flag a) where
instance Enum a => Enum (Flag a) where
fromEnum = fromEnum . fromFlag
- toEnum = toFlag . toEnum
+ toEnum = toFlag . toEnum
enumFrom (Flag a) = map toFlag . enumFrom $ a
- enumFrom _ = []
+ enumFrom _ = []
enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b
- enumFromThen _ _ = []
- enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b
- enumFromTo _ _ = []
+ enumFromThen _ _ = []
+ enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b
+ enumFromTo _ _ = []
enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c
- enumFromThenTo _ _ _ = []
+ enumFromThenTo _ _ _ = []
toFlag :: a -> Flag a
toFlag = Flag
fromFlag :: WithCallStack (Flag a -> a)
fromFlag (Flag x) = x
-fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault"
+fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault"
fromFlagOrDefault :: a -> Flag a -> a
-fromFlagOrDefault _ (Flag x) = x
-fromFlagOrDefault def NoFlag = def
+fromFlagOrDefault _ (Flag x) = x
+fromFlagOrDefault def NoFlag = def
flagToMaybe :: Flag a -> Maybe a
flagToMaybe (Flag x) = Just x
-flagToMaybe NoFlag = Nothing
+flagToMaybe NoFlag = Nothing
-- | @since 3.4.0.0
flagElim :: b -> (a -> b) -> Flag a -> b
-flagElim n _ NoFlag = n
+flagElim n _ NoFlag = n
flagElim _ f (Flag x) = f x
flagToList :: Flag a -> [a]
flagToList (Flag x) = [x]
-flagToList NoFlag = []
+flagToList NoFlag = []
allFlags :: [Flag Bool] -> Flag Bool
-allFlags flags = if all (\f -> fromFlagOrDefault False f) flags
- then Flag True
- else NoFlag
+allFlags flags =
+ if all (\f -> fromFlagOrDefault False f) flags
+ then Flag True
+ else NoFlag
maybeToFlag :: Maybe a -> Flag a
-maybeToFlag Nothing = NoFlag
+maybeToFlag Nothing = NoFlag
maybeToFlag (Just x) = Flag x
-- | Types that represent boolean flags.
class BooleanFlag a where
- asBool :: a -> Bool
+ asBool :: a -> Bool
instance BooleanFlag Bool where
asBool = id
diff --git a/Cabal/src/Distribution/Simple/GHC.hs b/Cabal/src/Distribution/Simple/GHC.hs
index 57102bfbdb64b1db297af18ab45e6182d14ded38..9676cc27487983de6a9e3a73082f774b394e879c 100644
--- a/Cabal/src/Distribution/Simple/GHC.hs
+++ b/Cabal/src/Distribution/Simple/GHC.hs
@@ -1,10 +1,11 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.GHC
-- Copyright : Isaac Jones 2003-2007
@@ -35,93 +36,111 @@
-- remembering the layout of files in the build directory (which is not
-- explicitly documented) and thus what search dirs are used for various kinds
-- of files.
+module Distribution.Simple.GHC
+ ( getGhcInfo
+ , configure
+ , getInstalledPackages
+ , getInstalledPackagesMonitorFiles
+ , getPackageDBContents
+ , buildLib
+ , buildFLib
+ , buildExe
+ , replLib
+ , replFLib
+ , replExe
+ , startInterpreter
+ , installLib
+ , installFLib
+ , installExe
+ , libAbiHash
+ , hcPkgInfo
+ , registerPackage
+ , componentGhcOptions
+ , componentCcGhcOptions
+ , getGhcAppDir
+ , getLibDir
+ , isDynamic
+ , getGlobalPackageDB
+ , pkgRoot
+
+ -- * Constructing and deconstructing GHC environment files
+ , Internal.GhcEnvironmentFileEntry (..)
+ , Internal.simpleGhcEnvironmentFile
+ , Internal.renderGhcEnvironmentFile
+ , Internal.writeGhcEnvironmentFile
+ , Internal.ghcPlatformAndVersionString
+ , readGhcEnvironmentFile
+ , parseGhcEnvironmentFile
+ , ParseErrorExc (..)
+
+ -- * Version-specific implementation quirks
+ , getImplInfo
+ , GhcImplInfo (..)
+ ) where
-module Distribution.Simple.GHC (
- getGhcInfo,
- configure,
- getInstalledPackages,
- getInstalledPackagesMonitorFiles,
- getPackageDBContents,
- buildLib, buildFLib, buildExe,
- replLib, replFLib, replExe,
- startInterpreter,
- installLib, installFLib, installExe,
- libAbiHash,
- hcPkgInfo,
- registerPackage,
- componentGhcOptions,
- componentCcGhcOptions,
- getGhcAppDir,
- getLibDir,
- isDynamic,
- getGlobalPackageDB,
- pkgRoot,
- -- * Constructing and deconstructing GHC environment files
- Internal.GhcEnvironmentFileEntry(..),
- Internal.simpleGhcEnvironmentFile,
- Internal.renderGhcEnvironmentFile,
- Internal.writeGhcEnvironmentFile,
- Internal.ghcPlatformAndVersionString,
- readGhcEnvironmentFile,
- parseGhcEnvironmentFile,
- ParseErrorExc(..),
- -- * Version-specific implementation quirks
- getImplInfo,
- GhcImplInfo(..)
- ) where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.CabalSpecVersion
-import Distribution.Simple.GHC.ImplInfo
-import Distribution.Simple.GHC.EnvironmentParser
-import Distribution.PackageDescription.Utils (cabalBug)
-import Distribution.PackageDescription as PD
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+import Distribution.ModuleName (ModuleName)
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.Package
+import Distribution.PackageDescription as PD
+import Distribution.PackageDescription.Utils (cabalBug)
+import Distribution.Pretty
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.Compiler
+import Distribution.Simple.Flag (Flag (Flag), fromFlag, fromFlagOrDefault, toFlag)
+import Distribution.Simple.GHC.EnvironmentParser
+import Distribution.Simple.GHC.ImplInfo
+import qualified Distribution.Simple.GHC.Internal as Internal
+import qualified Distribution.Simple.Hpc as Hpc
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Simple.LocalBuildInfo
-import Distribution.Types.ComponentLocalBuildInfo
-import qualified Distribution.Simple.Hpc as Hpc
-import Distribution.Simple.BuildPaths
-import Distribution.Simple.Utils
-import Distribution.Package
-import qualified Distribution.ModuleName as ModuleName
-import Distribution.ModuleName (ModuleName)
import Distribution.Simple.Program
+import qualified Distribution.Simple.Program.Ar as Ar
import Distribution.Simple.Program.Builtin (runghcProgram)
+import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
-import qualified Distribution.Simple.Program.Ar as Ar
-import qualified Distribution.Simple.Program.Ld as Ld
+import qualified Distribution.Simple.Program.Ld as Ld
import qualified Distribution.Simple.Program.Strip as Strip
-import Distribution.Simple.Program.GHC
-import Distribution.Simple.Flag ( Flag(Flag), fromFlag, fromFlagOrDefault, toFlag )
import Distribution.Simple.Setup.Config
import Distribution.Simple.Setup.Repl
-import Distribution.Simple.Compiler
-import Distribution.Version
+import Distribution.Simple.Utils
import Distribution.System
+import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.PackageName.Magic
-import Distribution.Verbosity
-import Distribution.Pretty
import Distribution.Utils.NubList
import Distribution.Utils.Path
+import Distribution.Verbosity
+import Distribution.Version
import Language.Haskell.Extension
-import Control.Monad (msum, forM_)
+import Control.Monad (forM_, msum)
import Data.Char (isLower)
import qualified Data.Map as Map
import System.Directory
- ( doesFileExist, doesDirectoryExist
- , getAppUserDataDirectory, createDirectoryIfMissing
- , canonicalizePath, removeFile, renameFile, getDirectoryContents
- , makeRelativeToCurrentDirectory, doesDirectoryExist )
-import System.FilePath ( (</>), (<.>), takeExtension
- , takeDirectory, replaceExtension
- ,isRelative )
+ ( canonicalizePath
+ , createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ , getAppUserDataDirectory
+ , getDirectoryContents
+ , makeRelativeToCurrentDirectory
+ , removeFile
+ , renameFile
+ )
+import System.FilePath
+ ( isRelative
+ , replaceExtension
+ , takeDirectory
+ , takeExtension
+ , (<.>)
+ , (</>)
+ )
import qualified System.Info
#ifndef mingw32_HOST_OS
import System.Posix (createSymbolicLink)
@@ -130,86 +149,112 @@ import System.Posix (createSymbolicLink)
-- -----------------------------------------------------------------------------
-- Configuring
-configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramDb
- -> IO (Compiler, Maybe Platform, ProgramDb)
+configure
+ :: Verbosity
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> ProgramDb
+ -> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity hcPath hcPkgPath conf0 = do
-
(ghcProg, ghcVersion, progdb1) <-
- requireProgramVersion verbosity ghcProgram
- (orLaterVersion (mkVersion [7,0,1]))
+ requireProgramVersion
+ verbosity
+ ghcProgram
+ (orLaterVersion (mkVersion [7, 0, 1]))
(userMaybeSpecifyPath "ghc" hcPath conf0)
let implInfo = ghcVersionImplInfo ghcVersion
-- Cabal currently supports ghc >= 7.0.1 && < 9.8
-- ... and the following odd development version
- unless (ghcVersion < mkVersion [9,8]) $
+ unless (ghcVersion < mkVersion [9, 8]) $
warn verbosity $
- "Unknown/unsupported 'ghc' version detected "
- ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 9.8): "
- ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion
+ "Unknown/unsupported 'ghc' version detected "
+ ++ "(Cabal "
+ ++ prettyShow cabalVersion
+ ++ " supports 'ghc' version < 9.8): "
+ ++ programPath ghcProg
+ ++ " is version "
+ ++ prettyShow ghcVersion
-- This is slightly tricky, we have to configure ghc first, then we use the
-- location of ghc to help find ghc-pkg in the case that the user did not
-- specify the location of ghc-pkg directly:
(ghcPkgProg, ghcPkgVersion, progdb2) <-
- requireProgramVersion verbosity ghcPkgProgram {
- programFindLocation = guessGhcPkgFromGhcPath ghcProg
- }
- anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1)
-
- when (ghcVersion /= ghcPkgVersion) $ die' verbosity $
- "Version mismatch between ghc and ghc-pkg: "
- ++ programPath ghcProg ++ " is version " ++ prettyShow ghcVersion ++ " "
- ++ programPath ghcPkgProg ++ " is version " ++ prettyShow ghcPkgVersion
+ requireProgramVersion
+ verbosity
+ ghcPkgProgram
+ { programFindLocation = guessGhcPkgFromGhcPath ghcProg
+ }
+ anyVersion
+ (userMaybeSpecifyPath "ghc-pkg" hcPkgPath progdb1)
+
+ when (ghcVersion /= ghcPkgVersion) $
+ die' verbosity $
+ "Version mismatch between ghc and ghc-pkg: "
+ ++ programPath ghcProg
+ ++ " is version "
+ ++ prettyShow ghcVersion
+ ++ " "
+ ++ programPath ghcPkgProg
+ ++ " is version "
+ ++ prettyShow ghcPkgVersion
-- Likewise we try to find the matching hsc2hs and haddock programs.
- let hsc2hsProgram' = hsc2hsProgram {
- programFindLocation = guessHsc2hsFromGhcPath ghcProg
- }
- haddockProgram' = haddockProgram {
- programFindLocation = guessHaddockFromGhcPath ghcProg
- }
- hpcProgram' = hpcProgram {
- programFindLocation = guessHpcFromGhcPath ghcProg
- }
- runghcProgram' = runghcProgram {
- programFindLocation = guessRunghcFromGhcPath ghcProg
- }
- progdb3 = addKnownProgram haddockProgram' $
- addKnownProgram hsc2hsProgram' $
- addKnownProgram hpcProgram' $
+ let hsc2hsProgram' =
+ hsc2hsProgram
+ { programFindLocation = guessHsc2hsFromGhcPath ghcProg
+ }
+ haddockProgram' =
+ haddockProgram
+ { programFindLocation = guessHaddockFromGhcPath ghcProg
+ }
+ hpcProgram' =
+ hpcProgram
+ { programFindLocation = guessHpcFromGhcPath ghcProg
+ }
+ runghcProgram' =
+ runghcProgram
+ { programFindLocation = guessRunghcFromGhcPath ghcProg
+ }
+ progdb3 =
+ addKnownProgram haddockProgram' $
+ addKnownProgram hsc2hsProgram' $
+ addKnownProgram hpcProgram' $
addKnownProgram runghcProgram' progdb2
- languages <- Internal.getLanguages verbosity implInfo ghcProg
+ languages <- Internal.getLanguages verbosity implInfo ghcProg
extensions0 <- Internal.getExtensions verbosity implInfo ghcProg
ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcProg
let ghcInfoMap = Map.fromList ghcInfo
- extensions = -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214
- filterExt JavaScriptFFI $
- -- see 'filterExtTH' comment below
- filterExtTH $ extensions0
+ extensions =
+ -- workaround https://gitlab.haskell.org/ghc/ghc/-/issues/11214
+ filterExt JavaScriptFFI $
+ -- see 'filterExtTH' comment below
+ filterExtTH $
+ extensions0
-- starting with GHC 8.0, `TemplateHaskell` will be omitted from
-- `--supported-extensions` when it's not available.
-- for older GHCs we can use the "Have interpreter" property to
-- filter out `TemplateHaskell`
- filterExtTH | ghcVersion < mkVersion [8]
- , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap
- = filterExt TemplateHaskell
- | otherwise = id
+ filterExtTH
+ | ghcVersion < mkVersion [8]
+ , Just "NO" <- Map.lookup "Have interpreter" ghcInfoMap =
+ filterExt TemplateHaskell
+ | otherwise = id
filterExt ext = filter ((/= EnableExtension ext) . fst)
- let comp = Compiler {
- compilerId = CompilerId GHC ghcVersion,
- compilerAbiTag = NoAbiTag,
- compilerCompat = [],
- compilerLanguages = languages,
- compilerExtensions = extensions,
- compilerProperties = ghcInfoMap
- }
+ let comp =
+ Compiler
+ { compilerId = CompilerId GHC ghcVersion
+ , compilerAbiTag = NoAbiTag
+ , compilerCompat = []
+ , compilerLanguages = languages
+ , compilerExtensions = extensions
+ , compilerProperties = ghcInfoMap
+ }
compPlatform = Internal.targetPlatform ghcInfo
-- configure gcc and ld
progdb4 = Internal.configureToolchain implInfo ghcProg ghcInfoMap progdb3
@@ -222,52 +267,69 @@ configure verbosity hcPath hcPkgPath conf0 = do
-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
---
-guessToolFromGhcPath :: Program -> ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
-guessToolFromGhcPath tool ghcProg verbosity searchpath
- = do let toolname = programName tool
- given_path = programPath ghcProg
- given_dir = takeDirectory given_path
- real_path <- canonicalizePath given_path
- let real_dir = takeDirectory real_path
- versionSuffix path = takeVersionSuffix (dropExeExtension path)
- given_suf = versionSuffix given_path
- real_suf = versionSuffix real_path
- guessNormal dir = dir </> toolname <.> exeExtension buildPlatform
- guessGhcVersioned dir suf = dir </> (toolname ++ "-ghc" ++ suf)
- <.> exeExtension buildPlatform
- guessVersioned dir suf = dir </> (toolname ++ suf)
- <.> exeExtension buildPlatform
- mkGuesses dir suf | null suf = [guessNormal dir]
- | otherwise = [guessGhcVersioned dir suf,
- guessVersioned dir suf,
- guessNormal dir]
- -- order matters here, see https://github.com/haskell/cabal/issues/7390
- guesses = (if real_path == given_path
- then []
- else mkGuesses real_dir real_suf)
- ++ mkGuesses given_dir given_suf
- info verbosity $ "looking for tool " ++ toolname
- ++ " near compiler in " ++ given_dir
- debug verbosity $ "candidate locations: " ++ show guesses
- exists <- traverse doesFileExist guesses
- case [ file | (file, True) <- zip guesses exists ] of
- -- If we can't find it near ghc, fall back to the usual
- -- method.
- [] -> programFindLocation tool verbosity searchpath
- (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp
- let lookedAt = map fst
- . takeWhile (\(_file, exist) -> not exist)
- $ zip guesses exists
- return (Just (fp, lookedAt))
-
- where takeVersionSuffix :: FilePath -> String
- takeVersionSuffix = takeWhileEndLE isSuffixChar
-
- isSuffixChar :: Char -> Bool
- isSuffixChar c = isDigit c || c == '.' || c == '-'
+guessToolFromGhcPath
+ :: Program
+ -> ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
+guessToolFromGhcPath tool ghcProg verbosity searchpath =
+ do
+ let toolname = programName tool
+ given_path = programPath ghcProg
+ given_dir = takeDirectory given_path
+ real_path <- canonicalizePath given_path
+ let real_dir = takeDirectory real_path
+ versionSuffix path = takeVersionSuffix (dropExeExtension path)
+ given_suf = versionSuffix given_path
+ real_suf = versionSuffix real_path
+ guessNormal dir = dir </> toolname <.> exeExtension buildPlatform
+ guessGhcVersioned dir suf =
+ dir
+ </> (toolname ++ "-ghc" ++ suf)
+ <.> exeExtension buildPlatform
+ guessVersioned dir suf =
+ dir
+ </> (toolname ++ suf)
+ <.> exeExtension buildPlatform
+ mkGuesses dir suf
+ | null suf = [guessNormal dir]
+ | otherwise =
+ [ guessGhcVersioned dir suf
+ , guessVersioned dir suf
+ , guessNormal dir
+ ]
+ -- order matters here, see https://github.com/haskell/cabal/issues/7390
+ guesses =
+ ( if real_path == given_path
+ then []
+ else mkGuesses real_dir real_suf
+ )
+ ++ mkGuesses given_dir given_suf
+ info verbosity $
+ "looking for tool "
+ ++ toolname
+ ++ " near compiler in "
+ ++ given_dir
+ debug verbosity $ "candidate locations: " ++ show guesses
+ exists <- traverse doesFileExist guesses
+ case [file | (file, True) <- zip guesses exists] of
+ -- If we can't find it near ghc, fall back to the usual
+ -- method.
+ [] -> programFindLocation tool verbosity searchpath
+ (fp : _) -> do
+ info verbosity $ "found " ++ toolname ++ " in " ++ fp
+ let lookedAt =
+ map fst
+ . takeWhile (\(_file, exist) -> not exist)
+ $ zip guesses exists
+ return (Just (fp, lookedAt))
+ where
+ takeVersionSuffix :: FilePath -> String
+ takeVersionSuffix = takeWhileEndLE isSuffixChar
+
+ isSuffixChar :: Char -> Bool
+ isSuffixChar c = isDigit c || c == '.' || c == '-'
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
-- corresponding ghc-pkg, we try looking for both a versioned and unversioned
@@ -276,10 +338,11 @@ guessToolFromGhcPath tool ghcProg verbosity searchpath
-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg-6.6.1(.exe)
-- > /usr/local/bin/ghc-pkg(.exe)
---
-guessGhcPkgFromGhcPath :: ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+guessGhcPkgFromGhcPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
@@ -289,10 +352,11 @@ guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram
-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs-6.6.1(.exe)
-- > /usr/local/bin/hsc2hs(.exe)
---
-guessHsc2hsFromGhcPath :: ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+guessHsc2hsFromGhcPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram
-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a
@@ -302,23 +366,27 @@ guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram
-- > /usr/local/bin/haddock-ghc-6.6.1(.exe)
-- > /usr/local/bin/haddock-6.6.1(.exe)
-- > /usr/local/bin/haddock(.exe)
---
-guessHaddockFromGhcPath :: ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+guessHaddockFromGhcPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessHaddockFromGhcPath = guessToolFromGhcPath haddockProgram
-guessHpcFromGhcPath :: ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+guessHpcFromGhcPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessHpcFromGhcPath = guessToolFromGhcPath hpcProgram
-guessRunghcFromGhcPath :: ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+guessRunghcFromGhcPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessRunghcFromGhcPath = guessToolFromGhcPath runghcProgram
-
getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg
where
@@ -326,47 +394,54 @@ getGhcInfo verbosity ghcProg = Internal.getGhcInfo verbosity implInfo ghcProg
implInfo = ghcVersionImplInfo version
-- | Given a single package DB, return all installed packages.
-getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb
- -> IO InstalledPackageIndex
+getPackageDBContents
+ :: Verbosity
+ -> PackageDB
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getPackageDBContents verbosity packagedb progdb = do
pkgss <- getInstalledPackages' verbosity [packagedb] progdb
toPackageIndex verbosity pkgss progdb
-- | Given a package DB stack, return all installed packages.
-getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack
- -> ProgramDb
- -> IO InstalledPackageIndex
+getInstalledPackages
+ :: Verbosity
+ -> Compiler
+ -> PackageDBStack
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity comp packagedbs progdb = do
checkPackageDbEnvVar verbosity
checkPackageDbStack verbosity comp packagedbs
pkgss <- getInstalledPackages' verbosity packagedbs progdb
index <- toPackageIndex verbosity pkgss progdb
return $! hackRtsPackage index
-
where
hackRtsPackage index =
case PackageIndex.lookupPackageName index (mkPackageName "rts") of
- [(_,[rts])]
- -> PackageIndex.insert (removeMingwIncludeDir rts) index
- _ -> index -- No (or multiple) ghc rts package is registered!!
- -- Feh, whatever, the ghc test suite does some crazy stuff.
+ [(_, [rts])] ->
+ PackageIndex.insert (removeMingwIncludeDir rts) index
+ _ -> index -- No (or multiple) ghc rts package is registered!!
+ -- Feh, whatever, the ghc test suite does some crazy stuff.
-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a
-- @PackageIndex@. Helper function used by 'getPackageDBContents' and
-- 'getInstalledPackages'.
-toPackageIndex :: Verbosity
- -> [(PackageDB, [InstalledPackageInfo])]
- -> ProgramDb
- -> IO InstalledPackageIndex
+toPackageIndex
+ :: Verbosity
+ -> [(PackageDB, [InstalledPackageInfo])]
+ -> ProgramDb
+ -> IO InstalledPackageIndex
toPackageIndex verbosity pkgss progdb = do
-- On Windows, various fields have $topdir/foo rather than full
-- paths. We need to substitute the right value in so that when
-- we, for example, call gcc, we have proper paths to give it.
topDir <- getLibDir' verbosity ghcProg
- let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
- | (_, pkgs) <- pkgss ]
+ let indices =
+ [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
+ | (_, pkgs) <- pkgss
+ ]
return $! mconcat indices
-
where
ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb
@@ -378,103 +453,114 @@ getGhcAppDir = getAppUserDataDirectory "ghc"
getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir verbosity lbi =
- dropWhileEndLE isSpace `fmap`
- getDbProgramOutput verbosity ghcProgram
- (withPrograms lbi) ["--print-libdir"]
+ dropWhileEndLE isSpace
+ `fmap` getDbProgramOutput
+ verbosity
+ ghcProgram
+ (withPrograms lbi)
+ ["--print-libdir"]
getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' verbosity ghcProg =
- dropWhileEndLE isSpace `fmap`
- getProgramOutput verbosity ghcProg ["--print-libdir"]
-
+ dropWhileEndLE isSpace
+ `fmap` getProgramOutput verbosity ghcProg ["--print-libdir"]
-- | Return the 'FilePath' to the global GHC package database.
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB verbosity ghcProg =
- dropWhileEndLE isSpace `fmap`
- getProgramOutput verbosity ghcProg ["--print-global-package-db"]
+ dropWhileEndLE isSpace
+ `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"]
-- | Return the 'FilePath' to the per-user GHC package database.
getUserPackageDB
:: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB _verbosity ghcProg platform = do
- -- It's rather annoying that we have to reconstruct this, because ghc
- -- hides this information from us otherwise. But for certain use cases
- -- like change monitoring it really can't remain hidden.
- appdir <- getGhcAppDir
- return (appdir </> platformAndVersion </> packageConfFileName)
+ -- It's rather annoying that we have to reconstruct this, because ghc
+ -- hides this information from us otherwise. But for certain use cases
+ -- like change monitoring it really can't remain hidden.
+ appdir <- getGhcAppDir
+ return (appdir </> platformAndVersion </> packageConfFileName)
where
- platformAndVersion = Internal.ghcPlatformAndVersionString
- platform ghcVersion
+ platformAndVersion =
+ Internal.ghcPlatformAndVersionString
+ platform
+ ghcVersion
packageConfFileName = "package.conf.d"
ghcVersion = fromMaybe (error "GHC.getUserPackageDB: no ghc version") $ programVersion ghcProg
checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar verbosity =
- Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH"
+ Internal.checkPackageDbEnvVar verbosity "GHC" "GHC_PACKAGE_PATH"
checkPackageDbStack :: Verbosity -> Compiler -> PackageDBStack -> IO ()
checkPackageDbStack verbosity comp =
- if flagPackageConf implInfo
- then checkPackageDbStackPre76 verbosity
- else checkPackageDbStackPost76 verbosity
- where implInfo = ghcVersionImplInfo (compilerVersion comp)
+ if flagPackageConf implInfo
+ then checkPackageDbStackPre76 verbosity
+ else checkPackageDbStackPost76 verbosity
+ where
+ implInfo = ghcVersionImplInfo (compilerVersion comp)
checkPackageDbStackPost76 :: Verbosity -> PackageDBStack -> IO ()
-checkPackageDbStackPost76 _ (GlobalPackageDB:rest)
+checkPackageDbStackPost76 _ (GlobalPackageDB : rest)
| GlobalPackageDB `notElem` rest = return ()
checkPackageDbStackPost76 verbosity rest
| GlobalPackageDB `elem` rest =
- die' verbosity $ "If the global package db is specified, it must be "
- ++ "specified first and cannot be specified multiple times"
+ die' verbosity $
+ "If the global package db is specified, it must be "
+ ++ "specified first and cannot be specified multiple times"
checkPackageDbStackPost76 _ _ = return ()
checkPackageDbStackPre76 :: Verbosity -> PackageDBStack -> IO ()
-checkPackageDbStackPre76 _ (GlobalPackageDB:rest)
+checkPackageDbStackPre76 _ (GlobalPackageDB : rest)
| GlobalPackageDB `notElem` rest = return ()
checkPackageDbStackPre76 verbosity rest
| GlobalPackageDB `notElem` rest =
- die' verbosity $
+ die' verbosity $
"With current ghc versions the global package db is always used "
- ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"
- ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"
+ ++ "and must be listed first. This ghc limitation is lifted in GHC 7.6,"
+ ++ "see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"
checkPackageDbStackPre76 verbosity _ =
- die' verbosity $ "If the global package db is specified, it must be "
- ++ "specified first and cannot be specified multiple times"
+ die' verbosity $
+ "If the global package db is specified, it must be "
+ ++ "specified first and cannot be specified multiple times"
-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This
-- breaks when you want to use a different gcc, so we need to filter
-- it out.
removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo
removeMingwIncludeDir pkg =
- let ids = InstalledPackageInfo.includeDirs pkg
- ids' = filter (not . ("mingw" `isSuffixOf`)) ids
- in pkg { InstalledPackageInfo.includeDirs = ids' }
+ let ids = InstalledPackageInfo.includeDirs pkg
+ ids' = filter (not . ("mingw" `isSuffixOf`)) ids
+ in pkg{InstalledPackageInfo.includeDirs = ids'}
-- | Get the packages from specific PackageDBs, not cumulative.
---
-getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb
- -> IO [(PackageDB, [InstalledPackageInfo])]
+getInstalledPackages'
+ :: Verbosity
+ -> [PackageDB]
+ -> ProgramDb
+ -> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs progdb =
sequenceA
- [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
- return (packagedb, pkgs)
- | packagedb <- packagedbs ]
-
-getInstalledPackagesMonitorFiles :: Verbosity -> Platform
- -> ProgramDb
- -> [PackageDB]
- -> IO [FilePath]
+ [ do
+ pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
+ return (packagedb, pkgs)
+ | packagedb <- packagedbs
+ ]
+
+getInstalledPackagesMonitorFiles
+ :: Verbosity
+ -> Platform
+ -> ProgramDb
+ -> [PackageDB]
+ -> IO [FilePath]
getInstalledPackagesMonitorFiles verbosity platform progdb =
- traverse getPackageDBPath
+ traverse getPackageDBPath
where
getPackageDBPath :: PackageDB -> IO FilePath
getPackageDBPath GlobalPackageDB =
selectMonitorFile =<< getGlobalPackageDB verbosity ghcProg
-
getPackageDBPath UserPackageDB =
selectMonitorFile =<< getUserPackageDB verbosity ghcProg platform
-
getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path
-- GHC has old style file dbs, and new style directory dbs.
@@ -483,30 +569,45 @@ getInstalledPackagesMonitorFiles verbosity platform progdb =
-- so it's safe to only monitor this one file.
selectMonitorFile path = do
isFileStyle <- doesFileExist path
- if isFileStyle then return path
- else return (path </> "package.cache")
+ if isFileStyle
+ then return path
+ else return (path </> "package.cache")
ghcProg = fromMaybe (error "GHC.toPackageIndex: no ghc program") $ lookupProgram ghcProgram progdb
-
-- -----------------------------------------------------------------------------
-- Building a library
-buildLib :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO ()
+buildLib
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildLib = buildOrReplLib Nothing
-replLib :: ReplOptions -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Library
- -> ComponentLocalBuildInfo -> IO ()
+replLib
+ :: ReplOptions
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
replLib = buildOrReplLib . Just
-buildOrReplLib :: Maybe ReplOptions -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Library
- -> ComponentLocalBuildInfo -> IO ()
+buildOrReplLib
+ :: Maybe ReplOptions
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
let uid = componentUnitId clbi
libTargetDir = componentBuildDir lbi clbi
@@ -523,7 +624,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
replFlags = fromMaybe mempty mReplFlags
comp = compiler lbi
ghcVersion = compilerVersion comp
- implInfo = getImplInfo comp
+ implInfo = getImplInfo comp
platform@(Platform hostArch hostOS) = hostPlatform lbi
hasJsSupport = hostArch == JavaScript
has_code = not (componentIsIndefinite clbi)
@@ -539,13 +640,12 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs libBi)
cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic libBi)
-
- let isGhcDynamic = isDynamic comp
+ let isGhcDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
doingTH = usesTemplateHaskellOrQQ libBi
forceVanillaLib = doingTH && not isGhcDynamic
- forceSharedLib = doingTH && isGhcDynamic
- -- TH always needs default libs, even when building for profiling
+ forceSharedLib = doingTH && isGhcDynamic
+ -- TH always needs default libs, even when building for profiling
-- Determine if program coverage should be enabled and if so, what
-- '-hpcdir' should be.
@@ -557,262 +657,355 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
pkg_name = prettyShow (PD.package pkg_descr)
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
- | forRepl = mempty -- HPC is not supported in ghci
+ | forRepl = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
| otherwise = mempty
createDirectoryIfMissingVerbose verbosity True libTargetDir
-- TODO: do we need to put hs-boot files into place for mutually recursive
-- modules?
- let cLikeSources = fromNubListR $ mconcat
- [ toNubListR (cSources libBi)
- , toNubListR (cxxSources libBi)
- , toNubListR (cmmSources libBi)
- , toNubListR (asmSources libBi)
- , if hasJsSupport
- -- JS files are C-like with GHC's JS backend: they are
- -- "compiled" into `.o` files (renamed with a header).
- -- This is a difference from GHCJS, for which we only
- -- pass the JS files at link time.
- then toNubListR (jsSources libBi)
- else mempty
- ]
- cLikeObjs = map (`replaceExtension` objExtension) cLikeSources
- baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
- vanillaOpts = baseOpts `mappend` mempty {
- ghcOptMode = toFlag GhcModeMake,
- ghcOptNumJobs = numJobs,
- ghcOptInputModules = toNubListR $ allLibModules lib clbi,
- ghcOptHPCDir = hpcdir Hpc.Vanilla
- }
-
- profOpts = vanillaOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptProfilingAuto = Internal.profDetailLevelFlag True
- (withProfLibDetail lbi),
- ghcOptHiSuffix = toFlag "p_hi",
- ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = hcProfOptions GHC libBi,
- ghcOptHPCDir = hpcdir Hpc.Prof
- }
-
- sharedOpts = vanillaOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "dyn_hi",
- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = hcSharedOptions GHC libBi,
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
- linkerOpts = mempty {
- ghcOptLinkOptions = PD.ldOptions libBi
- ++ [ "-static"
- | withFullyStaticExe lbi ]
- -- Pass extra `ld-options` given
- -- through to GHC's linker.
- ++ maybe [] programOverrideArgs
- (lookupProgram ldProgram (withPrograms lbi)),
- ghcOptLinkLibs = if withFullyStaticExe lbi
- then extraLibsStatic libBi
- else extraLibs libBi,
- ghcOptLinkLibPath = toNubListR $
- if withFullyStaticExe lbi
- then cleanedExtraLibDirsStatic
- else cleanedExtraLibDirs,
- ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
- ghcOptLinkFrameworkDirs = toNubListR $
- PD.extraFrameworkDirs libBi,
- ghcOptInputFiles = toNubListR
- [relLibTargetDir </> x | x <- cLikeObjs]
- }
- replOpts = vanillaOpts {
- ghcOptExtra = Internal.filterGhciFlags
- (ghcOptExtra vanillaOpts)
- <> replOptionsFlags replFlags,
- ghcOptNumJobs = mempty,
- ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts)
- }
- `mappend` linkerOpts
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeInteractive,
- ghcOptOptimisation = toFlag GhcNoOptimisation
- }
-
- vanillaSharedOpts = vanillaOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
- ghcOptDynHiSuffix = toFlag "dyn_hi",
- ghcOptDynObjSuffix = toFlag "dyn_o",
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
+ let cLikeSources =
+ fromNubListR $
+ mconcat
+ [ toNubListR (cSources libBi)
+ , toNubListR (cxxSources libBi)
+ , toNubListR (cmmSources libBi)
+ , toNubListR (asmSources libBi)
+ , if hasJsSupport
+ then -- JS files are C-like with GHC's JS backend: they are
+ -- "compiled" into `.o` files (renamed with a header).
+ -- This is a difference from GHCJS, for which we only
+ -- pass the JS files at link time.
+ toNubListR (jsSources libBi)
+ else mempty
+ ]
+ cLikeObjs = map (`replaceExtension` objExtension) cLikeSources
+ baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
+ vanillaOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeMake
+ , ghcOptNumJobs = numJobs
+ , ghcOptInputModules = toNubListR $ allLibModules lib clbi
+ , ghcOptHPCDir = hpcdir Hpc.Vanilla
+ }
+
+ profOpts =
+ vanillaOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptProfilingAuto =
+ Internal.profDetailLevelFlag
+ True
+ (withProfLibDetail lbi)
+ , ghcOptHiSuffix = toFlag "p_hi"
+ , ghcOptObjSuffix = toFlag "p_o"
+ , ghcOptExtra = hcProfOptions GHC libBi
+ , ghcOptHPCDir = hpcdir Hpc.Prof
+ }
+
+ sharedOpts =
+ vanillaOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptFPic = toFlag True
+ , ghcOptHiSuffix = toFlag "dyn_hi"
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ , ghcOptExtra = hcSharedOptions GHC libBi
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ linkerOpts =
+ mempty
+ { ghcOptLinkOptions =
+ PD.ldOptions libBi
+ ++ [ "-static"
+ | withFullyStaticExe lbi
+ ]
+ -- Pass extra `ld-options` given
+ -- through to GHC's linker.
+ ++ maybe
+ []
+ programOverrideArgs
+ (lookupProgram ldProgram (withPrograms lbi))
+ , ghcOptLinkLibs =
+ if withFullyStaticExe lbi
+ then extraLibsStatic libBi
+ else extraLibs libBi
+ , ghcOptLinkLibPath =
+ toNubListR $
+ if withFullyStaticExe lbi
+ then cleanedExtraLibDirsStatic
+ else cleanedExtraLibDirs
+ , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
+ , ghcOptLinkFrameworkDirs =
+ toNubListR $
+ PD.extraFrameworkDirs libBi
+ , ghcOptInputFiles =
+ toNubListR
+ [relLibTargetDir </> x | x <- cLikeObjs]
+ }
+ replOpts =
+ vanillaOpts
+ { ghcOptExtra =
+ Internal.filterGhciFlags
+ (ghcOptExtra vanillaOpts)
+ <> replOptionsFlags replFlags
+ , ghcOptNumJobs = mempty
+ , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules vanillaOpts)
+ }
+ `mappend` linkerOpts
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeInteractive
+ , ghcOptOptimisation = toFlag GhcNoOptimisation
+ }
+
+ vanillaSharedOpts =
+ vanillaOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
+ , ghcOptDynHiSuffix = toFlag "dyn_hi"
+ , ghcOptDynObjSuffix = toFlag "dyn_o"
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
unless (forRepl || null (allLibModules lib clbi)) $
- do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
- shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts)
- useDynToo = dynamicTooSupported &&
- (forceVanillaLib || withVanillaLib lbi) &&
- (forceSharedLib || withSharedLib lbi) &&
- null (hcSharedOptions GHC libBi)
- if not has_code
+ do
+ let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)
+ shared = whenSharedLib forceSharedLib (runGhcProg sharedOpts)
+ useDynToo =
+ dynamicTooSupported
+ && (forceVanillaLib || withVanillaLib lbi)
+ && (forceSharedLib || withSharedLib lbi)
+ && null (hcSharedOptions GHC libBi)
+ if not has_code
then vanilla
else
- if useDynToo
- then do
+ if useDynToo
+ then do
runGhcProg vanillaSharedOpts
case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
(Flag dynDir, Flag vanillaDir) ->
- -- When the vanilla and shared library builds are done
- -- in one pass, only one set of HPC module interfaces
- -- are generated. This set should suffice for both
- -- static and dynamically linked executables. We copy
- -- the modules interfaces so they are available under
- -- both ways.
- copyDirectoryRecursive verbosity dynDir vanillaDir
+ -- When the vanilla and shared library builds are done
+ -- in one pass, only one set of HPC module interfaces
+ -- are generated. This set should suffice for both
+ -- static and dynamically linked executables. We copy
+ -- the modules interfaces so they are available under
+ -- both ways.
+ copyDirectoryRecursive verbosity dynDir vanillaDir
_ -> return ()
- else if isGhcDynamic
- then do shared; vanilla
- else do vanilla; shared
- whenProfLib (runGhcProg profOpts)
+ else
+ if isGhcDynamic
+ then do shared; vanilla
+ else do vanilla; shared
+ whenProfLib (runGhcProg profOpts)
-- Build any C++ sources separately.
unless (not has_code || null (cxxSources libBi)) $ do
info verbosity "Building C++ Sources..."
sequence_
- [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo
- lbi libBi clbi relLibTargetDir filename
- vanillaCxxOpts = if isGhcDynamic
- then baseCxxOpts { ghcOptFPic = toFlag True }
- else baseCxxOpts
- profCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaCxxOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded cxxOpts = do
- needsRecomp <- checkNeedsRecompilation filename cxxOpts
- when needsRecomp $ runGhcProg cxxOpts
- runGhcProgIfNeeded vanillaCxxOpts
- unless forRepl $
- whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts)
- | filename <- cxxSources libBi]
+ [ do
+ let baseCxxOpts =
+ Internal.componentCxxGhcOptions
+ verbosity
+ implInfo
+ lbi
+ libBi
+ clbi
+ relLibTargetDir
+ filename
+ vanillaCxxOpts =
+ if isGhcDynamic
+ then baseCxxOpts{ghcOptFPic = toFlag True}
+ else baseCxxOpts
+ profCxxOpts =
+ vanillaCxxOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCxxOpts =
+ vanillaCxxOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCxxOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded cxxOpts = do
+ needsRecomp <- checkNeedsRecompilation filename cxxOpts
+ when needsRecomp $ runGhcProg cxxOpts
+ runGhcProgIfNeeded vanillaCxxOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts)
+ | filename <- cxxSources libBi
+ ]
-- build any C sources
unless (not has_code || null (cSources libBi)) $ do
info verbosity "Building C Sources..."
sequence_
- [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo
- lbi libBi clbi relLibTargetDir filename
- vanillaCcOpts = if isGhcDynamic
- -- Dynamic GHC requires C sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCcOpts { ghcOptFPic = toFlag True }
- else baseCcOpts
- profCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaCcOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded ccOpts = do
- needsRecomp <- checkNeedsRecompilation filename ccOpts
- when needsRecomp $ runGhcProg ccOpts
- runGhcProgIfNeeded vanillaCcOpts
- unless forRepl $
- whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
- | filename <- cSources libBi]
+ [ do
+ let baseCcOpts =
+ Internal.componentCcGhcOptions
+ verbosity
+ implInfo
+ lbi
+ libBi
+ clbi
+ relLibTargetDir
+ filename
+ vanillaCcOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires C sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseCcOpts{ghcOptFPic = toFlag True}
+ else baseCcOpts
+ profCcOpts =
+ vanillaCcOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCcOpts =
+ vanillaCcOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCcOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded ccOpts = do
+ needsRecomp <- checkNeedsRecompilation filename ccOpts
+ when needsRecomp $ runGhcProg ccOpts
+ runGhcProgIfNeeded vanillaCcOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
+ | filename <- cSources libBi
+ ]
-- build any JS sources
unless (not has_code || not hasJsSupport || null (jsSources libBi)) $ do
info verbosity "Building JS Sources..."
sequence_
- [ do let vanillaJsOpts = Internal.componentJsGhcOptions verbosity implInfo
- lbi libBi clbi relLibTargetDir filename
- profJsOpts = vanillaJsOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaJsOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded jsOpts = do
- needsRecomp <- checkNeedsRecompilation filename jsOpts
- when needsRecomp $ runGhcProg jsOpts
- runGhcProgIfNeeded vanillaJsOpts
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profJsOpts)
- | filename <- jsSources libBi]
+ [ do
+ let vanillaJsOpts =
+ Internal.componentJsGhcOptions
+ verbosity
+ implInfo
+ lbi
+ libBi
+ clbi
+ relLibTargetDir
+ filename
+ profJsOpts =
+ vanillaJsOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptObjSuffix = toFlag "p_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaJsOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded jsOpts = do
+ needsRecomp <- checkNeedsRecompilation filename jsOpts
+ when needsRecomp $ runGhcProg jsOpts
+ runGhcProgIfNeeded vanillaJsOpts
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profJsOpts)
+ | filename <- jsSources libBi
+ ]
-- build any ASM sources
unless (not has_code || null (asmSources libBi)) $ do
info verbosity "Building Assembler Sources..."
sequence_
- [ do let baseAsmOpts = Internal.componentAsmGhcOptions verbosity implInfo
- lbi libBi clbi relLibTargetDir filename
- vanillaAsmOpts = if isGhcDynamic
- -- Dynamic GHC requires objects to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseAsmOpts { ghcOptFPic = toFlag True }
- else baseAsmOpts
- profAsmOpts = vanillaAsmOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedAsmOpts = vanillaAsmOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaAsmOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded asmOpts = do
- needsRecomp <- checkNeedsRecompilation filename asmOpts
- when needsRecomp $ runGhcProg asmOpts
- runGhcProgIfNeeded vanillaAsmOpts
- unless forRepl $
- whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts)
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts)
- | filename <- asmSources libBi]
+ [ do
+ let baseAsmOpts =
+ Internal.componentAsmGhcOptions
+ verbosity
+ implInfo
+ lbi
+ libBi
+ clbi
+ relLibTargetDir
+ filename
+ vanillaAsmOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires objects to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseAsmOpts{ghcOptFPic = toFlag True}
+ else baseAsmOpts
+ profAsmOpts =
+ vanillaAsmOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedAsmOpts =
+ vanillaAsmOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaAsmOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded asmOpts = do
+ needsRecomp <- checkNeedsRecompilation filename asmOpts
+ when needsRecomp $ runGhcProg asmOpts
+ runGhcProgIfNeeded vanillaAsmOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedAsmOpts)
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profAsmOpts)
+ | filename <- asmSources libBi
+ ]
-- build any Cmm sources
unless (not has_code || null (cmmSources libBi)) $ do
info verbosity "Building C-- Sources..."
sequence_
- [ do let baseCmmOpts = Internal.componentCmmGhcOptions verbosity implInfo
- lbi libBi clbi relLibTargetDir filename
- vanillaCmmOpts = if isGhcDynamic
- -- Dynamic GHC requires C sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCmmOpts { ghcOptFPic = toFlag True }
- else baseCmmOpts
- profCmmOpts = vanillaCmmOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedCmmOpts = vanillaCmmOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaCmmOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded cmmOpts = do
- needsRecomp <- checkNeedsRecompilation filename cmmOpts
- when needsRecomp $ runGhcProg cmmOpts
- runGhcProgIfNeeded vanillaCmmOpts
- unless forRepl $
- whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts)
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts)
- | filename <- cmmSources libBi]
+ [ do
+ let baseCmmOpts =
+ Internal.componentCmmGhcOptions
+ verbosity
+ implInfo
+ lbi
+ libBi
+ clbi
+ relLibTargetDir
+ filename
+ vanillaCmmOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires C sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseCmmOpts{ghcOptFPic = toFlag True}
+ else baseCmmOpts
+ profCmmOpts =
+ vanillaCmmOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCmmOpts =
+ vanillaCmmOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCmmOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded cmmOpts = do
+ needsRecomp <- checkNeedsRecompilation filename cmmOpts
+ when needsRecomp $ runGhcProg cmmOpts
+ runGhcProgIfNeeded vanillaCmmOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCmmOpts)
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCmmOpts)
+ | filename <- cmmSources libBi
+ ]
-- TODO: problem here is we need the .c files built first, so we can load them
-- with ghci, but .c files can depend on .h files generated by ghc by ffi
@@ -824,143 +1017,197 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
-- link:
when has_code . unless forRepl $ do
info verbosity "Linking..."
- let cLikeProfObjs = map (`replaceExtension` ("p_" ++ objExtension))
- cLikeSources
- cLikeSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
- cLikeSources
- compiler_id = compilerId (compiler lbi)
- vanillaLibFilePath = relLibTargetDir </> mkLibName uid
- profileLibFilePath = relLibTargetDir </> mkProfLibName uid
- sharedLibFilePath = relLibTargetDir </>
- mkSharedLibName (hostPlatform lbi) compiler_id uid
- staticLibFilePath = relLibTargetDir </>
- mkStaticLibName (hostPlatform lbi) compiler_id uid
- ghciLibFilePath = relLibTargetDir </> Internal.mkGHCiLibName uid
- ghciProfLibFilePath = relLibTargetDir </> Internal.mkGHCiProfLibName uid
- libInstallPath = libdir $
- absoluteComponentInstallDirs
- pkg_descr lbi uid NoCopyDest
- sharedLibInstallPath = libInstallPath </>
- mkSharedLibName (hostPlatform lbi) compiler_id uid
-
- stubObjs <- catMaybes <$> sequenceA
- [ findFileWithExtension [objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
- , x <- allLibModules lib clbi ]
- stubProfObjs <- catMaybes <$> sequenceA
- [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
- , x <- allLibModules lib clbi ]
- stubSharedObjs <- catMaybes <$> sequenceA
- [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
- , x <- allLibModules lib clbi ]
-
- hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi
- relLibTargetDir objExtension True
+ let cLikeProfObjs =
+ map
+ (`replaceExtension` ("p_" ++ objExtension))
+ cLikeSources
+ cLikeSharedObjs =
+ map
+ (`replaceExtension` ("dyn_" ++ objExtension))
+ cLikeSources
+ compiler_id = compilerId (compiler lbi)
+ vanillaLibFilePath = relLibTargetDir </> mkLibName uid
+ profileLibFilePath = relLibTargetDir </> mkProfLibName uid
+ sharedLibFilePath =
+ relLibTargetDir
+ </> mkSharedLibName (hostPlatform lbi) compiler_id uid
+ staticLibFilePath =
+ relLibTargetDir
+ </> mkStaticLibName (hostPlatform lbi) compiler_id uid
+ ghciLibFilePath = relLibTargetDir </> Internal.mkGHCiLibName uid
+ ghciProfLibFilePath = relLibTargetDir </> Internal.mkGHCiProfLibName uid
+ libInstallPath =
+ libdir $
+ absoluteComponentInstallDirs
+ pkg_descr
+ lbi
+ uid
+ NoCopyDest
+ sharedLibInstallPath =
+ libInstallPath
+ </> mkSharedLibName (hostPlatform lbi) compiler_id uid
+
+ stubObjs <-
+ catMaybes
+ <$> sequenceA
+ [ findFileWithExtension
+ [objExtension]
+ [libTargetDir]
+ (ModuleName.toFilePath x ++ "_stub")
+ | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files
+ , x <- allLibModules lib clbi
+ ]
+ stubProfObjs <-
+ catMaybes
+ <$> sequenceA
+ [ findFileWithExtension
+ ["p_" ++ objExtension]
+ [libTargetDir]
+ (ModuleName.toFilePath x ++ "_stub")
+ | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files
+ , x <- allLibModules lib clbi
+ ]
+ stubSharedObjs <-
+ catMaybes
+ <$> sequenceA
+ [ findFileWithExtension
+ ["dyn_" ++ objExtension]
+ [libTargetDir]
+ (ModuleName.toFilePath x ++ "_stub")
+ | ghcVersion < mkVersion [7, 2] -- ghc-7.2+ does not make _stub.o files
+ , x <- allLibModules lib clbi
+ ]
+
+ hObjs <-
+ Internal.getHaskellObjects
+ implInfo
+ lib
+ lbi
+ clbi
+ relLibTargetDir
+ objExtension
+ True
hProfObjs <-
if withProfLib lbi
- then Internal.getHaskellObjects implInfo lib lbi clbi
- relLibTargetDir ("p_" ++ objExtension) True
- else return []
+ then
+ Internal.getHaskellObjects
+ implInfo
+ lib
+ lbi
+ clbi
+ relLibTargetDir
+ ("p_" ++ objExtension)
+ True
+ else return []
hSharedObjs <-
if withSharedLib lbi
- then Internal.getHaskellObjects implInfo lib lbi clbi
- relLibTargetDir ("dyn_" ++ objExtension) False
- else return []
+ then
+ Internal.getHaskellObjects
+ implInfo
+ lib
+ lbi
+ clbi
+ relLibTargetDir
+ ("dyn_" ++ objExtension)
+ False
+ else return []
unless (null hObjs && null cLikeObjs && null stubObjs) $ do
rpaths <- getRPaths lbi clbi
let staticObjectFiles =
- hObjs
+ hObjs
++ map (relLibTargetDir </>) cLikeObjs
++ stubObjs
profObjectFiles =
- hProfObjs
+ hProfObjs
++ map (relLibTargetDir </>) cLikeProfObjs
++ stubProfObjs
dynamicObjectFiles =
- hSharedObjs
+ hSharedObjs
++ map (relLibTargetDir </>) cLikeSharedObjs
++ stubSharedObjs
-- After the relocation lib is created we invoke ghc -shared
-- with the dependencies spelled out as -package arguments
-- and ghc invokes the linker with the proper library paths
ghcSharedLinkArgs =
- mempty {
- ghcOptShared = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptInputFiles = toNubListR dynamicObjectFiles,
- ghcOptOutputFile = toFlag sharedLibFilePath,
- ghcOptExtra = hcSharedOptions GHC libBi,
- -- For dynamic libs, Mac OS/X needs to know the install location
+ mempty
+ { ghcOptShared = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptInputFiles = toNubListR dynamicObjectFiles
+ , ghcOptOutputFile = toFlag sharedLibFilePath
+ , ghcOptExtra = hcSharedOptions GHC libBi
+ , -- For dynamic libs, Mac OS/X needs to know the install location
-- at build time. This only applies to GHC < 7.8 - see the
-- discussion in #1660.
- ghcOptDylibName = if hostOS == OSX
- && ghcVersion < mkVersion [7,8]
- then toFlag sharedLibInstallPath
- else mempty,
- ghcOptHideAllPackages = toFlag True,
- ghcOptNoAutoLinkPackages = toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptThisUnitId = case clbi of
- LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
- -> toFlag pk
- _ -> mempty,
- ghcOptThisComponentId = case clbi of
- LibComponentLocalBuildInfo
- { componentInstantiatedWith = insts } ->
- if null insts
- then mempty
- else toFlag (componentComponentId clbi)
- _ -> mempty,
- ghcOptInstantiatedWith = case clbi of
- LibComponentLocalBuildInfo
- { componentInstantiatedWith = insts }
- -> insts
- _ -> [],
- ghcOptPackages = toNubListR $
- Internal.mkGhcOptPackages clbi ,
- ghcOptLinkLibs = extraLibs libBi,
- ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs,
- ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
- ghcOptLinkFrameworkDirs =
- toNubListR $ PD.extraFrameworkDirs libBi,
- ghcOptRPaths = rpaths
+ ghcOptDylibName =
+ if hostOS == OSX
+ && ghcVersion < mkVersion [7, 8]
+ then toFlag sharedLibInstallPath
+ else mempty
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptNoAutoLinkPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptThisUnitId = case clbi of
+ LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
+ toFlag pk
+ _ -> mempty
+ , ghcOptThisComponentId = case clbi of
+ LibComponentLocalBuildInfo
+ { componentInstantiatedWith = insts
+ } ->
+ if null insts
+ then mempty
+ else toFlag (componentComponentId clbi)
+ _ -> mempty
+ , ghcOptInstantiatedWith = case clbi of
+ LibComponentLocalBuildInfo
+ { componentInstantiatedWith = insts
+ } ->
+ insts
+ _ -> []
+ , ghcOptPackages =
+ toNubListR $
+ Internal.mkGhcOptPackages clbi
+ , ghcOptLinkLibs = extraLibs libBi
+ , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
+ , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
+ , ghcOptLinkFrameworkDirs =
+ toNubListR $ PD.extraFrameworkDirs libBi
+ , ghcOptRPaths = rpaths
}
ghcStaticLinkArgs =
- mempty {
- ghcOptStaticLib = toFlag True,
- ghcOptInputFiles = toNubListR staticObjectFiles,
- ghcOptOutputFile = toFlag staticLibFilePath,
- ghcOptExtra = hcStaticOptions GHC libBi,
- ghcOptHideAllPackages = toFlag True,
- ghcOptNoAutoLinkPackages = toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptThisUnitId = case clbi of
- LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
- -> toFlag pk
- _ -> mempty,
- ghcOptThisComponentId = case clbi of
- LibComponentLocalBuildInfo
- { componentInstantiatedWith = insts } ->
- if null insts
- then mempty
- else toFlag (componentComponentId clbi)
- _ -> mempty,
- ghcOptInstantiatedWith = case clbi of
- LibComponentLocalBuildInfo
- { componentInstantiatedWith = insts }
- -> insts
- _ -> [],
- ghcOptPackages = toNubListR $
- Internal.mkGhcOptPackages clbi ,
- ghcOptLinkLibs = extraLibs libBi,
- ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
+ mempty
+ { ghcOptStaticLib = toFlag True
+ , ghcOptInputFiles = toNubListR staticObjectFiles
+ , ghcOptOutputFile = toFlag staticLibFilePath
+ , ghcOptExtra = hcStaticOptions GHC libBi
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptNoAutoLinkPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptThisUnitId = case clbi of
+ LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
+ toFlag pk
+ _ -> mempty
+ , ghcOptThisComponentId = case clbi of
+ LibComponentLocalBuildInfo
+ { componentInstantiatedWith = insts
+ } ->
+ if null insts
+ then mempty
+ else toFlag (componentComponentId clbi)
+ _ -> mempty
+ , ghcOptInstantiatedWith = case clbi of
+ LibComponentLocalBuildInfo
+ { componentInstantiatedWith = insts
+ } ->
+ insts
+ _ -> []
+ , ghcOptPackages =
+ toNubListR $
+ Internal.mkGhcOptPackages clbi
+ , ghcOptLinkLibs = extraLibs libBi
+ , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
}
info verbosity (show (ghcOptPackages ghcSharedLinkArgs))
@@ -969,15 +1216,23 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
whenGHCiLib $ do
(ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
- Ld.combineObjectFiles verbosity lbi ldProg
- ghciLibFilePath staticObjectFiles
+ Ld.combineObjectFiles
+ verbosity
+ lbi
+ ldProg
+ ghciLibFilePath
+ staticObjectFiles
whenProfLib $ do
Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
whenGHCiLib $ do
(ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
- Ld.combineObjectFiles verbosity lbi ldProg
- ghciProfLibFilePath profObjectFiles
+ Ld.combineObjectFiles
+ verbosity
+ lbi
+ ldProg
+ ghciProfLibFilePath
+ profObjectFiles
whenSharedLib False $
runGhcProg ghcSharedLinkArgs
@@ -986,13 +1241,19 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
runGhcProg ghcStaticLinkArgs
-- | Start a REPL without loading any source files.
-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform
- -> PackageDBStack -> IO ()
+startInterpreter
+ :: Verbosity
+ -> ProgramDb
+ -> Compiler
+ -> Platform
+ -> PackageDBStack
+ -> IO ()
startInterpreter verbosity progdb comp platform packageDBs = do
- let replOpts = mempty {
- ghcOptMode = toFlag GhcModeInteractive,
- ghcOptPackageDBs = packageDBs
- }
+ let replOpts =
+ mempty
+ { ghcOptMode = toFlag GhcModeInteractive
+ , ghcOptPackageDBs = packageDBs
+ }
checkPackageDbStack verbosity comp packageDBs
(ghcProg, _) <- requireProgram verbosity ghcProgram progdb
runGHC verbosity ghcProg comp platform replOpts
@@ -1002,61 +1263,76 @@ startInterpreter verbosity progdb comp platform packageDBs = do
-- | Build a foreign library
buildFLib
- :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> ForeignLib -> ComponentLocalBuildInfo -> IO ()
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib
replFLib
- :: ReplOptions -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> ForeignLib
- -> ComponentLocalBuildInfo -> IO ()
-replFLib replFlags v njobs pkg lbi =
+ :: ReplOptions
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO ()
+replFLib replFlags v njobs pkg lbi =
gbuild v njobs pkg lbi . GReplFLib replFlags
-- | Build an executable with GHC.
---
buildExe
- :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> Executable -> ComponentLocalBuildInfo -> IO ()
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe
replExe
- :: ReplOptions -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Executable
- -> ComponentLocalBuildInfo -> IO ()
+ :: ReplOptions
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
replExe replFlags v njobs pkg lbi =
gbuild v njobs pkg lbi . GReplExe replFlags
-- | Building an executable, starting the REPL, and building foreign
-- libraries are all very similar and implemented in 'gbuild'. The
-- 'GBuildMode' distinguishes between the various kinds of operation.
-data GBuildMode =
- GBuildExe Executable
- | GReplExe ReplOptions Executable
+data GBuildMode
+ = GBuildExe Executable
+ | GReplExe ReplOptions Executable
| GBuildFLib ForeignLib
- | GReplFLib ReplOptions ForeignLib
+ | GReplFLib ReplOptions ForeignLib
gbuildInfo :: GBuildMode -> BuildInfo
-gbuildInfo (GBuildExe exe) = buildInfo exe
-gbuildInfo (GReplExe _ exe) = buildInfo exe
+gbuildInfo (GBuildExe exe) = buildInfo exe
+gbuildInfo (GReplExe _ exe) = buildInfo exe
gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib
-gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib
+gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib
gbuildName :: GBuildMode -> String
-gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe
-gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe
+gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe
+gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe
gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib
-gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib
+gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib
gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String
-gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe
-gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe
+gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe
+gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe
gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib
-gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib
+gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib
exeTargetName :: Platform -> Executable -> String
exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform
@@ -1072,22 +1348,23 @@ exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeEx
-- than the target OS (but this is wrong elsewhere in Cabal as well).
flibTargetName :: LocalBuildInfo -> ForeignLib -> String
flibTargetName lbi flib =
- case (os, foreignLibType flib) of
- (Windows, ForeignLibNativeShared) -> nm <.> "dll"
- (Windows, ForeignLibNativeStatic) -> nm <.> "lib"
- (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt
- (_other, ForeignLibNativeShared) ->
- "lib" ++ nm <.> dllExtension (hostPlatform lbi)
- (_other, ForeignLibNativeStatic) ->
- "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)
- (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"
+ case (os, foreignLibType flib) of
+ (Windows, ForeignLibNativeShared) -> nm <.> "dll"
+ (Windows, ForeignLibNativeStatic) -> nm <.> "lib"
+ (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt
+ (_other, ForeignLibNativeShared) ->
+ "lib" ++ nm <.> dllExtension (hostPlatform lbi)
+ (_other, ForeignLibNativeStatic) ->
+ "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)
+ (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"
where
nm :: String
nm = unUnqualComponentName $ foreignLibName flib
os :: OS
- os = let (Platform _ os') = hostPlatform lbi
- in os'
+ os =
+ let (Platform _ os') = hostPlatform lbi
+ in os'
-- If a foreign lib foo has lib-version-info 5:1:2 or
-- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1
@@ -1096,7 +1373,7 @@ flibTargetName lbi flib =
versionedExt :: String
versionedExt =
let nums = foreignLibVersion flib os
- in foldl (<.>) "so" (map show nums)
+ in foldl (<.>) "so" (map show nums)
-- | Name for the library when building.
--
@@ -1118,32 +1395,33 @@ flibBuildName :: LocalBuildInfo -> ForeignLib -> String
flibBuildName lbi flib
-- On linux, if a foreign-library has version data, the first digit is used
-- to produce the SONAME.
- | (os, foreignLibType flib) ==
- (Linux, ForeignLibNativeShared)
- = let nums = foreignLibVersion flib os
- in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))
+ | (os, foreignLibType flib)
+ == (Linux, ForeignLibNativeShared) =
+ let nums = foreignLibVersion flib os
+ in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))
| otherwise = flibTargetName lbi flib
where
os :: OS
- os = let (Platform _ os') = hostPlatform lbi
- in os'
+ os =
+ let (Platform _ os') = hostPlatform lbi
+ in os'
nm :: String
nm = unUnqualComponentName $ foreignLibName flib
gbuildIsRepl :: GBuildMode -> Bool
-gbuildIsRepl (GBuildExe _) = False
+gbuildIsRepl (GBuildExe _) = False
gbuildIsRepl (GReplExe _ _) = True
gbuildIsRepl (GBuildFLib _) = False
gbuildIsRepl (GReplFLib _ _) = True
gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool
gbuildNeedDynamic lbi bm =
- case bm of
- GBuildExe _ -> withDynExe lbi
- GReplExe _ _ -> withDynExe lbi
- GBuildFLib flib -> withDynFLib flib
- GReplFLib _ flib -> withDynFLib flib
+ case bm of
+ GBuildExe _ -> withDynExe lbi
+ GReplExe _ _ -> withDynExe lbi
+ GBuildFLib flib -> withDynFLib flib
+ GReplFLib _ flib -> withDynFLib flib
where
withDynFLib flib =
case foreignLibType flib of
@@ -1151,12 +1429,12 @@ gbuildNeedDynamic lbi bm =
ForeignLibStandalone `notElem` foreignLibOptions flib
ForeignLibNativeStatic ->
False
- ForeignLibTypeUnknown ->
+ ForeignLibTypeUnknown ->
cabalBug "unknown foreign lib type"
gbuildModDefFiles :: GBuildMode -> [FilePath]
-gbuildModDefFiles (GBuildExe _) = []
-gbuildModDefFiles (GReplExe _ _) = []
+gbuildModDefFiles (GBuildExe _) = []
+gbuildModDefFiles (GReplExe _ _) = []
gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib
gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib
@@ -1166,18 +1444,18 @@ gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib
-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.
exeMainModuleName :: Executable -> Maybe ModuleName
exeMainModuleName Executable{buildInfo = bnfo} =
- -- GHC honors the last occurrence of a module name updated via -main-is
- --
- -- Moreover, -main-is when parsed left-to-right can update either
- -- the "Main" module name, or the "main" function name, or both,
- -- see also 'decodeMainIsArg'.
- msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts
+ -- GHC honors the last occurrence of a module name updated via -main-is
+ --
+ -- Moreover, -main-is when parsed left-to-right can update either
+ -- the "Main" module name, or the "main" function name, or both,
+ -- see also 'decodeMainIsArg'.
+ msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts
where
ghcopts = hcOptions GHC bnfo
findIsMainArgs [] = []
- findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest
- findIsMainArgs (_:rest) = findIsMainArgs rest
+ findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest
+ findIsMainArgs (_ : rest) = findIsMainArgs rest
-- | Decode argument to '-main-is'
--
@@ -1189,25 +1467,28 @@ exeMainModuleName Executable{buildInfo = bnfo} =
-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg arg
- | headOf main_fn isLower
- -- The arg looked like "Foo.Bar.baz"
- = Just (ModuleName.fromString main_mod)
- | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
- = Just (ModuleName.fromString arg)
- | otherwise -- The arg looked like "baz"
- = Nothing
+ | headOf main_fn isLower =
+ -- The arg looked like "Foo.Bar.baz"
+ Just (ModuleName.fromString main_mod)
+ | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
+ =
+ Just (ModuleName.fromString arg)
+ | otherwise -- The arg looked like "baz"
+ =
+ Nothing
where
headOf :: String -> (Char -> Bool) -> Bool
headOf str pred' = any pred' (safeHead str)
(main_mod, main_fn) = splitLongestPrefix arg (== '.')
- splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
+ splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
splitLongestPrefix str pred'
- | null r_pre = (str, [])
- | otherwise = (reverse (safeTail r_pre), reverse r_suf)
- -- 'safeTail' drops the char satisfying 'pred'
- where (r_suf, r_pre) = break pred' (reverse str)
+ | null r_pre = (str, [])
+ | otherwise = (reverse (safeTail r_pre), reverse r_suf)
+ where
+ -- 'safeTail' drops the char satisfying 'pred'
+ (r_suf, r_pre) = break pred' (reverse str)
-- | A collection of:
-- * C input files
@@ -1216,26 +1497,27 @@ decodeMainIsArg arg
-- * GHC input modules
--
-- Used to correctly build and link sources.
-data BuildSources = BuildSources {
- cSourcesFiles :: [FilePath],
- cxxSourceFiles :: [FilePath],
- inputSourceFiles :: [FilePath],
- inputSourceModules :: [ModuleName]
- }
+data BuildSources = BuildSources
+ { cSourcesFiles :: [FilePath]
+ , cxxSourceFiles :: [FilePath]
+ , inputSourceFiles :: [FilePath]
+ , inputSourceModules :: [ModuleName]
+ }
-- | Locate and return the 'BuildSources' required to build and link.
-gbuildSources :: Verbosity
- -> PackageId
- -> CabalSpecVersion
- -> FilePath
- -> GBuildMode
- -> IO BuildSources
+gbuildSources
+ :: Verbosity
+ -> PackageId
+ -> CabalSpecVersion
+ -> FilePath
+ -> GBuildMode
+ -> IO BuildSources
gbuildSources verbosity pkgId specVer tmpDir bm =
- case bm of
- GBuildExe exe -> exeSources exe
- GReplExe _ exe -> exeSources exe
- GBuildFLib flib -> return $ flibSources flib
- GReplFLib _ flib -> return $ flibSources flib
+ case bm of
+ GBuildExe exe -> exeSources exe
+ GReplExe _ exe -> exeSources exe
+ GBuildFLib flib -> return $ flibSources flib
+ GReplFLib _ flib -> return $ flibSources flib
where
exeSources :: Executable -> IO BuildSources
exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do
@@ -1247,57 +1529,62 @@ gbuildSources verbosity pkgId specVer tmpDir bm =
if isHaskell main || pkgId == fakePackageId
then
if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames)
- then do
- -- The cabal manual clearly states that `other-modules` is
- -- intended for non-main modules. However, there's at least one
- -- important package on Hackage (happy-1.19.5) which
- -- violates this. We workaround this here so that we don't
- -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which
- -- would result in GHC complaining about duplicate Main
- -- modules.
- --
- -- Finally, we only enable this workaround for
- -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
- -- have no excuse anymore to keep doing it wrong... ;-)
- warn verbosity $ "Enabling workaround for Main module '"
- ++ prettyShow mainModName
- ++ "' listed in 'other-modules' illegally!"
-
- return BuildSources {
- cSourcesFiles = cSources bnfo,
- cxxSourceFiles = cxxSources bnfo,
- inputSourceFiles = [main],
- inputSourceModules = filter (/= mainModName) $
- exeModules exe
- }
-
- else return BuildSources {
- cSourcesFiles = cSources bnfo,
- cxxSourceFiles = cxxSources bnfo,
- inputSourceFiles = [main],
- inputSourceModules = exeModules exe
- }
- else let (csf, cxxsf)
- | isCxx main = ( cSources bnfo, main : cxxSources bnfo)
- -- if main is not a Haskell source
- -- and main is not a C++ source
- -- then we assume that it is a C source
- | otherwise = (main : cSources bnfo, cxxSources bnfo)
-
- in return BuildSources {
- cSourcesFiles = csf,
- cxxSourceFiles = cxxsf,
- inputSourceFiles = [],
- inputSourceModules = exeModules exe
- }
+ then do
+ -- The cabal manual clearly states that `other-modules` is
+ -- intended for non-main modules. However, there's at least one
+ -- important package on Hackage (happy-1.19.5) which
+ -- violates this. We workaround this here so that we don't
+ -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which
+ -- would result in GHC complaining about duplicate Main
+ -- modules.
+ --
+ -- Finally, we only enable this workaround for
+ -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
+ -- have no excuse anymore to keep doing it wrong... ;-)
+ warn verbosity $
+ "Enabling workaround for Main module '"
+ ++ prettyShow mainModName
+ ++ "' listed in 'other-modules' illegally!"
+
+ return
+ BuildSources
+ { cSourcesFiles = cSources bnfo
+ , cxxSourceFiles = cxxSources bnfo
+ , inputSourceFiles = [main]
+ , inputSourceModules =
+ filter (/= mainModName) $
+ exeModules exe
+ }
+ else
+ return
+ BuildSources
+ { cSourcesFiles = cSources bnfo
+ , cxxSourceFiles = cxxSources bnfo
+ , inputSourceFiles = [main]
+ , inputSourceModules = exeModules exe
+ }
+ else
+ let (csf, cxxsf)
+ | isCxx main = (cSources bnfo, main : cxxSources bnfo)
+ -- if main is not a Haskell source
+ -- and main is not a C++ source
+ -- then we assume that it is a C source
+ | otherwise = (main : cSources bnfo, cxxSources bnfo)
+ in return
+ BuildSources
+ { cSourcesFiles = csf
+ , cxxSourceFiles = cxxsf
+ , inputSourceFiles = []
+ , inputSourceModules = exeModules exe
+ }
flibSources :: ForeignLib -> BuildSources
flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =
- BuildSources {
- cSourcesFiles = cSources bnfo,
- cxxSourceFiles = cxxSources bnfo,
- inputSourceFiles = [],
- inputSourceModules = foreignLibModules flib
+ BuildSources
+ { cSourcesFiles = cSources bnfo
+ , cxxSourceFiles = cxxSources bnfo
+ , inputSourceFiles = []
+ , inputSourceModules = foreignLibModules flib
}
isCxx :: FilePath -> Bool
@@ -1309,31 +1596,36 @@ isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]
replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a
replNoLoad replFlags l
- | replOptionsNoLoad replFlags == Flag True = mempty
- | otherwise = l
+ | replOptionsNoLoad replFlags == Flag True = mempty
+ | otherwise = l
-- | Generic build function. See comment for 'GBuildMode'.
-gbuild :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> GBuildMode -> ComponentLocalBuildInfo -> IO ()
+gbuild
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> GBuildMode
+ -> ComponentLocalBuildInfo
+ -> IO ()
gbuild verbosity numJobs pkg_descr lbi bm clbi = do
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
let replFlags = case bm of
- GReplExe flags _ -> flags
- GReplFLib flags _ -> flags
- GBuildExe{} -> mempty
- GBuildFLib{} -> mempty
- comp = compiler lbi
- platform = hostPlatform lbi
- implInfo = getImplInfo comp
+ GReplExe flags _ -> flags
+ GReplFLib flags _ -> flags
+ GBuildExe{} -> mempty
+ GBuildFLib{} -> mempty
+ comp = compiler lbi
+ platform = hostPlatform lbi
+ implInfo = getImplInfo comp
runGhcProg = runGHC verbosity ghcProg comp platform
let bnfo = gbuildInfo bm
-- the name that GHC really uses (e.g., with .exe on Windows for executables)
let targetName = gbuildTargetName lbi bm
- let targetDir = buildDir lbi </> (gbuildName bm)
- let tmpDir = targetDir </> (gbuildName bm ++ "-tmp")
+ let targetDir = buildDir lbi </> (gbuildName bm)
+ let tmpDir = targetDir </> (gbuildName bm ++ "-tmp")
createDirectoryIfMissingVerbose verbosity True targetDir
createDirectoryIfMissingVerbose verbosity True tmpDir
@@ -1345,9 +1637,9 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
let isCoverageEnabled = exeCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
- | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
+ | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)
- | otherwise = mempty
+ | otherwise = mempty
rpaths <- getRPaths lbi clbi
buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm
@@ -1356,107 +1648,137 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
cleanedExtraLibDirs <- filterM doesDirectoryExist (extraLibDirs bnfo)
cleanedExtraLibDirsStatic <- filterM doesDirectoryExist (extraLibDirsStatic bnfo)
-
- let cSrcs = cSourcesFiles buildSources
- cxxSrcs = cxxSourceFiles buildSources
- inputFiles = inputSourceFiles buildSources
- inputModules = inputSourceModules buildSources
- isGhcDynamic = isDynamic comp
+ let cSrcs = cSourcesFiles buildSources
+ cxxSrcs = cxxSourceFiles buildSources
+ inputFiles = inputSourceFiles buildSources
+ inputModules = inputSourceModules buildSources
+ isGhcDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
- cLikeObjs = map (`replaceExtension` objExtension) cSrcs
- cxxObjs = map (`replaceExtension` objExtension) cxxSrcs
- needDynamic = gbuildNeedDynamic lbi bm
- needProfiling = withProfExe lbi
-
- -- build executables
- baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir)
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeMake,
- ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId
- then filter isHaskell inputFiles
- else inputFiles,
- ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId
- then filter (not . isHaskell) inputFiles
- else [],
- ghcOptInputModules = toNubListR inputModules
- }
- staticOpts = baseOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticOnly,
- ghcOptHPCDir = hpcdir Hpc.Vanilla
- }
- profOpts = baseOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptProfilingAuto = Internal.profDetailLevelFlag False
- (withProfExeDetail lbi),
- ghcOptHiSuffix = toFlag "p_hi",
- ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = hcProfOptions GHC bnfo,
- ghcOptHPCDir = hpcdir Hpc.Prof
- }
- dynOpts = baseOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- -- TODO: Does it hurt to set -fPIC for executables?
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "dyn_hi",
- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = hcSharedOptions GHC bnfo,
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
- dynTooOpts = staticOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
- ghcOptDynHiSuffix = toFlag "dyn_hi",
- ghcOptDynObjSuffix = toFlag "dyn_o",
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
- linkerOpts = mempty {
- ghcOptLinkOptions = PD.ldOptions bnfo
- ++ [ "-static"
- | withFullyStaticExe lbi ]
- -- Pass extra `ld-options` given
- -- through to GHC's linker.
- ++ maybe [] programOverrideArgs
- (lookupProgram ldProgram (withPrograms lbi)),
- ghcOptLinkLibs = if withFullyStaticExe lbi
- then extraLibsStatic bnfo
- else extraLibs bnfo,
- ghcOptLinkLibPath = toNubListR $
- if withFullyStaticExe lbi
- then cleanedExtraLibDirsStatic
- else cleanedExtraLibDirs,
- ghcOptLinkFrameworks = toNubListR $
- PD.frameworks bnfo,
- ghcOptLinkFrameworkDirs = toNubListR $
- PD.extraFrameworkDirs bnfo,
- ghcOptInputFiles = toNubListR
- [tmpDir </> x | x <- cLikeObjs ++ cxxObjs]
- }
- dynLinkerOpts = mempty {
- ghcOptRPaths = rpaths,
- ghcOptInputFiles = toNubListR
- [tmpDir </> x | x <- cLikeObjs ++ cxxObjs]
- }
- replOpts = baseOpts {
- ghcOptExtra = Internal.filterGhciFlags
- (ghcOptExtra baseOpts)
- <> replOptionsFlags replFlags,
- ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts),
- ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts)
- }
- -- For a normal compile we do separate invocations of ghc for
- -- compiling as for linking. But for repl we have to do just
- -- the one invocation, so that one has to include all the
- -- linker stuff too, like -l flags and any .o files from C
- -- files etc.
- `mappend` linkerOpts
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeInteractive,
- ghcOptOptimisation = toFlag GhcNoOptimisation
- }
- commonOpts | needProfiling = profOpts
- | needDynamic = dynOpts
- | otherwise = staticOpts
- compileOpts | useDynToo = dynTooOpts
- | otherwise = commonOpts
+ cLikeObjs = map (`replaceExtension` objExtension) cSrcs
+ cxxObjs = map (`replaceExtension` objExtension) cxxSrcs
+ needDynamic = gbuildNeedDynamic lbi bm
+ needProfiling = withProfExe lbi
+
+ -- build executables
+ baseOpts =
+ (componentGhcOptions verbosity lbi bnfo clbi tmpDir)
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeMake
+ , ghcOptInputFiles =
+ toNubListR $
+ if package pkg_descr == fakePackageId
+ then filter isHaskell inputFiles
+ else inputFiles
+ , ghcOptInputScripts =
+ toNubListR $
+ if package pkg_descr == fakePackageId
+ then filter (not . isHaskell) inputFiles
+ else []
+ , ghcOptInputModules = toNubListR inputModules
+ }
+ staticOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcStaticOnly
+ , ghcOptHPCDir = hpcdir Hpc.Vanilla
+ }
+ profOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptProfilingAuto =
+ Internal.profDetailLevelFlag
+ False
+ (withProfExeDetail lbi)
+ , ghcOptHiSuffix = toFlag "p_hi"
+ , ghcOptObjSuffix = toFlag "p_o"
+ , ghcOptExtra = hcProfOptions GHC bnfo
+ , ghcOptHPCDir = hpcdir Hpc.Prof
+ }
+ dynOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , -- TODO: Does it hurt to set -fPIC for executables?
+ ghcOptFPic = toFlag True
+ , ghcOptHiSuffix = toFlag "dyn_hi"
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ , ghcOptExtra = hcSharedOptions GHC bnfo
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ dynTooOpts =
+ staticOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
+ , ghcOptDynHiSuffix = toFlag "dyn_hi"
+ , ghcOptDynObjSuffix = toFlag "dyn_o"
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ linkerOpts =
+ mempty
+ { ghcOptLinkOptions =
+ PD.ldOptions bnfo
+ ++ [ "-static"
+ | withFullyStaticExe lbi
+ ]
+ -- Pass extra `ld-options` given
+ -- through to GHC's linker.
+ ++ maybe
+ []
+ programOverrideArgs
+ (lookupProgram ldProgram (withPrograms lbi))
+ , ghcOptLinkLibs =
+ if withFullyStaticExe lbi
+ then extraLibsStatic bnfo
+ else extraLibs bnfo
+ , ghcOptLinkLibPath =
+ toNubListR $
+ if withFullyStaticExe lbi
+ then cleanedExtraLibDirsStatic
+ else cleanedExtraLibDirs
+ , ghcOptLinkFrameworks =
+ toNubListR $
+ PD.frameworks bnfo
+ , ghcOptLinkFrameworkDirs =
+ toNubListR $
+ PD.extraFrameworkDirs bnfo
+ , ghcOptInputFiles =
+ toNubListR
+ [tmpDir </> x | x <- cLikeObjs ++ cxxObjs]
+ }
+ dynLinkerOpts =
+ mempty
+ { ghcOptRPaths = rpaths
+ , ghcOptInputFiles =
+ toNubListR
+ [tmpDir </> x | x <- cLikeObjs ++ cxxObjs]
+ }
+ replOpts =
+ baseOpts
+ { ghcOptExtra =
+ Internal.filterGhciFlags
+ (ghcOptExtra baseOpts)
+ <> replOptionsFlags replFlags
+ , ghcOptInputModules = replNoLoad replFlags (ghcOptInputModules baseOpts)
+ , ghcOptInputFiles = replNoLoad replFlags (ghcOptInputFiles baseOpts)
+ }
+ -- For a normal compile we do separate invocations of ghc for
+ -- compiling as for linking. But for repl we have to do just
+ -- the one invocation, so that one has to include all the
+ -- linker stuff too, like -l flags and any .o files from C
+ -- files etc.
+ `mappend` linkerOpts
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeInteractive
+ , ghcOptOptimisation = toFlag GhcNoOptimisation
+ }
+ commonOpts
+ | needProfiling = profOpts
+ | needDynamic = dynOpts
+ | otherwise = staticOpts
+ compileOpts
+ | useDynToo = dynTooOpts
+ | otherwise = commonOpts
withStaticExe = not needProfiling && not needDynamic
-- For building exe's that use TH with -prof or -dynamic we actually have
@@ -1468,171 +1790,218 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- need to be .dyn_o instead of .o.
doingTH = usesTemplateHaskellOrQQ bnfo
-- Should we use -dynamic-too instead of compiling twice?
- useDynToo = dynamicTooSupported && isGhcDynamic
- && doingTH && withStaticExe
- && null (hcSharedOptions GHC bnfo)
- compileTHOpts | isGhcDynamic = dynOpts
- | otherwise = staticOpts
+ useDynToo =
+ dynamicTooSupported
+ && isGhcDynamic
+ && doingTH
+ && withStaticExe
+ && null (hcSharedOptions GHC bnfo)
+ compileTHOpts
+ | isGhcDynamic = dynOpts
+ | otherwise = staticOpts
compileForTH
| gbuildIsRepl bm = False
- | useDynToo = False
- | isGhcDynamic = doingTH && (needProfiling || withStaticExe)
- | otherwise = doingTH && (needProfiling || needDynamic)
+ | useDynToo = False
+ | isGhcDynamic = doingTH && (needProfiling || withStaticExe)
+ | otherwise = doingTH && (needProfiling || needDynamic)
- -- Build static/dynamic object files for TH, if needed.
+ -- Build static/dynamic object files for TH, if needed.
when compileForTH $
- runGhcProg compileTHOpts { ghcOptNoLink = toFlag True
- , ghcOptNumJobs = numJobs }
+ runGhcProg
+ compileTHOpts
+ { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = numJobs
+ }
-- Do not try to build anything if there are no input files.
-- This can happen if the cabal file ends up with only cSrcs
-- but no Haskell modules.
- unless ((null inputFiles && null inputModules)
- || gbuildIsRepl bm) $
- runGhcProg compileOpts { ghcOptNoLink = toFlag True
- , ghcOptNumJobs = numJobs }
+ unless
+ ( (null inputFiles && null inputModules)
+ || gbuildIsRepl bm
+ )
+ $ runGhcProg
+ compileOpts
+ { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = numJobs
+ }
-- build any C++ sources
unless (null cxxSrcs) $ do
- info verbosity "Building C++ Sources..."
- sequence_
- [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo
- lbi bnfo clbi tmpDir filename
- vanillaCxxOpts = if isGhcDynamic
- -- Dynamic GHC requires C++ sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCxxOpts { ghcOptFPic = toFlag True }
- else baseCxxOpts
- profCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True
- }
- sharedCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly
- }
- opts | needProfiling = profCxxOpts
- | needDynamic = sharedCxxOpts
- | otherwise = vanillaCxxOpts
- -- TODO: Placing all Haskell, C, & C++ objects in a single directory
- -- Has the potential for file collisions. In general we would
- -- consider this a user error. However, we should strive to
- -- add a warning if this occurs.
- odir = fromFlag (ghcOptObjDir opts)
- createDirectoryIfMissingVerbose verbosity True odir
- needsRecomp <- checkNeedsRecompilation filename opts
- when needsRecomp $
- runGhcProg opts
- | filename <- cxxSrcs ]
+ info verbosity "Building C++ Sources..."
+ sequence_
+ [ do
+ let baseCxxOpts =
+ Internal.componentCxxGhcOptions
+ verbosity
+ implInfo
+ lbi
+ bnfo
+ clbi
+ tmpDir
+ filename
+ vanillaCxxOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires C++ sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseCxxOpts{ghcOptFPic = toFlag True}
+ else baseCxxOpts
+ profCxxOpts =
+ vanillaCxxOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ }
+ sharedCxxOpts =
+ vanillaCxxOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ }
+ opts
+ | needProfiling = profCxxOpts
+ | needDynamic = sharedCxxOpts
+ | otherwise = vanillaCxxOpts
+ -- TODO: Placing all Haskell, C, & C++ objects in a single directory
+ -- Has the potential for file collisions. In general we would
+ -- consider this a user error. However, we should strive to
+ -- add a warning if this occurs.
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ needsRecomp <- checkNeedsRecompilation filename opts
+ when needsRecomp $
+ runGhcProg opts
+ | filename <- cxxSrcs
+ ]
-- build any C sources
unless (null cSrcs) $ do
- info verbosity "Building C Sources..."
- sequence_
- [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo
- lbi bnfo clbi tmpDir filename
- vanillaCcOpts = if isGhcDynamic
- -- Dynamic GHC requires C sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCcOpts { ghcOptFPic = toFlag True }
- else baseCcOpts
- profCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True
- }
- sharedCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly
- }
- opts | needProfiling = profCcOpts
- | needDynamic = sharedCcOpts
- | otherwise = vanillaCcOpts
- odir = fromFlag (ghcOptObjDir opts)
- createDirectoryIfMissingVerbose verbosity True odir
- needsRecomp <- checkNeedsRecompilation filename opts
- when needsRecomp $
- runGhcProg opts
- | filename <- cSrcs ]
+ info verbosity "Building C Sources..."
+ sequence_
+ [ do
+ let baseCcOpts =
+ Internal.componentCcGhcOptions
+ verbosity
+ implInfo
+ lbi
+ bnfo
+ clbi
+ tmpDir
+ filename
+ vanillaCcOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires C sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseCcOpts{ghcOptFPic = toFlag True}
+ else baseCcOpts
+ profCcOpts =
+ vanillaCcOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ }
+ sharedCcOpts =
+ vanillaCcOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ }
+ opts
+ | needProfiling = profCcOpts
+ | needDynamic = sharedCcOpts
+ | otherwise = vanillaCcOpts
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ needsRecomp <- checkNeedsRecompilation filename opts
+ when needsRecomp $
+ runGhcProg opts
+ | filename <- cSrcs
+ ]
-- TODO: problem here is we need the .c files built first, so we can load them
-- with ghci, but .c files can depend on .h files generated by ghc by ffi
-- exports.
case bm of
- GReplExe _ _ -> runGhcProg replOpts
+ GReplExe _ _ -> runGhcProg replOpts
GReplFLib _ _ -> runGhcProg replOpts
GBuildExe _ -> do
- let linkOpts = commonOpts
- `mappend` linkerOpts
- `mappend` mempty {
- ghcOptLinkNoHsMain = toFlag (null inputFiles)
- }
- `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)
+ let linkOpts =
+ commonOpts
+ `mappend` linkerOpts
+ `mappend` mempty
+ { ghcOptLinkNoHsMain = toFlag (null inputFiles)
+ }
+ `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)
info verbosity "Linking..."
-- Work around old GHCs not relinking in this
-- situation, see #3294
let target = targetDir </> targetName
- when (compilerVersion comp < mkVersion [7,7]) $ do
+ when (compilerVersion comp < mkVersion [7, 7]) $ do
e <- doesFileExist target
when e (removeFile target)
- runGhcProg linkOpts { ghcOptOutputFile = toFlag target }
+ runGhcProg linkOpts{ghcOptOutputFile = toFlag target}
GBuildFLib flib -> do
- let -- Instruct GHC to link against libHSrts.
- rtsLinkOpts :: GhcOptions
- rtsLinkOpts
- | supportsFLinkRts =
- mempty {
- ghcOptLinkRts = toFlag True
- }
- | otherwise =
- mempty {
- ghcOptLinkLibs = rtsOptLinkLibs,
- ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo
- }
- where
- threaded = hasThreaded (gbuildInfo bm)
- supportsFLinkRts = compilerVersion comp >= mkVersion [9,0]
- rtsInfo = extractRtsInfo lbi
- rtsOptLinkLibs = [
- if needDynamic
- then if threaded
- then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)
- else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)
- else if threaded
- then statRtsThreadedLib (rtsStaticInfo rtsInfo)
- else statRtsVanillaLib (rtsStaticInfo rtsInfo)
- ]
-
-
- linkOpts :: GhcOptions
- linkOpts = case foreignLibType flib of
- ForeignLibNativeShared ->
- commonOpts
+ let
+ -- Instruct GHC to link against libHSrts.
+ rtsLinkOpts :: GhcOptions
+ rtsLinkOpts
+ | supportsFLinkRts =
+ mempty
+ { ghcOptLinkRts = toFlag True
+ }
+ | otherwise =
+ mempty
+ { ghcOptLinkLibs = rtsOptLinkLibs
+ , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo
+ }
+ where
+ threaded = hasThreaded (gbuildInfo bm)
+ supportsFLinkRts = compilerVersion comp >= mkVersion [9, 0]
+ rtsInfo = extractRtsInfo lbi
+ rtsOptLinkLibs =
+ [ if needDynamic
+ then
+ if threaded
+ then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)
+ else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)
+ else
+ if threaded
+ then statRtsThreadedLib (rtsStaticInfo rtsInfo)
+ else statRtsVanillaLib (rtsStaticInfo rtsInfo)
+ ]
+
+ linkOpts :: GhcOptions
+ linkOpts = case foreignLibType flib of
+ ForeignLibNativeShared ->
+ commonOpts
`mappend` linkerOpts
`mappend` dynLinkerOpts
`mappend` rtsLinkOpts
- `mappend` mempty {
- ghcOptLinkNoHsMain = toFlag True,
- ghcOptShared = toFlag True,
- ghcOptFPic = toFlag True,
- ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm
+ `mappend` mempty
+ { ghcOptLinkNoHsMain = toFlag True
+ , ghcOptShared = toFlag True
+ , ghcOptFPic = toFlag True
+ , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm
}
-- See Note [RPATH]
- `mappend` ifNeedsRPathWorkaround lbi mempty {
- ghcOptLinkOptions = ["-Wl,--no-as-needed"]
- , ghcOptLinkLibs = ["ffi"]
- }
- ForeignLibNativeStatic ->
- -- this should be caught by buildFLib
- -- (and if we do implement this, we probably don't even want to call
- -- ghc here, but rather Ar.createArLibArchive or something)
- cabalBug "static libraries not yet implemented"
- ForeignLibTypeUnknown ->
- cabalBug "unknown foreign lib type"
+ `mappend` ifNeedsRPathWorkaround
+ lbi
+ mempty
+ { ghcOptLinkOptions = ["-Wl,--no-as-needed"]
+ , ghcOptLinkLibs = ["ffi"]
+ }
+ ForeignLibNativeStatic ->
+ -- this should be caught by buildFLib
+ -- (and if we do implement this, we probably don't even want to call
+ -- ghc here, but rather Ar.createArLibArchive or something)
+ cabalBug "static libraries not yet implemented"
+ ForeignLibTypeUnknown ->
+ cabalBug "unknown foreign lib type"
-- We build under a (potentially) different filename to set a
-- soname on supported platforms. See also the note for
-- @flibBuildName@.
info verbosity "Linking..."
let buildName = flibBuildName lbi flib
- runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> buildName) }
+ runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir </> buildName)}
renameFile (targetDir </> buildName) (targetDir </> targetName)
{-
@@ -1709,32 +2078,32 @@ ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a
ifNeedsRPathWorkaround lbi a =
case hostPlatform lbi of
Platform _ Linux -> a
- _otherwise -> mempty
-
-data DynamicRtsInfo = DynamicRtsInfo {
- dynRtsVanillaLib :: FilePath
- , dynRtsThreadedLib :: FilePath
- , dynRtsDebugLib :: FilePath
- , dynRtsEventlogLib :: FilePath
- , dynRtsThreadedDebugLib :: FilePath
+ _otherwise -> mempty
+
+data DynamicRtsInfo = DynamicRtsInfo
+ { dynRtsVanillaLib :: FilePath
+ , dynRtsThreadedLib :: FilePath
+ , dynRtsDebugLib :: FilePath
+ , dynRtsEventlogLib :: FilePath
+ , dynRtsThreadedDebugLib :: FilePath
, dynRtsThreadedEventlogLib :: FilePath
}
-data StaticRtsInfo = StaticRtsInfo {
- statRtsVanillaLib :: FilePath
- , statRtsThreadedLib :: FilePath
- , statRtsDebugLib :: FilePath
- , statRtsEventlogLib :: FilePath
- , statRtsThreadedDebugLib :: FilePath
- , statRtsThreadedEventlogLib :: FilePath
- , statRtsProfilingLib :: FilePath
+data StaticRtsInfo = StaticRtsInfo
+ { statRtsVanillaLib :: FilePath
+ , statRtsThreadedLib :: FilePath
+ , statRtsDebugLib :: FilePath
+ , statRtsEventlogLib :: FilePath
+ , statRtsThreadedDebugLib :: FilePath
+ , statRtsThreadedEventlogLib :: FilePath
+ , statRtsProfilingLib :: FilePath
, statRtsThreadedProfilingLib :: FilePath
}
-data RtsInfo = RtsInfo {
- rtsDynamicInfo :: DynamicRtsInfo
- , rtsStaticInfo :: StaticRtsInfo
- , rtsLibPaths :: [FilePath]
+data RtsInfo = RtsInfo
+ { rtsDynamicInfo :: DynamicRtsInfo
+ , rtsStaticInfo :: StaticRtsInfo
+ , rtsLibPaths :: [FilePath]
}
-- | Extract (and compute) information about the RTS library
@@ -1745,65 +2114,73 @@ data RtsInfo = RtsInfo {
-- doesn't really help.
extractRtsInfo :: LocalBuildInfo -> RtsInfo
extractRtsInfo lbi =
- case PackageIndex.lookupPackageName
- (installedPkgs lbi) (mkPackageName "rts") of
- [(_, [rts])] -> aux rts
- _otherwise -> error "No (or multiple) ghc rts package is registered"
+ case PackageIndex.lookupPackageName
+ (installedPkgs lbi)
+ (mkPackageName "rts") of
+ [(_, [rts])] -> aux rts
+ _otherwise -> error "No (or multiple) ghc rts package is registered"
where
aux :: InstalledPackageInfo -> RtsInfo
- aux rts = RtsInfo {
- rtsDynamicInfo = DynamicRtsInfo {
- dynRtsVanillaLib = withGhcVersion "HSrts"
- , dynRtsThreadedLib = withGhcVersion "HSrts_thr"
- , dynRtsDebugLib = withGhcVersion "HSrts_debug"
- , dynRtsEventlogLib = withGhcVersion "HSrts_l"
- , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"
- , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"
- }
- , rtsStaticInfo = StaticRtsInfo {
- statRtsVanillaLib = "HSrts"
- , statRtsThreadedLib = "HSrts_thr"
- , statRtsDebugLib = "HSrts_debug"
- , statRtsEventlogLib = "HSrts_l"
- , statRtsThreadedDebugLib = "HSrts_thr_debug"
- , statRtsThreadedEventlogLib = "HSrts_thr_l"
- , statRtsProfilingLib = "HSrts_p"
- , statRtsThreadedProfilingLib = "HSrts_thr_p"
- }
- , rtsLibPaths = InstalledPackageInfo.libraryDirs rts
- }
+ aux rts =
+ RtsInfo
+ { rtsDynamicInfo =
+ DynamicRtsInfo
+ { dynRtsVanillaLib = withGhcVersion "HSrts"
+ , dynRtsThreadedLib = withGhcVersion "HSrts_thr"
+ , dynRtsDebugLib = withGhcVersion "HSrts_debug"
+ , dynRtsEventlogLib = withGhcVersion "HSrts_l"
+ , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"
+ , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"
+ }
+ , rtsStaticInfo =
+ StaticRtsInfo
+ { statRtsVanillaLib = "HSrts"
+ , statRtsThreadedLib = "HSrts_thr"
+ , statRtsDebugLib = "HSrts_debug"
+ , statRtsEventlogLib = "HSrts_l"
+ , statRtsThreadedDebugLib = "HSrts_thr_debug"
+ , statRtsThreadedEventlogLib = "HSrts_thr_l"
+ , statRtsProfilingLib = "HSrts_p"
+ , statRtsThreadedProfilingLib = "HSrts_thr_p"
+ }
+ , rtsLibPaths = InstalledPackageInfo.libraryDirs rts
+ }
withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))
-- | Returns True if the modification date of the given source file is newer than
-- the object file we last compiled for it, or if no object file exists yet.
checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
checkNeedsRecompilation filename opts = filename `moreRecentFile` oname
- where oname = getObjectFileName filename opts
+ where
+ oname = getObjectFileName filename opts
-- | Finds the object file name of the given source file
getObjectFileName :: FilePath -> GhcOptions -> FilePath
getObjectFileName filename opts = oname
- where odir = fromFlag (ghcOptObjDir opts)
- oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)
- oname = odir </> replaceExtension filename oext
+ where
+ odir = fromFlag (ghcOptObjDir opts)
+ oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)
+ oname = odir </> replaceExtension filename oext
-- | Calculate the RPATHs for the component we are building.
--
-- Calculates relative RPATHs when 'relocatable' is set.
-getRPaths :: LocalBuildInfo
- -> ComponentLocalBuildInfo -- ^ Component we are building
- -> IO (NubListR FilePath)
+getRPaths
+ :: LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -- ^ Component we are building
+ -> IO (NubListR FilePath)
getRPaths lbi clbi | supportRPaths hostOS = do
- libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
- let hostPref = case hostOS of
- OSX -> "@loader_path"
- _ -> "$ORIGIN"
- relPath p = if isRelative p then hostPref </> p else p
- rpaths = toNubListR (map relPath libraryPaths)
- return rpaths
+ libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
+ let hostPref = case hostOS of
+ OSX -> "@loader_path"
+ _ -> "$ORIGIN"
+ relPath p = if isRelative p then hostPref </> p else p
+ rpaths = toNubListR (map relPath libraryPaths)
+ return rpaths
where
(Platform _ hostOS) = hostPlatform lbi
- compid = compilerId . compiler $ lbi
+ compid = compilerId . compiler $ lbi
-- The list of RPath-supported operating systems below reflects the
-- platforms on which Cabal's RPATH handling is tested. It does _NOT_
@@ -1812,29 +2189,29 @@ getRPaths lbi clbi | supportRPaths hostOS = do
-- E.g. when this comment was written, the *BSD operating systems were
-- untested with regards to Cabal RPATH handling, and were hence set to
-- 'False', while those operating systems themselves do support RPATH.
- supportRPaths Linux = True
- supportRPaths Windows = False
- supportRPaths OSX = True
- supportRPaths FreeBSD =
+ supportRPaths Linux = True
+ supportRPaths Windows = False
+ supportRPaths OSX = True
+ supportRPaths FreeBSD =
case compid of
- CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True
- _ -> False
- supportRPaths OpenBSD = False
- supportRPaths NetBSD = False
- supportRPaths DragonFly = False
- supportRPaths Solaris = False
- supportRPaths AIX = False
- supportRPaths HPUX = False
- supportRPaths IRIX = False
- supportRPaths HaLVM = False
- supportRPaths IOS = False
- supportRPaths Android = False
- supportRPaths Ghcjs = False
- supportRPaths Wasi = False
- supportRPaths Hurd = False
+ CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True
+ _ -> False
+ supportRPaths OpenBSD = False
+ supportRPaths NetBSD = False
+ supportRPaths DragonFly = False
+ supportRPaths Solaris = False
+ supportRPaths AIX = False
+ supportRPaths HPUX = False
+ supportRPaths IRIX = False
+ supportRPaths HaLVM = False
+ supportRPaths IOS = False
+ supportRPaths Android = False
+ supportRPaths Ghcjs = False
+ supportRPaths Wasi = False
+ supportRPaths Hurd = False
supportRPaths (OtherOS _) = False
- -- Do _not_ add a default case so that we get a warning here when a new OS
- -- is added.
+-- Do _not_ add a default case so that we get a warning here when a new OS
+-- is added.
getRPaths _ _ = return mempty
@@ -1848,111 +2225,151 @@ hasThreaded bi = elem "-threaded" ghc
-- | Extracts a String representing a hash of the ABI of a built
-- library. It can fail if the library has not yet been built.
---
-libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO String
+libAbiHash
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO String
libAbiHash verbosity _pkg_descr lbi lib clbi = do
let
- libBi = libBuildInfo lib
- comp = compiler lbi
- platform = hostPlatform lbi
- vanillaArgs0 =
- (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeAbiHash,
- ghcOptInputModules = toNubListR $ exposedModules lib
+ libBi = libBuildInfo lib
+ comp = compiler lbi
+ platform = hostPlatform lbi
+ vanillaArgs0 =
+ (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeAbiHash
+ , ghcOptInputModules = toNubListR $ exposedModules lib
+ }
+ vanillaArgs =
+ -- Package DBs unnecessary, and break ghc-cabal. See #3633
+ -- BUT, put at least the global database so that 7.4 doesn't
+ -- break.
+ vanillaArgs0
+ { ghcOptPackageDBs = [GlobalPackageDB]
+ , ghcOptPackages = mempty
}
- vanillaArgs =
- -- Package DBs unnecessary, and break ghc-cabal. See #3633
- -- BUT, put at least the global database so that 7.4 doesn't
- -- break.
- vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB]
- , ghcOptPackages = mempty }
- sharedArgs = vanillaArgs `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "dyn_hi",
- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = hcSharedOptions GHC libBi
- }
- profArgs = vanillaArgs `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptProfilingAuto = Internal.profDetailLevelFlag True
- (withProfLibDetail lbi),
- ghcOptHiSuffix = toFlag "p_hi",
- ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = hcProfOptions GHC libBi
- }
- ghcArgs
- | withVanillaLib lbi = vanillaArgs
- | withSharedLib lbi = sharedArgs
- | withProfLib lbi = profArgs
- | otherwise = error "libAbiHash: Can't find an enabled library way"
+ sharedArgs =
+ vanillaArgs
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptFPic = toFlag True
+ , ghcOptHiSuffix = toFlag "dyn_hi"
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ , ghcOptExtra = hcSharedOptions GHC libBi
+ }
+ profArgs =
+ vanillaArgs
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptProfilingAuto =
+ Internal.profDetailLevelFlag
+ True
+ (withProfLibDetail lbi)
+ , ghcOptHiSuffix = toFlag "p_hi"
+ , ghcOptObjSuffix = toFlag "p_o"
+ , ghcOptExtra = hcProfOptions GHC libBi
+ }
+ ghcArgs
+ | withVanillaLib lbi = vanillaArgs
+ | withSharedLib lbi = sharedArgs
+ | withProfLib lbi = profArgs
+ | otherwise = error "libAbiHash: Can't find an enabled library way"
(ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)
- hash <- getProgramInvocationOutput verbosity
- (ghcInvocation ghcProg comp platform ghcArgs)
+ hash <-
+ getProgramInvocationOutput
+ verbosity
+ (ghcInvocation ghcProg comp platform ghcArgs)
return (takeWhile (not . isSpace) hash)
-componentGhcOptions :: Verbosity -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
- -> GhcOptions
+componentGhcOptions
+ :: Verbosity
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> GhcOptions
componentGhcOptions verbosity lbi =
Internal.componentGhcOptions verbosity implInfo lbi
where
- comp = compiler lbi
+ comp = compiler lbi
implInfo = getImplInfo comp
-componentCcGhcOptions :: Verbosity -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+componentCcGhcOptions
+ :: Verbosity
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentCcGhcOptions verbosity lbi =
- Internal.componentCcGhcOptions verbosity implInfo lbi
+ Internal.componentCcGhcOptions verbosity implInfo lbi
where
- comp = compiler lbi
+ comp = compiler lbi
implInfo = getImplInfo comp
-- -----------------------------------------------------------------------------
-- Installing
--- |Install executables for GHC.
-installExe :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^Where to copy the files to
- -> FilePath -- ^Build location
- -> (FilePath, FilePath) -- ^Executable (prefix,suffix)
- -> PackageDescription
- -> Executable
- -> IO ()
-installExe verbosity lbi binDir buildPref
- (progprefix, progsuffix) _pkg exe = do
- createDirectoryIfMissingVerbose verbosity True binDir
- let exeName' = unUnqualComponentName $ exeName exe
- exeFileName = exeTargetName (hostPlatform lbi) exe
- fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
- installBinary dest = do
- installExecutableFile verbosity
+-- | Install executables for GHC.
+installExe
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ Where to copy the files to
+ -> FilePath
+ -- ^ Build location
+ -> (FilePath, FilePath)
+ -- ^ Executable (prefix,suffix)
+ -> PackageDescription
+ -> Executable
+ -> IO ()
+installExe
+ verbosity
+ lbi
+ binDir
+ buildPref
+ (progprefix, progsuffix)
+ _pkg
+ exe = do
+ createDirectoryIfMissingVerbose verbosity True binDir
+ let exeName' = unUnqualComponentName $ exeName exe
+ exeFileName = exeTargetName (hostPlatform lbi) exe
+ fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
+ installBinary dest = do
+ installExecutableFile
+ verbosity
(buildPref </> exeName' </> exeFileName)
(dest <.> exeExtension (hostPlatform lbi))
when (stripExes lbi) $
- Strip.stripExe verbosity (hostPlatform lbi) (withPrograms lbi)
- (dest <.> exeExtension (hostPlatform lbi))
- installBinary (binDir </> fixedExeBaseName)
-
--- |Install foreign library for GHC.
-installFLib :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^install location
- -> FilePath -- ^Build location
- -> PackageDescription
- -> ForeignLib
- -> IO ()
+ Strip.stripExe
+ verbosity
+ (hostPlatform lbi)
+ (withPrograms lbi)
+ (dest <.> exeExtension (hostPlatform lbi))
+ installBinary (binDir </> fixedExeBaseName)
+
+-- | Install foreign library for GHC.
+installFLib
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ install location
+ -> FilePath
+ -- ^ Build location
+ -> PackageDescription
+ -> ForeignLib
+ -> IO ()
installFLib verbosity lbi targetDir builtDir _pkg flib =
- install (foreignLibIsShared flib)
- builtDir
- targetDir
- (flibTargetName lbi flib)
+ install
+ (foreignLibIsShared flib)
+ builtDir
+ targetDir
+ (flibTargetName lbi flib)
where
install isShared srcDir dstDir name = do
let src = srcDir </> name
@@ -1961,49 +2378,54 @@ installFLib verbosity lbi targetDir builtDir _pkg flib =
-- TODO: Should we strip? (stripLibs lbi)
if isShared
then installExecutableFile verbosity src dst
- else installOrdinaryFile verbosity src dst
+ else installOrdinaryFile verbosity src dst
-- Now install appropriate symlinks if library is versioned
let (Platform _ os) = hostPlatform lbi
when (not (null (foreignLibVersion flib os))) $ do
- when (os /= Linux) $ die' verbosity
+ when (os /= Linux) $
+ die'
+ verbosity
-- It should be impossible to get here.
"Can't install foreign-library symlink on non-Linux OS"
#ifndef mingw32_HOST_OS
- -- 'createSymbolicLink file1 file2' creates a symbolic link
- -- named 'file2' which points to the file 'file1'.
- -- Note that we do want a symlink to 'name' rather than
- -- 'dst', because the symlink will be relative to the
- -- directory it's created in.
- -- Finally, we first create the symlinks in a temporary
- -- directory and then rename to simulate 'ln --force'.
- withTempDirectory verbosity dstDir nm $ \tmpDir -> do
- let link1 = flibBuildName lbi flib
- link2 = "lib" ++ nm <.> "so"
- createSymbolicLink name (tmpDir </> link1)
- renameFile (tmpDir </> link1) (dstDir </> link1)
- createSymbolicLink name (tmpDir </> link2)
- renameFile (tmpDir </> link2) (dstDir </> link2)
- where
- nm :: String
- nm = unUnqualComponentName $ foreignLibName flib
+ -- 'createSymbolicLink file1 file2' creates a symbolic link
+ -- named 'file2' which points to the file 'file1'.
+ -- Note that we do want a symlink to 'name' rather than
+ -- 'dst', because the symlink will be relative to the
+ -- directory it's created in.
+ -- Finally, we first create the symlinks in a temporary
+ -- directory and then rename to simulate 'ln --force'.
+ withTempDirectory verbosity dstDir nm $ \tmpDir -> do
+ let link1 = flibBuildName lbi flib
+ link2 = "lib" ++ nm <.> "so"
+ createSymbolicLink name (tmpDir </> link1)
+ renameFile (tmpDir </> link1) (dstDir </> link1)
+ createSymbolicLink name (tmpDir </> link2)
+ renameFile (tmpDir </> link2) (dstDir </> link2)
+ where
+ nm :: String
+ nm = unUnqualComponentName $ foreignLibName flib
#endif /* mingw32_HOST_OS */
-
--- |Install for ghc, .hi, .a and, if --with-ghci given, .o
-installLib :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^install location
- -> FilePath -- ^install location for dynamic libraries
- -> FilePath -- ^Build location
- -> PackageDescription
- -> Library
- -> ComponentLocalBuildInfo
- -> IO ()
+-- | Install for ghc, .hi, .a and, if --with-ghci given, .o
+installLib
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ install location
+ -> FilePath
+ -- ^ install location for dynamic libraries
+ -> FilePath
+ -- ^ Build location
+ -> PackageDescription
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
-- copy .hi files over:
whenVanilla $ copyModuleFiles "hi"
- whenProf $ copyModuleFiles "p_hi"
- whenShared $ copyModuleFiles "dyn_hi"
+ whenProf $ copyModuleFiles "p_hi"
+ whenShared $ copyModuleFiles "dyn_hi"
-- copy extra compilation artifacts that ghc plugins may produce
copyDirectoryIfExists "extra-compilation-artifacts"
@@ -2011,54 +2433,64 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
-- copy the built library files over:
whenHasCode $ do
whenVanilla $ do
- sequence_ [ installOrdinary
- builtDir
- targetDir
- (mkGenericStaticLibName (l ++ f))
- | l <- getHSLibraryName
- (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib))
- , f <- "":extraLibFlavours (libBuildInfo lib)
- ]
+ sequence_
+ [ installOrdinary
+ builtDir
+ targetDir
+ (mkGenericStaticLibName (l ++ f))
+ | l <-
+ getHSLibraryName
+ (componentUnitId clbi)
+ : (extraBundledLibs (libBuildInfo lib))
+ , f <- "" : extraLibFlavours (libBuildInfo lib)
+ ]
whenGHCi $ installOrdinary builtDir targetDir ghciLibName
whenProf $ do
installOrdinary builtDir targetDir profileLibName
whenGHCi $ installOrdinary builtDir targetDir ghciProfLibName
- whenShared $ if
- -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
- -- See ghc issue #15837 and Cabal PR #5855.
- | specVersion pkg < CabalSpecV3_0 -> do
- sequence_ [ installShared builtDir dynlibTargetDir
- (mkGenericSharedLibName platform compiler_id (l ++ f))
- | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
- , f <- "":extraDynLibFlavours (libBuildInfo lib)
- ]
- | otherwise -> do
- sequence_ [ installShared
- builtDir
- dynlibTargetDir
- (mkGenericSharedLibName
+ whenShared $
+ if
+ -- The behavior for "extra-bundled-libraries" changed in version 2.5.0.
+ -- See ghc issue #15837 and Cabal PR #5855.
+ | specVersion pkg < CabalSpecV3_0 -> do
+ sequence_
+ [ installShared
+ builtDir
+ dynlibTargetDir
+ (mkGenericSharedLibName platform compiler_id (l ++ f))
+ | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
+ , f <- "" : extraDynLibFlavours (libBuildInfo lib)
+ ]
+ | otherwise -> do
+ sequence_
+ [ installShared
+ builtDir
+ dynlibTargetDir
+ ( mkGenericSharedLibName
+ platform
+ compiler_id
+ (getHSLibraryName uid ++ f)
+ )
+ | f <- "" : extraDynLibFlavours (libBuildInfo lib)
+ ]
+ sequence_
+ [ do
+ files <- getDirectoryContents builtDir
+ let l' =
+ mkGenericSharedBundledLibName
platform
compiler_id
- (getHSLibraryName uid ++ f))
- | f <- "":extraDynLibFlavours (libBuildInfo lib)
- ]
- sequence_ [ do
- files <- getDirectoryContents builtDir
- let l' = mkGenericSharedBundledLibName
- platform
- compiler_id
- l
- forM_ files $ \ file ->
- when (l' `isPrefixOf` file) $ do
- isFile <- doesFileExist (builtDir </> file)
- when isFile $ do
- installShared
- builtDir
- dynlibTargetDir
- file
- | l <- extraBundledLibs (libBuildInfo lib)
- ]
-
+ l
+ forM_ files $ \file ->
+ when (l' `isPrefixOf` file) $ do
+ isFile <- doesFileExist (builtDir </> file)
+ when isFile $ do
+ installShared
+ builtDir
+ dynlibTargetDir
+ file
+ | l <- extraBundledLibs (libBuildInfo lib)
+ ]
where
builtDir = componentBuildDir lbi clbi
@@ -2070,20 +2502,24 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
if isShared
then installExecutableFile verbosity src dst
- else installOrdinaryFile verbosity src dst
+ else installOrdinaryFile verbosity src dst
- when (stripLibs lbi) $ Strip.stripLib verbosity
- platform (withPrograms lbi) dst
+ when (stripLibs lbi) $
+ Strip.stripLib
+ verbosity
+ platform
+ (withPrograms lbi)
+ dst
installOrdinary = install False
- installShared = install True
+ installShared = install True
copyModuleFiles ext =
findModuleFilesEx verbosity [builtDir] [ext] (allLibModules lib clbi)
- >>= installOrdinaryFiles verbosity targetDir
+ >>= installOrdinaryFiles verbosity targetDir
copyDirectoryIfExists dirName = do
- let src = builtDir </> dirName
+ let src = builtDir </> dirName
dst = targetDir </> dirName
dirExists <- doesDirectoryExist src
when dirExists $ copyDirectoryRecursive verbosity src dst
@@ -2091,45 +2527,48 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir pkg lib clbi = do
compiler_id = compilerId (compiler lbi)
platform = hostPlatform lbi
uid = componentUnitId clbi
- profileLibName = mkProfLibName uid
- ghciLibName = Internal.mkGHCiLibName uid
+ profileLibName = mkProfLibName uid
+ ghciLibName = Internal.mkGHCiLibName uid
ghciProfLibName = Internal.mkGHCiProfLibName uid
- hasLib = not $ null (allLibModules lib clbi)
- && null (cSources (libBuildInfo lib))
- && null (cxxSources (libBuildInfo lib))
- && null (cmmSources (libBuildInfo lib))
- && null (asmSources (libBuildInfo lib))
- && (null (jsSources (libBuildInfo lib)) || not hasJsSupport)
+ hasLib =
+ not $
+ null (allLibModules lib clbi)
+ && null (cSources (libBuildInfo lib))
+ && null (cxxSources (libBuildInfo lib))
+ && null (cmmSources (libBuildInfo lib))
+ && null (asmSources (libBuildInfo lib))
+ && (null (jsSources (libBuildInfo lib)) || not hasJsSupport)
hasJsSupport = case hostPlatform lbi of
Platform JavaScript _ -> True
- _ -> False
+ _ -> False
has_code = not (componentIsIndefinite clbi)
whenHasCode = when has_code
whenVanilla = when (hasLib && withVanillaLib lbi)
- whenProf = when (hasLib && withProfLib lbi && has_code)
- whenGHCi = when (hasLib && withGHCiLib lbi && has_code)
- whenShared = when (hasLib && withSharedLib lbi && has_code)
+ whenProf = when (hasLib && withProfLib lbi && has_code)
+ whenGHCi = when (hasLib && withGHCiLib lbi && has_code)
+ whenShared = when (hasLib && withSharedLib lbi && has_code)
-- -----------------------------------------------------------------------------
-- Registering
hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
-hcPkgInfo progdb = HcPkg.HcPkgInfo
- { HcPkg.hcPkgProgram = ghcPkgProg
- , HcPkg.noPkgDbStack = v < [6,9]
- , HcPkg.noVerboseFlag = v < [6,11]
- , HcPkg.flagPackageConf = v < [7,5]
- , HcPkg.supportsDirDbs = v >= [6,8]
- , HcPkg.requiresDirDbs = v >= [7,10]
- , HcPkg.nativeMultiInstance = v >= [7,10]
- , HcPkg.recacheMultiInstance = v >= [6,12]
- , HcPkg.suppressFilesCheck = v >= [6,6]
- }
+hcPkgInfo progdb =
+ HcPkg.HcPkgInfo
+ { HcPkg.hcPkgProgram = ghcPkgProg
+ , HcPkg.noPkgDbStack = v < [6, 9]
+ , HcPkg.noVerboseFlag = v < [6, 11]
+ , HcPkg.flagPackageConf = v < [7, 5]
+ , HcPkg.supportsDirDbs = v >= [6, 8]
+ , HcPkg.requiresDirDbs = v >= [7, 10]
+ , HcPkg.nativeMultiInstance = v >= [7, 10]
+ , HcPkg.recacheMultiInstance = v >= [6, 12]
+ , HcPkg.suppressFilesCheck = v >= [6, 6]
+ }
where
- v = versionNumbers ver
+ v = versionNumbers ver
ghcPkgProg = fromMaybe (error "GHC.hcPkgInfo: no ghc program") $ lookupProgram ghcPkgProgram progdb
- ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg
+ ver = fromMaybe (error "GHC.hcPkgInfo: no ghc version") $ programVersion ghcPkgProg
registerPackage
:: Verbosity
@@ -2139,21 +2578,29 @@ registerPackage
-> HcPkg.RegisterOptions
-> IO ()
registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
- HcPkg.register (hcPkgInfo progdb) verbosity packageDbs
- installedPkgInfo registerOptions
+ HcPkg.register
+ (hcPkgInfo progdb)
+ verbosity
+ packageDbs
+ installedPkgInfo
+ registerOptions
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot verbosity lbi = pkgRoot'
- where
+ where
pkgRoot' GlobalPackageDB =
let ghcProg = fromMaybe (error "GHC.pkgRoot: no ghc program") $ lookupProgram ghcProgram (withPrograms lbi)
- in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)
+ in fmap takeDirectory (getGlobalPackageDB verbosity ghcProg)
pkgRoot' UserPackageDB = do
appDir <- getGhcAppDir
- let ver = compilerVersion (compiler lbi)
- subdir = System.Info.arch ++ '-':System.Info.os
- ++ '-':prettyShow ver
- rootDir = appDir </> subdir
+ let ver = compilerVersion (compiler lbi)
+ subdir =
+ System.Info.arch
+ ++ '-'
+ : System.Info.os
+ ++ '-'
+ : prettyShow ver
+ rootDir = appDir </> subdir
-- We must create the root directory for the user package database if it
-- does not yet exists. Otherwise '${pkgroot}' will resolve to a
-- directory at the time of 'ghc-pkg register', and registration will
@@ -2172,4 +2619,4 @@ supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
withExt :: FilePath -> String -> FilePath
-withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else ""
+withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else ""
diff --git a/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs b/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs
index f0ff8bc9cbad3c9a3d66569e53993c2e7f189e6c..38ec484fe28e1f92da52af20a00d499b31a6647f 100644
--- a/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs
+++ b/Cabal/src/Distribution/Simple/GHC/EnvironmentParser.hs
@@ -4,39 +4,49 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
-module Distribution.Simple.GHC.EnvironmentParser
- ( parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc(..) ) where
-import Prelude ()
+module Distribution.Simple.GHC.EnvironmentParser (parseGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc (..)) where
+
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Simple.Compiler
- ( PackageDB(..) )
+ ( PackageDB (..)
+ )
import Distribution.Simple.GHC.Internal
- ( GhcEnvironmentFileEntry(..) )
+ ( GhcEnvironmentFileEntry (..)
+ )
import Distribution.Types.UnitId
- ( mkUnitId )
+ ( mkUnitId
+ )
import qualified Text.Parsec as P
import Text.Parsec.String
- ( Parser, parseFromFile )
+ ( Parser
+ , parseFromFile
+ )
parseEnvironmentFileLine :: Parser GhcEnvironmentFileEntry
-parseEnvironmentFileLine = GhcEnvFileComment <$> comment
- <|> GhcEnvFilePackageId <$> unitId
- <|> GhcEnvFilePackageDb <$> packageDb
- <|> pure GhcEnvFileClearPackageDbStack <* clearDb
- where
- comment = P.string "--" *> P.many (P.noneOf "\r\n")
- unitId = P.try $ P.string "package-id" *> P.spaces *>
- (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+"))
- packageDb = (P.string "global-package-db" *> pure GlobalPackageDB)
- <|> (P.string "user-package-db" *> pure UserPackageDB)
- <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine))
- clearDb = P.string "clear-package-db"
+parseEnvironmentFileLine =
+ GhcEnvFileComment <$> comment
+ <|> GhcEnvFilePackageId <$> unitId
+ <|> GhcEnvFilePackageDb <$> packageDb
+ <|> pure GhcEnvFileClearPackageDbStack <* clearDb
+ where
+ comment = P.string "--" *> P.many (P.noneOf "\r\n")
+ unitId =
+ P.try $
+ P.string "package-id"
+ *> P.spaces
+ *> (mkUnitId <$> P.many1 (P.satisfy $ \c -> isAlphaNum c || c `elem` "-_.+"))
+ packageDb =
+ (P.string "global-package-db" *> pure GlobalPackageDB)
+ <|> (P.string "user-package-db" *> pure UserPackageDB)
+ <|> (P.string "package-db" *> P.spaces *> (SpecificPackageDB <$> P.many1 (P.noneOf "\r\n") <* P.lookAhead P.endOfLine))
+ clearDb = P.string "clear-package-db"
newtype ParseErrorExc = ParseErrorExc P.ParseError
- deriving (Show, Typeable)
+ deriving (Show, Typeable)
instance Exception ParseErrorExc
@@ -45,5 +55,5 @@ parseGhcEnvironmentFile = parseEnvironmentFileLine `P.sepEndBy` P.endOfLine <* P
readGhcEnvironmentFile :: FilePath -> IO [GhcEnvironmentFileEntry]
readGhcEnvironmentFile path =
- either (throwIO . ParseErrorExc) return =<<
- parseFromFile parseGhcEnvironmentFile path
+ either (throwIO . ParseErrorExc) return
+ =<< parseFromFile parseGhcEnvironmentFile path
diff --git a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs
index ea95aac50e651638ae267ac4e9e133ff484c16d0..04aaa59859497c20ab1a598b9485ec6626d9229c 100644
--- a/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs
+++ b/Cabal/src/Distribution/Simple/GHC/ImplInfo.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.GHC.ImplInfo
--
@@ -8,92 +9,115 @@
-- This module contains the data structure describing invocation
-- details for a GHC or GHC-derived compiler, such as supported flags
-- and workarounds for bugs.
+module Distribution.Simple.GHC.ImplInfo
+ ( GhcImplInfo (..)
+ , getImplInfo
+ , ghcVersionImplInfo
+ , ghcjsVersionImplInfo
+ ) where
-module Distribution.Simple.GHC.ImplInfo (
- GhcImplInfo(..), getImplInfo,
- ghcVersionImplInfo, ghcjsVersionImplInfo
- ) where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Simple.Compiler
import Distribution.Version
-{- |
- Information about features and quirks of a GHC-based implementation.
-
- Compiler flavors based on GHC behave similarly enough that some of
- the support code for them is shared. Every implementation has its
- own peculiarities, that may or may not be a direct result of the
- underlying GHC version. This record keeps track of these differences.
-
- All shared code (i.e. everything not in the Distribution.Simple.FLAVOR
- module) should use implementation info rather than version numbers
- to test for supported features.
--}
-
+-- |
+-- Information about features and quirks of a GHC-based implementation.
+--
+-- Compiler flavors based on GHC behave similarly enough that some of
+-- the support code for them is shared. Every implementation has its
+-- own peculiarities, that may or may not be a direct result of the
+-- underlying GHC version. This record keeps track of these differences.
+--
+-- All shared code (i.e. everything not in the Distribution.Simple.FLAVOR
+-- module) should use implementation info rather than version numbers
+-- to test for supported features.
data GhcImplInfo = GhcImplInfo
- { supportsHaskell2010 :: Bool -- ^ -XHaskell2010 and -XHaskell98 flags
- , supportsGHC2021 :: Bool -- ^ -XGHC2021 flag
- , reportsNoExt :: Bool -- ^ --supported-languages gives Ext and NoExt
- , alwaysNondecIndent :: Bool -- ^ NondecreasingIndentation is always on
- , flagGhciScript :: Bool -- ^ -ghci-script flag supported
- , flagProfAuto :: Bool -- ^ new style -fprof-auto* flags
- , flagProfLate :: Bool -- ^ fprof-late flag
- , flagPackageConf :: Bool -- ^ use package-conf instead of package-db
- , flagDebugInfo :: Bool -- ^ -g flag supported
- , supportsDebugLevels :: Bool -- ^ supports numeric @-g@ levels
- , supportsPkgEnvFiles :: Bool -- ^ picks up @.ghc.environment@ files
- , flagWarnMissingHomeModules :: Bool -- ^ -Wmissing-home-modules is supported
+ { supportsHaskell2010 :: Bool
+ -- ^ -XHaskell2010 and -XHaskell98 flags
+ , supportsGHC2021 :: Bool
+ -- ^ -XGHC2021 flag
+ , reportsNoExt :: Bool
+ -- ^ --supported-languages gives Ext and NoExt
+ , alwaysNondecIndent :: Bool
+ -- ^ NondecreasingIndentation is always on
+ , flagGhciScript :: Bool
+ -- ^ -ghci-script flag supported
+ , flagProfAuto :: Bool
+ -- ^ new style -fprof-auto* flags
+ , flagProfLate :: Bool
+ -- ^ fprof-late flag
+ , flagPackageConf :: Bool
+ -- ^ use package-conf instead of package-db
+ , flagDebugInfo :: Bool
+ -- ^ -g flag supported
+ , supportsDebugLevels :: Bool
+ -- ^ supports numeric @-g@ levels
+ , supportsPkgEnvFiles :: Bool
+ -- ^ picks up @.ghc.environment@ files
+ , flagWarnMissingHomeModules :: Bool
+ -- ^ -Wmissing-home-modules is supported
}
getImplInfo :: Compiler -> GhcImplInfo
getImplInfo comp =
case compilerFlavor comp of
- GHC -> ghcVersionImplInfo (compilerVersion comp)
+ GHC -> ghcVersionImplInfo (compilerVersion comp)
GHCJS -> case compilerCompatVersion GHC comp of
- Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer
- _ -> error ("Distribution.Simple.GHC.Props.getImplProps: " ++
- "could not find GHC version for GHCJS compiler")
- x -> error ("Distribution.Simple.GHC.Props.getImplProps only works" ++
- "for GHC-like compilers (GHC, GHCJS)" ++
- ", but found " ++ show x)
+ Just ghcVer -> ghcjsVersionImplInfo (compilerVersion comp) ghcVer
+ _ ->
+ error
+ ( "Distribution.Simple.GHC.Props.getImplProps: "
+ ++ "could not find GHC version for GHCJS compiler"
+ )
+ x ->
+ error
+ ( "Distribution.Simple.GHC.Props.getImplProps only works"
+ ++ "for GHC-like compilers (GHC, GHCJS)"
+ ++ ", but found "
+ ++ show x
+ )
ghcVersionImplInfo :: Version -> GhcImplInfo
-ghcVersionImplInfo ver = GhcImplInfo
- { supportsHaskell2010 = v >= [7]
- , supportsGHC2021 = v >= [9,1]
- , reportsNoExt = v >= [7]
- , alwaysNondecIndent = v < [7,1]
- , flagGhciScript = v >= [7,2]
- , flagProfAuto = v >= [7,4]
- , flagProfLate = v >= [9,4]
- , flagPackageConf = v < [7,5]
- , flagDebugInfo = v >= [7,10]
- , supportsDebugLevels = v >= [8,0]
- , supportsPkgEnvFiles = v >= [8,0,1,20160901] -- broken in 8.0.1, fixed in 8.0.2
- , flagWarnMissingHomeModules = v >= [8,2]
- }
+ghcVersionImplInfo ver =
+ GhcImplInfo
+ { supportsHaskell2010 = v >= [7]
+ , supportsGHC2021 = v >= [9, 1]
+ , reportsNoExt = v >= [7]
+ , alwaysNondecIndent = v < [7, 1]
+ , flagGhciScript = v >= [7, 2]
+ , flagProfAuto = v >= [7, 4]
+ , flagProfLate = v >= [9, 4]
+ , flagPackageConf = v < [7, 5]
+ , flagDebugInfo = v >= [7, 10]
+ , supportsDebugLevels = v >= [8, 0]
+ , supportsPkgEnvFiles = v >= [8, 0, 1, 20160901] -- broken in 8.0.1, fixed in 8.0.2
+ , flagWarnMissingHomeModules = v >= [8, 2]
+ }
where
v = versionNumbers ver
-ghcjsVersionImplInfo :: Version -- ^ The GHCJS version
- -> Version -- ^ The GHC version
- -> GhcImplInfo
-ghcjsVersionImplInfo _ghcjsver ghcver = GhcImplInfo
- { supportsHaskell2010 = True
- , supportsGHC2021 = True
- , reportsNoExt = True
- , alwaysNondecIndent = False
- , flagGhciScript = True
- , flagProfAuto = True
- , flagProfLate = True
- , flagPackageConf = False
- , flagDebugInfo = False
- , supportsDebugLevels = ghcv >= [8,0]
- , supportsPkgEnvFiles = ghcv >= [8,0,2] --TODO: check this works in ghcjs
- , flagWarnMissingHomeModules = ghcv >= [8,2]
- }
+ghcjsVersionImplInfo
+ :: Version
+ -- ^ The GHCJS version
+ -> Version
+ -- ^ The GHC version
+ -> GhcImplInfo
+ghcjsVersionImplInfo _ghcjsver ghcver =
+ GhcImplInfo
+ { supportsHaskell2010 = True
+ , supportsGHC2021 = True
+ , reportsNoExt = True
+ , alwaysNondecIndent = False
+ , flagGhciScript = True
+ , flagProfAuto = True
+ , flagProfLate = True
+ , flagPackageConf = False
+ , flagDebugInfo = False
+ , supportsDebugLevels = ghcv >= [8, 0]
+ , supportsPkgEnvFiles = ghcv >= [8, 0, 2] -- TODO: check this works in ghcjs
+ , flagWarnMissingHomeModules = ghcv >= [8, 2]
+ }
where
ghcv = versionNumbers ghcver
diff --git a/Cabal/src/Distribution/Simple/GHC/Internal.hs b/Cabal/src/Distribution/Simple/GHC/Internal.hs
index 332fe9cce179b6231a9e3f90381aadbb2aec1d2a..64c6faf8d378921af3a36ad0d05f12dc121961ab 100644
--- a/Cabal/src/Distribution/Simple/GHC/Internal.hs
+++ b/Cabal/src/Distribution/Simple/GHC/Internal.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.GHC.Internal
-- Copyright : Isaac Jones 2003-2007
@@ -11,156 +12,173 @@
--
-- This module contains functions shared by GHC (Distribution.Simple.GHC)
-- and GHC-derived compilers.
+module Distribution.Simple.GHC.Internal
+ ( configureToolchain
+ , getLanguages
+ , getExtensions
+ , targetPlatform
+ , getGhcInfo
+ , componentCcGhcOptions
+ , componentCmmGhcOptions
+ , componentCxxGhcOptions
+ , componentAsmGhcOptions
+ , componentJsGhcOptions
+ , componentGhcOptions
+ , mkGHCiLibName
+ , mkGHCiProfLibName
+ , filterGhciFlags
+ , ghcLookupProperty
+ , getHaskellObjects
+ , mkGhcOptPackages
+ , substTopDir
+ , checkPackageDbEnvVar
+ , profDetailLevelFlag
+
+ -- * GHC platform and version strings
+ , ghcArchString
+ , ghcOsString
+ , ghcPlatformAndVersionString
+
+ -- * Constructing GHC environment files
+ , GhcEnvironmentFileEntry (..)
+ , writeGhcEnvironmentFile
+ , simpleGhcEnvironmentFile
+ , ghcEnvironmentFileName
+ , renderGhcEnvironmentFile
+ , renderGhcEnvironmentFileEntry
+ ) where
-module Distribution.Simple.GHC.Internal (
- configureToolchain,
- getLanguages,
- getExtensions,
- targetPlatform,
- getGhcInfo,
- componentCcGhcOptions,
- componentCmmGhcOptions,
- componentCxxGhcOptions,
- componentAsmGhcOptions,
- componentJsGhcOptions,
- componentGhcOptions,
- mkGHCiLibName,
- mkGHCiProfLibName,
- filterGhciFlags,
- ghcLookupProperty,
- getHaskellObjects,
- mkGhcOptPackages,
- substTopDir,
- checkPackageDbEnvVar,
- profDetailLevelFlag,
- -- * GHC platform and version strings
- ghcArchString,
- ghcOsString,
- ghcPlatformAndVersionString,
- -- * Constructing GHC environment files
- GhcEnvironmentFileEntry(..),
- writeGhcEnvironmentFile,
- simpleGhcEnvironmentFile,
- ghcEnvironmentFileName,
- renderGhcEnvironmentFile,
- renderGhcEnvironmentFileEntry,
- ) where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Simple.GHC.ImplInfo
-import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Backpack
+import Distribution.Compat.Stack
import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.PackageDescription
import Distribution.Lex
-import Distribution.Simple.Compiler
-import Distribution.Simple.Program.GHC
-import Distribution.Simple.Flag ( Flag, maybeToFlag, toFlag )
import qualified Distribution.ModuleName as ModuleName
-import Distribution.Simple.Program
+import Distribution.PackageDescription
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty (prettyShow)
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.Compiler
+import Distribution.Simple.Flag (Flag, maybeToFlag, toFlag)
+import Distribution.Simple.GHC.ImplInfo
import Distribution.Simple.LocalBuildInfo
-import Distribution.Types.UnitId
-import Distribution.Types.LocalBuildInfo
-import Distribution.Types.TargetInfo
+import Distribution.Simple.Program
+import Distribution.Simple.Program.GHC
import Distribution.Simple.Utils
-import Distribution.Simple.BuildPaths
import Distribution.System
-import Distribution.Pretty ( prettyShow )
-import Distribution.Parsec ( simpleParsec )
-import Distribution.Utils.NubList ( toNubListR )
+import Distribution.Types.ComponentLocalBuildInfo
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.TargetInfo
+import Distribution.Types.UnitId
+import Distribution.Utils.NubList (toNubListR)
+import Distribution.Utils.Path
import Distribution.Verbosity
-import Distribution.Compat.Stack
import Distribution.Version (Version)
-import Distribution.Utils.Path
import Language.Haskell.Extension
-import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as BS
-import System.Directory ( getDirectoryContents, getTemporaryDirectory )
-import System.Environment ( getEnv )
-import System.FilePath ( (</>), (<.>), takeExtension
- , takeDirectory, takeFileName)
-import System.IO ( hClose, hPutStrLn )
+import qualified Data.Map as Map
+import System.Directory (getDirectoryContents, getTemporaryDirectory)
+import System.Environment (getEnv)
+import System.FilePath
+ ( takeDirectory
+ , takeExtension
+ , takeFileName
+ , (<.>)
+ , (</>)
+ )
+import System.IO (hClose, hPutStrLn)
targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
-- | Adjust the way we find and configure gcc and ld
---
-configureToolchain :: GhcImplInfo
- -> ConfiguredProgram
- -> Map String String
- -> ProgramDb
- -> ProgramDb
+configureToolchain
+ :: GhcImplInfo
+ -> ConfiguredProgram
+ -> Map String String
+ -> ProgramDb
+ -> ProgramDb
configureToolchain _implInfo ghcProg ghcInfo =
- addKnownProgram gccProgram {
- programFindLocation = findProg gccProgramName extraGccPath,
- programPostConf = configureGcc
- }
- . addKnownProgram ldProgram {
- programFindLocation = findProg ldProgramName extraLdPath,
- programPostConf = configureLd
- }
- . addKnownProgram arProgram {
- programFindLocation = findProg arProgramName extraArPath
- }
- . addKnownProgram stripProgram {
- programFindLocation = findProg stripProgramName extraStripPath
- }
+ addKnownProgram
+ gccProgram
+ { programFindLocation = findProg gccProgramName extraGccPath
+ , programPostConf = configureGcc
+ }
+ . addKnownProgram
+ ldProgram
+ { programFindLocation = findProg ldProgramName extraLdPath
+ , programPostConf = configureLd
+ }
+ . addKnownProgram
+ arProgram
+ { programFindLocation = findProg arProgramName extraArPath
+ }
+ . addKnownProgram
+ stripProgram
+ { programFindLocation = findProg stripProgramName extraStripPath
+ }
where
compilerDir = takeDirectory (programPath ghcProg)
- base_dir = takeDirectory compilerDir
+ base_dir = takeDirectory compilerDir
mingwBinDir = base_dir </> "mingw" </> "bin"
- isWindows = case buildOS of Windows -> True; _ -> False
- binPrefix = ""
+ isWindows = case buildOS of Windows -> True; _ -> False
+ binPrefix = ""
maybeName :: Program -> Maybe FilePath -> String
- maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName)
+ maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName)
- gccProgramName = maybeName gccProgram mbGccLocation
- ldProgramName = maybeName ldProgram mbLdLocation
- arProgramName = maybeName arProgram mbArLocation
+ gccProgramName = maybeName gccProgram mbGccLocation
+ ldProgramName = maybeName ldProgram mbLdLocation
+ arProgramName = maybeName arProgram mbArLocation
stripProgramName = maybeName stripProgram mbStripLocation
mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
- mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]
- | otherwise = mbDir
+ mkExtraPath mbPath mingwPath
+ | isWindows = mbDir ++ [mingwPath]
+ | otherwise = mbDir
where
mbDir = maybeToList . fmap takeDirectory $ mbPath
- extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
- extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
- extraArPath = mkExtraPath mbArLocation windowsExtraArDir
+ extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
+ extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
+ extraArPath = mkExtraPath mbArLocation windowsExtraArDir
extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir
-- on Windows finding and configuring ghc's gcc & binutils is a bit special
- (windowsExtraGccDir, windowsExtraLdDir,
- windowsExtraArDir, windowsExtraStripDir) =
- let b = mingwBinDir </> binPrefix
- in (b, b, b, b)
-
- findProg :: String -> [FilePath]
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+ ( windowsExtraGccDir
+ , windowsExtraLdDir
+ , windowsExtraArDir
+ , windowsExtraStripDir
+ ) =
+ let b = mingwBinDir </> binPrefix
+ in (b, b, b, b)
+
+ findProg
+ :: String
+ -> [FilePath]
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
findProg progName extraPath v searchpath =
- findProgramOnSearchPath v searchpath' progName
+ findProgramOnSearchPath v searchpath' progName
where
searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath
-- Read tool locations from the 'ghc --info' output. Useful when
-- cross-compiling.
- mbGccLocation = Map.lookup "C compiler command" ghcInfo
- mbLdLocation = Map.lookup "ld command" ghcInfo
- mbArLocation = Map.lookup "ar command" ghcInfo
+ mbGccLocation = Map.lookup "C compiler command" ghcInfo
+ mbLdLocation = Map.lookup "ld command" ghcInfo
+ mbArLocation = Map.lookup "ar command" ghcInfo
mbStripLocation = Map.lookup "strip command" ghcInfo
- ccFlags = getFlags "C compiler flags"
+ ccFlags = getFlags "C compiler flags"
-- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags"
-- and "Ld Linker flags" to "ld flags" (GHC #4862).
gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags"
- ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags"
+ ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags"
-- It appears that GHC 7.6 and earlier encode the tokenized flags as a
-- [String] in these settings whereas later versions just encode the flags as
@@ -170,364 +188,460 @@ configureToolchain _implInfo ghcProg ghcInfo =
-- flags ourself.
getFlags :: String -> [String]
getFlags key =
- case Map.lookup key ghcInfo of
- Nothing -> []
- Just flags
- | (flags', ""):_ <- reads flags -> flags'
- | otherwise -> tokenizeQuotedWords flags
+ case Map.lookup key ghcInfo of
+ Nothing -> []
+ Just flags
+ | (flags', "") : _ <- reads flags -> flags'
+ | otherwise -> tokenizeQuotedWords flags
configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc _v gccProg = do
- return gccProg {
- programDefaultArgs = programDefaultArgs gccProg
- ++ ccFlags ++ gccLinkerFlags
- }
+ return
+ gccProg
+ { programDefaultArgs =
+ programDefaultArgs gccProg
+ ++ ccFlags
+ ++ gccLinkerFlags
+ }
configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd v ldProg = do
ldProg' <- configureLd' v ldProg
- return ldProg' {
- programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
- }
+ return
+ ldProg'
+ { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
+ }
-- we need to find out if ld supports the -x flag
configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd' verbosity ldProg = do
tempDir <- getTemporaryDirectory
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
- withTempFile tempDir ".o" $ \testofile testohnd -> do
- hPutStrLn testchnd "int foo() { return 0; }"
- hClose testchnd; hClose testohnd
- runProgram verbosity ghcProg
- [ "-hide-all-packages"
- , "-c", testcfile
- , "-o", testofile
- ]
- withTempFile tempDir ".o" $ \testofile' testohnd' ->
- do
- hClose testohnd'
- _ <- getProgramOutput verbosity ldProg
- ["-x", "-r", testofile, "-o", testofile']
- return True
- `catchIO` (\_ -> return False)
- `catchExit` (\_ -> return False)
+ withTempFile tempDir ".o" $ \testofile testohnd -> do
+ hPutStrLn testchnd "int foo() { return 0; }"
+ hClose testchnd
+ hClose testohnd
+ runProgram
+ verbosity
+ ghcProg
+ [ "-hide-all-packages"
+ , "-c"
+ , testcfile
+ , "-o"
+ , testofile
+ ]
+ withTempFile tempDir ".o" $ \testofile' testohnd' ->
+ do
+ hClose testohnd'
+ _ <-
+ getProgramOutput
+ verbosity
+ ldProg
+ ["-x", "-r", testofile, "-o", testofile']
+ return True
+ `catchIO` (\_ -> return False)
+ `catchExit` (\_ -> return False)
if ldx
- then return ldProg { programDefaultArgs = ["-x"] }
+ then return ldProg{programDefaultArgs = ["-x"]}
else return ldProg
-getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram
- -> IO [(Language, String)]
+getLanguages
+ :: Verbosity
+ -> GhcImplInfo
+ -> ConfiguredProgram
+ -> IO [(Language, String)]
getLanguages _ implInfo _
-- TODO: should be using --supported-languages rather than hard coding
- | supportsGHC2021 implInfo = return
- [ (GHC2021, "-XGHC2021")
- , (Haskell2010, "-XHaskell2010")
- , (Haskell98, "-XHaskell98")
- ]
- | supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98")
- ,(Haskell2010, "-XHaskell2010")]
- | otherwise = return [(Haskell98, "")]
-
-getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram
- -> IO [(String, String)]
+ | supportsGHC2021 implInfo =
+ return
+ [ (GHC2021, "-XGHC2021")
+ , (Haskell2010, "-XHaskell2010")
+ , (Haskell98, "-XHaskell98")
+ ]
+ | supportsHaskell2010 implInfo =
+ return
+ [ (Haskell98, "-XHaskell98")
+ , (Haskell2010, "-XHaskell2010")
+ ]
+ | otherwise = return [(Haskell98, "")]
+
+getGhcInfo
+ :: Verbosity
+ -> GhcImplInfo
+ -> ConfiguredProgram
+ -> IO [(String, String)]
getGhcInfo verbosity _implInfo ghcProg = do
- xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
- ["--info"]
- case reads xs of
- [(i, ss)]
- | all isSpace ss ->
- return i
- _ ->
- die' verbosity "Can't parse --info output of GHC"
-
-getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram
- -> IO [(Extension, Maybe String)]
+ xs <-
+ getProgramOutput
+ verbosity
+ (suppressOverrideArgs ghcProg)
+ ["--info"]
+ case reads xs of
+ [(i, ss)]
+ | all isSpace ss ->
+ return i
+ _ ->
+ die' verbosity "Can't parse --info output of GHC"
+
+getExtensions
+ :: Verbosity
+ -> GhcImplInfo
+ -> ConfiguredProgram
+ -> IO [(Extension, Maybe String)]
getExtensions verbosity implInfo ghcProg = do
- str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
- ["--supported-languages"]
- let extStrs = if reportsNoExt implInfo
- then lines str
- else -- Older GHCs only gave us either Foo or NoFoo,
- -- so we have to work out the other one ourselves
- [ extStr''
- | extStr <- lines str
- , let extStr' = case extStr of
- 'N' : 'o' : xs -> xs
- _ -> "No" ++ extStr
- , extStr'' <- [extStr, extStr']
- ]
- let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext)
- | Just ext <- map simpleParsec extStrs ]
- extensions1 = if alwaysNondecIndent implInfo
- then -- ghc-7.2 split NondecreasingIndentation off
- -- into a proper extension. Before that it
- -- was always on.
- -- Since it was not a proper extension, it could
- -- not be turned off, hence we omit a
- -- DisableExtension entry here.
- (EnableExtension NondecreasingIndentation, Nothing) :
- extensions0
- else extensions0
- return extensions1
-
-componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+ str <-
+ getProgramOutput
+ verbosity
+ (suppressOverrideArgs ghcProg)
+ ["--supported-languages"]
+ let extStrs =
+ if reportsNoExt implInfo
+ then lines str
+ else -- Older GHCs only gave us either Foo or NoFoo,
+ -- so we have to work out the other one ourselves
+
+ [ extStr''
+ | extStr <- lines str
+ , let extStr' = case extStr of
+ 'N' : 'o' : xs -> xs
+ _ -> "No" ++ extStr
+ , extStr'' <- [extStr, extStr']
+ ]
+ let extensions0 =
+ [ (ext, Just $ "-X" ++ prettyShow ext)
+ | Just ext <- map simpleParsec extStrs
+ ]
+ extensions1 =
+ if alwaysNondecIndent implInfo
+ then -- ghc-7.2 split NondecreasingIndentation off
+ -- into a proper extension. Before that it
+ -- was always on.
+ -- Since it was not a proper extension, it could
+ -- not be turned off, hence we omit a
+ -- DisableExtension entry here.
+
+ (EnableExtension NondecreasingIndentation, Nothing)
+ : extensions0
+ else extensions0
+ return extensions1
+
+componentCcGhcOptions
+ :: Verbosity
+ -> GhcImplInfo
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename =
- mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
- ghcOptVerbosity = toFlag (min verbosity normal),
- ghcOptMode = toFlag GhcModeCompile,
- ghcOptInputFiles = toNubListR [filename],
-
- ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir]
- -- includes relative to the package
- ++ includeDirs bi
- -- potential includes generated by `configure'
- -- in the build directory
- ++ [buildDir lbi </> dir | dir <- includeDirs bi],
- ghcOptHideAllPackages= toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
- ghcOptCcOptions = (case withOptimization lbi of
- NoOptimisation -> []
- _ -> ["-O2"]) ++
- (case withDebugInfo lbi of
- NoDebugInfo -> []
- MinimalDebugInfo -> ["-g1"]
- NormalDebugInfo -> ["-g"]
- MaximalDebugInfo -> ["-g3"]) ++
- ccOptions bi,
- ghcOptCcProgram = maybeToFlag $ programPath <$>
- lookupProgram gccProgram (withPrograms lbi),
- ghcOptObjDir = toFlag odir,
- ghcOptExtra = hcOptions GHC bi
+ ghcOptVerbosity = toFlag (min verbosity normal)
+ , ghcOptMode = toFlag GhcModeCompile
+ , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptCppIncludePath =
+ toNubListR $
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ -- includes relative to the package
+ ++ includeDirs bi
+ -- potential includes generated by `configure'
+ -- in the build directory
+ ++ [buildDir lbi </> dir | dir <- includeDirs bi]
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi
+ , ghcOptCcOptions =
+ ( case withOptimization lbi of
+ NoOptimisation -> []
+ _ -> ["-O2"]
+ )
+ ++ ( case withDebugInfo lbi of
+ NoDebugInfo -> []
+ MinimalDebugInfo -> ["-g1"]
+ NormalDebugInfo -> ["-g"]
+ MaximalDebugInfo -> ["-g3"]
+ )
+ ++ ccOptions bi
+ , ghcOptCcProgram =
+ maybeToFlag $
+ programPath
+ <$> lookupProgram gccProgram (withPrograms lbi)
+ , ghcOptObjDir = toFlag odir
+ , ghcOptExtra = hcOptions GHC bi
}
-
-componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+componentCxxGhcOptions
+ :: Verbosity
+ -> GhcImplInfo
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename =
- mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
- ghcOptVerbosity = toFlag (min verbosity normal),
- ghcOptMode = toFlag GhcModeCompile,
- ghcOptInputFiles = toNubListR [filename],
-
- ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir]
- -- includes relative to the package
- ++ includeDirs bi
- -- potential includes generated by `configure'
- -- in the build directory
- ++ [buildDir lbi </> dir | dir <- includeDirs bi],
- ghcOptHideAllPackages= toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
- ghcOptCxxOptions = (case withOptimization lbi of
- NoOptimisation -> []
- _ -> ["-O2"]) ++
- (case withDebugInfo lbi of
- NoDebugInfo -> []
- MinimalDebugInfo -> ["-g1"]
- NormalDebugInfo -> ["-g"]
- MaximalDebugInfo -> ["-g3"]) ++
- cxxOptions bi,
- ghcOptCcProgram = maybeToFlag $ programPath <$>
- lookupProgram gccProgram (withPrograms lbi),
- ghcOptObjDir = toFlag odir,
- ghcOptExtra = hcOptions GHC bi
+ ghcOptVerbosity = toFlag (min verbosity normal)
+ , ghcOptMode = toFlag GhcModeCompile
+ , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptCppIncludePath =
+ toNubListR $
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ -- includes relative to the package
+ ++ includeDirs bi
+ -- potential includes generated by `configure'
+ -- in the build directory
+ ++ [buildDir lbi </> dir | dir <- includeDirs bi]
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi
+ , ghcOptCxxOptions =
+ ( case withOptimization lbi of
+ NoOptimisation -> []
+ _ -> ["-O2"]
+ )
+ ++ ( case withDebugInfo lbi of
+ NoDebugInfo -> []
+ MinimalDebugInfo -> ["-g1"]
+ NormalDebugInfo -> ["-g"]
+ MaximalDebugInfo -> ["-g3"]
+ )
+ ++ cxxOptions bi
+ , ghcOptCcProgram =
+ maybeToFlag $
+ programPath
+ <$> lookupProgram gccProgram (withPrograms lbi)
+ , ghcOptObjDir = toFlag odir
+ , ghcOptExtra = hcOptions GHC bi
}
-
-componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+componentAsmGhcOptions
+ :: Verbosity
+ -> GhcImplInfo
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename =
- mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
- ghcOptVerbosity = toFlag (min verbosity normal),
- ghcOptMode = toFlag GhcModeCompile,
- ghcOptInputFiles = toNubListR [filename],
-
- ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir]
- -- includes relative to the package
- ++ includeDirs bi
- -- potential includes generated by `configure'
- -- in the build directory
- ++ [buildDir lbi </> dir | dir <- includeDirs bi],
- ghcOptHideAllPackages= toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
- ghcOptAsmOptions = (case withOptimization lbi of
- NoOptimisation -> []
- _ -> ["-O2"]) ++
- (case withDebugInfo lbi of
- NoDebugInfo -> []
- MinimalDebugInfo -> ["-g1"]
- NormalDebugInfo -> ["-g"]
- MaximalDebugInfo -> ["-g3"]) ++
- asmOptions bi,
- ghcOptObjDir = toFlag odir
+ ghcOptVerbosity = toFlag (min verbosity normal)
+ , ghcOptMode = toFlag GhcModeCompile
+ , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptCppIncludePath =
+ toNubListR $
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ -- includes relative to the package
+ ++ includeDirs bi
+ -- potential includes generated by `configure'
+ -- in the build directory
+ ++ [buildDir lbi </> dir | dir <- includeDirs bi]
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi
+ , ghcOptAsmOptions =
+ ( case withOptimization lbi of
+ NoOptimisation -> []
+ _ -> ["-O2"]
+ )
+ ++ ( case withDebugInfo lbi of
+ NoDebugInfo -> []
+ MinimalDebugInfo -> ["-g1"]
+ NormalDebugInfo -> ["-g"]
+ MaximalDebugInfo -> ["-g3"]
+ )
+ ++ asmOptions bi
+ , ghcOptObjDir = toFlag odir
}
-componentJsGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+componentJsGhcOptions
+ :: Verbosity
+ -> GhcImplInfo
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentJsGhcOptions verbosity _implInfo lbi bi clbi odir filename =
- mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
- ghcOptVerbosity = toFlag (min verbosity normal),
- ghcOptMode = toFlag GhcModeCompile,
- ghcOptInputFiles = toNubListR [filename],
-
- ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir]
- -- includes relative to the package
- ++ includeDirs bi
- -- potential includes generated by `configure'
- -- in the build directory
- ++ [buildDir lbi </> dir | dir <- includeDirs bi],
- ghcOptHideAllPackages= toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
- ghcOptObjDir = toFlag odir
+ ghcOptVerbosity = toFlag (min verbosity normal)
+ , ghcOptMode = toFlag GhcModeCompile
+ , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptCppIncludePath =
+ toNubListR $
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ -- includes relative to the package
+ ++ includeDirs bi
+ -- potential includes generated by `configure'
+ -- in the build directory
+ ++ [buildDir lbi </> dir | dir <- includeDirs bi]
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi
+ , ghcOptObjDir = toFlag odir
}
-
-componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
- -> GhcOptions
+componentGhcOptions
+ :: Verbosity
+ -> GhcImplInfo
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> GhcOptions
componentGhcOptions verbosity implInfo lbi bi clbi odir =
- mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
- ghcOptVerbosity = toFlag (min verbosity normal),
- ghcOptCabal = toFlag True,
- ghcOptThisUnitId = case clbi of
- LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
- -> toFlag pk
- _ -> mempty,
- ghcOptThisComponentId = case clbi of
- LibComponentLocalBuildInfo { componentComponentId = cid
- , componentInstantiatedWith = insts } ->
- if null insts
- then mempty
- else toFlag cid
- _ -> mempty,
- ghcOptInstantiatedWith = case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts }
- -> insts
- _ -> [],
- ghcOptNoCode = toFlag $ componentIsIndefinite clbi,
- ghcOptHideAllPackages = toFlag True,
- ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
- ghcOptSplitSections = toFlag (splitSections lbi),
- ghcOptSplitObjs = toFlag (splitObjs lbi),
- ghcOptSourcePathClear = toFlag True,
- ghcOptSourcePath = toNubListR $ map getSymbolicPath (hsSourceDirs bi)
- ++ [odir]
- ++ [autogenComponentModulesDir lbi clbi]
- ++ [autogenPackageModulesDir lbi],
- ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir]
- -- includes relative to the package
- ++ includeDirs bi
- -- potential includes generated by `configure'
- -- in the build directory
- ++ [buildDir lbi </> dir | dir <- includeDirs bi],
- ghcOptCppOptions = cppOptions bi,
- ghcOptCppIncludes = toNubListR $
- [autogenComponentModulesDir lbi clbi </> cppHeaderName],
- ghcOptFfiIncludes = toNubListR $ includes bi,
- ghcOptObjDir = toFlag odir,
- ghcOptHiDir = toFlag odir,
- ghcOptStubDir = toFlag odir,
- ghcOptOutputDir = toFlag odir,
- ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
- ghcOptDebugInfo = toFlag (withDebugInfo lbi),
- ghcOptExtra = hcOptions GHC bi,
- ghcOptExtraPath = toNubListR $ exe_paths,
- ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
- -- Unsupported extensions have already been checked by configure
- ghcOptExtensions = toNubListR $ usedExtensions bi,
- ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi)
+ ghcOptVerbosity = toFlag (min verbosity normal)
+ , ghcOptCabal = toFlag True
+ , ghcOptThisUnitId = case clbi of
+ LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
+ toFlag pk
+ _ -> mempty
+ , ghcOptThisComponentId = case clbi of
+ LibComponentLocalBuildInfo
+ { componentComponentId = cid
+ , componentInstantiatedWith = insts
+ } ->
+ if null insts
+ then mempty
+ else toFlag cid
+ _ -> mempty
+ , ghcOptInstantiatedWith = case clbi of
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
+ insts
+ _ -> []
+ , ghcOptNoCode = toFlag $ componentIsIndefinite clbi
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi
+ , ghcOptSplitSections = toFlag (splitSections lbi)
+ , ghcOptSplitObjs = toFlag (splitObjs lbi)
+ , ghcOptSourcePathClear = toFlag True
+ , ghcOptSourcePath =
+ toNubListR $
+ map getSymbolicPath (hsSourceDirs bi)
+ ++ [odir]
+ ++ [autogenComponentModulesDir lbi clbi]
+ ++ [autogenPackageModulesDir lbi]
+ , ghcOptCppIncludePath =
+ toNubListR $
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ -- includes relative to the package
+ ++ includeDirs bi
+ -- potential includes generated by `configure'
+ -- in the build directory
+ ++ [buildDir lbi </> dir | dir <- includeDirs bi]
+ , ghcOptCppOptions = cppOptions bi
+ , ghcOptCppIncludes =
+ toNubListR $
+ [autogenComponentModulesDir lbi clbi </> cppHeaderName]
+ , ghcOptFfiIncludes = toNubListR $ includes bi
+ , ghcOptObjDir = toFlag odir
+ , ghcOptHiDir = toFlag odir
+ , ghcOptStubDir = toFlag odir
+ , ghcOptOutputDir = toFlag odir
+ , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
+ , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
+ , ghcOptExtra = hcOptions GHC bi
+ , ghcOptExtraPath = toNubListR $ exe_paths
+ , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi))
+ , -- Unsupported extensions have already been checked by configure
+ ghcOptExtensions = toNubListR $ usedExtensions bi
+ , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi)
}
where
- exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt)
- | uid <- componentExeDeps clbi
- -- TODO: Ugh, localPkgDescr
- , Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ]
+ exe_paths =
+ [ componentBuildDir lbi (targetCLBI exe_tgt)
+ | uid <- componentExeDeps clbi
+ , -- TODO: Ugh, localPkgDescr
+ Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid]
+ ]
toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation
-toGhcOptimisation NoOptimisation = mempty --TODO perhaps override?
-toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
+toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override?
+toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
-
-componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+componentCmmGhcOptions
+ :: Verbosity
+ -> GhcImplInfo
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename =
- mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
-- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
- ghcOptVerbosity = toFlag (min verbosity normal),
- ghcOptMode = toFlag GhcModeCompile,
- ghcOptInputFiles = toNubListR [filename],
-
- ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir]
- -- includes relative to the package
- ++ includeDirs bi
- -- potential includes generated by `configure'
- -- in the build directory
- ++ [buildDir lbi </> dir | dir <- includeDirs bi],
- ghcOptCppOptions = cppOptions bi,
- ghcOptCppIncludes = toNubListR $
- [autogenComponentModulesDir lbi clbi </> cppHeaderName],
- ghcOptHideAllPackages= toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
- ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
- ghcOptDebugInfo = toFlag (withDebugInfo lbi),
- ghcOptExtra = cmmOptions bi,
- ghcOptObjDir = toFlag odir
+ ghcOptVerbosity = toFlag (min verbosity normal)
+ , ghcOptMode = toFlag GhcModeCompile
+ , ghcOptInputFiles = toNubListR [filename]
+ , ghcOptCppIncludePath =
+ toNubListR $
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ -- includes relative to the package
+ ++ includeDirs bi
+ -- potential includes generated by `configure'
+ -- in the build directory
+ ++ [buildDir lbi </> dir | dir <- includeDirs bi]
+ , ghcOptCppOptions = cppOptions bi
+ , ghcOptCppIncludes =
+ toNubListR $
+ [autogenComponentModulesDir lbi clbi </> cppHeaderName]
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptPackages = toNubListR $ mkGhcOptPackages clbi
+ , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
+ , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
+ , ghcOptExtra = cmmOptions bi
+ , ghcOptObjDir = toFlag odir
}
-
-- | Strip out flags that are not supported in ghci
filterGhciFlags :: [String] -> [String]
filterGhciFlags = filter supported
where
- supported ('-':'O':_) = False
- supported "-debug" = False
+ supported ('-' : 'O' : _) = False
+ supported "-debug" = False
supported "-threaded" = False
- supported "-ticky" = False
+ supported "-ticky" = False
supported "-eventlog" = False
- supported "-prof" = False
- supported "-unreg" = False
- supported _ = True
+ supported "-prof" = False
+ supported "-unreg" = False
+ supported _ = True
mkGHCiLibName :: UnitId -> String
mkGHCiLibName lib = getHSLibraryName lib <.> "o"
@@ -539,45 +653,60 @@ ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty prop comp =
case Map.lookup prop (compilerProperties comp) of
Just "YES" -> True
- _ -> False
+ _ -> False
-- when using -split-objs, we need to search for object files in the
-- Module_split directory for each module.
-getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> FilePath -> String -> Bool -> IO [FilePath]
+getHaskellObjects
+ :: GhcImplInfo
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> String
+ -> Bool
+ -> IO [FilePath]
getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs
| splitObjs lbi && allow_split_objs = do
- let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
- dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
- | x <- allLibModules lib clbi ]
- objss <- traverse getDirectoryContents dirs
- let objs = [ dir </> obj
- | (objs',dir) <- zip objss dirs, obj <- objs',
- let obj_ext = takeExtension obj,
- '.':wanted_obj_ext == obj_ext ]
- return objs
- | otherwise =
- return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
- | x <- allLibModules lib clbi ]
-
-mkGhcOptPackages :: ComponentLocalBuildInfo
- -> [(OpenUnitId, ModuleRenaming)]
+ let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
+ dirs =
+ [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
+ | x <- allLibModules lib clbi
+ ]
+ objss <- traverse getDirectoryContents dirs
+ let objs =
+ [ dir </> obj
+ | (objs', dir) <- zip objss dirs
+ , obj <- objs'
+ , let obj_ext = takeExtension obj
+ , '.' : wanted_obj_ext == obj_ext
+ ]
+ return objs
+ | otherwise =
+ return
+ [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
+ | x <- allLibModules lib clbi
+ ]
+
+mkGhcOptPackages
+ :: ComponentLocalBuildInfo
+ -> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages = componentIncludes
substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo
-substTopDir topDir ipo
- = ipo {
- IPI.importDirs = map f (IPI.importDirs ipo),
- IPI.libraryDirs = map f (IPI.libraryDirs ipo),
- IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo),
- IPI.includeDirs = map f (IPI.includeDirs ipo),
- IPI.frameworkDirs = map f (IPI.frameworkDirs ipo),
- IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo),
- IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)
- }
- where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
- f x = x
+substTopDir topDir ipo =
+ ipo
+ { IPI.importDirs = map f (IPI.importDirs ipo)
+ , IPI.libraryDirs = map f (IPI.libraryDirs ipo)
+ , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo)
+ , IPI.includeDirs = map f (IPI.includeDirs ipo)
+ , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo)
+ , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo)
+ , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)
+ }
+ where
+ f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest
+ f x = x
-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let
-- users know that this is the case. See ticket #335. Simply ignoring it is
@@ -591,132 +720,139 @@ substTopDir topDir ipo
-- GHC{,JS}_PACKAGE_PATH.
checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()
checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do
- mPP <- lookupEnv packagePathEnvVar
- when (isJust mPP) $ do
- mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
- unless (mPP == mcsPP) abort
- where
- lookupEnv :: String -> IO (Maybe String)
- lookupEnv name = (Just `fmap` getEnv name)
- `catchIO` const (return Nothing)
- abort =
- die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable "
- ++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "
- ++ "flag --package-db to specify a package database (it can be "
- ++ "used multiple times)."
-
- _ = callStack -- TODO: output stack when erroring
+ mPP <- lookupEnv packagePathEnvVar
+ when (isJust mPP) $ do
+ mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
+ unless (mPP == mcsPP) abort
+ where
+ lookupEnv :: String -> IO (Maybe String)
+ lookupEnv name =
+ (Just `fmap` getEnv name)
+ `catchIO` const (return Nothing)
+ abort =
+ die' verbosity $
+ "Use of "
+ ++ compilerName
+ ++ "'s environment variable "
+ ++ packagePathEnvVar
+ ++ " is incompatible with Cabal. Use the "
+ ++ "flag --package-db to specify a package database (it can be "
+ ++ "used multiple times)."
+
+ _ = callStack -- TODO: output stack when erroring
profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag forLib mpl =
- case mpl of
- ProfDetailNone -> mempty
- ProfDetailDefault | forLib -> toFlag GhcProfAutoExported
- | otherwise -> toFlag GhcProfAutoToplevel
- ProfDetailExportedFunctions -> toFlag GhcProfAutoExported
- ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel
- ProfDetailAllFunctions -> toFlag GhcProfAutoAll
- ProfDetailTopLate -> toFlag GhcProfLate
- ProfDetailOther _ -> mempty
-
+ case mpl of
+ ProfDetailNone -> mempty
+ ProfDetailDefault
+ | forLib -> toFlag GhcProfAutoExported
+ | otherwise -> toFlag GhcProfAutoToplevel
+ ProfDetailExportedFunctions -> toFlag GhcProfAutoExported
+ ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel
+ ProfDetailAllFunctions -> toFlag GhcProfAutoAll
+ ProfDetailTopLate -> toFlag GhcProfLate
+ ProfDetailOther _ -> mempty
-- -----------------------------------------------------------------------------
-- GHC platform and version strings
-- | GHC's rendering of its host or target 'Arch' as used in its platform
-- strings and certain file locations (such as user package db location).
---
ghcArchString :: Arch -> String
-ghcArchString PPC = "powerpc"
+ghcArchString PPC = "powerpc"
ghcArchString PPC64 = "powerpc64"
ghcArchString other = prettyShow other
-- | GHC's rendering of its host or target 'OS' as used in its platform
-- strings and certain file locations (such as user package db location).
---
ghcOsString :: OS -> String
ghcOsString Windows = "mingw32"
-ghcOsString OSX = "darwin"
+ghcOsString OSX = "darwin"
ghcOsString Solaris = "solaris2"
-ghcOsString other = prettyShow other
+ghcOsString other = prettyShow other
-- | GHC's rendering of its platform and compiler version string as used in
-- certain file locations (such as user package db location).
-- For example @x86_64-linux-7.10.4@
---
ghcPlatformAndVersionString :: Platform -> Version -> String
ghcPlatformAndVersionString (Platform arch os) version =
- intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ]
-
+ intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version]
-- -----------------------------------------------------------------------------
-- Constructing GHC environment files
-- | The kinds of entries we can stick in a @.ghc.environment@ file.
---
-data GhcEnvironmentFileEntry =
- GhcEnvFileComment String -- ^ @-- a comment@
- | GhcEnvFilePackageId UnitId -- ^ @package-id foo-1.0-4fe301a...@
- | GhcEnvFilePackageDb PackageDB -- ^ @global-package-db@,
- -- @user-package-db@ or
- -- @package-db blah/package.conf.d/@
- | GhcEnvFileClearPackageDbStack -- ^ @clear-package-db@
- deriving (Eq, Ord, Show)
+data GhcEnvironmentFileEntry
+ = -- | @-- a comment@
+ GhcEnvFileComment String
+ | -- | @package-id foo-1.0-4fe301a...@
+ GhcEnvFilePackageId UnitId
+ | -- | @global-package-db@,
+ -- @user-package-db@ or
+ -- @package-db blah/package.conf.d/@
+ GhcEnvFilePackageDb PackageDB
+ | -- | @clear-package-db@
+ GhcEnvFileClearPackageDbStack
+ deriving (Eq, Ord, Show)
-- | Make entries for a GHC environment file based on a 'PackageDBStack' and
-- a bunch of package (unit) ids.
--
-- If you need to do anything more complicated then either use this as a basis
-- and add more entries, or just make all the entries directly.
---
-simpleGhcEnvironmentFile :: PackageDBStack
- -> [UnitId]
- -> [GhcEnvironmentFileEntry]
+simpleGhcEnvironmentFile
+ :: PackageDBStack
+ -> [UnitId]
+ -> [GhcEnvironmentFileEntry]
simpleGhcEnvironmentFile packageDBs pkgids =
- GhcEnvFileClearPackageDbStack
- : map GhcEnvFilePackageDb packageDBs
- ++ map GhcEnvFilePackageId pkgids
+ GhcEnvFileClearPackageDbStack
+ : map GhcEnvFilePackageDb packageDBs
+ ++ map GhcEnvFilePackageId pkgids
-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.
--
-- The 'Platform' and GHC 'Version' are needed as part of the file name.
--
-- Returns the name of the file written.
-writeGhcEnvironmentFile :: FilePath -- ^ directory in which to put it
- -> Platform -- ^ the GHC target platform
- -> Version -- ^ the GHC version
- -> [GhcEnvironmentFileEntry] -- ^ the content
- -> IO FilePath
+writeGhcEnvironmentFile
+ :: FilePath
+ -- ^ directory in which to put it
+ -> Platform
+ -- ^ the GHC target platform
+ -> Version
+ -- ^ the GHC version
+ -> [GhcEnvironmentFileEntry]
+ -- ^ the content
+ -> IO FilePath
writeGhcEnvironmentFile directory platform ghcversion entries = do
- writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries
- return envfile
+ writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries
+ return envfile
where
envfile = directory </> ghcEnvironmentFileName platform ghcversion
-- | The @.ghc.environment-$arch-$os-$ver@ file name
---
ghcEnvironmentFileName :: Platform -> Version -> FilePath
ghcEnvironmentFileName platform ghcversion =
- ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion
+ ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion
-- | Render a bunch of GHC environment file entries
---
renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String
renderGhcEnvironmentFile =
- unlines . map renderGhcEnvironmentFileEntry
+ unlines . map renderGhcEnvironmentFileEntry
-- | Render an individual GHC environment file entry
---
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String
renderGhcEnvironmentFileEntry entry = case entry of
- GhcEnvFileComment comment -> format comment
- where format = intercalate "\n" . map ("--" <++>) . lines
- pref <++> "" = pref
- pref <++> str = pref ++ " " ++ str
- GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid
- GhcEnvFilePackageDb pkgdb ->
- case pkgdb of
- GlobalPackageDB -> "global-package-db"
- UserPackageDB -> "user-package-db"
- SpecificPackageDB dbfile -> "package-db " ++ dbfile
- GhcEnvFileClearPackageDbStack -> "clear-package-db"
+ GhcEnvFileComment comment -> format comment
+ where
+ format = intercalate "\n" . map ("--" <++>) . lines
+ pref <++> "" = pref
+ pref <++> str = pref ++ " " ++ str
+ GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid
+ GhcEnvFilePackageDb pkgdb ->
+ case pkgdb of
+ GlobalPackageDB -> "global-package-db"
+ UserPackageDB -> "user-package-db"
+ SpecificPackageDB dbfile -> "package-db " ++ dbfile
+ GhcEnvFileClearPackageDbStack -> "clear-package-db"
diff --git a/Cabal/src/Distribution/Simple/GHCJS.hs b/Cabal/src/Distribution/Simple/GHCJS.hs
index 775948c74acaa85a08eaafff4236d6c034cdb7d8..3727f2d244905ae65b6cfdbe2d9df1621ee27a63 100644
--- a/Cabal/src/Distribution/Simple/GHCJS.hs
+++ b/Cabal/src/Distribution/Simple/GHCJS.hs
@@ -1,109 +1,134 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE CPP #-}
-module Distribution.Simple.GHCJS (
- getGhcInfo,
- configure,
- getInstalledPackages,
- getInstalledPackagesMonitorFiles,
- getPackageDBContents,
- buildLib, buildFLib, buildExe,
- replLib, replFLib, replExe,
- startInterpreter,
- installLib, installFLib, installExe,
- libAbiHash,
- hcPkgInfo,
- registerPackage,
- componentGhcOptions,
- componentCcGhcOptions,
- getLibDir,
- isDynamic,
- getGlobalPackageDB,
- pkgRoot,
- runCmd,
- -- * Constructing and deconstructing GHC environment files
- Internal.GhcEnvironmentFileEntry(..),
- Internal.simpleGhcEnvironmentFile,
- Internal.renderGhcEnvironmentFile,
- Internal.writeGhcEnvironmentFile,
- Internal.ghcPlatformAndVersionString,
- readGhcEnvironmentFile,
- parseGhcEnvironmentFile,
- ParseErrorExc(..),
- -- * Version-specific implementation quirks
- getImplInfo,
- GhcImplInfo(..)
- ) where
+module Distribution.Simple.GHCJS
+ ( getGhcInfo
+ , configure
+ , getInstalledPackages
+ , getInstalledPackagesMonitorFiles
+ , getPackageDBContents
+ , buildLib
+ , buildFLib
+ , buildExe
+ , replLib
+ , replFLib
+ , replExe
+ , startInterpreter
+ , installLib
+ , installFLib
+ , installExe
+ , libAbiHash
+ , hcPkgInfo
+ , registerPackage
+ , componentGhcOptions
+ , componentCcGhcOptions
+ , getLibDir
+ , isDynamic
+ , getGlobalPackageDB
+ , pkgRoot
+ , runCmd
+
+ -- * Constructing and deconstructing GHC environment files
+ , Internal.GhcEnvironmentFileEntry (..)
+ , Internal.simpleGhcEnvironmentFile
+ , Internal.renderGhcEnvironmentFile
+ , Internal.writeGhcEnvironmentFile
+ , Internal.ghcPlatformAndVersionString
+ , readGhcEnvironmentFile
+ , parseGhcEnvironmentFile
+ , ParseErrorExc (..)
+
+ -- * Version-specific implementation quirks
+ , getImplInfo
+ , GhcImplInfo (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import qualified Distribution.Simple.GHC.Internal as Internal
-import Distribution.Simple.GHC.ImplInfo
-import Distribution.Simple.GHC.EnvironmentParser
-import Distribution.PackageDescription.Utils (cabalBug)
-import Distribution.PackageDescription as PD
+import Distribution.CabalSpecVersion
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
+import Distribution.ModuleName (ModuleName)
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.Package
+import Distribution.PackageDescription as PD
+import Distribution.PackageDescription.Utils (cabalBug)
+import Distribution.Pretty
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.Compiler
+import Distribution.Simple.Flag
+import Distribution.Simple.GHC.EnvironmentParser
+import Distribution.Simple.GHC.ImplInfo
+import qualified Distribution.Simple.GHC.Internal as Internal
+import qualified Distribution.Simple.Hpc as Hpc
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Simple.LocalBuildInfo
-import Distribution.Types.ComponentLocalBuildInfo
-import qualified Distribution.Simple.Hpc as Hpc
-import Distribution.Simple.BuildPaths
-import Distribution.Simple.Utils
-import Distribution.Package
-import qualified Distribution.ModuleName as ModuleName
-import Distribution.ModuleName (ModuleName)
import Distribution.Simple.Program
+import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Strip as Strip
-import Distribution.Simple.Program.GHC
-import Distribution.Simple.Flag
import Distribution.Simple.Setup.Config
-import Distribution.Simple.Compiler
-import Distribution.CabalSpecVersion
-import Distribution.Version
+import Distribution.Simple.Utils
import Distribution.System
+import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.PackageName.Magic
-import Distribution.Verbosity
-import Distribution.Pretty
import Distribution.Utils.NubList
import Distribution.Utils.Path
+import Distribution.Verbosity
+import Distribution.Version
import Control.Monad (msum)
import Data.Char (isLower)
import qualified Data.Map as Map
import System.Directory
- ( doesFileExist, getAppUserDataDirectory, createDirectoryIfMissing
- , canonicalizePath, removeFile, renameFile )
-import System.FilePath ( (</>), (<.>), takeExtension
- , takeDirectory, replaceExtension
- ,isRelative )
+ ( canonicalizePath
+ , createDirectoryIfMissing
+ , doesFileExist
+ , getAppUserDataDirectory
+ , removeFile
+ , renameFile
+ )
+import System.FilePath
+ ( isRelative
+ , replaceExtension
+ , takeDirectory
+ , takeExtension
+ , (<.>)
+ , (</>)
+ )
import qualified System.Info
-- -----------------------------------------------------------------------------
-- Configuring
-configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramDb
- -> IO (Compiler, Maybe Platform, ProgramDb)
+configure
+ :: Verbosity
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> ProgramDb
+ -> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity hcPath hcPkgPath conf0 = do
-
(ghcjsProg, ghcjsVersion, progdb1) <-
- requireProgramVersion verbosity ghcjsProgram
- (orLaterVersion (mkVersion [0,1]))
+ requireProgramVersion
+ verbosity
+ ghcjsProgram
+ (orLaterVersion (mkVersion [0, 1]))
(userMaybeSpecifyPath "ghcjs" hcPath conf0)
Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)
- unless (ghcjsGhcVersion < mkVersion [8,8]) $
+ unless (ghcjsGhcVersion < mkVersion [8, 8]) $
warn verbosity $
- "Unknown/unsupported 'ghc' version detected "
- ++ "(Cabal " ++ prettyShow cabalVersion ++ " supports 'ghc' version < 8.8): "
- ++ programPath ghcjsProg ++ " is based on GHC version " ++
- prettyShow ghcjsGhcVersion
+ "Unknown/unsupported 'ghc' version detected "
+ ++ "(Cabal "
+ ++ prettyShow cabalVersion
+ ++ " supports 'ghc' version < 8.8): "
+ ++ programPath ghcjsProg
+ ++ " is based on GHC version "
+ ++ prettyShow ghcjsGhcVersion
let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion
@@ -111,131 +136,180 @@ configure verbosity hcPath hcPkgPath conf0 = do
-- location of ghc to help find ghc-pkg in the case that the user did not
-- specify the location of ghc-pkg directly:
(ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-
- requireProgramVersion verbosity ghcjsPkgProgram {
- programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
- }
- anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)
-
- Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion
- verbosity (programPath ghcjsPkgProg)
-
- when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $
- "Version mismatch between ghcjs and ghcjs-pkg: "
- ++ programPath ghcjsProg ++ " is version " ++ prettyShow ghcjsVersion ++ " "
- ++ programPath ghcjsPkgProg ++ " is version " ++ prettyShow ghcjsPkgGhcjsVersion
-
- when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $
- "Version mismatch between ghcjs and ghcjs-pkg: "
- ++ programPath ghcjsProg
- ++ " was built with GHC version " ++ prettyShow ghcjsGhcVersion ++ " "
- ++ programPath ghcjsPkgProg
- ++ " was built with GHC version " ++ prettyShow ghcjsPkgVersion
-
+ requireProgramVersion
+ verbosity
+ ghcjsPkgProgram
+ { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
+ }
+ anyVersion
+ (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)
+
+ Just ghcjsPkgGhcjsVersion <-
+ findGhcjsPkgGhcjsVersion
+ verbosity
+ (programPath ghcjsPkgProg)
+
+ when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $
+ die' verbosity $
+ "Version mismatch between ghcjs and ghcjs-pkg: "
+ ++ programPath ghcjsProg
+ ++ " is version "
+ ++ prettyShow ghcjsVersion
+ ++ " "
+ ++ programPath ghcjsPkgProg
+ ++ " is version "
+ ++ prettyShow ghcjsPkgGhcjsVersion
+
+ when (ghcjsGhcVersion /= ghcjsPkgVersion) $
+ die' verbosity $
+ "Version mismatch between ghcjs and ghcjs-pkg: "
+ ++ programPath ghcjsProg
+ ++ " was built with GHC version "
+ ++ prettyShow ghcjsGhcVersion
+ ++ " "
+ ++ programPath ghcjsPkgProg
+ ++ " was built with GHC version "
+ ++ prettyShow ghcjsPkgVersion
-- Likewise we try to find the matching hsc2hs and haddock programs.
- let hsc2hsProgram' = hsc2hsProgram {
- programFindLocation =
- guessHsc2hsFromGhcjsPath ghcjsProg
- }
- haddockProgram' = haddockProgram {
- programFindLocation =
- guessHaddockFromGhcjsPath ghcjsProg
- }
- hpcProgram' = hpcProgram {
- programFindLocation = guessHpcFromGhcjsPath ghcjsProg
- }
- {-
+ let hsc2hsProgram' =
+ hsc2hsProgram
+ { programFindLocation =
+ guessHsc2hsFromGhcjsPath ghcjsProg
+ }
+ haddockProgram' =
+ haddockProgram
+ { programFindLocation =
+ guessHaddockFromGhcjsPath ghcjsProg
+ }
+ hpcProgram' =
+ hpcProgram
+ { programFindLocation = guessHpcFromGhcjsPath ghcjsProg
+ }
+ {-
runghcProgram' = runghcProgram {
programFindLocation = guessRunghcFromGhcjsPath ghcjsProg
} -}
- progdb3 = addKnownProgram haddockProgram' $
- addKnownProgram hsc2hsProgram' $
- addKnownProgram hpcProgram' $
+ progdb3 =
+ addKnownProgram haddockProgram' $
+ addKnownProgram hsc2hsProgram' $
+ addKnownProgram hpcProgram' $
{- addKnownProgram runghcProgram' -} progdb2
- languages <- Internal.getLanguages verbosity implInfo ghcjsProg
+ languages <- Internal.getLanguages verbosity implInfo ghcjsProg
extensions <- Internal.getExtensions verbosity implInfo ghcjsProg
ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
let ghcInfoMap = Map.fromList ghcjsInfo
- let comp = Compiler {
- compilerId = CompilerId GHCJS ghcjsVersion,
- compilerAbiTag = AbiTag $
- "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion),
- compilerCompat = [CompilerId GHC ghcjsGhcVersion],
- compilerLanguages = languages,
- compilerExtensions = extensions,
- compilerProperties = ghcInfoMap
- }
+ let comp =
+ Compiler
+ { compilerId = CompilerId GHCJS ghcjsVersion
+ , compilerAbiTag =
+ AbiTag $
+ "ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion)
+ , compilerCompat = [CompilerId GHC ghcjsGhcVersion]
+ , compilerLanguages = languages
+ , compilerExtensions = extensions
+ , compilerProperties = ghcInfoMap
+ }
compPlatform = Internal.targetPlatform ghcjsInfo
return (comp, compPlatform, progdb3)
-guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity
- -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
+guessGhcjsPkgFromGhcjsPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram
-guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
- -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
+guessHsc2hsFromGhcjsPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram
-guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity
- -> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
+guessHaddockFromGhcjsPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram
-guessHpcFromGhcjsPath :: ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
+guessHpcFromGhcjsPath
+ :: ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
guessHpcFromGhcjsPath = guessToolFromGhcjsPath hpcProgram
+guessToolFromGhcjsPath
+ :: Program
+ -> ConfiguredProgram
+ -> Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
+guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath =
+ do
+ let toolname = programName tool
+ given_path = programPath ghcjsProg
+ given_dir = takeDirectory given_path
+ real_path <- canonicalizePath given_path
+ let real_dir = takeDirectory real_path
+ versionSuffix path = takeVersionSuffix (dropExeExtension path)
+ given_suf = versionSuffix given_path
+ real_suf = versionSuffix real_path
+ guessNormal dir = dir </> toolname <.> exeExtension buildPlatform
+ guessGhcjs dir =
+ dir
+ </> (toolname ++ "-ghcjs")
+ <.> exeExtension buildPlatform
+ guessGhcjsVersioned dir suf =
+ dir
+ </> (toolname ++ "-ghcjs" ++ suf)
+ <.> exeExtension buildPlatform
+ guessVersioned dir suf =
+ dir
+ </> (toolname ++ suf)
+ <.> exeExtension buildPlatform
+ mkGuesses dir suf
+ | null suf = [guessGhcjs dir, guessNormal dir]
+ | otherwise =
+ [ guessGhcjsVersioned dir suf
+ , guessVersioned dir suf
+ , guessGhcjs dir
+ , guessNormal dir
+ ]
+ guesses =
+ mkGuesses given_dir given_suf
+ ++ if real_path == given_path
+ then []
+ else mkGuesses real_dir real_suf
+ info verbosity $
+ "looking for tool "
+ ++ toolname
+ ++ " near compiler in "
+ ++ given_dir
+ debug verbosity $ "candidate locations: " ++ show guesses
+ exists <- traverse doesFileExist guesses
+ case [file | (file, True) <- zip guesses exists] of
+ -- If we can't find it near ghc, fall back to the usual
+ -- method.
+ [] -> programFindLocation tool verbosity searchpath
+ (fp : _) -> do
+ info verbosity $ "found " ++ toolname ++ " in " ++ fp
+ let lookedAt =
+ map fst
+ . takeWhile (\(_file, exist) -> not exist)
+ $ zip guesses exists
+ return (Just (fp, lookedAt))
+ where
+ takeVersionSuffix :: FilePath -> String
+ takeVersionSuffix = takeWhileEndLE isSuffixChar
-guessToolFromGhcjsPath :: Program -> ConfiguredProgram
- -> Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath]))
-guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath
- = do let toolname = programName tool
- given_path = programPath ghcjsProg
- given_dir = takeDirectory given_path
- real_path <- canonicalizePath given_path
- let real_dir = takeDirectory real_path
- versionSuffix path = takeVersionSuffix (dropExeExtension path)
- given_suf = versionSuffix given_path
- real_suf = versionSuffix real_path
- guessNormal dir = dir </> toolname <.> exeExtension buildPlatform
- guessGhcjs dir = dir </> (toolname ++ "-ghcjs")
- <.> exeExtension buildPlatform
- guessGhcjsVersioned dir suf = dir </> (toolname ++ "-ghcjs" ++ suf)
- <.> exeExtension buildPlatform
- guessVersioned dir suf = dir </> (toolname ++ suf)
- <.> exeExtension buildPlatform
- mkGuesses dir suf | null suf = [guessGhcjs dir, guessNormal dir]
- | otherwise = [guessGhcjsVersioned dir suf,
- guessVersioned dir suf,
- guessGhcjs dir,
- guessNormal dir]
- guesses = mkGuesses given_dir given_suf ++
- if real_path == given_path
- then []
- else mkGuesses real_dir real_suf
- info verbosity $ "looking for tool " ++ toolname
- ++ " near compiler in " ++ given_dir
- debug verbosity $ "candidate locations: " ++ show guesses
- exists <- traverse doesFileExist guesses
- case [ file | (file, True) <- zip guesses exists ] of
- -- If we can't find it near ghc, fall back to the usual
- -- method.
- [] -> programFindLocation tool verbosity searchpath
- (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp
- let lookedAt = map fst
- . takeWhile (\(_file, exist) -> not exist)
- $ zip guesses exists
- return (Just (fp, lookedAt))
-
- where takeVersionSuffix :: FilePath -> String
- takeVersionSuffix = takeWhileEndLE isSuffixChar
-
- isSuffixChar :: Char -> Bool
- isSuffixChar c = isDigit c || c == '.' || c == '-'
+ isSuffixChar :: Char -> Bool
+ isSuffixChar c = isDigit c || c == '.' || c == '-'
getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsProg
@@ -244,15 +318,21 @@ getGhcInfo verbosity ghcjsProg = Internal.getGhcInfo verbosity implInfo ghcjsPro
implInfo = ghcVersionImplInfo version
-- | Given a single package DB, return all installed packages.
-getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb
- -> IO InstalledPackageIndex
+getPackageDBContents
+ :: Verbosity
+ -> PackageDB
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getPackageDBContents verbosity packagedb progdb = do
pkgss <- getInstalledPackages' verbosity [packagedb] progdb
toPackageIndex verbosity pkgss progdb
-- | Given a package DB stack, return all installed packages.
-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb
- -> IO InstalledPackageIndex
+getInstalledPackages
+ :: Verbosity
+ -> PackageDBStack
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity packagedbs progdb = do
checkPackageDbEnvVar verbosity
checkPackageDbStack verbosity packagedbs
@@ -260,94 +340,106 @@ getInstalledPackages verbosity packagedbs progdb = do
index <- toPackageIndex verbosity pkgss progdb
return $! index
-toPackageIndex :: Verbosity
- -> [(PackageDB, [InstalledPackageInfo])]
- -> ProgramDb
- -> IO InstalledPackageIndex
+toPackageIndex
+ :: Verbosity
+ -> [(PackageDB, [InstalledPackageInfo])]
+ -> ProgramDb
+ -> IO InstalledPackageIndex
toPackageIndex verbosity pkgss progdb = do
-- On Windows, various fields have $topdir/foo rather than full
-- paths. We need to substitute the right value in so that when
-- we, for example, call gcc, we have proper paths to give it.
topDir <- getLibDir' verbosity ghcjsProg
- let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
- | (_, pkgs) <- pkgss ]
+ let indices =
+ [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
+ | (_, pkgs) <- pkgss
+ ]
return $! (mconcat indices)
-
where
ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb
getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir verbosity lbi =
- dropWhileEndLE isSpace `fmap`
- getDbProgramOutput verbosity ghcjsProgram
- (withPrograms lbi) ["--print-libdir"]
+ dropWhileEndLE isSpace
+ `fmap` getDbProgramOutput
+ verbosity
+ ghcjsProgram
+ (withPrograms lbi)
+ ["--print-libdir"]
getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' verbosity ghcjsProg =
- dropWhileEndLE isSpace `fmap`
- getProgramOutput verbosity ghcjsProg ["--print-libdir"]
-
+ dropWhileEndLE isSpace
+ `fmap` getProgramOutput verbosity ghcjsProg ["--print-libdir"]
-- | Return the 'FilePath' to the global GHC package database.
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB verbosity ghcProg =
- dropWhileEndLE isSpace `fmap`
- getProgramOutput verbosity ghcProg ["--print-global-package-db"]
+ dropWhileEndLE isSpace
+ `fmap` getProgramOutput verbosity ghcProg ["--print-global-package-db"]
-- | Return the 'FilePath' to the per-user GHC package database.
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB _verbosity ghcjsProg platform = do
- -- It's rather annoying that we have to reconstruct this, because ghc
- -- hides this information from us otherwise. But for certain use cases
- -- like change monitoring it really can't remain hidden.
- appdir <- getAppUserDataDirectory "ghcjs"
- return (appdir </> platformAndVersion </> packageConfFileName)
+ -- It's rather annoying that we have to reconstruct this, because ghc
+ -- hides this information from us otherwise. But for certain use cases
+ -- like change monitoring it really can't remain hidden.
+ appdir <- getAppUserDataDirectory "ghcjs"
+ return (appdir </> platformAndVersion </> packageConfFileName)
where
- platformAndVersion = Internal.ghcPlatformAndVersionString
- platform ghcjsVersion
+ platformAndVersion =
+ Internal.ghcPlatformAndVersionString
+ platform
+ ghcjsVersion
packageConfFileName = "package.conf.d"
ghcjsVersion = fromMaybe (error "GHCJS.getUserPackageDB: no version") $ programVersion ghcjsProg
checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar verbosity =
- Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH"
+ Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH"
checkPackageDbStack :: Verbosity -> PackageDBStack -> IO ()
-checkPackageDbStack _ (GlobalPackageDB:rest)
+checkPackageDbStack _ (GlobalPackageDB : rest)
| GlobalPackageDB `notElem` rest = return ()
checkPackageDbStack verbosity rest
| GlobalPackageDB `notElem` rest =
- die' verbosity $ "With current ghc versions the global package db is always used "
- ++ "and must be listed first. This ghc limitation may be lifted in "
- ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"
+ die' verbosity $
+ "With current ghc versions the global package db is always used "
+ ++ "and must be listed first. This ghc limitation may be lifted in "
+ ++ "future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"
checkPackageDbStack verbosity _ =
- die' verbosity $ "If the global package db is specified, it must be "
- ++ "specified first and cannot be specified multiple times"
+ die' verbosity $
+ "If the global package db is specified, it must be "
+ ++ "specified first and cannot be specified multiple times"
-getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb
- -> IO [(PackageDB, [InstalledPackageInfo])]
+getInstalledPackages'
+ :: Verbosity
+ -> [PackageDB]
+ -> ProgramDb
+ -> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs progdb =
sequenceA
- [ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
- return (packagedb, pkgs)
- | packagedb <- packagedbs ]
+ [ do
+ pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
+ return (packagedb, pkgs)
+ | packagedb <- packagedbs
+ ]
-- | Get the packages from specific PackageDBs, not cumulative.
---
-getInstalledPackagesMonitorFiles :: Verbosity -> Platform
- -> ProgramDb
- -> [PackageDB]
- -> IO [FilePath]
+getInstalledPackagesMonitorFiles
+ :: Verbosity
+ -> Platform
+ -> ProgramDb
+ -> [PackageDB]
+ -> IO [FilePath]
getInstalledPackagesMonitorFiles verbosity platform progdb =
- traverse getPackageDBPath
+ traverse getPackageDBPath
where
getPackageDBPath :: PackageDB -> IO FilePath
getPackageDBPath GlobalPackageDB =
selectMonitorFile =<< getGlobalPackageDB verbosity ghcjsProg
-
getPackageDBPath UserPackageDB =
selectMonitorFile =<< getUserPackageDB verbosity ghcjsProg platform
-
getPackageDBPath (SpecificPackageDB path) = selectMonitorFile path
-- GHC has old style file dbs, and new style directory dbs.
@@ -356,37 +448,52 @@ getInstalledPackagesMonitorFiles verbosity platform progdb =
-- so it's safe to only monitor this one file.
selectMonitorFile path = do
isFileStyle <- doesFileExist path
- if isFileStyle then return path
- else return (path </> "package.cache")
+ if isFileStyle
+ then return path
+ else return (path </> "package.cache")
ghcjsProg = fromMaybe (error "GHCJS.toPackageIndex no ghcjs program") $ lookupProgram ghcjsProgram progdb
-
toJSLibName :: String -> String
toJSLibName lib
- | takeExtension lib `elem` [".dll",".dylib",".so"]
- = replaceExtension lib "js_so"
+ | takeExtension lib `elem` [".dll", ".dylib", ".so"] =
+ replaceExtension lib "js_so"
| takeExtension lib == ".a" = replaceExtension lib "js_a"
- | otherwise = lib <.> "js_a"
+ | otherwise = lib <.> "js_a"
-- -----------------------------------------------------------------------------
-- Building a library
-buildLib :: Verbosity -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
- -> IO ()
+buildLib
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildLib = buildOrReplLib Nothing
-replLib :: [String] -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Library
- -> ComponentLocalBuildInfo -> IO ()
+replLib
+ :: [String]
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
replLib = buildOrReplLib . Just
-buildOrReplLib :: Maybe [String] -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Library
- -> ComponentLocalBuildInfo -> IO ()
+buildOrReplLib
+ :: Maybe [String]
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
let uid = componentUnitId clbi
libTargetDir = componentBuildDir lbi clbi
@@ -401,7 +508,7 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
forRepl = maybe False (const True) mReplFlags
-- ifReplLib = when forRepl
comp = compiler lbi
- implInfo = getImplInfo comp
+ implInfo = getImplInfo comp
platform@(Platform _hostArch _hostOS) = hostPlatform lbi
has_code = not (componentIsIndefinite clbi)
@@ -411,12 +518,12 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
let libBi = libBuildInfo lib
-- fixme flags shouldn't depend on ghcjs being dynamic or not
- let isGhcjsDynamic = isDynamic comp
+ let isGhcjsDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
doingTH = usesTemplateHaskellOrQQ libBi
forceVanillaLib = doingTH && not isGhcjsDynamic
- forceSharedLib = doingTH && isGhcjsDynamic
- -- TH always needs default libs, even when building for profiling
+ forceSharedLib = doingTH && isGhcjsDynamic
+ -- TH always needs default libs, even when building for profiling
-- Determine if program coverage should be enabled and if so, what
-- '-hpcdir' should be.
@@ -428,152 +535,169 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
pkg_name = prettyShow (PD.package pkg_descr)
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
- | forRepl = mempty -- HPC is not supported in ghci
+ | forRepl = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
| otherwise = mempty
createDirectoryIfMissingVerbose verbosity True libTargetDir
-- TODO: do we need to put hs-boot files into place for mutually recursive
-- modules?
- let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi)
- jsSrcs = jsSources libBi
- cObjs = map (`replaceExtension` objExtension) cLikeFiles
- baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
- linkJsLibOpts = mempty {
- ghcOptExtra =
- [ "-link-js-lib" , getHSLibraryName uid
- , "-js-lib-outputdir", libTargetDir ] ++
- jsSrcs
- }
- vanillaOptsNoJsLib = baseOpts `mappend` mempty {
- ghcOptMode = toFlag GhcModeMake,
- ghcOptNumJobs = numJobs,
- ghcOptInputModules = toNubListR $ allLibModules lib clbi,
- ghcOptHPCDir = hpcdir Hpc.Vanilla
- }
+ let cLikeFiles = fromNubListR $ toNubListR (cSources libBi) <> toNubListR (cxxSources libBi)
+ jsSrcs = jsSources libBi
+ cObjs = map (`replaceExtension` objExtension) cLikeFiles
+ baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
+ linkJsLibOpts =
+ mempty
+ { ghcOptExtra =
+ [ "-link-js-lib"
+ , getHSLibraryName uid
+ , "-js-lib-outputdir"
+ , libTargetDir
+ ]
+ ++ jsSrcs
+ }
+ vanillaOptsNoJsLib =
+ baseOpts
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeMake
+ , ghcOptNumJobs = numJobs
+ , ghcOptInputModules = toNubListR $ allLibModules lib clbi
+ , ghcOptHPCDir = hpcdir Hpc.Vanilla
+ }
vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts
- profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptProfilingAuto = Internal.profDetailLevelFlag True
- (withProfLibDetail lbi),
- -- ghcOptHiSuffix = toFlag "p_hi",
- -- ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = hcProfOptions GHC libBi,
- ghcOptHPCDir = hpcdir Hpc.Prof
- }
-
- sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptFPic = toFlag True,
- -- ghcOptHiSuffix = toFlag "dyn_hi",
- -- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = hcSharedOptions GHC libBi,
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
-
- vanillaSharedOpts = vanillaOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
- ghcOptDynHiSuffix = toFlag "js_dyn_hi",
- ghcOptDynObjSuffix = toFlag "js_dyn_o",
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
+ profOpts =
+ adjustExts "p_hi" "p_o" vanillaOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptProfilingAuto =
+ Internal.profDetailLevelFlag
+ True
+ (withProfLibDetail lbi)
+ , -- ghcOptHiSuffix = toFlag "p_hi",
+ -- ghcOptObjSuffix = toFlag "p_o",
+ ghcOptExtra = hcProfOptions GHC libBi
+ , ghcOptHPCDir = hpcdir Hpc.Prof
+ }
+
+ sharedOpts =
+ adjustExts "dyn_hi" "dyn_o" vanillaOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptFPic = toFlag True
+ , -- ghcOptHiSuffix = toFlag "dyn_hi",
+ -- ghcOptObjSuffix = toFlag "dyn_o",
+ ghcOptExtra = hcSharedOptions GHC libBi
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+
+ vanillaSharedOpts =
+ vanillaOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
+ , ghcOptDynHiSuffix = toFlag "js_dyn_hi"
+ , ghcOptDynObjSuffix = toFlag "js_dyn_o"
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $
- do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)
- shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts)
- useDynToo = dynamicTooSupported &&
- (forceVanillaLib || withVanillaLib lbi) &&
- (forceSharedLib || withSharedLib lbi) &&
- null (hcSharedOptions GHC libBi)
- if not has_code
+ do
+ let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)
+ shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts)
+ useDynToo =
+ dynamicTooSupported
+ && (forceVanillaLib || withVanillaLib lbi)
+ && (forceSharedLib || withSharedLib lbi)
+ && null (hcSharedOptions GHC libBi)
+ if not has_code
then vanilla
else
- if useDynToo
- then do
+ if useDynToo
+ then do
runGhcjsProg vanillaSharedOpts
case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
(Flag dynDir, Flag vanillaDir) ->
- -- When the vanilla and shared library builds are done
- -- in one pass, only one set of HPC module interfaces
- -- are generated. This set should suffice for both
- -- static and dynamically linked executables. We copy
- -- the modules interfaces so they are available under
- -- both ways.
- copyDirectoryRecursive verbosity dynDir vanillaDir
+ -- When the vanilla and shared library builds are done
+ -- in one pass, only one set of HPC module interfaces
+ -- are generated. This set should suffice for both
+ -- static and dynamically linked executables. We copy
+ -- the modules interfaces so they are available under
+ -- both ways.
+ copyDirectoryRecursive verbosity dynDir vanillaDir
_ -> return ()
- else if isGhcjsDynamic
- then do shared; vanilla
- else do vanilla; shared
- whenProfLib (runGhcjsProg profOpts)
+ else
+ if isGhcjsDynamic
+ then do shared; vanilla
+ else do vanilla; shared
+ whenProfLib (runGhcjsProg profOpts)
-- Build any C++ sources separately.
{-
- unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do
- info verbosity "Building C++ Sources..."
- sequence_
- [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo
- lbi libBi clbi libTargetDir filename
- vanillaCxxOpts = if isGhcjsDynamic
- then baseCxxOpts { ghcOptFPic = toFlag True }
- else baseCxxOpts
- profCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaCxxOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded cxxOpts = do
- needsRecomp <- checkNeedsRecompilation filename cxxOpts
- when needsRecomp $ runGhcjsProg cxxOpts
- runGhcProgIfNeeded vanillaCxxOpts
- unless forRepl $
- whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts)
- | filename <- cxxSources libBi]
-
- ifReplLib $ do
- when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"
- ifReplLib (runGhcjsProg replOpts)
--}
+ unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do
+ info verbosity "Building C++ Sources..."
+ sequence_
+ [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo
+ lbi libBi clbi libTargetDir filename
+ vanillaCxxOpts = if isGhcjsDynamic
+ then baseCxxOpts { ghcOptFPic = toFlag True }
+ else baseCxxOpts
+ profCxxOpts = vanillaCxxOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCxxOpts = vanillaCxxOpts `mappend` mempty {
+ ghcOptFPic = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCxxOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded cxxOpts = do
+ needsRecomp <- checkNeedsRecompilation filename cxxOpts
+ when needsRecomp $ runGhcjsProg cxxOpts
+ runGhcProgIfNeeded vanillaCxxOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCxxOpts)
+ | filename <- cxxSources libBi]
+
+ ifReplLib $ do
+ when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"
+ ifReplLib (runGhcjsProg replOpts)
+ -}
-- build any C sources
-- TODO: Add support for S and CMM files.
{-
- unless (not has_code || null (cSources libBi) || not nativeToo) $ do
- info verbosity "Building C Sources..."
- sequence_
- [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo
- lbi libBi clbi libTargetDir filename
- vanillaCcOpts = if isGhcjsDynamic
- -- Dynamic GHC requires C sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCcOpts { ghcOptFPic = toFlag True }
- else baseCcOpts
- profCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptObjSuffix = toFlag "p_o"
- }
- sharedCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptObjSuffix = toFlag "dyn_o"
- }
- odir = fromFlag (ghcOptObjDir vanillaCcOpts)
- createDirectoryIfMissingVerbose verbosity True odir
- let runGhcProgIfNeeded ccOpts = do
- needsRecomp <- checkNeedsRecompilation filename ccOpts
- when needsRecomp $ runGhcjsProg ccOpts
- runGhcProgIfNeeded vanillaCcOpts
- unless forRepl $
- whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
- unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
- | filename <- cSources libBi]
--}
+ unless (not has_code || null (cSources libBi) || not nativeToo) $ do
+ info verbosity "Building C Sources..."
+ sequence_
+ [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo
+ lbi libBi clbi libTargetDir filename
+ vanillaCcOpts = if isGhcjsDynamic
+ -- Dynamic GHC requires C sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ then baseCcOpts { ghcOptFPic = toFlag True }
+ else baseCcOpts
+ profCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptProfilingMode = toFlag True,
+ ghcOptObjSuffix = toFlag "p_o"
+ }
+ sharedCcOpts = vanillaCcOpts `mappend` mempty {
+ ghcOptFPic = toFlag True,
+ ghcOptDynLinkMode = toFlag GhcDynamicOnly,
+ ghcOptObjSuffix = toFlag "dyn_o"
+ }
+ odir = fromFlag (ghcOptObjDir vanillaCcOpts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ let runGhcProgIfNeeded ccOpts = do
+ needsRecomp <- checkNeedsRecompilation filename ccOpts
+ when needsRecomp $ runGhcjsProg ccOpts
+ runGhcProgIfNeeded vanillaCcOpts
+ unless forRepl $
+ whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
+ unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
+ | filename <- cSources libBi]
+ -}
-- TODO: problem here is we need the .c files built first, so we can load them
-- with ghci, but .c files can depend on .h files generated by ghc by ffi
-- exports.
@@ -582,8 +706,10 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
when has_code . when False {- fixme nativeToo -} . unless forRepl $ do
info verbosity "Linking..."
- let cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
- (cSources libBi ++ cxxSources libBi)
+ let cSharedObjs =
+ map
+ (`replaceExtension` ("dyn_" ++ objExtension))
+ (cSources libBi ++ cxxSources libBi)
compiler_id = compilerId (compiler lbi)
sharedLibFilePath = libTargetDir </> mkSharedLibName (hostPlatform lbi) compiler_id uid
staticLibFilePath = libTargetDir </> mkStaticLibName (hostPlatform lbi) compiler_id uid
@@ -591,132 +717,148 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
let stubObjs = []
stubSharedObjs = []
-{-
- stubObjs <- catMaybes <$> sequenceA
- [ findFileWithExtension [objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
- , x <- allLibModules lib clbi ]
- stubProfObjs <- catMaybes <$> sequenceA
- [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
- , x <- allLibModules lib clbi ]
- stubSharedObjs <- catMaybes <$> sequenceA
- [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
- (ModuleName.toFilePath x ++"_stub")
- | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
- , x <- allLibModules lib clbi ]
--}
- hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi
- libTargetDir objExtension True
+ {-
+ stubObjs <- catMaybes <$> sequenceA
+ [ findFileWithExtension [objExtension] [libTargetDir]
+ (ModuleName.toFilePath x ++"_stub")
+ | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
+ , x <- allLibModules lib clbi ]
+ stubProfObjs <- catMaybes <$> sequenceA
+ [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
+ (ModuleName.toFilePath x ++"_stub")
+ | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
+ , x <- allLibModules lib clbi ]
+ stubSharedObjs <- catMaybes <$> sequenceA
+ [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
+ (ModuleName.toFilePath x ++"_stub")
+ | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
+ , x <- allLibModules lib clbi ]
+ -}
+ hObjs <-
+ Internal.getHaskellObjects
+ implInfo
+ lib
+ lbi
+ clbi
+ libTargetDir
+ objExtension
+ True
hSharedObjs <-
if withSharedLib lbi
- then Internal.getHaskellObjects implInfo lib lbi clbi
- libTargetDir ("dyn_" ++ objExtension) False
- else return []
+ then
+ Internal.getHaskellObjects
+ implInfo
+ lib
+ lbi
+ clbi
+ libTargetDir
+ ("dyn_" ++ objExtension)
+ False
+ else return []
unless (null hObjs && null cObjs && null stubObjs) $ do
rpaths <- getRPaths lbi clbi
let staticObjectFiles =
- hObjs
+ hObjs
++ map (libTargetDir </>) cObjs
++ stubObjs
dynamicObjectFiles =
- hSharedObjs
+ hSharedObjs
++ map (libTargetDir </>) cSharedObjs
++ stubSharedObjs
-- After the relocation lib is created we invoke ghc -shared
-- with the dependencies spelled out as -package arguments
-- and ghc invokes the linker with the proper library paths
ghcSharedLinkArgs =
- mempty {
- ghcOptShared = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptInputFiles = toNubListR dynamicObjectFiles,
- ghcOptOutputFile = toFlag sharedLibFilePath,
- ghcOptExtra = hcSharedOptions GHC libBi,
- -- For dynamic libs, Mac OS/X needs to know the install location
+ mempty
+ { ghcOptShared = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptInputFiles = toNubListR dynamicObjectFiles
+ , ghcOptOutputFile = toFlag sharedLibFilePath
+ , ghcOptExtra = hcSharedOptions GHC libBi
+ , -- For dynamic libs, Mac OS/X needs to know the install location
-- at build time. This only applies to GHC < 7.8 - see the
-- discussion in #1660.
- {-
- ghcOptDylibName = if hostOS == OSX
- && ghcVersion < mkVersion [7,8]
- then toFlag sharedLibInstallPath
- else mempty, -}
- ghcOptHideAllPackages = toFlag True,
- ghcOptNoAutoLinkPackages = toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptThisUnitId = case clbi of
- LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
- -> toFlag pk
- _ -> mempty,
- ghcOptThisComponentId = case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->
- if null insts
- then mempty
- else toFlag (componentComponentId clbi)
- _ -> mempty,
- ghcOptInstantiatedWith = case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts }
- -> insts
- _ -> [],
- ghcOptPackages = toNubListR $
- Internal.mkGhcOptPackages clbi ,
- ghcOptLinkLibs = extraLibs libBi,
- ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi,
- ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
- ghcOptLinkFrameworkDirs =
- toNubListR $ PD.extraFrameworkDirs libBi,
- ghcOptRPaths = rpaths
+ {-
+ ghcOptDylibName = if hostOS == OSX
+ && ghcVersion < mkVersion [7,8]
+ then toFlag sharedLibInstallPath
+ else mempty, -}
+ ghcOptHideAllPackages = toFlag True
+ , ghcOptNoAutoLinkPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptThisUnitId = case clbi of
+ LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
+ toFlag pk
+ _ -> mempty
+ , ghcOptThisComponentId = case clbi of
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
+ if null insts
+ then mempty
+ else toFlag (componentComponentId clbi)
+ _ -> mempty
+ , ghcOptInstantiatedWith = case clbi of
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
+ insts
+ _ -> []
+ , ghcOptPackages =
+ toNubListR $
+ Internal.mkGhcOptPackages clbi
+ , ghcOptLinkLibs = extraLibs libBi
+ , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
+ , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
+ , ghcOptLinkFrameworkDirs =
+ toNubListR $ PD.extraFrameworkDirs libBi
+ , ghcOptRPaths = rpaths
}
ghcStaticLinkArgs =
- mempty {
- ghcOptStaticLib = toFlag True,
- ghcOptInputFiles = toNubListR staticObjectFiles,
- ghcOptOutputFile = toFlag staticLibFilePath,
- ghcOptExtra = hcStaticOptions GHC libBi,
- ghcOptHideAllPackages = toFlag True,
- ghcOptNoAutoLinkPackages = toFlag True,
- ghcOptPackageDBs = withPackageDB lbi,
- ghcOptThisUnitId = case clbi of
- LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
- -> toFlag pk
- _ -> mempty,
- ghcOptThisComponentId = case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts } ->
- if null insts
- then mempty
- else toFlag (componentComponentId clbi)
- _ -> mempty,
- ghcOptInstantiatedWith = case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts }
- -> insts
- _ -> [],
- ghcOptPackages = toNubListR $
- Internal.mkGhcOptPackages clbi ,
- ghcOptLinkLibs = extraLibs libBi,
- ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
+ mempty
+ { ghcOptStaticLib = toFlag True
+ , ghcOptInputFiles = toNubListR staticObjectFiles
+ , ghcOptOutputFile = toFlag staticLibFilePath
+ , ghcOptExtra = hcStaticOptions GHC libBi
+ , ghcOptHideAllPackages = toFlag True
+ , ghcOptNoAutoLinkPackages = toFlag True
+ , ghcOptPackageDBs = withPackageDB lbi
+ , ghcOptThisUnitId = case clbi of
+ LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
+ toFlag pk
+ _ -> mempty
+ , ghcOptThisComponentId = case clbi of
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
+ if null insts
+ then mempty
+ else toFlag (componentComponentId clbi)
+ _ -> mempty
+ , ghcOptInstantiatedWith = case clbi of
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
+ insts
+ _ -> []
+ , ghcOptPackages =
+ toNubListR $
+ Internal.mkGhcOptPackages clbi
+ , ghcOptLinkLibs = extraLibs libBi
+ , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
}
info verbosity (show (ghcOptPackages ghcSharedLinkArgs))
-{-
- whenVanillaLib False $ do
- Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
- whenGHCiLib $ do
- (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
- Ld.combineObjectFiles verbosity lbi ldProg
- ghciLibFilePath staticObjectFiles
- -}
-{-
- whenProfLib $ do
- Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
- whenGHCiLib $ do
- (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
- Ld.combineObjectFiles verbosity lbi ldProg
- ghciProfLibFilePath profObjectFiles
--}
+ {-
+ whenVanillaLib False $ do
+ Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
+ whenGHCiLib $ do
+ (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
+ Ld.combineObjectFiles verbosity lbi ldProg
+ ghciLibFilePath staticObjectFiles
+ -}
+ {-
+ whenProfLib $ do
+ Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
+ whenGHCiLib $ do
+ (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
+ Ld.combineObjectFiles verbosity lbi ldProg
+ ghciProfLibFilePath profObjectFiles
+ -}
whenSharedLib False $
runGhcjsProg ghcSharedLinkArgs
@@ -724,13 +866,19 @@ buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
runGhcjsProg ghcStaticLinkArgs
-- | Start a REPL without loading any source files.
-startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform
- -> PackageDBStack -> IO ()
+startInterpreter
+ :: Verbosity
+ -> ProgramDb
+ -> Compiler
+ -> Platform
+ -> PackageDBStack
+ -> IO ()
startInterpreter verbosity progdb comp platform packageDBs = do
- let replOpts = mempty {
- ghcOptMode = toFlag GhcModeInteractive,
- ghcOptPackageDBs = packageDBs
- }
+ let replOpts =
+ mempty
+ { ghcOptMode = toFlag GhcModeInteractive
+ , ghcOptPackageDBs = packageDBs
+ }
checkPackageDbStack verbosity packageDBs
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb
runGHC verbosity ghcjsProg comp platform replOpts
@@ -740,61 +888,76 @@ startInterpreter verbosity progdb comp platform packageDBs = do
-- | Build a foreign library
buildFLib
- :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> ForeignLib -> ComponentLocalBuildInfo -> IO ()
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildFLib v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildFLib
replFLib
- :: [String] -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> ForeignLib
- -> ComponentLocalBuildInfo -> IO ()
-replFLib replFlags v njobs pkg lbi =
+ :: [String]
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> ForeignLib
+ -> ComponentLocalBuildInfo
+ -> IO ()
+replFLib replFlags v njobs pkg lbi =
gbuild v njobs pkg lbi . GReplFLib replFlags
-- | Build an executable with GHC.
---
buildExe
- :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> Executable -> ComponentLocalBuildInfo -> IO ()
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildExe v njobs pkg lbi = gbuild v njobs pkg lbi . GBuildExe
replExe
- :: [String] -> Verbosity
- -> Flag (Maybe Int) -> PackageDescription
- -> LocalBuildInfo -> Executable
- -> ComponentLocalBuildInfo -> IO ()
+ :: [String]
+ -> Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
replExe replFlags v njobs pkg lbi =
gbuild v njobs pkg lbi . GReplExe replFlags
-- | Building an executable, starting the REPL, and building foreign
-- libraries are all very similar and implemented in 'gbuild'. The
-- 'GBuildMode' distinguishes between the various kinds of operation.
-data GBuildMode =
- GBuildExe Executable
- | GReplExe [String] Executable
+data GBuildMode
+ = GBuildExe Executable
+ | GReplExe [String] Executable
| GBuildFLib ForeignLib
- | GReplFLib [String] ForeignLib
+ | GReplFLib [String] ForeignLib
gbuildInfo :: GBuildMode -> BuildInfo
-gbuildInfo (GBuildExe exe) = buildInfo exe
-gbuildInfo (GReplExe _ exe) = buildInfo exe
+gbuildInfo (GBuildExe exe) = buildInfo exe
+gbuildInfo (GReplExe _ exe) = buildInfo exe
gbuildInfo (GBuildFLib flib) = foreignLibBuildInfo flib
-gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib
+gbuildInfo (GReplFLib _ flib) = foreignLibBuildInfo flib
gbuildName :: GBuildMode -> String
-gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe
-gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe
+gbuildName (GBuildExe exe) = unUnqualComponentName $ exeName exe
+gbuildName (GReplExe _ exe) = unUnqualComponentName $ exeName exe
gbuildName (GBuildFLib flib) = unUnqualComponentName $ foreignLibName flib
-gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib
+gbuildName (GReplFLib _ flib) = unUnqualComponentName $ foreignLibName flib
gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String
-gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe
-gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe
+gbuildTargetName lbi (GBuildExe exe) = exeTargetName (hostPlatform lbi) exe
+gbuildTargetName lbi (GReplExe _ exe) = exeTargetName (hostPlatform lbi) exe
gbuildTargetName lbi (GBuildFLib flib) = flibTargetName lbi flib
-gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib
+gbuildTargetName lbi (GReplFLib _ flib) = flibTargetName lbi flib
exeTargetName :: Platform -> Executable -> String
exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeExtension platform
@@ -810,20 +973,21 @@ exeTargetName platform exe = unUnqualComponentName (exeName exe) `withExt` exeEx
-- than the target OS (but this is wrong elsewhere in Cabal as well).
flibTargetName :: LocalBuildInfo -> ForeignLib -> String
flibTargetName lbi flib =
- case (os, foreignLibType flib) of
- (Windows, ForeignLibNativeShared) -> nm <.> "dll"
- (Windows, ForeignLibNativeStatic) -> nm <.> "lib"
- (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt
- (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi)
- (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)
- (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"
+ case (os, foreignLibType flib) of
+ (Windows, ForeignLibNativeShared) -> nm <.> "dll"
+ (Windows, ForeignLibNativeStatic) -> nm <.> "lib"
+ (Linux, ForeignLibNativeShared) -> "lib" ++ nm <.> versionedExt
+ (_other, ForeignLibNativeShared) -> "lib" ++ nm <.> dllExtension (hostPlatform lbi)
+ (_other, ForeignLibNativeStatic) -> "lib" ++ nm <.> staticLibExtension (hostPlatform lbi)
+ (_any, ForeignLibTypeUnknown) -> cabalBug "unknown foreign lib type"
where
nm :: String
nm = unUnqualComponentName $ foreignLibName flib
os :: OS
- os = let (Platform _ os') = hostPlatform lbi
- in os'
+ os =
+ let (Platform _ os') = hostPlatform lbi
+ in os'
-- If a foreign lib foo has lib-version-info 5:1:2 or
-- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1
@@ -832,7 +996,7 @@ flibTargetName lbi flib =
versionedExt :: String
versionedExt =
let nums = foreignLibVersion flib os
- in foldl (<.>) "so" (map show nums)
+ in foldl (<.>) "so" (map show nums)
-- | Name for the library when building.
--
@@ -854,32 +1018,33 @@ flibBuildName :: LocalBuildInfo -> ForeignLib -> String
flibBuildName lbi flib
-- On linux, if a foreign-library has version data, the first digit is used
-- to produce the SONAME.
- | (os, foreignLibType flib) ==
- (Linux, ForeignLibNativeShared)
- = let nums = foreignLibVersion flib os
- in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))
+ | (os, foreignLibType flib)
+ == (Linux, ForeignLibNativeShared) =
+ let nums = foreignLibVersion flib os
+ in "lib" ++ nm <.> foldl (<.>) "so" (map show (take 1 nums))
| otherwise = flibTargetName lbi flib
where
os :: OS
- os = let (Platform _ os') = hostPlatform lbi
- in os'
+ os =
+ let (Platform _ os') = hostPlatform lbi
+ in os'
nm :: String
nm = unUnqualComponentName $ foreignLibName flib
gbuildIsRepl :: GBuildMode -> Bool
-gbuildIsRepl (GBuildExe _) = False
+gbuildIsRepl (GBuildExe _) = False
gbuildIsRepl (GReplExe _ _) = True
gbuildIsRepl (GBuildFLib _) = False
gbuildIsRepl (GReplFLib _ _) = True
gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool
gbuildNeedDynamic lbi bm =
- case bm of
- GBuildExe _ -> withDynExe lbi
- GReplExe _ _ -> withDynExe lbi
- GBuildFLib flib -> withDynFLib flib
- GReplFLib _ flib -> withDynFLib flib
+ case bm of
+ GBuildExe _ -> withDynExe lbi
+ GReplExe _ _ -> withDynExe lbi
+ GBuildFLib flib -> withDynFLib flib
+ GReplFLib _ flib -> withDynFLib flib
where
withDynFLib flib =
case foreignLibType flib of
@@ -887,12 +1052,12 @@ gbuildNeedDynamic lbi bm =
ForeignLibStandalone `notElem` foreignLibOptions flib
ForeignLibNativeStatic ->
False
- ForeignLibTypeUnknown ->
+ ForeignLibTypeUnknown ->
cabalBug "unknown foreign lib type"
gbuildModDefFiles :: GBuildMode -> [FilePath]
-gbuildModDefFiles (GBuildExe _) = []
-gbuildModDefFiles (GReplExe _ _) = []
+gbuildModDefFiles (GBuildExe _) = []
+gbuildModDefFiles (GReplExe _ _) = []
gbuildModDefFiles (GBuildFLib flib) = foreignLibModDefFile flib
gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib
@@ -902,18 +1067,18 @@ gbuildModDefFiles (GReplFLib _ flib) = foreignLibModDefFile flib
-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.
exeMainModuleName :: Executable -> Maybe ModuleName
exeMainModuleName Executable{buildInfo = bnfo} =
- -- GHC honors the last occurrence of a module name updated via -main-is
- --
- -- Moreover, -main-is when parsed left-to-right can update either
- -- the "Main" module name, or the "main" function name, or both,
- -- see also 'decodeMainIsArg'.
- msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts
+ -- GHC honors the last occurrence of a module name updated via -main-is
+ --
+ -- Moreover, -main-is when parsed left-to-right can update either
+ -- the "Main" module name, or the "main" function name, or both,
+ -- see also 'decodeMainIsArg'.
+ msum $ reverse $ map decodeMainIsArg $ findIsMainArgs ghcopts
where
ghcopts = hcOptions GHC bnfo
findIsMainArgs [] = []
- findIsMainArgs ("-main-is":arg:rest) = arg : findIsMainArgs rest
- findIsMainArgs (_:rest) = findIsMainArgs rest
+ findIsMainArgs ("-main-is" : arg : rest) = arg : findIsMainArgs rest
+ findIsMainArgs (_ : rest) = findIsMainArgs rest
-- | Decode argument to '-main-is'
--
@@ -925,26 +1090,28 @@ exeMainModuleName Executable{buildInfo = bnfo} =
-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg arg
- | headOf main_fn isLower
- -- The arg looked like "Foo.Bar.baz"
- = Just (ModuleName.fromString main_mod)
- | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
- = Just (ModuleName.fromString arg)
- | otherwise -- The arg looked like "baz"
- = Nothing
+ | headOf main_fn isLower =
+ -- The arg looked like "Foo.Bar.baz"
+ Just (ModuleName.fromString main_mod)
+ | headOf arg isUpper -- The arg looked like "Foo" or "Foo.Bar"
+ =
+ Just (ModuleName.fromString arg)
+ | otherwise -- The arg looked like "baz"
+ =
+ Nothing
where
headOf :: String -> (Char -> Bool) -> Bool
headOf str pred' = any pred' (safeHead str)
(main_mod, main_fn) = splitLongestPrefix arg (== '.')
- splitLongestPrefix :: String -> (Char -> Bool) -> (String,String)
+ splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
splitLongestPrefix str pred'
- | null r_pre = (str, [])
- | otherwise = (reverse (safeTail r_pre), reverse r_suf)
- -- 'safeTail' drops the char satisfying 'pred'
- where (r_suf, r_pre) = break pred' (reverse str)
-
+ | null r_pre = (str, [])
+ | otherwise = (reverse (safeTail r_pre), reverse r_suf)
+ where
+ -- 'safeTail' drops the char satisfying 'pred'
+ (r_suf, r_pre) = break pred' (reverse str)
-- | A collection of:
-- * C input files
@@ -953,26 +1120,27 @@ decodeMainIsArg arg
-- * GHC input modules
--
-- Used to correctly build and link sources.
-data BuildSources = BuildSources {
- cSourcesFiles :: [FilePath],
- cxxSourceFiles :: [FilePath],
- inputSourceFiles :: [FilePath],
- inputSourceModules :: [ModuleName]
- }
+data BuildSources = BuildSources
+ { cSourcesFiles :: [FilePath]
+ , cxxSourceFiles :: [FilePath]
+ , inputSourceFiles :: [FilePath]
+ , inputSourceModules :: [ModuleName]
+ }
-- | Locate and return the 'BuildSources' required to build and link.
-gbuildSources :: Verbosity
- -> PackageId
- -> CabalSpecVersion
- -> FilePath
- -> GBuildMode
- -> IO BuildSources
+gbuildSources
+ :: Verbosity
+ -> PackageId
+ -> CabalSpecVersion
+ -> FilePath
+ -> GBuildMode
+ -> IO BuildSources
gbuildSources verbosity pkgId specVer tmpDir bm =
- case bm of
- GBuildExe exe -> exeSources exe
- GReplExe _ exe -> exeSources exe
- GBuildFLib flib -> return $ flibSources flib
- GReplFLib _ flib -> return $ flibSources flib
+ case bm of
+ GBuildExe exe -> exeSources exe
+ GReplExe _ exe -> exeSources exe
+ GBuildFLib flib -> return $ flibSources flib
+ GReplFLib _ flib -> return $ flibSources flib
where
exeSources :: Executable -> IO BuildSources
exeSources exe@Executable{buildInfo = bnfo, modulePath = modPath} = do
@@ -984,56 +1152,60 @@ gbuildSources verbosity pkgId specVer tmpDir bm =
if isHaskell main || pkgId == fakePackageId
then
if specVer < CabalSpecV2_0 && (mainModName `elem` otherModNames)
- then do
- -- The cabal manual clearly states that `other-modules` is
- -- intended for non-main modules. However, there's at least one
- -- important package on Hackage (happy-1.19.5) which
- -- violates this. We workaround this here so that we don't
- -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which
- -- would result in GHC complaining about duplicate Main
- -- modules.
- --
- -- Finally, we only enable this workaround for
- -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
- -- have no excuse anymore to keep doing it wrong... ;-)
- warn verbosity $ "Enabling workaround for Main module '"
- ++ prettyShow mainModName
- ++ "' listed in 'other-modules' illegally!"
-
- return BuildSources {
- cSourcesFiles = cSources bnfo,
- cxxSourceFiles = cxxSources bnfo,
- inputSourceFiles = [main],
- inputSourceModules = filter (/= mainModName) $ exeModules exe
- }
-
- else return BuildSources {
- cSourcesFiles = cSources bnfo,
- cxxSourceFiles = cxxSources bnfo,
- inputSourceFiles = [main],
- inputSourceModules = exeModules exe
- }
- else let (csf, cxxsf)
- | isCxx main = ( cSources bnfo, main : cxxSources bnfo)
- -- if main is not a Haskell source
- -- and main is not a C++ source
- -- then we assume that it is a C source
- | otherwise = (main : cSources bnfo, cxxSources bnfo)
-
- in return BuildSources {
- cSourcesFiles = csf,
- cxxSourceFiles = cxxsf,
- inputSourceFiles = [],
- inputSourceModules = exeModules exe
- }
+ then do
+ -- The cabal manual clearly states that `other-modules` is
+ -- intended for non-main modules. However, there's at least one
+ -- important package on Hackage (happy-1.19.5) which
+ -- violates this. We workaround this here so that we don't
+ -- invoke GHC with e.g. 'ghc --make Main src/Main.hs' which
+ -- would result in GHC complaining about duplicate Main
+ -- modules.
+ --
+ -- Finally, we only enable this workaround for
+ -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
+ -- have no excuse anymore to keep doing it wrong... ;-)
+ warn verbosity $
+ "Enabling workaround for Main module '"
+ ++ prettyShow mainModName
+ ++ "' listed in 'other-modules' illegally!"
+
+ return
+ BuildSources
+ { cSourcesFiles = cSources bnfo
+ , cxxSourceFiles = cxxSources bnfo
+ , inputSourceFiles = [main]
+ , inputSourceModules = filter (/= mainModName) $ exeModules exe
+ }
+ else
+ return
+ BuildSources
+ { cSourcesFiles = cSources bnfo
+ , cxxSourceFiles = cxxSources bnfo
+ , inputSourceFiles = [main]
+ , inputSourceModules = exeModules exe
+ }
+ else
+ let (csf, cxxsf)
+ | isCxx main = (cSources bnfo, main : cxxSources bnfo)
+ -- if main is not a Haskell source
+ -- and main is not a C++ source
+ -- then we assume that it is a C source
+ | otherwise = (main : cSources bnfo, cxxSources bnfo)
+ in return
+ BuildSources
+ { cSourcesFiles = csf
+ , cxxSourceFiles = cxxsf
+ , inputSourceFiles = []
+ , inputSourceModules = exeModules exe
+ }
flibSources :: ForeignLib -> BuildSources
flibSources flib@ForeignLib{foreignLibBuildInfo = bnfo} =
- BuildSources {
- cSourcesFiles = cSources bnfo,
- cxxSourceFiles = cxxSources bnfo,
- inputSourceFiles = [],
- inputSourceModules = foreignLibModules flib
+ BuildSources
+ { cSourcesFiles = cSources bnfo
+ , cxxSourceFiles = cxxSources bnfo
+ , inputSourceFiles = []
+ , inputSourceModules = foreignLibModules flib
}
isCxx :: FilePath -> Bool
@@ -1044,29 +1216,34 @@ isHaskell :: FilePath -> Bool
isHaskell fp = elem (takeExtension fp) [".hs", ".lhs"]
-- | Generic build function. See comment for 'GBuildMode'.
-gbuild :: Verbosity -> Flag (Maybe Int)
- -> PackageDescription -> LocalBuildInfo
- -> GBuildMode -> ComponentLocalBuildInfo -> IO ()
+gbuild
+ :: Verbosity
+ -> Flag (Maybe Int)
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> GBuildMode
+ -> ComponentLocalBuildInfo
+ -> IO ()
gbuild verbosity numJobs pkg_descr lbi bm clbi = do
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
let replFlags = case bm of
- GReplExe flags _ -> flags
- GReplFLib flags _ -> flags
- GBuildExe{} -> mempty
- GBuildFLib{} -> mempty
- comp = compiler lbi
- platform = hostPlatform lbi
- implInfo = getImplInfo comp
+ GReplExe flags _ -> flags
+ GReplFLib flags _ -> flags
+ GBuildExe{} -> mempty
+ GBuildFLib{} -> mempty
+ comp = compiler lbi
+ platform = hostPlatform lbi
+ implInfo = getImplInfo comp
runGhcProg = runGHC verbosity ghcjsProg comp platform
let (bnfo, threaded) = case bm of
GBuildFLib _ -> popThreadedFlag (gbuildInfo bm)
- _ -> (gbuildInfo bm, False)
+ _ -> (gbuildInfo bm, False)
-- the name that GHC really uses (e.g., with .exe on Windows for executables)
let targetName = gbuildTargetName lbi bm
- let targetDir = buildDir lbi </> (gbuildName bm)
- let tmpDir = targetDir </> (gbuildName bm ++ "-tmp")
+ let targetDir = buildDir lbi </> (gbuildName bm)
+ let tmpDir = targetDir </> (gbuildName bm ++ "-tmp")
createDirectoryIfMissingVerbose verbosity True targetDir
createDirectoryIfMissingVerbose verbosity True tmpDir
@@ -1078,109 +1255,134 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
let isCoverageEnabled = exeCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
- | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
+ | gbuildIsRepl bm = mempty -- HPC is not supported in ghci
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way (gbuildName bm)
- | otherwise = mempty
+ | otherwise = mempty
rpaths <- getRPaths lbi clbi
buildSources <- gbuildSources verbosity (package pkg_descr) (specVersion pkg_descr) tmpDir bm
- let cSrcs = cSourcesFiles buildSources
- cxxSrcs = cxxSourceFiles buildSources
- inputFiles = inputSourceFiles buildSources
- inputModules = inputSourceModules buildSources
- isGhcDynamic = isDynamic comp
+ let cSrcs = cSourcesFiles buildSources
+ cxxSrcs = cxxSourceFiles buildSources
+ inputFiles = inputSourceFiles buildSources
+ inputModules = inputSourceModules buildSources
+ isGhcDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
- cObjs = map (`replaceExtension` objExtension) cSrcs
- cxxObjs = map (`replaceExtension` objExtension) cxxSrcs
- needDynamic = gbuildNeedDynamic lbi bm
- needProfiling = withProfExe lbi
+ cObjs = map (`replaceExtension` objExtension) cSrcs
+ cxxObjs = map (`replaceExtension` objExtension) cxxSrcs
+ needDynamic = gbuildNeedDynamic lbi bm
+ needProfiling = withProfExe lbi
- -- build executables
+ -- build executables
buildRunner = case clbi of
- LibComponentLocalBuildInfo {} -> False
- FLibComponentLocalBuildInfo {} -> False
- ExeComponentLocalBuildInfo {} -> True
- TestComponentLocalBuildInfo {} -> True
- BenchComponentLocalBuildInfo {} -> True
- baseOpts = (componentGhcOptions verbosity lbi bnfo clbi tmpDir)
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeMake,
- ghcOptInputFiles = toNubListR $ if package pkg_descr == fakePackageId
- then filter isHaskell inputFiles
- else inputFiles,
- ghcOptInputScripts = toNubListR $ if package pkg_descr == fakePackageId
- then filter (not . isHaskell) inputFiles
- else [],
- ghcOptInputModules = toNubListR inputModules,
- -- for all executable components (exe/test/bench),
- -- GHCJS must be passed the "-build-runner" option
- ghcOptExtra =
- if buildRunner then ["-build-runner"]
- else mempty
- }
- staticOpts = baseOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticOnly,
- ghcOptHPCDir = hpcdir Hpc.Vanilla
- }
- profOpts = baseOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptProfilingAuto = Internal.profDetailLevelFlag False
- (withProfExeDetail lbi),
- ghcOptHiSuffix = toFlag "p_hi",
- ghcOptObjSuffix = toFlag "p_o",
- ghcOptExtra = hcProfOptions GHC bnfo,
- ghcOptHPCDir = hpcdir Hpc.Prof
- }
- dynOpts = baseOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- -- TODO: Does it hurt to set -fPIC for executables?
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "dyn_hi",
- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = hcSharedOptions GHC bnfo,
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
- dynTooOpts = staticOpts `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
- ghcOptDynHiSuffix = toFlag "dyn_hi",
- ghcOptDynObjSuffix = toFlag "dyn_o",
- ghcOptHPCDir = hpcdir Hpc.Dyn
- }
- linkerOpts = mempty {
- ghcOptLinkOptions = PD.ldOptions bnfo,
- ghcOptLinkLibs = extraLibs bnfo,
- ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo,
- ghcOptLinkFrameworks = toNubListR $
- PD.frameworks bnfo,
- ghcOptLinkFrameworkDirs = toNubListR $
- PD.extraFrameworkDirs bnfo,
- ghcOptInputFiles = toNubListR
- [tmpDir </> x | x <- cObjs ++ cxxObjs]
- }
- dynLinkerOpts = mempty {
- ghcOptRPaths = rpaths
- }
- replOpts = baseOpts {
- ghcOptExtra = Internal.filterGhciFlags
- (ghcOptExtra baseOpts)
- <> replFlags
- }
- -- For a normal compile we do separate invocations of ghc for
- -- compiling as for linking. But for repl we have to do just
- -- the one invocation, so that one has to include all the
- -- linker stuff too, like -l flags and any .o files from C
- -- files etc.
- `mappend` linkerOpts
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeInteractive,
- ghcOptOptimisation = toFlag GhcNoOptimisation
- }
- commonOpts | needProfiling = profOpts
- | needDynamic = dynOpts
- | otherwise = staticOpts
- compileOpts | useDynToo = dynTooOpts
- | otherwise = commonOpts
+ LibComponentLocalBuildInfo{} -> False
+ FLibComponentLocalBuildInfo{} -> False
+ ExeComponentLocalBuildInfo{} -> True
+ TestComponentLocalBuildInfo{} -> True
+ BenchComponentLocalBuildInfo{} -> True
+ baseOpts =
+ (componentGhcOptions verbosity lbi bnfo clbi tmpDir)
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeMake
+ , ghcOptInputFiles =
+ toNubListR $
+ if package pkg_descr == fakePackageId
+ then filter isHaskell inputFiles
+ else inputFiles
+ , ghcOptInputScripts =
+ toNubListR $
+ if package pkg_descr == fakePackageId
+ then filter (not . isHaskell) inputFiles
+ else []
+ , ghcOptInputModules = toNubListR inputModules
+ , -- for all executable components (exe/test/bench),
+ -- GHCJS must be passed the "-build-runner" option
+ ghcOptExtra =
+ if buildRunner
+ then ["-build-runner"]
+ else mempty
+ }
+ staticOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcStaticOnly
+ , ghcOptHPCDir = hpcdir Hpc.Vanilla
+ }
+ profOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptProfilingAuto =
+ Internal.profDetailLevelFlag
+ False
+ (withProfExeDetail lbi)
+ , ghcOptHiSuffix = toFlag "p_hi"
+ , ghcOptObjSuffix = toFlag "p_o"
+ , ghcOptExtra = hcProfOptions GHC bnfo
+ , ghcOptHPCDir = hpcdir Hpc.Prof
+ }
+ dynOpts =
+ baseOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , -- TODO: Does it hurt to set -fPIC for executables?
+ ghcOptFPic = toFlag True
+ , ghcOptHiSuffix = toFlag "dyn_hi"
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ , ghcOptExtra = hcSharedOptions GHC bnfo
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ dynTooOpts =
+ staticOpts
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
+ , ghcOptDynHiSuffix = toFlag "dyn_hi"
+ , ghcOptDynObjSuffix = toFlag "dyn_o"
+ , ghcOptHPCDir = hpcdir Hpc.Dyn
+ }
+ linkerOpts =
+ mempty
+ { ghcOptLinkOptions = PD.ldOptions bnfo
+ , ghcOptLinkLibs = extraLibs bnfo
+ , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo
+ , ghcOptLinkFrameworks =
+ toNubListR $
+ PD.frameworks bnfo
+ , ghcOptLinkFrameworkDirs =
+ toNubListR $
+ PD.extraFrameworkDirs bnfo
+ , ghcOptInputFiles =
+ toNubListR
+ [tmpDir </> x | x <- cObjs ++ cxxObjs]
+ }
+ dynLinkerOpts =
+ mempty
+ { ghcOptRPaths = rpaths
+ }
+ replOpts =
+ baseOpts
+ { ghcOptExtra =
+ Internal.filterGhciFlags
+ (ghcOptExtra baseOpts)
+ <> replFlags
+ }
+ -- For a normal compile we do separate invocations of ghc for
+ -- compiling as for linking. But for repl we have to do just
+ -- the one invocation, so that one has to include all the
+ -- linker stuff too, like -l flags and any .o files from C
+ -- files etc.
+ `mappend` linkerOpts
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeInteractive
+ , ghcOptOptimisation = toFlag GhcNoOptimisation
+ }
+ commonOpts
+ | needProfiling = profOpts
+ | needDynamic = dynOpts
+ | otherwise = staticOpts
+ compileOpts
+ | useDynToo = dynTooOpts
+ | otherwise = commonOpts
withStaticExe = not needProfiling && not needDynamic
-- For building exe's that use TH with -prof or -dynamic we actually have
@@ -1192,141 +1394,188 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- need to be .dyn_o instead of .o.
doingTH = usesTemplateHaskellOrQQ bnfo
-- Should we use -dynamic-too instead of compiling twice?
- useDynToo = dynamicTooSupported && isGhcDynamic
- && doingTH && withStaticExe
- && null (hcSharedOptions GHC bnfo)
- compileTHOpts | isGhcDynamic = dynOpts
- | otherwise = staticOpts
+ useDynToo =
+ dynamicTooSupported
+ && isGhcDynamic
+ && doingTH
+ && withStaticExe
+ && null (hcSharedOptions GHC bnfo)
+ compileTHOpts
+ | isGhcDynamic = dynOpts
+ | otherwise = staticOpts
compileForTH
| gbuildIsRepl bm = False
- | useDynToo = False
- | isGhcDynamic = doingTH && (needProfiling || withStaticExe)
- | otherwise = doingTH && (needProfiling || needDynamic)
+ | useDynToo = False
+ | isGhcDynamic = doingTH && (needProfiling || withStaticExe)
+ | otherwise = doingTH && (needProfiling || needDynamic)
- -- Build static/dynamic object files for TH, if needed.
+ -- Build static/dynamic object files for TH, if needed.
when compileForTH $
- runGhcProg compileTHOpts { ghcOptNoLink = toFlag True
- , ghcOptNumJobs = numJobs }
+ runGhcProg
+ compileTHOpts
+ { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = numJobs
+ }
-- Do not try to build anything if there are no input files.
-- This can happen if the cabal file ends up with only cSrcs
-- but no Haskell modules.
- unless ((null inputFiles && null inputModules)
- || gbuildIsRepl bm) $
- runGhcProg compileOpts { ghcOptNoLink = toFlag True
- , ghcOptNumJobs = numJobs }
+ unless
+ ( (null inputFiles && null inputModules)
+ || gbuildIsRepl bm
+ )
+ $ runGhcProg
+ compileOpts
+ { ghcOptNoLink = toFlag True
+ , ghcOptNumJobs = numJobs
+ }
-- build any C++ sources
unless (null cxxSrcs) $ do
- info verbosity "Building C++ Sources..."
- sequence_
- [ do let baseCxxOpts = Internal.componentCxxGhcOptions verbosity implInfo
- lbi bnfo clbi tmpDir filename
- vanillaCxxOpts = if isGhcDynamic
- -- Dynamic GHC requires C++ sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCxxOpts { ghcOptFPic = toFlag True }
- else baseCxxOpts
- profCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True
- }
- sharedCxxOpts = vanillaCxxOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly
- }
- opts | needProfiling = profCxxOpts
- | needDynamic = sharedCxxOpts
- | otherwise = vanillaCxxOpts
- -- TODO: Placing all Haskell, C, & C++ objects in a single directory
- -- Has the potential for file collisions. In general we would
- -- consider this a user error. However, we should strive to
- -- add a warning if this occurs.
- odir = fromFlag (ghcOptObjDir opts)
- createDirectoryIfMissingVerbose verbosity True odir
- needsRecomp <- checkNeedsRecompilation filename opts
- when needsRecomp $
- runGhcProg opts
- | filename <- cxxSrcs ]
+ info verbosity "Building C++ Sources..."
+ sequence_
+ [ do
+ let baseCxxOpts =
+ Internal.componentCxxGhcOptions
+ verbosity
+ implInfo
+ lbi
+ bnfo
+ clbi
+ tmpDir
+ filename
+ vanillaCxxOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires C++ sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseCxxOpts{ghcOptFPic = toFlag True}
+ else baseCxxOpts
+ profCxxOpts =
+ vanillaCxxOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ }
+ sharedCxxOpts =
+ vanillaCxxOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ }
+ opts
+ | needProfiling = profCxxOpts
+ | needDynamic = sharedCxxOpts
+ | otherwise = vanillaCxxOpts
+ -- TODO: Placing all Haskell, C, & C++ objects in a single directory
+ -- Has the potential for file collisions. In general we would
+ -- consider this a user error. However, we should strive to
+ -- add a warning if this occurs.
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ needsRecomp <- checkNeedsRecompilation filename opts
+ when needsRecomp $
+ runGhcProg opts
+ | filename <- cxxSrcs
+ ]
-- build any C sources
unless (null cSrcs) $ do
- info verbosity "Building C Sources..."
- sequence_
- [ do let baseCcOpts = Internal.componentCcGhcOptions verbosity implInfo
- lbi bnfo clbi tmpDir filename
- vanillaCcOpts = if isGhcDynamic
- -- Dynamic GHC requires C sources to be built
- -- with -fPIC for REPL to work. See #2207.
- then baseCcOpts { ghcOptFPic = toFlag True }
- else baseCcOpts
- profCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptProfilingMode = toFlag True
- }
- sharedCcOpts = vanillaCcOpts `mappend` mempty {
- ghcOptFPic = toFlag True,
- ghcOptDynLinkMode = toFlag GhcDynamicOnly
- }
- opts | needProfiling = profCcOpts
- | needDynamic = sharedCcOpts
- | otherwise = vanillaCcOpts
- odir = fromFlag (ghcOptObjDir opts)
- createDirectoryIfMissingVerbose verbosity True odir
- needsRecomp <- checkNeedsRecompilation filename opts
- when needsRecomp $
- runGhcProg opts
- | filename <- cSrcs ]
+ info verbosity "Building C Sources..."
+ sequence_
+ [ do
+ let baseCcOpts =
+ Internal.componentCcGhcOptions
+ verbosity
+ implInfo
+ lbi
+ bnfo
+ clbi
+ tmpDir
+ filename
+ vanillaCcOpts =
+ if isGhcDynamic
+ then -- Dynamic GHC requires C sources to be built
+ -- with -fPIC for REPL to work. See #2207.
+ baseCcOpts{ghcOptFPic = toFlag True}
+ else baseCcOpts
+ profCcOpts =
+ vanillaCcOpts
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ }
+ sharedCcOpts =
+ vanillaCcOpts
+ `mappend` mempty
+ { ghcOptFPic = toFlag True
+ , ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ }
+ opts
+ | needProfiling = profCcOpts
+ | needDynamic = sharedCcOpts
+ | otherwise = vanillaCcOpts
+ odir = fromFlag (ghcOptObjDir opts)
+ createDirectoryIfMissingVerbose verbosity True odir
+ needsRecomp <- checkNeedsRecompilation filename opts
+ when needsRecomp $
+ runGhcProg opts
+ | filename <- cSrcs
+ ]
-- TODO: problem here is we need the .c files built first, so we can load them
-- with ghci, but .c files can depend on .h files generated by ghc by ffi
-- exports.
case bm of
- GReplExe _ _ -> runGhcProg replOpts
+ GReplExe _ _ -> runGhcProg replOpts
GReplFLib _ _ -> runGhcProg replOpts
GBuildExe _ -> do
- let linkOpts = commonOpts
- `mappend` linkerOpts
- `mappend` mempty {
- ghcOptLinkNoHsMain = toFlag (null inputFiles)
- }
- `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)
+ let linkOpts =
+ commonOpts
+ `mappend` linkerOpts
+ `mappend` mempty
+ { ghcOptLinkNoHsMain = toFlag (null inputFiles)
+ }
+ `mappend` (if withDynExe lbi then dynLinkerOpts else mempty)
info verbosity "Linking..."
-- Work around old GHCs not relinking in this
-- situation, see #3294
let target = targetDir </> targetName
- when (compilerVersion comp < mkVersion [7,7]) $ do
+ when (compilerVersion comp < mkVersion [7, 7]) $ do
e <- doesFileExist target
when e (removeFile target)
- runGhcProg linkOpts { ghcOptOutputFile = toFlag target }
+ runGhcProg linkOpts{ghcOptOutputFile = toFlag target}
GBuildFLib flib -> do
- let rtsInfo = extractRtsInfo lbi
- rtsOptLinkLibs = [
- if needDynamic
- then if threaded
- then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)
- else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)
- else if threaded
- then statRtsThreadedLib (rtsStaticInfo rtsInfo)
- else statRtsVanillaLib (rtsStaticInfo rtsInfo)
- ]
+ let rtsInfo = extractRtsInfo lbi
+ rtsOptLinkLibs =
+ [ if needDynamic
+ then
+ if threaded
+ then dynRtsThreadedLib (rtsDynamicInfo rtsInfo)
+ else dynRtsVanillaLib (rtsDynamicInfo rtsInfo)
+ else
+ if threaded
+ then statRtsThreadedLib (rtsStaticInfo rtsInfo)
+ else statRtsVanillaLib (rtsStaticInfo rtsInfo)
+ ]
linkOpts = case foreignLibType flib of
ForeignLibNativeShared ->
- commonOpts
- `mappend` linkerOpts
- `mappend` dynLinkerOpts
- `mappend` mempty {
- ghcOptLinkNoHsMain = toFlag True,
- ghcOptShared = toFlag True,
- ghcOptLinkLibs = rtsOptLinkLibs,
- ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo,
- ghcOptFPic = toFlag True,
- ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm
- }
- -- See Note [RPATH]
- `mappend` ifNeedsRPathWorkaround lbi mempty {
- ghcOptLinkOptions = ["-Wl,--no-as-needed"]
- , ghcOptLinkLibs = ["ffi"]
- }
+ commonOpts
+ `mappend` linkerOpts
+ `mappend` dynLinkerOpts
+ `mappend` mempty
+ { ghcOptLinkNoHsMain = toFlag True
+ , ghcOptShared = toFlag True
+ , ghcOptLinkLibs = rtsOptLinkLibs
+ , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo
+ , ghcOptFPic = toFlag True
+ , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm
+ }
+ -- See Note [RPATH]
+ `mappend` ifNeedsRPathWorkaround
+ lbi
+ mempty
+ { ghcOptLinkOptions = ["-Wl,--no-as-needed"]
+ , ghcOptLinkLibs = ["ffi"]
+ }
ForeignLibNativeStatic ->
-- this should be caught by buildFLib
-- (and if we do implement this, we probably don't even want to call
@@ -1339,7 +1588,7 @@ gbuild verbosity numJobs pkg_descr lbi bm clbi = do
-- @flibBuildName@.
info verbosity "Linking..."
let buildName = flibBuildName lbi flib
- runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> buildName) }
+ runGhcProg linkOpts{ghcOptOutputFile = toFlag (targetDir </> buildName)}
renameFile (targetDir </> buildName) (targetDir </> targetName)
{-
@@ -1416,32 +1665,32 @@ ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a
ifNeedsRPathWorkaround lbi a =
case hostPlatform lbi of
Platform _ Linux -> a
- _otherwise -> mempty
-
-data DynamicRtsInfo = DynamicRtsInfo {
- dynRtsVanillaLib :: FilePath
- , dynRtsThreadedLib :: FilePath
- , dynRtsDebugLib :: FilePath
- , dynRtsEventlogLib :: FilePath
- , dynRtsThreadedDebugLib :: FilePath
+ _otherwise -> mempty
+
+data DynamicRtsInfo = DynamicRtsInfo
+ { dynRtsVanillaLib :: FilePath
+ , dynRtsThreadedLib :: FilePath
+ , dynRtsDebugLib :: FilePath
+ , dynRtsEventlogLib :: FilePath
+ , dynRtsThreadedDebugLib :: FilePath
, dynRtsThreadedEventlogLib :: FilePath
}
-data StaticRtsInfo = StaticRtsInfo {
- statRtsVanillaLib :: FilePath
- , statRtsThreadedLib :: FilePath
- , statRtsDebugLib :: FilePath
- , statRtsEventlogLib :: FilePath
- , statRtsThreadedDebugLib :: FilePath
- , statRtsThreadedEventlogLib :: FilePath
- , statRtsProfilingLib :: FilePath
+data StaticRtsInfo = StaticRtsInfo
+ { statRtsVanillaLib :: FilePath
+ , statRtsThreadedLib :: FilePath
+ , statRtsDebugLib :: FilePath
+ , statRtsEventlogLib :: FilePath
+ , statRtsThreadedDebugLib :: FilePath
+ , statRtsThreadedEventlogLib :: FilePath
+ , statRtsProfilingLib :: FilePath
, statRtsThreadedProfilingLib :: FilePath
}
-data RtsInfo = RtsInfo {
- rtsDynamicInfo :: DynamicRtsInfo
- , rtsStaticInfo :: StaticRtsInfo
- , rtsLibPaths :: [FilePath]
+data RtsInfo = RtsInfo
+ { rtsDynamicInfo :: DynamicRtsInfo
+ , rtsStaticInfo :: StaticRtsInfo
+ , rtsLibPaths :: [FilePath]
}
-- | Extract (and compute) information about the RTS library
@@ -1452,64 +1701,71 @@ data RtsInfo = RtsInfo {
-- doesn't really help.
extractRtsInfo :: LocalBuildInfo -> RtsInfo
extractRtsInfo lbi =
- case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of
- [(_, [rts])] -> aux rts
- _otherwise -> error "No (or multiple) ghc rts package is registered"
+ case PackageIndex.lookupPackageName (installedPkgs lbi) (mkPackageName "rts") of
+ [(_, [rts])] -> aux rts
+ _otherwise -> error "No (or multiple) ghc rts package is registered"
where
aux :: InstalledPackageInfo -> RtsInfo
- aux rts = RtsInfo {
- rtsDynamicInfo = DynamicRtsInfo {
- dynRtsVanillaLib = withGhcVersion "HSrts"
- , dynRtsThreadedLib = withGhcVersion "HSrts_thr"
- , dynRtsDebugLib = withGhcVersion "HSrts_debug"
- , dynRtsEventlogLib = withGhcVersion "HSrts_l"
- , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"
- , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"
- }
- , rtsStaticInfo = StaticRtsInfo {
- statRtsVanillaLib = "HSrts"
- , statRtsThreadedLib = "HSrts_thr"
- , statRtsDebugLib = "HSrts_debug"
- , statRtsEventlogLib = "HSrts_l"
- , statRtsThreadedDebugLib = "HSrts_thr_debug"
- , statRtsThreadedEventlogLib = "HSrts_thr_l"
- , statRtsProfilingLib = "HSrts_p"
- , statRtsThreadedProfilingLib = "HSrts_thr_p"
- }
- , rtsLibPaths = InstalledPackageInfo.libraryDirs rts
- }
+ aux rts =
+ RtsInfo
+ { rtsDynamicInfo =
+ DynamicRtsInfo
+ { dynRtsVanillaLib = withGhcVersion "HSrts"
+ , dynRtsThreadedLib = withGhcVersion "HSrts_thr"
+ , dynRtsDebugLib = withGhcVersion "HSrts_debug"
+ , dynRtsEventlogLib = withGhcVersion "HSrts_l"
+ , dynRtsThreadedDebugLib = withGhcVersion "HSrts_thr_debug"
+ , dynRtsThreadedEventlogLib = withGhcVersion "HSrts_thr_l"
+ }
+ , rtsStaticInfo =
+ StaticRtsInfo
+ { statRtsVanillaLib = "HSrts"
+ , statRtsThreadedLib = "HSrts_thr"
+ , statRtsDebugLib = "HSrts_debug"
+ , statRtsEventlogLib = "HSrts_l"
+ , statRtsThreadedDebugLib = "HSrts_thr_debug"
+ , statRtsThreadedEventlogLib = "HSrts_thr_l"
+ , statRtsProfilingLib = "HSrts_p"
+ , statRtsThreadedProfilingLib = "HSrts_thr_p"
+ }
+ , rtsLibPaths = InstalledPackageInfo.libraryDirs rts
+ }
withGhcVersion = (++ ("-ghc" ++ prettyShow (compilerVersion (compiler lbi))))
-- | Returns True if the modification date of the given source file is newer than
-- the object file we last compiled for it, or if no object file exists yet.
checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
checkNeedsRecompilation filename opts = filename `moreRecentFile` oname
- where oname = getObjectFileName filename opts
+ where
+ oname = getObjectFileName filename opts
-- | Finds the object file name of the given source file
getObjectFileName :: FilePath -> GhcOptions -> FilePath
getObjectFileName filename opts = oname
- where odir = fromFlag (ghcOptObjDir opts)
- oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)
- oname = odir </> replaceExtension filename oext
+ where
+ odir = fromFlag (ghcOptObjDir opts)
+ oext = fromFlagOrDefault "o" (ghcOptObjSuffix opts)
+ oname = odir </> replaceExtension filename oext
-- | Calculate the RPATHs for the component we are building.
--
-- Calculates relative RPATHs when 'relocatable' is set.
-getRPaths :: LocalBuildInfo
- -> ComponentLocalBuildInfo -- ^ Component we are building
- -> IO (NubListR FilePath)
+getRPaths
+ :: LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -- ^ Component we are building
+ -> IO (NubListR FilePath)
getRPaths lbi clbi | supportRPaths hostOS = do
- libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
- let hostPref = case hostOS of
- OSX -> "@loader_path"
- _ -> "$ORIGIN"
- relPath p = if isRelative p then hostPref </> p else p
- rpaths = toNubListR (map relPath libraryPaths)
- return rpaths
+ libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
+ let hostPref = case hostOS of
+ OSX -> "@loader_path"
+ _ -> "$ORIGIN"
+ relPath p = if isRelative p then hostPref </> p else p
+ rpaths = toNubListR (map relPath libraryPaths)
+ return rpaths
where
(Platform _ hostOS) = hostPlatform lbi
- compid = compilerId . compiler $ lbi
+ compid = compilerId . compiler $ lbi
-- The list of RPath-supported operating systems below reflects the
-- platforms on which Cabal's RPATH handling is tested. It does _NOT_
@@ -1518,29 +1774,29 @@ getRPaths lbi clbi | supportRPaths hostOS = do
-- E.g. when this comment was written, the *BSD operating systems were
-- untested with regards to Cabal RPATH handling, and were hence set to
-- 'False', while those operating systems themselves do support RPATH.
- supportRPaths Linux = True
- supportRPaths Windows = False
- supportRPaths OSX = True
- supportRPaths FreeBSD =
+ supportRPaths Linux = True
+ supportRPaths Windows = False
+ supportRPaths OSX = True
+ supportRPaths FreeBSD =
case compid of
- CompilerId GHC ver | ver >= mkVersion [7,10,2] -> True
- _ -> False
- supportRPaths OpenBSD = False
- supportRPaths NetBSD = False
- supportRPaths DragonFly = False
- supportRPaths Solaris = False
- supportRPaths AIX = False
- supportRPaths HPUX = False
- supportRPaths IRIX = False
- supportRPaths HaLVM = False
- supportRPaths IOS = False
- supportRPaths Android = False
- supportRPaths Ghcjs = False
- supportRPaths Wasi = False
- supportRPaths Hurd = False
+ CompilerId GHC ver | ver >= mkVersion [7, 10, 2] -> True
+ _ -> False
+ supportRPaths OpenBSD = False
+ supportRPaths NetBSD = False
+ supportRPaths DragonFly = False
+ supportRPaths Solaris = False
+ supportRPaths AIX = False
+ supportRPaths HPUX = False
+ supportRPaths IRIX = False
+ supportRPaths HaLVM = False
+ supportRPaths IOS = False
+ supportRPaths Android = False
+ supportRPaths Ghcjs = False
+ supportRPaths Wasi = False
+ supportRPaths Hurd = False
supportRPaths (OtherOS _) = False
- -- Do _not_ add a default case so that we get a warning here when a new OS
- -- is added.
+-- Do _not_ add a default case so that we get a warning here when a new OS
+-- is added.
getRPaths _ _ = return mempty
@@ -1550,154 +1806,193 @@ getRPaths _ _ = return mempty
-- the appropriate RTS on our own.
popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)
popThreadedFlag bi =
- ( bi { options = filterHcOptions (/= "-threaded") (options bi) }
- , hasThreaded (options bi))
-
+ ( bi{options = filterHcOptions (/= "-threaded") (options bi)}
+ , hasThreaded (options bi)
+ )
where
- filterHcOptions :: (String -> Bool)
- -> PerCompilerFlavor [String]
- -> PerCompilerFlavor [String]
+ filterHcOptions
+ :: (String -> Bool)
+ -> PerCompilerFlavor [String]
+ -> PerCompilerFlavor [String]
filterHcOptions p (PerCompilerFlavor ghc ghcjs) =
- PerCompilerFlavor (filter p ghc) ghcjs
+ PerCompilerFlavor (filter p ghc) ghcjs
hasThreaded :: PerCompilerFlavor [String] -> Bool
hasThreaded (PerCompilerFlavor ghc _) = elem "-threaded" ghc
-- | Extracts a String representing a hash of the ABI of a built
-- library. It can fail if the library has not yet been built.
---
-libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO String
+libAbiHash
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO String
libAbiHash verbosity _pkg_descr lbi lib clbi = do
let
- libBi = libBuildInfo lib
- comp = compiler lbi
- platform = hostPlatform lbi
- vanillaArgs0 =
- (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))
- `mappend` mempty {
- ghcOptMode = toFlag GhcModeAbiHash,
- ghcOptInputModules = toNubListR $ exposedModules lib
+ libBi = libBuildInfo lib
+ comp = compiler lbi
+ platform = hostPlatform lbi
+ vanillaArgs0 =
+ (componentGhcOptions verbosity lbi libBi clbi (componentBuildDir lbi clbi))
+ `mappend` mempty
+ { ghcOptMode = toFlag GhcModeAbiHash
+ , ghcOptInputModules = toNubListR $ exposedModules lib
+ }
+ vanillaArgs =
+ -- Package DBs unnecessary, and break ghc-cabal. See #3633
+ -- BUT, put at least the global database so that 7.4 doesn't
+ -- break.
+ vanillaArgs0
+ { ghcOptPackageDBs = [GlobalPackageDB]
+ , ghcOptPackages = mempty
}
- vanillaArgs =
- -- Package DBs unnecessary, and break ghc-cabal. See #3633
- -- BUT, put at least the global database so that 7.4 doesn't
- -- break.
- vanillaArgs0 { ghcOptPackageDBs = [GlobalPackageDB]
- , ghcOptPackages = mempty }
- sharedArgs = vanillaArgs `mappend` mempty {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "js_dyn_hi",
- ghcOptObjSuffix = toFlag "js_dyn_o",
- ghcOptExtra = hcSharedOptions GHC libBi
- }
- profArgs = vanillaArgs `mappend` mempty {
- ghcOptProfilingMode = toFlag True,
- ghcOptProfilingAuto = Internal.profDetailLevelFlag True
- (withProfLibDetail lbi),
- ghcOptHiSuffix = toFlag "js_p_hi",
- ghcOptObjSuffix = toFlag "js_p_o",
- ghcOptExtra = hcProfOptions GHC libBi
- }
- ghcArgs
- | withVanillaLib lbi = vanillaArgs
- | withSharedLib lbi = sharedArgs
- | withProfLib lbi = profArgs
- | otherwise = error "libAbiHash: Can't find an enabled library way"
+ sharedArgs =
+ vanillaArgs
+ `mappend` mempty
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptFPic = toFlag True
+ , ghcOptHiSuffix = toFlag "js_dyn_hi"
+ , ghcOptObjSuffix = toFlag "js_dyn_o"
+ , ghcOptExtra = hcSharedOptions GHC libBi
+ }
+ profArgs =
+ vanillaArgs
+ `mappend` mempty
+ { ghcOptProfilingMode = toFlag True
+ , ghcOptProfilingAuto =
+ Internal.profDetailLevelFlag
+ True
+ (withProfLibDetail lbi)
+ , ghcOptHiSuffix = toFlag "js_p_hi"
+ , ghcOptObjSuffix = toFlag "js_p_o"
+ , ghcOptExtra = hcProfOptions GHC libBi
+ }
+ ghcArgs
+ | withVanillaLib lbi = vanillaArgs
+ | withSharedLib lbi = sharedArgs
+ | withProfLib lbi = profArgs
+ | otherwise = error "libAbiHash: Can't find an enabled library way"
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
- hash <- getProgramInvocationOutput verbosity
- (ghcInvocation ghcjsProg comp platform ghcArgs)
+ hash <-
+ getProgramInvocationOutput
+ verbosity
+ (ghcInvocation ghcjsProg comp platform ghcArgs)
return (takeWhile (not . isSpace) hash)
-componentGhcOptions :: Verbosity -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
- -> GhcOptions
+componentGhcOptions
+ :: Verbosity
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir
comp = compiler lbi
implInfo = getImplInfo comp
- in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi
- }
-
+ in opts
+ { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi
+ }
-componentCcGhcOptions :: Verbosity -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> FilePath
- -> GhcOptions
+componentCcGhcOptions
+ :: Verbosity
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> GhcOptions
componentCcGhcOptions verbosity lbi =
- Internal.componentCcGhcOptions verbosity implInfo lbi
+ Internal.componentCcGhcOptions verbosity implInfo lbi
where
- comp = compiler lbi
+ comp = compiler lbi
implInfo = getImplInfo comp
-
-- -----------------------------------------------------------------------------
-- Installing
--- |Install executables for GHCJS.
-installExe :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^Where to copy the files to
- -> FilePath -- ^Build location
- -> (FilePath, FilePath) -- ^Executable (prefix,suffix)
- -> PackageDescription
- -> Executable
- -> IO ()
-installExe verbosity lbi binDir buildPref
- (progprefix, progsuffix) _pkg exe = do
- createDirectoryIfMissingVerbose verbosity True binDir
- let exeName' = unUnqualComponentName $ exeName exe
- exeFileName = exeName'
- fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
- installBinary dest = do
- runDbProgram verbosity ghcjsProgram (withPrograms lbi) $
- [ "--install-executable"
- , buildPref </> exeName' </> exeFileName
- , "-o", dest
- ] ++
- case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of
- (True, Just strip) -> ["-strip-program", programPath strip]
- _ -> []
- installBinary (binDir </> fixedExeBaseName)
-
-
--- |Install foreign library for GHC.
-installFLib :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^install location
- -> FilePath -- ^Build location
- -> PackageDescription
- -> ForeignLib
- -> IO ()
+-- | Install executables for GHCJS.
+installExe
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ Where to copy the files to
+ -> FilePath
+ -- ^ Build location
+ -> (FilePath, FilePath)
+ -- ^ Executable (prefix,suffix)
+ -> PackageDescription
+ -> Executable
+ -> IO ()
+installExe
+ verbosity
+ lbi
+ binDir
+ buildPref
+ (progprefix, progsuffix)
+ _pkg
+ exe = do
+ createDirectoryIfMissingVerbose verbosity True binDir
+ let exeName' = unUnqualComponentName $ exeName exe
+ exeFileName = exeName'
+ fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
+ installBinary dest = do
+ runDbProgram verbosity ghcjsProgram (withPrograms lbi) $
+ [ "--install-executable"
+ , buildPref </> exeName' </> exeFileName
+ , "-o"
+ , dest
+ ]
+ ++ case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of
+ (True, Just strip) -> ["-strip-program", programPath strip]
+ _ -> []
+ installBinary (binDir </> fixedExeBaseName)
+
+-- | Install foreign library for GHC.
+installFLib
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ install location
+ -> FilePath
+ -- ^ Build location
+ -> PackageDescription
+ -> ForeignLib
+ -> IO ()
installFLib verbosity lbi targetDir builtDir _pkg flib =
- install (foreignLibIsShared flib)
- builtDir
- targetDir
- (flibTargetName lbi flib)
+ install
+ (foreignLibIsShared flib)
+ builtDir
+ targetDir
+ (flibTargetName lbi flib)
where
install _isShared srcDir dstDir name = do
let src = srcDir </> name
dst = dstDir </> name
createDirectoryIfMissingVerbose verbosity True targetDir
- installOrdinaryFile verbosity src dst
-
-
--- |Install for ghc, .hi, .a and, if --with-ghci given, .o
-installLib :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^install location
- -> FilePath -- ^install location for dynamic libraries
- -> FilePath -- ^Build location
- -> PackageDescription
- -> Library
- -> ComponentLocalBuildInfo
- -> IO ()
+ installOrdinaryFile verbosity src dst
+
+-- | Install for ghc, .hi, .a and, if --with-ghci given, .o
+installLib
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ install location
+ -> FilePath
+ -- ^ install location for dynamic libraries
+ -> FilePath
+ -- ^ Build location
+ -> PackageDescription
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do
whenVanilla $ copyModuleFiles "js_hi"
- whenProf $ copyModuleFiles "js_p_hi"
- whenShared $ copyModuleFiles "js_dyn_hi"
+ whenProf $ copyModuleFiles "js_p_hi"
+ whenShared $ copyModuleFiles "js_dyn_hi"
-- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName
-- whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName
@@ -1705,20 +2000,24 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do
-- fixme do these make the correct lib names?
whenHasCode $ do
whenVanilla $ do
- sequence_ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f))
- | l <- getHSLibraryName (componentUnitId clbi):(extraBundledLibs (libBuildInfo lib))
- , f <- "":extraLibFlavours (libBuildInfo lib)
- ]
- -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)
+ sequence_
+ [ installOrdinary builtDir' targetDir (toJSLibName $ mkGenericStaticLibName (l ++ f))
+ | l <- getHSLibraryName (componentUnitId clbi) : (extraBundledLibs (libBuildInfo lib))
+ , f <- "" : extraLibFlavours (libBuildInfo lib)
+ ]
+ -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)
whenProf $ do
installOrdinary builtDir' targetDir (toJSLibName profileLibName)
- -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName)
- whenShared $
- sequence_ [ installShared builtDir' dynlibTargetDir
- (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f))
- | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
- , f <- "":extraDynLibFlavours (libBuildInfo lib)
- ]
+ -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName)
+ whenShared $
+ sequence_
+ [ installShared
+ builtDir'
+ dynlibTargetDir
+ (toJSLibName $ mkGenericSharedLibName platform compiler_id (l ++ f))
+ | l <- getHSLibraryName uid : extraBundledLibs (libBuildInfo lib)
+ , f <- "" : extraDynLibFlavours (libBuildInfo lib)
+ ]
where
builtDir' = componentBuildDir lbi clbi
@@ -1729,44 +2028,49 @@ installLib verbosity lbi targetDir dynlibTargetDir _builtDir _pkg lib clbi = do
if isShared
then installExecutableFile verbosity src dst
- else installOrdinaryFile verbosity src dst
+ else installOrdinaryFile verbosity src dst
when (stripLibs lbi && not isJS) $
- Strip.stripLib verbosity
- (hostPlatform lbi) (withPrograms lbi) dst
+ Strip.stripLib
+ verbosity
+ (hostPlatform lbi)
+ (withPrograms lbi)
+ dst
installOrdinary = install False True
- installShared = install True True
+ installShared = install True True
copyModuleFiles ext =
findModuleFilesEx verbosity [builtDir'] [ext] (allLibModules lib clbi)
- >>= installOrdinaryFiles verbosity targetDir
+ >>= installOrdinaryFiles verbosity targetDir
compiler_id = compilerId (compiler lbi)
platform = hostPlatform lbi
uid = componentUnitId clbi
-- vanillaLibName = mkLibName uid
- profileLibName = mkProfLibName uid
+ profileLibName = mkProfLibName uid
-- sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid
- hasLib = not $ null (allLibModules lib clbi)
- && null (cSources (libBuildInfo lib))
- && null (cxxSources (libBuildInfo lib))
- && null (jsSources (libBuildInfo lib))
+ hasLib =
+ not $
+ null (allLibModules lib clbi)
+ && null (cSources (libBuildInfo lib))
+ && null (cxxSources (libBuildInfo lib))
+ && null (jsSources (libBuildInfo lib))
has_code = not (componentIsIndefinite clbi)
whenHasCode = when has_code
whenVanilla = when (hasLib && withVanillaLib lbi)
- whenProf = when (hasLib && withProfLib lbi && has_code)
+ whenProf = when (hasLib && withProfLib lbi && has_code)
-- whenGHCi = when (hasLib && withGHCiLib lbi && has_code)
- whenShared = when (hasLib && withSharedLib lbi && has_code)
-
+ whenShared = when (hasLib && withSharedLib lbi && has_code)
adjustExts :: String -> String -> GhcOptions -> GhcOptions
adjustExts hiSuf objSuf opts =
- opts `mappend` mempty {
- ghcOptHiSuffix = toFlag hiSuf,
- ghcOptObjSuffix = toFlag objSuf
- }
+ opts
+ `mappend` mempty
+ { ghcOptHiSuffix = toFlag hiSuf
+ , ghcOptObjSuffix = toFlag objSuf
+ }
isDynamic :: Compiler -> Bool
isDynamic = Internal.ghcLookupProperty "GHC Dynamic"
@@ -1775,7 +2079,7 @@ supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
withExt :: FilePath -> String -> FilePath
-withExt fp ext = fp <.> if takeExtension fp /= ('.':ext) then ext else ""
+withExt fp ext = fp <.> if takeExtension fp /= ('.' : ext) then ext else ""
findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsGhcVersion verbosity pgm =
@@ -1789,20 +2093,22 @@ findGhcjsPkgGhcjsVersion verbosity pgm =
-- Registering
hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
-hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg
- , HcPkg.noPkgDbStack = False
- , HcPkg.noVerboseFlag = False
- , HcPkg.flagPackageConf = False
- , HcPkg.supportsDirDbs = True
- , HcPkg.requiresDirDbs = ver >= v7_10
- , HcPkg.nativeMultiInstance = ver >= v7_10
- , HcPkg.recacheMultiInstance = True
- , HcPkg.suppressFilesCheck = True
- }
+hcPkgInfo progdb =
+ HcPkg.HcPkgInfo
+ { HcPkg.hcPkgProgram = ghcjsPkgProg
+ , HcPkg.noPkgDbStack = False
+ , HcPkg.noVerboseFlag = False
+ , HcPkg.flagPackageConf = False
+ , HcPkg.supportsDirDbs = True
+ , HcPkg.requiresDirDbs = ver >= v7_10
+ , HcPkg.nativeMultiInstance = ver >= v7_10
+ , HcPkg.recacheMultiInstance = True
+ , HcPkg.suppressFilesCheck = True
+ }
where
- v7_10 = mkVersion [7,10]
+ v7_10 = mkVersion [7, 10]
ghcjsPkgProg = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs program") $ lookupProgram ghcjsPkgProgram progdb
- ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg
+ ver = fromMaybe (error "GHCJS.hcPkgInfo no ghcjs version") $ programVersion ghcjsPkgProg
registerPackage
:: Verbosity
@@ -1812,22 +2118,30 @@ registerPackage
-> HcPkg.RegisterOptions
-> IO ()
registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
- HcPkg.register (hcPkgInfo progdb) verbosity packageDbs
- installedPkgInfo registerOptions
+ HcPkg.register
+ (hcPkgInfo progdb)
+ verbosity
+ packageDbs
+ installedPkgInfo
+ registerOptions
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot verbosity lbi = pkgRoot'
- where
+ where
pkgRoot' GlobalPackageDB =
let ghcjsProg = fromMaybe (error "GHCJS.pkgRoot: no ghcjs program") $ lookupProgram ghcjsProgram (withPrograms lbi)
- in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)
+ in fmap takeDirectory (getGlobalPackageDB verbosity ghcjsProg)
pkgRoot' UserPackageDB = do
appDir <- getAppUserDataDirectory "ghcjs"
-- fixme correct this version
- let ver = compilerVersion (compiler lbi)
- subdir = System.Info.arch ++ '-':System.Info.os
- ++ '-':prettyShow ver
- rootDir = appDir </> subdir
+ let ver = compilerVersion (compiler lbi)
+ subdir =
+ System.Info.arch
+ ++ '-'
+ : System.Info.os
+ ++ '-'
+ : prettyShow ver
+ rootDir = appDir </> subdir
-- We must create the root directory for the user package database if it
-- does not yet exists. Otherwise '${pkgroot}' will resolve to a
-- directory at the time of 'ghc-pkg register', and registration will
@@ -1836,12 +2150,13 @@ pkgRoot verbosity lbi = pkgRoot'
return rootDir
pkgRoot' (SpecificPackageDB fp) = return (takeDirectory fp)
-
-- | Get the JavaScript file name and command and arguments to run a
-- program compiled by GHCJS
-- the exe should be the base program name without exe extension
-runCmd :: ProgramDb -> FilePath
- -> (FilePath, FilePath, [String])
+runCmd
+ :: ProgramDb
+ -> FilePath
+ -> (FilePath, FilePath, [String])
runCmd progdb exe =
( script
, programPath ghcjsProg
diff --git a/Cabal/src/Distribution/Simple/Glob.hs b/Cabal/src/Distribution/Simple/Glob.hs
index 2586ddd68e024189e8bf755557e3a9267201b31e..81c196cb9cbb44aa850a25b909e847ce6389a373 100644
--- a/Cabal/src/Distribution/Simple/Glob.hs
+++ b/Cabal/src/Distribution/Simple/Glob.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Glob
-- Copyright : Isaac Jones, Simon Marlow 2003-2004
@@ -13,29 +14,28 @@
-- Portability : portable
--
-- Simple file globbing.
-
-module Distribution.Simple.Glob (
- GlobSyntaxError(..),
- GlobResult(..),
- matchDirFileGlob,
- matchDirFileGlobWithDie,
- runDirFileGlob,
- fileGlobMatches,
- parseFileGlob,
- explainGlobSyntaxError,
- isRecursiveInRoot,
- Glob,
+module Distribution.Simple.Glob
+ ( GlobSyntaxError (..)
+ , GlobResult (..)
+ , matchDirFileGlob
+ , matchDirFileGlobWithDie
+ , runDirFileGlob
+ , fileGlobMatches
+ , parseFileGlob
+ , explainGlobSyntaxError
+ , isRecursiveInRoot
+ , Glob
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.CabalSpecVersion
import Distribution.Simple.Utils
import Distribution.Verbosity
-import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)
-import System.FilePath (joinPath, splitExtensions, splitDirectories, takeFileName, (</>), (<.>))
+import System.Directory (doesDirectoryExist, doesFileExist, getDirectoryContents)
+import System.FilePath (joinPath, splitDirectories, splitExtensions, takeFileName, (<.>), (</>))
import qualified Data.List.NonEmpty as NE
@@ -45,19 +45,19 @@ import qualified Data.List.NonEmpty as NE
-- separators from the glob we might not end up properly normalised.
data GlobResult a
- = GlobMatch a
- -- ^ The glob matched the value supplied.
- | GlobWarnMultiDot a
- -- ^ The glob did not match the value supplied because the
+ = -- | The glob matched the value supplied.
+ GlobMatch a
+ | -- | The glob did not match the value supplied because the
-- cabal-version is too low and the extensions on the file did
-- not precisely match the glob's extensions, but rather the
-- glob was a proper suffix of the file's extensions; i.e., if
-- not for the low cabal-version, it would have matched.
- | GlobMissingDirectory FilePath
- -- ^ The glob couldn't match because the directory named doesn't
+ GlobWarnMultiDot a
+ | -- | The glob couldn't match because the directory named doesn't
-- exist. The directory will be as it appears in the glob (i.e.,
-- relative to the directory passed to 'matchDirFileGlob', and,
-- for 'data-files', relative to 'data-dir').
+ GlobMissingDirectory FilePath
deriving (Show, Eq, Ord, Functor)
-- | Extract the matches from a list of 'GlobResult's.
@@ -65,7 +65,7 @@ data GlobResult a
-- Note: throws away the 'GlobMissingDirectory' results; chances are
-- that you want to check for these and error out if any are present.
globMatches :: [GlobResult a] -> [a]
-globMatches input = [ a | GlobMatch a <- input ]
+globMatches input = [a | GlobMatch a <- input]
data GlobSyntaxError
= StarInDirectory
@@ -80,55 +80,62 @@ data GlobSyntaxError
explainGlobSyntaxError :: FilePath -> GlobSyntaxError -> String
explainGlobSyntaxError filepath StarInDirectory =
- "invalid file glob '" ++ filepath
- ++ "'. A wildcard '**' is only allowed as the final parent"
- ++ " directory. Stars must not otherwise appear in the parent"
- ++ " directories."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. A wildcard '**' is only allowed as the final parent"
+ ++ " directory. Stars must not otherwise appear in the parent"
+ ++ " directories."
explainGlobSyntaxError filepath StarInExtension =
- "invalid file glob '" ++ filepath
- ++ "'. Wildcards '*' are only allowed as the"
- ++ " file's base name, not in the file extension."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Wildcards '*' are only allowed as the"
+ ++ " file's base name, not in the file extension."
explainGlobSyntaxError filepath StarInFileName =
- "invalid file glob '" ++ filepath
- ++ "'. Wildcards '*' may only totally replace the"
- ++ " file's base name, not only parts of it."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Wildcards '*' may only totally replace the"
+ ++ " file's base name, not only parts of it."
explainGlobSyntaxError filepath NoExtensionOnStar =
- "invalid file glob '" ++ filepath
- ++ "'. If a wildcard '*' is used it must be with an file extension."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. If a wildcard '*' is used it must be with an file extension."
explainGlobSyntaxError filepath LiteralFileNameGlobStar =
- "invalid file glob '" ++ filepath
- ++ "'. Prior to 'cabal-version: 3.8'"
- ++ " if a wildcard '**' is used as a parent directory, the"
- ++ " file's base name must be a wildcard '*'."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Prior to 'cabal-version: 3.8'"
+ ++ " if a wildcard '**' is used as a parent directory, the"
+ ++ " file's base name must be a wildcard '*'."
explainGlobSyntaxError _ EmptyGlob =
- "invalid file glob. A glob cannot be the empty string."
+ "invalid file glob. A glob cannot be the empty string."
explainGlobSyntaxError filepath VersionDoesNotSupportGlobStar =
- "invalid file glob '" ++ filepath
- ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
- ++ " or greater. Alternatively, for compatibility with earlier Cabal"
- ++ " versions, list the included directories explicitly."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Using the double-star syntax requires 'cabal-version: 2.4'"
+ ++ " or greater. Alternatively, for compatibility with earlier Cabal"
+ ++ " versions, list the included directories explicitly."
explainGlobSyntaxError filepath VersionDoesNotSupportGlob =
- "invalid file glob '" ++ filepath
- ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
- ++ "Alternatively if you require compatibility with earlier Cabal "
- ++ "versions then list all the files explicitly."
+ "invalid file glob '"
+ ++ filepath
+ ++ "'. Using star wildcards requires 'cabal-version: >= 1.6'. "
+ ++ "Alternatively if you require compatibility with earlier Cabal "
+ ++ "versions then list all the files explicitly."
-data IsRecursive = Recursive | NonRecursive deriving Eq
+data IsRecursive = Recursive | NonRecursive deriving (Eq)
data MultiDot = MultiDotDisabled | MultiDotEnabled
data Glob
- = GlobStem FilePath Glob
- -- ^ A single subdirectory component + remainder.
+ = -- | A single subdirectory component + remainder.
+ GlobStem FilePath Glob
| GlobFinal GlobFinal
data GlobFinal
- = FinalMatch IsRecursive MultiDot String
- -- ^ First argument: Is this a @**/*.ext@ pattern?
+ = -- | First argument: Is this a @**/*.ext@ pattern?
-- Second argument: should we match against the exact extensions, or accept a suffix?
-- Third argument: the extensions to accept.
- | FinalLit IsRecursive FilePath
- -- ^ Literal file name.
+ FinalMatch IsRecursive MultiDot String
+ | -- | Literal file name.
+ FinalLit IsRecursive FilePath
reconstructGlob :: Glob -> FilePath
reconstructGlob (GlobStem dir glob) =
@@ -155,7 +162,7 @@ fileGlobMatchesSegments pat (seg : segs) = case pat of
fileGlobMatchesSegments pat' segs
GlobFinal final -> case final of
FinalMatch Recursive multidot ext -> do
- let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg:|segs)
+ let (candidateBase, candidateExts) = splitExtensions (NE.last $ seg :| segs)
guard (not (null candidateBase))
checkExt multidot ext candidateExts
FinalMatch NonRecursive multidot ext -> do
@@ -168,8 +175,10 @@ fileGlobMatchesSegments pat (seg : segs) = case pat of
checkExt
:: MultiDot
- -> String -- ^ The pattern's extension
- -> String -- ^ The candidate file's extension
+ -> String
+ -- ^ The pattern's extension
+ -> String
+ -- ^ The candidate file's extension
-> Maybe (GlobResult ())
checkExt multidot ext candidate
| ext == candidate = Just (GlobMatch ())
@@ -181,37 +190,41 @@ checkExt multidot ext candidate
parseFileGlob :: CabalSpecVersion -> FilePath -> Either GlobSyntaxError Glob
parseFileGlob version filepath = case reverse (splitDirectories filepath) of
[] ->
- Left EmptyGlob
+ Left EmptyGlob
(filename : "**" : segments)
| allowGlobStar -> do
finalSegment <- case splitExtensions filename of
- ("*", ext) | '*' `elem` ext -> Left StarInExtension
- | null ext -> Left NoExtensionOnStar
- | otherwise -> Right (FinalMatch Recursive multidot ext)
- _ -> if allowLiteralFilenameGlobStar
- then Right (FinalLit Recursive filename)
- else Left LiteralFileNameGlobStar
+ ("*", ext)
+ | '*' `elem` ext -> Left StarInExtension
+ | null ext -> Left NoExtensionOnStar
+ | otherwise -> Right (FinalMatch Recursive multidot ext)
+ _ ->
+ if allowLiteralFilenameGlobStar
+ then Right (FinalLit Recursive filename)
+ else Left LiteralFileNameGlobStar
foldM addStem (GlobFinal finalSegment) segments
| otherwise -> Left VersionDoesNotSupportGlobStar
(filename : segments) -> do
- pat <- case splitExtensions filename of
- ("*", ext) | not allowGlob -> Left VersionDoesNotSupportGlob
- | '*' `elem` ext -> Left StarInExtension
- | null ext -> Left NoExtensionOnStar
- | otherwise -> Right (FinalMatch NonRecursive multidot ext)
- (_, ext) | '*' `elem` ext -> Left StarInExtension
- | '*' `elem` filename -> Left StarInFileName
- | otherwise -> Right (FinalLit NonRecursive filename)
- foldM addStem (GlobFinal pat) segments
+ pat <- case splitExtensions filename of
+ ("*", ext)
+ | not allowGlob -> Left VersionDoesNotSupportGlob
+ | '*' `elem` ext -> Left StarInExtension
+ | null ext -> Left NoExtensionOnStar
+ | otherwise -> Right (FinalMatch NonRecursive multidot ext)
+ (_, ext)
+ | '*' `elem` ext -> Left StarInExtension
+ | '*' `elem` filename -> Left StarInFileName
+ | otherwise -> Right (FinalLit NonRecursive filename)
+ foldM addStem (GlobFinal pat) segments
where
- allowGlob = version >= CabalSpecV1_6
+ allowGlob = version >= CabalSpecV1_6
allowGlobStar = version >= CabalSpecV2_4
addStem pat seg
| '*' `elem` seg = Left StarInDirectory
- | otherwise = Right (GlobStem seg pat)
+ | otherwise = Right (GlobStem seg pat)
multidot
| version >= CabalSpecV2_4 = MultiDotEnabled
- | otherwise = MultiDotDisabled
+ | otherwise = MultiDotDisabled
allowLiteralFilenameGlobStar = version >= CabalSpecV3_8
-- | This will 'die'' when the glob matches no files, or if the glob
@@ -227,37 +240,38 @@ parseFileGlob version filepath = case reverse (splitDirectories filepath) of
-- prefix.
--
-- The second 'FilePath' is the glob itself.
---
matchDirFileGlob :: Verbosity -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlob v = matchDirFileGlobWithDie v die'
-- | Like 'matchDirFileGlob' but with customizable 'die'
--
-- @since 3.6.0.0
---
matchDirFileGlobWithDie :: Verbosity -> (Verbosity -> String -> IO [FilePath]) -> CabalSpecVersion -> FilePath -> FilePath -> IO [FilePath]
matchDirFileGlobWithDie verbosity rip version dir filepath = case parseFileGlob version filepath of
Left err -> rip verbosity $ explainGlobSyntaxError filepath err
Right glob -> do
results <- runDirFileGlob verbosity dir glob
let missingDirectories =
- [ missingDir | GlobMissingDirectory missingDir <- results ]
+ [missingDir | GlobMissingDirectory missingDir <- results]
matches = globMatches results
let errors :: [String]
errors =
- [ "filepath wildcard '" ++ filepath ++ "' refers to the directory"
- ++ " '" ++ missingDir ++ "', which does not exist or is not a directory."
- | missingDir <- missingDirectories
- ]
- ++
- [ "filepath wildcard '" ++ filepath ++ "' does not match any files."
- | null matches
- ]
+ [ "filepath wildcard '"
+ ++ filepath
+ ++ "' refers to the directory"
+ ++ " '"
+ ++ missingDir
+ ++ "', which does not exist or is not a directory."
+ | missingDir <- missingDirectories
+ ]
+ ++ [ "filepath wildcard '" ++ filepath ++ "' does not match any files."
+ | null matches
+ ]
if null errors
- then return matches
- else rip verbosity $ unlines errors
+ then return matches
+ else rip verbosity $ unlines errors
-- | Match files against a pre-parsed glob, starting in a directory.
--
@@ -276,8 +290,8 @@ runDirFileGlob verbosity rawDir pat = do
-- hard-to-debug failure if we don't check for that here.
when (null rawDir) $
warn verbosity $
- "Null dir passed to runDirFileGlob; interpreting it "
- ++ "as '.'. This is probably an internal error."
+ "Null dir passed to runDirFileGlob; interpreting it "
+ ++ "as '.'. This is probably an internal error."
let dir = if null rawDir then "." else rawDir
debug verbosity $ "Expanding glob '" ++ reconstructGlob pat ++ "' in directory '" ++ dir ++ "'."
-- This function might be called from the project root with dir as
@@ -304,8 +318,7 @@ runDirFileGlob verbosity rawDir pat = do
match <- checkExt multidot exts candidateExts
return (joinedPrefix </> candidate <$ match)
return $ mapMaybe checkName candidates
- else
- return [ GlobMissingDirectory joinedPrefix ]
+ else return [GlobMissingDirectory joinedPrefix]
FinalLit Recursive fn -> do
let prefix = dir </> joinedPrefix
directoryExists <- doesDirectoryExist prefix
@@ -313,15 +326,13 @@ runDirFileGlob verbosity rawDir pat = do
then do
candidates <- getDirectoryContentsRecursive prefix
let checkName candidate
- | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix </> candidate)
- | otherwise = Nothing
+ | takeFileName candidate == fn = Just $ GlobMatch (joinedPrefix </> candidate)
+ | otherwise = Nothing
return $ mapMaybe checkName candidates
- else
- return [ GlobMissingDirectory joinedPrefix ]
-
+ else return [GlobMissingDirectory joinedPrefix]
FinalLit NonRecursive fn -> do
exists <- doesFileExist (dir </> joinedPrefix </> fn)
- return [ GlobMatch (joinedPrefix </> fn) | exists ]
+ return [GlobMatch (joinedPrefix </> fn) | exists]
unfoldr' :: (a -> Either r (b, a)) -> a -> ([b], r)
unfoldr' f a = case f a of
@@ -338,7 +349,6 @@ splitConstantPrefix = unfoldr' step
step (GlobStem seg pat) = Right (seg, pat)
step (GlobFinal pat) = Left pat
-
isRecursiveInRoot :: Glob -> Bool
-isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True
+isRecursiveInRoot (GlobFinal (FinalMatch Recursive _ _)) = True
isRecursiveInRoot _ = False
diff --git a/Cabal/src/Distribution/Simple/Haddock.hs b/Cabal/src/Distribution/Simple/Haddock.hs
index 215cf92f4d45b24ba396f8b0e10645816d2e316a..6b54de6b6c9bb6f6a338a5d58a90cabecfa99810 100644
--- a/Cabal/src/Distribution/Simple/Haddock.hs
+++ b/Cabal/src/Distribution/Simple/Haddock.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Haddock
-- Copyright : Isaac Jones 2003-2005
@@ -18,59 +19,57 @@
--
-- The @hscolour@ support allows generating HTML versions of the original
-- source, with coloured syntax highlighting.
-
-module Distribution.Simple.Haddock (
- haddock, createHaddockIndex, hscolour,
-
- haddockPackagePaths,
- Visibility(..)
+module Distribution.Simple.Haddock
+ ( haddock
+ , createHaddockIndex
+ , hscolour
+ , haddockPackagePaths
+ , Visibility (..)
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
-- local
-import Distribution.Backpack.DescribeUnitId
+
import Distribution.Backpack (OpenModule)
-import Distribution.Types.ForeignLib
-import Distribution.Types.UnqualComponentName
-import Distribution.Types.ComponentLocalBuildInfo
-import Distribution.Types.ExecutableScope
-import Distribution.Types.LocalBuildInfo
-import Distribution.Types.TargetInfo
-import Distribution.Types.ExposedModule
-import Distribution.Package
+import Distribution.Backpack.DescribeUnitId
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.ModuleName as ModuleName
+import Distribution.Package
import Distribution.PackageDescription
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty
+import Distribution.Simple.Build
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
+import Distribution.Simple.Flag
import Distribution.Simple.Glob
+import Distribution.Simple.InstallDirs
+import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.PreProcess
+import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
+import qualified Distribution.Simple.Program.HcPkg as HcPkg
import Distribution.Simple.Program.ResponseFile
-import Distribution.Simple.Program
-import Distribution.Simple.PreProcess
-import Distribution.Simple.Flag
+import Distribution.Simple.Register
import Distribution.Simple.Setup.Haddock
import Distribution.Simple.Setup.Hscolour
-import Distribution.Simple.Build
-import Distribution.Simple.BuildTarget
-import Distribution.Simple.InstallDirs
-import Distribution.Simple.LocalBuildInfo hiding (substPathTemplate)
-import Distribution.Simple.BuildPaths
-import Distribution.Simple.Register
-import qualified Distribution.Simple.Program.HcPkg as HcPkg
-import qualified Distribution.Simple.PackageIndex as PackageIndex
-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
-import Distribution.InstalledPackageInfo ( InstalledPackageInfo )
import Distribution.Simple.Utils
import Distribution.System
-import Distribution.Pretty
-import Distribution.Parsec (simpleParsec)
+import Distribution.Types.ComponentLocalBuildInfo
+import Distribution.Types.ExposedModule
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.TargetInfo
import Distribution.Utils.NubList
-import Distribution.Version
import qualified Distribution.Utils.ShortText as ShortText
+import Distribution.Version
import Distribution.Verbosity
import Language.Haskell.Extension
@@ -78,71 +77,72 @@ import Language.Haskell.Extension
import Distribution.Compat.Semigroup (All (..), Any (..))
import Control.Monad
-import Data.Either ( rights )
+import Data.Either (rights)
-import System.Directory (getCurrentDirectory, doesDirectoryExist, doesFileExist)
-import System.FilePath ( (</>), (<.>), normalise, isAbsolute )
-import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)
+import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory)
+import System.FilePath (isAbsolute, normalise, (<.>), (</>))
+import System.IO (hClose, hPutStrLn, hSetEncoding, utf8)
-- ------------------------------------------------------------------------------
-- Types
-- | A record that represents the arguments to the haddock executable, a product
-- monoid.
-data HaddockArgs = HaddockArgs {
- argInterfaceFile :: Flag FilePath,
- -- ^ Path to the interface file, relative to argOutputDir, required.
- argPackageName :: Flag PackageIdentifier,
- -- ^ Package name, required.
- argHideModules :: (All,[ModuleName.ModuleName]),
- -- ^ (Hide modules ?, modules to hide)
- argIgnoreExports :: Any,
- -- ^ Ignore export lists in modules?
- argLinkSource :: Flag (Template,Template,Template),
- -- ^ (Template for modules, template for symbols, template for lines).
- argLinkedSource :: Flag Bool,
- -- ^ Generate hyperlinked sources
- argQuickJump :: Flag Bool,
- -- ^ Generate quickjump index
- argCssFile :: Flag FilePath,
- -- ^ Optional custom CSS file.
- argContents :: Flag String,
- -- ^ Optional URL to contents page.
- argGenContents :: Flag Bool,
- -- ^ Generate contents
- argIndex :: Flag String,
- -- ^ Optional URL to index page.
- argGenIndex :: Flag Bool,
- -- ^ Generate index
- argBaseUrl :: Flag String,
- -- ^ Optional base url from which static files will be loaded.
- argVerbose :: Any,
- argOutput :: Flag [Output],
- -- ^ HTML or Hoogle doc or both? Required.
- argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)],
- -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)].
- argOutputDir :: Directory,
- -- ^ Where to generate the documentation.
- argTitle :: Flag String,
- -- ^ Page title, required.
- argPrologue :: Flag String,
- -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'.
- argPrologueFile :: Flag FilePath,
- -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'.
- argGhcOptions :: GhcOptions,
- -- ^ Additional flags to pass to GHC.
- argGhcLibDir :: Flag FilePath,
- -- ^ To find the correct GHC, required.
- argReexports :: [OpenModule],
- -- ^ Re-exported modules
- argTargets :: [FilePath],
- -- ^ Modules to process.
- argLib :: Flag String
- -- ^ haddock's static \/ auxiliary files.
-} deriving Generic
+data HaddockArgs = HaddockArgs
+ { argInterfaceFile :: Flag FilePath
+ -- ^ Path to the interface file, relative to argOutputDir, required.
+ , argPackageName :: Flag PackageIdentifier
+ -- ^ Package name, required.
+ , argHideModules :: (All, [ModuleName.ModuleName])
+ -- ^ (Hide modules ?, modules to hide)
+ , argIgnoreExports :: Any
+ -- ^ Ignore export lists in modules?
+ , argLinkSource :: Flag (Template, Template, Template)
+ -- ^ (Template for modules, template for symbols, template for lines).
+ , argLinkedSource :: Flag Bool
+ -- ^ Generate hyperlinked sources
+ , argQuickJump :: Flag Bool
+ -- ^ Generate quickjump index
+ , argCssFile :: Flag FilePath
+ -- ^ Optional custom CSS file.
+ , argContents :: Flag String
+ -- ^ Optional URL to contents page.
+ , argGenContents :: Flag Bool
+ -- ^ Generate contents
+ , argIndex :: Flag String
+ -- ^ Optional URL to index page.
+ , argGenIndex :: Flag Bool
+ -- ^ Generate index
+ , argBaseUrl :: Flag String
+ -- ^ Optional base url from which static files will be loaded.
+ , argVerbose :: Any
+ , argOutput :: Flag [Output]
+ -- ^ HTML or Hoogle doc or both? Required.
+ , argInterfaces :: [(FilePath, Maybe String, Maybe String, Visibility)]
+ -- ^ [(Interface file, URL to the HTML docs and hyperlinked-source for links)].
+ , argOutputDir :: Directory
+ -- ^ Where to generate the documentation.
+ , argTitle :: Flag String
+ -- ^ Page title, required.
+ , argPrologue :: Flag String
+ -- ^ Prologue text, required for 'haddock', ignored by 'haddocks'.
+ , argPrologueFile :: Flag FilePath
+ -- ^ Prologue file name, ignored by 'haddock', optional for 'haddocks'.
+ , argGhcOptions :: GhcOptions
+ -- ^ Additional flags to pass to GHC.
+ , argGhcLibDir :: Flag FilePath
+ -- ^ To find the correct GHC, required.
+ , argReexports :: [OpenModule]
+ -- ^ Re-exported modules
+ , argTargets :: [FilePath]
+ -- ^ Modules to process.
+ , argLib :: Flag String
+ -- ^ haddock's static \/ auxiliary files.
+ }
+ deriving (Generic)
-- | The FilePath of a directory, it's a monoid under '(</>)'.
-newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord)
+newtype Directory = Dir {unDir' :: FilePath} deriving (Read, Show, Eq, Ord)
unDir :: Directory -> FilePath
unDir = normalise . unDir'
@@ -150,530 +150,672 @@ unDir = normalise . unDir'
type Template = String
data Output = Html | Hoogle
- deriving Eq
+ deriving (Eq)
-- ------------------------------------------------------------------------------
-- Haddock support
-- | Get Haddock program and check if it matches the request
-getHaddockProg :: Verbosity
- -> ProgramDb
- -> Compiler
- -> HaddockArgs
- -> Flag Bool -- ^ quickjump feature
- -> IO (ConfiguredProgram, Version)
+getHaddockProg
+ :: Verbosity
+ -> ProgramDb
+ -> Compiler
+ -> HaddockArgs
+ -> Flag Bool
+ -- ^ quickjump feature
+ -> IO (ConfiguredProgram, Version)
getHaddockProg verbosity programDb comp args quickJumpFlag = do
- let HaddockArgs { argQuickJump
- , argOutput
- } = args
- hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput
-
- (haddockProg, version, _) <-
- requireProgramVersion verbosity haddockProgram
- (orLaterVersion (mkVersion [2,0])) programDb
-
- -- various sanity checks
- when (hoogle && version < mkVersion [2,2]) $
- die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag."
-
- when (fromFlag argQuickJump && version < mkVersion [2,19]) $ do
- let msg = "Haddock prior to 2.19 does not support the --quickjump flag."
- alt = "The generated documentation won't have the QuickJump feature."
- if Flag True == quickJumpFlag
- then die' verbosity msg
- else warn verbosity (msg ++ "\n" ++ alt)
-
- haddockGhcVersionStr <- getProgramOutput verbosity haddockProg
- ["--ghc-version"]
- case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of
- (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock"
- (_, Nothing) -> die' verbosity "Could not get GHC version from compiler"
- (Just haddockGhcVersion, Just ghcVersion)
- | haddockGhcVersion == ghcVersion -> return ()
- | otherwise -> die' verbosity $
- "Haddock's internal GHC version must match the configured "
- ++ "GHC version.\n"
- ++ "The GHC version is " ++ prettyShow ghcVersion ++ " but "
- ++ "haddock is using GHC version " ++ prettyShow haddockGhcVersion
-
- return (haddockProg, version)
-
-
-haddock :: PackageDescription
- -> LocalBuildInfo
- -> [PPSuffixHandler]
- -> HaddockFlags
- -> IO ()
+ let HaddockArgs
+ { argQuickJump
+ , argOutput
+ } = args
+ hoogle = Hoogle `elem` fromFlagOrDefault [] argOutput
+
+ (haddockProg, version, _) <-
+ requireProgramVersion
+ verbosity
+ haddockProgram
+ (orLaterVersion (mkVersion [2, 0]))
+ programDb
+
+ -- various sanity checks
+ when (hoogle && version < mkVersion [2, 2]) $
+ die' verbosity "Haddock 2.0 and 2.1 do not support the --hoogle flag."
+
+ when (fromFlag argQuickJump && version < mkVersion [2, 19]) $ do
+ let msg = "Haddock prior to 2.19 does not support the --quickjump flag."
+ alt = "The generated documentation won't have the QuickJump feature."
+ if Flag True == quickJumpFlag
+ then die' verbosity msg
+ else warn verbosity (msg ++ "\n" ++ alt)
+
+ haddockGhcVersionStr <-
+ getProgramOutput
+ verbosity
+ haddockProg
+ ["--ghc-version"]
+ case (simpleParsec haddockGhcVersionStr, compilerCompatVersion GHC comp) of
+ (Nothing, _) -> die' verbosity "Could not get GHC version from Haddock"
+ (_, Nothing) -> die' verbosity "Could not get GHC version from compiler"
+ (Just haddockGhcVersion, Just ghcVersion)
+ | haddockGhcVersion == ghcVersion -> return ()
+ | otherwise ->
+ die' verbosity $
+ "Haddock's internal GHC version must match the configured "
+ ++ "GHC version.\n"
+ ++ "The GHC version is "
+ ++ prettyShow ghcVersion
+ ++ " but "
+ ++ "haddock is using GHC version "
+ ++ prettyShow haddockGhcVersion
+
+ return (haddockProg, version)
+
+haddock
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> HaddockFlags
+ -> IO ()
haddock pkg_descr _ _ haddockFlags
- | not (hasLibs pkg_descr)
- && not (fromFlag $ haddockExecutables haddockFlags)
- && not (fromFlag $ haddockTestSuites haddockFlags)
- && not (fromFlag $ haddockBenchmarks haddockFlags)
- && not (fromFlag $ haddockForeignLibs haddockFlags)
- =
+ | not (hasLibs pkg_descr)
+ && not (fromFlag $ haddockExecutables haddockFlags)
+ && not (fromFlag $ haddockTestSuites haddockFlags)
+ && not (fromFlag $ haddockBenchmarks haddockFlags)
+ && not (fromFlag $ haddockForeignLibs haddockFlags) =
warn (fromFlag $ haddockVerbosity haddockFlags) $
- "No documentation was generated as this package does not contain "
- ++ "a library. Perhaps you want to use the --executables, --tests,"
- ++ " --benchmarks or --foreign-libraries flags."
-
+ "No documentation was generated as this package does not contain "
+ ++ "a library. Perhaps you want to use the --executables, --tests,"
+ ++ " --benchmarks or --foreign-libraries flags."
haddock pkg_descr lbi suffixes flags' = do
- let verbosity = flag haddockVerbosity
- comp = compiler lbi
- platform = hostPlatform lbi
-
- quickJmpFlag = haddockQuickJump flags'
- flags = case haddockTarget of
- ForDevelopment -> flags'
- ForHackage -> flags'
- { haddockHoogle = Flag True
- , haddockHtml = Flag True
+ let verbosity = flag haddockVerbosity
+ comp = compiler lbi
+ platform = hostPlatform lbi
+
+ quickJmpFlag = haddockQuickJump flags'
+ flags = case haddockTarget of
+ ForDevelopment -> flags'
+ ForHackage ->
+ flags'
+ { haddockHoogle = Flag True
+ , haddockHtml = Flag True
, haddockHtmlLocation = Flag (pkg_url ++ "/docs")
- , haddockContents = Flag (toPathTemplate pkg_url)
+ , haddockContents = Flag (toPathTemplate pkg_url)
, haddockLinkedSource = Flag True
- , haddockQuickJump = Flag True
+ , haddockQuickJump = Flag True
}
- pkg_url = "/package/$pkg-$version"
- flag f = fromFlag $ f flags
-
- tmpFileOpts = defaultTempFileOptions
- { optKeepTempFiles = flag haddockKeepTempFiles }
- htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation
- $ flags
- haddockTarget =
- fromFlagOrDefault ForDevelopment (haddockForHackage flags')
-
- libdirArgs <- getGhcLibDir verbosity lbi
- -- The haddock-output-dir flag overrides any other documentation placement concerns.
- -- The point is to give the user full freedom over the location if they need it.
- let overrideWithOutputDir args = case haddockOutputDir flags of
- NoFlag -> args
- Flag dir -> args { argOutputDir = Dir dir }
- let commonArgs = overrideWithOutputDir $ mconcat
+ pkg_url = "/package/$pkg-$version"
+ flag f = fromFlag $ f flags
+
+ tmpFileOpts =
+ defaultTempFileOptions
+ { optKeepTempFiles = flag haddockKeepTempFiles
+ }
+ htmlTemplate =
+ fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $
+ flags
+ haddockTarget =
+ fromFlagOrDefault ForDevelopment (haddockForHackage flags')
+
+ libdirArgs <- getGhcLibDir verbosity lbi
+ -- The haddock-output-dir flag overrides any other documentation placement concerns.
+ -- The point is to give the user full freedom over the location if they need it.
+ let overrideWithOutputDir args = case haddockOutputDir flags of
+ NoFlag -> args
+ Flag dir -> args{argOutputDir = Dir dir}
+ let commonArgs =
+ overrideWithOutputDir $
+ mconcat
[ libdirArgs
, fromFlags (haddockTemplateEnv lbi (packageId pkg_descr)) flags
- , fromPackageDescription haddockTarget pkg_descr ]
-
- (haddockProg, version) <-
- getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag
-
- -- We fall back to using HsColour only for versions of Haddock which don't
- -- support '--hyperlinked-sources'.
- when (flag haddockLinkedSource && version < mkVersion [2,17]) $
- hscolour' (warn verbosity) haddockTarget pkg_descr lbi suffixes
+ , fromPackageDescription haddockTarget pkg_descr
+ ]
+
+ (haddockProg, version) <-
+ getHaddockProg verbosity (withPrograms lbi) comp commonArgs quickJmpFlag
+
+ -- We fall back to using HsColour only for versions of Haddock which don't
+ -- support '--hyperlinked-sources'.
+ when (flag haddockLinkedSource && version < mkVersion [2, 17]) $
+ hscolour'
+ (warn verbosity)
+ haddockTarget
+ pkg_descr
+ lbi
+ suffixes
(defaultHscolourFlags `mappend` haddockToHscolour flags)
- targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags)
-
- let
- targets' =
- case targets of
- [] -> allTargetsInBuildOrder' pkg_descr lbi
- _ -> targets
+ targets <- readTargetInfos verbosity pkg_descr lbi (haddockArgs flags)
- internalPackageDB <-
- createInternalPackageDB verbosity lbi (flag haddockDistPref)
+ let
+ targets' =
+ case targets of
+ [] -> allTargetsInBuildOrder' pkg_descr lbi
+ _ -> targets
- (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do
+ internalPackageDB <-
+ createInternalPackageDB verbosity lbi (flag haddockDistPref)
- let component = targetComponent target
- clbi = targetCLBI target
+ (\f -> foldM_ f (installedPkgs lbi) targets') $ \index target -> do
+ let component = targetComponent target
+ clbi = targetCLBI target
- componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity
+ componentInitialBuildSteps (flag haddockDistPref) pkg_descr lbi clbi verbosity
- let
- lbi' = lbi {
- withPackageDB = withPackageDB lbi ++ [internalPackageDB],
- installedPkgs = index
+ let
+ lbi' =
+ lbi
+ { withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+ , installedPkgs = index
}
- preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes
- let
- doExe com = case (compToExe com) of
- Just exe -> do
- withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $
- \tmp -> do
- exeArgs <- fromExecutable verbosity tmp lbi' clbi htmlTemplate
- version exe
- let exeArgs' = commonArgs `mappend` exeArgs
- runHaddock verbosity tmpFileOpts comp platform
- haddockProg True exeArgs'
- Nothing -> do
- warn (fromFlag $ haddockVerbosity flags)
- "Unsupported component, skipping..."
- return ()
- -- We define 'smsg' once and then reuse it inside the case, so that
- -- we don't say we are running Haddock when we actually aren't
- -- (e.g., Haddock is not run on non-libraries)
- smsg :: IO ()
- smsg = setupMessage' verbosity "Running Haddock on" (packageId pkg_descr)
- (componentLocalName clbi) (maybeComponentInstantiatedWith clbi)
- case component of
- CLib lib -> do
- withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
+ preprocessComponent pkg_descr component lbi' clbi False verbosity suffixes
+ let
+ doExe com = case (compToExe com) of
+ Just exe -> do
+ withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $
\tmp -> do
- smsg
- libArgs <- fromLibrary verbosity tmp lbi' clbi htmlTemplate
- version lib
- let libArgs' = commonArgs `mappend` libArgs
- runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs'
-
- pwd <- getCurrentDirectory
-
- let
- ipi = inplaceInstalledPackageInfo
- pwd (flag haddockDistPref) pkg_descr
- (mkAbiHash "inplace") lib lbi' clbi
-
- debug verbosity $ "Registering inplace:\n"
+ exeArgs <-
+ fromExecutable
+ verbosity
+ tmp
+ lbi'
+ clbi
+ htmlTemplate
+ version
+ exe
+ let exeArgs' = commonArgs `mappend` exeArgs
+ runHaddock
+ verbosity
+ tmpFileOpts
+ comp
+ platform
+ haddockProg
+ True
+ exeArgs'
+ Nothing -> do
+ warn
+ (fromFlag $ haddockVerbosity flags)
+ "Unsupported component, skipping..."
+ return ()
+ -- We define 'smsg' once and then reuse it inside the case, so that
+ -- we don't say we are running Haddock when we actually aren't
+ -- (e.g., Haddock is not run on non-libraries)
+ smsg :: IO ()
+ smsg =
+ setupMessage'
+ verbosity
+ "Running Haddock on"
+ (packageId pkg_descr)
+ (componentLocalName clbi)
+ (maybeComponentInstantiatedWith clbi)
+ case component of
+ CLib lib -> do
+ withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $
+ \tmp -> do
+ smsg
+ libArgs <-
+ fromLibrary
+ verbosity
+ tmp
+ lbi'
+ clbi
+ htmlTemplate
+ version
+ lib
+ let libArgs' = commonArgs `mappend` libArgs
+ runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs'
+
+ pwd <- getCurrentDirectory
+
+ let
+ ipi =
+ inplaceInstalledPackageInfo
+ pwd
+ (flag haddockDistPref)
+ pkg_descr
+ (mkAbiHash "inplace")
+ lib
+ lbi'
+ clbi
+
+ debug verbosity $
+ "Registering inplace:\n"
++ (InstalledPackageInfo.showInstalledPackageInfo ipi)
- registerPackage verbosity (compiler lbi') (withPrograms lbi')
- (withPackageDB lbi') ipi
- HcPkg.defaultRegisterOptions {
- HcPkg.registerMultiInstance = True
+ registerPackage
+ verbosity
+ (compiler lbi')
+ (withPrograms lbi')
+ (withPackageDB lbi')
+ ipi
+ HcPkg.defaultRegisterOptions
+ { HcPkg.registerMultiInstance = True
}
- return $ PackageIndex.insert ipi index
-
- CFLib flib -> (when (flag haddockForeignLibs) $ do
- withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $
- \tmp -> do
- smsg
- flibArgs <- fromForeignLib verbosity tmp lbi' clbi htmlTemplate
- version flib
- let libArgs' = commonArgs `mappend` flibArgs
- runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs')
-
+ return $ PackageIndex.insert ipi index
+ CFLib flib ->
+ ( when (flag haddockForeignLibs) $ do
+ withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi') "tmp" $
+ \tmp -> do
+ smsg
+ flibArgs <-
+ fromForeignLib
+ verbosity
+ tmp
+ lbi'
+ clbi
+ htmlTemplate
+ version
+ flib
+ let libArgs' = commonArgs `mappend` flibArgs
+ runHaddock verbosity tmpFileOpts comp platform haddockProg True libArgs'
+ )
>> return index
+ CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index
+ CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index
+ CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index
- CExe _ -> (when (flag haddockExecutables) $ smsg >> doExe component) >> return index
- CTest _ -> (when (flag haddockTestSuites) $ smsg >> doExe component) >> return index
- CBench _ -> (when (flag haddockBenchmarks) $ smsg >> doExe component) >> return index
-
- for_ (extraDocFiles pkg_descr) $ \ fpath -> do
- files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
- for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
-
+ for_ (extraDocFiles pkg_descr) $ \fpath -> do
+ files <- matchDirFileGlob verbosity (specVersion pkg_descr) "." fpath
+ for_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)
-- | Execute 'Haddock' configured with 'HaddocksFlags'. It is used to build
-- index and contents for documentation of multiple packages.
---
-createHaddockIndex :: Verbosity
- -> ProgramDb
- -> Compiler
- -> Platform
- -> HaddockProjectFlags
- -> IO ()
+createHaddockIndex
+ :: Verbosity
+ -> ProgramDb
+ -> Compiler
+ -> Platform
+ -> HaddockProjectFlags
+ -> IO ()
createHaddockIndex verbosity programDb comp platform flags = do
- let args = fromHaddockProjectFlags flags
- (haddockProg, _version) <-
- getHaddockProg verbosity programDb comp args (haddockProjectQuickJump flags)
- runHaddock verbosity defaultTempFileOptions comp platform haddockProg False args
+ let args = fromHaddockProjectFlags flags
+ (haddockProg, _version) <-
+ getHaddockProg verbosity programDb comp args (haddockProjectQuickJump flags)
+ runHaddock verbosity defaultTempFileOptions comp platform haddockProg False args
-- ------------------------------------------------------------------------------
-- Contributions to HaddockArgs (see also Doctest.hs for very similar code).
fromFlags :: PathTemplateEnv -> HaddockFlags -> HaddockArgs
fromFlags env flags =
- mempty {
- argHideModules = (maybe mempty (All . not)
- $ flagToMaybe (haddockInternal flags), mempty),
- argLinkSource = if fromFlag (haddockLinkedSource flags)
- then Flag ("src/%{MODULE/./-}.html"
- ,"src/%{MODULE/./-}.html#%{NAME}"
- ,"src/%{MODULE/./-}.html#line-%{LINE}")
- else NoFlag,
- argLinkedSource = haddockLinkedSource flags,
- argQuickJump = haddockQuickJump flags,
- argCssFile = haddockCss flags,
- argContents = fmap (fromPathTemplate . substPathTemplate env)
- (haddockContents flags),
- argGenContents = Flag False,
- argIndex = fmap (fromPathTemplate . substPathTemplate env)
- (haddockIndex flags),
- argGenIndex = Flag False,
- argBaseUrl = haddockBaseUrl flags,
- argLib = haddockLib flags,
- argVerbose = maybe mempty (Any . (>= deafening))
- . flagToMaybe $ haddockVerbosity flags,
- argOutput =
- Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++
- [ Hoogle | Flag True <- [haddockHoogle flags] ]
- of [] -> [ Html ]
- os -> os,
- argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags,
-
- argGhcOptions = mempty { ghcOptExtra = ghcArgs }
+ mempty
+ { argHideModules =
+ ( maybe mempty (All . not) $
+ flagToMaybe (haddockInternal flags)
+ , mempty
+ )
+ , argLinkSource =
+ if fromFlag (haddockLinkedSource flags)
+ then
+ Flag
+ ( "src/%{MODULE/./-}.html"
+ , "src/%{MODULE/./-}.html#%{NAME}"
+ , "src/%{MODULE/./-}.html#line-%{LINE}"
+ )
+ else NoFlag
+ , argLinkedSource = haddockLinkedSource flags
+ , argQuickJump = haddockQuickJump flags
+ , argCssFile = haddockCss flags
+ , argContents =
+ fmap
+ (fromPathTemplate . substPathTemplate env)
+ (haddockContents flags)
+ , argGenContents = Flag False
+ , argIndex =
+ fmap
+ (fromPathTemplate . substPathTemplate env)
+ (haddockIndex flags)
+ , argGenIndex = Flag False
+ , argBaseUrl = haddockBaseUrl flags
+ , argLib = haddockLib flags
+ , argVerbose =
+ maybe mempty (Any . (>= deafening))
+ . flagToMaybe
+ $ haddockVerbosity flags
+ , argOutput =
+ Flag $ case [Html | Flag True <- [haddockHtml flags]]
+ ++ [Hoogle | Flag True <- [haddockHoogle flags]] of
+ [] -> [Html]
+ os -> os
+ , argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags
+ , argGhcOptions = mempty{ghcOptExtra = ghcArgs}
}
- where
- ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags
+ where
+ ghcArgs = fromMaybe [] . lookup "ghc" . haddockProgramArgs $ flags
fromHaddockProjectFlags :: HaddockProjectFlags -> HaddockArgs
fromHaddockProjectFlags flags =
- mempty
- { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)
- , argQuickJump = haddockProjectQuickJump flags
- , argGenContents = haddockProjectGenContents flags
- , argGenIndex = haddockProjectGenIndex flags
- , argPrologueFile = haddockProjectPrologue flags
- , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)
- , argLinkedSource = haddockProjectLinkedSource flags
- , argLib = haddockProjectLib flags
- }
-
+ mempty
+ { argOutputDir = Dir (fromFlag $ haddockProjectDir flags)
+ , argQuickJump = haddockProjectQuickJump flags
+ , argGenContents = haddockProjectGenContents flags
+ , argGenIndex = haddockProjectGenIndex flags
+ , argPrologueFile = haddockProjectPrologue flags
+ , argInterfaces = fromFlagOrDefault [] (haddockProjectInterfaces flags)
+ , argLinkedSource = haddockProjectLinkedSource flags
+ , argLib = haddockProjectLib flags
+ }
fromPackageDescription :: HaddockTarget -> PackageDescription -> HaddockArgs
-fromPackageDescription haddockTarget pkg_descr = mempty
+fromPackageDescription haddockTarget pkg_descr =
+ mempty
{ argInterfaceFile = Flag $ haddockName pkg_descr
, argPackageName = Flag $ packageId $ pkg_descr
- , argOutputDir = Dir $
- "doc" </> "html" </> haddockDirName haddockTarget pkg_descr
- , argPrologue = Flag $ ShortText.fromShortText $
- if ShortText.null desc
- then synopsis pkg_descr
- else desc
+ , argOutputDir =
+ Dir $
+ "doc" </> "html" </> haddockDirName haddockTarget pkg_descr
+ , argPrologue =
+ Flag $
+ ShortText.fromShortText $
+ if ShortText.null desc
+ then synopsis pkg_descr
+ else desc
, argTitle = Flag $ showPkg ++ subtitle
}
where
desc = description pkg_descr
showPkg = prettyShow (packageId pkg_descr)
subtitle
- | ShortText.null (synopsis pkg_descr) = ""
- | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr)
-
-componentGhcOptions :: Verbosity -> LocalBuildInfo
- -> BuildInfo -> ComponentLocalBuildInfo -> FilePath
- -> GhcOptions
+ | ShortText.null (synopsis pkg_descr) = ""
+ | otherwise = ": " ++ ShortText.fromShortText (synopsis pkg_descr)
+
+componentGhcOptions
+ :: Verbosity
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
let f = case compilerFlavor (compiler lbi) of
- GHC -> GHC.componentGhcOptions
- GHCJS -> GHCJS.componentGhcOptions
- _ -> error $
- "Distribution.Simple.Haddock.componentGhcOptions:" ++
- "haddock only supports GHC and GHCJS"
- in f verbosity lbi bi clbi odir
-
-mkHaddockArgs :: Verbosity
- -> FilePath
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for HTML location
- -> Version
- -> [FilePath]
- -> BuildInfo
- -> IO HaddockArgs
+ GHC -> GHC.componentGhcOptions
+ GHCJS -> GHCJS.componentGhcOptions
+ _ ->
+ error $
+ "Distribution.Simple.Haddock.componentGhcOptions:"
+ ++ "haddock only supports GHC and GHCJS"
+ in f verbosity lbi bi clbi odir
+
+mkHaddockArgs
+ :: Verbosity
+ -> FilePath
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -- ^ template for HTML location
+ -> Version
+ -> [FilePath]
+ -> BuildInfo
+ -> IO HaddockArgs
mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion inFiles bi = do
- ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
- let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {
- -- Noooooooooo!!!!!111
- -- haddock stomps on our precious .hi
- -- and .o files. Workaround by telling
- -- haddock to write them elsewhere.
- ghcOptObjDir = toFlag tmp,
- ghcOptHiDir = toFlag tmp,
- ghcOptStubDir = toFlag tmp
- } `mappend` getGhcCppOpts haddockVersion bi
- sharedOpts = vanillaOpts {
- ghcOptDynLinkMode = toFlag GhcDynamicOnly,
- ghcOptFPic = toFlag True,
- ghcOptHiSuffix = toFlag "dyn_hi",
- ghcOptObjSuffix = toFlag "dyn_o",
- ghcOptExtra = hcSharedOptions GHC bi
-
- }
- opts <- if withVanillaLib lbi
- then return vanillaOpts
- else if withSharedLib lbi
- then return sharedOpts
- else die' verbosity $ "Must have vanilla or shared libraries "
- ++ "enabled in order to run haddock"
-
- return ifaceArgs
- { argGhcOptions = opts
- , argTargets = inFiles
- , argReexports = getReexports clbi
+ ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate
+ let vanillaOpts =
+ (componentGhcOptions normal lbi bi clbi (buildDir lbi))
+ { -- Noooooooooo!!!!!111
+ -- haddock stomps on our precious .hi
+ -- and .o files. Workaround by telling
+ -- haddock to write them elsewhere.
+ ghcOptObjDir = toFlag tmp
+ , ghcOptHiDir = toFlag tmp
+ , ghcOptStubDir = toFlag tmp
+ }
+ `mappend` getGhcCppOpts haddockVersion bi
+ sharedOpts =
+ vanillaOpts
+ { ghcOptDynLinkMode = toFlag GhcDynamicOnly
+ , ghcOptFPic = toFlag True
+ , ghcOptHiSuffix = toFlag "dyn_hi"
+ , ghcOptObjSuffix = toFlag "dyn_o"
+ , ghcOptExtra = hcSharedOptions GHC bi
+ }
+ opts <-
+ if withVanillaLib lbi
+ then return vanillaOpts
+ else
+ if withSharedLib lbi
+ then return sharedOpts
+ else
+ die' verbosity $
+ "Must have vanilla or shared libraries "
+ ++ "enabled in order to run haddock"
+
+ return
+ ifaceArgs
+ { argGhcOptions = opts
+ , argTargets = inFiles
+ , argReexports = getReexports clbi
}
-fromLibrary :: Verbosity
- -> FilePath
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for HTML location
- -> Version
- -> Library
- -> IO HaddockArgs
+fromLibrary
+ :: Verbosity
+ -> FilePath
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -- ^ template for HTML location
+ -> Version
+ -> Library
+ -> IO HaddockArgs
fromLibrary verbosity tmp lbi clbi htmlTemplate haddockVersion lib = do
- inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi
- args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate haddockVersion
- inFiles (libBuildInfo lib)
- return args {
- argHideModules = (mempty, otherModules (libBuildInfo lib))
- }
+ inFiles <- map snd `fmap` getLibSourceFiles verbosity lbi lib clbi
+ args <-
+ mkHaddockArgs
+ verbosity
+ tmp
+ lbi
+ clbi
+ htmlTemplate
+ haddockVersion
+ inFiles
+ (libBuildInfo lib)
+ return
+ args
+ { argHideModules = (mempty, otherModules (libBuildInfo lib))
+ }
-fromExecutable :: Verbosity
- -> FilePath
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for HTML location
- -> Version
- -> Executable
- -> IO HaddockArgs
+fromExecutable
+ :: Verbosity
+ -> FilePath
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -- ^ template for HTML location
+ -> Version
+ -> Executable
+ -> IO HaddockArgs
fromExecutable verbosity tmp lbi clbi htmlTemplate haddockVersion exe = do
- inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi
- args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate
- haddockVersion inFiles (buildInfo exe)
- return args {
- argOutputDir = Dir $ unUnqualComponentName $ exeName exe,
- argTitle = Flag $ unUnqualComponentName $ exeName exe
- }
+ inFiles <- map snd `fmap` getExeSourceFiles verbosity lbi exe clbi
+ args <-
+ mkHaddockArgs
+ verbosity
+ tmp
+ lbi
+ clbi
+ htmlTemplate
+ haddockVersion
+ inFiles
+ (buildInfo exe)
+ return
+ args
+ { argOutputDir = Dir $ unUnqualComponentName $ exeName exe
+ , argTitle = Flag $ unUnqualComponentName $ exeName exe
+ }
-fromForeignLib :: Verbosity
- -> FilePath
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for HTML location
- -> Version
- -> ForeignLib
- -> IO HaddockArgs
+fromForeignLib
+ :: Verbosity
+ -> FilePath
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -- ^ template for HTML location
+ -> Version
+ -> ForeignLib
+ -> IO HaddockArgs
fromForeignLib verbosity tmp lbi clbi htmlTemplate haddockVersion flib = do
- inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi
- args <- mkHaddockArgs verbosity tmp lbi clbi htmlTemplate
- haddockVersion inFiles (foreignLibBuildInfo flib)
- return args {
- argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib,
- argTitle = Flag $ unUnqualComponentName $ foreignLibName flib
- }
+ inFiles <- map snd `fmap` getFLibSourceFiles verbosity lbi flib clbi
+ args <-
+ mkHaddockArgs
+ verbosity
+ tmp
+ lbi
+ clbi
+ htmlTemplate
+ haddockVersion
+ inFiles
+ (foreignLibBuildInfo flib)
+ return
+ args
+ { argOutputDir = Dir $ unUnqualComponentName $ foreignLibName flib
+ , argTitle = Flag $ unUnqualComponentName $ foreignLibName flib
+ }
compToExe :: Component -> Maybe Executable
compToExe comp =
case comp of
- CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->
- Just Executable {
- exeName = testName test,
- modulePath = f,
- exeScope = ExecutablePublic,
- buildInfo = testBuildInfo test
- }
- CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->
- Just Executable {
- exeName = benchmarkName bench,
- modulePath = f,
- exeScope = ExecutablePublic,
- buildInfo = benchmarkBuildInfo bench
- }
+ CTest test@TestSuite{testInterface = TestSuiteExeV10 _ f} ->
+ Just
+ Executable
+ { exeName = testName test
+ , modulePath = f
+ , exeScope = ExecutablePublic
+ , buildInfo = testBuildInfo test
+ }
+ CBench bench@Benchmark{benchmarkInterface = BenchmarkExeV10 _ f} ->
+ Just
+ Executable
+ { exeName = benchmarkName bench
+ , modulePath = f
+ , exeScope = ExecutablePublic
+ , buildInfo = benchmarkBuildInfo bench
+ }
CExe exe -> Just exe
_ -> Nothing
-getInterfaces :: Verbosity
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate -- ^ template for HTML location
- -> IO HaddockArgs
+getInterfaces
+ :: Verbosity
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -- ^ template for HTML location
+ -> IO HaddockArgs
getInterfaces verbosity lbi clbi htmlTemplate = do
- (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate
- traverse_ (warn (verboseUnmarkOutput verbosity)) warnings
- return $ mempty {
- argInterfaces = packageFlags
- }
+ (packageFlags, warnings) <- haddockPackageFlags verbosity lbi clbi htmlTemplate
+ traverse_ (warn (verboseUnmarkOutput verbosity)) warnings
+ return $
+ mempty
+ { argInterfaces = packageFlags
+ }
getReexports :: ComponentLocalBuildInfo -> [OpenModule]
-getReexports LibComponentLocalBuildInfo {componentExposedModules = mods } =
- mapMaybe exposedReexport mods
+getReexports LibComponentLocalBuildInfo{componentExposedModules = mods} =
+ mapMaybe exposedReexport mods
getReexports _ = []
-getGhcCppOpts :: Version
- -> BuildInfo
- -> GhcOptions
+getGhcCppOpts
+ :: Version
+ -> BuildInfo
+ -> GhcOptions
getGhcCppOpts haddockVersion bi =
- mempty {
- ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp],
- ghcOptCppOptions = defines
+ mempty
+ { ghcOptExtensions = toNubListR [EnableExtension CPP | needsCpp]
+ , ghcOptCppOptions = defines
}
where
- needsCpp = EnableExtension CPP `elem` usedExtensions bi
- defines = [haddockVersionMacro]
- haddockVersionMacro = "-D__HADDOCK_VERSION__="
- ++ show (v1 * 1000 + v2 * 10 + v3)
+ needsCpp = EnableExtension CPP `elem` usedExtensions bi
+ defines = [haddockVersionMacro]
+ haddockVersionMacro =
+ "-D__HADDOCK_VERSION__="
+ ++ show (v1 * 1000 + v2 * 10 + v3)
where
(v1, v2, v3) = case versionNumbers haddockVersion of
- [] -> (0,0,0)
- [x] -> (x,0,0)
- [x,y] -> (x,y,0)
- (x:y:z:_) -> (x,y,z)
-
-getGhcLibDir :: Verbosity -> LocalBuildInfo
- -> IO HaddockArgs
+ [] -> (0, 0, 0)
+ [x] -> (x, 0, 0)
+ [x, y] -> (x, y, 0)
+ (x : y : z : _) -> (x, y, z)
+
+getGhcLibDir
+ :: Verbosity
+ -> LocalBuildInfo
+ -> IO HaddockArgs
getGhcLibDir verbosity lbi = do
- l <- case compilerFlavor (compiler lbi) of
- GHC -> GHC.getLibDir verbosity lbi
- GHCJS -> GHCJS.getLibDir verbosity lbi
- _ -> error "haddock only supports GHC and GHCJS"
- return $ mempty { argGhcLibDir = Flag l }
+ l <- case compilerFlavor (compiler lbi) of
+ GHC -> GHC.getLibDir verbosity lbi
+ GHCJS -> GHCJS.getLibDir verbosity lbi
+ _ -> error "haddock only supports GHC and GHCJS"
+ return $ mempty{argGhcLibDir = Flag l}
-- ------------------------------------------------------------------------------
+
-- | Call haddock with the specified arguments.
-runHaddock :: Verbosity
- -> TempFileOptions
- -> Compiler
- -> Platform
- -> ConfiguredProgram
- -> Bool -- ^ require targets
- -> HaddockArgs
- -> IO ()
+runHaddock
+ :: Verbosity
+ -> TempFileOptions
+ -> Compiler
+ -> Platform
+ -> ConfiguredProgram
+ -> Bool
+ -- ^ require targets
+ -> HaddockArgs
+ -> IO ()
runHaddock verbosity tmpFileOpts comp platform haddockProg requireTargets args
- | requireTargets && null (argTargets args) = warn verbosity $
- "Haddocks are being requested, but there aren't any modules given "
- ++ "to create documentation for."
+ | requireTargets && null (argTargets args) =
+ warn verbosity $
+ "Haddocks are being requested, but there aren't any modules given "
+ ++ "to create documentation for."
| otherwise = do
- let haddockVersion = fromMaybe (error "unable to determine haddock version")
- (programVersion haddockProg)
- renderArgs verbosity tmpFileOpts haddockVersion comp platform args $
- \(flags,result)-> do
-
- runProgram verbosity haddockProg flags
-
- notice verbosity $ "Documentation created: " ++ result
-
-
-renderArgs :: Verbosity
- -> TempFileOptions
- -> Version
- -> Compiler
- -> Platform
- -> HaddockArgs
- -> (([String], FilePath) -> IO a)
- -> IO a
+ let haddockVersion =
+ fromMaybe
+ (error "unable to determine haddock version")
+ (programVersion haddockProg)
+ renderArgs verbosity tmpFileOpts haddockVersion comp platform args $
+ \(flags, result) -> do
+ runProgram verbosity haddockProg flags
+
+ notice verbosity $ "Documentation created: " ++ result
+
+renderArgs
+ :: Verbosity
+ -> TempFileOptions
+ -> Version
+ -> Compiler
+ -> Platform
+ -> HaddockArgs
+ -> (([String], FilePath) -> IO a)
+ -> IO a
renderArgs verbosity tmpFileOpts version comp platform args k = do
- let haddockSupportsUTF8 = version >= mkVersion [2,14,4]
- haddockSupportsResponseFiles = version > mkVersion [2,16,2]
+ let haddockSupportsUTF8 = version >= mkVersion [2, 14, 4]
+ haddockSupportsResponseFiles = version > mkVersion [2, 16, 2]
createDirectoryIfMissingVerbose verbosity True outputDir
case argPrologue args of
Flag prologueText ->
withTempFileEx tmpFileOpts outputDir "haddock-prologue.txt" $
\prologueFileName h -> do
- do
- when haddockSupportsUTF8 (hSetEncoding h utf8)
- hPutStrLn h prologueText
- hClose h
- let pflag = "--prologue=" ++ prologueFileName
- renderedArgs = pflag : renderPureArgs version comp platform args
- if haddockSupportsResponseFiles
- then
- withResponseFile
- verbosity
- tmpFileOpts
- outputDir
- "haddock-response.txt"
- (if haddockSupportsUTF8 then Just utf8 else Nothing)
- renderedArgs
- (\responseFileName -> k (["@" ++ responseFileName], result))
- else
- k (renderedArgs, result)
+ do
+ when haddockSupportsUTF8 (hSetEncoding h utf8)
+ hPutStrLn h prologueText
+ hClose h
+ let pflag = "--prologue=" ++ prologueFileName
+ renderedArgs = pflag : renderPureArgs version comp platform args
+ if haddockSupportsResponseFiles
+ then
+ withResponseFile
+ verbosity
+ tmpFileOpts
+ outputDir
+ "haddock-response.txt"
+ (if haddockSupportsUTF8 then Just utf8 else Nothing)
+ renderedArgs
+ (\responseFileName -> k (["@" ++ responseFileName], result))
+ else k (renderedArgs, result)
_ -> do
- let renderedArgs = (case argPrologueFile args of
- Flag pfile -> ["--prologue="++pfile]
- _ -> [])
- <> renderPureArgs version comp platform args
+ let renderedArgs =
+ ( case argPrologueFile args of
+ Flag pfile -> ["--prologue=" ++ pfile]
+ _ -> []
+ )
+ <> renderPureArgs version comp platform args
if haddockSupportsResponseFiles
then
withResponseFile
@@ -684,251 +826,273 @@ renderArgs verbosity tmpFileOpts version comp platform args k = do
(if haddockSupportsUTF8 then Just utf8 else Nothing)
renderedArgs
(\responseFileName -> k (["@" ++ responseFileName], result))
- else
- k (renderedArgs, result)
- where
- outputDir = (unDir $ argOutputDir args)
- result = intercalate ", "
- . map (\o -> outputDir </>
- case o of
- Html -> "index.html"
- Hoogle -> pkgstr <.> "txt")
- . fromFlagOrDefault [Html]
- . argOutput
- $ args
- where
- pkgstr = prettyShow $ packageName pkgid
- pkgid = arg argPackageName
- arg f = fromFlag $ f args
+ else k (renderedArgs, result)
+ where
+ outputDir = (unDir $ argOutputDir args)
+ result =
+ intercalate ", "
+ . map
+ ( \o ->
+ outputDir
+ </> case o of
+ Html -> "index.html"
+ Hoogle -> pkgstr <.> "txt"
+ )
+ . fromFlagOrDefault [Html]
+ . argOutput
+ $ args
+ where
+ pkgstr = prettyShow $ packageName pkgid
+ pkgid = arg argPackageName
+ arg f = fromFlag $ f args
renderPureArgs :: Version -> Compiler -> Platform -> HaddockArgs -> [String]
-renderPureArgs version comp platform args = concat
- [ map (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)
- . flagToList . argInterfaceFile $ args
-
+renderPureArgs version comp platform args =
+ concat
+ [ map (\f -> "--dump-interface=" ++ unDir (argOutputDir args) </> f)
+ . flagToList
+ . argInterfaceFile
+ $ args
, if haddockSupportsPackageName
- then maybe [] (\pkg -> [ "--package-name=" ++ prettyShow (pkgName pkg)
- , "--package-version=" ++ prettyShow (pkgVersion pkg)
- ])
- . flagToMaybe . argPackageName $ args
+ then
+ maybe
+ []
+ ( \pkg ->
+ [ "--package-name=" ++ prettyShow (pkgName pkg)
+ , "--package-version=" ++ prettyShow (pkgVersion pkg)
+ ]
+ )
+ . flagToMaybe
+ . argPackageName
+ $ args
else []
-
- , [ "--since-qual=external" | isVersion 2 20 ]
-
- , [ "--quickjump" | isVersion 2 19
- , _ <- flagToList . argQuickJump $ args ]
-
- , [ "--hyperlinked-source" | isVersion 2 17
- , True <- flagToList . argLinkedSource $ args ]
-
- , (\(All b,xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b)
- . argHideModules $ args
-
+ , ["--since-qual=external" | isVersion 2 20]
+ , [ "--quickjump" | isVersion 2 19, _ <- flagToList . argQuickJump $ args
+ ]
+ , [ "--hyperlinked-source" | isVersion 2 17, True <- flagToList . argLinkedSource $ args
+ ]
+ , (\(All b, xs) -> bool (map (("--hide=" ++) . prettyShow) xs) [] b)
+ . argHideModules
+ $ args
, bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args
-
- , maybe [] (\(m,e,l) ->
- ["--source-module=" ++ m
- ,"--source-entity=" ++ e]
- ++ if isVersion 2 14 then ["--source-entity-line=" ++ l]
- else []
- ) . flagToMaybe . argLinkSource $ args
-
- , maybe [] ((:[]) . ("--css="++)) . flagToMaybe . argCssFile $ args
-
- , maybe [] ((:[]) . ("--use-contents="++)) . flagToMaybe . argContents $ args
-
- , bool ["--gen-contents"] [] .fromFlagOrDefault False . argGenContents $ args
-
- , maybe [] ((:[]) . ("--use-index="++)) . flagToMaybe . argIndex $ args
-
+ , maybe
+ []
+ ( \(m, e, l) ->
+ [ "--source-module=" ++ m
+ , "--source-entity=" ++ e
+ ]
+ ++ if isVersion 2 14
+ then ["--source-entity-line=" ++ l]
+ else []
+ )
+ . flagToMaybe
+ . argLinkSource
+ $ args
+ , maybe [] ((: []) . ("--css=" ++)) . flagToMaybe . argCssFile $ args
+ , maybe [] ((: []) . ("--use-contents=" ++)) . flagToMaybe . argContents $ args
+ , bool ["--gen-contents"] [] . fromFlagOrDefault False . argGenContents $ args
+ , maybe [] ((: []) . ("--use-index=" ++)) . flagToMaybe . argIndex $ args
, bool ["--gen-index"] [] . fromFlagOrDefault False . argGenIndex $ args
-
- , maybe [] ((:[]) . ("--base-url="++)) . flagToMaybe . argBaseUrl $ args
-
+ , maybe [] ((: []) . ("--base-url=" ++)) . flagToMaybe . argBaseUrl $ args
, bool [] [verbosityFlag] . getAny . argVerbose $ args
-
, map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html")
- . fromFlagOrDefault [] . argOutput $ args
-
+ . fromFlagOrDefault []
+ . argOutput
+ $ args
, renderInterfaces . argInterfaces $ args
-
- , (:[]) . ("--odir="++) . unDir . argOutputDir $ args
-
- , maybe []
- ( (:[])
- . ("--title="++)
- . (bool (++" (internal documentation)")
- id (getAny $ argIgnoreExports args))
+ , (: []) . ("--odir=" ++) . unDir . argOutputDir $ args
+ , maybe
+ []
+ ( (: [])
+ . ("--title=" ++)
+ . ( bool
+ (++ " (internal documentation)")
+ id
+ (getAny $ argIgnoreExports args)
+ )
)
- . flagToMaybe . argTitle $ args
-
- , [ "--optghc=" ++ opt | let opts = argGhcOptions args
- , opt <- renderGhcOptions comp platform opts ]
-
- , maybe [] (\l -> ["-B"++l]) $
- flagToMaybe (argGhcLibDir args) -- error if Nothing?
-
- -- https://github.com/haskell/haddock/pull/547
- , [ "--reexport=" ++ prettyShow r
+ . flagToMaybe
+ . argTitle
+ $ args
+ , [ "--optghc=" ++ opt | let opts = argGhcOptions args, opt <- renderGhcOptions comp platform opts
+ ]
+ , maybe [] (\l -> ["-B" ++ l]) $
+ flagToMaybe (argGhcLibDir args) -- error if Nothing?
+ , -- https://github.com/haskell/haddock/pull/547
+ [ "--reexport=" ++ prettyShow r
| r <- argReexports args
, isVersion 2 19
]
-
, argTargets $ args
- , maybe [] ((:[]) . ("--lib="++)) . flagToMaybe . argLib $ args
+ , maybe [] ((: []) . ("--lib=" ++)) . flagToMaybe . argLib $ args
]
- where
- renderInterfaces = map renderInterface
-
- renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String
- renderInterface (i, html, hypsrc, visibility) = "--read-interface=" ++
- (intercalate "," $ concat [ [ fromMaybe "" html ]
- , -- only render hypsrc path if html path
- -- is given and hyperlinked-source is
- -- enabled
- [ case (html, hypsrc) of
- (Nothing, _) -> ""
- (_, Nothing) -> ""
- (_, Just x) | isVersion 2 17
- , fromFlagOrDefault False . argLinkedSource $ args
- -> x
- | otherwise
- -> ""
- ]
- , if haddockSupportsVisibility
- then [ case visibility of
- Visible -> "visible"
- Hidden -> "hidden"
- ]
- else []
- , [ i ]
- ])
-
- bool a b c = if c then a else b
- isVersion major minor = version >= mkVersion [major,minor]
- verbosityFlag
- | isVersion 2 5 = "--verbosity=1"
- | otherwise = "--verbose"
- haddockSupportsVisibility = version >= mkVersion [2,26,1]
- haddockSupportsPackageName = version > mkVersion [2,16]
+ where
+ renderInterfaces = map renderInterface
+
+ renderInterface :: (FilePath, Maybe FilePath, Maybe FilePath, Visibility) -> String
+ renderInterface (i, html, hypsrc, visibility) =
+ "--read-interface="
+ ++ ( intercalate "," $
+ concat
+ [ [fromMaybe "" html]
+ , -- only render hypsrc path if html path
+ -- is given and hyperlinked-source is
+ -- enabled
+
+ [ case (html, hypsrc) of
+ (Nothing, _) -> ""
+ (_, Nothing) -> ""
+ (_, Just x)
+ | isVersion 2 17
+ , fromFlagOrDefault False . argLinkedSource $ args ->
+ x
+ | otherwise ->
+ ""
+ ]
+ , if haddockSupportsVisibility
+ then
+ [ case visibility of
+ Visible -> "visible"
+ Hidden -> "hidden"
+ ]
+ else []
+ , [i]
+ ]
+ )
+
+ bool a b c = if c then a else b
+ isVersion major minor = version >= mkVersion [major, minor]
+ verbosityFlag
+ | isVersion 2 5 = "--verbosity=1"
+ | otherwise = "--verbose"
+ haddockSupportsVisibility = version >= mkVersion [2, 26, 1]
+ haddockSupportsPackageName = version > mkVersion [2, 16]
---------------------------------------------------------------------------------
-- | Given a list of 'InstalledPackageInfo's, return a list of interfaces and
-- HTML paths, and an optional warning for packages with missing documentation.
-haddockPackagePaths :: [InstalledPackageInfo]
- -> Maybe (InstalledPackageInfo -> FilePath)
- -> IO ([( FilePath -- path to interface
- -- file
-
- , Maybe FilePath -- url to html
- -- documentation
-
- , Maybe FilePath -- url to hyperlinked
- -- source
- , Visibility
- )]
- , Maybe String -- warning about
- -- missing documentation
- )
+haddockPackagePaths
+ :: [InstalledPackageInfo]
+ -> Maybe (InstalledPackageInfo -> FilePath)
+ -> IO
+ ( [ ( FilePath -- path to interface
+ -- file
+ , Maybe FilePath -- url to html
+ -- documentation
+ , Maybe FilePath -- url to hyperlinked
+ -- source
+ , Visibility
+ )
+ ]
+ , Maybe String -- warning about
+ -- missing documentation
+ )
haddockPackagePaths ipkgs mkHtmlPath = do
- interfaces <- sequenceA
- [ case interfaceAndHtmlPath ipkg of
+ interfaces <-
+ sequenceA
+ [ case interfaceAndHtmlPath ipkg of
Nothing -> return (Left (packageId ipkg))
Just (interface, html) -> do
-
(html', hypsrc') <-
case html of
Just htmlPath -> do
let hypSrcPath = htmlPath </> defaultHyperlinkedSourceDirectory
hypSrcExists <- doesDirectoryExist hypSrcPath
- return $ ( Just (fixFileUrl htmlPath)
- , if hypSrcExists
- then Just (fixFileUrl hypSrcPath)
- else Nothing
- )
+ return $
+ ( Just (fixFileUrl htmlPath)
+ , if hypSrcExists
+ then Just (fixFileUrl hypSrcPath)
+ else Nothing
+ )
Nothing -> return (Nothing, Nothing)
exists <- doesFileExist interface
if exists
then return (Right (interface, html', hypsrc', Visible))
else return (Left pkgid)
- | ipkg <- ipkgs, let pkgid = packageId ipkg
- , pkgName pkgid `notElem` noHaddockWhitelist
- ]
+ | ipkg <- ipkgs
+ , let pkgid = packageId ipkg
+ , pkgName pkgid `notElem` noHaddockWhitelist
+ ]
- let missing = [ pkgid | Left pkgid <- interfaces ]
- warning = "The documentation for the following packages are not "
- ++ "installed. No links will be generated to these packages: "
- ++ intercalate ", " (map prettyShow missing)
+ let missing = [pkgid | Left pkgid <- interfaces]
+ warning =
+ "The documentation for the following packages are not "
+ ++ "installed. No links will be generated to these packages: "
+ ++ intercalate ", " (map prettyShow missing)
flags = rights interfaces
return (flags, if null missing then Nothing else Just warning)
-
where
-- Don't warn about missing documentation for these packages. See #1231.
- noHaddockWhitelist = map mkPackageName [ "rts" ]
+ noHaddockWhitelist = map mkPackageName ["rts"]
-- Actually extract interface and HTML paths from an 'InstalledPackageInfo'.
- interfaceAndHtmlPath :: InstalledPackageInfo
- -> Maybe (FilePath, Maybe FilePath)
+ interfaceAndHtmlPath
+ :: InstalledPackageInfo
+ -> Maybe (FilePath, Maybe FilePath)
interfaceAndHtmlPath pkg = do
interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)
html <- case mkHtmlPath of
- Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
+ Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)
Just mkPath -> Just (mkPath pkg)
return (interface, if null html then Nothing else Just html)
-- The 'haddock-html' field in the hc-pkg output is often set as a
-- native path, but we need it as a URL. See #1064. Also don't "fix"
-- the path if it is an interpolated one.
- fixFileUrl f | Nothing <- mkHtmlPath
- , isAbsolute f = "file://" ++ f
- | otherwise = f
+ fixFileUrl f
+ | Nothing <- mkHtmlPath
+ , isAbsolute f =
+ "file://" ++ f
+ | otherwise = f
-- 'src' is the default hyperlinked source directory ever since. It is
-- not possible to configure that directory in any way in haddock.
defaultHyperlinkedSourceDirectory = "src"
-
-haddockPackageFlags :: Verbosity
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Maybe PathTemplate
- -> IO ([( FilePath -- path to interface
- -- file
-
- , Maybe FilePath -- url to html
- -- documentation
-
- , Maybe FilePath -- url to hyperlinked
- -- source
- , Visibility
- )]
- , Maybe String -- warning about
- -- missing documentation
- )
+haddockPackageFlags
+ :: Verbosity
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Maybe PathTemplate
+ -> IO
+ ( [ ( FilePath -- path to interface
+ -- file
+ , Maybe FilePath -- url to html
+ -- documentation
+ , Maybe FilePath -- url to hyperlinked
+ -- source
+ , Visibility
+ )
+ ]
+ , Maybe String -- warning about
+ -- missing documentation
+ )
haddockPackageFlags verbosity lbi clbi htmlTemplate = do
let allPkgs = installedPkgs lbi
directDeps = map fst (componentPackageDeps clbi)
transitiveDeps <- case PackageIndex.dependencyClosure allPkgs directDeps of
- Left x -> return x
- Right inf -> die' verbosity $ "internal error when calculating transitive "
- ++ "package dependencies.\nDebug info: " ++ show inf
+ Left x -> return x
+ Right inf ->
+ die' verbosity $
+ "internal error when calculating transitive "
+ ++ "package dependencies.\nDebug info: "
+ ++ show inf
haddockPackagePaths (PackageIndex.allPackages transitiveDeps) mkHtmlPath
- where
- mkHtmlPath = fmap expandTemplateVars htmlTemplate
- expandTemplateVars tmpl pkg =
- fromPathTemplate . substPathTemplate (env pkg) $ tmpl
- env pkg = haddockTemplateEnv lbi (packageId pkg)
-
+ where
+ mkHtmlPath = fmap expandTemplateVars htmlTemplate
+ expandTemplateVars tmpl pkg =
+ fromPathTemplate . substPathTemplate (env pkg) $ tmpl
+ env pkg = haddockTemplateEnv lbi (packageId pkg)
haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv
haddockTemplateEnv lbi pkg_id =
(PrefixVar, prefix (installDirTemplates lbi))
- -- We want the legacy unit ID here, because it gives us nice paths
- -- (Haddock people don't care about the dependencies)
- : initialPathTemplateEnv
+ -- We want the legacy unit ID here, because it gives us nice paths
+ -- (Haddock people don't care about the dependencies)
+ : initialPathTemplateEnv
pkg_id
(mkLegacyUnitId pkg_id)
(compilerInfo (compiler lbi))
@@ -937,31 +1101,37 @@ haddockTemplateEnv lbi pkg_id =
-- ------------------------------------------------------------------------------
-- hscolour support.
-hscolour :: PackageDescription
- -> LocalBuildInfo
- -> [PPSuffixHandler]
- -> HscolourFlags
- -> IO ()
+hscolour
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> HscolourFlags
+ -> IO ()
hscolour = hscolour' dieNoVerbosity ForDevelopment
-hscolour' :: (String -> IO ()) -- ^ Called when the 'hscolour' exe is not found.
- -> HaddockTarget
- -> PackageDescription
- -> LocalBuildInfo
- -> [PPSuffixHandler]
- -> HscolourFlags
- -> IO ()
+hscolour'
+ :: (String -> IO ())
+ -- ^ Called when the 'hscolour' exe is not found.
+ -> HaddockTarget
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> HscolourFlags
+ -> IO ()
hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =
- either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg) =<<
- lookupProgramVersion verbosity hscolourProgram
- (orLaterVersion (mkVersion [1,8])) (withPrograms lbi)
+ either onNoHsColour (\(hscolourProg, _, _) -> go hscolourProg)
+ =<< lookupProgramVersion
+ verbosity
+ hscolourProgram
+ (orLaterVersion (mkVersion [1, 8]))
+ (withPrograms lbi)
where
go :: ConfiguredProgram -> IO ()
go hscolourProg = do
warn verbosity $
- "the 'cabal hscolour' command is deprecated in favour of 'cabal " ++
- "haddock --hyperlink-source' and will be removed in the next major " ++
- "release."
+ "the 'cabal hscolour' command is deprecated in favour of 'cabal "
+ ++ "haddock --hyperlink-source' and will be removed in the next major "
+ ++ "release."
setupMessage verbosity "Running hscolour for" (packageId pkg_descr)
createDirectoryIfMissingVerbose verbosity True $
@@ -973,11 +1143,14 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =
let
doExe com = case (compToExe com) of
Just exe -> do
- let outputDir = hscolourPref haddockTarget distPref pkg_descr
- </> unUnqualComponentName (exeName exe) </> "src"
+ let outputDir =
+ hscolourPref haddockTarget distPref pkg_descr
+ </> unUnqualComponentName (exeName exe)
+ </> "src"
runHsColour hscolourProg outputDir =<< getExeSourceFiles verbosity lbi exe clbi
Nothing -> do
- warn (fromFlag $ hscolourVerbosity flags)
+ warn
+ (fromFlag $ hscolourVerbosity flags)
"Unsupported component, skipping..."
return ()
case comp of
@@ -985,60 +1158,68 @@ hscolour' onNoHsColour haddockTarget pkg_descr lbi suffixes flags =
let outputDir = hscolourPref haddockTarget distPref pkg_descr </> "src"
runHsColour hscolourProg outputDir =<< getLibSourceFiles verbosity lbi lib clbi
CFLib flib -> do
- let outputDir = hscolourPref haddockTarget distPref pkg_descr
- </> unUnqualComponentName (foreignLibName flib) </> "src"
+ let outputDir =
+ hscolourPref haddockTarget distPref pkg_descr
+ </> unUnqualComponentName (foreignLibName flib)
+ </> "src"
runHsColour hscolourProg outputDir =<< getFLibSourceFiles verbosity lbi flib clbi
- CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp
- CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp
- CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp
+ CExe _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp
+ CTest _ -> when (fromFlag (hscolourTestSuites flags)) $ doExe comp
+ CBench _ -> when (fromFlag (hscolourBenchmarks flags)) $ doExe comp
stylesheet = flagToMaybe (hscolourCSS flags)
- verbosity = fromFlag (hscolourVerbosity flags)
- distPref = fromFlag (hscolourDistPref flags)
+ verbosity = fromFlag (hscolourVerbosity flags)
+ distPref = fromFlag (hscolourDistPref flags)
runHsColour prog outputDir moduleFiles = do
- createDirectoryIfMissingVerbose verbosity True outputDir
-
- case stylesheet of -- copy the CSS file
- Nothing | programVersion prog >= Just (mkVersion [1,9]) ->
- runProgram verbosity prog
- ["-print-css", "-o" ++ outputDir </> "hscolour.css"]
- | otherwise -> return ()
- Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")
-
- for_ moduleFiles $ \(m, inFile) ->
- runProgram verbosity prog
- ["-css", "-anchor", "-o" ++ outFile m, inFile]
- where
- outFile m = outputDir </>
- intercalate "-" (ModuleName.components m) <.> "html"
+ createDirectoryIfMissingVerbose verbosity True outputDir
+
+ case stylesheet of -- copy the CSS file
+ Nothing
+ | programVersion prog >= Just (mkVersion [1, 9]) ->
+ runProgram
+ verbosity
+ prog
+ ["-print-css", "-o" ++ outputDir </> "hscolour.css"]
+ | otherwise -> return ()
+ Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css")
+
+ for_ moduleFiles $ \(m, inFile) ->
+ runProgram
+ verbosity
+ prog
+ ["-css", "-anchor", "-o" ++ outFile m, inFile]
+ where
+ outFile m =
+ outputDir
+ </> intercalate "-" (ModuleName.components m) <.> "html"
haddockToHscolour :: HaddockFlags -> HscolourFlags
haddockToHscolour flags =
- HscolourFlags {
- hscolourCSS = haddockHscolourCss flags,
- hscolourExecutables = haddockExecutables flags,
- hscolourTestSuites = haddockTestSuites flags,
- hscolourBenchmarks = haddockBenchmarks flags,
- hscolourForeignLibs = haddockForeignLibs flags,
- hscolourVerbosity = haddockVerbosity flags,
- hscolourDistPref = haddockDistPref flags,
- hscolourCabalFilePath = haddockCabalFilePath flags
+ HscolourFlags
+ { hscolourCSS = haddockHscolourCss flags
+ , hscolourExecutables = haddockExecutables flags
+ , hscolourTestSuites = haddockTestSuites flags
+ , hscolourBenchmarks = haddockBenchmarks flags
+ , hscolourForeignLibs = haddockForeignLibs flags
+ , hscolourVerbosity = haddockVerbosity flags
+ , hscolourDistPref = haddockDistPref flags
+ , hscolourCabalFilePath = haddockCabalFilePath flags
}
-- ------------------------------------------------------------------------------
-- Boilerplate Monoid instance.
instance Monoid HaddockArgs where
- mempty = gmempty
- mappend = (<>)
+ mempty = gmempty
+ mappend = (<>)
instance Semigroup HaddockArgs where
- (<>) = gmappend
+ (<>) = gmappend
instance Monoid Directory where
- mempty = Dir "."
- mappend = (<>)
+ mempty = Dir "."
+ mappend = (<>)
instance Semigroup Directory where
- Dir m <> Dir n = Dir $ m </> n
+ Dir m <> Dir n = Dir $ m </> n
diff --git a/Cabal/src/Distribution/Simple/HaskellSuite.hs b/Cabal/src/Distribution/Simple/HaskellSuite.hs
index d40e4d46971a971eb6b9e5dd501fbaf2c794755b..cbd2fbf1a0779e7be5ea382b748bfcf719df0ae4 100644
--- a/Cabal/src/Distribution/Simple/HaskellSuite.hs
+++ b/Cabal/src/Distribution/Simple/HaskellSuite.hs
@@ -3,39 +3,41 @@
module Distribution.Simple.HaskellSuite where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import qualified Data.List.NonEmpty as NE
-import Distribution.Simple.Program
-import Distribution.Simple.Compiler
-import Distribution.Simple.Utils
-import Distribution.Simple.BuildPaths
-import Distribution.Verbosity
-import Distribution.Version
-import Distribution.Pretty
-import Distribution.Parsec (simpleParsec)
-import Distribution.Package
import Distribution.InstalledPackageInfo hiding (includeDirs)
-import Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Package
import Distribution.PackageDescription
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty
+import Distribution.Simple.BuildPaths
+import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
+import Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.Program
+import Distribution.Simple.Program.Builtin
+import Distribution.Simple.Utils
import Distribution.System (Platform)
import Distribution.Utils.Path
+import Distribution.Verbosity
+import Distribution.Version
import Language.Haskell.Extension
-import Distribution.Simple.Program.Builtin
configure
- :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)
+ :: Verbosity
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> ProgramDb
+ -> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity mbHcPath hcPkgPath progdb0 = do
-
-- We have no idea how a haskell-suite tool is named, so we require at
-- least some information from the user.
hcPath <-
let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)"
- in maybe (die' verbosity msg) return mbHcPath
+ in maybe (die' verbosity msg) return mbHcPath
when (isJust hcPkgPath) $
warn verbosity "--with-hc-pkg option is ignored for haskell-suite"
@@ -54,13 +56,13 @@ configure verbosity mbHcPath hcPkgPath progdb0 = do
progdb1
return (comp, Nothing, progdb2)
-
where
configureCompiler hcPath progdb0' = do
let
haskellSuiteProgram' =
haskellSuiteProgram
- { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath }
+ { programFindLocation = \v p -> findProgramOnSearchPath v p hcPath
+ }
-- NB: cannot call requireProgram right away — it'd think that
-- the program is already configured and won't reconfigure it again.
@@ -69,19 +71,20 @@ configure verbosity mbHcPath hcPkgPath progdb0 = do
(confdCompiler, progdb2) <- requireProgram verbosity haskellSuiteProgram' progdb1
extensions <- getExtensions verbosity confdCompiler
- languages <- getLanguages verbosity confdCompiler
+ languages <- getLanguages verbosity confdCompiler
(compName, compVersion) <-
getCompilerVersion verbosity confdCompiler
let
- comp = Compiler {
- compilerId = CompilerId (HaskellSuite compName) compVersion,
- compilerAbiTag = NoAbiTag,
- compilerCompat = [],
- compilerLanguages = languages,
- compilerExtensions = extensions,
- compilerProperties = mempty
- }
+ comp =
+ Compiler
+ { compilerId = CompilerId (HaskellSuite compName) compVersion
+ , compilerAbiTag = NoAbiTag
+ , compilerCompat = []
+ , compilerLanguages = languages
+ , compilerExtensions = extensions
+ , compilerProperties = mempty
+ }
return (comp, confdCompiler, progdb2)
@@ -106,51 +109,63 @@ getCompilerVersion verbosity prog = do
getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Maybe CompilerFlag)]
getExtensions verbosity prog = do
extStrs <-
- lines `fmap`
- rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]
+ lines
+ `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]
return
- [ (ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs ]
+ [(ext, Just $ "-X" ++ prettyShow ext) | Just ext <- map simpleParsec extStrs]
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, CompilerFlag)]
getLanguages verbosity prog = do
langStrs <-
- lines `fmap`
- rawSystemStdout verbosity (programPath prog) ["--supported-languages"]
+ lines
+ `fmap` rawSystemStdout verbosity (programPath prog) ["--supported-languages"]
return
- [ (ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs ]
+ [(ext, "-G" ++ prettyShow ext) | Just ext <- map simpleParsec langStrs]
-- Other compilers do some kind of a packagedb stack check here. Not sure
-- if we need something like that as well.
-getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb
- -> IO InstalledPackageIndex
+getInstalledPackages
+ :: Verbosity
+ -> PackageDBStack
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity packagedbs progdb =
liftM (PackageIndex.fromList . concat) $ for packagedbs $ \packagedb ->
- do str <-
- getDbProgramOutput verbosity haskellSuitePkgProgram progdb
- ["dump", packageDbOpt packagedb]
- `catchExit` \_ -> die' verbosity $ "pkg dump failed"
- case parsePackages str of
- Right ok -> return ok
- _ -> die' verbosity "failed to parse output of 'pkg dump'"
-
+ do
+ str <-
+ getDbProgramOutput
+ verbosity
+ haskellSuitePkgProgram
+ progdb
+ ["dump", packageDbOpt packagedb]
+ `catchExit` \_ -> die' verbosity $ "pkg dump failed"
+ case parsePackages str of
+ Right ok -> return ok
+ _ -> die' verbosity "failed to parse output of 'pkg dump'"
where
parsePackages str =
- case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of
- ([], ok) -> Right [ pkg | (_, pkg) <- ok ]
- (msgss, _) -> Left (foldMap NE.toList msgss)
+ case partitionEithers $ map (parseInstalledPackageInfo . toUTF8BS) (splitPkgs str) of
+ ([], ok) -> Right [pkg | (_, pkg) <- ok]
+ (msgss, _) -> Left (foldMap NE.toList msgss)
splitPkgs :: String -> [String]
splitPkgs = map unlines . splitWith ("---" ==) . lines
where
splitWith :: (a -> Bool) -> [a] -> [[a]]
- splitWith p xs = ys : case zs of
- [] -> []
- _:ws -> splitWith p ws
- where (ys,zs) = break p xs
+ splitWith p xs =
+ ys : case zs of
+ [] -> []
+ _ : ws -> splitWith p ws
+ where
+ (ys, zs) = break p xs
buildLib
- :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO ()
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildLib verbosity pkg_descr lbi lib clbi = do
-- In future, there should be a mechanism for the compiler to request any
-- number of the above parameters (or their parts) — in particular,
@@ -167,28 +182,37 @@ buildLib verbosity pkg_descr lbi lib clbi = do
pkgid = packageId pkg_descr
runDbProgram verbosity haskellSuiteProgram progdb $
- [ "compile", "--build-dir", odir ] ++
- concat [ ["-i", d] | d <- srcDirs ] ++
- concat [ ["-I", d] | d <- [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi
- ,odir] ++ includeDirs bi ] ++
- [ packageDbOpt pkgDb | pkgDb <- dbStack ] ++
- [ "--package-name", prettyShow pkgid ] ++
- concat [ ["--package-id", prettyShow ipkgid ]
- | (ipkgid, _) <- componentPackageDeps clbi ] ++
- ["-G", prettyShow language] ++
- concat [ ["-X", prettyShow ex] | ex <- usedExtensions bi ] ++
- cppOptions (libBuildInfo lib) ++
- [ prettyShow modu | modu <- allLibModules lib clbi ]
-
-
+ ["compile", "--build-dir", odir]
+ ++ concat [["-i", d] | d <- srcDirs]
+ ++ concat
+ [ ["-I", d]
+ | d <-
+ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ , odir
+ ]
+ ++ includeDirs bi
+ ]
+ ++ [packageDbOpt pkgDb | pkgDb <- dbStack]
+ ++ ["--package-name", prettyShow pkgid]
+ ++ concat
+ [ ["--package-id", prettyShow ipkgid]
+ | (ipkgid, _) <- componentPackageDeps clbi
+ ]
+ ++ ["-G", prettyShow language]
+ ++ concat [["-X", prettyShow ex] | ex <- usedExtensions bi]
+ ++ cppOptions (libBuildInfo lib)
+ ++ [prettyShow modu | modu <- allLibModules lib clbi]
installLib
:: Verbosity
-> LocalBuildInfo
- -> FilePath -- ^install location
- -> FilePath -- ^install location for dynamic libraries
- -> FilePath -- ^Build location
+ -> FilePath
+ -- ^ install location
+ -> FilePath
+ -- ^ install location for dynamic libraries
+ -> FilePath
+ -- ^ Build location
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
@@ -197,11 +221,16 @@ installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib clbi = do
let progdb = withPrograms lbi
runDbProgram verbosity haskellSuitePkgProgram progdb $
[ "install-library"
- , "--build-dir", builtDir
- , "--target-dir", targetDir
- , "--dynlib-target-dir", dynlibTargetDir
- , "--package-id", prettyShow $ packageId pkg
- ] ++ map prettyShow (allLibModules lib clbi)
+ , "--build-dir"
+ , builtDir
+ , "--target-dir"
+ , targetDir
+ , "--dynlib-target-dir"
+ , dynlibTargetDir
+ , "--package-id"
+ , prettyShow $ packageId pkg
+ ]
+ ++ map prettyShow (allLibModules lib clbi)
registerPackage
:: Verbosity
@@ -213,16 +242,22 @@ registerPackage verbosity progdb packageDbs installedPkgInfo = do
(hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram progdb
runProgramInvocation verbosity $
- (programInvocation hspkg
- ["update", packageDbOpt $ registrationPackageDB packageDbs])
- { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo }
+ ( programInvocation
+ hspkg
+ ["update", packageDbOpt $ registrationPackageDB packageDbs]
+ )
+ { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo installedPkgInfo
+ }
initPackageDB :: Verbosity -> ProgramDb -> FilePath -> IO ()
initPackageDB verbosity progdb dbPath =
- runDbProgram verbosity haskellSuitePkgProgram progdb
+ runDbProgram
+ verbosity
+ haskellSuitePkgProgram
+ progdb
["init", dbPath]
packageDbOpt :: PackageDB -> String
-packageDbOpt GlobalPackageDB = "--global"
-packageDbOpt UserPackageDB = "--user"
+packageDbOpt GlobalPackageDB = "--global"
+packageDbOpt UserPackageDB = "--user"
packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db
diff --git a/Cabal/src/Distribution/Simple/Hpc.hs b/Cabal/src/Distribution/Simple/Hpc.hs
index 4e292509d7899b46be464441e1e07f1740badf33..5d24f190b7ecb09a2aaa1b02529ba95eb7124c4c 100644
--- a/Cabal/src/Distribution/Simple/Hpc.hs
+++ b/Cabal/src/Distribution/Simple/Hpc.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Hpc
-- Copyright : Thomas Tuegel 2011
@@ -13,39 +14,39 @@
-- This module provides functions for locating various HPC-related paths and
-- a function for adding the necessary options to a PackageDescription to
-- build test suites with HPC enabled.
-
module Distribution.Simple.Hpc
- ( Way(..), guessWay
- , htmlDir
- , mixDir
- , tixDir
- , tixFilePath
- , markupPackage
- , markupTest
- ) where
+ ( Way (..)
+ , guessWay
+ , htmlDir
+ , mixDir
+ , tixDir
+ , tixFilePath
+ , markupPackage
+ , markupTest
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
-import Distribution.ModuleName ( main )
-import qualified Distribution.PackageDescription as PD
+import Distribution.ModuleName (main)
import Distribution.PackageDescription
- ( Library(..)
- , TestSuite(..)
- , testModules
- )
+ ( Library (..)
+ , TestSuite (..)
+ , testModules
+ )
+import qualified Distribution.PackageDescription as PD
import Distribution.Pretty
-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
import Distribution.Simple.Program
- ( hpcProgram
- , requireProgramVersion
- )
-import Distribution.Simple.Program.Hpc ( markup, union )
-import Distribution.Simple.Utils ( notice )
-import Distribution.Version ( anyVersion )
-import Distribution.Verbosity ( Verbosity() )
-import System.Directory ( createDirectoryIfMissing, doesFileExist )
+ ( hpcProgram
+ , requireProgramVersion
+ )
+import Distribution.Simple.Program.Hpc (markup, union)
+import Distribution.Simple.Utils (notice)
+import Distribution.Types.UnqualComponentName
+import Distribution.Verbosity (Verbosity ())
+import Distribution.Version (anyVersion)
+import System.Directory (createDirectoryIfMissing, doesFileExist)
import System.FilePath
-- -------------------------------------------------------------------------
@@ -54,9 +55,12 @@ import System.FilePath
data Way = Vanilla | Prof | Dyn
deriving (Bounded, Enum, Eq, Read, Show)
-hpcDir :: FilePath -- ^ \"dist/\" prefix
- -> Way
- -> FilePath -- ^ Directory containing component's HPC .mix files
+hpcDir
+ :: FilePath
+ -- ^ \"dist/\" prefix
+ -> Way
+ -> FilePath
+ -- ^ Directory containing component's HPC .mix files
hpcDir distPref way = distPref </> "hpc" </> wayDir
where
wayDir = case way of
@@ -64,51 +68,69 @@ hpcDir distPref way = distPref </> "hpc" </> wayDir
Prof -> "prof"
Dyn -> "dyn"
-mixDir :: FilePath -- ^ \"dist/\" prefix
- -> Way
- -> FilePath -- ^ Component name
- -> FilePath -- ^ Directory containing test suite's .mix files
+mixDir
+ :: FilePath
+ -- ^ \"dist/\" prefix
+ -> Way
+ -> FilePath
+ -- ^ Component name
+ -> FilePath
+ -- ^ Directory containing test suite's .mix files
mixDir distPref way name = hpcDir distPrefBuild way </> "mix" </> name
- where
- -- This is a hack for HPC over test suites, needed to match the directory
- -- where HPC saves and reads .mix files when the main library of the same
- -- package is being processed, perhaps in a previous cabal run (#5213).
- -- E.g., @distPref@ may be
- -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@
- -- but the path where library mix files reside has two less components
- -- at the end (@t/tests@) and this reduced path needs to be passed to
- -- both @hpc@ and @ghc@. For non-default optimization levels, the path
- -- suffix is one element longer and the extra path element needs
- -- to be preserved.
- distPrefElements = splitDirectories distPref
- distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of
- ["t", _, "noopt"] ->
- joinPath $ take (length distPrefElements - 3) distPrefElements
- ++ ["noopt"]
- ["t", _, "opt"] ->
- joinPath $ take (length distPrefElements - 3) distPrefElements
- ++ ["opt"]
- [_, "t", _] ->
- joinPath $ take (length distPrefElements - 2) distPrefElements
- _ -> distPref
+ where
+ -- This is a hack for HPC over test suites, needed to match the directory
+ -- where HPC saves and reads .mix files when the main library of the same
+ -- package is being processed, perhaps in a previous cabal run (#5213).
+ -- E.g., @distPref@ may be
+ -- @./dist-newstyle/build/x86_64-linux/ghc-9.0.1/cabal-gh5213-0.1/t/tests@
+ -- but the path where library mix files reside has two less components
+ -- at the end (@t/tests@) and this reduced path needs to be passed to
+ -- both @hpc@ and @ghc@. For non-default optimization levels, the path
+ -- suffix is one element longer and the extra path element needs
+ -- to be preserved.
+ distPrefElements = splitDirectories distPref
+ distPrefBuild = case drop (length distPrefElements - 3) distPrefElements of
+ ["t", _, "noopt"] ->
+ joinPath $
+ take (length distPrefElements - 3) distPrefElements
+ ++ ["noopt"]
+ ["t", _, "opt"] ->
+ joinPath $
+ take (length distPrefElements - 3) distPrefElements
+ ++ ["opt"]
+ [_, "t", _] ->
+ joinPath $ take (length distPrefElements - 2) distPrefElements
+ _ -> distPref
-tixDir :: FilePath -- ^ \"dist/\" prefix
- -> Way
- -> FilePath -- ^ Component name
- -> FilePath -- ^ Directory containing test suite's .tix files
+tixDir
+ :: FilePath
+ -- ^ \"dist/\" prefix
+ -> Way
+ -> FilePath
+ -- ^ Component name
+ -> FilePath
+ -- ^ Directory containing test suite's .tix files
tixDir distPref way name = hpcDir distPref way </> "tix" </> name
-- | Path to the .tix file containing a test suite's sum statistics.
-tixFilePath :: FilePath -- ^ \"dist/\" prefix
- -> Way
- -> FilePath -- ^ Component name
- -> FilePath -- ^ Path to test suite's .tix file
+tixFilePath
+ :: FilePath
+ -- ^ \"dist/\" prefix
+ -> Way
+ -> FilePath
+ -- ^ Component name
+ -> FilePath
+ -- ^ Path to test suite's .tix file
tixFilePath distPref way name = tixDir distPref way name </> name <.> "tix"
-htmlDir :: FilePath -- ^ \"dist/\" prefix
- -> Way
- -> FilePath -- ^ Component name
- -> FilePath -- ^ Path to test suite's HTML markup directory
+htmlDir
+ :: FilePath
+ -- ^ \"dist/\" prefix
+ -> Way
+ -> FilePath
+ -- ^ Component name
+ -> FilePath
+ -- ^ Path to test suite's HTML markup directory
htmlDir distPref way name = hpcDir distPref way </> "html" </> name
-- | Attempt to guess the way the test suites in this package were compiled
@@ -120,55 +142,76 @@ guessWay lbi
| otherwise = Vanilla
-- | Generate the HTML markup for a test suite.
-markupTest :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^ \"dist/\" prefix
- -> String -- ^ Library name
- -> TestSuite
- -> Library
- -> IO ()
+markupTest
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ \"dist/\" prefix
+ -> String
+ -- ^ Library name
+ -> TestSuite
+ -> Library
+ -> IO ()
markupTest verbosity lbi distPref libraryName suite library = do
- tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
- when tixFileExists $ do
- -- behaviour of 'markup' depends on version, so we need *a* version
- -- but no particular one
- (hpc, hpcVer, _) <- requireProgramVersion verbosity
- hpcProgram anyVersion (withPrograms lbi)
- let htmlDir_ = htmlDir distPref way testName'
- markup hpc hpcVer verbosity
- (tixFilePath distPref way testName') mixDirs
- htmlDir_
- (exposedModules library)
- notice verbosity $ "Test coverage report written to "
- ++ htmlDir_ </> "hpc_index" <.> "html"
+ tixFileExists <- doesFileExist $ tixFilePath distPref way $ testName'
+ when tixFileExists $ do
+ -- behaviour of 'markup' depends on version, so we need *a* version
+ -- but no particular one
+ (hpc, hpcVer, _) <-
+ requireProgramVersion
+ verbosity
+ hpcProgram
+ anyVersion
+ (withPrograms lbi)
+ let htmlDir_ = htmlDir distPref way testName'
+ markup
+ hpc
+ hpcVer
+ verbosity
+ (tixFilePath distPref way testName')
+ mixDirs
+ htmlDir_
+ (exposedModules library)
+ notice verbosity $
+ "Test coverage report written to "
+ ++ htmlDir_
+ </> "hpc_index" <.> "html"
where
way = guessWay lbi
testName' = unUnqualComponentName $ testName suite
- mixDirs = map (mixDir distPref way) [ testName', libraryName ]
+ mixDirs = map (mixDir distPref way) [testName', libraryName]
-- | Generate the HTML markup for all of a package's test suites.
-markupPackage :: Verbosity
- -> LocalBuildInfo
- -> FilePath -- ^ \"dist/\" prefix
- -> PD.PackageDescription
- -> [TestSuite]
- -> IO ()
+markupPackage
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -- ^ \"dist/\" prefix
+ -> PD.PackageDescription
+ -> [TestSuite]
+ -> IO ()
markupPackage verbosity lbi distPref pkg_descr suites = do
- let tixFiles = map (tixFilePath distPref way) testNames
- tixFilesExist <- traverse doesFileExist tixFiles
- when (and tixFilesExist) $ do
- -- behaviour of 'markup' depends on version, so we need *a* version
- -- but no particular one
- (hpc, hpcVer, _) <- requireProgramVersion verbosity
- hpcProgram anyVersion (withPrograms lbi)
- let outFile = tixFilePath distPref way libraryName
- htmlDir' = htmlDir distPref way libraryName
- excluded = concatMap testModules suites ++ [ main ]
- createDirectoryIfMissing True $ takeDirectory outFile
- union hpc verbosity tixFiles outFile excluded
- markup hpc hpcVer verbosity outFile mixDirs htmlDir' included
- notice verbosity $ "Package coverage report written to "
- ++ htmlDir' </> "hpc_index.html"
+ let tixFiles = map (tixFilePath distPref way) testNames
+ tixFilesExist <- traverse doesFileExist tixFiles
+ when (and tixFilesExist) $ do
+ -- behaviour of 'markup' depends on version, so we need *a* version
+ -- but no particular one
+ (hpc, hpcVer, _) <-
+ requireProgramVersion
+ verbosity
+ hpcProgram
+ anyVersion
+ (withPrograms lbi)
+ let outFile = tixFilePath distPref way libraryName
+ htmlDir' = htmlDir distPref way libraryName
+ excluded = concatMap testModules suites ++ [main]
+ createDirectoryIfMissing True $ takeDirectory outFile
+ union hpc verbosity tixFiles outFile excluded
+ markup hpc hpcVer verbosity outFile mixDirs htmlDir' included
+ notice verbosity $
+ "Package coverage report written to "
+ ++ htmlDir'
+ </> "hpc_index.html"
where
way = guessWay lbi
testNames = fmap (unUnqualComponentName . testName) suites
diff --git a/Cabal/src/Distribution/Simple/Install.hs b/Cabal/src/Distribution/Simple/Install.hs
index 432a94c7f228e3e99b16d564718de9ecaea1e761..f5034cf88b9e9edb410dccd5ee73fd9034ea3b74 100644
--- a/Cabal/src/Distribution/Simple/Install.hs
+++ b/Cabal/src/Distribution/Simple/Install.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Install
-- Copyright : Isaac Jones 2003-2004
@@ -14,66 +15,86 @@
-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into
-- place based on the prefix argument. It does the generic bits and then calls
-- compiler-specific functions to do the rest.
-
-module Distribution.Simple.Install (
- install,
+module Distribution.Simple.Install
+ ( install
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.TargetInfo
-import Distribution.Types.LocalBuildInfo
+import Distribution.Types.ExecutableScope
import Distribution.Types.ForeignLib
+import Distribution.Types.LocalBuildInfo
import Distribution.Types.PackageDescription
+import Distribution.Types.TargetInfo
import Distribution.Types.UnqualComponentName
-import Distribution.Types.ExecutableScope
import Distribution.Package
import Distribution.PackageDescription
-import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths (haddockName, haddockPref)
-import Distribution.Simple.Glob (matchDirFileGlob)
-import Distribution.Simple.Utils
- ( createDirectoryIfMissingVerbose
- , installDirectoryContents, installOrdinaryFile, isInSearchPath
- , die', info, noticeNoWrap, warn )
+import Distribution.Simple.BuildTarget
import Distribution.Simple.Compiler
- ( CompilerFlavor(..), compilerFlavor )
+ ( CompilerFlavor (..)
+ , compilerFlavor
+ )
import Distribution.Simple.Flag
- ( fromFlag )
+ ( fromFlag
+ )
+import Distribution.Simple.Glob (matchDirFileGlob)
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Setup.Copy
- ( CopyFlags(..) )
+ ( CopyFlags (..)
+ )
import Distribution.Simple.Setup.Haddock
- ( HaddockTarget(ForDevelopment) )
-import Distribution.Simple.BuildTarget
+ ( HaddockTarget (ForDevelopment)
+ )
+import Distribution.Simple.Utils
+ ( createDirectoryIfMissingVerbose
+ , die'
+ , info
+ , installDirectoryContents
+ , installOrdinaryFile
+ , isInSearchPath
+ , noticeNoWrap
+ , warn
+ )
import Distribution.Utils.Path (getSymbolicPath)
-import qualified Distribution.Simple.GHC as GHC
+import Distribution.Compat.Graph (IsNode (..))
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
-import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
-import Distribution.Compat.Graph (IsNode(..))
+import qualified Distribution.Simple.UHC as UHC
import System.Directory
- ( doesDirectoryExist, doesFileExist )
+ ( doesDirectoryExist
+ , doesFileExist
+ )
import System.FilePath
- ( takeFileName, takeDirectory, (</>), isRelative )
+ ( isRelative
+ , takeDirectory
+ , takeFileName
+ , (</>)
+ )
-import Distribution.Verbosity
import Distribution.Pretty
- ( prettyShow )
+ ( prettyShow
+ )
+import Distribution.Verbosity
--- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"
--- actions. Move files into place based on the prefix argument.
+-- | Perform the \"@.\/setup install@\" and \"@.\/setup copy@\"
+-- actions. Move files into place based on the prefix argument.
--
--- This does NOT register libraries, you should call 'register'
--- to do that.
-
-install :: PackageDescription -- ^information from the .cabal file
- -> LocalBuildInfo -- ^information from the configure step
- -> CopyFlags -- ^flags sent to copy or install
- -> IO ()
+-- This does NOT register libraries, you should call 'register'
+-- to do that.
+install
+ :: PackageDescription
+ -- ^ information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ information from the configure step
+ -> CopyFlags
+ -- ^ flags sent to copy or install
+ -> IO ()
install pkg_descr lbi flags = do
checkHasLibsOrExes
targets <- readTargetInfos verbosity pkg_descr lbi (copyArgs flags)
@@ -84,27 +105,33 @@ install pkg_descr lbi flags = do
withNeededTargetsInBuildOrder' pkg_descr lbi (map nodeKey targets) $ \target ->
let comp = targetComponent target
clbi = targetCLBI target
- in copyComponent verbosity pkg_descr lbi comp clbi copydest
- where
- distPref = fromFlag (copyDistPref flags)
- verbosity = fromFlag (copyVerbosity flags)
- copydest = fromFlag (copyDest flags)
+ in copyComponent verbosity pkg_descr lbi comp clbi copydest
+ where
+ distPref = fromFlag (copyDistPref flags)
+ verbosity = fromFlag (copyVerbosity flags)
+ copydest = fromFlag (copyDest flags)
- checkHasLibsOrExes =
- unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $
- die' verbosity "No executables and no library found. Nothing to do."
+ checkHasLibsOrExes =
+ unless (hasLibs pkg_descr || hasForeignLibs pkg_descr || hasExes pkg_descr) $
+ die' verbosity "No executables and no library found. Nothing to do."
-- | Copy package global files.
-copyPackage :: Verbosity -> PackageDescription
- -> LocalBuildInfo -> FilePath -> CopyDest -> IO ()
+copyPackage
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> FilePath
+ -> CopyDest
+ -> IO ()
copyPackage verbosity pkg_descr lbi distPref copydest = do
- let -- This is a bit of a hack, to handle files which are not
- -- per-component (data files and Haddock files.)
- InstallDirs {
- datadir = dataPref,
- docdir = docPref,
- htmldir = htmlPref,
- haddockdir = interfacePref
+ let
+ -- This is a bit of a hack, to handle files which are not
+ -- per-component (data files and Haddock files.)
+ InstallDirs
+ { datadir = dataPref
+ , docdir = docPref
+ , htmldir = htmlPref
+ , haddockdir = interfacePref
} = absoluteInstallCommandDirs pkg_descr lbi (localUnitId lbi) copydest
-- Install (package-global) data files
@@ -113,30 +140,40 @@ copyPackage verbosity pkg_descr lbi distPref copydest = do
-- Install (package-global) Haddock files
-- TODO: these should be done per-library
docExists <- doesDirectoryExist $ haddockPref ForDevelopment distPref pkg_descr
- info verbosity ("directory " ++ haddockPref ForDevelopment distPref pkg_descr ++
- " does exist: " ++ show docExists)
+ info
+ verbosity
+ ( "directory "
+ ++ haddockPref ForDevelopment distPref pkg_descr
+ ++ " does exist: "
+ ++ show docExists
+ )
-- TODO: this is a bit questionable, Haddock files really should
-- be per library (when there are convenience libraries.)
when docExists $ do
- createDirectoryIfMissingVerbose verbosity True htmlPref
- installDirectoryContents verbosity
- (haddockPref ForDevelopment distPref pkg_descr) htmlPref
- -- setPermissionsRecursive [Read] htmlPref
- -- The haddock interface file actually already got installed
- -- in the recursive copy, but now we install it where we actually
- -- want it to be (normally the same place). We could remove the
- -- copy in htmlPref first.
- let haddockInterfaceFileSrc = haddockPref ForDevelopment distPref pkg_descr
- </> haddockName pkg_descr
- haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr
- -- We only generate the haddock interface file for libs, So if the
- -- package consists only of executables there will not be one:
- exists <- doesFileExist haddockInterfaceFileSrc
- when exists $ do
- createDirectoryIfMissingVerbose verbosity True interfacePref
- installOrdinaryFile verbosity haddockInterfaceFileSrc
- haddockInterfaceFileDest
+ createDirectoryIfMissingVerbose verbosity True htmlPref
+ installDirectoryContents
+ verbosity
+ (haddockPref ForDevelopment distPref pkg_descr)
+ htmlPref
+ -- setPermissionsRecursive [Read] htmlPref
+ -- The haddock interface file actually already got installed
+ -- in the recursive copy, but now we install it where we actually
+ -- want it to be (normally the same place). We could remove the
+ -- copy in htmlPref first.
+ let haddockInterfaceFileSrc =
+ haddockPref ForDevelopment distPref pkg_descr
+ </> haddockName pkg_descr
+ haddockInterfaceFileDest = interfacePref </> haddockName pkg_descr
+ -- We only generate the haddock interface file for libs, So if the
+ -- package consists only of executables there will not be one:
+ exists <- doesFileExist haddockInterfaceFileSrc
+ when exists $ do
+ createDirectoryIfMissingVerbose verbosity True interfacePref
+ installOrdinaryFile
+ verbosity
+ haddockInterfaceFileSrc
+ haddockInterfaceFileDest
let lfiles = licenseFiles pkg_descr
unless (null lfiles) $ do
@@ -147,118 +184,146 @@ copyPackage verbosity pkg_descr lbi distPref copydest = do
installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)
-- | Copy files associated with a component.
-copyComponent :: Verbosity -> PackageDescription
- -> LocalBuildInfo -> Component -> ComponentLocalBuildInfo
- -> CopyDest
- -> IO ()
+copyComponent
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Component
+ -> ComponentLocalBuildInfo
+ -> CopyDest
+ -> IO ()
copyComponent verbosity pkg_descr lbi (CLib lib) clbi copydest = do
- let InstallDirs{
- libdir = libPref,
- dynlibdir = dynlibPref,
- includedir = incPref
- } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest
- buildPref = componentBuildDir lbi clbi
-
- case libName lib of
- LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref)
- LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref)
+ let InstallDirs
+ { libdir = libPref
+ , dynlibdir = dynlibPref
+ , includedir = incPref
+ } = absoluteInstallCommandDirs pkg_descr lbi (componentUnitId clbi) copydest
+ buildPref = componentBuildDir lbi clbi
- -- install include files for all compilers - they may be needed to compile
- -- haskell files (using the CPP extension)
- installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref
+ case libName lib of
+ LMainLibName -> noticeNoWrap verbosity ("Installing library in " ++ libPref)
+ LSubLibName n -> noticeNoWrap verbosity ("Installing internal library " ++ prettyShow n ++ " in " ++ libPref)
- case compilerFlavor (compiler lbi) of
- GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
- GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
- UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
- HaskellSuite _ -> HaskellSuite.installLib
- verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
- _ -> die' verbosity $ "installing with "
- ++ prettyShow (compilerFlavor (compiler lbi))
- ++ " is not implemented"
+ -- install include files for all compilers - they may be needed to compile
+ -- haskell files (using the CPP extension)
+ installIncludeFiles verbosity (libBuildInfo lib) lbi buildPref incPref
+ case compilerFlavor (compiler lbi) of
+ GHC -> GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
+ GHCJS -> GHCJS.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
+ UHC -> UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr lib clbi
+ HaskellSuite _ ->
+ HaskellSuite.installLib
+ verbosity
+ lbi
+ libPref
+ dynlibPref
+ buildPref
+ pkg_descr
+ lib
+ clbi
+ _ ->
+ die' verbosity $
+ "installing with "
+ ++ prettyShow (compilerFlavor (compiler lbi))
+ ++ " is not implemented"
copyComponent verbosity pkg_descr lbi (CFLib flib) clbi copydest = do
- let InstallDirs{
- flibdir = flibPref,
- includedir = incPref
- } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest
- buildPref = componentBuildDir lbi clbi
+ let InstallDirs
+ { flibdir = flibPref
+ , includedir = incPref
+ } = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest
+ buildPref = componentBuildDir lbi clbi
- noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref)
- installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref
-
- case compilerFlavor (compiler lbi) of
- GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib
- GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib
- _ -> die' verbosity $ "installing foreign lib with "
- ++ prettyShow (compilerFlavor (compiler lbi))
- ++ " is not implemented"
+ noticeNoWrap verbosity ("Installing foreign library " ++ unUnqualComponentName (foreignLibName flib) ++ " in " ++ flibPref)
+ installIncludeFiles verbosity (foreignLibBuildInfo flib) lbi buildPref incPref
+ case compilerFlavor (compiler lbi) of
+ GHC -> GHC.installFLib verbosity lbi flibPref buildPref pkg_descr flib
+ GHCJS -> GHCJS.installFLib verbosity lbi flibPref buildPref pkg_descr flib
+ _ ->
+ die' verbosity $
+ "installing foreign lib with "
+ ++ prettyShow (compilerFlavor (compiler lbi))
+ ++ " is not implemented"
copyComponent verbosity pkg_descr lbi (CExe exe) clbi copydest = do
- let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest
- -- the installers know how to find the actual location of the
- -- binaries
- buildPref = buildDir lbi
- uid = componentUnitId clbi
- pkgid = packageId pkg_descr
- binPref | ExecutablePrivate <- exeScope exe = libexecdir installDirs
- | otherwise = bindir installDirs
- progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi)
- progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi)
- progFix = (progPrefixPref, progSuffixPref)
- noticeNoWrap verbosity ("Installing executable " ++ prettyShow (exeName exe)
- ++ " in " ++ binPref)
- inPath <- isInSearchPath binPref
- when (not inPath) $
- warn verbosity ("The directory " ++ binPref
- ++ " is not in the system search path.")
- case compilerFlavor (compiler lbi) of
- GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe
- GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe
- UHC -> return ()
- HaskellSuite {} -> return ()
- _ -> die' verbosity $ "installing with "
- ++ prettyShow (compilerFlavor (compiler lbi))
- ++ " is not implemented"
+ let installDirs = absoluteComponentInstallDirs pkg_descr lbi (componentUnitId clbi) copydest
+ -- the installers know how to find the actual location of the
+ -- binaries
+ buildPref = buildDir lbi
+ uid = componentUnitId clbi
+ pkgid = packageId pkg_descr
+ binPref
+ | ExecutablePrivate <- exeScope exe = libexecdir installDirs
+ | otherwise = bindir installDirs
+ progPrefixPref = substPathTemplate pkgid lbi uid (progPrefix lbi)
+ progSuffixPref = substPathTemplate pkgid lbi uid (progSuffix lbi)
+ progFix = (progPrefixPref, progSuffixPref)
+ noticeNoWrap
+ verbosity
+ ( "Installing executable "
+ ++ prettyShow (exeName exe)
+ ++ " in "
+ ++ binPref
+ )
+ inPath <- isInSearchPath binPref
+ when (not inPath) $
+ warn
+ verbosity
+ ( "The directory "
+ ++ binPref
+ ++ " is not in the system search path."
+ )
+ case compilerFlavor (compiler lbi) of
+ GHC -> GHC.installExe verbosity lbi binPref buildPref progFix pkg_descr exe
+ GHCJS -> GHCJS.installExe verbosity lbi binPref buildPref progFix pkg_descr exe
+ UHC -> return ()
+ HaskellSuite{} -> return ()
+ _ ->
+ die' verbosity $
+ "installing with "
+ ++ prettyShow (compilerFlavor (compiler lbi))
+ ++ " is not implemented"
-- Nothing to do for benchmark/testsuite
copyComponent _ _ _ (CBench _) _ _ = return ()
copyComponent _ _ _ (CTest _) _ _ = return ()
-- | Install the files listed in data-files
---
installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO ()
installDataFiles verbosity pkg_descr destDataDir =
- flip traverse_ (dataFiles pkg_descr) $ \ glob -> do
+ flip traverse_ (dataFiles pkg_descr) $ \glob -> do
let srcDataDirRaw = dataDir pkg_descr
- srcDataDir = if null srcDataDirRaw
- then "."
- else srcDataDirRaw
+ srcDataDir =
+ if null srcDataDirRaw
+ then "."
+ else srcDataDirRaw
files <- matchDirFileGlob verbosity (specVersion pkg_descr) srcDataDir glob
- for_ files $ \ file' -> do
+ for_ files $ \file' -> do
let src = srcDataDir </> file'
dst = destDataDir </> file'
createDirectoryIfMissingVerbose verbosity True (takeDirectory dst)
installOrdinaryFile verbosity src dst
-- | Install the files listed in install-includes for a library
---
installIncludeFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()
installIncludeFiles verbosity libBi lbi buildPref destIncludeDir = do
- let relincdirs = "." : filter isRelative (includeDirs libBi)
- incdirs = [ baseDir lbi </> dir | dir <- relincdirs ]
- ++ [ buildPref </> dir | dir <- relincdirs ]
- incs <- traverse (findInc incdirs) (installIncludes libBi)
- sequence_
- [ do createDirectoryIfMissingVerbose verbosity True destDir
- installOrdinaryFile verbosity srcFile destFile
- | (relFile, srcFile) <- incs
- , let destFile = destIncludeDir </> relFile
- destDir = takeDirectory destFile ]
+ let relincdirs = "." : filter isRelative (includeDirs libBi)
+ incdirs =
+ [baseDir lbi </> dir | dir <- relincdirs]
+ ++ [buildPref </> dir | dir <- relincdirs]
+ incs <- traverse (findInc incdirs) (installIncludes libBi)
+ sequence_
+ [ do
+ createDirectoryIfMissingVerbose verbosity True destDir
+ installOrdinaryFile verbosity srcFile destFile
+ | (relFile, srcFile) <- incs
+ , let destFile = destIncludeDir </> relFile
+ destDir = takeDirectory destFile
+ ]
where
- baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')
- findInc [] file = die' verbosity ("can't find include file " ++ file)
- findInc (dir:dirs) file = do
- let path = dir </> file
- exists <- doesFileExist path
- if exists then return (file, path) else findInc dirs file
+ baseDir lbi' = fromMaybe "" (takeDirectory <$> cabalFilePath lbi')
+ findInc [] file = die' verbosity ("can't find include file " ++ file)
+ findInc (dir : dirs) file = do
+ let path = dir </> file
+ exists <- doesFileExist path
+ if exists then return (file, path) else findInc dirs file
diff --git a/Cabal/src/Distribution/Simple/InstallDirs.hs b/Cabal/src/Distribution/Simple/InstallDirs.hs
index 739b87d58c9067a73391c5332a325378495d967d..c77ee8a99b2941e4aa158589eae293b8cee53e97 100644
--- a/Cabal/src/Distribution/Simple/InstallDirs.hs
+++ b/Cabal/src/Distribution/Simple/InstallDirs.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.InstallDirs
-- Copyright : Isaac Jones 2003-2004
@@ -22,48 +23,49 @@
-- changing the prefix all other dirs still end up changed appropriately. So it
-- provides a 'PathTemplate' type and functions for substituting for these
-- templates.
-
-module Distribution.Simple.InstallDirs (
- InstallDirs(..),
- InstallDirTemplates,
- defaultInstallDirs,
- defaultInstallDirs',
- combineInstallDirs,
- absoluteInstallDirs,
- CopyDest(..),
- prefixRelativeInstallDirs,
- substituteInstallDirTemplates,
-
- PathTemplate,
- PathTemplateVariable(..),
- PathTemplateEnv,
- toPathTemplate,
- fromPathTemplate,
- combinePathTemplate,
- substPathTemplate,
- initialPathTemplateEnv,
- platformTemplateEnv,
- compilerTemplateEnv,
- packageTemplateEnv,
- abiTemplateEnv,
- installDirsTemplateEnv,
+module Distribution.Simple.InstallDirs
+ ( InstallDirs (..)
+ , InstallDirTemplates
+ , defaultInstallDirs
+ , defaultInstallDirs'
+ , combineInstallDirs
+ , absoluteInstallDirs
+ , CopyDest (..)
+ , prefixRelativeInstallDirs
+ , substituteInstallDirTemplates
+ , PathTemplate
+ , PathTemplateVariable (..)
+ , PathTemplateEnv
+ , toPathTemplate
+ , fromPathTemplate
+ , combinePathTemplate
+ , substPathTemplate
+ , initialPathTemplateEnv
+ , platformTemplateEnv
+ , compilerTemplateEnv
+ , packageTemplateEnv
+ , abiTemplateEnv
+ , installDirsTemplateEnv
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Compat.Environment (lookupEnv)
-import Distribution.Pretty
-import Distribution.Package
-import Distribution.System
import Distribution.Compiler
+import Distribution.Package
+import Distribution.Pretty
import Distribution.Simple.InstallDirs.Internal
+import Distribution.System
import System.Directory (getAppUserDataDirectory)
import System.FilePath
- ( (</>), isPathSeparator
- , pathSeparator, dropDrive
- , takeDirectory )
+ ( dropDrive
+ , isPathSeparator
+ , pathSeparator
+ , takeDirectory
+ , (</>)
+ )
#ifdef mingw32_HOST_OS
import qualified Prelude
@@ -74,32 +76,32 @@ import Foreign.C
-- ---------------------------------------------------------------------------
-- Installation directories
-
-- | The directories where we will install files for packages.
--
-- We have several different directories for different types of files since
-- many systems have conventions whereby different types of files in a package
-- are installed in different directories. This is particularly the case on
-- Unix style systems.
---
-data InstallDirs dir = InstallDirs {
- prefix :: dir,
- bindir :: dir,
- libdir :: dir,
- libsubdir :: dir,
- dynlibdir :: dir,
- flibdir :: dir, -- ^ foreign libraries
- libexecdir :: dir,
- libexecsubdir:: dir,
- includedir :: dir,
- datadir :: dir,
- datasubdir :: dir,
- docdir :: dir,
- mandir :: dir,
- htmldir :: dir,
- haddockdir :: dir,
- sysconfdir :: dir
- } deriving (Eq, Read, Show, Functor, Generic, Typeable)
+data InstallDirs dir = InstallDirs
+ { prefix :: dir
+ , bindir :: dir
+ , libdir :: dir
+ , libsubdir :: dir
+ , dynlibdir :: dir
+ , flibdir :: dir
+ -- ^ foreign libraries
+ , libexecdir :: dir
+ , libexecsubdir :: dir
+ , includedir :: dir
+ , datadir :: dir
+ , datasubdir :: dir
+ , docdir :: dir
+ , mandir :: dir
+ , htmldir :: dir
+ , haddockdir :: dir
+ , sysconfdir :: dir
+ }
+ deriving (Eq, Read, Show, Functor, Generic, Typeable)
instance Binary dir => Binary (InstallDirs dir)
instance Structured dir => Structured (InstallDirs dir)
@@ -111,38 +113,41 @@ instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
instance Semigroup dir => Semigroup (InstallDirs dir) where
(<>) = gmappend
-combineInstallDirs :: (a -> b -> c)
- -> InstallDirs a
- -> InstallDirs b
- -> InstallDirs c
-combineInstallDirs combine a b = InstallDirs {
- prefix = prefix a `combine` prefix b,
- bindir = bindir a `combine` bindir b,
- libdir = libdir a `combine` libdir b,
- libsubdir = libsubdir a `combine` libsubdir b,
- dynlibdir = dynlibdir a `combine` dynlibdir b,
- flibdir = flibdir a `combine` flibdir b,
- libexecdir = libexecdir a `combine` libexecdir b,
- libexecsubdir= libexecsubdir a `combine` libexecsubdir b,
- includedir = includedir a `combine` includedir b,
- datadir = datadir a `combine` datadir b,
- datasubdir = datasubdir a `combine` datasubdir b,
- docdir = docdir a `combine` docdir b,
- mandir = mandir a `combine` mandir b,
- htmldir = htmldir a `combine` htmldir b,
- haddockdir = haddockdir a `combine` haddockdir b,
- sysconfdir = sysconfdir a `combine` sysconfdir b
- }
+combineInstallDirs
+ :: (a -> b -> c)
+ -> InstallDirs a
+ -> InstallDirs b
+ -> InstallDirs c
+combineInstallDirs combine a b =
+ InstallDirs
+ { prefix = prefix a `combine` prefix b
+ , bindir = bindir a `combine` bindir b
+ , libdir = libdir a `combine` libdir b
+ , libsubdir = libsubdir a `combine` libsubdir b
+ , dynlibdir = dynlibdir a `combine` dynlibdir b
+ , flibdir = flibdir a `combine` flibdir b
+ , libexecdir = libexecdir a `combine` libexecdir b
+ , libexecsubdir = libexecsubdir a `combine` libexecsubdir b
+ , includedir = includedir a `combine` includedir b
+ , datadir = datadir a `combine` datadir b
+ , datasubdir = datasubdir a `combine` datasubdir b
+ , docdir = docdir a `combine` docdir b
+ , mandir = mandir a `combine` mandir b
+ , htmldir = htmldir a `combine` htmldir b
+ , haddockdir = haddockdir a `combine` haddockdir b
+ , sysconfdir = sysconfdir a `combine` sysconfdir b
+ }
appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a
-appendSubdirs append dirs = dirs {
- libdir = libdir dirs `append` libsubdir dirs,
- libexecdir = libexecdir dirs `append` libexecsubdir dirs,
- datadir = datadir dirs `append` datasubdir dirs,
- libsubdir = error "internal error InstallDirs.libsubdir",
- libexecsubdir = error "internal error InstallDirs.libexecsubdir",
- datasubdir = error "internal error InstallDirs.datasubdir"
- }
+appendSubdirs append dirs =
+ dirs
+ { libdir = libdir dirs `append` libsubdir dirs
+ , libexecdir = libexecdir dirs `append` libexecsubdir dirs
+ , datadir = datadir dirs `append` datasubdir dirs
+ , libsubdir = error "internal error InstallDirs.libsubdir"
+ , libexecsubdir = error "internal error InstallDirs.libexecsubdir"
+ , datasubdir = error "internal error InstallDirs.datasubdir"
+ }
-- | The installation directories in terms of 'PathTemplate's that contain
-- variables.
@@ -165,7 +170,6 @@ appendSubdirs append dirs = dirs {
--
-- An additional complication is the need to support relocatable packages on
-- systems which support such things, like Windows.
---
type InstallDirTemplates = InstallDirs PathTemplate
-- ---------------------------------------------------------------------------
@@ -174,56 +178,66 @@ type InstallDirTemplates = InstallDirs PathTemplate
defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
defaultInstallDirs = defaultInstallDirs' False
-defaultInstallDirs' :: Bool {- use external internal deps -}
- -> CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates
+defaultInstallDirs'
+ :: Bool {- use external internal deps -}
+ -> CompilerFlavor
+ -> Bool
+ -> Bool
+ -> IO InstallDirTemplates
defaultInstallDirs' True comp userInstall hasLibs = do
dflt <- defaultInstallDirs' False comp userInstall hasLibs
-- Be a bit more hermetic about per-component installs
- return dflt { datasubdir = toPathTemplate $ "$abi" </> "$libname",
- docdir = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"
- }
+ return
+ dflt
+ { datasubdir = toPathTemplate $ "$abi" </> "$libname"
+ , docdir = toPathTemplate $ "$datadir" </> "doc" </> "$abi" </> "$libname"
+ }
defaultInstallDirs' False comp userInstall _hasLibs = do
installPrefix <-
- if userInstall
+ if userInstall
then do
mDir <- lookupEnv "CABAL_DIR"
case mDir of
Nothing -> getAppUserDataDirectory "cabal"
Just dir -> return dir
else case buildOS of
- Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir
- return (windowsProgramFilesDir </> "Haskell")
- _ -> return "/usr/local"
+ Windows -> do
+ windowsProgramFilesDir <- getWindowsProgramFilesDir
+ return (windowsProgramFilesDir </> "Haskell")
+ _ -> return "/usr/local"
installLibDir <-
- case buildOS of
+ case buildOS of
Windows -> return "$prefix"
- _ -> return ("$prefix" </> "lib")
- return $ fmap toPathTemplate $ InstallDirs {
- prefix = installPrefix,
- bindir = "$prefix" </> "bin",
- libdir = installLibDir,
- libsubdir = case comp of
- UHC -> "$pkgid"
- _other -> "$abi" </> "$libname",
- dynlibdir = "$libdir" </> case comp of
- UHC -> "$pkgid"
- _other -> "$abi",
- libexecsubdir= "$abi" </> "$pkgid",
- flibdir = "$libdir",
- libexecdir = case buildOS of
- Windows -> "$prefix" </> "$libname"
- _other -> "$prefix" </> "libexec",
- includedir = "$libdir" </> "$libsubdir" </> "include",
- datadir = case buildOS of
- Windows -> "$prefix"
- _other -> "$prefix" </> "share",
- datasubdir = "$abi" </> "$pkgid",
- docdir = "$datadir" </> "doc" </> "$abi" </> "$pkgid",
- mandir = "$datadir" </> "man",
- htmldir = "$docdir" </> "html",
- haddockdir = "$htmldir",
- sysconfdir = "$prefix" </> "etc"
- }
+ _ -> return ("$prefix" </> "lib")
+ return $
+ fmap toPathTemplate $
+ InstallDirs
+ { prefix = installPrefix
+ , bindir = "$prefix" </> "bin"
+ , libdir = installLibDir
+ , libsubdir = case comp of
+ UHC -> "$pkgid"
+ _other -> "$abi" </> "$libname"
+ , dynlibdir =
+ "$libdir" </> case comp of
+ UHC -> "$pkgid"
+ _other -> "$abi"
+ , libexecsubdir = "$abi" </> "$pkgid"
+ , flibdir = "$libdir"
+ , libexecdir = case buildOS of
+ Windows -> "$prefix" </> "$libname"
+ _other -> "$prefix" </> "libexec"
+ , includedir = "$libdir" </> "$libsubdir" </> "include"
+ , datadir = case buildOS of
+ Windows -> "$prefix"
+ _other -> "$prefix" </> "share"
+ , datasubdir = "$abi" </> "$pkgid"
+ , docdir = "$datadir" </> "doc" </> "$abi" </> "$pkgid"
+ , mandir = "$datadir" </> "man"
+ , htmldir = "$docdir" </> "html"
+ , haddockdir = "$htmldir"
+ , sysconfdir = "$prefix" </> "etc"
+ }
-- ---------------------------------------------------------------------------
-- Converting directories, absolute or prefix-relative
@@ -239,77 +253,84 @@ defaultInstallDirs' False comp userInstall _hasLibs = do
-- can replace 'prefix' with the 'PrefixVar' and get resulting
-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it
-- each to check which paths are relative to the $prefix.
---
-substituteInstallDirTemplates :: PathTemplateEnv
- -> InstallDirTemplates -> InstallDirTemplates
+substituteInstallDirTemplates
+ :: PathTemplateEnv
+ -> InstallDirTemplates
+ -> InstallDirTemplates
substituteInstallDirTemplates env dirs = dirs'
where
- dirs' = InstallDirs {
- -- So this specifies exactly which vars are allowed in each template
- prefix = subst prefix [],
- bindir = subst bindir [prefixVar],
- libdir = subst libdir [prefixVar, bindirVar],
- libsubdir = subst libsubdir [],
- dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar],
- flibdir = subst flibdir [prefixVar, bindirVar, libdirVar],
- libexecdir = subst libexecdir prefixBinLibVars,
- libexecsubdir = subst libexecsubdir [],
- includedir = subst includedir prefixBinLibVars,
- datadir = subst datadir prefixBinLibVars,
- datasubdir = subst datasubdir [],
- docdir = subst docdir prefixBinLibDataVars,
- mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]),
- htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]),
- haddockdir = subst haddockdir (prefixBinLibDataVars ++
- [docdirVar, htmldirVar]),
- sysconfdir = subst sysconfdir prefixBinLibVars
- }
- subst dir env' = substPathTemplate (env'++env) (dir dirs)
-
- prefixVar = (PrefixVar, prefix dirs')
- bindirVar = (BindirVar, bindir dirs')
- libdirVar = (LibdirVar, libdir dirs')
- libsubdirVar = (LibsubdirVar, libsubdir dirs')
- datadirVar = (DatadirVar, datadir dirs')
- datasubdirVar = (DatasubdirVar, datasubdir dirs')
- docdirVar = (DocdirVar, docdir dirs')
- htmldirVar = (HtmldirVar, htmldir dirs')
+ dirs' =
+ InstallDirs
+ { -- So this specifies exactly which vars are allowed in each template
+ prefix = subst prefix []
+ , bindir = subst bindir [prefixVar]
+ , libdir = subst libdir [prefixVar, bindirVar]
+ , libsubdir = subst libsubdir []
+ , dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar]
+ , flibdir = subst flibdir [prefixVar, bindirVar, libdirVar]
+ , libexecdir = subst libexecdir prefixBinLibVars
+ , libexecsubdir = subst libexecsubdir []
+ , includedir = subst includedir prefixBinLibVars
+ , datadir = subst datadir prefixBinLibVars
+ , datasubdir = subst datasubdir []
+ , docdir = subst docdir prefixBinLibDataVars
+ , mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar])
+ , htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar])
+ , haddockdir =
+ subst
+ haddockdir
+ ( prefixBinLibDataVars
+ ++ [docdirVar, htmldirVar]
+ )
+ , sysconfdir = subst sysconfdir prefixBinLibVars
+ }
+ subst dir env' = substPathTemplate (env' ++ env) (dir dirs)
+
+ prefixVar = (PrefixVar, prefix dirs')
+ bindirVar = (BindirVar, bindir dirs')
+ libdirVar = (LibdirVar, libdir dirs')
+ libsubdirVar = (LibsubdirVar, libsubdir dirs')
+ datadirVar = (DatadirVar, datadir dirs')
+ datasubdirVar = (DatasubdirVar, datasubdir dirs')
+ docdirVar = (DocdirVar, docdir dirs')
+ htmldirVar = (HtmldirVar, htmldir dirs')
prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar]
prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar]
-- | Convert from abstract install directories to actual absolute ones by
-- substituting for all the variables in the abstract paths, to get real
-- absolute path.
-absoluteInstallDirs :: PackageIdentifier
- -> UnitId
- -> CompilerInfo
- -> CopyDest
- -> Platform
- -> InstallDirs PathTemplate
- -> InstallDirs FilePath
+absoluteInstallDirs
+ :: PackageIdentifier
+ -> UnitId
+ -> CompilerInfo
+ -> CopyDest
+ -> Platform
+ -> InstallDirs PathTemplate
+ -> InstallDirs FilePath
absoluteInstallDirs pkgId libname compilerId copydest platform dirs =
- (case copydest of
- CopyTo destdir -> fmap ((destdir </>) . dropDrive)
- CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir))
- _ -> id)
- . appendSubdirs (</>)
- . fmap fromPathTemplate
- $ substituteInstallDirTemplates env dirs
+ ( case copydest of
+ CopyTo destdir -> fmap ((destdir </>) . dropDrive)
+ CopyToDb dbdir -> fmap (substPrefix "${pkgroot}" (takeDirectory dbdir))
+ _ -> id
+ )
+ . appendSubdirs (</>)
+ . fmap fromPathTemplate
+ $ substituteInstallDirTemplates env dirs
where
env = initialPathTemplateEnv pkgId libname compilerId platform
substPrefix pre root path
| pre `isPrefixOf` path = root ++ drop (length pre) path
- | otherwise = path
+ | otherwise = path
-
--- |The location prefix for the /copy/ command.
+-- | The location prefix for the /copy/ command.
data CopyDest
= NoCopyDest
| CopyTo FilePath
- | CopyToDb FilePath
- -- ^ when using the ${pkgroot} as prefix. The CopyToDb will
- -- adjust the paths to be relative to the provided package
- -- database when copying / installing.
+ | -- | when using the ${pkgroot} as prefix. The CopyToDb will
+ -- adjust the paths to be relative to the provided package
+ -- database when copying / installing.
+ CopyToDb FilePath
deriving (Eq, Show, Generic)
instance Binary CopyDest
@@ -319,22 +340,23 @@ instance Binary CopyDest
-- If any of the paths are not relative, ie they are absolute paths, then it
-- prevents us from making a relocatable package (also known as a \"prefix
-- independent\" package).
---
-prefixRelativeInstallDirs :: PackageIdentifier
- -> UnitId
- -> CompilerInfo
- -> Platform
- -> InstallDirTemplates
- -> InstallDirs (Maybe FilePath)
+prefixRelativeInstallDirs
+ :: PackageIdentifier
+ -> UnitId
+ -> CompilerInfo
+ -> Platform
+ -> InstallDirTemplates
+ -> InstallDirs (Maybe FilePath)
prefixRelativeInstallDirs pkgId libname compilerId platform dirs =
- fmap relative
- . appendSubdirs combinePathTemplate
- $ -- substitute the path template into each other, except that we map
+ fmap relative
+ . appendSubdirs combinePathTemplate
+ $ substituteInstallDirTemplates -- substitute the path template into each other, except that we map
-- \$prefix back to $prefix. We're trying to end up with templates that
-- mention no vars except $prefix.
- substituteInstallDirTemplates env dirs {
- prefix = PathTemplate [Variable PrefixVar]
- }
+ env
+ dirs
+ { prefix = PathTemplate [Variable PrefixVar]
+ }
where
env = initialPathTemplateEnv pkgId libname compilerId platform
@@ -342,17 +364,16 @@ prefixRelativeInstallDirs pkgId libname compilerId platform dirs =
-- path by stripping off $prefix/ or $prefix
relative dir = case dir of
PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs)
- relative' (Variable PrefixVar : Ordinary (s:rest) : rest')
- | isPathSeparator s = Just (Ordinary rest : rest')
+ relative' (Variable PrefixVar : Ordinary (s : rest) : rest')
+ | isPathSeparator s = Just (Ordinary rest : rest')
relative' (Variable PrefixVar : rest) = Just rest
- relative' _ = Nothing
+ relative' _ = Nothing
-- ---------------------------------------------------------------------------
-- Path templates
-- | An abstract path, possibly containing variables that need to be
-- substituted for to get a real 'FilePath'.
---
newtype PathTemplate = PathTemplate [PathComponent]
deriving (Eq, Ord, Generic, Typeable)
@@ -362,15 +383,14 @@ instance Structured PathTemplate
type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars.
---
toPathTemplate :: FilePath -> PathTemplate
-toPathTemplate fp = PathTemplate
+toPathTemplate fp =
+ PathTemplate
. fromMaybe (error $ "panic! toPathTemplate " ++ show fp)
. readMaybe -- TODO: eradicateNoParse
$ fp
-- | Convert back to a path, any remaining vars are included
---
fromPathTemplate :: PathTemplate -> FilePath
fromPathTemplate (PathTemplate template) = show template
@@ -380,71 +400,80 @@ combinePathTemplate (PathTemplate t1) (PathTemplate t2) =
substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate
substPathTemplate environment (PathTemplate template) =
- PathTemplate (concatMap subst template)
-
- where subst component@(Ordinary _) = [component]
- subst component@(Variable variable) =
- case lookup variable environment of
- Just (PathTemplate components) -> components
- Nothing -> [component]
+ PathTemplate (concatMap subst template)
+ where
+ subst component@(Ordinary _) = [component]
+ subst component@(Variable variable) =
+ case lookup variable environment of
+ Just (PathTemplate components) -> components
+ Nothing -> [component]
-- | The initial environment has all the static stuff but no paths
-initialPathTemplateEnv :: PackageIdentifier
- -> UnitId
- -> CompilerInfo
- -> Platform
- -> PathTemplateEnv
+initialPathTemplateEnv
+ :: PackageIdentifier
+ -> UnitId
+ -> CompilerInfo
+ -> Platform
+ -> PathTemplateEnv
initialPathTemplateEnv pkgId libname compiler platform =
- packageTemplateEnv pkgId libname
- ++ compilerTemplateEnv compiler
- ++ platformTemplateEnv platform
- ++ abiTemplateEnv compiler platform
+ packageTemplateEnv pkgId libname
+ ++ compilerTemplateEnv compiler
+ ++ platformTemplateEnv platform
+ ++ abiTemplateEnv compiler platform
packageTemplateEnv :: PackageIdentifier -> UnitId -> PathTemplateEnv
packageTemplateEnv pkgId uid =
- [(PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)])
- ,(PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)])
- -- Invariant: uid is actually a HashedUnitId. Hard to enforce because
- -- it's an API change.
- ,(LibNameVar, PathTemplate [Ordinary $ prettyShow uid])
- ,(PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId])
+ [ (PkgNameVar, PathTemplate [Ordinary $ prettyShow (packageName pkgId)])
+ , (PkgVerVar, PathTemplate [Ordinary $ prettyShow (packageVersion pkgId)])
+ , -- Invariant: uid is actually a HashedUnitId. Hard to enforce because
+ -- it's an API change.
+ (LibNameVar, PathTemplate [Ordinary $ prettyShow uid])
+ , (PkgIdVar, PathTemplate [Ordinary $ prettyShow pkgId])
]
compilerTemplateEnv :: CompilerInfo -> PathTemplateEnv
compilerTemplateEnv compiler =
- [(CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])
+ [ (CompilerVar, PathTemplate [Ordinary $ prettyShow (compilerInfoId compiler)])
]
platformTemplateEnv :: Platform -> PathTemplateEnv
platformTemplateEnv (Platform arch os) =
- [(OSVar, PathTemplate [Ordinary $ prettyShow os])
- ,(ArchVar, PathTemplate [Ordinary $ prettyShow arch])
+ [ (OSVar, PathTemplate [Ordinary $ prettyShow os])
+ , (ArchVar, PathTemplate [Ordinary $ prettyShow arch])
]
abiTemplateEnv :: CompilerInfo -> Platform -> PathTemplateEnv
abiTemplateEnv compiler (Platform arch os) =
- [(AbiVar, PathTemplate [Ordinary $ prettyShow arch ++ '-':prettyShow os ++
- '-':prettyShow (compilerInfoId compiler) ++
- case compilerInfoAbiTag compiler of
- NoAbiTag -> ""
- AbiTag tag -> '-':tag])
- ,(AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])
+ [
+ ( AbiVar
+ , PathTemplate
+ [ Ordinary $
+ prettyShow arch
+ ++ '-'
+ : prettyShow os
+ ++ '-'
+ : prettyShow (compilerInfoId compiler)
+ ++ case compilerInfoAbiTag compiler of
+ NoAbiTag -> ""
+ AbiTag tag -> '-' : tag
+ ]
+ )
+ , (AbiTagVar, PathTemplate [Ordinary $ abiTagString (compilerInfoAbiTag compiler)])
]
installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv
installDirsTemplateEnv dirs =
- [(PrefixVar, prefix dirs)
- ,(BindirVar, bindir dirs)
- ,(LibdirVar, libdir dirs)
- ,(LibsubdirVar, libsubdir dirs)
- ,(DynlibdirVar, dynlibdir dirs)
- ,(DatadirVar, datadir dirs)
- ,(DatasubdirVar, datasubdir dirs)
- ,(DocdirVar, docdir dirs)
- ,(HtmldirVar, htmldir dirs)
+ [ (PrefixVar, prefix dirs)
+ , (BindirVar, bindir dirs)
+ , (LibdirVar, libdir dirs)
+ , (LibsubdirVar, libsubdir dirs)
+ , (DynlibdirVar, dynlibdir dirs)
+ , (DatadirVar, datadir dirs)
+ , (DatasubdirVar, datasubdir dirs)
+ , (DocdirVar, docdir dirs)
+ , (HtmldirVar, htmldir dirs)
]
-
-- ---------------------------------------------------------------------------
-- Parsing and showing path templates:
@@ -458,13 +487,16 @@ instance Show PathTemplate where
show (PathTemplate template) = show (show template)
instance Read PathTemplate where
- readsPrec p s = [ (PathTemplate template, s')
- | (path, s') <- readsPrec p s
- , (template, "") <- reads path ]
+ readsPrec p s =
+ [ (PathTemplate template, s')
+ | (path, s') <- readsPrec p s
+ , (template, "") <- reads path
+ ]
-- ---------------------------------------------------------------------------
-- Internal utilities
+{- FOURMOLU_DISABLE -}
getWindowsProgramFilesDir :: IO FilePath
getWindowsProgramFilesDir = do
#ifdef mingw32_HOST_OS
@@ -473,6 +505,7 @@ getWindowsProgramFilesDir = do
let m = Nothing
#endif
return (fromMaybe "C:\\Program Files" m)
+{- FOURMOLU_ENABLE -}
#ifdef mingw32_HOST_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
@@ -490,6 +523,7 @@ csidl_PROGRAM_FILES = 0x0026
-- csidl_PROGRAM_FILES_COMMON :: CInt
-- csidl_PROGRAM_FILES_COMMON = 0x002b
+{- FOURMOLU_DISABLE -}
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
@@ -504,3 +538,4 @@ foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"
-> CWString
-> Prelude.IO CInt
#endif
+{- FOURMOLU_ENABLE -}
diff --git a/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs b/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs
index 61eedbee700afe52372691200df94e7637991a29..9c411b7dcc15740cbb458c14d821f4e67a0d9e8c 100644
--- a/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs
+++ b/Cabal/src/Distribution/Simple/InstallDirs/Internal.hs
@@ -1,127 +1,160 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Simple.InstallDirs.Internal
- ( PathComponent(..)
- , PathTemplateVariable(..)
+ ( PathComponent (..)
+ , PathTemplateVariable (..)
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-data PathComponent =
- Ordinary FilePath
- | Variable PathTemplateVariable
- deriving (Eq, Ord, Generic, Typeable)
+data PathComponent
+ = Ordinary FilePath
+ | Variable PathTemplateVariable
+ deriving (Eq, Ord, Generic, Typeable)
instance Binary PathComponent
instance Structured PathComponent
-data PathTemplateVariable =
- PrefixVar -- ^ The @$prefix@ path variable
- | BindirVar -- ^ The @$bindir@ path variable
- | LibdirVar -- ^ The @$libdir@ path variable
- | LibsubdirVar -- ^ The @$libsubdir@ path variable
- | DynlibdirVar -- ^ The @$dynlibdir@ path variable
- | DatadirVar -- ^ The @$datadir@ path variable
- | DatasubdirVar -- ^ The @$datasubdir@ path variable
- | DocdirVar -- ^ The @$docdir@ path variable
- | HtmldirVar -- ^ The @$htmldir@ path variable
- | PkgNameVar -- ^ The @$pkg@ package name path variable
- | PkgVerVar -- ^ The @$version@ package version path variable
- | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@
- | LibNameVar -- ^ The @$libname@ path variable
- | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@
- | OSVar -- ^ The operating system name, eg @windows@ or @linux@
- | ArchVar -- ^ The CPU architecture name, eg @i386@ or @x86_64@
- | AbiVar -- ^ The compiler's ABI identifier,
- --- $arch-$os-$compiler-$abitag
- | AbiTagVar -- ^ The optional ABI tag for the compiler
- | ExecutableNameVar -- ^ The executable name; used in shell wrappers
- | TestSuiteNameVar -- ^ The name of the test suite being run
- | TestSuiteResultVar -- ^ The result of the test suite being run, eg
- -- @pass@, @fail@, or @error@.
- | BenchmarkNameVar -- ^ The name of the benchmark being run
+data PathTemplateVariable
+ = -- | The @$prefix@ path variable
+ PrefixVar
+ | -- | The @$bindir@ path variable
+ BindirVar
+ | -- | The @$libdir@ path variable
+ LibdirVar
+ | -- | The @$libsubdir@ path variable
+ LibsubdirVar
+ | -- | The @$dynlibdir@ path variable
+ DynlibdirVar
+ | -- | The @$datadir@ path variable
+ DatadirVar
+ | -- | The @$datasubdir@ path variable
+ DatasubdirVar
+ | -- | The @$docdir@ path variable
+ DocdirVar
+ | -- | The @$htmldir@ path variable
+ HtmldirVar
+ | -- | The @$pkg@ package name path variable
+ PkgNameVar
+ | -- | The @$version@ package version path variable
+ PkgVerVar
+ | -- | The @$pkgid@ package Id path variable, eg @foo-1.0@
+ PkgIdVar
+ | -- | The @$libname@ path variable
+ LibNameVar
+ | -- | The compiler name and version, eg @ghc-6.6.1@
+ CompilerVar
+ | -- | The operating system name, eg @windows@ or @linux@
+ OSVar
+ | -- | The CPU architecture name, eg @i386@ or @x86_64@
+ ArchVar
+ | -- | The compiler's ABI identifier,
+ AbiVar
+ | --- $arch-$os-$compiler-$abitag
+
+ -- | The optional ABI tag for the compiler
+ AbiTagVar
+ | -- | The executable name; used in shell wrappers
+ ExecutableNameVar
+ | -- | The name of the test suite being run
+ TestSuiteNameVar
+ | -- | The result of the test suite being run, eg
+ -- @pass@, @fail@, or @error@.
+ TestSuiteResultVar
+ | -- | The name of the benchmark being run
+ BenchmarkNameVar
deriving (Eq, Ord, Generic, Typeable)
instance Binary PathTemplateVariable
instance Structured PathTemplateVariable
instance Show PathTemplateVariable where
- show PrefixVar = "prefix"
- show LibNameVar = "libname"
- show BindirVar = "bindir"
- show LibdirVar = "libdir"
- show LibsubdirVar = "libsubdir"
- show DynlibdirVar = "dynlibdir"
- show DatadirVar = "datadir"
+ show PrefixVar = "prefix"
+ show LibNameVar = "libname"
+ show BindirVar = "bindir"
+ show LibdirVar = "libdir"
+ show LibsubdirVar = "libsubdir"
+ show DynlibdirVar = "dynlibdir"
+ show DatadirVar = "datadir"
show DatasubdirVar = "datasubdir"
- show DocdirVar = "docdir"
- show HtmldirVar = "htmldir"
- show PkgNameVar = "pkg"
- show PkgVerVar = "version"
- show PkgIdVar = "pkgid"
- show CompilerVar = "compiler"
- show OSVar = "os"
- show ArchVar = "arch"
- show AbiTagVar = "abitag"
- show AbiVar = "abi"
+ show DocdirVar = "docdir"
+ show HtmldirVar = "htmldir"
+ show PkgNameVar = "pkg"
+ show PkgVerVar = "version"
+ show PkgIdVar = "pkgid"
+ show CompilerVar = "compiler"
+ show OSVar = "os"
+ show ArchVar = "arch"
+ show AbiTagVar = "abitag"
+ show AbiVar = "abi"
show ExecutableNameVar = "executablename"
- show TestSuiteNameVar = "test-suite"
+ show TestSuiteNameVar = "test-suite"
show TestSuiteResultVar = "result"
- show BenchmarkNameVar = "benchmark"
+ show BenchmarkNameVar = "benchmark"
instance Read PathTemplateVariable where
readsPrec _ s =
- take 1
- [ (var, drop (length varStr) s)
- | (varStr, var) <- vars
- , varStr `isPrefixOf` s ]
- -- NB: order matters! Longer strings first
- where vars = [("prefix", PrefixVar)
- ,("bindir", BindirVar)
- ,("libdir", LibdirVar)
- ,("libsubdir", LibsubdirVar)
- ,("dynlibdir", DynlibdirVar)
- ,("datadir", DatadirVar)
- ,("datasubdir", DatasubdirVar)
- ,("docdir", DocdirVar)
- ,("htmldir", HtmldirVar)
- ,("pkgid", PkgIdVar)
- ,("libname", LibNameVar)
- ,("pkgkey", LibNameVar) -- backwards compatibility
- ,("pkg", PkgNameVar)
- ,("version", PkgVerVar)
- ,("compiler", CompilerVar)
- ,("os", OSVar)
- ,("arch", ArchVar)
- ,("abitag", AbiTagVar)
- ,("abi", AbiVar)
- ,("executablename", ExecutableNameVar)
- ,("test-suite", TestSuiteNameVar)
- ,("result", TestSuiteResultVar)
- ,("benchmark", BenchmarkNameVar)]
+ take
+ 1
+ [ (var, drop (length varStr) s)
+ | (varStr, var) <- vars
+ , varStr `isPrefixOf` s
+ ]
+ where
+ -- NB: order matters! Longer strings first
+ vars =
+ [ ("prefix", PrefixVar)
+ , ("bindir", BindirVar)
+ , ("libdir", LibdirVar)
+ , ("libsubdir", LibsubdirVar)
+ , ("dynlibdir", DynlibdirVar)
+ , ("datadir", DatadirVar)
+ , ("datasubdir", DatasubdirVar)
+ , ("docdir", DocdirVar)
+ , ("htmldir", HtmldirVar)
+ , ("pkgid", PkgIdVar)
+ , ("libname", LibNameVar)
+ , ("pkgkey", LibNameVar) -- backwards compatibility
+ , ("pkg", PkgNameVar)
+ , ("version", PkgVerVar)
+ , ("compiler", CompilerVar)
+ , ("os", OSVar)
+ , ("arch", ArchVar)
+ , ("abitag", AbiTagVar)
+ , ("abi", AbiVar)
+ , ("executablename", ExecutableNameVar)
+ , ("test-suite", TestSuiteNameVar)
+ , ("result", TestSuiteResultVar)
+ , ("benchmark", BenchmarkNameVar)
+ ]
instance Show PathComponent where
show (Ordinary path) = path
- show (Variable var) = '$':show var
+ show (Variable var) = '$' : show var
showList = foldr (\x -> (shows x .)) id
instance Read PathComponent where
-- for some reason we collapse multiple $ symbols here
readsPrec _ = lex0
- where lex0 [] = []
- lex0 ('$':'$':s') = lex0 ('$':s')
- lex0 ('$':s') = case [ (Variable var, s'')
- | (var, s'') <- reads s' ] of
- [] -> lex1 "$" s'
- ok -> ok
- lex0 s' = lex1 [] s'
- lex1 "" "" = []
- lex1 acc "" = [(Ordinary (reverse acc), "")]
- lex1 acc ('$':'$':s) = lex1 acc ('$':s)
- lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)]
- lex1 acc (c:s) = lex1 (c:acc) s
- readList [] = [([],"")]
- readList s = [ (component:components, s'')
- | (component, s') <- reads s
- , (components, s'') <- readList s' ]
+ where
+ lex0 [] = []
+ lex0 ('$' : '$' : s') = lex0 ('$' : s')
+ lex0 ('$' : s') = case [ (Variable var, s'')
+ | (var, s'') <- reads s'
+ ] of
+ [] -> lex1 "$" s'
+ ok -> ok
+ lex0 s' = lex1 [] s'
+ lex1 "" "" = []
+ lex1 acc "" = [(Ordinary (reverse acc), "")]
+ lex1 acc ('$' : '$' : s) = lex1 acc ('$' : s)
+ lex1 acc ('$' : s) = [(Ordinary (reverse acc), '$' : s)]
+ lex1 acc (c : s) = lex1 (c : acc) s
+ readList [] = [([], "")]
+ readList s =
+ [ (component : components, s'')
+ | (component, s') <- reads s
+ , (components, s'') <- readList s'
+ ]
diff --git a/Cabal/src/Distribution/Simple/LocalBuildInfo.hs b/Cabal/src/Distribution/Simple/LocalBuildInfo.hs
index 992b5eba74f9765b5e84ee0d8bd32993b2a681ad..1290fd1f1687f537de1afc9157aca19b69a4b261 100644
--- a/Cabal/src/Distribution/Simple/LocalBuildInfo.hs
+++ b/Cabal/src/Distribution/Simple/LocalBuildInfo.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.LocalBuildInfo
-- Copyright : Isaac Jones 2003-2004
@@ -18,81 +19,83 @@
-- programs, the package database to use and a bunch of miscellaneous configure
-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets
-- passed in to very many subsequent build actions.
-
-module Distribution.Simple.LocalBuildInfo (
- LocalBuildInfo(..),
- localComponentId,
- localUnitId,
- localCompatPackageKey,
-
- -- * Buildable package components
- Component(..),
- ComponentName(..),
- LibraryName(..),
- defaultLibName,
- showComponentName,
- componentNameString,
- ComponentLocalBuildInfo(..),
- componentBuildDir,
- foldComponent,
- componentName,
- componentBuildInfo,
- componentBuildable,
- pkgComponents,
- pkgBuildableComponents,
- lookupComponent,
- getComponent,
- allComponentsInBuildOrder,
- depLibraryPaths,
- allLibModules,
-
- withAllComponentsInBuildOrder,
- withLibLBI,
- withExeLBI,
- withBenchLBI,
- withTestLBI,
- enabledTestLBIs,
- enabledBenchLBIs,
-
- -- * Installation directories
- module Distribution.Simple.InstallDirs,
- absoluteInstallDirs, prefixRelativeInstallDirs,
- absoluteInstallCommandDirs,
- absoluteComponentInstallDirs, prefixRelativeComponentInstallDirs,
- substPathTemplate,
+module Distribution.Simple.LocalBuildInfo
+ ( LocalBuildInfo (..)
+ , localComponentId
+ , localUnitId
+ , localCompatPackageKey
+
+ -- * Buildable package components
+ , Component (..)
+ , ComponentName (..)
+ , LibraryName (..)
+ , defaultLibName
+ , showComponentName
+ , componentNameString
+ , ComponentLocalBuildInfo (..)
+ , componentBuildDir
+ , foldComponent
+ , componentName
+ , componentBuildInfo
+ , componentBuildable
+ , pkgComponents
+ , pkgBuildableComponents
+ , lookupComponent
+ , getComponent
+ , allComponentsInBuildOrder
+ , depLibraryPaths
+ , allLibModules
+ , withAllComponentsInBuildOrder
+ , withLibLBI
+ , withExeLBI
+ , withBenchLBI
+ , withTestLBI
+ , enabledTestLBIs
+ , enabledBenchLBIs
+
+ -- * Installation directories
+ , module Distribution.Simple.InstallDirs
+ , absoluteInstallDirs
+ , prefixRelativeInstallDirs
+ , absoluteInstallCommandDirs
+ , absoluteComponentInstallDirs
+ , prefixRelativeComponentInstallDirs
+ , substPathTemplate
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Types.Component
-import Distribution.Types.PackageId
-import Distribution.Types.UnitId
-import Distribution.Types.ComponentName
-import Distribution.Types.UnqualComponentName
-import Distribution.Types.PackageDescription
import Distribution.Types.ComponentLocalBuildInfo
+import Distribution.Types.ComponentName
import Distribution.Types.LocalBuildInfo
+import Distribution.Types.PackageDescription
+import Distribution.Types.PackageId
import Distribution.Types.TargetInfo
+import Distribution.Types.UnitId
+import Distribution.Types.UnqualComponentName
-import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,
- prefixRelativeInstallDirs,
- substPathTemplate, )
-import qualified Distribution.Simple.InstallDirs as InstallDirs
-import Distribution.PackageDescription
+import qualified Distribution.Compat.Graph as Graph
import qualified Distribution.InstalledPackageInfo as Installed
-import Distribution.Package
import Distribution.ModuleName
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.Pretty
import Distribution.Simple.Compiler
+import Distribution.Simple.InstallDirs hiding
+ ( absoluteInstallDirs
+ , prefixRelativeInstallDirs
+ , substPathTemplate
+ )
+import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.PackageIndex
import Distribution.Simple.Utils
-import Distribution.Pretty
-import qualified Distribution.Compat.Graph as Graph
import Data.List (stripPrefix)
import System.FilePath
-import System.Directory (doesDirectoryExist, canonicalizePath)
+import System.Directory (canonicalizePath, doesDirectoryExist)
-- -----------------------------------------------------------------------------
-- Configuration information of buildable components
@@ -101,83 +104,104 @@ componentBuildDir :: LocalBuildInfo -> ComponentLocalBuildInfo -> FilePath
-- For now, we assume that libraries/executables/test-suites/benchmarks
-- are only ever built once. With Backpack, we need a special case for
-- libraries so that we can handle building them multiple times.
-componentBuildDir lbi clbi
- = buildDir lbi </>
- case componentLocalName clbi of
- CLibName LMainLibName ->
- if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)
- then ""
- else prettyShow (componentUnitId clbi)
- CLibName (LSubLibName s) ->
- if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)
- then unUnqualComponentName s
- else prettyShow (componentUnitId clbi)
- CFLibName s -> unUnqualComponentName s
- CExeName s -> unUnqualComponentName s
- CTestName s -> unUnqualComponentName s
- CBenchName s -> unUnqualComponentName s
+componentBuildDir lbi clbi =
+ buildDir lbi
+ </> case componentLocalName clbi of
+ CLibName LMainLibName ->
+ if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)
+ then ""
+ else prettyShow (componentUnitId clbi)
+ CLibName (LSubLibName s) ->
+ if prettyShow (componentUnitId clbi) == prettyShow (componentComponentId clbi)
+ then unUnqualComponentName s
+ else prettyShow (componentUnitId clbi)
+ CFLibName s -> unUnqualComponentName s
+ CExeName s -> unUnqualComponentName s
+ CTestName s -> unUnqualComponentName s
+ CBenchName s -> unUnqualComponentName s
-- | Perform the action on each enabled 'library' in the package
-- description with the 'ComponentLocalBuildInfo'.
-withLibLBI :: PackageDescription -> LocalBuildInfo
- -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO ()
+withLibLBI
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> (Library -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
withLibLBI pkg lbi f =
- withAllTargetsInBuildOrder' pkg lbi $ \target ->
- case targetComponent target of
- CLib lib -> f lib (targetCLBI target)
- _ -> return ()
+ withAllTargetsInBuildOrder' pkg lbi $ \target ->
+ case targetComponent target of
+ CLib lib -> f lib (targetCLBI target)
+ _ -> return ()
-- | Perform the action on each enabled 'Executable' in the package
-- description. Extended version of 'withExe' that also gives corresponding
-- build info.
-withExeLBI :: PackageDescription -> LocalBuildInfo
- -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO ()
+withExeLBI
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> (Executable -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
withExeLBI pkg lbi f =
- withAllTargetsInBuildOrder' pkg lbi $ \target ->
- case targetComponent target of
- CExe exe -> f exe (targetCLBI target)
- _ -> return ()
+ withAllTargetsInBuildOrder' pkg lbi $ \target ->
+ case targetComponent target of
+ CExe exe -> f exe (targetCLBI target)
+ _ -> return ()
-- | Perform the action on each enabled 'Benchmark' in the package
-- description.
-withBenchLBI :: PackageDescription -> LocalBuildInfo
- -> (Benchmark -> ComponentLocalBuildInfo -> IO ()) -> IO ()
+withBenchLBI
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> (Benchmark -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
withBenchLBI pkg lbi f =
- sequence_ [ f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi ]
+ sequence_ [f bench clbi | (bench, clbi) <- enabledBenchLBIs pkg lbi]
-withTestLBI :: PackageDescription -> LocalBuildInfo
- -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()
+withTestLBI
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> (TestSuite -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
withTestLBI pkg lbi f =
- sequence_ [ f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi ]
+ sequence_ [f test clbi | (test, clbi) <- enabledTestLBIs pkg lbi]
-enabledTestLBIs :: PackageDescription -> LocalBuildInfo
- -> [(TestSuite, ComponentLocalBuildInfo)]
+enabledTestLBIs
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> [(TestSuite, ComponentLocalBuildInfo)]
enabledTestLBIs pkg lbi =
- [ (test, targetCLBI target)
- | target <- allTargetsInBuildOrder' pkg lbi
- , CTest test <- [targetComponent target] ]
-
-enabledBenchLBIs :: PackageDescription -> LocalBuildInfo
- -> [(Benchmark, ComponentLocalBuildInfo)]
+ [ (test, targetCLBI target)
+ | target <- allTargetsInBuildOrder' pkg lbi
+ , CTest test <- [targetComponent target]
+ ]
+
+enabledBenchLBIs
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> [(Benchmark, ComponentLocalBuildInfo)]
enabledBenchLBIs pkg lbi =
- [ (bench, targetCLBI target)
- | target <- allTargetsInBuildOrder' pkg lbi
- , CBench bench <- [targetComponent target] ]
+ [ (bench, targetCLBI target)
+ | target <- allTargetsInBuildOrder' pkg lbi
+ , CBench bench <- [targetComponent target]
+ ]
-- | Perform the action on each buildable 'Library' or 'Executable' (Component)
-- in the PackageDescription, subject to the build order specified by the
-- 'compBuildOrder' field of the given 'LocalBuildInfo'
-withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo
- -> (Component -> ComponentLocalBuildInfo -> IO ())
- -> IO ()
+withAllComponentsInBuildOrder
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> (Component -> ComponentLocalBuildInfo -> IO ())
+ -> IO ()
withAllComponentsInBuildOrder pkg lbi f =
- withAllTargetsInBuildOrder' pkg lbi $ \target ->
- f (targetComponent target) (targetCLBI target)
+ withAllTargetsInBuildOrder' pkg lbi $ \target ->
+ f (targetComponent target) (targetCLBI target)
-allComponentsInBuildOrder :: LocalBuildInfo
- -> [ComponentLocalBuildInfo]
+allComponentsInBuildOrder
+ :: LocalBuildInfo
+ -> [ComponentLocalBuildInfo]
allComponentsInBuildOrder lbi =
- Graph.topSort (componentGraph lbi)
+ Graph.topSort (componentGraph lbi)
-- -----------------------------------------------------------------------------
-- A random function that has no business in this module
@@ -186,29 +210,42 @@ allComponentsInBuildOrder lbi =
-- transitive dependencies of the component we are building.
--
-- When wanted, and possible, returns paths relative to the installDirs 'prefix'
-depLibraryPaths :: Bool -- ^ Building for inplace?
- -> Bool -- ^ Generate prefix-relative library paths
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo -- ^ Component that is being built
- -> IO [FilePath]
+depLibraryPaths
+ :: Bool
+ -- ^ Building for inplace?
+ -> Bool
+ -- ^ Generate prefix-relative library paths
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -- ^ Component that is being built
+ -> IO [FilePath]
depLibraryPaths inplace relative lbi clbi = do
- let pkgDescr = localPkgDescr lbi
- installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest
- executable = case clbi of
- ExeComponentLocalBuildInfo {} -> True
- _ -> False
- relDir | executable = bindir installDirs
- | otherwise = libdir installDirs
-
- let -- TODO: this is kind of inefficient
- internalDeps = [ uid
- | (uid, _) <- componentPackageDeps clbi
- -- Test that it's internal
- , sub_target <- allTargetsInBuildOrder' pkgDescr lbi
- , componentUnitId (targetCLBI (sub_target)) == uid ]
- internalLibs = [ getLibDir (targetCLBI sub_target)
- | sub_target <- neededTargetsInBuildOrder'
- pkgDescr lbi internalDeps ]
+ let pkgDescr = localPkgDescr lbi
+ installDirs = absoluteComponentInstallDirs pkgDescr lbi (componentUnitId clbi) NoCopyDest
+ executable = case clbi of
+ ExeComponentLocalBuildInfo{} -> True
+ _ -> False
+ relDir
+ | executable = bindir installDirs
+ | otherwise = libdir installDirs
+
+ let
+ -- TODO: this is kind of inefficient
+ internalDeps =
+ [ uid
+ | (uid, _) <- componentPackageDeps clbi
+ , -- Test that it's internal
+ sub_target <- allTargetsInBuildOrder' pkgDescr lbi
+ , componentUnitId (targetCLBI (sub_target)) == uid
+ ]
+ internalLibs =
+ [ getLibDir (targetCLBI sub_target)
+ | sub_target <-
+ neededTargetsInBuildOrder'
+ pkgDescr
+ lbi
+ internalDeps
+ ]
{-
-- This is better, but it doesn't work, because we may be passed a
-- CLBI which doesn't actually exist, and was faked up when we
@@ -219,61 +256,64 @@ depLibraryPaths inplace relative lbi clbi = do
$ neededTargetsInBuildOrder lbi [componentUnitId clbi]
internalLibs = map getLibDir internalCLBIs
-}
- getLibDir sub_clbi
- | inplace = componentBuildDir lbi sub_clbi
- | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest)
-
- -- Why do we go through all the trouble of a hand-crafting
- -- internalLibs, when 'installedPkgs' actually contains the
- -- internal libraries? The trouble is that 'installedPkgs'
- -- may contain *inplace* entries, which we must NOT use for
- -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation).
- -- See #4025 for more details. This is all horrible but it
- -- is a moot point if you are using a per-component build,
- -- because you never have any internal libraries in this case;
- -- they're all external.
- let external_ipkgs = filter is_external (allPackages (installedPkgs lbi))
- is_external ipkg = not (installedUnitId ipkg `elem` internalDeps)
- -- First look for dynamic libraries in `dynamic-library-dirs`, and use
- -- `library-dirs` as a fall back.
- getDynDir pkg = case Installed.libraryDynDirs pkg of
- [] -> Installed.libraryDirs pkg
- d -> d
- allDepLibDirs = concatMap getDynDir external_ipkgs
-
- allDepLibDirs' = internalLibs ++ allDepLibDirs
- allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs'
-
- let p = prefix installDirs
- prefixRelative l = isJust (stripPrefix p l)
- libPaths
- | relative &&
- prefixRelative relDir = map (\l ->
- if prefixRelative l
- then shortRelativePath relDir l
- else l
- ) allDepLibDirsC
- | otherwise = allDepLibDirsC
-
- return libPaths
+ getLibDir sub_clbi
+ | inplace = componentBuildDir lbi sub_clbi
+ | otherwise = dynlibdir (absoluteComponentInstallDirs pkgDescr lbi (componentUnitId sub_clbi) NoCopyDest)
+
+ -- Why do we go through all the trouble of a hand-crafting
+ -- internalLibs, when 'installedPkgs' actually contains the
+ -- internal libraries? The trouble is that 'installedPkgs'
+ -- may contain *inplace* entries, which we must NOT use for
+ -- not inplace 'depLibraryPaths' (e.g., for RPATH calculation).
+ -- See #4025 for more details. This is all horrible but it
+ -- is a moot point if you are using a per-component build,
+ -- because you never have any internal libraries in this case;
+ -- they're all external.
+ let external_ipkgs = filter is_external (allPackages (installedPkgs lbi))
+ is_external ipkg = not (installedUnitId ipkg `elem` internalDeps)
+ -- First look for dynamic libraries in `dynamic-library-dirs`, and use
+ -- `library-dirs` as a fall back.
+ getDynDir pkg = case Installed.libraryDynDirs pkg of
+ [] -> Installed.libraryDirs pkg
+ d -> d
+ allDepLibDirs = concatMap getDynDir external_ipkgs
+
+ allDepLibDirs' = internalLibs ++ allDepLibDirs
+ allDepLibDirsC <- traverse canonicalizePathNoFail allDepLibDirs'
+
+ let p = prefix installDirs
+ prefixRelative l = isJust (stripPrefix p l)
+ libPaths
+ | relative
+ && prefixRelative relDir =
+ map
+ ( \l ->
+ if prefixRelative l
+ then shortRelativePath relDir l
+ else l
+ )
+ allDepLibDirsC
+ | otherwise = allDepLibDirsC
+
+ return libPaths
where
-- 'canonicalizePath' fails on UNIX when the directory does not exists.
-- So just don't canonicalize when it doesn't exist.
canonicalizePathNoFail p = do
exists <- doesDirectoryExist p
if exists
- then canonicalizePath p
- else return p
+ then canonicalizePath p
+ else return p
-- | Get all module names that needed to be built by GHC; i.e., all
-- of these 'ModuleName's have interface files associated with them
-- that need to be installed.
allLibModules :: Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules lib clbi =
- ordNub $
- explicitLibModules lib ++
- case clbi of
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts } -> map fst insts
+ ordNub $
+ explicitLibModules lib
+ ++ case clbi of
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} -> map fst insts
_ -> []
-- -----------------------------------------------------------------------------
@@ -283,17 +323,21 @@ allLibModules lib clbi =
-- assuming that @$libname@ points to the public library (or some fake
-- package identifier if there is no public library.) IF AT ALL
-- POSSIBLE, please use 'absoluteComponentInstallDirs' instead.
-absoluteInstallDirs :: PackageDescription -> LocalBuildInfo
- -> CopyDest
- -> InstallDirs FilePath
+absoluteInstallDirs
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> CopyDest
+ -> InstallDirs FilePath
absoluteInstallDirs pkg lbi copydest =
- absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest
+ absoluteComponentInstallDirs pkg lbi (localUnitId lbi) copydest
-- | See 'InstallDirs.absoluteInstallDirs'.
-absoluteComponentInstallDirs :: PackageDescription -> LocalBuildInfo
- -> UnitId
- -> CopyDest
- -> InstallDirs FilePath
+absoluteComponentInstallDirs
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> UnitId
+ -> CopyDest
+ -> InstallDirs FilePath
absoluteComponentInstallDirs pkg lbi uid copydest =
InstallDirs.absoluteInstallDirs
(packageId pkg)
@@ -303,29 +347,31 @@ absoluteComponentInstallDirs pkg lbi uid copydest =
(hostPlatform lbi)
(installDirTemplates lbi)
-absoluteInstallCommandDirs :: PackageDescription -> LocalBuildInfo
- -> UnitId
- -> CopyDest
- -> InstallDirs FilePath
+absoluteInstallCommandDirs
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> UnitId
+ -> CopyDest
+ -> InstallDirs FilePath
absoluteInstallCommandDirs pkg lbi uid copydest =
- dirs {
- -- Handle files which are not
- -- per-component (data files and Haddock files.)
- datadir = datadir dirs',
- -- NB: The situation with Haddock is a bit delicate. On the
- -- one hand, the easiest to understand Haddock documentation
- -- path is pkgname-0.1, which means it's per-package (not
- -- per-component). But this means that it's impossible to
- -- install Haddock documentation for internal libraries. We'll
- -- keep this constraint for now; this means you can't use
- -- Cabal to Haddock internal libraries. This does not seem
- -- like a big problem.
- docdir = docdir dirs',
- htmldir = htmldir dirs',
- haddockdir = haddockdir dirs'
+ dirs
+ { -- Handle files which are not
+ -- per-component (data files and Haddock files.)
+ datadir = datadir dirs'
+ , -- NB: The situation with Haddock is a bit delicate. On the
+ -- one hand, the easiest to understand Haddock documentation
+ -- path is pkgname-0.1, which means it's per-package (not
+ -- per-component). But this means that it's impossible to
+ -- install Haddock documentation for internal libraries. We'll
+ -- keep this constraint for now; this means you can't use
+ -- Cabal to Haddock internal libraries. This does not seem
+ -- like a big problem.
+ docdir = docdir dirs'
+ , htmldir = htmldir dirs'
+ , haddockdir = haddockdir dirs'
}
where
- dirs = absoluteComponentInstallDirs pkg lbi uid copydest
+ dirs = absoluteComponentInstallDirs pkg lbi uid copydest
-- Notice use of 'absoluteInstallDirs' (not the
-- per-component variant). This means for non-library
-- packages we'll just pick a nondescriptive foo-0.1
@@ -335,15 +381,19 @@ absoluteInstallCommandDirs pkg lbi uid copydest =
-- assuming that @$libname@ points to the public library (or some fake
-- package identifier if there is no public library.) IF AT ALL
-- POSSIBLE, please use 'prefixRelativeComponentInstallDirs' instead.
-prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo
- -> InstallDirs (Maybe FilePath)
+prefixRelativeInstallDirs
+ :: PackageId
+ -> LocalBuildInfo
+ -> InstallDirs (Maybe FilePath)
prefixRelativeInstallDirs pkg_descr lbi =
- prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi)
-
--- |See 'InstallDirs.prefixRelativeInstallDirs'
-prefixRelativeComponentInstallDirs :: PackageId -> LocalBuildInfo
- -> UnitId
- -> InstallDirs (Maybe FilePath)
+ prefixRelativeComponentInstallDirs pkg_descr lbi (localUnitId lbi)
+
+-- | See 'InstallDirs.prefixRelativeInstallDirs'
+prefixRelativeComponentInstallDirs
+ :: PackageId
+ -> LocalBuildInfo
+ -> UnitId
+ -> InstallDirs (Maybe FilePath)
prefixRelativeComponentInstallDirs pkg_descr lbi uid =
InstallDirs.prefixRelativeInstallDirs
(packageId pkg_descr)
@@ -352,14 +402,19 @@ prefixRelativeComponentInstallDirs pkg_descr lbi uid =
(hostPlatform lbi)
(installDirTemplates lbi)
-substPathTemplate :: PackageId -> LocalBuildInfo
- -> UnitId
- -> PathTemplate -> FilePath
-substPathTemplate pkgid lbi uid = fromPathTemplate
- . ( InstallDirs.substPathTemplate env )
- where env = initialPathTemplateEnv
- pkgid
- uid
- (compilerInfo (compiler lbi))
- (hostPlatform lbi)
-
+substPathTemplate
+ :: PackageId
+ -> LocalBuildInfo
+ -> UnitId
+ -> PathTemplate
+ -> FilePath
+substPathTemplate pkgid lbi uid =
+ fromPathTemplate
+ . (InstallDirs.substPathTemplate env)
+ where
+ env =
+ initialPathTemplateEnv
+ pkgid
+ uid
+ (compilerInfo (compiler lbi))
+ (hostPlatform lbi)
diff --git a/Cabal/src/Distribution/Simple/PackageDescription.hs b/Cabal/src/Distribution/Simple/PackageDescription.hs
index 6bf11413930632f70a806ba7270cec71321dbfd5..c52cea789d917414bc4fc88c4b736b12a2c59063 100644
--- a/Cabal/src/Distribution/Simple/PackageDescription.hs
+++ b/Cabal/src/Distribution/Simple/PackageDescription.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.PackageDescription
-- Copyright : Isaac Jones 2003-2005
@@ -8,33 +9,37 @@
-- Portability : portable
--
-- This defines parsers for the @.cabal@ format
-
-module Distribution.Simple.PackageDescription (
- -- * Read and Parse files
- readGenericPackageDescription,
- readHookedBuildInfo,
+module Distribution.Simple.PackageDescription
+ ( -- * Read and Parse files
+ readGenericPackageDescription
+ , readHookedBuildInfo
-- * Utility Parsing function
- parseString,
- ) where
+ , parseString
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Fields.ParseResult
import Distribution.PackageDescription
import Distribution.PackageDescription.Parsec
- ( parseGenericPackageDescription, parseHookedBuildInfo )
-import Distribution.Parsec.Error ( showPError )
+ ( parseGenericPackageDescription
+ , parseHookedBuildInfo
+ )
+import Distribution.Parsec.Error (showPError)
import Distribution.Parsec.Warning
- ( PWarning(..), PWarnType(PWTExperimental), showPWarning )
-import Distribution.Simple.Utils ( equating, die', warn )
-import Distribution.Verbosity ( normal, Verbosity )
+ ( PWarnType (PWTExperimental)
+ , PWarning (..)
+ , showPWarning
+ )
+import Distribution.Simple.Utils (die', equating, warn)
+import Distribution.Verbosity (Verbosity, normal)
-import Data.List ( groupBy )
-import Text.Printf ( printf )
import qualified Data.ByteString as BS
+import Data.List (groupBy)
import System.Directory (doesFileExist)
+import Text.Printf (printf)
readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription = readAndParseFile parseGenericPackageDescription
@@ -49,55 +54,63 @@ readHookedBuildInfo = readAndParseFile parseHookedBuildInfo
--
-- Argument order is chosen to encourage partial application.
readAndParseFile
- :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser
- -> Verbosity -- ^ Verbosity level
- -> FilePath -- ^ File to read
- -> IO a
+ :: (BS.ByteString -> ParseResult a)
+ -- ^ File contents to final value parser
+ -> Verbosity
+ -- ^ Verbosity level
+ -> FilePath
+ -- ^ File to read
+ -> IO a
readAndParseFile parser verbosity fpath = do
- exists <- doesFileExist fpath
- unless exists $
- die' verbosity $
- "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
- bs <- BS.readFile fpath
- parseString parser verbosity fpath bs
+ exists <- doesFileExist fpath
+ unless exists $
+ die' verbosity $
+ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
+ bs <- BS.readFile fpath
+ parseString parser verbosity fpath bs
parseString
- :: (BS.ByteString -> ParseResult a) -- ^ File contents to final value parser
- -> Verbosity -- ^ Verbosity level
- -> String -- ^ File name
- -> BS.ByteString
- -> IO a
+ :: (BS.ByteString -> ParseResult a)
+ -- ^ File contents to final value parser
+ -> Verbosity
+ -- ^ Verbosity level
+ -> String
+ -- ^ File name
+ -> BS.ByteString
+ -> IO a
parseString parser verbosity name bs = do
- let (warnings, result) = runParseResult (parser bs)
- traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings)
- case result of
- Right x -> return x
- Left (_, errors) -> do
- traverse_ (warn verbosity . showPError name) errors
- die' verbosity $ "Failed parsing \"" ++ name ++ "\"."
+ let (warnings, result) = runParseResult (parser bs)
+ traverse_ (warn verbosity . showPWarning name) (flattenDups verbosity warnings)
+ case result of
+ Right x -> return x
+ Left (_, errors) -> do
+ traverse_ (warn verbosity . showPError name) errors
+ die' verbosity $ "Failed parsing \"" ++ name ++ "\"."
-- | Collapse duplicate experimental feature warnings into single warning, with
-- a count of further sites
flattenDups :: Verbosity -> [PWarning] -> [PWarning]
flattenDups verbosity ws
- | verbosity <= normal = rest ++ experimentals
- | otherwise = ws -- show all instances
- where
- (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws
- experimentals =
- concatMap flatCount
- . groupBy (equating warningStr)
- . sortBy (comparing warningStr)
- $ exps
+ | verbosity <= normal = rest ++ experimentals
+ | otherwise = ws -- show all instances
+ where
+ (exps, rest) = partition (\(PWarning w _ _) -> w == PWTExperimental) ws
+ experimentals =
+ concatMap flatCount
+ . groupBy (equating warningStr)
+ . sortBy (comparing warningStr)
+ $ exps
- warningStr (PWarning _ _ w) = w
+ warningStr (PWarning _ _ w) = w
- -- flatten if we have 3 or more examples
- flatCount :: [PWarning] -> [PWarning]
- flatCount w@[] = w
- flatCount w@[_] = w
- flatCount w@[_,_] = w
- flatCount (PWarning t pos w:xs) =
- [PWarning t pos
- (w <> printf " (and %d more occurrences)" (length xs))
- ]
+ -- flatten if we have 3 or more examples
+ flatCount :: [PWarning] -> [PWarning]
+ flatCount w@[] = w
+ flatCount w@[_] = w
+ flatCount w@[_, _] = w
+ flatCount (PWarning t pos w : xs) =
+ [ PWarning
+ t
+ pos
+ (w <> printf " (and %d more occurrences)" (length xs))
+ ]
diff --git a/Cabal/src/Distribution/Simple/PackageIndex.hs b/Cabal/src/Distribution/Simple/PackageIndex.hs
index 26d0147a3c729fe60c31490c2e41e30b604e5d6c..927e10ae878ae4c7b6bc46f4938a68b5030b5418 100644
--- a/Cabal/src/Distribution/Simple/PackageIndex.hs
+++ b/Cabal/src/Distribution/Simple/PackageIndex.hs
@@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.PackageIndex
-- Copyright : (c) David Himmelstrup 2005,
@@ -43,80 +44,77 @@
-- 'Distribution.Client.PackageIndex', which indexes packages only by
-- 'PackageName' (this makes it suitable for indexing source packages,
-- for which we don't know 'UnitId's.)
---
-module Distribution.Simple.PackageIndex (
- -- * Package index data type
- InstalledPackageIndex,
- PackageIndex,
-
- -- * Creating an index
- fromList,
-
- -- * Updates
- merge,
-
- insert,
-
- deleteUnitId,
- deleteSourcePackageId,
- deletePackageName,
--- deleteDependency,
-
- -- * Queries
-
- -- ** Precise lookups
- lookupUnitId,
- lookupComponentId,
- lookupSourcePackageId,
- lookupPackageId,
- lookupPackageName,
- lookupDependency,
- lookupInternalDependency,
-
- -- ** Case-insensitive searches
- searchByName,
- SearchResult(..),
- searchByNameSubstring,
- searchWithPredicate,
-
- -- ** Bulk queries
- allPackages,
- allPackagesByName,
- allPackagesBySourcePackageId,
- allPackagesBySourcePackageIdAndLibName,
-
- -- ** Special queries
- brokenPackages,
- dependencyClosure,
- reverseDependencyClosure,
- topologicalOrder,
- reverseTopologicalOrder,
- dependencyInconsistencies,
- dependencyCycles,
- dependencyGraph,
- moduleNameIndex
+module Distribution.Simple.PackageIndex
+ ( -- * Package index data type
+ InstalledPackageIndex
+ , PackageIndex
+
+ -- * Creating an index
+ , fromList
+
+ -- * Updates
+ , merge
+ , insert
+ , deleteUnitId
+ , deleteSourcePackageId
+ , deletePackageName
+ -- deleteDependency,
+
+ -- * Queries
+
+ -- ** Precise lookups
+ , lookupUnitId
+ , lookupComponentId
+ , lookupSourcePackageId
+ , lookupPackageId
+ , lookupPackageName
+ , lookupDependency
+ , lookupInternalDependency
+
+ -- ** Case-insensitive searches
+ , searchByName
+ , SearchResult (..)
+ , searchByNameSubstring
+ , searchWithPredicate
+
+ -- ** Bulk queries
+ , allPackages
+ , allPackagesByName
+ , allPackagesBySourcePackageId
+ , allPackagesBySourcePackageIdAndLibName
+
+ -- ** Special queries
+ , brokenPackages
+ , dependencyClosure
+ , reverseDependencyClosure
+ , topologicalOrder
+ , reverseTopologicalOrder
+ , dependencyInconsistencies
+ , dependencyCycles
+ , dependencyGraph
+ , moduleNameIndex
) where
-import Prelude ()
-import Distribution.Compat.Prelude hiding (lookup)
import qualified Data.Map.Strict as Map
+import Distribution.Compat.Prelude hiding (lookup)
+import Prelude ()
-import Distribution.Package
import Distribution.Backpack
-import Distribution.ModuleName
import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.Version
+import Distribution.ModuleName
+import Distribution.Package
import Distribution.Simple.Utils
import Distribution.Types.LibraryName
+import Distribution.Version
import Control.Exception (assert)
+import Control.Monad
import Data.Array ((!))
import qualified Data.Array as Array
import qualified Data.Graph as Graph
-import Data.List as List ( groupBy, deleteBy, deleteFirstsBy )
+import Data.List as List (deleteBy, deleteFirstsBy, groupBy)
import qualified Data.List.NonEmpty as NE
-import qualified Data.Tree as Tree
-import Control.Monad
+import qualified Data.Tree as Tree
import Distribution.Compat.Stack
import qualified Prelude (foldr1)
@@ -126,27 +124,25 @@ import qualified Prelude (foldr1)
--
-- Packages are uniquely identified in by their 'UnitId', they can
-- also be efficiently looked up by package name or by name and version.
---
-data PackageIndex a = PackageIndex {
- -- The primary index. Each InstalledPackageInfo record is uniquely identified
- -- by its UnitId.
- --
- unitIdIndex :: !(Map UnitId a),
-
- -- This auxiliary index maps package names (case-sensitively) to all the
- -- versions and instances of that package. This allows us to find all
- -- versions satisfying a dependency.
- --
- -- It is a three-level index. The first level is the package name,
- -- the second is the package version and the final level is instances
- -- of the same package version. These are unique by UnitId
- -- and are kept in preference order.
- --
- -- FIXME: Clarify what "preference order" means. Check that this invariant is
- -- preserved. See #1463 for discussion.
- packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))
-
- } deriving (Eq, Generic, Show, Read, Typeable)
+data PackageIndex a = PackageIndex
+ { -- The primary index. Each InstalledPackageInfo record is uniquely identified
+ -- by its UnitId.
+ --
+ unitIdIndex :: !(Map UnitId a)
+ , -- This auxiliary index maps package names (case-sensitively) to all the
+ -- versions and instances of that package. This allows us to find all
+ -- versions satisfying a dependency.
+ --
+ -- It is a three-level index. The first level is the package name,
+ -- the second is the package version and the final level is instances
+ -- of the same package version. These are unique by UnitId
+ -- and are kept in preference order.
+ --
+ -- FIXME: Clarify what "preference order" means. Check that this invariant is
+ -- preserved. See #1463 for discussion.
+ packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))
+ }
+ deriving (Eq, Generic, Show, Read, Typeable)
instance Binary a => Binary (PackageIndex a)
instance Structured a => Structured (PackageIndex a)
@@ -156,9 +152,10 @@ instance Structured a => Structured (PackageIndex a)
type InstalledPackageIndex = PackageIndex IPI.InstalledPackageInfo
instance Monoid (PackageIndex IPI.InstalledPackageInfo) where
- mempty = PackageIndex Map.empty Map.empty
+ mempty = PackageIndex Map.empty Map.empty
mappend = (<>)
- --save one mappend with empty in the common case:
+
+ -- save one mappend with empty in the common case:
mconcat [] = mempty
mconcat xs = Prelude.foldr1 mappend xs
@@ -170,69 +167,84 @@ invariant :: WithCallStack (InstalledPackageIndex -> Bool)
invariant (PackageIndex pids pnames) =
-- trace (show pids' ++ "\n" ++ show pnames') $
pids' == pnames'
- where
- pids' = map installedUnitId (Map.elems pids)
- pnames' = sort
- [ assert pinstOk (installedUnitId pinst)
- | ((pname, plib), pvers) <- Map.toList pnames
- , let pversOk = not (Map.null pvers)
- , (pver, pinsts) <- assert pversOk $ Map.toList pvers
- , let pinsts' = sortBy (comparing installedUnitId) pinsts
- pinstsOk = all (\g -> length g == 1)
- (groupBy (equating installedUnitId) pinsts')
- , pinst <- assert pinstsOk $ pinsts'
- , let pinstOk = packageName pinst == pname
+ where
+ pids' = map installedUnitId (Map.elems pids)
+ pnames' =
+ sort
+ [ assert pinstOk (installedUnitId pinst)
+ | ((pname, plib), pvers) <- Map.toList pnames
+ , let pversOk = not (Map.null pvers)
+ , (pver, pinsts) <- assert pversOk $ Map.toList pvers
+ , let pinsts' = sortBy (comparing installedUnitId) pinsts
+ pinstsOk =
+ all
+ (\g -> length g == 1)
+ (groupBy (equating installedUnitId) pinsts')
+ , pinst <- assert pinstsOk $ pinsts'
+ , let pinstOk =
+ packageName pinst == pname
&& packageVersion pinst == pver
- && IPI.sourceLibName pinst == plib
- ]
- -- If you see this invariant failing (ie the assert in mkPackageIndex below)
- -- then one thing to check is if it is happening in fromList. Check if the
- -- second list above (the sort [...] bit) is ending up with duplicates. This
- -- has been observed in practice once due to a messed up ghc-pkg db. How/why
- -- it became messed up was not discovered.
+ && IPI.sourceLibName pinst == plib
+ ]
+-- If you see this invariant failing (ie the assert in mkPackageIndex below)
+-- then one thing to check is if it is happening in fromList. Check if the
+-- second list above (the sort [...] bit) is ending up with duplicates. This
+-- has been observed in practice once due to a messed up ghc-pkg db. How/why
+-- it became messed up was not discovered.
--
+
-- * Internal helpers
+
--
-mkPackageIndex :: WithCallStack (Map UnitId IPI.InstalledPackageInfo
- -> Map (PackageName, LibraryName)
- (Map Version [IPI.InstalledPackageInfo])
- -> InstalledPackageIndex)
+mkPackageIndex
+ :: WithCallStack
+ ( Map UnitId IPI.InstalledPackageInfo
+ -> Map
+ (PackageName, LibraryName)
+ (Map Version [IPI.InstalledPackageInfo])
+ -> InstalledPackageIndex
+ )
mkPackageIndex pids pnames = assert (invariant index) index
- where index = PackageIndex pids pnames
-
+ where
+ index = PackageIndex pids pnames
--
+
-- * Construction
+
--
-- | Build an index out of a bunch of packages.
--
-- If there are duplicates by 'UnitId' then later ones mask earlier
-- ones.
---
fromList :: [IPI.InstalledPackageInfo] -> InstalledPackageIndex
fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames)
where
- pids = Map.fromList [ (installedUnitId pkg, pkg) | pkg <- pkgs ]
- pnames =
+ pids = Map.fromList [(installedUnitId pkg, pkg) | pkg <- pkgs]
+ pnames =
Map.fromList
[ (liftM2 (,) packageName IPI.sourceLibName (NE.head pkgsN), pvers)
- | pkgsN <- NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))
- . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))
- $ pkgs
+ | pkgsN <-
+ NE.groupBy (equating (liftM2 (,) packageName IPI.sourceLibName))
+ . sortBy (comparing (liftM3 (,,) packageName IPI.sourceLibName packageVersion))
+ $ pkgs
, let pvers =
Map.fromList
- [ (packageVersion (NE.head pkgsNV),
- NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV))
- | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN
- ]
+ [ ( packageVersion (NE.head pkgsNV)
+ , NE.nubBy (equating installedUnitId) (NE.reverse pkgsNV)
+ )
+ | pkgsNV <- NE.groupBy (equating packageVersion) pkgsN
+ ]
]
--
+
-- * Updates
+
--
-- | Merge two indexes.
@@ -244,101 +256,110 @@ fromList pkgs = mkPackageIndex pids ((fmap . fmap) toList pnames)
-- \"preferred\" over those from the first. Being preferred means they are top
-- result when we do a lookup by source 'PackageId'. This is the mechanism we
-- use to prefer user packages over global packages.
---
-merge :: InstalledPackageIndex -> InstalledPackageIndex
- -> InstalledPackageIndex
+merge
+ :: InstalledPackageIndex
+ -> InstalledPackageIndex
+ -> InstalledPackageIndex
merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =
- mkPackageIndex (Map.unionWith (\_ y -> y) pids1 pids2)
- (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)
+ mkPackageIndex
+ (Map.unionWith (\_ y -> y) pids1 pids2)
+ (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2)
where
-- Packages in the second list mask those in the first, however preferred
-- packages go first in the list.
mergeBuckets xs ys = ys ++ (xs \\ ys)
(\\) = deleteFirstsBy (equating installedUnitId)
-
-- | Inserts a single package into the index.
--
-- This is equivalent to (but slightly quicker than) using 'mappend' or
-- 'merge' with a singleton index.
---
insert :: IPI.InstalledPackageInfo -> InstalledPackageIndex -> InstalledPackageIndex
insert pkg (PackageIndex pids pnames) =
- mkPackageIndex pids' pnames'
-
+ mkPackageIndex pids' pnames'
where
- pids' = Map.insert (installedUnitId pkg) pkg pids
+ pids' = Map.insert (installedUnitId pkg) pkg pids
pnames' = insertPackageName pnames
insertPackageName =
- Map.insertWith (\_ -> insertPackageVersion)
- (packageName pkg, IPI.sourceLibName pkg)
- (Map.singleton (packageVersion pkg) [pkg])
+ Map.insertWith
+ (\_ -> insertPackageVersion)
+ (packageName pkg, IPI.sourceLibName pkg)
+ (Map.singleton (packageVersion pkg) [pkg])
insertPackageVersion =
- Map.insertWith (\_ -> insertPackageInstance)
- (packageVersion pkg) [pkg]
+ Map.insertWith
+ (\_ -> insertPackageInstance)
+ (packageVersion pkg)
+ [pkg]
insertPackageInstance pkgs =
pkg : deleteBy (equating installedUnitId) pkg pkgs
-
-- | Removes a single installed package from the index.
---
-deleteUnitId :: UnitId -> InstalledPackageIndex
- -> InstalledPackageIndex
+deleteUnitId
+ :: UnitId
+ -> InstalledPackageIndex
+ -> InstalledPackageIndex
deleteUnitId ipkgid original@(PackageIndex pids pnames) =
case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of
- (Nothing, _) -> original
- (Just spkgid, pids') -> mkPackageIndex pids'
- (deletePkgName spkgid pnames)
-
+ (Nothing, _) -> original
+ (Just spkgid, pids') ->
+ mkPackageIndex
+ pids'
+ (deletePkgName spkgid pnames)
where
deletePkgName spkgid =
Map.update (deletePkgVersion spkgid) (packageName spkgid, IPI.sourceLibName spkgid)
deletePkgVersion spkgid =
- (\m -> if Map.null m then Nothing else Just m)
- . Map.update deletePkgInstance (packageVersion spkgid)
+ (\m -> if Map.null m then Nothing else Just m)
+ . Map.update deletePkgInstance (packageVersion spkgid)
deletePkgInstance =
- (\xs -> if null xs then Nothing else Just xs)
- . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined
+ (\xs -> if null xs then Nothing else Just xs)
+ . List.deleteBy (\_ pkg -> installedUnitId pkg == ipkgid) undefined
-- | Removes all packages with this source 'PackageId' from the index.
---
-deleteSourcePackageId :: PackageId -> InstalledPackageIndex
- -> InstalledPackageIndex
+deleteSourcePackageId
+ :: PackageId
+ -> InstalledPackageIndex
+ -> InstalledPackageIndex
deleteSourcePackageId pkgid original@(PackageIndex pids pnames) =
-- NB: Doesn't delete internal packages
case Map.lookup (packageName pkgid, LMainLibName) pnames of
- Nothing -> original
- Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
- Nothing -> original
- Just pkgs -> mkPackageIndex
- (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)
- (deletePkgName pnames)
+ Nothing -> original
+ Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
+ Nothing -> original
+ Just pkgs ->
+ mkPackageIndex
+ (foldl' (flip (Map.delete . installedUnitId)) pids pkgs)
+ (deletePkgName pnames)
where
deletePkgName =
Map.update deletePkgVersion (packageName pkgid, LMainLibName)
deletePkgVersion =
- (\m -> if Map.null m then Nothing else Just m)
- . Map.delete (packageVersion pkgid)
-
+ (\m -> if Map.null m then Nothing else Just m)
+ . Map.delete (packageVersion pkgid)
-- | Removes all packages with this (case-sensitive) name from the index.
--
-- NB: Does NOT delete internal libraries from this package.
---
-deletePackageName :: PackageName -> InstalledPackageIndex
- -> InstalledPackageIndex
+deletePackageName
+ :: PackageName
+ -> InstalledPackageIndex
+ -> InstalledPackageIndex
deletePackageName name original@(PackageIndex pids pnames) =
case Map.lookup (name, LMainLibName) pnames of
- Nothing -> original
- Just pvers -> mkPackageIndex
- (foldl' (flip (Map.delete . installedUnitId)) pids
- (concat (Map.elems pvers)))
- (Map.delete (name, LMainLibName) pnames)
+ Nothing -> original
+ Just pvers ->
+ mkPackageIndex
+ ( foldl'
+ (flip (Map.delete . installedUnitId))
+ pids
+ (concat (Map.elems pvers))
+ )
+ (Map.delete (name, LMainLibName) pnames)
{-
-- | Removes all packages satisfying this dependency from the index.
@@ -349,11 +370,12 @@ deleteDependency (Dependency name verstionRange) =
-}
--
+
-- * Bulk queries
+
--
-- | Get all the packages from the index.
---
allPackages :: PackageIndex a -> [a]
allPackages = Map.elems . unitIdIndex
@@ -362,91 +384,99 @@ allPackages = Map.elems . unitIdIndex
-- They are grouped by package name (case-sensitively).
--
-- (Doesn't include private libraries.)
---
allPackagesByName :: PackageIndex a -> [(PackageName, [a])]
allPackagesByName index =
[ (pkgname, concat (Map.elems pvers))
- | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index) ]
+ | ((pkgname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
+ ]
-- | Get all the packages from the index.
--
-- They are grouped by source package id (package name and version).
--
-- (Doesn't include private libraries)
---
-allPackagesBySourcePackageId :: HasUnitId a => PackageIndex a
- -> [(PackageId, [a])]
+allPackagesBySourcePackageId
+ :: HasUnitId a
+ => PackageIndex a
+ -> [(PackageId, [a])]
allPackagesBySourcePackageId index =
[ (packageId ipkg, ipkgs)
| ((_, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
- , ipkgs@(ipkg:_) <- Map.elems pvers ]
+ , ipkgs@(ipkg : _) <- Map.elems pvers
+ ]
-- | Get all the packages from the index.
--
-- They are grouped by source package id and library name.
--
-- This DOES include internal libraries.
-allPackagesBySourcePackageIdAndLibName :: HasUnitId a => PackageIndex a
- -> [((PackageId, LibraryName), [a])]
+allPackagesBySourcePackageIdAndLibName
+ :: HasUnitId a
+ => PackageIndex a
+ -> [((PackageId, LibraryName), [a])]
allPackagesBySourcePackageIdAndLibName index =
[ ((packageId ipkg, ln), ipkgs)
| ((_, ln), pvers) <- Map.toList (packageIdIndex index)
- , ipkgs@(ipkg:_) <- Map.elems pvers ]
+ , ipkgs@(ipkg : _) <- Map.elems pvers
+ ]
--
+
-- * Lookups
+
--
-- | Does a lookup by unit identifier.
--
-- Since multiple package DBs mask each other by 'UnitId',
-- then we get back at most one package.
---
-lookupUnitId :: PackageIndex a -> UnitId
- -> Maybe a
+lookupUnitId
+ :: PackageIndex a
+ -> UnitId
+ -> Maybe a
lookupUnitId index uid = Map.lookup uid (unitIdIndex index)
-- | Does a lookup by component identifier. In the absence
-- of Backpack, this is just a 'lookupUnitId'.
---
-lookupComponentId :: PackageIndex a -> ComponentId
- -> Maybe a
+lookupComponentId
+ :: PackageIndex a
+ -> ComponentId
+ -> Maybe a
lookupComponentId index cid =
- Map.lookup (newSimpleUnitId cid) (unitIdIndex index)
+ Map.lookup (newSimpleUnitId cid) (unitIdIndex index)
-- | Does a lookup by source package id (name & version).
--
-- There can be multiple installed packages with the same source 'PackageId'
-- but different 'UnitId'. They are returned in order of
-- preference, with the most preferred first.
---
lookupSourcePackageId :: PackageIndex a -> PackageId -> [a]
lookupSourcePackageId index pkgid =
-- Do not lookup internal libraries
case Map.lookup (packageName pkgid, LMainLibName) (packageIdIndex index) of
- Nothing -> []
- Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
- Nothing -> []
+ Nothing -> []
+ Just pvers -> case Map.lookup (packageVersion pkgid) pvers of
+ Nothing -> []
Just pkgs -> pkgs -- in preference order
-- | Convenient alias of 'lookupSourcePackageId', but assuming only
-- one package per package ID.
lookupPackageId :: PackageIndex a -> PackageId -> Maybe a
-lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of
- [] -> Nothing
- [pkg] -> Just pkg
- _ -> error "Distribution.Simple.PackageIndex: multiple matches found"
+lookupPackageId index pkgid = case lookupSourcePackageId index pkgid of
+ [] -> Nothing
+ [pkg] -> Just pkg
+ _ -> error "Distribution.Simple.PackageIndex: multiple matches found"
-- | Does a lookup by source package name.
---
-lookupPackageName :: PackageIndex a -> PackageName
- -> [(Version, [a])]
+lookupPackageName
+ :: PackageIndex a
+ -> PackageName
+ -> [(Version, [a])]
lookupPackageName index name =
-- Do not match internal libraries
case Map.lookup (name, LMainLibName) (packageIdIndex index) of
- Nothing -> []
- Just pvers -> Map.toList pvers
-
+ Nothing -> []
+ Just pvers -> Map.toList pvers
-- | Does a lookup by source package name and a range of versions.
--
@@ -457,12 +487,14 @@ lookupPackageName index name =
-- function on those; use 'lookupInternalDependency' instead.
--
-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.
---
-lookupDependency :: InstalledPackageIndex -> PackageName -> VersionRange
- -> [(Version, [IPI.InstalledPackageInfo])]
+lookupDependency
+ :: InstalledPackageIndex
+ -> PackageName
+ -> VersionRange
+ -> [(Version, [IPI.InstalledPackageInfo])]
lookupDependency index pn vr =
- -- Yes, a little bit of a misnomer here!
- lookupInternalDependency index pn vr LMainLibName
+ -- Yes, a little bit of a misnomer here!
+ lookupInternalDependency index pn vr LMainLibName
-- | Does a lookup by source package name and a range of versions.
--
@@ -470,30 +502,34 @@ lookupDependency index pn vr =
-- satisfying the version range constraint.
--
-- INVARIANT: List of eligible 'IPI.InstalledPackageInfo' is non-empty.
---
-lookupInternalDependency :: InstalledPackageIndex -> PackageName -> VersionRange
- -> LibraryName
- -> [(Version, [IPI.InstalledPackageInfo])]
+lookupInternalDependency
+ :: InstalledPackageIndex
+ -> PackageName
+ -> VersionRange
+ -> LibraryName
+ -> [(Version, [IPI.InstalledPackageInfo])]
lookupInternalDependency index name versionRange libn =
case Map.lookup (name, libn) (packageIdIndex index) of
- Nothing -> []
- Just pvers -> [ (ver, pkgs')
- | (ver, pkgs) <- Map.toList pvers
- , ver `withinRange` versionRange
- , let pkgs' = filter eligible pkgs
- -- Enforce the invariant
- , not (null pkgs')
- ]
- where
- -- When we select for dependencies, we ONLY want to pick up indefinite
- -- packages, or packages with no instantiations. We'll do mix-in
- -- linking to improve any such package into an instantiated one
- -- later.
- eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg)
-
+ Nothing -> []
+ Just pvers ->
+ [ (ver, pkgs')
+ | (ver, pkgs) <- Map.toList pvers
+ , ver `withinRange` versionRange
+ , let pkgs' = filter eligible pkgs
+ , -- Enforce the invariant
+ not (null pkgs')
+ ]
+ where
+ -- When we select for dependencies, we ONLY want to pick up indefinite
+ -- packages, or packages with no instantiations. We'll do mix-in
+ -- linking to improve any such package into an instantiated one
+ -- later.
+ eligible pkg = IPI.indefinite pkg || null (IPI.instantiatedWith pkg)
--
+
-- * Case insensitive name lookups
+
--
-- | Does a case-insensitive search by package name.
@@ -507,42 +543,45 @@ lookupInternalDependency index name versionRange libn =
-- have an ambiguous result, and we get back all the versions of all the
-- packages. The list of ambiguous results is split by exact package name. So
-- it is a non-empty list of non-empty lists.
---
searchByName :: PackageIndex a -> String -> SearchResult [a]
searchByName index name =
-- Don't match internal packages
- case [ pkgs | pkgs@((pname, LMainLibName),_) <- Map.toList (packageIdIndex index)
- , lowercase (unPackageName pname) == lname ] of
- [] -> None
- [(_,pvers)] -> Unambiguous (concat (Map.elems pvers))
- pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of
- Just (_,pvers) -> Unambiguous (concat (Map.elems pvers))
- Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss)
- where lname = lowercase name
+ case [ pkgs | pkgs@((pname, LMainLibName), _) <- Map.toList (packageIdIndex index), lowercase (unPackageName pname) == lname
+ ] of
+ [] -> None
+ [(_, pvers)] -> Unambiguous (concat (Map.elems pvers))
+ pkgss -> case find ((mkPackageName name ==) . fst . fst) pkgss of
+ Just (_, pvers) -> Unambiguous (concat (Map.elems pvers))
+ Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss)
+ where
+ lname = lowercase name
data SearchResult a = None | Unambiguous a | Ambiguous [a]
-- | Does a case-insensitive substring search by package name.
--
-- That is, all packages that contain the given string in their name.
---
searchByNameSubstring :: PackageIndex a -> String -> [a]
searchByNameSubstring index searchterm =
searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n)
- where lsearchterm = lowercase searchterm
+ where
+ lsearchterm = lowercase searchterm
-- | @since 3.4.0.0
searchWithPredicate :: PackageIndex a -> (String -> Bool) -> [a]
searchWithPredicate index predicate =
[ pkg
- -- Don't match internal packages
- | ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
+ | -- Don't match internal packages
+ ((pname, LMainLibName), pvers) <- Map.toList (packageIdIndex index)
, predicate (unPackageName pname)
, pkgs <- Map.elems pvers
- , pkg <- pkgs ]
+ , pkg <- pkgs
+ ]
--
+
-- * Special queries
+
--
-- None of the stuff below depends on the internal representation of the index.
@@ -554,27 +593,30 @@ searchWithPredicate index predicate =
-- This actually computes the strongly connected components. So it gives us a
-- list of groups of packages where within each group they all depend on each
-- other, directly or indirectly.
---
dependencyCycles :: PackageInstalled a => PackageIndex a -> [[a]]
dependencyCycles index =
- [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]
+ [vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList]
where
- adjacencyList = [ (pkg, installedUnitId pkg, installedDepends pkg)
- | pkg <- allPackages index ]
-
+ adjacencyList =
+ [ (pkg, installedUnitId pkg, installedDepends pkg)
+ | pkg <- allPackages index
+ ]
-- | All packages that have immediate dependencies that are not in the index.
--
-- Returns such packages along with the dependencies that they're missing.
---
-brokenPackages :: PackageInstalled a => PackageIndex a
- -> [(a, [UnitId])]
+brokenPackages
+ :: PackageInstalled a
+ => PackageIndex a
+ -> [(a, [UnitId])]
brokenPackages index =
[ (pkg, missing)
- | pkg <- allPackages index
- , let missing = [ pkg' | pkg' <- installedDepends pkg
- , isNothing (lookupUnitId index pkg') ]
- , not (null missing) ]
+ | pkg <- allPackages index
+ , let missing =
+ [ pkg' | pkg' <- installedDepends pkg, isNothing (lookupUnitId index pkg')
+ ]
+ , not (null missing)
+ ]
-- | Tries to take the transitive closure of the package dependencies.
--
@@ -583,78 +625,89 @@ brokenPackages index =
--
-- * Note that if the result is @Right []@ it is because at least one of
-- the original given 'PackageId's do not occur in the index.
---
-dependencyClosure :: InstalledPackageIndex
- -> [UnitId]
- -> Either (InstalledPackageIndex)
- [(IPI.InstalledPackageInfo, [UnitId])]
+dependencyClosure
+ :: InstalledPackageIndex
+ -> [UnitId]
+ -> Either
+ (InstalledPackageIndex)
+ [(IPI.InstalledPackageInfo, [UnitId])]
dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of
(completed, []) -> Left completed
- (completed, _) -> Right (brokenPackages completed)
- where
- closure completed failed [] = (completed, failed)
- closure completed failed (pkgid:pkgids) = case lookupUnitId index pkgid of
- Nothing -> closure completed (pkgid:failed) pkgids
- Just pkg -> case lookupUnitId completed (installedUnitId pkg) of
- Just _ -> closure completed failed pkgids
+ (completed, _) -> Right (brokenPackages completed)
+ where
+ closure completed failed [] = (completed, failed)
+ closure completed failed (pkgid : pkgids) = case lookupUnitId index pkgid of
+ Nothing -> closure completed (pkgid : failed) pkgids
+ Just pkg -> case lookupUnitId completed (installedUnitId pkg) of
+ Just _ -> closure completed failed pkgids
Nothing -> closure completed' failed pkgids'
- where completed' = insert pkg completed
- pkgids' = installedDepends pkg ++ pkgids
+ where
+ completed' = insert pkg completed
+ pkgids' = installedDepends pkg ++ pkgids
-- | Takes the transitive closure of the packages reverse dependencies.
--
-- * The given 'PackageId's must be in the index.
---
-reverseDependencyClosure :: PackageInstalled a => PackageIndex a
- -> [UnitId]
- -> [a]
+reverseDependencyClosure
+ :: PackageInstalled a
+ => PackageIndex a
+ -> [UnitId]
+ -> [a]
reverseDependencyClosure index =
- map vertexToPkg
- . concatMap Tree.flatten
- . Graph.dfs reverseDepGraph
- . map (fromMaybe noSuchPkgId . pkgIdToVertex)
-
+ map vertexToPkg
+ . concatMap Tree.flatten
+ . Graph.dfs reverseDepGraph
+ . map (fromMaybe noSuchPkgId . pkgIdToVertex)
where
(depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index
reverseDepGraph = Graph.transposeG depGraph
noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"
topologicalOrder :: PackageInstalled a => PackageIndex a -> [a]
-topologicalOrder index = map toPkgId
- . Graph.topSort
- $ graph
- where (graph, toPkgId, _) = dependencyGraph index
+topologicalOrder index =
+ map toPkgId
+ . Graph.topSort
+ $ graph
+ where
+ (graph, toPkgId, _) = dependencyGraph index
reverseTopologicalOrder :: PackageInstalled a => PackageIndex a -> [a]
-reverseTopologicalOrder index = map toPkgId
- . Graph.topSort
- . Graph.transposeG
- $ graph
- where (graph, toPkgId, _) = dependencyGraph index
+reverseTopologicalOrder index =
+ map toPkgId
+ . Graph.topSort
+ . Graph.transposeG
+ $ graph
+ where
+ (graph, toPkgId, _) = dependencyGraph index
-- | Builds a graph of the package dependencies.
--
-- Dependencies on other packages that are not in the index are discarded.
-- You can check if there are any such dependencies with 'brokenPackages'.
---
-dependencyGraph :: PackageInstalled a => PackageIndex a
- -> (Graph.Graph,
- Graph.Vertex -> a,
- UnitId -> Maybe Graph.Vertex)
+dependencyGraph
+ :: PackageInstalled a
+ => PackageIndex a
+ -> ( Graph.Graph
+ , Graph.Vertex -> a
+ , UnitId -> Maybe Graph.Vertex
+ )
dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)
where
- graph = Array.listArray bounds
- [ [ v | Just v <- map id_to_vertex (installedDepends pkg) ]
- | pkg <- pkgs ]
+ graph =
+ Array.listArray
+ bounds
+ [ [v | Just v <- map id_to_vertex (installedDepends pkg)]
+ | pkg <- pkgs
+ ]
- pkgs = sortBy (comparing packageId) (allPackages index)
- vertices = zip (map installedUnitId pkgs) [0..]
- vertex_map = Map.fromList vertices
+ pkgs = sortBy (comparing packageId) (allPackages index)
+ vertices = zip (map installedUnitId pkgs) [0 ..]
+ vertex_map = Map.fromList vertices
id_to_vertex pid = Map.lookup pid vertex_map
vertex_to_pkg vertex = pkgTable ! vertex
- pkgTable = Array.listArray bounds pkgs
+ pkgTable = Array.listArray bounds pkgs
topBound = length pkgs - 1
bounds = (0, topBound)
@@ -671,29 +724,36 @@ type DepUniqueKey = (PackageName, LibraryName, Map ModuleName OpenModule)
-- Each element in the result is a package name along with the packages that
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
---
-dependencyInconsistencies :: InstalledPackageIndex
- -- At DepUniqueKey...
- -> [(DepUniqueKey,
- -- There were multiple packages (BAD!)
- [(UnitId,
- -- And here are the packages which
- -- immediately depended on it
- [IPI.InstalledPackageInfo])])]
+dependencyInconsistencies
+ :: InstalledPackageIndex
+ -- At DepUniqueKey...
+ -> [ ( DepUniqueKey
+ , -- There were multiple packages (BAD!)
+ [ ( UnitId
+ , -- And here are the packages which
+ -- immediately depended on it
+ [IPI.InstalledPackageInfo]
+ )
+ ]
+ )
+ ]
dependencyInconsistencies index = do
- (dep_key, insts_map) <- Map.toList inverseIndex
- let insts = Map.toList insts_map
- guard (length insts >= 2)
- return (dep_key, insts)
+ (dep_key, insts_map) <- Map.toList inverseIndex
+ let insts = Map.toList insts_map
+ guard (length insts >= 2)
+ return (dep_key, insts)
where
inverseIndex :: Map DepUniqueKey (Map UnitId [IPI.InstalledPackageInfo])
inverseIndex = Map.fromListWith (Map.unionWith (++)) $ do
- pkg <- allPackages index
- dep_ipid <- installedDepends pkg
- Just dep <- [lookupUnitId index dep_ipid]
- let dep_key = (packageName dep, IPI.sourceLibName dep,
- Map.fromList (IPI.instantiatedWith dep))
- return (dep_key, Map.singleton dep_ipid [pkg])
+ pkg <- allPackages index
+ dep_ipid <- installedDepends pkg
+ Just dep <- [lookupUnitId index dep_ipid]
+ let dep_key =
+ ( packageName dep
+ , IPI.sourceLibName dep
+ , Map.fromList (IPI.instantiatedWith dep)
+ )
+ return (dep_key, Map.singleton dep_ipid [pkg])
-- | A rough approximation of GHC's module finder, takes a
-- 'InstalledPackageIndex' and turns it into a map from module names to their
@@ -705,12 +765,14 @@ moduleNameIndex index =
pkg <- allPackages index
IPI.ExposedModule m reexport <- IPI.exposedModules pkg
case reexport of
- Nothing -> return (m, [pkg])
- Just (OpenModuleVar _) -> []
- Just (OpenModule _ m') | m == m' -> []
- | otherwise -> return (m', [pkg])
- -- The heuristic is this: we want to prefer the original package
- -- which originally exported a module. However, if a reexport
- -- also *renamed* the module (m /= m'), then we have to use the
- -- downstream package, since the upstream package has the wrong
- -- module name!
+ Nothing -> return (m, [pkg])
+ Just (OpenModuleVar _) -> []
+ Just (OpenModule _ m')
+ | m == m' -> []
+ | otherwise -> return (m', [pkg])
+
+-- The heuristic is this: we want to prefer the original package
+-- which originally exported a module. However, if a reexport
+-- also *renamed* the module (m /= m'), then we have to use the
+-- downstream package, since the upstream package has the wrong
+-- module name!
diff --git a/Cabal/src/Distribution/Simple/PreProcess.hs b/Cabal/src/Distribution/Simple/PreProcess.hs
index d47dd803569ef6141d5d17718d562c97c1a1b832..5531140629f8cd7c5de941360ee6fa60dc300b9a 100644
--- a/Cabal/src/Distribution/Simple/PreProcess.hs
+++ b/Cabal/src/Distribution/Simple/PreProcess.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.PreProcess
-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace
@@ -19,121 +20,139 @@
-- for actually preprocessing some sources given a bunch of known suffix
-- handlers. This module is not as good as it could be, it could really do with
-- a rewrite to address some of the problems we have with pre-processors.
+module Distribution.Simple.PreProcess
+ ( preprocessComponent
+ , preprocessExtras
+ , knownSuffixHandlers
+ , ppSuffixes
+ , PPSuffixHandler
+ , PreProcessor (..)
+ , mkSimplePreProcessor
+ , runSimplePreProcessor
+ , ppCpp
+ , ppCpp'
+ , ppGreenCard
+ , ppC2hs
+ , ppHsc2hs
+ , ppHappy
+ , ppAlex
+ , ppUnlit
+ , platformDefines
+ , unsorted
+ )
+where
-module Distribution.Simple.PreProcess (preprocessComponent, preprocessExtras,
- knownSuffixHandlers, ppSuffixes,
- PPSuffixHandler, PreProcessor(..),
- mkSimplePreProcessor, runSimplePreProcessor,
- ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,
- ppHappy, ppAlex, ppUnlit, platformDefines,
- unsorted
- )
- where
-
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Stack
+import Prelude ()
-import Distribution.Simple.PreProcess.Unlit
import Distribution.Backpack.DescribeUnitId
-import Distribution.Package
-import qualified Distribution.ModuleName as ModuleName
+import qualified Distribution.InstalledPackageInfo as Installed
import Distribution.ModuleName (ModuleName)
+import qualified Distribution.ModuleName as ModuleName
+import Distribution.Package
import Distribution.PackageDescription as PD
-import qualified Distribution.InstalledPackageInfo as Installed
-import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Pretty
+import Distribution.Simple.BuildPaths
import Distribution.Simple.CCompiler
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
-import Distribution.Simple.BuildPaths
-import Distribution.Simple.Utils
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.PreProcess.Unlit
import Distribution.Simple.Program
import Distribution.Simple.Program.ResponseFile
import Distribution.Simple.Test.LibV09
+import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.PackageName.Magic
-import Distribution.Pretty
-import Distribution.Version
-import Distribution.Verbosity
import Distribution.Utils.Path
+import Distribution.Verbosity
+import Distribution.Version
-import System.Directory (doesFileExist, doesDirectoryExist)
-import System.Info (os, arch)
-import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),
- takeDirectory, normalise, replaceExtension,
- takeExtensions)
-
--- |The interface to a preprocessor, which may be implemented using an
--- external program, but need not be. The arguments are the name of
--- the input file, the name of the output file and a verbosity level.
--- Here is a simple example that merely prepends a comment to the given
--- source file:
---
--- > ppTestHandler :: PreProcessor
--- > ppTestHandler =
--- > PreProcessor {
--- > platformIndependent = True,
--- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
--- > do info verbosity (inFile++" has been preprocessed to "++outFile)
--- > stuff <- readFile inFile
--- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff)
--- > return ExitSuccess
+import System.Directory (doesDirectoryExist, doesFileExist)
+import System.FilePath
+ ( dropExtensions
+ , normalise
+ , replaceExtension
+ , splitExtension
+ , takeDirectory
+ , takeExtensions
+ , (<.>)
+ , (</>)
+ )
+import System.Info (arch, os)
+
+-- | The interface to a preprocessor, which may be implemented using an
+-- external program, but need not be. The arguments are the name of
+-- the input file, the name of the output file and a verbosity level.
+-- Here is a simple example that merely prepends a comment to the given
+-- source file:
--
--- We split the input and output file names into a base directory and the
--- rest of the file name. The input base dir is the path in the list of search
--- dirs that this file was found in. The output base dir is the build dir where
--- all the generated source files are put.
+-- > ppTestHandler :: PreProcessor
+-- > ppTestHandler =
+-- > PreProcessor {
+-- > platformIndependent = True,
+-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
+-- > do info verbosity (inFile++" has been preprocessed to "++outFile)
+-- > stuff <- readFile inFile
+-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff)
+-- > return ExitSuccess
--
--- The reason for splitting it up this way is that some pre-processors don't
--- simply generate one output .hs file from one input file but have
--- dependencies on other generated files (notably c2hs, where building one
--- .hs file may require reading other .chi files, and then compiling the .hs
--- file may require reading a generated .h file). In these cases the generated
--- files need to embed relative path names to each other (eg the generated .hs
--- file mentions the .h file in the FFI imports). This path must be relative to
--- the base directory where the generated files are located, it cannot be
--- relative to the top level of the build tree because the compilers do not
--- look for .h files relative to there, ie we do not use \"-I .\", instead we
--- use \"-I dist\/build\" (or whatever dist dir has been set by the user)
+-- We split the input and output file names into a base directory and the
+-- rest of the file name. The input base dir is the path in the list of search
+-- dirs that this file was found in. The output base dir is the build dir where
+-- all the generated source files are put.
--
--- Most pre-processors do not care of course, so mkSimplePreProcessor and
--- runSimplePreProcessor functions handle the simple case.
+-- The reason for splitting it up this way is that some pre-processors don't
+-- simply generate one output .hs file from one input file but have
+-- dependencies on other generated files (notably c2hs, where building one
+-- .hs file may require reading other .chi files, and then compiling the .hs
+-- file may require reading a generated .h file). In these cases the generated
+-- files need to embed relative path names to each other (eg the generated .hs
+-- file mentions the .h file in the FFI imports). This path must be relative to
+-- the base directory where the generated files are located, it cannot be
+-- relative to the top level of the build tree because the compilers do not
+-- look for .h files relative to there, ie we do not use \"-I .\", instead we
+-- use \"-I dist\/build\" (or whatever dist dir has been set by the user)
--
-data PreProcessor = PreProcessor {
-
- -- Is the output of the pre-processor platform independent? eg happy output
- -- is portable haskell but c2hs's output is platform dependent.
- -- This matters since only platform independent generated code can be
- -- included into a source tarball.
- platformIndependent :: Bool,
-
- -- TODO: deal with pre-processors that have implementation dependent output
- -- eg alex and happy have --ghc flags. However we can't really include
- -- ghc-specific code into supposedly portable source tarballs.
-
- -- | This function can reorder /all/ modules, not just those that the
+-- Most pre-processors do not care of course, so mkSimplePreProcessor and
+-- runSimplePreProcessor functions handle the simple case.
+data PreProcessor = PreProcessor
+ { -- Is the output of the pre-processor platform independent? eg happy output
+ -- is portable haskell but c2hs's output is platform dependent.
+ -- This matters since only platform independent generated code can be
+ -- included into a source tarball.
+ platformIndependent :: Bool
+ , -- TODO: deal with pre-processors that have implementation dependent output
+ -- eg alex and happy have --ghc flags. However we can't really include
+ -- ghc-specific code into supposedly portable source tarballs.
+
+ ppOrdering
+ :: Verbosity
+ -> [FilePath] -- Source directories
+ -> [ModuleName] -- Module names
+ -> IO [ModuleName] -- Sorted modules
+
+ -- ^ This function can reorder /all/ modules, not just those that the
-- require the preprocessor in question. As such, this function should be
-- well-behaved and not reorder modules it doesn't have dominion over!
--
-- @since 3.8.1.0
- ppOrdering :: Verbosity
- -> [FilePath] -- Source directories
- -> [ModuleName] -- Module names
- -> IO [ModuleName], -- Sorted modules
-
- runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir
- -> (FilePath, FilePath) -- Output file name, relative to an output base dir
- -> Verbosity -- verbosity
- -> IO () -- Should exit if the preprocessor fails
+ , runPreProcessor
+ :: (FilePath, FilePath) -- Location of the source file relative to a base dir
+ -> (FilePath, FilePath) -- Output file name, relative to an output base dir
+ -> Verbosity -- verbosity
+ -> IO () -- Should exit if the preprocessor fails
}
-- | Just present the modules in the order given; this is the default and it is
-- appropriate for preprocessors which do not have any sort of dependencies
-- between modules.
-unsorted :: Verbosity
- -> [FilePath]
- -> [ModuleName]
- -> IO [ModuleName]
+unsorted
+ :: Verbosity
+ -> [FilePath]
+ -> [ModuleName]
+ -> IO [ModuleName]
unsorted _ _ ms = pure ms
-- | Function to determine paths to possible extra C sources for a
@@ -142,196 +161,257 @@ unsorted _ _ ms = pure ms
-- preprocessor's output name format.
type PreProcessorExtras = FilePath -> IO [FilePath]
-
-mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ())
- -> (FilePath, FilePath)
- -> (FilePath, FilePath) -> Verbosity -> IO ()
-mkSimplePreProcessor simplePP
+mkSimplePreProcessor
+ :: (FilePath -> FilePath -> Verbosity -> IO ())
+ -> (FilePath, FilePath)
+ -> (FilePath, FilePath)
+ -> Verbosity
+ -> IO ()
+mkSimplePreProcessor
+ simplePP
(inBaseDir, inRelativeFile)
- (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity
- where inFile = normalise (inBaseDir </> inRelativeFile)
- outFile = normalise (outBaseDir </> outRelativeFile)
-
-runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity
- -> IO ()
+ (outBaseDir, outRelativeFile)
+ verbosity = simplePP inFile outFile verbosity
+ where
+ inFile = normalise (inBaseDir </> inRelativeFile)
+ outFile = normalise (outBaseDir </> outRelativeFile)
+
+runSimplePreProcessor
+ :: PreProcessor
+ -> FilePath
+ -> FilePath
+ -> Verbosity
+ -> IO ()
runSimplePreProcessor pp inFile outFile verbosity =
runPreProcessor pp (".", inFile) (".", outFile) verbosity
--- |A preprocessor for turning non-Haskell files with the given extension
--- into plain Haskell source files.
-type PPSuffixHandler
- = (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor)
+-- | A preprocessor for turning non-Haskell files with the given extension
+-- into plain Haskell source files.
+type PPSuffixHandler =
+ (String, BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor)
-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given
-- component (lib, exe, or test suite).
--
-- XXX: This is terrible
-preprocessComponent :: PackageDescription
- -> Component
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Bool
- -> Verbosity
- -> [PPSuffixHandler]
- -> IO ()
+preprocessComponent
+ :: PackageDescription
+ -> Component
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Bool
+ -> Verbosity
+ -> [PPSuffixHandler]
+ -> IO ()
preprocessComponent pd comp lbi clbi isSrcDist verbosity handlers =
-- Skip preprocessing for scripts since they should be regular Haskell files,
-- but may have no or unknown extensions.
when (package pd /= fakePackageId) $ do
- -- NB: never report instantiation here; we'll report it properly when
- -- building.
- setupMessage' verbosity "Preprocessing" (packageId pd)
- (componentLocalName clbi) (Nothing :: Maybe [(ModuleName, Module)])
- case comp of
- (CLib lib@Library{ libBuildInfo = bi }) -> do
- let dirs = map getSymbolicPath (hsSourceDirs bi) ++
- [ autogenComponentModulesDir lbi clbi ,autogenPackageModulesDir lbi]
- let hndlrs = localHandlers bi
- mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi)
- for_ (map ModuleName.toFilePath mods) $
- pre dirs (componentBuildDir lbi clbi) hndlrs
- (CFLib flib@ForeignLib { foreignLibBuildInfo = bi, foreignLibName = nm }) -> do
- let nm' = unUnqualComponentName nm
- let flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
- dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi]
- let hndlrs = localHandlers bi
- mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib)
- for_ (map ModuleName.toFilePath mods) $
- pre dirs flibDir hndlrs
- (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do
- let nm' = unUnqualComponentName nm
- let exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
- dirs = map getSymbolicPath (hsSourceDirs bi) ++ [autogenComponentModulesDir lbi clbi
- ,autogenPackageModulesDir lbi]
- let hndlrs = localHandlers bi
- mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi)
- for_ (map ModuleName.toFilePath mods) $
- pre dirs exeDir hndlrs
- pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $
- dropExtensions (modulePath exe)
- CTest test@TestSuite{ testName = nm } -> do
- let nm' = unUnqualComponentName nm
- case testInterface test of
- TestSuiteExeV10 _ f ->
+ -- NB: never report instantiation here; we'll report it properly when
+ -- building.
+ setupMessage'
+ verbosity
+ "Preprocessing"
+ (packageId pd)
+ (componentLocalName clbi)
+ (Nothing :: Maybe [(ModuleName, Module)])
+ case comp of
+ (CLib lib@Library{libBuildInfo = bi}) -> do
+ let dirs =
+ map getSymbolicPath (hsSourceDirs bi)
+ ++ [autogenComponentModulesDir lbi clbi, autogenPackageModulesDir lbi]
+ let hndlrs = localHandlers bi
+ mods <- orderingFromHandlers verbosity dirs hndlrs (allLibModules lib clbi)
+ for_ (map ModuleName.toFilePath mods) $
+ pre dirs (componentBuildDir lbi clbi) hndlrs
+ (CFLib flib@ForeignLib{foreignLibBuildInfo = bi, foreignLibName = nm}) -> do
+ let nm' = unUnqualComponentName nm
+ let flibDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
+ dirs =
+ map getSymbolicPath (hsSourceDirs bi)
+ ++ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ ]
+ let hndlrs = localHandlers bi
+ mods <- orderingFromHandlers verbosity dirs hndlrs (foreignLibModules flib)
+ for_ (map ModuleName.toFilePath mods) $
+ pre dirs flibDir hndlrs
+ (CExe exe@Executable{buildInfo = bi, exeName = nm}) -> do
+ let nm' = unUnqualComponentName nm
+ let exeDir = buildDir lbi </> nm' </> nm' ++ "-tmp"
+ dirs =
+ map getSymbolicPath (hsSourceDirs bi)
+ ++ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ ]
+ let hndlrs = localHandlers bi
+ mods <- orderingFromHandlers verbosity dirs hndlrs (otherModules bi)
+ for_ (map ModuleName.toFilePath mods) $
+ pre dirs exeDir hndlrs
+ pre (map getSymbolicPath (hsSourceDirs bi)) exeDir (localHandlers bi) $
+ dropExtensions (modulePath exe)
+ CTest test@TestSuite{testName = nm} -> do
+ let nm' = unUnqualComponentName nm
+ case testInterface test of
+ TestSuiteExeV10 _ f ->
preProcessTest test f $ buildDir lbi </> nm' </> nm' ++ "-tmp"
- TestSuiteLibV09 _ _ -> do
- let testDir = buildDir lbi </> stubName test
- </> stubName test ++ "-tmp"
+ TestSuiteLibV09 _ _ -> do
+ let testDir =
+ buildDir lbi
+ </> stubName test
+ </> stubName test
+ ++ "-tmp"
writeSimpleTestStub test testDir
preProcessTest test (stubFilePath test) testDir
- TestSuiteUnsupported tt ->
- die' verbosity $ "No support for preprocessing test "
- ++ "suite type " ++ prettyShow tt
- CBench bm@Benchmark{ benchmarkName = nm } -> do
- let nm' = unUnqualComponentName nm
- case benchmarkInterface bm of
- BenchmarkExeV10 _ f ->
+ TestSuiteUnsupported tt ->
+ die' verbosity $
+ "No support for preprocessing test "
+ ++ "suite type "
+ ++ prettyShow tt
+ CBench bm@Benchmark{benchmarkName = nm} -> do
+ let nm' = unUnqualComponentName nm
+ case benchmarkInterface bm of
+ BenchmarkExeV10 _ f ->
preProcessBench bm f $ buildDir lbi </> nm' </> nm' ++ "-tmp"
- BenchmarkUnsupported tt ->
- die' verbosity $ "No support for preprocessing benchmark "
- ++ "type " ++ prettyShow tt
+ BenchmarkUnsupported tt ->
+ die' verbosity $
+ "No support for preprocessing benchmark "
+ ++ "type "
+ ++ prettyShow tt
where
orderingFromHandlers v d hndlrs mods =
- foldM (\acc (_,pp) -> ppOrdering pp v d acc) mods hndlrs
+ foldM (\acc (_, pp) -> ppOrdering pp v d acc) mods hndlrs
builtinHaskellSuffixes = ["hs", "lhs", "hsig", "lhsig"]
- builtinCSuffixes = cSourceExtensions
- builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes
+ builtinCSuffixes = cSourceExtensions
+ builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes
localHandlers bi = [(ext, h bi lbi clbi) | (ext, h) <- handlers]
pre dirs dir lhndlrs fp =
preprocessFile (map unsafeMakeSymbolicPath dirs) dir isSrcDist fp verbosity builtinSuffixes lhndlrs True
- preProcessTest test = preProcessComponent (testBuildInfo test)
- (testModules test)
- preProcessBench bm = preProcessComponent (benchmarkBuildInfo bm)
- (benchmarkModules bm)
+ preProcessTest test =
+ preProcessComponent
+ (testBuildInfo test)
+ (testModules test)
+ preProcessBench bm =
+ preProcessComponent
+ (benchmarkBuildInfo bm)
+ (benchmarkModules bm)
preProcessComponent
- :: BuildInfo
- -> [ModuleName]
- -> FilePath
- -> FilePath
- -> IO ()
+ :: BuildInfo
+ -> [ModuleName]
+ -> FilePath
+ -> FilePath
+ -> IO ()
preProcessComponent bi modules exePath dir = do
- let biHandlers = localHandlers bi
- sourceDirs = map getSymbolicPath (hsSourceDirs bi) ++ [ autogenComponentModulesDir lbi clbi
- , autogenPackageModulesDir lbi ]
- sequence_ [ preprocessFile (map unsafeMakeSymbolicPath sourceDirs) dir isSrcDist
- (ModuleName.toFilePath modu) verbosity builtinSuffixes
- biHandlers False
- | modu <- modules ]
- -- XXX: what we do here (re SymbolicPath dir)
- -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir?
- -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator)
- preprocessFile (unsafeMakeSymbolicPath dir : hsSourceDirs bi) dir isSrcDist
- (dropExtensions $ exePath) verbosity
- builtinSuffixes biHandlers False
-
---TODO: try to list all the modules that could not be found
+ let biHandlers = localHandlers bi
+ sourceDirs =
+ map getSymbolicPath (hsSourceDirs bi)
+ ++ [ autogenComponentModulesDir lbi clbi
+ , autogenPackageModulesDir lbi
+ ]
+ sequence_
+ [ preprocessFile
+ (map unsafeMakeSymbolicPath sourceDirs)
+ dir
+ isSrcDist
+ (ModuleName.toFilePath modu)
+ verbosity
+ builtinSuffixes
+ biHandlers
+ False
+ | modu <- modules
+ ]
+ -- XXX: what we do here (re SymbolicPath dir)
+ -- XXX: 2020-10-15 do we rely here on CWD being the PackageDir?
+ -- Note we don't fail on missing in this case, because the main file may be generated later (i.e. by a test code generator)
+ preprocessFile
+ (unsafeMakeSymbolicPath dir : hsSourceDirs bi)
+ dir
+ isSrcDist
+ (dropExtensions $ exePath)
+ verbosity
+ builtinSuffixes
+ biHandlers
+ False
+
+-- TODO: try to list all the modules that could not be found
-- not just the first one. It's annoying and slow due to the need
-- to reconfigure after editing the .cabal file each time.
-- | Find the first extension of the file that exists, and preprocess it
-- if required.
preprocessFile
- :: [SymbolicPath PackageDir SourceDir] -- ^ source directories
-
- -> FilePath -- ^build directory
- -> Bool -- ^preprocess for sdist
- -> FilePath -- ^module file name
- -> Verbosity -- ^verbosity
- -> [String] -- ^builtin suffixes
- -> [(String, PreProcessor)] -- ^possible preprocessors
- -> Bool -- ^fail on missing file
- -> IO ()
+ :: [SymbolicPath PackageDir SourceDir]
+ -- ^ source directories
+ -> FilePath
+ -- ^ build directory
+ -> Bool
+ -- ^ preprocess for sdist
+ -> FilePath
+ -- ^ module file name
+ -> Verbosity
+ -- ^ verbosity
+ -> [String]
+ -- ^ builtin suffixes
+ -> [(String, PreProcessor)]
+ -- ^ possible preprocessors
+ -> Bool
+ -- ^ fail on missing file
+ -> IO ()
preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers failOnMissing = do
- -- look for files in the various source dirs with this module name
- -- and a file extension of a known preprocessor
- psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile
- case psrcFiles of
- -- no preprocessor file exists, look for an ordinary source file
- -- just to make sure one actually exists at all for this module.
- -- Note: by looking in the target/output build dir too, we allow
- -- source files to appear magically in the target build dir without
- -- any corresponding "real" source file. This lets custom Setup.hs
- -- files generate source modules directly into the build dir without
- -- the rest of the build system being aware of it (somewhat dodgy)
- Nothing -> do
- bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile
- case (bsrcFiles, failOnMissing) of
- (Nothing, True) ->
- die' verbosity $ "can't find source for " ++ baseFile
- ++ " in " ++ intercalate ", " (map getSymbolicPath searchLoc)
- _ -> return ()
- -- found a pre-processable file in one of the source dirs
- Just (psrcLoc, psrcRelFile) -> do
- let (srcStem, ext) = splitExtension psrcRelFile
- psrcFile = psrcLoc </> psrcRelFile
- pp = fromMaybe (error "Distribution.Simple.PreProcess: Just expected")
- (lookup (safeTail ext) handlers)
- -- Preprocessing files for 'sdist' is different from preprocessing
- -- for 'build'. When preprocessing for sdist we preprocess to
- -- avoid that the user has to have the preprocessors available.
- -- ATM, we don't have a way to specify which files are to be
- -- preprocessed and which not, so for sdist we only process
- -- platform independent files and put them into the 'buildLoc'
- -- (which we assume is set to the temp. directory that will become
- -- the tarball).
- --TODO: eliminate sdist variant, just supply different handlers
- when (not forSDist || forSDist && platformIndependent pp) $ do
- -- look for existing pre-processed source file in the dest dir to
- -- see if we really have to re-run the preprocessor.
- ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile
- recomp <- case ppsrcFiles of
- Nothing -> return True
- Just ppsrcFile ->
- psrcFile `moreRecentFile` ppsrcFile
- when recomp $ do
- let destDir = buildLoc </> dirName srcStem
- createDirectoryIfMissingVerbose verbosity True destDir
- runPreProcessorWithHsBootHack pp
- (psrcLoc, psrcRelFile)
- (buildLoc, srcStem <.> "hs")
-
+ -- look for files in the various source dirs with this module name
+ -- and a file extension of a known preprocessor
+ psrcFiles <- findFileWithExtension' (map fst handlers) (map getSymbolicPath searchLoc) baseFile
+ case psrcFiles of
+ -- no preprocessor file exists, look for an ordinary source file
+ -- just to make sure one actually exists at all for this module.
+ -- Note: by looking in the target/output build dir too, we allow
+ -- source files to appear magically in the target build dir without
+ -- any corresponding "real" source file. This lets custom Setup.hs
+ -- files generate source modules directly into the build dir without
+ -- the rest of the build system being aware of it (somewhat dodgy)
+ Nothing -> do
+ bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : map getSymbolicPath searchLoc) baseFile
+ case (bsrcFiles, failOnMissing) of
+ (Nothing, True) ->
+ die' verbosity $
+ "can't find source for "
+ ++ baseFile
+ ++ " in "
+ ++ intercalate ", " (map getSymbolicPath searchLoc)
+ _ -> return ()
+ -- found a pre-processable file in one of the source dirs
+ Just (psrcLoc, psrcRelFile) -> do
+ let (srcStem, ext) = splitExtension psrcRelFile
+ psrcFile = psrcLoc </> psrcRelFile
+ pp =
+ fromMaybe
+ (error "Distribution.Simple.PreProcess: Just expected")
+ (lookup (safeTail ext) handlers)
+ -- Preprocessing files for 'sdist' is different from preprocessing
+ -- for 'build'. When preprocessing for sdist we preprocess to
+ -- avoid that the user has to have the preprocessors available.
+ -- ATM, we don't have a way to specify which files are to be
+ -- preprocessed and which not, so for sdist we only process
+ -- platform independent files and put them into the 'buildLoc'
+ -- (which we assume is set to the temp. directory that will become
+ -- the tarball).
+ -- TODO: eliminate sdist variant, just supply different handlers
+ when (not forSDist || forSDist && platformIndependent pp) $ do
+ -- look for existing pre-processed source file in the dest dir to
+ -- see if we really have to re-run the preprocessor.
+ ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile
+ recomp <- case ppsrcFiles of
+ Nothing -> return True
+ Just ppsrcFile ->
+ psrcFile `moreRecentFile` ppsrcFile
+ when recomp $ do
+ let destDir = buildLoc </> dirName srcStem
+ createDirectoryIfMissingVerbose verbosity True destDir
+ runPreProcessorWithHsBootHack
+ pp
+ (psrcLoc, psrcRelFile)
+ (buildLoc, srcStem <.> "hs")
where
dirName = takeDirectory
@@ -340,48 +420,55 @@ preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes ha
-- then we need to copy the hs-boot file there too. This should probably be
-- done another way. Possibly we should also be looking for .lhs-boot
-- files, but I think that preprocessors only produce .hs files.
- runPreProcessorWithHsBootHack pp
- (inBaseDir, inRelativeFile)
+ runPreProcessorWithHsBootHack
+ pp
+ (inBaseDir, inRelativeFile)
(outBaseDir, outRelativeFile) = do
- runPreProcessor pp
+ runPreProcessor
+ pp
(inBaseDir, inRelativeFile)
- (outBaseDir, outRelativeFile) verbosity
+ (outBaseDir, outRelativeFile)
+ verbosity
exists <- doesFileExist inBoot
when exists $ copyFileVerbose verbosity inBoot outBoot
+ where
+ inBoot = replaceExtension inFile "hs-boot"
+ outBoot = replaceExtension outFile "hs-boot"
- where
- inBoot = replaceExtension inFile "hs-boot"
- outBoot = replaceExtension outFile "hs-boot"
-
- inFile = normalise (inBaseDir </> inRelativeFile)
- outFile = normalise (outBaseDir </> outRelativeFile)
+ inFile = normalise (inBaseDir </> inRelativeFile)
+ outFile = normalise (outBaseDir </> outRelativeFile)
-- ------------------------------------------------------------
+
-- * known preprocessors
+
-- ------------------------------------------------------------
ppGreenCard :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
-ppGreenCard _ lbi _
- = PreProcessor {
- platformIndependent = False,
- ppOrdering = unsorted,
- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
- runDbProgram verbosity greencardProgram (withPrograms lbi)
- (["-tffi", "-o" ++ outFile, inFile])
- }
+ppGreenCard _ lbi _ =
+ PreProcessor
+ { platformIndependent = False
+ , ppOrdering = unsorted
+ , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
+ runDbProgram
+ verbosity
+ greencardProgram
+ (withPrograms lbi)
+ (["-tffi", "-o" ++ outFile, inFile])
+ }
-- This one is useful for preprocessors that can't handle literate source.
-- We also need a way to chain preprocessors.
ppUnlit :: PreProcessor
ppUnlit =
- PreProcessor {
- platformIndependent = True,
- ppOrdering = unsorted,
- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
- withUTF8FileContents inFile $ \contents ->
- either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents)
- }
+ PreProcessor
+ { platformIndependent = True
+ , ppOrdering = unsorted
+ , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
+ withUTF8FileContents inFile $ \contents ->
+ either (writeUTF8File outFile) (die' verbosity) (unlit inFile contents)
+ }
ppCpp :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ppCpp = ppCpp' []
@@ -389,161 +476,198 @@ ppCpp = ppCpp' []
ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ppCpp' extraArgs bi lbi clbi =
case compilerFlavor (compiler lbi) of
- GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi
+ GHC -> ppGhcCpp ghcProgram (const True) args bi lbi clbi
GHCJS -> ppGhcCpp ghcjsProgram (const True) args bi lbi clbi
- _ -> ppCpphs args bi lbi clbi
- where cppArgs = getCppOptions bi lbi
- args = cppArgs ++ extraArgs
-
-ppGhcCpp :: Program -> (Version -> Bool)
- -> [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
+ _ -> ppCpphs args bi lbi clbi
+ where
+ cppArgs = getCppOptions bi lbi
+ args = cppArgs ++ extraArgs
+
+ppGhcCpp
+ :: Program
+ -> (Version -> Bool)
+ -> [String]
+ -> BuildInfo
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> PreProcessor
ppGhcCpp program xHs extraArgs _bi lbi clbi =
- PreProcessor {
- platformIndependent = False,
- ppOrdering = unsorted,
- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
- (prog, version, _) <- requireProgramVersion verbosity
- program anyVersion (withPrograms lbi)
- runProgram verbosity prog $
+ PreProcessor
+ { platformIndependent = False
+ , ppOrdering = unsorted
+ , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
+ (prog, version, _) <-
+ requireProgramVersion
+ verbosity
+ program
+ anyVersion
+ (withPrograms lbi)
+ runProgram verbosity prog $
["-E", "-cpp"]
- -- This is a bit of an ugly hack. We're going to
- -- unlit the file ourselves later on if appropriate,
- -- so we need GHC not to unlit it now or it'll get
- -- double-unlitted. In the future we might switch to
- -- using cpphs --unlit instead.
- ++ (if xHs version then ["-x", "hs"] else [])
- ++ [ "-optP-include", "-optP"++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]
- ++ ["-o", outFile, inFile]
- ++ extraArgs
- }
+ -- This is a bit of an ugly hack. We're going to
+ -- unlit the file ourselves later on if appropriate,
+ -- so we need GHC not to unlit it now or it'll get
+ -- double-unlitted. In the future we might switch to
+ -- using cpphs --unlit instead.
+ ++ (if xHs version then ["-x", "hs"] else [])
+ ++ ["-optP-include", "-optP" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]
+ ++ ["-o", outFile, inFile]
+ ++ extraArgs
+ }
ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ppCpphs extraArgs _bi lbi clbi =
- PreProcessor {
- platformIndependent = False,
- ppOrdering = unsorted,
- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
- (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity
- cpphsProgram anyVersion (withPrograms lbi)
- runProgram verbosity cpphsProg $
- ("-O" ++ outFile) : inFile
- : "--noline" : "--strip"
- : (if cpphsVersion >= mkVersion [1,6]
- then ["--include="++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]
- else [])
- ++ extraArgs
- }
+ PreProcessor
+ { platformIndependent = False
+ , ppOrdering = unsorted
+ , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
+ (cpphsProg, cpphsVersion, _) <-
+ requireProgramVersion
+ verbosity
+ cpphsProgram
+ anyVersion
+ (withPrograms lbi)
+ runProgram verbosity cpphsProg $
+ ("-O" ++ outFile)
+ : inFile
+ : "--noline"
+ : "--strip"
+ : ( if cpphsVersion >= mkVersion [1, 6]
+ then ["--include=" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]
+ else []
+ )
+ ++ extraArgs
+ }
ppHsc2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ppHsc2hs bi lbi clbi =
- PreProcessor {
- platformIndependent = False,
- ppOrdering = unsorted,
- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
- (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
- (hsc2hsProg, hsc2hsVersion, _) <- requireProgramVersion verbosity
- hsc2hsProgram anyVersion (withPrograms lbi)
- -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122.
- let isCross = hostPlatform lbi /= buildPlatform
- prependCrossFlags = if isCross then ("-x":) else id
- let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0,68,4]
- pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile
- if hsc2hsSupportsResponseFiles
- then withResponseFile
- verbosity
- defaultTempFileOptions
- (takeDirectory outFile)
- "hsc2hs-response.txt"
- Nothing
- pureArgs
- (\responseFileName ->
- runProgram verbosity hsc2hsProg (prependCrossFlags ["@"++ responseFileName]))
- else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs)
- }
+ PreProcessor
+ { platformIndependent = False
+ , ppOrdering = unsorted
+ , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do
+ (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
+ (hsc2hsProg, hsc2hsVersion, _) <-
+ requireProgramVersion
+ verbosity
+ hsc2hsProgram
+ anyVersion
+ (withPrograms lbi)
+ -- See Trac #13896 and https://github.com/haskell/cabal/issues/3122.
+ let isCross = hostPlatform lbi /= buildPlatform
+ prependCrossFlags = if isCross then ("-x" :) else id
+ let hsc2hsSupportsResponseFiles = hsc2hsVersion >= mkVersion [0, 68, 4]
+ pureArgs = genPureArgs hsc2hsVersion gccProg inFile outFile
+ if hsc2hsSupportsResponseFiles
+ then
+ withResponseFile
+ verbosity
+ defaultTempFileOptions
+ (takeDirectory outFile)
+ "hsc2hs-response.txt"
+ Nothing
+ pureArgs
+ ( \responseFileName ->
+ runProgram verbosity hsc2hsProg (prependCrossFlags ["@" ++ responseFileName])
+ )
+ else runProgram verbosity hsc2hsProg (prependCrossFlags pureArgs)
+ }
where
-- Returns a list of command line arguments that can either be passed
-- directly, or via a response file.
genPureArgs :: Version -> ConfiguredProgram -> String -> String -> [String]
genPureArgs hsc2hsVersion gccProg inFile outFile =
- -- Additional gcc options
- [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg
- ++ programOverrideArgs gccProg ]
- ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg
- ++ programOverrideArgs gccProg ]
-
- -- OSX frameworks:
- ++ [ what ++ "=-F" ++ opt
- | isOSX
- , opt <- nub (concatMap Installed.frameworkDirs pkgs)
- , what <- ["--cflag", "--lflag"] ]
- ++ [ "--lflag=" ++ arg
- | isOSX
- , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs
- , arg <- ["-framework", opt] ]
-
- -- Note that on ELF systems, wherever we use -L, we must also use -R
- -- because presumably that -L dir is not on the normal path for the
- -- system's dynamic linker. This is needed because hsc2hs works by
- -- compiling a C program and then running it.
-
- ++ [ "--cflag=" ++ opt | opt <- platformDefines lbi ]
-
- -- Options from the current package:
- ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ]
- ++ [ "--cflag=-I" ++ buildDir lbi </> dir | dir <- PD.includeDirs bi ]
- ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi
- ++ PD.cppOptions bi
- -- hsc2hs uses the C ABI
- -- We assume that there are only C sources
- -- and C++ functions are exported via a C
- -- interface and wrapped in a C source file.
- -- Therefore we do not supply C++ flags
- -- because there will not be C++ sources.
- --
- -- DO NOT add PD.cxxOptions unless this changes!
- ]
- ++ [ "--cflag=" ++ opt | opt <-
- [ "-I" ++ autogenComponentModulesDir lbi clbi,
- "-I" ++ autogenPackageModulesDir lbi,
- "-include", autogenComponentModulesDir lbi clbi </> cppHeaderName ] ]
- ++ [ "--lflag=-L" ++ opt
- | opt <-
+ -- Additional gcc options
+ [ "--cflag=" ++ opt
+ | opt <-
+ programDefaultArgs gccProg
+ ++ programOverrideArgs gccProg
+ ]
+ ++ [ "--lflag=" ++ opt
+ | opt <-
+ programDefaultArgs gccProg
+ ++ programOverrideArgs gccProg
+ ]
+ -- OSX frameworks:
+ ++ [ what ++ "=-F" ++ opt
+ | isOSX
+ , opt <- nub (concatMap Installed.frameworkDirs pkgs)
+ , what <- ["--cflag", "--lflag"]
+ ]
+ ++ [ "--lflag=" ++ arg
+ | isOSX
+ , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs
+ , arg <- ["-framework", opt]
+ ]
+ -- Note that on ELF systems, wherever we use -L, we must also use -R
+ -- because presumably that -L dir is not on the normal path for the
+ -- system's dynamic linker. This is needed because hsc2hs works by
+ -- compiling a C program and then running it.
+
+ ++ ["--cflag=" ++ opt | opt <- platformDefines lbi]
+ -- Options from the current package:
+ ++ ["--cflag=-I" ++ dir | dir <- PD.includeDirs bi]
+ ++ ["--cflag=-I" ++ buildDir lbi </> dir | dir <- PD.includeDirs bi]
+ ++ [ "--cflag=" ++ opt
+ | opt <-
+ PD.ccOptions bi
+ ++ PD.cppOptions bi
+ -- hsc2hs uses the C ABI
+ -- We assume that there are only C sources
+ -- and C++ functions are exported via a C
+ -- interface and wrapped in a C source file.
+ -- Therefore we do not supply C++ flags
+ -- because there will not be C++ sources.
+ --
+ -- DO NOT add PD.cxxOptions unless this changes!
+ ]
+ ++ [ "--cflag=" ++ opt
+ | opt <-
+ [ "-I" ++ autogenComponentModulesDir lbi clbi
+ , "-I" ++ autogenPackageModulesDir lbi
+ , "-include"
+ , autogenComponentModulesDir lbi clbi </> cppHeaderName
+ ]
+ ]
+ ++ [ "--lflag=-L" ++ opt
+ | opt <-
if withFullyStaticExe lbi
then PD.extraLibDirsStatic bi
else PD.extraLibDirs bi
- ]
- ++ [ "--lflag=-Wl,-R," ++ opt
- | isELF
- , opt <-
+ ]
+ ++ [ "--lflag=-Wl,-R," ++ opt
+ | isELF
+ , opt <-
if withFullyStaticExe lbi
then PD.extraLibDirsStatic bi
else PD.extraLibDirs bi
- ]
- ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ]
- ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ]
-
- -- Options from dependent packages
- ++ [ "--cflag=" ++ opt
- | pkg <- pkgs
- , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]
- ++ [ opt | opt <- Installed.ccOptions pkg ] ]
- ++ [ "--lflag=" ++ opt
- | pkg <- pkgs
- , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ]
- ++ [ "-Wl,-R," ++ opt | isELF
- , opt <- Installed.libraryDirs pkg ]
+ ]
+ ++ ["--lflag=-l" ++ opt | opt <- PD.extraLibs bi]
+ ++ ["--lflag=" ++ opt | opt <- PD.ldOptions bi]
+ -- Options from dependent packages
+ ++ [ "--cflag=" ++ opt
+ | pkg <- pkgs
+ , opt <-
+ ["-I" ++ opt | opt <- Installed.includeDirs pkg]
+ ++ [opt | opt <- Installed.ccOptions pkg]
+ ]
+ ++ [ "--lflag=" ++ opt
+ | pkg <- pkgs
+ , opt <-
+ ["-L" ++ opt | opt <- Installed.libraryDirs pkg]
+ ++ [ "-Wl,-R," ++ opt | isELF, opt <- Installed.libraryDirs pkg
+ ]
++ [ "-l" ++ opt
| opt <-
- if withFullyStaticExe lbi
- then Installed.extraLibrariesStatic pkg
- else Installed.extraLibraries pkg
+ if withFullyStaticExe lbi
+ then Installed.extraLibrariesStatic pkg
+ else Installed.extraLibraries pkg
]
- ++ [ opt | opt <- Installed.ldOptions pkg ] ]
- ++ preccldFlags
- ++ hsc2hsOptions bi
- ++ postccldFlags
-
- ++ ["-o", outFile, inFile]
+ ++ [opt | opt <- Installed.ldOptions pkg]
+ ]
+ ++ preccldFlags
+ ++ hsc2hsOptions bi
+ ++ postccldFlags
+ ++ ["-o", outFile, inFile]
where
-- hsc2hs flag parsing was wrong
-- (see -- https://github.com/haskell/hsc2hs/issues/35)
@@ -555,128 +679,140 @@ ppHsc2hs bi lbi clbi =
]
(preccldFlags, postccldFlags)
- | hsc2hsVersion >= mkVersion [0,68,8] = (ccldFlags, [])
- | otherwise = ([], ccldFlags)
+ | hsc2hsVersion >= mkVersion [0, 68, 8] = (ccldFlags, [])
+ | otherwise = ([], ccldFlags)
hacked_index = packageHacks (installedPkgs lbi)
-- Look only at the dependencies of the current component
-- being built! This relies on 'installedPkgs' maintaining
-- 'InstalledPackageInfo' for internal deps too; see #2971.
pkgs = PackageIndex.topologicalOrder $
- case PackageIndex.dependencyClosure hacked_index
- (map fst (componentPackageDeps clbi)) of
- Left index' -> index'
- Right inf ->
- error ("ppHsc2hs: broken closure: " ++ show inf)
+ case PackageIndex.dependencyClosure
+ hacked_index
+ (map fst (componentPackageDeps clbi)) of
+ Left index' -> index'
+ Right inf ->
+ error ("ppHsc2hs: broken closure: " ++ show inf)
isOSX = case buildOS of OSX -> True; _ -> False
- isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True;
+ isELF = case buildOS of OSX -> False; Windows -> False; AIX -> False; _ -> True
packageHacks = case compilerFlavor (compiler lbi) of
- GHC -> hackRtsPackage
+ GHC -> hackRtsPackage
GHCJS -> hackRtsPackage
- _ -> id
+ _ -> id
-- We don't link in the actual Haskell libraries of our dependencies, so
-- the -u flags in the ldOptions of the rts package mean linking fails on
-- OS X (its ld is a tad stricter than gnu ld). Thus we remove the
-- ldOptions for GHC's rts package:
hackRtsPackage index =
case PackageIndex.lookupPackageName index (mkPackageName "rts") of
- [(_, [rts])]
- -> PackageIndex.insert rts { Installed.ldOptions = [] } index
- _ -> error "No (or multiple) ghc rts package is registered!!"
+ [(_, [rts])] ->
+ PackageIndex.insert rts{Installed.ldOptions = []} index
+ _ -> error "No (or multiple) ghc rts package is registered!!"
ppHsc2hsExtras :: PreProcessorExtras
-ppHsc2hsExtras buildBaseDir = filter ("_hsc.c" `isSuffixOf`) `fmap`
- getDirectoryContentsRecursive buildBaseDir
+ppHsc2hsExtras buildBaseDir =
+ filter ("_hsc.c" `isSuffixOf`)
+ `fmap` getDirectoryContentsRecursive buildBaseDir
ppC2hs :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
ppC2hs bi lbi clbi =
- PreProcessor {
- platformIndependent = False,
- ppOrdering = unsorted,
- runPreProcessor = \(inBaseDir, inRelativeFile)
- (outBaseDir, outRelativeFile) verbosity -> do
- (c2hsProg, _, _) <- requireProgramVersion verbosity
- c2hsProgram (orLaterVersion (mkVersion [0,15]))
- (withPrograms lbi)
- (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
- runProgram verbosity c2hsProg $
-
- -- Options from the current package:
- [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ]
- ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ]
- ++ [ "--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName) ]
- ++ [ "--include=" ++ outBaseDir ]
-
- -- Options from dependent packages
- ++ [ "--cppopts=" ++ opt
- | pkg <- pkgs
- , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]
- ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg
- -- c2hs uses the C ABI
- -- We assume that there are only C sources
- -- and C++ functions are exported via a C
- -- interface and wrapped in a C source file.
- -- Therefore we do not supply C++ flags
- -- because there will not be C++ sources.
- --
- --
- -- DO NOT add Installed.cxxOptions unless this changes!
- , c `elem` "DIU" ] ]
- --TODO: install .chi files for packages, so we can --include
- -- those dirs here, for the dependencies
-
- -- input and output files
- ++ [ "--output-dir=" ++ outBaseDir
- , "--output=" ++ outRelativeFile
- , inBaseDir </> inRelativeFile ]
- }
+ PreProcessor
+ { platformIndependent = False
+ , ppOrdering = unsorted
+ , runPreProcessor =
+ \(inBaseDir, inRelativeFile)
+ (outBaseDir, outRelativeFile)
+ verbosity -> do
+ (c2hsProg, _, _) <-
+ requireProgramVersion
+ verbosity
+ c2hsProgram
+ (orLaterVersion (mkVersion [0, 15]))
+ (withPrograms lbi)
+ (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi)
+ runProgram verbosity c2hsProg $
+ -- Options from the current package:
+ ["--cpp=" ++ programPath gccProg, "--cppopts=-E"]
+ ++ ["--cppopts=" ++ opt | opt <- getCppOptions bi lbi]
+ ++ ["--cppopts=-include" ++ (autogenComponentModulesDir lbi clbi </> cppHeaderName)]
+ ++ ["--include=" ++ outBaseDir]
+ -- Options from dependent packages
+ ++ [ "--cppopts=" ++ opt
+ | pkg <- pkgs
+ , opt <-
+ ["-I" ++ opt | opt <- Installed.includeDirs pkg]
+ ++ [ opt | opt@('-' : c : _) <- Installed.ccOptions pkg,
+ -- c2hs uses the C ABI
+ -- We assume that there are only C sources
+ -- and C++ functions are exported via a C
+ -- interface and wrapped in a C source file.
+ -- Therefore we do not supply C++ flags
+ -- because there will not be C++ sources.
+ --
+ --
+ -- DO NOT add Installed.cxxOptions unless this changes!
+ c `elem` "DIU"
+ ]
+ ]
+ -- TODO: install .chi files for packages, so we can --include
+ -- those dirs here, for the dependencies
+
+ -- input and output files
+ ++ [ "--output-dir=" ++ outBaseDir
+ , "--output=" ++ outRelativeFile
+ , inBaseDir </> inRelativeFile
+ ]
+ }
where
pkgs = PackageIndex.topologicalOrder (installedPkgs lbi)
ppC2hsExtras :: PreProcessorExtras
-ppC2hsExtras d = filter (\p -> takeExtensions p == ".chs.c") `fmap`
- getDirectoryContentsRecursive d
+ppC2hsExtras d =
+ filter (\p -> takeExtensions p == ".chs.c")
+ `fmap` getDirectoryContentsRecursive d
---TODO: perhaps use this with hsc2hs too
---TODO: remove cc-options from cpphs for cabal-version: >= 1.10
---TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC
+-- TODO: perhaps use this with hsc2hs too
+-- TODO: remove cc-options from cpphs for cabal-version: >= 1.10
+-- TODO: Refactor and add separate getCppOptionsForHs, getCppOptionsForCxx, & getCppOptionsForC
-- instead of combining all these cases in a single function. This blind combination can
-- potentially lead to compilation inconsistencies.
getCppOptions :: BuildInfo -> LocalBuildInfo -> [String]
-getCppOptions bi lbi
- = platformDefines lbi
- ++ cppOptions bi
- ++ ["-I" ++ dir | dir <- PD.includeDirs bi]
- ++ [opt | opt@('-':c:_) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"]
+getCppOptions bi lbi =
+ platformDefines lbi
+ ++ cppOptions bi
+ ++ ["-I" ++ dir | dir <- PD.includeDirs bi]
+ ++ [opt | opt@('-' : c : _) <- PD.ccOptions bi ++ PD.cxxOptions bi, c `elem` "DIU"]
platformDefines :: LocalBuildInfo -> [String]
platformDefines lbi =
case compilerFlavor comp of
- GHC ->
- ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++
- ["-D" ++ os ++ "_BUILD_OS=1"] ++
- ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++
- map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++
- map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
+ GHC ->
+ ["-D__GLASGOW_HASKELL__=" ++ versionInt version]
+ ++ ["-D" ++ os ++ "_BUILD_OS=1"]
+ ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"]
+ ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr
+ ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
GHCJS ->
- compatGlasgowHaskell ++
- ["-D__GHCJS__=" ++ versionInt version] ++
- ["-D" ++ os ++ "_BUILD_OS=1"] ++
- ["-D" ++ arch ++ "_BUILD_ARCH=1"] ++
- map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++
- map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
- HaskellSuite {} ->
- ["-D__HASKELL_SUITE__"] ++
- map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr ++
- map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
- _ -> []
+ compatGlasgowHaskell
+ ++ ["-D__GHCJS__=" ++ versionInt version]
+ ++ ["-D" ++ os ++ "_BUILD_OS=1"]
+ ++ ["-D" ++ arch ++ "_BUILD_ARCH=1"]
+ ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr
+ ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
+ HaskellSuite{} ->
+ ["-D__HASKELL_SUITE__"]
+ ++ map (\os' -> "-D" ++ os' ++ "_HOST_OS=1") osStr
+ ++ map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr
+ _ -> []
where
comp = compiler lbi
Platform hostArch hostOS = hostPlatform lbi
version = compilerVersion comp
compatGlasgowHaskell =
- maybe [] (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])
- (compilerCompatVersion GHC comp)
+ maybe
+ []
+ (\v -> ["-D__GLASGOW_HASKELL__=" ++ versionInt v])
+ (compilerCompatVersion GHC comp)
-- TODO: move this into the compiler abstraction
-- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all
-- the other compilers. Check if that's really what they want.
@@ -684,144 +820,155 @@ platformDefines lbi =
versionInt v = case versionNumbers v of
[] -> "1"
[n] -> show n
- n1:n2:_ ->
+ n1 : n2 : _ ->
-- 6.8.x -> 608
-- 6.10.x -> 610
let s1 = show n1
s2 = show n2
middle = case s2 of
- _ : _ : _ -> ""
- _ -> "0"
- in s1 ++ middle ++ s2
+ _ : _ : _ -> ""
+ _ -> "0"
+ in s1 ++ middle ++ s2
osStr = case hostOS of
- Linux -> ["linux"]
- Windows -> ["mingw32"]
- OSX -> ["darwin"]
- FreeBSD -> ["freebsd"]
- OpenBSD -> ["openbsd"]
- NetBSD -> ["netbsd"]
+ Linux -> ["linux"]
+ Windows -> ["mingw32"]
+ OSX -> ["darwin"]
+ FreeBSD -> ["freebsd"]
+ OpenBSD -> ["openbsd"]
+ NetBSD -> ["netbsd"]
DragonFly -> ["dragonfly"]
- Solaris -> ["solaris2"]
- AIX -> ["aix"]
- HPUX -> ["hpux"]
- IRIX -> ["irix"]
- HaLVM -> []
- IOS -> ["ios"]
- Android -> ["android"]
- Ghcjs -> ["ghcjs"]
- Wasi -> ["wasi"]
- Hurd -> ["hurd"]
+ Solaris -> ["solaris2"]
+ AIX -> ["aix"]
+ HPUX -> ["hpux"]
+ IRIX -> ["irix"]
+ HaLVM -> []
+ IOS -> ["ios"]
+ Android -> ["android"]
+ Ghcjs -> ["ghcjs"]
+ Wasi -> ["wasi"]
+ Hurd -> ["hurd"]
OtherOS _ -> []
archStr = case hostArch of
- I386 -> ["i386"]
- X86_64 -> ["x86_64"]
- PPC -> ["powerpc"]
- PPC64 -> ["powerpc64"]
- Sparc -> ["sparc"]
- Arm -> ["arm"]
- AArch64 -> ["aarch64"]
- Mips -> ["mips"]
- SH -> []
- IA64 -> ["ia64"]
- S390 -> ["s390"]
- S390X -> ["s390x"]
- Alpha -> ["alpha"]
- Hppa -> ["hppa"]
- Rs6000 -> ["rs6000"]
- M68k -> ["m68k"]
- Vax -> ["vax"]
- JavaScript -> ["javascript"]
- Wasm32 -> ["wasm32"]
+ I386 -> ["i386"]
+ X86_64 -> ["x86_64"]
+ PPC -> ["powerpc"]
+ PPC64 -> ["powerpc64"]
+ Sparc -> ["sparc"]
+ Arm -> ["arm"]
+ AArch64 -> ["aarch64"]
+ Mips -> ["mips"]
+ SH -> []
+ IA64 -> ["ia64"]
+ S390 -> ["s390"]
+ S390X -> ["s390x"]
+ Alpha -> ["alpha"]
+ Hppa -> ["hppa"]
+ Rs6000 -> ["rs6000"]
+ M68k -> ["m68k"]
+ Vax -> ["vax"]
+ JavaScript -> ["javascript"]
+ Wasm32 -> ["wasm32"]
OtherArch _ -> []
ppHappy :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
-ppHappy _ lbi _ = pp { platformIndependent = True }
- where pp = standardPP lbi happyProgram (hcFlags hc)
- hc = compilerFlavor (compiler lbi)
- hcFlags GHC = ["-agc"]
- hcFlags GHCJS = ["-agc"]
- hcFlags _ = []
+ppHappy _ lbi _ = pp{platformIndependent = True}
+ where
+ pp = standardPP lbi happyProgram (hcFlags hc)
+ hc = compilerFlavor (compiler lbi)
+ hcFlags GHC = ["-agc"]
+ hcFlags GHCJS = ["-agc"]
+ hcFlags _ = []
ppAlex :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
-ppAlex _ lbi _ = pp { platformIndependent = True }
- where pp = standardPP lbi alexProgram (hcFlags hc)
- hc = compilerFlavor (compiler lbi)
- hcFlags GHC = ["-g"]
- hcFlags GHCJS = ["-g"]
- hcFlags _ = []
+ppAlex _ lbi _ = pp{platformIndependent = True}
+ where
+ pp = standardPP lbi alexProgram (hcFlags hc)
+ hc = compilerFlavor (compiler lbi)
+ hcFlags GHC = ["-g"]
+ hcFlags GHCJS = ["-g"]
+ hcFlags _ = []
standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor
standardPP lbi prog args =
- PreProcessor {
- platformIndependent = False,
- ppOrdering = unsorted,
- runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
- runDbProgram verbosity prog (withPrograms lbi)
- (args ++ ["-o", outFile, inFile])
- }
-
--- |Convenience function; get the suffixes of these preprocessors.
-ppSuffixes :: [ PPSuffixHandler ] -> [String]
+ PreProcessor
+ { platformIndependent = False
+ , ppOrdering = unsorted
+ , runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity ->
+ runDbProgram
+ verbosity
+ prog
+ (withPrograms lbi)
+ (args ++ ["-o", outFile, inFile])
+ }
+
+-- | Convenience function; get the suffixes of these preprocessors.
+ppSuffixes :: [PPSuffixHandler] -> [String]
ppSuffixes = map fst
--- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs.
-knownSuffixHandlers :: [ PPSuffixHandler ]
+-- | Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs.
+knownSuffixHandlers :: [PPSuffixHandler]
knownSuffixHandlers =
- [ ("gc", ppGreenCard)
- , ("chs", ppC2hs)
- , ("hsc", ppHsc2hs)
- , ("x", ppAlex)
- , ("y", ppHappy)
- , ("ly", ppHappy)
- , ("cpphs", ppCpp)
+ [ ("gc", ppGreenCard)
+ , ("chs", ppC2hs)
+ , ("hsc", ppHsc2hs)
+ , ("x", ppAlex)
+ , ("y", ppHappy)
+ , ("ly", ppHappy)
+ , ("cpphs", ppCpp)
]
--- |Standard preprocessors with possible extra C sources: c2hs, hsc2hs.
-knownExtrasHandlers :: [ PreProcessorExtras ]
-knownExtrasHandlers = [ ppC2hsExtras, ppHsc2hsExtras ]
+-- | Standard preprocessors with possible extra C sources: c2hs, hsc2hs.
+knownExtrasHandlers :: [PreProcessorExtras]
+knownExtrasHandlers = [ppC2hsExtras, ppHsc2hsExtras]
-- | Find any extra C sources generated by preprocessing that need to
-- be added to the component (addresses issue #238).
-preprocessExtras :: Verbosity
- -> Component
- -> LocalBuildInfo
- -> IO [FilePath]
+preprocessExtras
+ :: Verbosity
+ -> Component
+ -> LocalBuildInfo
+ -> IO [FilePath]
preprocessExtras verbosity comp lbi = case comp of
CLib _ -> pp $ buildDir lbi
- (CExe Executable { exeName = nm }) -> do
+ (CExe Executable{exeName = nm}) -> do
let nm' = unUnqualComponentName nm
pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"
- (CFLib ForeignLib { foreignLibName = nm }) -> do
+ (CFLib ForeignLib{foreignLibName = nm}) -> do
let nm' = unUnqualComponentName nm
pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"
CTest test -> do
let nm' = unUnqualComponentName $ testName test
case testInterface test of
TestSuiteExeV10 _ _ ->
- pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"
+ pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"
TestSuiteLibV09 _ _ ->
- pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp"
+ pp $ buildDir lbi </> stubName test </> stubName test ++ "-tmp"
TestSuiteUnsupported tt ->
- die' verbosity $ "No support for preprocessing test suite type " ++
- prettyShow tt
+ die' verbosity $
+ "No support for preprocessing test suite type "
+ ++ prettyShow tt
CBench bm -> do
let nm' = unUnqualComponentName $ benchmarkName bm
case benchmarkInterface bm of
BenchmarkExeV10 _ _ ->
- pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"
+ pp $ buildDir lbi </> nm' </> nm' ++ "-tmp"
BenchmarkUnsupported tt ->
- die' verbosity $ "No support for preprocessing benchmark "
- ++ "type " ++ prettyShow tt
+ die' verbosity $
+ "No support for preprocessing benchmark "
+ ++ "type "
+ ++ prettyShow tt
where
pp :: FilePath -> IO [FilePath]
pp dir = do
- b <- doesDirectoryExist dir
- if b
- then (map (dir </>) . filter not_sub . concat)
- <$> for knownExtrasHandlers
- (withLexicalCallStack (\f -> f dir))
- else pure []
+ b <- doesDirectoryExist dir
+ if b
+ then
+ (map (dir </>) . filter not_sub . concat)
+ <$> for
+ knownExtrasHandlers
+ (withLexicalCallStack (\f -> f dir))
+ else pure []
-- TODO: This is a terrible hack to work around #3545 while we don't
-- reorganize the directory layout. Basically, for the main
-- library, we might accidentally pick up autogenerated sources for
@@ -831,11 +978,12 @@ preprocessExtras verbosity comp lbi = case comp of
-- if a user has a test suite named foobar and puts their C file in
-- foobar/foo.c, this test will incorrectly exclude it. But I
-- didn't want to break BC...
- not_sub p = and [ not (pre `isPrefixOf` p) | pre <- component_dirs ]
+ not_sub p = and [not (pre `isPrefixOf` p) | pre <- component_dirs]
component_dirs = component_names (localPkgDescr lbi)
-- TODO: libify me
- component_names pkg_descr = fmap unUnqualComponentName $
- mapMaybe (libraryNameString . libName) (subLibraries pkg_descr) ++
- map exeName (executables pkg_descr) ++
- map testName (testSuites pkg_descr) ++
- map benchmarkName (benchmarks pkg_descr)
+ component_names pkg_descr =
+ fmap unUnqualComponentName $
+ mapMaybe (libraryNameString . libName) (subLibraries pkg_descr)
+ ++ map exeName (executables pkg_descr)
+ ++ map testName (testSuites pkg_descr)
+ ++ map benchmarkName (benchmarks pkg_descr)
diff --git a/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs b/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs
index bcd2649a3118ddd593e50f247760dd72670967ae..a4a1e6719cd66f8418a20e334d84a00204f2b146 100644
--- a/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs
+++ b/Cabal/src/Distribution/Simple/PreProcess/Unlit.hs
@@ -1,4 +1,9 @@
-----------------------------------------------------------------------------
+
+-- This version is interesting because instead of striping comment lines, it
+-- turns them into "-- " style comments. This allows using haddock markup
+-- in literate scripts without having to use "> --" prefix.
+
-- |
-- Module : Distribution.Simple.PreProcess.Unlit
-- Copyright : ...
@@ -8,73 +13,77 @@
--
-- Remove the \"literal\" markups from a Haskell source file, including
-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\"
+module Distribution.Simple.PreProcess.Unlit (unlit, plain) where
--- This version is interesting because instead of striping comment lines, it
--- turns them into "-- " style comments. This allows using haddock markup
--- in literate scripts without having to use "> --" prefix.
-
-module Distribution.Simple.PreProcess.Unlit (unlit,plain) where
-
-import Prelude ()
import Distribution.Compat.Prelude
-import Distribution.Utils.Generic (safeTail, safeLast, safeInit)
+import Distribution.Utils.Generic (safeInit, safeLast, safeTail)
+import Prelude ()
import Data.List (mapAccumL)
-data Classified = BirdTrack String | Blank String | Ordinary String
- | Line !Int String | CPP String
- | BeginCode | EndCode
- -- output only:
- | Error String | Comment String
+data Classified
+ = BirdTrack String
+ | Blank String
+ | Ordinary String
+ | Line !Int String
+ | CPP String
+ | BeginCode
+ | EndCode
+ | -- output only:
+ Error String
+ | Comment String
-- | No unliteration.
plain :: String -> String -> String
plain _ hs = hs
classify :: String -> Classified
-classify ('>':s) = BirdTrack s
-classify ('#':s) = case tokens s of
- (line:file@('"':_:_):_) | all isDigit line
- && safeLast file == Just '"'
- -- this shouldn't fail as we tested for 'all isDigit'
- -> Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse
- _ -> CPP s
- where tokens = unfoldr $ \str -> case lex str of
- (t@(_:_), str'):_ -> Just (t, str')
- _ -> Nothing
-classify ('\\':s)
+classify ('>' : s) = BirdTrack s
+classify ('#' : s) = case tokens s of
+ (line : file@('"' : _ : _) : _)
+ | all isDigit line
+ && safeLast file == Just '"' ->
+ -- this shouldn't fail as we tested for 'all isDigit'
+ Line (fromMaybe (error $ "panic! read @Int " ++ show line) $ readMaybe line) (safeTail (safeInit file)) -- TODO:eradicateNoParse
+ _ -> CPP s
+ where
+ tokens = unfoldr $ \str -> case lex str of
+ (t@(_ : _), str') : _ -> Just (t, str')
+ _ -> Nothing
+classify ('\\' : s)
| "begin{code}" `isPrefixOf` s = BeginCode
- | "end{code}" `isPrefixOf` s = EndCode
-classify s | all isSpace s = Blank s
-classify s = Ordinary s
+ | "end{code}" `isPrefixOf` s = EndCode
+classify s | all isSpace s = Blank s
+classify s = Ordinary s
-- So the weird exception for comment indenting is to make things work with
-- haddock, see classifyAndCheckForBirdTracks below.
unclassify :: Bool -> Classified -> String
-unclassify _ (BirdTrack s) = ' ':s
-unclassify _ (Blank s) = s
-unclassify _ (Ordinary s) = s
-unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file
-unclassify _ (CPP s) = '#':s
-unclassify True (Comment "") = " --"
-unclassify True (Comment s) = " -- " ++ s
-unclassify False (Comment "") = "--"
-unclassify False (Comment s) = "-- " ++ s
-unclassify _ _ = internalError
+unclassify _ (BirdTrack s) = ' ' : s
+unclassify _ (Blank s) = s
+unclassify _ (Ordinary s) = s
+unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file
+unclassify _ (CPP s) = '#' : s
+unclassify True (Comment "") = " --"
+unclassify True (Comment s) = " -- " ++ s
+unclassify False (Comment "") = "--"
+unclassify False (Comment s) = "-- " ++ s
+unclassify _ _ = internalError
-- | 'unlit' takes a filename (for error reports), and transforms the
-- given string, to eliminate the literate comments from the program text.
unlit :: FilePath -> String -> Either String String
unlit file input =
- let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks
- . inlines
- $ input
- in either (Left . unlines . map (unclassify usesBirdTracks))
- Right
- . checkErrors
- . reclassify
- $ classified
-
+ let (usesBirdTracks, classified) =
+ classifyAndCheckForBirdTracks
+ . inlines
+ $ input
+ in either
+ (Left . unlines . map (unclassify usesBirdTracks))
+ Right
+ . checkErrors
+ . reclassify
+ $ classified
where
-- So haddock requires comments and code to align, since it treats comments
-- as following the layout rule. This is a pain for us since bird track
@@ -94,16 +103,17 @@ unlit file input =
in (seenBirdTrack || isBirdTrack classification, classification)
isBirdTrack (BirdTrack _) = True
- isBirdTrack _ = False
-
- checkErrors ls = case [ e | Error e <- ls ] of
- [] -> Left ls
- (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message)
- where (f, n) = errorPos file 1 ls
- errorPos f n [] = (f, n)
- errorPos f n (Error _:_) = (f, n)
- errorPos _ _ (Line n' f':ls) = errorPos f' n' ls
- errorPos f n (_ :ls) = errorPos f (n+1) ls
+ isBirdTrack _ = False
+
+ checkErrors ls = case [e | Error e <- ls] of
+ [] -> Left ls
+ (message : _) -> Right (f ++ ":" ++ show n ++ ": " ++ message)
+ where
+ (f, n) = errorPos file 1 ls
+ errorPos f n [] = (f, n)
+ errorPos f n (Error _ : _) = (f, n)
+ errorPos _ _ (Line n' f' : ls) = errorPos f' n' ls
+ errorPos f n (_ : ls) = errorPos f (n + 1) ls
-- Here we model a state machine, with each state represented by
-- a local function. We only have four states (well, five,
@@ -117,51 +127,51 @@ unlit file input =
reclassify :: [Classified] -> [Classified]
reclassify = blank -- begin in blank state
where
- latex [] = []
- latex (EndCode :ls) = Blank "" : comment ls
- latex (BeginCode :_ ) = [Error "\\begin{code} in code section"]
- latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls
- latex ( l:ls) = l : latex ls
-
- blank [] = []
- blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"]
- blank (BeginCode :ls) = Blank "" : latex ls
- blank (BirdTrack l:ls) = BirdTrack l : bird ls
- blank (Ordinary l:ls) = Comment l : comment ls
- blank ( l:ls) = l : blank ls
-
- bird [] = []
- bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"]
- bird (BeginCode :ls) = Blank "" : latex ls
- bird (Blank l :ls) = Blank l : blank ls
- bird (Ordinary _:_ ) = [Error "program line before comment line"]
- bird ( l:ls) = l : bird ls
-
- comment [] = []
- comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"]
- comment (BeginCode :ls) = Blank "" : latex ls
- comment (CPP l :ls) = CPP l : comment ls
- comment (BirdTrack _:_ ) = [Error "comment line before program line"]
+ latex [] = []
+ latex (EndCode : ls) = Blank "" : comment ls
+ latex (BeginCode : _) = [Error "\\begin{code} in code section"]
+ latex (BirdTrack l : ls) = Ordinary ('>' : l) : latex ls
+ latex (l : ls) = l : latex ls
+
+ blank [] = []
+ blank (EndCode : _) = [Error "\\end{code} without \\begin{code}"]
+ blank (BeginCode : ls) = Blank "" : latex ls
+ blank (BirdTrack l : ls) = BirdTrack l : bird ls
+ blank (Ordinary l : ls) = Comment l : comment ls
+ blank (l : ls) = l : blank ls
+
+ bird [] = []
+ bird (EndCode : _) = [Error "\\end{code} without \\begin{code}"]
+ bird (BeginCode : ls) = Blank "" : latex ls
+ bird (Blank l : ls) = Blank l : blank ls
+ bird (Ordinary _ : _) = [Error "program line before comment line"]
+ bird (l : ls) = l : bird ls
+
+ comment [] = []
+ comment (EndCode : _) = [Error "\\end{code} without \\begin{code}"]
+ comment (BeginCode : ls) = Blank "" : latex ls
+ comment (CPP l : ls) = CPP l : comment ls
+ comment (BirdTrack _ : _) = [Error "comment line before program line"]
-- a blank line and another ordinary line following a comment
-- will be treated as continuing the comment. Otherwise it's
-- then end of the comment, with a blank line.
- comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls
- comment (Blank l:ls) = Blank l : blank ls
- comment (Line n f :ls) = Line n f : comment ls
- comment (Ordinary l:ls) = Comment l : comment ls
- comment (Comment _: _) = internalError
- comment (Error _: _) = internalError
+ comment (Blank l : ls@(Ordinary _ : _)) = Comment l : comment ls
+ comment (Blank l : ls) = Blank l : blank ls
+ comment (Line n f : ls) = Line n f : comment ls
+ comment (Ordinary l : ls) = Comment l : comment ls
+ comment (Comment _ : _) = internalError
+ comment (Error _ : _) = internalError
-- Re-implementation of 'lines', for better efficiency (but decreased laziness).
-- Also, importantly, accepts non-standard DOS and Mac line ending characters.
inlines :: String -> [String]
inlines xs = lines' xs id
where
- lines' [] acc = [acc []]
- lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS
- lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS
- lines' ('\n':s) acc = acc [] : lines' s id -- Unix
- lines' (c:s) acc = lines' s (acc . (c:))
+ lines' [] acc = [acc []]
+ lines' ('\^M' : '\n' : s) acc = acc [] : lines' s id -- DOS
+ lines' ('\^M' : s) acc = acc [] : lines' s id -- MacOS
+ lines' ('\n' : s) acc = acc [] : lines' s id -- Unix
+ lines' (c : s) acc = lines' s (acc . (c :))
internalError :: a
internalError = error "unlit: internal error"
diff --git a/Cabal/src/Distribution/Simple/Program.hs b/Cabal/src/Distribution/Simple/Program.hs
index c51108119821b8f441ecb96887916cf76bf9103c..7423b5d1455e53756a1696b5ac1dea26a0f7c4d6 100644
--- a/Cabal/src/Distribution/Simple/Program.hs
+++ b/Cabal/src/Distribution/Simple/Program.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program
-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009
@@ -34,150 +35,166 @@
-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a
-- hook user the ability to get the above flags and such so that they
-- don't have to write all the PATH logic inside Setup.lhs.
-
-module Distribution.Simple.Program (
- -- * Program and functions for constructing them
- Program(..)
- , ProgramSearchPath
- , ProgramSearchPathEntry(..)
- , simpleProgram
- , findProgramOnSearchPath
- , defaultProgramSearchPath
- , findProgramVersion
+module Distribution.Simple.Program
+ ( -- * Program and functions for constructing them
+ Program (..)
+ , ProgramSearchPath
+ , ProgramSearchPathEntry (..)
+ , simpleProgram
+ , findProgramOnSearchPath
+ , defaultProgramSearchPath
+ , findProgramVersion
-- * Configured program and related functions
- , ConfiguredProgram(..)
- , programPath
- , ProgArg
- , ProgramLocation(..)
- , runProgram
- , getProgramOutput
- , suppressOverrideArgs
+ , ConfiguredProgram (..)
+ , programPath
+ , ProgArg
+ , ProgramLocation (..)
+ , runProgram
+ , getProgramOutput
+ , suppressOverrideArgs
-- * Program invocations
- , ProgramInvocation(..)
- , emptyProgramInvocation
- , simpleProgramInvocation
- , programInvocation
- , runProgramInvocation
- , getProgramInvocationOutput
- , getProgramInvocationLBS
+ , ProgramInvocation (..)
+ , emptyProgramInvocation
+ , simpleProgramInvocation
+ , programInvocation
+ , runProgramInvocation
+ , getProgramInvocationOutput
+ , getProgramInvocationLBS
-- * The collection of unconfigured and configured programs
- , builtinPrograms
+ , builtinPrograms
-- * The collection of configured programs we can run
- , ProgramDb
- , defaultProgramDb
- , emptyProgramDb
- , restoreProgramDb
- , addKnownProgram
- , addKnownPrograms
- , lookupKnownProgram
- , knownPrograms
- , getProgramSearchPath
- , setProgramSearchPath
- , userSpecifyPath
- , userSpecifyPaths
- , userMaybeSpecifyPath
- , userSpecifyArgs
- , userSpecifyArgss
- , userSpecifiedArgs
- , lookupProgram
- , lookupProgramVersion
- , updateProgram
- , configureProgram
- , configureAllKnownPrograms
- , reconfigurePrograms
- , requireProgram
- , requireProgramVersion
- , needProgram
- , runDbProgram
- , getDbProgramOutput
+ , ProgramDb
+ , defaultProgramDb
+ , emptyProgramDb
+ , restoreProgramDb
+ , addKnownProgram
+ , addKnownPrograms
+ , lookupKnownProgram
+ , knownPrograms
+ , getProgramSearchPath
+ , setProgramSearchPath
+ , userSpecifyPath
+ , userSpecifyPaths
+ , userMaybeSpecifyPath
+ , userSpecifyArgs
+ , userSpecifyArgss
+ , userSpecifiedArgs
+ , lookupProgram
+ , lookupProgramVersion
+ , updateProgram
+ , configureProgram
+ , configureAllKnownPrograms
+ , reconfigurePrograms
+ , requireProgram
+ , requireProgramVersion
+ , needProgram
+ , runDbProgram
+ , getDbProgramOutput
-- * Programs that Cabal knows about
- , ghcProgram
- , ghcPkgProgram
- , ghcjsProgram
- , ghcjsPkgProgram
- , hmakeProgram
- , jhcProgram
- , uhcProgram
- , gccProgram
- , arProgram
- , stripProgram
- , happyProgram
- , alexProgram
- , hsc2hsProgram
- , c2hsProgram
- , cpphsProgram
- , hscolourProgram
- , doctestProgram
- , haddockProgram
- , greencardProgram
- , ldProgram
- , tarProgram
- , cppProgram
- , pkgConfigProgram
- , hpcProgram
- ) where
+ , ghcProgram
+ , ghcPkgProgram
+ , ghcjsProgram
+ , ghcjsPkgProgram
+ , hmakeProgram
+ , jhcProgram
+ , uhcProgram
+ , gccProgram
+ , arProgram
+ , stripProgram
+ , happyProgram
+ , alexProgram
+ , hsc2hsProgram
+ , c2hsProgram
+ , cpphsProgram
+ , hscolourProgram
+ , doctestProgram
+ , haddockProgram
+ , greencardProgram
+ , ldProgram
+ , tarProgram
+ , cppProgram
+ , pkgConfigProgram
+ , hpcProgram
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Simple.Program.Types
-import Distribution.Simple.Program.Run
-import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Builtin
+import Distribution.Simple.Program.Db
import Distribution.Simple.Program.Find
+import Distribution.Simple.Program.Run
+import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Verbosity
-- | Runs the given configured program.
-runProgram :: Verbosity -- ^Verbosity
- -> ConfiguredProgram -- ^The program to run
- -> [ProgArg] -- ^Any /extra/ arguments to add
- -> IO ()
+runProgram
+ :: Verbosity
+ -- ^ Verbosity
+ -> ConfiguredProgram
+ -- ^ The program to run
+ -> [ProgArg]
+ -- ^ Any /extra/ arguments to add
+ -> IO ()
runProgram verbosity prog args =
runProgramInvocation verbosity (programInvocation prog args)
-
-- | Runs the given configured program and gets the output.
---
-getProgramOutput :: Verbosity -- ^Verbosity
- -> ConfiguredProgram -- ^The program to run
- -> [ProgArg] -- ^Any /extra/ arguments to add
- -> IO String
+getProgramOutput
+ :: Verbosity
+ -- ^ Verbosity
+ -> ConfiguredProgram
+ -- ^ The program to run
+ -> [ProgArg]
+ -- ^ Any /extra/ arguments to add
+ -> IO String
getProgramOutput verbosity prog args =
getProgramInvocationOutput verbosity (programInvocation prog args)
-
-- | Looks up the given program in the program database and runs it.
---
-runDbProgram :: Verbosity -- ^verbosity
- -> Program -- ^The program to run
- -> ProgramDb -- ^look up the program here
- -> [ProgArg] -- ^Any /extra/ arguments to add
- -> IO ()
+runDbProgram
+ :: Verbosity
+ -- ^ verbosity
+ -> Program
+ -- ^ The program to run
+ -> ProgramDb
+ -- ^ look up the program here
+ -> [ProgArg]
+ -- ^ Any /extra/ arguments to add
+ -> IO ()
runDbProgram verbosity prog programDb args =
case lookupProgram prog programDb of
- Nothing -> die' verbosity notFound
+ Nothing -> die' verbosity notFound
Just configuredProg -> runProgram verbosity configuredProg args
- where
- notFound = "The program '" ++ programName prog
- ++ "' is required but it could not be found"
+ where
+ notFound =
+ "The program '"
+ ++ programName prog
+ ++ "' is required but it could not be found"
-- | Looks up the given program in the program database and runs it.
---
-getDbProgramOutput :: Verbosity -- ^verbosity
- -> Program -- ^The program to run
- -> ProgramDb -- ^look up the program here
- -> [ProgArg] -- ^Any /extra/ arguments to add
- -> IO String
+getDbProgramOutput
+ :: Verbosity
+ -- ^ verbosity
+ -> Program
+ -- ^ The program to run
+ -> ProgramDb
+ -- ^ look up the program here
+ -> [ProgArg]
+ -- ^ Any /extra/ arguments to add
+ -> IO String
getDbProgramOutput verbosity prog programDb args =
case lookupProgram prog programDb of
- Nothing -> die' verbosity notFound
+ Nothing -> die' verbosity notFound
Just configuredProg -> getProgramOutput verbosity configuredProg args
- where
- notFound = "The program '" ++ programName prog
- ++ "' is required but it could not be found"
+ where
+ notFound =
+ "The program '"
+ ++ programName prog
+ ++ "' is required but it could not be found"
diff --git a/Cabal/src/Distribution/Simple/Program/Ar.hs b/Cabal/src/Distribution/Simple/Program/Ar.hs
index 6c2ef09ecca4fa68d06bdcdeda2af5508b36d51c..b5d1cfe65e66dff4b722f62adc2083e4bc532b3c 100644
--- a/Cabal/src/Distribution/Simple/Program/Ar.hs
+++ b/Cabal/src/Distribution/Simple/Program/Ar.hs
@@ -1,9 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE NondecreasingIndentation #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Ar
-- Copyright : Duncan Coutts 2009
@@ -12,127 +13,155 @@
-- Portability : portable
--
-- This module provides an library interface to the @ar@ program.
-
-module Distribution.Simple.Program.Ar (
- createArLibArchive,
- multiStageProgramInvocation
+module Distribution.Simple.Program.Ar
+ ( createArLibArchive
+ , multiStageProgramInvocation
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import Distribution.Compat.CopyFile (filesEqual)
-import Distribution.Simple.Compiler (arResponseFilesSupported, arDashLSupported)
-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
+import Distribution.Simple.Compiler (arDashLSupported, arResponseFilesSupported)
+import Distribution.Simple.Flag
+ ( fromFlagOrDefault
+ )
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
import Distribution.Simple.Program
- ( ProgramInvocation, arProgram, requireProgram )
+ ( ProgramInvocation
+ , arProgram
+ , requireProgram
+ )
import Distribution.Simple.Program.ResponseFile
- ( withResponseFile )
+ ( withResponseFile
+ )
import Distribution.Simple.Program.Run
- ( programInvocation, multiStageProgramInvocation
- , runProgramInvocation )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault )
+ ( multiStageProgramInvocation
+ , programInvocation
+ , runProgramInvocation
+ )
import Distribution.Simple.Setup.Config
- ( configUseResponseFiles )
+ ( configUseResponseFiles
+ )
import Distribution.Simple.Utils
- ( defaultTempFileOptions, dieWithLocation', withTempDirectory )
+ ( defaultTempFileOptions
+ , dieWithLocation'
+ , withTempDirectory
+ )
import Distribution.System
- ( Arch(..), OS(..), Platform(..) )
+ ( Arch (..)
+ , OS (..)
+ , Platform (..)
+ )
import Distribution.Verbosity
- ( Verbosity, deafening, verbose )
+ ( Verbosity
+ , deafening
+ , verbose
+ )
import System.Directory (doesFileExist, renameFile)
-import System.FilePath ((</>), splitFileName)
+import System.FilePath (splitFileName, (</>))
import System.IO
- ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek)
- , hFileSize, hSeek, withBinaryFile )
+ ( Handle
+ , IOMode (ReadWriteMode)
+ , SeekMode (AbsoluteSeek)
+ , hFileSize
+ , hSeek
+ , withBinaryFile
+ )
-- | Call @ar@ to create a library archive from a bunch of object files.
---
-createArLibArchive :: Verbosity -> LocalBuildInfo
- -> FilePath -> [FilePath] -> IO ()
+createArLibArchive
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -> [FilePath]
+ -> IO ()
createArLibArchive verbosity lbi targetPath files = do
(ar, _) <- requireProgram verbosity arProgram progDb
let (targetDir, targetName) = splitFileName targetPath
- withTempDirectory verbosity targetDir "objs" $ \ tmpDir -> do
- let tmpPath = tmpDir </> targetName
-
- -- The args to use with "ar" are actually rather subtle and system-dependent.
- -- In particular we have the following issues:
- --
- -- -- On OS X, "ar q" does not make an archive index. Archives with no
- -- index cannot be used.
- --
- -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us
- -- do that. We have duplicates because of modules like "A.M" and "B.M"
- -- both make an object file "M.o" and ar does not consider the directory.
- --
- -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier
- -- in "q" mode which compels the archiver to add the members of an input
- -- archive to the output, rather than the archive itself. This is
- -- necessary as GHC may produce .o files that are actually archives. See
- -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068.
- --
- -- Our solution is to use "ar r" in the simple case when one call is enough.
- -- When we need to call ar multiple times we use "ar q" and for the last
- -- call on OSX we use "ar qs" so that it'll make the index.
-
- let simpleArgs = case hostOS of
- OSX -> ["-r", "-s"]
- _ | dashLSupported -> ["-qL"]
- _ -> ["-r"]
-
- initialArgs = ["-q"]
- finalArgs = case hostOS of
- OSX -> ["-q", "-s"]
- _ | dashLSupported -> ["-qL"]
- _ -> ["-q"]
-
- extraArgs = verbosityOpts verbosity ++ [tmpPath]
-
- simple = programInvocation ar (simpleArgs ++ extraArgs)
- initial = programInvocation ar (initialArgs ++ extraArgs)
- middle = initial
- final = programInvocation ar (finalArgs ++ extraArgs)
-
- oldVersionManualOverride =
- fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
- responseArgumentsNotSupported =
- not (arResponseFilesSupported (compiler lbi))
- dashLSupported =
- arDashLSupported (compiler lbi)
-
- invokeWithResponesFile :: FilePath -> ProgramInvocation
- invokeWithResponesFile atFile =
- programInvocation ar $
- simpleArgs ++ extraArgs ++ ['@' : atFile]
-
- if oldVersionManualOverride || responseArgumentsNotSupported
- then
- sequence_
- [ runProgramInvocation verbosity inv
- | inv <- multiStageProgramInvocation
- simple (initial, middle, final) files ]
- else
- withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $
+ withTempDirectory verbosity targetDir "objs" $ \tmpDir -> do
+ let tmpPath = tmpDir </> targetName
+
+ -- The args to use with "ar" are actually rather subtle and system-dependent.
+ -- In particular we have the following issues:
+ --
+ -- -- On OS X, "ar q" does not make an archive index. Archives with no
+ -- index cannot be used.
+ --
+ -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us
+ -- do that. We have duplicates because of modules like "A.M" and "B.M"
+ -- both make an object file "M.o" and ar does not consider the directory.
+ --
+ -- -- llvm-ar, which GHC >=9.4 uses on Windows, supports a "L" modifier
+ -- in "q" mode which compels the archiver to add the members of an input
+ -- archive to the output, rather than the archive itself. This is
+ -- necessary as GHC may produce .o files that are actually archives. See
+ -- https://gitlab.haskell.org/ghc/ghc/-/issues/21068.
+ --
+ -- Our solution is to use "ar r" in the simple case when one call is enough.
+ -- When we need to call ar multiple times we use "ar q" and for the last
+ -- call on OSX we use "ar qs" so that it'll make the index.
+
+ let simpleArgs = case hostOS of
+ OSX -> ["-r", "-s"]
+ _ | dashLSupported -> ["-qL"]
+ _ -> ["-r"]
+
+ initialArgs = ["-q"]
+ finalArgs = case hostOS of
+ OSX -> ["-q", "-s"]
+ _ | dashLSupported -> ["-qL"]
+ _ -> ["-q"]
+
+ extraArgs = verbosityOpts verbosity ++ [tmpPath]
+
+ simple = programInvocation ar (simpleArgs ++ extraArgs)
+ initial = programInvocation ar (initialArgs ++ extraArgs)
+ middle = initial
+ final = programInvocation ar (finalArgs ++ extraArgs)
+
+ oldVersionManualOverride =
+ fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
+ responseArgumentsNotSupported =
+ not (arResponseFilesSupported (compiler lbi))
+ dashLSupported =
+ arDashLSupported (compiler lbi)
+
+ invokeWithResponesFile :: FilePath -> ProgramInvocation
+ invokeWithResponesFile atFile =
+ programInvocation ar $
+ simpleArgs ++ extraArgs ++ ['@' : atFile]
+
+ if oldVersionManualOverride || responseArgumentsNotSupported
+ then
+ sequence_
+ [ runProgramInvocation verbosity inv
+ | inv <-
+ multiStageProgramInvocation
+ simple
+ (initial, middle, final)
+ files
+ ]
+ else withResponseFile verbosity defaultTempFileOptions tmpDir "ar.rsp" Nothing files $
\path -> runProgramInvocation verbosity $ invokeWithResponesFile path
- unless (hostArch == Arm -- See #1537
- || hostOS == AIX) $ -- AIX uses its own "ar" format variant
- wipeMetadata verbosity tmpPath
- equal <- filesEqual tmpPath targetPath
- unless equal $ renameFile tmpPath targetPath
-
+ unless
+ ( hostArch == Arm -- See #1537
+ || hostOS == AIX
+ )
+ $ wipeMetadata verbosity tmpPath -- AIX uses its own "ar" format variant
+ equal <- filesEqual tmpPath targetPath
+ unless equal $ renameFile tmpPath targetPath
where
progDb = withPrograms lbi
Platform hostArch hostOS = hostPlatform lbi
verbosityOpts v
| v >= deafening = ["-v"]
- | v >= verbose = []
- | otherwise = ["-c"] -- Do not warn if library had to be created.
+ | v >= verbose = []
+ | otherwise = ["-c"] -- Do not warn if library had to be created.
-- | @ar@ by default includes various metadata for each object file in their
-- respective headers, so the output can differ for the same inputs, making
@@ -142,17 +171,18 @@ createArLibArchive verbosity lbi targetPath files = do
-- rather harder than just re-implementing this feature.
wipeMetadata :: Verbosity -> FilePath -> IO ()
wipeMetadata verbosity path = do
- -- Check for existence first (ReadWriteMode would create one otherwise)
- exists <- doesFileExist path
- unless exists $ wipeError "Temporary file disappeared"
- withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h
-
+ -- Check for existence first (ReadWriteMode would create one otherwise)
+ exists <- doesFileExist path
+ unless exists $ wipeError "Temporary file disappeared"
+ withBinaryFile path ReadWriteMode $ \h -> hFileSize h >>= wipeArchive h
where
- wipeError msg = dieWithLocation' verbosity path Nothing $
+ wipeError msg =
+ dieWithLocation' verbosity path Nothing $
"Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg
archLF = "!<arch>\x0a" -- global magic, 8 bytes
x60LF = "\x60\x0a" -- header magic, 2 bytes
- metadata = BS.concat
+ metadata =
+ BS.concat
[ "0 " -- mtime, 12 bytes
, "0 " -- UID, 6 bytes
, "0 " -- GID, 6 bytes
@@ -164,40 +194,41 @@ wipeMetadata verbosity path = do
-- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details
wipeArchive :: Handle -> Integer -> IO ()
wipeArchive h archiveSize = do
- global <- BS.hGet h (BS.length archLF)
- unless (global == archLF) $ wipeError "Bad global header"
- wipeHeader (toInteger $ BS.length archLF)
-
+ global <- BS.hGet h (BS.length archLF)
+ unless (global == archLF) $ wipeError "Bad global header"
+ wipeHeader (toInteger $ BS.length archLF)
where
wipeHeader :: Integer -> IO ()
wipeHeader offset = case compare offset archiveSize of
- EQ -> return ()
- GT -> wipeError (atOffset "Archive truncated")
- LT -> do
- header <- BS.hGet h headerSize
- unless (BS.length header == headerSize) $
- wipeError (atOffset "Short header")
- let magic = BS.drop 58 header
- unless (magic == x60LF) . wipeError . atOffset $
- "Bad magic " ++ show magic ++ " in header"
-
- let name = BS.take 16 header
- let size = BS.take 10 $ BS.drop 48 header
- objSize <- case reads (BS8.unpack size) of
- [(n, s)] | all isSpace s -> return n
- _ -> wipeError (atOffset "Bad file size in header")
-
- let replacement = BS.concat [ name, metadata, size, magic ]
- unless (BS.length replacement == headerSize) $
- wipeError (atOffset "Something has gone terribly wrong")
- hSeek h AbsoluteSeek offset
- BS.hPut h replacement
-
- let nextHeader = offset + toInteger headerSize +
- -- Odd objects are padded with an extra '\x0a'
- if odd objSize then objSize + 1 else objSize
- hSeek h AbsoluteSeek nextHeader
- wipeHeader nextHeader
-
+ EQ -> return ()
+ GT -> wipeError (atOffset "Archive truncated")
+ LT -> do
+ header <- BS.hGet h headerSize
+ unless (BS.length header == headerSize) $
+ wipeError (atOffset "Short header")
+ let magic = BS.drop 58 header
+ unless (magic == x60LF) . wipeError . atOffset $
+ "Bad magic " ++ show magic ++ " in header"
+
+ let name = BS.take 16 header
+ let size = BS.take 10 $ BS.drop 48 header
+ objSize <- case reads (BS8.unpack size) of
+ [(n, s)] | all isSpace s -> return n
+ _ -> wipeError (atOffset "Bad file size in header")
+
+ let replacement = BS.concat [name, metadata, size, magic]
+ unless (BS.length replacement == headerSize) $
+ wipeError (atOffset "Something has gone terribly wrong")
+ hSeek h AbsoluteSeek offset
+ BS.hPut h replacement
+
+ let nextHeader =
+ offset
+ + toInteger headerSize
+ +
+ -- Odd objects are padded with an extra '\x0a'
+ if odd objSize then objSize + 1 else objSize
+ hSeek h AbsoluteSeek nextHeader
+ wipeHeader nextHeader
where
atOffset msg = msg ++ " at offset " ++ show offset
diff --git a/Cabal/src/Distribution/Simple/Program/Builtin.hs b/Cabal/src/Distribution/Simple/Program/Builtin.hs
index 5c615fd5f51ed8543ac916b5cc422b2bed18982b..909ecc7e4b62d9382a8c182068999c26db6ac5cd 100644
--- a/Cabal/src/Distribution/Simple/Program/Builtin.hs
+++ b/Cabal/src/Distribution/Simple/Program/Builtin.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Builtin
-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009
@@ -9,47 +10,45 @@
-- The module defines all the known built-in 'Program's.
--
-- Where possible we try to find their version numbers.
---
-module Distribution.Simple.Program.Builtin (
-
- -- * The collection of unconfigured and configured programs
- builtinPrograms,
+module Distribution.Simple.Program.Builtin
+ ( -- * The collection of unconfigured and configured programs
+ builtinPrograms
-- * Programs that Cabal knows about
- ghcProgram,
- ghcPkgProgram,
- runghcProgram,
- ghcjsProgram,
- ghcjsPkgProgram,
- hmakeProgram,
- jhcProgram,
- haskellSuiteProgram,
- haskellSuitePkgProgram,
- uhcProgram,
- gccProgram,
- arProgram,
- stripProgram,
- happyProgram,
- alexProgram,
- hsc2hsProgram,
- c2hsProgram,
- cpphsProgram,
- hscolourProgram,
- doctestProgram,
- haddockProgram,
- greencardProgram,
- ldProgram,
- tarProgram,
- cppProgram,
- pkgConfigProgram,
- hpcProgram,
+ , ghcProgram
+ , ghcPkgProgram
+ , runghcProgram
+ , ghcjsProgram
+ , ghcjsPkgProgram
+ , hmakeProgram
+ , jhcProgram
+ , haskellSuiteProgram
+ , haskellSuitePkgProgram
+ , uhcProgram
+ , gccProgram
+ , arProgram
+ , stripProgram
+ , happyProgram
+ , alexProgram
+ , hsc2hsProgram
+ , c2hsProgram
+ , cpphsProgram
+ , hscolourProgram
+ , doctestProgram
+ , haddockProgram
+ , greencardProgram
+ , ldProgram
+ , tarProgram
+ , cppProgram
+ , pkgConfigProgram
+ , hpcProgram
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Simple.Program.GHC
import Distribution.Simple.Program.Find
+import Distribution.Simple.Program.GHC
import Distribution.Simple.Program.Internal
import Distribution.Simple.Program.Run
import Distribution.Simple.Program.Types
@@ -60,137 +59,153 @@ import Distribution.Version
import qualified Data.Map as Map
-- ------------------------------------------------------------
+
-- * Known programs
+
-- ------------------------------------------------------------
-- | The default list of programs.
-- These programs are typically used internally to Cabal.
builtinPrograms :: [Program]
builtinPrograms =
- [
- -- compilers and related progs
- ghcProgram
- , runghcProgram
- , ghcPkgProgram
- , ghcjsProgram
- , ghcjsPkgProgram
- , haskellSuiteProgram
- , haskellSuitePkgProgram
- , hmakeProgram
- , jhcProgram
- , uhcProgram
- , hpcProgram
- -- preprocessors
- , hscolourProgram
- , doctestProgram
- , haddockProgram
- , happyProgram
- , alexProgram
- , hsc2hsProgram
- , c2hsProgram
- , cpphsProgram
- , greencardProgram
- -- platform toolchain
- , gccProgram
- , arProgram
- , stripProgram
- , ldProgram
- , tarProgram
- -- configuration tools
- , pkgConfigProgram
- ]
+ [ -- compilers and related progs
+ ghcProgram
+ , runghcProgram
+ , ghcPkgProgram
+ , ghcjsProgram
+ , ghcjsPkgProgram
+ , haskellSuiteProgram
+ , haskellSuitePkgProgram
+ , hmakeProgram
+ , jhcProgram
+ , uhcProgram
+ , hpcProgram
+ , -- preprocessors
+ hscolourProgram
+ , doctestProgram
+ , haddockProgram
+ , happyProgram
+ , alexProgram
+ , hsc2hsProgram
+ , c2hsProgram
+ , cpphsProgram
+ , greencardProgram
+ , -- platform toolchain
+ gccProgram
+ , arProgram
+ , stripProgram
+ , ldProgram
+ , tarProgram
+ , -- configuration tools
+ pkgConfigProgram
+ ]
ghcProgram :: Program
-ghcProgram = (simpleProgram "ghc") {
- programFindVersion = findProgramVersion "--numeric-version" id,
-
- -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825
- -- (spurious warning on non-english locales)
- programPostConf = \_verbosity ghcProg ->
- do let ghcProg' = ghcProg {
- programOverrideEnv = ("LANGUAGE", Just "en")
- : programOverrideEnv ghcProg
- }
- -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4.
- affectedVersionRange = intersectVersionRanges
- (laterVersion $ mkVersion [7,8,0])
- (earlierVersion $ mkVersion [7,8,4])
- return $ maybe ghcProg
- (\v -> if withinRange v affectedVersionRange
- then ghcProg' else ghcProg)
- (programVersion ghcProg),
-
- programNormaliseArgs = normaliseGhcArgs
- }
+ghcProgram =
+ (simpleProgram "ghc")
+ { programFindVersion = findProgramVersion "--numeric-version" id
+ , -- Workaround for https://gitlab.haskell.org/ghc/ghc/-/issues/8825
+ -- (spurious warning on non-english locales)
+ programPostConf = \_verbosity ghcProg ->
+ do
+ let ghcProg' =
+ ghcProg
+ { programOverrideEnv =
+ ("LANGUAGE", Just "en")
+ : programOverrideEnv ghcProg
+ }
+ -- Only the 7.8 branch seems to be affected. Fixed in 7.8.4.
+ affectedVersionRange =
+ intersectVersionRanges
+ (laterVersion $ mkVersion [7, 8, 0])
+ (earlierVersion $ mkVersion [7, 8, 4])
+ return $
+ maybe
+ ghcProg
+ ( \v ->
+ if withinRange v affectedVersionRange
+ then ghcProg'
+ else ghcProg
+ )
+ (programVersion ghcProg)
+ , programNormaliseArgs = normaliseGhcArgs
+ }
runghcProgram :: Program
-runghcProgram = (simpleProgram "runghc") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- "runghc 7.10.3"
- (_:ver:_) -> ver
- _ -> ""
- }
+runghcProgram =
+ (simpleProgram "runghc")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "runghc 7.10.3"
+ (_ : ver : _) -> ver
+ _ -> ""
+ }
ghcPkgProgram :: Program
-ghcPkgProgram = (simpleProgram "ghc-pkg") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "ghc-pkg --version" gives a string like
- -- "GHC package manager version 6.4.1"
- case words str of
- (_:_:_:_:ver:_) -> ver
- _ -> ""
- }
+ghcPkgProgram =
+ (simpleProgram "ghc-pkg")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "ghc-pkg --version" gives a string like
+ -- "GHC package manager version 6.4.1"
+ case words str of
+ (_ : _ : _ : _ : ver : _) -> ver
+ _ -> ""
+ }
ghcjsProgram :: Program
-ghcjsProgram = (simpleProgram "ghcjs") {
- programFindVersion = findProgramVersion "--numeric-ghcjs-version" id
- }
+ghcjsProgram =
+ (simpleProgram "ghcjs")
+ { programFindVersion = findProgramVersion "--numeric-ghcjs-version" id
+ }
-- note: version is the version number of the GHC version that ghcjs-pkg was built with
ghcjsPkgProgram :: Program
-ghcjsPkgProgram = (simpleProgram "ghcjs-pkg") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "ghcjs-pkg --version" gives a string like
- -- "GHCJS package manager version 6.4.1"
- case words str of
- (_:_:_:_:ver:_) -> ver
- _ -> ""
- }
+ghcjsPkgProgram =
+ (simpleProgram "ghcjs-pkg")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "ghcjs-pkg --version" gives a string like
+ -- "GHCJS package manager version 6.4.1"
+ case words str of
+ (_ : _ : _ : _ : ver : _) -> ver
+ _ -> ""
+ }
hmakeProgram :: Program
-hmakeProgram = (simpleProgram "hmake") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "hmake --version" gives a string line
- -- "/usr/local/bin/hmake: 3.13 (2006-11-01)"
- case words str of
- (_:ver:_) -> ver
- _ -> ""
- }
+hmakeProgram =
+ (simpleProgram "hmake")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "hmake --version" gives a string line
+ -- "/usr/local/bin/hmake: 3.13 (2006-11-01)"
+ case words str of
+ (_ : ver : _) -> ver
+ _ -> ""
+ }
jhcProgram :: Program
-jhcProgram = (simpleProgram "jhc") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- invoking "jhc --version" gives a string like
- -- "jhc 0.3.20080208 (wubgipkamcep-2)
- -- compiled by ghc-6.8 on a x86_64 running linux"
- case words str of
- (_:ver:_) -> ver
- _ -> ""
- }
+jhcProgram =
+ (simpleProgram "jhc")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- invoking "jhc --version" gives a string like
+ -- "jhc 0.3.20080208 (wubgipkamcep-2)
+ -- compiled by ghc-6.8 on a x86_64 running linux"
+ case words str of
+ (_ : ver : _) -> ver
+ _ -> ""
+ }
uhcProgram :: Program
-uhcProgram = (simpleProgram "uhc") {
- programFindVersion = findProgramVersion "--version-dotted" id
- }
+uhcProgram =
+ (simpleProgram "uhc")
+ { programFindVersion = findProgramVersion "--version-dotted" id
+ }
hpcProgram :: Program
-hpcProgram = (simpleProgram "hpc")
- {
- programFindVersion = findProgramVersion "version" $ \str ->
- case words str of
- (_ : _ : _ : ver : _) -> ver
- _ -> ""
+hpcProgram =
+ (simpleProgram "hpc")
+ { programFindVersion = findProgramVersion "version" $ \str ->
+ case words str of
+ (_ : _ : _ : ver : _) -> ver
+ _ -> ""
}
-- This represents a haskell-suite compiler. Of course, the compiler
@@ -210,113 +225,123 @@ hpcProgram = (simpleProgram "hpc")
-- The path to the real compiler is found and recorded in the ProgramDb
-- during the configure phase.
haskellSuiteProgram :: Program
-haskellSuiteProgram = (simpleProgram "haskell-suite") {
- -- pretend that the program exists, otherwise it won't be in the
- -- "configured" state
- programFindLocation = \_verbosity _searchPath ->
- return $ Just ("haskell-suite-dummy-location", [])
- }
+haskellSuiteProgram =
+ (simpleProgram "haskell-suite")
+ { -- pretend that the program exists, otherwise it won't be in the
+ -- "configured" state
+ programFindLocation = \_verbosity _searchPath ->
+ return $ Just ("haskell-suite-dummy-location", [])
+ }
-- This represent a haskell-suite package manager. See the comments for
-- haskellSuiteProgram.
haskellSuitePkgProgram :: Program
-haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") {
- programFindLocation = \_verbosity _searchPath ->
- return $ Just ("haskell-suite-pkg-dummy-location", [])
- }
-
+haskellSuitePkgProgram =
+ (simpleProgram "haskell-suite-pkg")
+ { programFindLocation = \_verbosity _searchPath ->
+ return $ Just ("haskell-suite-pkg-dummy-location", [])
+ }
happyProgram :: Program
-happyProgram = (simpleProgram "happy") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "happy --version" gives a string like
- -- "Happy Version 1.16 Copyright (c) ...."
- case words str of
- (_:_:ver:_) -> ver
- _ -> ""
- }
+happyProgram =
+ (simpleProgram "happy")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "happy --version" gives a string like
+ -- "Happy Version 1.16 Copyright (c) ...."
+ case words str of
+ (_ : _ : ver : _) -> ver
+ _ -> ""
+ }
alexProgram :: Program
-alexProgram = (simpleProgram "alex") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "alex --version" gives a string like
- -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow"
- case words str of
- (_:_:ver:_) -> takeWhile (\x -> isDigit x || x == '.') ver
- _ -> ""
- }
+alexProgram =
+ (simpleProgram "alex")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "alex --version" gives a string like
+ -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow"
+ case words str of
+ (_ : _ : ver : _) -> takeWhile (\x -> isDigit x || x == '.') ver
+ _ -> ""
+ }
gccProgram :: Program
-gccProgram = (simpleProgram "gcc") {
- programFindVersion = findProgramVersion "-dumpversion" id
- }
+gccProgram =
+ (simpleProgram "gcc")
+ { programFindVersion = findProgramVersion "-dumpversion" id
+ }
arProgram :: Program
arProgram = simpleProgram "ar"
stripProgram :: Program
-stripProgram = (simpleProgram "strip") {
- programFindVersion = \verbosity ->
- findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)
- }
+stripProgram =
+ (simpleProgram "strip")
+ { programFindVersion = \verbosity ->
+ findProgramVersion "--version" stripExtractVersion (lessVerbose verbosity)
+ }
hsc2hsProgram :: Program
-hsc2hsProgram = (simpleProgram "hsc2hs") {
- programFindVersion =
- findProgramVersion "--version" $ \str ->
- -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66"
- case words str of
- (_:_:ver:_) -> ver
- _ -> ""
- }
+hsc2hsProgram =
+ (simpleProgram "hsc2hs")
+ { programFindVersion =
+ findProgramVersion "--version" $ \str ->
+ -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66"
+ case words str of
+ (_ : _ : ver : _) -> ver
+ _ -> ""
+ }
c2hsProgram :: Program
-c2hsProgram = (simpleProgram "c2hs") {
- programFindVersion = findProgramVersion "--numeric-version" id
- }
+c2hsProgram =
+ (simpleProgram "c2hs")
+ { programFindVersion = findProgramVersion "--numeric-version" id
+ }
cpphsProgram :: Program
-cpphsProgram = (simpleProgram "cpphs") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "cpphs --version" gives a string like "cpphs 1.3"
- case words str of
- (_:ver:_) -> ver
- _ -> ""
- }
+cpphsProgram =
+ (simpleProgram "cpphs")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "cpphs --version" gives a string like "cpphs 1.3"
+ case words str of
+ (_ : ver : _) -> ver
+ _ -> ""
+ }
hscolourProgram :: Program
-hscolourProgram = (simpleProgram "hscolour") {
- programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour",
- programFindVersion = findProgramVersion "-version" $ \str ->
- -- Invoking "HsColour -version" gives a string like "HsColour 1.7"
- case words str of
- (_:ver:_) -> ver
- _ -> ""
- }
+hscolourProgram =
+ (simpleProgram "hscolour")
+ { programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour"
+ , programFindVersion = findProgramVersion "-version" $ \str ->
+ -- Invoking "HsColour -version" gives a string like "HsColour 1.7"
+ case words str of
+ (_ : ver : _) -> ver
+ _ -> ""
+ }
-- TODO: Ensure that doctest is built against the same GHC as the one
-- that's being used. Same for haddock. @phadej pointed this out.
doctestProgram :: Program
-doctestProgram = (simpleProgram "doctest") {
- programFindLocation = \v p -> findProgramOnSearchPath v p "doctest"
- , programFindVersion = findProgramVersion "--version" $ \str ->
- -- "doctest version 0.11.2"
- case words str of
- (_:_:ver:_) -> ver
- _ -> ""
- }
+doctestProgram =
+ (simpleProgram "doctest")
+ { programFindLocation = \v p -> findProgramOnSearchPath v p "doctest"
+ , programFindVersion = findProgramVersion "--version" $ \str ->
+ -- "doctest version 0.11.2"
+ case words str of
+ (_ : _ : ver : _) -> ver
+ _ -> ""
+ }
haddockProgram :: Program
-haddockProgram = (simpleProgram "haddock") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- -- Invoking "haddock --version" gives a string like
- -- "Haddock version 0.8, (c) Simon Marlow 2006"
- case words str of
- (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver
- _ -> "",
-
- programNormaliseArgs = \_ _ args -> args
- }
+haddockProgram =
+ (simpleProgram "haddock")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ -- Invoking "haddock --version" gives a string like
+ -- "Haddock version 0.8, (c) Simon Marlow 2006"
+ case words str of
+ (_ : _ : ver : _) -> takeWhile (`elem` ('.' : ['0' .. '9'])) ver
+ _ -> ""
+ , programNormaliseArgs = \_ _ args -> args
+ }
greencardProgram :: Program
greencardProgram = simpleProgram "greencard"
@@ -325,24 +350,28 @@ ldProgram :: Program
ldProgram = simpleProgram "ld"
tarProgram :: Program
-tarProgram = (simpleProgram "tar") {
- -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the
- -- '--format' option.
- programPostConf = \verbosity tarProg -> do
- tarHelpOutput <- getProgramInvocationOutput
- verbosity (programInvocation tarProg ["--help"])
- -- Some versions of tar don't support '--help'.
- `catchIO` (\_ -> return "")
- let k = "Supports --format"
- v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO"
- m = Map.insert k v (programProperties tarProg)
- return $ tarProg { programProperties = m }
- }
+tarProgram =
+ (simpleProgram "tar")
+ { -- See #1901. Some versions of 'tar' (OpenBSD, NetBSD, ...) don't support the
+ -- '--format' option.
+ programPostConf = \verbosity tarProg -> do
+ tarHelpOutput <-
+ getProgramInvocationOutput
+ verbosity
+ (programInvocation tarProg ["--help"])
+ -- Some versions of tar don't support '--help'.
+ `catchIO` (\_ -> return "")
+ let k = "Supports --format"
+ v = if ("--format" `isInfixOf` tarHelpOutput) then "YES" else "NO"
+ m = Map.insert k v (programProperties tarProg)
+ return $ tarProg{programProperties = m}
+ }
cppProgram :: Program
cppProgram = simpleProgram "cpp"
pkgConfigProgram :: Program
-pkgConfigProgram = (simpleProgram "pkg-config") {
- programFindVersion = findProgramVersion "--version" id
- }
+pkgConfigProgram =
+ (simpleProgram "pkg-config")
+ { programFindVersion = findProgramVersion "--version" id
+ }
diff --git a/Cabal/src/Distribution/Simple/Program/Db.hs b/Cabal/src/Distribution/Simple/Program/Db.hs
index 4657e19b059024dad0d3f5141f3694e57e6707f2..7e151bc06e21b8f7b6975a79074048fb02ca809c 100644
--- a/Cabal/src/Distribution/Simple/Program/Db.hs
+++ b/Cabal/src/Distribution/Simple/Program/Db.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Db
-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009
@@ -23,42 +24,40 @@
-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a
-- hook user the ability to get the above flags and such so that they
-- don't have to write all the PATH logic inside Setup.lhs.
-
-module Distribution.Simple.Program.Db (
- -- * The collection of configured programs we can run
- ProgramDb,
- emptyProgramDb,
- defaultProgramDb,
- restoreProgramDb,
+module Distribution.Simple.Program.Db
+ ( -- * The collection of configured programs we can run
+ ProgramDb
+ , emptyProgramDb
+ , defaultProgramDb
+ , restoreProgramDb
-- ** Query and manipulate the program db
- addKnownProgram,
- addKnownPrograms,
- lookupKnownProgram,
- knownPrograms,
- getProgramSearchPath,
- setProgramSearchPath,
- modifyProgramSearchPath,
- userSpecifyPath,
- userSpecifyPaths,
- userMaybeSpecifyPath,
- userSpecifyArgs,
- userSpecifyArgss,
- userSpecifiedArgs,
- lookupProgram,
- updateProgram,
- configuredPrograms,
+ , addKnownProgram
+ , addKnownPrograms
+ , lookupKnownProgram
+ , knownPrograms
+ , getProgramSearchPath
+ , setProgramSearchPath
+ , modifyProgramSearchPath
+ , userSpecifyPath
+ , userSpecifyPaths
+ , userMaybeSpecifyPath
+ , userSpecifyArgs
+ , userSpecifyArgss
+ , userSpecifiedArgs
+ , lookupProgram
+ , updateProgram
+ , configuredPrograms
-- ** Query and manipulate the program db
- configureProgram,
- configureAllKnownPrograms,
- unconfigureProgram,
- lookupProgramVersion,
- reconfigurePrograms,
- requireProgram,
- requireProgramVersion,
- needProgram,
-
+ , configureProgram
+ , configureAllKnownPrograms
+ , unconfigureProgram
+ , lookupProgramVersion
+ , reconfigurePrograms
+ , requireProgram
+ , requireProgramVersion
+ , needProgram
) where
import Distribution.Compat.Prelude
@@ -69,7 +68,7 @@ import Distribution.Simple.Program.Builtin
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
-import Distribution.Utils.Structured (Structure (..), Structured (..))
+import Distribution.Utils.Structured (Structure (..), Structured (..))
import Distribution.Verbosity
import Distribution.Version
@@ -78,7 +77,9 @@ import Data.Tuple (swap)
import qualified Data.Map as Map
-- ------------------------------------------------------------
+
-- * Programs database
+
-- ------------------------------------------------------------
-- | The configuration is a collection of information about programs. It
@@ -89,17 +90,16 @@ import qualified Data.Map as Map
-- by one we try to configure them at which point we move them into the
-- configured collection. For unconfigured programs we record not just the
-- 'Program' but also any user-provided arguments and location for the program.
-data ProgramDb = ProgramDb {
- unconfiguredProgs :: UnconfiguredProgs,
- progSearchPath :: ProgramSearchPath,
- configuredProgs :: ConfiguredProgs
- }
+data ProgramDb = ProgramDb
+ { unconfiguredProgs :: UnconfiguredProgs
+ , progSearchPath :: ProgramSearchPath
+ , configuredProgs :: ConfiguredProgs
+ }
deriving (Typeable)
type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg])
-type UnconfiguredProgs = Map.Map String UnconfiguredProgram
-type ConfiguredProgs = Map.Map String ConfiguredProgram
-
+type UnconfiguredProgs = Map.Map String UnconfiguredProgram
+type ConfiguredProgs = Map.Map String ConfiguredProgram
emptyProgramDb :: ProgramDb
emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty
@@ -107,38 +107,38 @@ emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty
defaultProgramDb :: ProgramDb
defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb
-
-- internal helpers:
-updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs)
- -> ProgramDb -> ProgramDb
+updateUnconfiguredProgs
+ :: (UnconfiguredProgs -> UnconfiguredProgs)
+ -> ProgramDb
+ -> ProgramDb
updateUnconfiguredProgs update progdb =
- progdb { unconfiguredProgs = update (unconfiguredProgs progdb) }
+ progdb{unconfiguredProgs = update (unconfiguredProgs progdb)}
-updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs)
- -> ProgramDb -> ProgramDb
+updateConfiguredProgs
+ :: (ConfiguredProgs -> ConfiguredProgs)
+ -> ProgramDb
+ -> ProgramDb
updateConfiguredProgs update progdb =
- progdb { configuredProgs = update (configuredProgs progdb) }
-
+ progdb{configuredProgs = update (configuredProgs progdb)}
-- Read & Show instances are based on listToFM
-- | Note that this instance does not preserve the known 'Program's.
-- See 'restoreProgramDb' for details.
---
instance Show ProgramDb where
show = show . Map.toAscList . configuredProgs
-- | Note that this instance does not preserve the known 'Program's.
-- See 'restoreProgramDb' for details.
---
instance Read ProgramDb where
readsPrec p s =
- [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r)
- | (s', r) <- readsPrec p s ]
+ [ (emptyProgramDb{configuredProgs = Map.fromList s'}, r)
+ | (s', r) <- readsPrec p s
+ ]
-- | Note that this instance does not preserve the known 'Program's.
-- See 'restoreProgramDb' for details.
---
instance Binary ProgramDb where
put db = do
put (progSearchPath db)
@@ -146,18 +146,22 @@ instance Binary ProgramDb where
get = do
searchpath <- get
- progs <- get
- return $! emptyProgramDb {
- progSearchPath = searchpath,
- configuredProgs = progs
- }
+ progs <- get
+ return $!
+ emptyProgramDb
+ { progSearchPath = searchpath
+ , configuredProgs = progs
+ }
instance Structured ProgramDb where
- structure p = Nominal (typeRep p) 0 "ProgramDb"
- [ structure (Proxy :: Proxy ProgramSearchPath)
- , structure (Proxy :: Proxy ConfiguredProgs)
- ]
-
+ structure p =
+ Nominal
+ (typeRep p)
+ 0
+ "ProgramDb"
+ [ structure (Proxy :: Proxy ProgramSearchPath)
+ , structure (Proxy :: Proxy ConfiguredProgs)
+ ]
-- | The 'Read'\/'Show' and 'Binary' instances do not preserve all the
-- unconfigured 'Programs' because 'Program' is not in 'Read'\/'Show' because
@@ -166,127 +170,129 @@ instance Structured ProgramDb where
--
-- * It does not add the default programs, but you probably want them, use
-- 'builtinPrograms' in addition to any extra you might need.
---
restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb
restoreProgramDb = addKnownPrograms
-
-- -------------------------------
-- Managing unconfigured programs
-- | Add a known program that we may configure later
---
addKnownProgram :: Program -> ProgramDb -> ProgramDb
-addKnownProgram prog = updateUnconfiguredProgs $
- Map.insertWith combine (programName prog) (prog, Nothing, [])
- where combine _ (_, path, args) = (prog, path, args)
-
+addKnownProgram prog =
+ updateUnconfiguredProgs $
+ Map.insertWith combine (programName prog) (prog, Nothing, [])
+ where
+ combine _ (_, path, args) = (prog, path, args)
addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb
addKnownPrograms progs progdb = foldl' (flip addKnownProgram) progdb progs
-
lookupKnownProgram :: String -> ProgramDb -> Maybe Program
lookupKnownProgram name =
- fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs
-
+ fmap (\(p, _, _) -> p) . Map.lookup name . unconfiguredProgs
knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms progdb =
- [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs progdb)
- , let p' = Map.lookup (programName p) (configuredProgs progdb) ]
+ [ (p, p') | (p, _, _) <- Map.elems (unconfiguredProgs progdb), let p' = Map.lookup (programName p) (configuredProgs progdb)
+ ]
-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'.
-- This is the default list of locations where programs are looked for when
-- configuring them. This can be overridden for specific programs (with
-- 'userSpecifyPath'), and specific known programs can modify or ignore this
-- search path in their own configuration code.
---
getProgramSearchPath :: ProgramDb -> ProgramSearchPath
getProgramSearchPath = progSearchPath
-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'.
-- This will affect programs that are configured from here on, so you
-- should usually set it before configuring any programs.
---
setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb
-setProgramSearchPath searchpath db = db { progSearchPath = searchpath }
+setProgramSearchPath searchpath db = db{progSearchPath = searchpath}
-- | Modify the current 'ProgramSearchPath' used by the 'ProgramDb'.
-- This will affect programs that are configured from here on, so you
-- should usually modify it before configuring any programs.
---
-modifyProgramSearchPath :: (ProgramSearchPath -> ProgramSearchPath)
- -> ProgramDb
- -> ProgramDb
+modifyProgramSearchPath
+ :: (ProgramSearchPath -> ProgramSearchPath)
+ -> ProgramDb
+ -> ProgramDb
modifyProgramSearchPath f db =
setProgramSearchPath (f $ getProgramSearchPath db) db
--- |User-specify this path. Basically override any path information
--- for this program in the configuration. If it's not a known
--- program ignore it.
---
-userSpecifyPath :: String -- ^Program name
- -> FilePath -- ^user-specified path to the program
- -> ProgramDb -> ProgramDb
+-- | User-specify this path. Basically override any path information
+-- for this program in the configuration. If it's not a known
+-- program ignore it.
+userSpecifyPath
+ :: String
+ -- ^ Program name
+ -> FilePath
+ -- ^ user-specified path to the program
+ -> ProgramDb
+ -> ProgramDb
userSpecifyPath name path = updateUnconfiguredProgs $
- flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args)
-
-
-userMaybeSpecifyPath :: String -> Maybe FilePath
- -> ProgramDb -> ProgramDb
-userMaybeSpecifyPath _ Nothing progdb = progdb
+ flip Map.update name $
+ \(prog, _, args) -> Just (prog, Just path, args)
+
+userMaybeSpecifyPath
+ :: String
+ -> Maybe FilePath
+ -> ProgramDb
+ -> ProgramDb
+userMaybeSpecifyPath _ Nothing progdb = progdb
userMaybeSpecifyPath name (Just path) progdb = userSpecifyPath name path progdb
-
--- |User-specify the arguments for this program. Basically override
--- any args information for this program in the configuration. If it's
--- not a known program, ignore it..
-userSpecifyArgs :: String -- ^Program name
- -> [ProgArg] -- ^user-specified args
- -> ProgramDb
- -> ProgramDb
+-- | User-specify the arguments for this program. Basically override
+-- any args information for this program in the configuration. If it's
+-- not a known program, ignore it..
+userSpecifyArgs
+ :: String
+ -- ^ Program name
+ -> [ProgArg]
+ -- ^ user-specified args
+ -> ProgramDb
+ -> ProgramDb
userSpecifyArgs name args' =
- updateUnconfiguredProgs
- (flip Map.update name $
- \(prog, path, args) -> Just (prog, path, args ++ args'))
- . updateConfiguredProgs
- (flip Map.update name $
- \prog -> Just prog { programOverrideArgs = programOverrideArgs prog
- ++ args' })
-
+ updateUnconfiguredProgs
+ ( flip Map.update name $
+ \(prog, path, args) -> Just (prog, path, args ++ args')
+ )
+ . updateConfiguredProgs
+ ( flip Map.update name $
+ \prog ->
+ Just
+ prog
+ { programOverrideArgs =
+ programOverrideArgs prog
+ ++ args'
+ }
+ )
-- | Like 'userSpecifyPath' but for a list of progs and their paths.
---
-userSpecifyPaths :: [(String, FilePath)]
- -> ProgramDb
- -> ProgramDb
+userSpecifyPaths
+ :: [(String, FilePath)]
+ -> ProgramDb
+ -> ProgramDb
userSpecifyPaths paths progdb =
foldl' (\progdb' (prog, path) -> userSpecifyPath prog path progdb') progdb paths
-
-- | Like 'userSpecifyPath' but for a list of progs and their args.
---
-userSpecifyArgss :: [(String, [ProgArg])]
- -> ProgramDb
- -> ProgramDb
+userSpecifyArgss
+ :: [(String, [ProgArg])]
+ -> ProgramDb
+ -> ProgramDb
userSpecifyArgss argss progdb =
foldl' (\progdb' (prog, args) -> userSpecifyArgs prog args progdb') progdb argss
-
-- | Get the path that has been previously specified for a program, if any.
---
userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath
userSpecifiedPath prog =
- join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs
-
+ join . fmap (\(_, p, _) -> p) . Map.lookup (programName prog) . unconfiguredProgs
-- | Get any extra args that have been previously specified for a program.
---
userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg]
userSpecifiedArgs prog =
- maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs
-
+ maybe [] (\(_, _, as) -> as) . Map.lookup (programName prog) . unconfiguredProgs
-- -----------------------------
-- Managing configured programs
@@ -295,13 +301,14 @@ userSpecifiedArgs prog =
lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram prog = Map.lookup (programName prog) . configuredProgs
-
-- | Update a configured program in the database.
-updateProgram :: ConfiguredProgram -> ProgramDb
- -> ProgramDb
-updateProgram prog = updateConfiguredProgs $
- Map.insert (programId prog) prog
-
+updateProgram
+ :: ConfiguredProgram
+ -> ProgramDb
+ -> ProgramDb
+updateProgram prog =
+ updateConfiguredProgs $
+ Map.insert (programId prog) prog
-- | List all configured programs.
configuredPrograms :: ProgramDb -> [ConfiguredProgram]
@@ -323,57 +330,62 @@ configuredPrograms = Map.elems . configuredProgs
-- front all the programs we will need, so we try to configure them all.
-- To verify that a program was actually successfully configured use
-- 'requireProgram'.
---
-configureProgram :: Verbosity
- -> Program
- -> ProgramDb
- -> IO ProgramDb
+configureProgram
+ :: Verbosity
+ -> Program
+ -> ProgramDb
+ -> IO ProgramDb
configureProgram verbosity prog progdb = do
let name = programName prog
maybeLocation <- case userSpecifiedPath prog progdb of
- Nothing ->
+ Nothing ->
programFindLocation prog verbosity (progSearchPath progdb)
- >>= return . fmap (swap . fmap FoundOnSystem . swap)
+ >>= return . fmap (swap . fmap FoundOnSystem . swap)
Just path -> do
absolute <- doesExecutableExist path
if absolute
then return (Just (UserSpecified path, []))
- else findProgramOnSearchPath verbosity (progSearchPath progdb) path
- >>= maybe (die' verbosity notFound)
- (return . Just . swap . fmap UserSpecified . swap)
- where notFound = "Cannot find the program '" ++ name
- ++ "'. User-specified path '"
- ++ path ++ "' does not refer to an executable and "
- ++ "the program is not on the system path."
+ else
+ findProgramOnSearchPath verbosity (progSearchPath progdb) path
+ >>= maybe
+ (die' verbosity notFound)
+ (return . Just . swap . fmap UserSpecified . swap)
+ where
+ notFound =
+ "Cannot find the program '"
+ ++ name
+ ++ "'. User-specified path '"
+ ++ path
+ ++ "' does not refer to an executable and "
+ ++ "the program is not on the system path."
case maybeLocation of
Nothing -> return progdb
Just (location, triedLocations) -> do
version <- programFindVersion prog verbosity (locationPath location)
newPath <- programSearchPathAsPATHVar (progSearchPath progdb)
- let configuredProg = ConfiguredProgram {
- programId = name,
- programVersion = version,
- programDefaultArgs = [],
- programOverrideArgs = userSpecifiedArgs prog progdb,
- programOverrideEnv = [("PATH", Just newPath)],
- programProperties = Map.empty,
- programLocation = location,
- programMonitorFiles = triedLocations
- }
+ let configuredProg =
+ ConfiguredProgram
+ { programId = name
+ , programVersion = version
+ , programDefaultArgs = []
+ , programOverrideArgs = userSpecifiedArgs prog progdb
+ , programOverrideEnv = [("PATH", Just newPath)]
+ , programProperties = Map.empty
+ , programLocation = location
+ , programMonitorFiles = triedLocations
+ }
configuredProg' <- programPostConf prog verbosity configuredProg
return (updateConfiguredProgs (Map.insert name configuredProg') progdb)
-
-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'.
---
-configurePrograms :: Verbosity
- -> [Program]
- -> ProgramDb
- -> IO ProgramDb
+configurePrograms
+ :: Verbosity
+ -> [Program]
+ -> ProgramDb
+ -> IO ProgramDb
configurePrograms verbosity progs progdb =
foldM (flip (configureProgram verbosity)) progdb progs
-
-- | Unconfigure a program. This is basically a hack and you shouldn't
-- use it, but it can be handy for making sure a 'requireProgram'
-- actually reconfigures.
@@ -382,49 +394,51 @@ unconfigureProgram progname =
updateConfiguredProgs $ Map.delete progname
-- | Try to configure all the known programs that have not yet been configured.
---
-configureAllKnownPrograms :: Verbosity
- -> ProgramDb
- -> IO ProgramDb
+configureAllKnownPrograms
+ :: Verbosity
+ -> ProgramDb
+ -> IO ProgramDb
configureAllKnownPrograms verbosity progdb =
- configurePrograms verbosity
- [ prog | (prog,_,_) <- Map.elems notYetConfigured ] progdb
+ configurePrograms
+ verbosity
+ [prog | (prog, _, _) <- Map.elems notYetConfigured]
+ progdb
where
- notYetConfigured = unconfiguredProgs progdb
- `Map.difference` configuredProgs progdb
-
+ notYetConfigured =
+ unconfiguredProgs progdb
+ `Map.difference` configuredProgs progdb
-- | reconfigure a bunch of programs given new user-specified args. It takes
-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs
-- with a new path it calls 'configureProgram'.
---
-reconfigurePrograms :: Verbosity
- -> [(String, FilePath)]
- -> [(String, [ProgArg])]
- -> ProgramDb
- -> IO ProgramDb
+reconfigurePrograms
+ :: Verbosity
+ -> [(String, FilePath)]
+ -> [(String, [ProgArg])]
+ -> ProgramDb
+ -> IO ProgramDb
reconfigurePrograms verbosity paths argss progdb = do
configurePrograms verbosity progs
- . userSpecifyPaths paths
- . userSpecifyArgss argss
- $ progdb
-
+ . userSpecifyPaths paths
+ . userSpecifyArgss argss
+ $ progdb
where
- progs = catMaybes [ lookupKnownProgram name progdb | (name,_) <- paths ]
-
+ progs = catMaybes [lookupKnownProgram name progdb | (name, _) <- paths]
-- | Check that a program is configured and available to be run.
--
-- It raises an exception if the program could not be configured, otherwise
-- it returns the configured program.
---
-requireProgram :: Verbosity -> Program -> ProgramDb
- -> IO (ConfiguredProgram, ProgramDb)
+requireProgram
+ :: Verbosity
+ -> Program
+ -> ProgramDb
+ -> IO (ConfiguredProgram, ProgramDb)
requireProgram verbosity prog progdb = do
- mres <- needProgram verbosity prog progdb
- case mres of
- Nothing -> die' verbosity notFound
- Just res -> return res
+ mres <- needProgram verbosity prog progdb
+ case mres of
+ Nothing -> die' verbosity notFound
+ Just res -> return res
where
notFound = "The program '" ++ programName prog ++ "' is required but it could not be found."
@@ -434,17 +448,19 @@ requireProgram verbosity prog progdb = do
-- or is not found.
--
-- @since 3.0.1.0
-needProgram :: Verbosity -> Program -> ProgramDb
- -> IO (Maybe (ConfiguredProgram, ProgramDb))
+needProgram
+ :: Verbosity
+ -> Program
+ -> ProgramDb
+ -> IO (Maybe (ConfiguredProgram, ProgramDb))
needProgram verbosity prog progdb = do
-
-- If it's not already been configured, try to configure it now
progdb' <- case lookupProgram prog progdb of
Nothing -> configureProgram verbosity prog progdb
- Just _ -> return progdb
+ Just _ -> return progdb
case lookupProgram prog progdb' of
- Nothing -> return Nothing
+ Nothing -> return Nothing
Just configuredProg -> return (Just (configuredProg, progdb'))
-- | Check that a program is configured and available to be run.
@@ -456,50 +472,66 @@ needProgram verbosity prog progdb = do
-- It returns the configured program, its version number and a possibly updated
-- 'ProgramDb'. If the program could not be configured or the version is
-- unsuitable, it returns an error value.
---
lookupProgramVersion
- :: Verbosity -> Program -> VersionRange -> ProgramDb
+ :: Verbosity
+ -> Program
+ -> VersionRange
+ -> ProgramDb
-> IO (Either String (ConfiguredProgram, Version, ProgramDb))
lookupProgramVersion verbosity prog range programDb = do
-
-- If it's not already been configured, try to configure it now
programDb' <- case lookupProgram prog programDb of
Nothing -> configureProgram verbosity prog programDb
- Just _ -> return programDb
+ Just _ -> return programDb
case lookupProgram prog programDb' of
- Nothing -> return $! Left notFound
- Just configuredProg@ConfiguredProgram { programLocation = location } ->
+ Nothing -> return $! Left notFound
+ Just configuredProg@ConfiguredProgram{programLocation = location} ->
case programVersion configuredProg of
Just version
| withinRange version range ->
- return $! Right (configuredProg, version ,programDb')
- | otherwise ->
- return $! Left (badVersion version location)
- Nothing ->
+ return $! Right (configuredProg, version, programDb')
+ | otherwise ->
+ return $! Left (badVersion version location)
+ Nothing ->
return $! Left (unknownVersion location)
-
- where notFound = "The program '"
- ++ programName prog ++ "'" ++ versionRequirement
- ++ " is required but it could not be found."
- badVersion v l = "The program '"
- ++ programName prog ++ "'" ++ versionRequirement
- ++ " is required but the version found at "
- ++ locationPath l ++ " is version " ++ prettyShow v
- unknownVersion l = "The program '"
- ++ programName prog ++ "'" ++ versionRequirement
- ++ " is required but the version of "
- ++ locationPath l ++ " could not be determined."
- versionRequirement
- | isAnyVersion range = ""
- | otherwise = " version " ++ prettyShow range
+ where
+ notFound =
+ "The program '"
+ ++ programName prog
+ ++ "'"
+ ++ versionRequirement
+ ++ " is required but it could not be found."
+ badVersion v l =
+ "The program '"
+ ++ programName prog
+ ++ "'"
+ ++ versionRequirement
+ ++ " is required but the version found at "
+ ++ locationPath l
+ ++ " is version "
+ ++ prettyShow v
+ unknownVersion l =
+ "The program '"
+ ++ programName prog
+ ++ "'"
+ ++ versionRequirement
+ ++ " is required but the version of "
+ ++ locationPath l
+ ++ " could not be determined."
+ versionRequirement
+ | isAnyVersion range = ""
+ | otherwise = " version " ++ prettyShow range
-- | Like 'lookupProgramVersion', but raises an exception in case of error
-- instead of returning 'Left errMsg'.
---
-requireProgramVersion :: Verbosity -> Program -> VersionRange
- -> ProgramDb
- -> IO (ConfiguredProgram, Version, ProgramDb)
+requireProgramVersion
+ :: Verbosity
+ -> Program
+ -> VersionRange
+ -> ProgramDb
+ -> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion verbosity prog range programDb =
- join $ either (die' verbosity) return `fmap`
- lookupProgramVersion verbosity prog range programDb
+ join $
+ either (die' verbosity) return
+ `fmap` lookupProgramVersion verbosity prog range programDb
diff --git a/Cabal/src/Distribution/Simple/Program/Find.hs b/Cabal/src/Distribution/Simple/Program/Find.hs
index 1e8497e1e1af524f136921c05a6e0bc4099e4609..806c91259680b9c90671d9c8bda54c72652463d1 100644
--- a/Cabal/src/Distribution/Simple/Program/Find.hs
+++ b/Cabal/src/Distribution/Simple/Program/Find.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Find
-- Copyright : Duncan Coutts 2013
@@ -24,30 +25,35 @@
-- So we need an extension of the usual 'findExecutable' that can look in
-- additional locations, either before, after or instead of the normal OS
-- locations.
---
-module Distribution.Simple.Program.Find (
- -- * Program search path
- ProgramSearchPath,
- ProgramSearchPathEntry(..),
- defaultProgramSearchPath,
- findProgramOnSearchPath,
- programSearchPathAsPATHVar,
- getSystemSearchPath,
+module Distribution.Simple.Program.Find
+ ( -- * Program search path
+ ProgramSearchPath
+ , ProgramSearchPathEntry (..)
+ , defaultProgramSearchPath
+ , findProgramOnSearchPath
+ , programSearchPathAsPATHVar
+ , getSystemSearchPath
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Verbosity
+import Distribution.Compat.Environment
import Distribution.Simple.Utils
import Distribution.System
-import Distribution.Compat.Environment
+import Distribution.Verbosity
import qualified System.Directory as Directory
- ( findExecutable )
+ ( findExecutable
+ )
import System.FilePath as FilePath
- ( (</>), (<.>), splitSearchPath, searchPathSeparator, getSearchPath
- , takeDirectory )
+ ( getSearchPath
+ , searchPathSeparator
+ , splitSearchPath
+ , takeDirectory
+ , (<.>)
+ , (</>)
+ )
#if defined(mingw32_HOST_OS)
import qualified System.Win32 as Win32
#endif
@@ -63,11 +69,13 @@ import qualified System.Win32 as Win32
-- dir to search after the usual ones.
--
-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]
---
type ProgramSearchPath = [ProgramSearchPathEntry]
-data ProgramSearchPathEntry =
- ProgramSearchPathDir FilePath -- ^ A specific dir
- | ProgramSearchPathDefault -- ^ The system default
+
+data ProgramSearchPathEntry
+ = -- | A specific dir
+ ProgramSearchPathDir FilePath
+ | -- | The system default
+ ProgramSearchPathDefault
deriving (Eq, Generic, Typeable)
instance Binary ProgramSearchPathEntry
@@ -76,69 +84,74 @@ instance Structured ProgramSearchPathEntry
defaultProgramSearchPath :: ProgramSearchPath
defaultProgramSearchPath = [ProgramSearchPathDefault]
-findProgramOnSearchPath :: Verbosity -> ProgramSearchPath
- -> FilePath -> IO (Maybe (FilePath, [FilePath]))
+findProgramOnSearchPath
+ :: Verbosity
+ -> ProgramSearchPath
+ -> FilePath
+ -> IO (Maybe (FilePath, [FilePath]))
findProgramOnSearchPath verbosity searchpath prog = do
- debug verbosity $ "Searching for " ++ prog ++ " in path."
- res <- tryPathElems [] searchpath
- case res of
- Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
- Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at "++ path)
- return res
+ debug verbosity $ "Searching for " ++ prog ++ " in path."
+ res <- tryPathElems [] searchpath
+ case res of
+ Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
+ Just (path, _) -> debug verbosity ("Found " ++ prog ++ " at " ++ path)
+ return res
where
- tryPathElems :: [[FilePath]] -> [ProgramSearchPathEntry]
- -> IO (Maybe (FilePath, [FilePath]))
- tryPathElems _ [] = return Nothing
- tryPathElems tried (pe:pes) = do
+ tryPathElems
+ :: [[FilePath]]
+ -> [ProgramSearchPathEntry]
+ -> IO (Maybe (FilePath, [FilePath]))
+ tryPathElems _ [] = return Nothing
+ tryPathElems tried (pe : pes) = do
res <- tryPathElem pe
case res of
- (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes
+ (Nothing, notfoundat) -> tryPathElems (notfoundat : tried) pes
(Just foundat, notfoundat) -> return (Just (foundat, alltried))
where
alltried = concat (reverse (notfoundat : tried))
tryPathElem :: ProgramSearchPathEntry -> IO (Maybe FilePath, [FilePath])
tryPathElem (ProgramSearchPathDir dir) =
- findFirstExe [ dir </> prog <.> ext | ext <- exeExtensions ]
-
+ findFirstExe [dir </> prog <.> ext | ext <- exeExtensions]
-- On windows, getSystemSearchPath is not guaranteed 100% correct so we
-- use findExecutable and then approximate the not-found-at locations.
tryPathElem ProgramSearchPathDefault | buildOS == Windows = do
- mExe <- firstJustM [ findExecutable (prog <.> ext) | ext <- exeExtensions ]
+ mExe <- firstJustM [findExecutable (prog <.> ext) | ext <- exeExtensions]
syspath <- getSystemSearchPath
case mExe of
Nothing ->
- let notfoundat = [ dir </> prog | dir <- syspath ] in
- return (Nothing, notfoundat)
-
+ let notfoundat = [dir </> prog | dir <- syspath]
+ in return (Nothing, notfoundat)
Just foundat -> do
- let founddir = takeDirectory foundat
- notfoundat = [ dir </> prog
- | dir <- takeWhile (/= founddir) syspath ]
+ let founddir = takeDirectory foundat
+ notfoundat =
+ [ dir </> prog
+ | dir <- takeWhile (/= founddir) syspath
+ ]
return (Just foundat, notfoundat)
-- On other OSs we can just do the simple thing
tryPathElem ProgramSearchPathDefault = do
dirs <- getSystemSearchPath
- findFirstExe [ dir </> prog <.> ext | dir <- dirs, ext <- exeExtensions ]
+ findFirstExe [dir </> prog <.> ext | dir <- dirs, ext <- exeExtensions]
findFirstExe :: [FilePath] -> IO (Maybe FilePath, [FilePath])
findFirstExe = go []
where
- go fs' [] = return (Nothing, reverse fs')
- go fs' (f:fs) = do
+ go fs' [] = return (Nothing, reverse fs')
+ go fs' (f : fs) = do
isExe <- doesExecutableExist f
if isExe
then return (Just f, reverse fs')
- else go (f:fs') fs
+ else go (f : fs') fs
-- Helper for evaluating actions until the first one returns 'Just'
firstJustM :: Monad m => [m (Maybe a)] -> m (Maybe a)
firstJustM [] = return Nothing
- firstJustM (ma:mas) = do
+ firstJustM (ma : mas) = do
a <- ma
case a of
- Just _ -> return a
+ Just _ -> return a
Nothing -> firstJustM mas
-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var.
@@ -146,17 +159,16 @@ findProgramOnSearchPath verbosity searchpath prog = do
-- algorithm looks at more than just the @%PATH%@.
programSearchPathAsPATHVar :: ProgramSearchPath -> IO String
programSearchPathAsPATHVar searchpath = do
- ess <- traverse getEntries searchpath
- return (intercalate [searchPathSeparator] (concat ess))
+ ess <- traverse getEntries searchpath
+ return (intercalate [searchPathSeparator] (concat ess))
where
getEntries (ProgramSearchPathDir dir) = return [dir]
- getEntries ProgramSearchPathDefault = do
+ getEntries ProgramSearchPathDefault = do
env <- getEnvironment
return (maybe [] splitSearchPath (lookup "PATH" env))
-- | Get the system search path. On Unix systems this is just the @$PATH@ env
-- var, but on windows it's a bit more complicated.
---
getSystemSearchPath :: IO [FilePath]
getSystemSearchPath = fmap nub $ do
#if defined(mingw32_HOST_OS)
@@ -195,4 +207,3 @@ findExecutable prog = do
else return Nothing
_ -> return mExe
#endif
-
diff --git a/Cabal/src/Distribution/Simple/Program/GHC.hs b/Cabal/src/Distribution/Simple/Program/GHC.hs
index 902422c253f217fbe446f6d85decb2ee058749bd..71294c59d0069cfd6b330a0e1f9db95c004ab7aa 100644
--- a/Cabal/src/Distribution/Simple/Program/GHC.hs
+++ b/Cabal/src/Distribution/Simple/Program/GHC.hs
@@ -4,57 +4,53 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Simple.Program.GHC (
- GhcOptions(..),
- GhcMode(..),
- GhcOptimisation(..),
- GhcDynLinkMode(..),
- GhcProfAuto(..),
-
- ghcInvocation,
- renderGhcOptions,
-
- runGHC,
-
- packageDbArgsDb,
- normaliseGhcArgs
-
+module Distribution.Simple.Program.GHC
+ ( GhcOptions (..)
+ , GhcMode (..)
+ , GhcOptimisation (..)
+ , GhcDynLinkMode (..)
+ , GhcProfAuto (..)
+ , ghcInvocation
+ , renderGhcOptions
+ , runGHC
+ , packageDbArgsDb
+ , normaliseGhcArgs
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Backpack
-import Distribution.Compat.Semigroup (First'(..), Last'(..), Option'(..))
-import Distribution.Simple.GHC.ImplInfo
-import Distribution.PackageDescription
+import Distribution.Compat.Semigroup (First' (..), Last' (..), Option' (..))
import Distribution.ModuleName
+import Distribution.PackageDescription
+import Distribution.Pretty
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
-import Distribution.Simple.Program.Types
+import Distribution.Simple.GHC.ImplInfo
import Distribution.Simple.Program.Run
+import Distribution.Simple.Program.Types
import Distribution.System
-import Distribution.Pretty
import Distribution.Types.ComponentId
+import Distribution.Utils.NubList
import Distribution.Verbosity
import Distribution.Version
-import Distribution.Utils.NubList
import Language.Haskell.Extension
import Data.List (stripPrefix)
import qualified Data.Map as Map
-import Data.Monoid (All(..), Any(..), Endo(..))
+import Data.Monoid (All (..), Any (..), Endo (..))
import qualified Data.Set as Set
normaliseGhcArgs :: Maybe Version -> PackageDescription -> [String] -> [String]
normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
- | ghcVersion `withinRange` supportedGHCVersions
- = argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs
+ | ghcVersion `withinRange` supportedGHCVersions =
+ argumentFilters . filter simpleFilters . filterRtsOpts $ ghcArgs
where
supportedGHCVersions :: VersionRange
- supportedGHCVersions = orLaterVersion (mkVersion [8,0])
- -- we (weakly) support unknown future GHC versions for the purpose
- -- of filtering GHC arguments
+ supportedGHCVersions = orLaterVersion (mkVersion [8, 0])
+ -- we (weakly) support unknown future GHC versions for the purpose
+ -- of filtering GHC arguments
from :: Monoid m => [Int] -> m -> m
from version flags
@@ -66,8 +62,9 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
| ghcVersion `withinRange` earlierVersion (mkVersion version) = flags
| otherwise = mempty
- checkGhcFlags :: forall m . Monoid m => ([String] -> m) -> m
- checkGhcFlags fun = mconcat
+ checkGhcFlags :: forall m. Monoid m => ([String] -> m) -> m
+ checkGhcFlags fun =
+ mconcat
[ fun ghcArgs
, checkComponentFlags libBuildInfo pkgLibs
, checkComponentFlags buildInfo executables
@@ -84,7 +81,9 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
checkComponent = foldMap fun . filterGhcOptions . allGhcOptions
allGhcOptions :: BuildInfo -> [(CompilerFlavor, [String])]
- allGhcOptions = foldMap (perCompilerFlavorToList .)
+ allGhcOptions =
+ foldMap
+ (perCompilerFlavorToList .)
[options, profOptions, sharedOptions, staticOptions]
filterGhcOptions :: [(CompilerFlavor, [String])] -> [[String]]
@@ -97,31 +96,40 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
checkWarnings = All . Set.null . foldr alter Set.empty
alter :: String -> Set String -> Set String
- alter flag = appEndo $ mconcat
- [ \s -> Endo $ if s == "-Werror" then Set.insert s else id
- , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id
- , \s -> from [8,6] . Endo $
+ alter flag =
+ appEndo $
+ mconcat
+ [ \s -> Endo $ if s == "-Werror" then Set.insert s else id
+ , \s -> Endo $ if s == "-Wwarn" then const Set.empty else id
+ , \s ->
+ from [8, 6] . Endo $
if s == "-Werror=compat"
- then Set.union compatWarningSet else id
- , \s -> from [8,6] . Endo $
+ then Set.union compatWarningSet
+ else id
+ , \s ->
+ from [8, 6] . Endo $
if s == "-Wno-error=compat"
- then (`Set.difference` compatWarningSet) else id
- , \s -> from [8,6] . Endo $
+ then (`Set.difference` compatWarningSet)
+ else id
+ , \s ->
+ from [8, 6] . Endo $
if s == "-Wwarn=compat"
- then (`Set.difference` compatWarningSet) else id
- , from [8,4] $ markFlag "-Werror=" Set.insert
- , from [8,4] $ markFlag "-Wwarn=" Set.delete
- , from [8,4] $ markFlag "-Wno-error=" Set.delete
- ] flag
+ then (`Set.difference` compatWarningSet)
+ else id
+ , from [8, 4] $ markFlag "-Werror=" Set.insert
+ , from [8, 4] $ markFlag "-Wwarn=" Set.delete
+ , from [8, 4] $ markFlag "-Wno-error=" Set.delete
+ ]
+ flag
markFlag
- :: String
- -> (String -> Set String -> Set String)
- -> String
- -> Endo (Set String)
+ :: String
+ -> (String -> Set String -> Set String)
+ -> String
+ -> Endo (Set String)
markFlag name update flag = Endo $ case stripPrefix name flag of
- Just rest | not (null rest) && rest /= "compat" -> update rest
- _ -> id
+ Just rest | not (null rest) && rest /= "compat" -> update rest
+ _ -> id
flagArgumentFilter :: [String] -> [String] -> [String]
flagArgumentFilter flags = go
@@ -130,20 +138,21 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
makeFilter flag arg = Option' $ First' . filterRest <$> stripPrefix flag arg
where
filterRest leftOver = case dropEq leftOver of
- [] -> drop 1
- _ -> id
+ [] -> drop 1
+ _ -> id
checkFilter :: String -> Maybe ([String] -> [String])
checkFilter = fmap getFirst' . getOption' . foldMap makeFilter flags
go :: [String] -> [String]
go [] = []
- go (arg:args) = case checkFilter arg of
- Just f -> go (f args)
- Nothing -> arg : go args
+ go (arg : args) = case checkFilter arg of
+ Just f -> go (f args)
+ Nothing -> arg : go args
argumentFilters :: [String] -> [String]
- argumentFilters = flagArgumentFilter
+ argumentFilters =
+ flagArgumentFilter
["-ghci-script", "-H", "-interactive-print"]
filterRtsOpts :: [String] -> [String]
@@ -151,118 +160,162 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
where
go :: Bool -> [String] -> [String]
go _ [] = []
- go _ ("+RTS":opts) = go True opts
- go _ ("-RTS":opts) = go False opts
- go isRTSopts (opt:opts) = addOpt $ go isRTSopts opts
+ go _ ("+RTS" : opts) = go True opts
+ go _ ("-RTS" : opts) = go False opts
+ go isRTSopts (opt : opts) = addOpt $ go isRTSopts opts
where
- addOpt | isRTSopts = id
- | otherwise = (opt:)
+ addOpt
+ | isRTSopts = id
+ | otherwise = (opt :)
simpleFilters :: String -> Bool
- simpleFilters = not . getAny . mconcat
- [ flagIn simpleFlags
- , Any . isPrefixOf "-ddump-"
- , Any . isPrefixOf "-dsuppress-"
- , Any . isPrefixOf "-dno-suppress-"
- , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]
- , flagIn . invertibleFlagSet "-f" . mconcat $
- [ [ "reverse-errors", "warn-unused-binds", "break-on-error"
- , "break-on-exception", "print-bind-result"
- , "print-bind-contents", "print-evld-with-show"
- , "implicit-import-qualified", "error-spans"
- ]
- , from [7,8]
- [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options
- , "print-explicit-kinds"
- ]
- , from [8,0]
- [ "print-explicit-coercions"
- , "print-explicit-runtime-reps"
- , "print-equality-relations"
- , "print-unicode-syntax"
- , "print-expanded-synonyms"
- , "print-potential-instances"
- , "print-typechecker-elaboration"
- ]
- , from [8,2]
- [ "diagnostics-show-caret", "local-ghci-history"
- , "show-warning-groups", "hide-source-paths"
- , "show-hole-constraints"
+ simpleFilters =
+ not
+ . getAny
+ . mconcat
+ [ flagIn simpleFlags
+ , Any . isPrefixOf "-ddump-"
+ , Any . isPrefixOf "-dsuppress-"
+ , Any . isPrefixOf "-dno-suppress-"
+ , flagIn $ invertibleFlagSet "-" ["ignore-dot-ghci"]
+ , flagIn . invertibleFlagSet "-f" . mconcat $
+ [
+ [ "reverse-errors"
+ , "warn-unused-binds"
+ , "break-on-error"
+ , "break-on-exception"
+ , "print-bind-result"
+ , "print-bind-contents"
+ , "print-evld-with-show"
+ , "implicit-import-qualified"
+ , "error-spans"
]
- , from [8,4] ["show-loaded-modules"]
- , from [8,6] [ "ghci-leak-check", "no-it" ]
- , from [8,10]
- [ "defer-diagnostics" -- affects printing of diagnostics
- , "keep-going" -- try harder, the build will still fail if it's erroneous
- , "print-axiom-incomps" -- print more debug info for closed type families
- ]
- ]
- , flagIn . invertibleFlagSet "-d" $ [ "ppr-case-as-let", "ppr-ticks" ]
- , isOptIntFlag
- , isIntFlag
- , if safeToFilterWarnings
- then isWarning <> (Any . ("-w"==))
- else mempty
- , from [8,6] $
- if safeToFilterHoles
- then isTypedHoleFlag
- else mempty
- ]
+ , from
+ [7, 8]
+ [ "print-explicit-foralls" -- maybe also earlier, but GHC-7.6 doesn't have --show-options
+ , "print-explicit-kinds"
+ ]
+ , from
+ [8, 0]
+ [ "print-explicit-coercions"
+ , "print-explicit-runtime-reps"
+ , "print-equality-relations"
+ , "print-unicode-syntax"
+ , "print-expanded-synonyms"
+ , "print-potential-instances"
+ , "print-typechecker-elaboration"
+ ]
+ , from
+ [8, 2]
+ [ "diagnostics-show-caret"
+ , "local-ghci-history"
+ , "show-warning-groups"
+ , "hide-source-paths"
+ , "show-hole-constraints"
+ ]
+ , from [8, 4] ["show-loaded-modules"]
+ , from [8, 6] ["ghci-leak-check", "no-it"]
+ , from
+ [8, 10]
+ [ "defer-diagnostics" -- affects printing of diagnostics
+ , "keep-going" -- try harder, the build will still fail if it's erroneous
+ , "print-axiom-incomps" -- print more debug info for closed type families
+ ]
+ ]
+ , flagIn . invertibleFlagSet "-d" $ ["ppr-case-as-let", "ppr-ticks"]
+ , isOptIntFlag
+ , isIntFlag
+ , if safeToFilterWarnings
+ then isWarning <> (Any . ("-w" ==))
+ else mempty
+ , from [8, 6] $
+ if safeToFilterHoles
+ then isTypedHoleFlag
+ else mempty
+ ]
flagIn :: Set String -> String -> Any
flagIn set flag = Any $ Set.member flag set
isWarning :: String -> Any
- isWarning = mconcat $ map ((Any .) . isPrefixOf)
- ["-fwarn-", "-fno-warn-", "-W", "-Wno-"]
+ isWarning =
+ mconcat $
+ map
+ ((Any .) . isPrefixOf)
+ ["-fwarn-", "-fno-warn-", "-W", "-Wno-"]
simpleFlags :: Set String
- simpleFlags = Set.fromList . mconcat $
- [ [ "-n", "-#include", "-Rghc-timing", "-dstg-stats"
- , "-dth-dec-file", "-dsource-stats", "-dverbose-core2core"
- , "-dverbose-stg2stg", "-dcore-lint", "-dstg-lint", "-dcmm-lint"
- , "-dasm-lint", "-dannot-lint", "-dshow-passes", "-dfaststring-stats"
- , "-fno-max-relevant-binds", "-recomp", "-no-recomp", "-fforce-recomp"
- , "-fno-force-recomp"
- ]
-
- , from [8,2]
- [ "-fno-max-errors", "-fdiagnostics-color=auto"
- , "-fdiagnostics-color=always", "-fdiagnostics-color=never"
- , "-dppr-debug", "-dno-debug-output"
+ simpleFlags =
+ Set.fromList . mconcat $
+ [
+ [ "-n"
+ , "-#include"
+ , "-Rghc-timing"
+ , "-dstg-stats"
+ , "-dth-dec-file"
+ , "-dsource-stats"
+ , "-dverbose-core2core"
+ , "-dverbose-stg2stg"
+ , "-dcore-lint"
+ , "-dstg-lint"
+ , "-dcmm-lint"
+ , "-dasm-lint"
+ , "-dannot-lint"
+ , "-dshow-passes"
+ , "-dfaststring-stats"
+ , "-fno-max-relevant-binds"
+ , "-recomp"
+ , "-no-recomp"
+ , "-fforce-recomp"
+ , "-fno-force-recomp"
]
-
- , from [8,4] [ "-ddebug-output" ]
- , from [8,4] $ to [8,6] [ "-fno-max-valid-substitutions" ]
- , from [8,6] [ "-dhex-word-literals" ]
- , from [8,8] [ "-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits" ]
- , from [9,0] [ "-dlinear-core-lint" ]
- ]
+ , from
+ [8, 2]
+ [ "-fno-max-errors"
+ , "-fdiagnostics-color=auto"
+ , "-fdiagnostics-color=always"
+ , "-fdiagnostics-color=never"
+ , "-dppr-debug"
+ , "-dno-debug-output"
+ ]
+ , from [8, 4] ["-ddebug-output"]
+ , from [8, 4] $ to [8, 6] ["-fno-max-valid-substitutions"]
+ , from [8, 6] ["-dhex-word-literals"]
+ , from [8, 8] ["-fshow-docs-of-hole-fits", "-fno-show-docs-of-hole-fits"]
+ , from [9, 0] ["-dlinear-core-lint"]
+ ]
isOptIntFlag :: String -> Any
isOptIntFlag = mconcat . map (dropIntFlag True) $ ["-v", "-j"]
isIntFlag :: String -> Any
- isIntFlag = mconcat . map (dropIntFlag False) . mconcat $
- [ [ "-fmax-relevant-binds", "-ddpr-user-length", "-ddpr-cols"
- , "-dtrace-level", "-fghci-hist-size" ]
- , from [8,2] ["-fmax-uncovered-patterns", "-fmax-errors"]
- , from [8,4] $ to [8,6] ["-fmax-valid-substitutions"]
+ isIntFlag =
+ mconcat . map (dropIntFlag False) . mconcat $
+ [
+ [ "-fmax-relevant-binds"
+ , "-ddpr-user-length"
+ , "-ddpr-cols"
+ , "-dtrace-level"
+ , "-fghci-hist-size"
+ ]
+ , from [8, 2] ["-fmax-uncovered-patterns", "-fmax-errors"]
+ , from [8, 4] $ to [8, 6] ["-fmax-valid-substitutions"]
]
dropIntFlag :: Bool -> String -> String -> Any
dropIntFlag isOpt flag input = Any $ case stripPrefix flag input of
- Nothing -> False
- Just rest | isOpt && null rest -> True
- | otherwise -> case parseInt rest of
- Just _ -> True
- Nothing -> False
+ Nothing -> False
+ Just rest
+ | isOpt && null rest -> True
+ | otherwise -> case parseInt rest of
+ Just _ -> True
+ Nothing -> False
where
parseInt :: String -> Maybe Int
parseInt = readMaybe . dropEq
dropEq :: String -> String
- dropEq ('=':s) = s
+ dropEq ('=' : s) = s
dropEq s = s
invertibleFlagSet :: String -> [String] -> Set String
@@ -270,14 +323,21 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
Set.fromList $ (++) <$> [prefix, prefix ++ "no-"] <*> flagNames
compatWarningSet :: Set String
- compatWarningSet = Set.fromList $ mconcat
- [ from [8,6]
- [ "missing-monadfail-instances", "semigroup"
- , "noncanonical-monoid-instances", "implicit-kind-vars" ]
- ]
+ compatWarningSet =
+ Set.fromList $
+ mconcat
+ [ from
+ [8, 6]
+ [ "missing-monadfail-instances"
+ , "semigroup"
+ , "noncanonical-monoid-instances"
+ , "implicit-kind-vars"
+ ]
+ ]
safeToFilterHoles :: Bool
- safeToFilterHoles = getAll . checkGhcFlags $
+ safeToFilterHoles =
+ getAll . checkGhcFlags $
All . fromMaybe True . fmap getLast' . getOption' . foldMap notDeferred
where
notDeferred :: String -> Option' (Last' Bool)
@@ -286,24 +346,34 @@ normaliseGhcArgs (Just ghcVersion) PackageDescription{..} ghcArgs
notDeferred _ = Option' Nothing
isTypedHoleFlag :: String -> Any
- isTypedHoleFlag = mconcat
+ isTypedHoleFlag =
+ mconcat
[ flagIn . invertibleFlagSet "-f" $
- [ "show-hole-constraints", "show-valid-substitutions"
- , "show-valid-hole-fits", "sort-valid-hole-fits"
- , "sort-by-size-hole-fits", "sort-by-subsumption-hole-fits"
- , "abstract-refinement-hole-fits", "show-provenance-of-hole-fits"
- , "show-hole-matches-of-hole-fits", "show-type-of-hole-fits"
- , "show-type-app-of-hole-fits", "show-type-app-vars-of-hole-fits"
+ [ "show-hole-constraints"
+ , "show-valid-substitutions"
+ , "show-valid-hole-fits"
+ , "sort-valid-hole-fits"
+ , "sort-by-size-hole-fits"
+ , "sort-by-subsumption-hole-fits"
+ , "abstract-refinement-hole-fits"
+ , "show-provenance-of-hole-fits"
+ , "show-hole-matches-of-hole-fits"
+ , "show-type-of-hole-fits"
+ , "show-type-app-of-hole-fits"
+ , "show-type-app-vars-of-hole-fits"
, "unclutter-valid-hole-fits"
]
, flagIn . Set.fromList $
- [ "-fno-max-valid-hole-fits", "-fno-max-refinement-hole-fits"
- , "-fno-refinement-level-hole-fits" ]
+ [ "-fno-max-valid-hole-fits"
+ , "-fno-max-refinement-hole-fits"
+ , "-fno-refinement-level-hole-fits"
+ ]
, mconcat . map (dropIntFlag False) $
- [ "-fmax-valid-hole-fits", "-fmax-refinement-hole-fits"
- , "-frefinement-level-hole-fits" ]
+ [ "-fmax-valid-hole-fits"
+ , "-fmax-refinement-hole-fits"
+ , "-frefinement-level-hole-fits"
+ ]
]
-
normaliseGhcArgs _ _ args = args
-- | A structured set of GHC options/flags
@@ -314,546 +384,525 @@ normaliseGhcArgs _ _ args = args
-- enabled extensions;
-- * options that cannot be deduplicated in general without changing
-- semantics, e.g. extra ghc options or linking options.
-data GhcOptions = GhcOptions {
-
- -- | The major mode for the ghc invocation.
- ghcOptMode :: Flag GhcMode,
-
- -- | Any extra options to pass directly to ghc. These go at the end and hence
+data GhcOptions = GhcOptions
+ { ghcOptMode :: Flag GhcMode
+ -- ^ The major mode for the ghc invocation.
+ , ghcOptExtra :: [String]
+ -- ^ Any extra options to pass directly to ghc. These go at the end and hence
-- override other stuff.
- ghcOptExtra :: [String],
-
- -- | Extra default flags to pass directly to ghc. These go at the beginning
+ , ghcOptExtraDefault :: [String]
+ -- ^ Extra default flags to pass directly to ghc. These go at the beginning
-- and so can be overridden by other stuff.
- ghcOptExtraDefault :: [String],
-
- -----------------------
- -- Inputs and outputs
-
- -- | The main input files; could be .hs, .hi, .c, .o, depending on mode.
- ghcOptInputFiles :: NubListR FilePath,
-
- -- | Script files with irregular extensions that need -x hs.
- ghcOptInputScripts :: NubListR FilePath,
-
- -- | The names of input Haskell modules, mainly for @--make@ mode.
- ghcOptInputModules :: NubListR ModuleName,
-
- -- | Location for output file; the @ghc -o@ flag.
- ghcOptOutputFile :: Flag FilePath,
-
- -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;
+ , -----------------------
+ -- Inputs and outputs
+
+ ghcOptInputFiles :: NubListR FilePath
+ -- ^ The main input files; could be .hs, .hi, .c, .o, depending on mode.
+ , ghcOptInputScripts :: NubListR FilePath
+ -- ^ Script files with irregular extensions that need -x hs.
+ , ghcOptInputModules :: NubListR ModuleName
+ -- ^ The names of input Haskell modules, mainly for @--make@ mode.
+ , ghcOptOutputFile :: Flag FilePath
+ -- ^ Location for output file; the @ghc -o@ flag.
+ , ghcOptOutputDynFile :: Flag FilePath
+ -- ^ Location for dynamic output file in 'GhcStaticAndDynamic' mode;
-- the @ghc -dyno@ flag.
- ghcOptOutputDynFile :: Flag FilePath,
-
- -- | Start with an empty search path for Haskell source files;
+ , ghcOptSourcePathClear :: Flag Bool
+ -- ^ Start with an empty search path for Haskell source files;
-- the @ghc -i@ flag (@-i@ on its own with no path argument).
- ghcOptSourcePathClear :: Flag Bool,
-
- -- | Search path for Haskell source files; the @ghc -i@ flag.
- ghcOptSourcePath :: NubListR FilePath,
+ , ghcOptSourcePath :: NubListR FilePath
+ -- ^ Search path for Haskell source files; the @ghc -i@ flag.
+ , -------------
+ -- Packages
- -------------
- -- Packages
-
- -- | The unit ID the modules will belong to; the @ghc -this-unit-id@
+ ghcOptThisUnitId :: Flag String
+ -- ^ The unit ID the modules will belong to; the @ghc -this-unit-id@
-- flag (or @-this-package-key@ or @-package-name@ on older
-- versions of GHC). This is a 'String' because we assume you've
-- already figured out what the correct format for this string is
-- (we need to handle backwards compatibility.)
- ghcOptThisUnitId :: Flag String,
-
- -- | GHC doesn't make any assumptions about the format of
+ , ghcOptThisComponentId :: Flag ComponentId
+ -- ^ GHC doesn't make any assumptions about the format of
-- definite unit ids, so when we are instantiating a package it
-- needs to be told explicitly what the component being instantiated
-- is. This only gets set when 'ghcOptInstantiatedWith' is non-empty
- ghcOptThisComponentId :: Flag ComponentId,
-
- -- | How the requirements of the package being compiled are to
+ , ghcOptInstantiatedWith :: [(ModuleName, OpenModule)]
+ -- ^ How the requirements of the package being compiled are to
-- be filled. When typechecking an indefinite package, the 'OpenModule'
-- is always a 'OpenModuleVar'; otherwise, it specifies the installed module
-- that instantiates a package.
- ghcOptInstantiatedWith :: [(ModuleName, OpenModule)],
-
- -- | No code? (But we turn on interface writing
- ghcOptNoCode :: Flag Bool,
-
- -- | GHC package databases to use, the @ghc -package-conf@ flag.
- ghcOptPackageDBs :: PackageDBStack,
-
- -- | The GHC packages to bring into scope when compiling,
+ , ghcOptNoCode :: Flag Bool
+ -- ^ No code? (But we turn on interface writing
+ , ghcOptPackageDBs :: PackageDBStack
+ -- ^ GHC package databases to use, the @ghc -package-conf@ flag.
+ , ghcOptPackages
+ :: NubListR (OpenUnitId, ModuleRenaming)
+ -- ^ The GHC packages to bring into scope when compiling,
-- the @ghc -package-id@ flags.
- ghcOptPackages ::
- NubListR (OpenUnitId, ModuleRenaming),
-
- -- | Start with a clean package set; the @ghc -hide-all-packages@ flag
- ghcOptHideAllPackages :: Flag Bool,
-
- -- | Warn about modules, not listed in command line
- ghcOptWarnMissingHomeModules :: Flag Bool,
-
- -- | Don't automatically link in Haskell98 etc; the @ghc
+ , ghcOptHideAllPackages :: Flag Bool
+ -- ^ Start with a clean package set; the @ghc -hide-all-packages@ flag
+ , ghcOptWarnMissingHomeModules :: Flag Bool
+ -- ^ Warn about modules, not listed in command line
+ , ghcOptNoAutoLinkPackages :: Flag Bool
+ -- ^ Don't automatically link in Haskell98 etc; the @ghc
-- -no-auto-link-packages@ flag.
- ghcOptNoAutoLinkPackages :: Flag Bool,
-
- -----------------
- -- Linker stuff
-
- -- | Names of libraries to link in; the @ghc -l@ flag.
- ghcOptLinkLibs :: [FilePath],
-
- -- | Search path for libraries to link in; the @ghc -L@ flag.
- ghcOptLinkLibPath :: NubListR FilePath,
-
- -- | Options to pass through to the linker; the @ghc -optl@ flag.
- ghcOptLinkOptions :: [String],
-
- -- | OSX only: frameworks to link in; the @ghc -framework@ flag.
- ghcOptLinkFrameworks :: NubListR String,
-
- -- | OSX only: Search path for frameworks to link in; the
+ , -----------------
+ -- Linker stuff
+
+ ghcOptLinkLibs :: [FilePath]
+ -- ^ Names of libraries to link in; the @ghc -l@ flag.
+ , ghcOptLinkLibPath :: NubListR FilePath
+ -- ^ Search path for libraries to link in; the @ghc -L@ flag.
+ , ghcOptLinkOptions :: [String]
+ -- ^ Options to pass through to the linker; the @ghc -optl@ flag.
+ , ghcOptLinkFrameworks :: NubListR String
+ -- ^ OSX only: frameworks to link in; the @ghc -framework@ flag.
+ , ghcOptLinkFrameworkDirs :: NubListR String
+ -- ^ OSX only: Search path for frameworks to link in; the
-- @ghc -framework-path@ flag.
- ghcOptLinkFrameworkDirs :: NubListR String,
-
- -- | Instruct GHC to link against @libHSrts@ when producing a shared library.
- ghcOptLinkRts :: Flag Bool,
-
- -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.
- ghcOptNoLink :: Flag Bool,
-
- -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@
+ , ghcOptLinkRts :: Flag Bool
+ -- ^ Instruct GHC to link against @libHSrts@ when producing a shared library.
+ , ghcOptNoLink :: Flag Bool
+ -- ^ Don't do the link step, useful in make mode; the @ghc -no-link@ flag.
+ , ghcOptLinkNoHsMain :: Flag Bool
+ -- ^ Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@
-- flag.
- ghcOptLinkNoHsMain :: Flag Bool,
-
- -- | Module definition files (Windows specific)
- ghcOptLinkModDefFiles :: NubListR FilePath,
-
- --------------------
- -- C and CPP stuff
-
- -- | Options to pass through to the C compiler; the @ghc -optc@ flag.
- ghcOptCcOptions :: [String],
-
- -- | Options to pass through to the C++ compiler.
- ghcOptCxxOptions :: [String],
-
- -- | Options to pass through to the Assembler.
- ghcOptAsmOptions :: [String],
-
- -- | Options to pass through to CPP; the @ghc -optP@ flag.
- ghcOptCppOptions :: [String],
-
- -- | Search path for CPP includes like header files; the @ghc -I@ flag.
- ghcOptCppIncludePath :: NubListR FilePath,
-
- -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag.
- ghcOptCppIncludes :: NubListR FilePath,
-
- -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag.
- ghcOptFfiIncludes :: NubListR FilePath,
-
- -- | Program to use for the C and C++ compiler; the @ghc -pgmc@ flag.
- ghcOptCcProgram :: Flag FilePath,
-
- ----------------------------
- -- Language and extensions
-
- -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.
- ghcOptLanguage :: Flag Language,
-
- -- | The language extensions; the @ghc -X@ flag.
- ghcOptExtensions :: NubListR Extension,
-
- -- | A GHC version-dependent mapping of extensions to flags. This must be
+ , ghcOptLinkModDefFiles :: NubListR FilePath
+ -- ^ Module definition files (Windows specific)
+ , --------------------
+ -- C and CPP stuff
+
+ ghcOptCcOptions :: [String]
+ -- ^ Options to pass through to the C compiler; the @ghc -optc@ flag.
+ , ghcOptCxxOptions :: [String]
+ -- ^ Options to pass through to the C++ compiler.
+ , ghcOptAsmOptions :: [String]
+ -- ^ Options to pass through to the Assembler.
+ , ghcOptCppOptions :: [String]
+ -- ^ Options to pass through to CPP; the @ghc -optP@ flag.
+ , ghcOptCppIncludePath :: NubListR FilePath
+ -- ^ Search path for CPP includes like header files; the @ghc -I@ flag.
+ , ghcOptCppIncludes :: NubListR FilePath
+ -- ^ Extra header files to include at CPP stage; the @ghc -optP-include@ flag.
+ , ghcOptFfiIncludes :: NubListR FilePath
+ -- ^ Extra header files to include for old-style FFI; the @ghc -#include@ flag.
+ , ghcOptCcProgram :: Flag FilePath
+ -- ^ Program to use for the C and C++ compiler; the @ghc -pgmc@ flag.
+ , ----------------------------
+ -- Language and extensions
+
+ ghcOptLanguage :: Flag Language
+ -- ^ The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag.
+ , ghcOptExtensions :: NubListR Extension
+ -- ^ The language extensions; the @ghc -X@ flag.
+ , ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag)
+ -- ^ A GHC version-dependent mapping of extensions to flags. This must be
-- set to be able to make use of the 'ghcOptExtensions'.
- ghcOptExtensionMap :: Map Extension (Maybe CompilerFlag),
-
- ----------------
- -- Compilation
-
- -- | What optimisation level to use; the @ghc -O@ flag.
- ghcOptOptimisation :: Flag GhcOptimisation,
-
- -- | Emit debug info; the @ghc -g@ flag.
- ghcOptDebugInfo :: Flag DebugInfoLevel,
-
- -- | Compile in profiling mode; the @ghc -prof@ flag.
- ghcOptProfilingMode :: Flag Bool,
-
- -- | Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags.
- ghcOptProfilingAuto :: Flag GhcProfAuto,
-
- -- | Use the \"split sections\" feature; the @ghc -split-sections@ flag.
- ghcOptSplitSections :: Flag Bool,
-
- -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.
- ghcOptSplitObjs :: Flag Bool,
-
- -- | Run N jobs simultaneously (if possible).
- ghcOptNumJobs :: Flag (Maybe Int),
-
- -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.
- ghcOptHPCDir :: Flag FilePath,
-
- ----------------
- -- GHCi
-
- -- | Extra GHCi startup scripts; the @-ghci-script@ flag
- ghcOptGHCiScripts :: [FilePath],
-
- ------------------------
- -- Redirecting outputs
-
- ghcOptHiSuffix :: Flag String,
- ghcOptObjSuffix :: Flag String,
- ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode
- ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode
- ghcOptHiDir :: Flag FilePath,
- ghcOptObjDir :: Flag FilePath,
- ghcOptOutputDir :: Flag FilePath,
- ghcOptStubDir :: Flag FilePath,
-
- --------------------
- -- Creating libraries
-
- ghcOptDynLinkMode :: Flag GhcDynLinkMode,
- ghcOptStaticLib :: Flag Bool,
- ghcOptShared :: Flag Bool,
- ghcOptFPic :: Flag Bool,
- ghcOptDylibName :: Flag String,
- ghcOptRPaths :: NubListR FilePath,
-
- ---------------
- -- Misc flags
-
- -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.
- ghcOptVerbosity :: Flag Verbosity,
-
- -- | Put the extra folders in the PATH environment variable we invoke
+ , ----------------
+ -- Compilation
+
+ ghcOptOptimisation :: Flag GhcOptimisation
+ -- ^ What optimisation level to use; the @ghc -O@ flag.
+ , ghcOptDebugInfo :: Flag DebugInfoLevel
+ -- ^ Emit debug info; the @ghc -g@ flag.
+ , ghcOptProfilingMode :: Flag Bool
+ -- ^ Compile in profiling mode; the @ghc -prof@ flag.
+ , ghcOptProfilingAuto :: Flag GhcProfAuto
+ -- ^ Automatically add profiling cost centers; the @ghc -fprof-auto*@ flags.
+ , ghcOptSplitSections :: Flag Bool
+ -- ^ Use the \"split sections\" feature; the @ghc -split-sections@ flag.
+ , ghcOptSplitObjs :: Flag Bool
+ -- ^ Use the \"split object files\" feature; the @ghc -split-objs@ flag.
+ , ghcOptNumJobs :: Flag (Maybe Int)
+ -- ^ Run N jobs simultaneously (if possible).
+ , ghcOptHPCDir :: Flag FilePath
+ -- ^ Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags.
+ , ----------------
+ -- GHCi
+
+ ghcOptGHCiScripts :: [FilePath]
+ -- ^ Extra GHCi startup scripts; the @-ghci-script@ flag
+ , ------------------------
+ -- Redirecting outputs
+
+ ghcOptHiSuffix :: Flag String
+ , ghcOptObjSuffix :: Flag String
+ , ghcOptDynHiSuffix :: Flag String
+ -- ^ only in 'GhcStaticAndDynamic' mode
+ , ghcOptDynObjSuffix :: Flag String
+ -- ^ only in 'GhcStaticAndDynamic' mode
+ , ghcOptHiDir :: Flag FilePath
+ , ghcOptObjDir :: Flag FilePath
+ , ghcOptOutputDir :: Flag FilePath
+ , ghcOptStubDir :: Flag FilePath
+ , --------------------
+ -- Creating libraries
+
+ ghcOptDynLinkMode :: Flag GhcDynLinkMode
+ , ghcOptStaticLib :: Flag Bool
+ , ghcOptShared :: Flag Bool
+ , ghcOptFPic :: Flag Bool
+ , ghcOptDylibName :: Flag String
+ , ghcOptRPaths :: NubListR FilePath
+ , ---------------
+ -- Misc flags
+
+ ghcOptVerbosity :: Flag Verbosity
+ -- ^ Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag.
+ , ghcOptExtraPath :: NubListR FilePath
+ -- ^ Put the extra folders in the PATH environment variable we invoke
-- GHC with
- ghcOptExtraPath :: NubListR FilePath,
-
- -- | Let GHC know that it is Cabal that's calling it.
+ , ghcOptCabal :: Flag Bool
+ -- ^ Let GHC know that it is Cabal that's calling it.
-- Modifies some of the GHC error messages.
- ghcOptCabal :: Flag Bool
-
-} deriving (Show, Generic)
-
-
-data GhcMode = GhcModeCompile -- ^ @ghc -c@
- | GhcModeLink -- ^ @ghc@
- | GhcModeMake -- ^ @ghc --make@
- | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@
- | GhcModeAbiHash -- ^ @ghc --abi-hash@
--- | GhcModeDepAnalysis -- ^ @ghc -M@
--- | GhcModeEvaluate -- ^ @ghc -e@
- deriving (Show, Eq)
-
-data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@
- | GhcNormalOptimisation -- ^ @-O@
- | GhcMaximumOptimisation -- ^ @-O2@
- | GhcSpecialOptimisation String -- ^ e.g. @-Odph@
- deriving (Show, Eq)
-
-data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@
- | GhcDynamicOnly -- ^ @-dynamic@
- | GhcStaticAndDynamic -- ^ @-static -dynamic-too@
- deriving (Show, Eq)
-
-data GhcProfAuto = GhcProfAutoAll -- ^ @-fprof-auto@
- | GhcProfAutoToplevel -- ^ @-fprof-auto-top@
- | GhcProfAutoExported -- ^ @-fprof-auto-exported@
- | GhcProfLate -- ^ @-fprof-late
- deriving (Show, Eq)
-
-runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> Platform -> GhcOptions
- -> IO ()
+ }
+ deriving (Show, Generic)
+
+data GhcMode
+ = -- | @ghc -c@
+ GhcModeCompile
+ | -- | @ghc@
+ GhcModeLink
+ | -- | @ghc --make@
+ GhcModeMake
+ | -- | @ghci@ \/ @ghc --interactive@
+ GhcModeInteractive
+ | -- | @ghc --abi-hash@
+ -- | GhcModeDepAnalysis -- ^ @ghc -M@
+ -- | GhcModeEvaluate -- ^ @ghc -e@
+ GhcModeAbiHash
+ deriving (Show, Eq)
+
+data GhcOptimisation
+ = -- | @-O0@
+ GhcNoOptimisation
+ | -- | @-O@
+ GhcNormalOptimisation
+ | -- | @-O2@
+ GhcMaximumOptimisation
+ | -- | e.g. @-Odph@
+ GhcSpecialOptimisation String
+ deriving (Show, Eq)
+
+data GhcDynLinkMode
+ = -- | @-static@
+ GhcStaticOnly
+ | -- | @-dynamic@
+ GhcDynamicOnly
+ | -- | @-static -dynamic-too@
+ GhcStaticAndDynamic
+ deriving (Show, Eq)
+
+data GhcProfAuto
+ = -- | @-fprof-auto@
+ GhcProfAutoAll
+ | -- | @-fprof-auto-top@
+ GhcProfAutoToplevel
+ | -- | @-fprof-auto-exported@
+ GhcProfAutoExported
+ | -- | @-fprof-late
+ GhcProfLate
+ deriving (Show, Eq)
+
+runGHC
+ :: Verbosity
+ -> ConfiguredProgram
+ -> Compiler
+ -> Platform
+ -> GhcOptions
+ -> IO ()
runGHC verbosity ghcProg comp platform opts = do
runProgramInvocation verbosity (ghcInvocation ghcProg comp platform opts)
-
-ghcInvocation :: ConfiguredProgram -> Compiler -> Platform -> GhcOptions
- -> ProgramInvocation
+ghcInvocation
+ :: ConfiguredProgram
+ -> Compiler
+ -> Platform
+ -> GhcOptions
+ -> ProgramInvocation
ghcInvocation prog comp platform opts =
- (programInvocation prog (renderGhcOptions comp platform opts)) {
- progInvokePathEnv = fromNubListR (ghcOptExtraPath opts)
+ (programInvocation prog (renderGhcOptions comp platform opts))
+ { progInvokePathEnv = fromNubListR (ghcOptExtraPath opts)
}
renderGhcOptions :: Compiler -> Platform -> GhcOptions -> [String]
renderGhcOptions comp _platform@(Platform _arch os) opts
| compilerFlavor comp `notElem` [GHC, GHCJS] =
- error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "
- ++ "compiler flavor must be 'GHC' or 'GHCJS'!"
+ error $
+ "Distribution.Simple.Program.GHC.renderGhcOptions: "
+ ++ "compiler flavor must be 'GHC' or 'GHCJS'!"
| otherwise =
- concat
- [ case flagToMaybe (ghcOptMode opts) of
- Nothing -> []
- Just GhcModeCompile -> ["-c"]
- Just GhcModeLink -> []
- Just GhcModeMake -> ["--make"]
- Just GhcModeInteractive -> ["--interactive"]
- Just GhcModeAbiHash -> ["--abi-hash"]
--- Just GhcModeDepAnalysis -> ["-M"]
--- Just GhcModeEvaluate -> ["-e", expr]
-
- , ghcOptExtraDefault opts
-
- , [ "-no-link" | flagBool ghcOptNoLink ]
- , [ "-flink-rts" | flagBool ghcOptLinkRts ]
-
- ---------------
- -- Misc flags
-
- , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))
-
- , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal ]
-
- ----------------
- -- Compilation
-
- , case flagToMaybe (ghcOptOptimisation opts) of
- Nothing -> []
- Just GhcNoOptimisation -> ["-O0"]
- Just GhcNormalOptimisation -> ["-O"]
- Just GhcMaximumOptimisation -> ["-O2"]
- Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph
-
- , case flagToMaybe (ghcOptDebugInfo opts) of
- Nothing -> []
- Just NoDebugInfo -> []
- Just MinimalDebugInfo -> ["-g1"]
- Just NormalDebugInfo -> ["-g2"]
- Just MaximalDebugInfo -> ["-g3"]
-
- , [ "-prof" | flagBool ghcOptProfilingMode ]
-
- , case flagToMaybe (ghcOptProfilingAuto opts) of
- _ | not (flagBool ghcOptProfilingMode)
- -> []
- Nothing -> []
- Just GhcProfAutoAll
- | flagProfAuto implInfo -> ["-fprof-auto"]
- | otherwise -> ["-auto-all"] -- not the same, but close
- Just GhcProfLate
- | flagProfLate implInfo -> ["-fprof-late"]
- | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have.
- Just GhcProfAutoToplevel
- | flagProfAuto implInfo -> ["-fprof-auto-top"]
- | otherwise -> ["-auto-all"]
- Just GhcProfAutoExported
- | flagProfAuto implInfo -> ["-fprof-auto-exported"]
- | otherwise -> ["-auto"]
-
- , [ "-split-sections" | flagBool ghcOptSplitSections ]
- , [ "-split-objs" | flagBool ghcOptSplitObjs ]
-
- , case flagToMaybe (ghcOptHPCDir opts) of
- Nothing -> []
- Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]
-
- , if parmakeSupported comp
- then case ghcOptNumJobs opts of
- NoFlag -> []
- Flag n -> ["-j" ++ maybe "" show n]
- else []
-
- --------------------
- -- Creating libraries
-
- , [ "-staticlib" | flagBool ghcOptStaticLib ]
- , [ "-shared" | flagBool ghcOptShared ]
- , case flagToMaybe (ghcOptDynLinkMode opts) of
- Nothing -> []
- Just GhcStaticOnly -> ["-static"]
- Just GhcDynamicOnly -> ["-dynamic"]
- Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]
- , [ "-fPIC" | flagBool ghcOptFPic ]
-
- , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]
-
- ------------------------
- -- Redirecting outputs
-
- , concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ]
- , concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ]
- , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]
- , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ]
- , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir ]
- , concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ]
- , concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ]
- , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir ]
-
- -----------------------
- -- Source search path
-
- , [ "-i" | flagBool ghcOptSourcePathClear ]
- , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]
-
- --------------------
-
- --------------------
- -- CPP, C, and C++ stuff
-
- , [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ]
- , [ "-optP" ++ opt | opt <- ghcOptCppOptions opts]
- , concat [ [ "-optP-include", "-optP" ++ inc]
- | inc <- flags ghcOptCppIncludes ]
- , [ "-optc" ++ opt | opt <- ghcOptCcOptions opts]
- , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc
- let cxxflag = case compilerCompatVersion GHC comp of
+ concat
+ [ case flagToMaybe (ghcOptMode opts) of
+ Nothing -> []
+ Just GhcModeCompile -> ["-c"]
+ Just GhcModeLink -> []
+ Just GhcModeMake -> ["--make"]
+ Just GhcModeInteractive -> ["--interactive"]
+ Just GhcModeAbiHash -> ["--abi-hash"]
+ , -- Just GhcModeDepAnalysis -> ["-M"]
+ -- Just GhcModeEvaluate -> ["-e", expr]
+
+ ghcOptExtraDefault opts
+ , ["-no-link" | flagBool ghcOptNoLink]
+ , ["-flink-rts" | flagBool ghcOptLinkRts]
+ , ---------------
+ -- Misc flags
+
+ maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))
+ , ["-fbuilding-cabal-package" | flagBool ghcOptCabal]
+ , ----------------
+ -- Compilation
+
+ case flagToMaybe (ghcOptOptimisation opts) of
+ Nothing -> []
+ Just GhcNoOptimisation -> ["-O0"]
+ Just GhcNormalOptimisation -> ["-O"]
+ Just GhcMaximumOptimisation -> ["-O2"]
+ Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph
+ , case flagToMaybe (ghcOptDebugInfo opts) of
+ Nothing -> []
+ Just NoDebugInfo -> []
+ Just MinimalDebugInfo -> ["-g1"]
+ Just NormalDebugInfo -> ["-g2"]
+ Just MaximalDebugInfo -> ["-g3"]
+ , ["-prof" | flagBool ghcOptProfilingMode]
+ , case flagToMaybe (ghcOptProfilingAuto opts) of
+ _
+ | not (flagBool ghcOptProfilingMode) ->
+ []
+ Nothing -> []
+ Just GhcProfAutoAll
+ | flagProfAuto implInfo -> ["-fprof-auto"]
+ | otherwise -> ["-auto-all"] -- not the same, but close
+ Just GhcProfLate
+ | flagProfLate implInfo -> ["-fprof-late"]
+ | otherwise -> ["-fprof-auto-top"] -- not the same, not very close, but what we have.
+ Just GhcProfAutoToplevel
+ | flagProfAuto implInfo -> ["-fprof-auto-top"]
+ | otherwise -> ["-auto-all"]
+ Just GhcProfAutoExported
+ | flagProfAuto implInfo -> ["-fprof-auto-exported"]
+ | otherwise -> ["-auto"]
+ , ["-split-sections" | flagBool ghcOptSplitSections]
+ , ["-split-objs" | flagBool ghcOptSplitObjs]
+ , case flagToMaybe (ghcOptHPCDir opts) of
+ Nothing -> []
+ Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]
+ , if parmakeSupported comp
+ then case ghcOptNumJobs opts of
+ NoFlag -> []
+ Flag n -> ["-j" ++ maybe "" show n]
+ else []
+ , --------------------
+ -- Creating libraries
+
+ ["-staticlib" | flagBool ghcOptStaticLib]
+ , ["-shared" | flagBool ghcOptShared]
+ , case flagToMaybe (ghcOptDynLinkMode opts) of
+ Nothing -> []
+ Just GhcStaticOnly -> ["-static"]
+ Just GhcDynamicOnly -> ["-dynamic"]
+ Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]
+ , ["-fPIC" | flagBool ghcOptFPic]
+ , concat [["-dylib-install-name", libname] | libname <- flag ghcOptDylibName]
+ , ------------------------
+ -- Redirecting outputs
+
+ concat [["-osuf", suf] | suf <- flag ghcOptObjSuffix]
+ , concat [["-hisuf", suf] | suf <- flag ghcOptHiSuffix]
+ , concat [["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix]
+ , concat [["-dynhisuf", suf] | suf <- flag ghcOptDynHiSuffix]
+ , concat [["-outputdir", dir] | dir <- flag ghcOptOutputDir]
+ , concat [["-odir", dir] | dir <- flag ghcOptObjDir]
+ , concat [["-hidir", dir] | dir <- flag ghcOptHiDir]
+ , concat [["-stubdir", dir] | dir <- flag ghcOptStubDir]
+ , -----------------------
+ -- Source search path
+
+ ["-i" | flagBool ghcOptSourcePathClear]
+ , ["-i" ++ dir | dir <- flags ghcOptSourcePath]
+ , --------------------
+
+ --------------------
+ -- CPP, C, and C++ stuff
+
+ ["-I" ++ dir | dir <- flags ghcOptCppIncludePath]
+ , ["-optP" ++ opt | opt <- ghcOptCppOptions opts]
+ , concat
+ [ ["-optP-include", "-optP" ++ inc]
+ | inc <- flags ghcOptCppIncludes
+ ]
+ , ["-optc" ++ opt | opt <- ghcOptCcOptions opts]
+ , -- C++ compiler options: GHC >= 8.10 requires -optcxx, older requires -optc
+ let cxxflag = case compilerCompatVersion GHC comp of
Just v | v >= mkVersion [8, 10] -> "-optcxx"
_ -> "-optc"
- in [ cxxflag ++ opt | opt <- ghcOptCxxOptions opts]
- , [ "-opta" ++ opt | opt <- ghcOptAsmOptions opts]
- , concat [ ["-pgmc", cc] | cc <- flag ghcOptCcProgram ]
-
- -----------------
- -- Linker stuff
-
- , [ "-optl" ++ opt | opt <- ghcOptLinkOptions opts]
- , ["-l" ++ lib | lib <- ghcOptLinkLibs opts]
- , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ]
- , if isOSX
- then concat [ ["-framework", fmwk]
- | fmwk <- flags ghcOptLinkFrameworks ]
- else []
- , if isOSX
- then concat [ ["-framework-path", path]
- | path <- flags ghcOptLinkFrameworkDirs ]
- else []
- , [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ]
- , [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]
- , concat [ [ "-optl-Wl,-rpath," ++ dir]
- | dir <- flags ghcOptRPaths ]
- , [ modDefFile | modDefFile <- flags ghcOptLinkModDefFiles ]
-
- -------------
- -- Packages
-
- , concat [ [ case () of
- _ | unitIdSupported comp -> "-this-unit-id"
- | packageKeySupported comp -> "-this-package-key"
- | otherwise -> "-package-name"
- , this_arg ]
- | this_arg <- flag ghcOptThisUnitId ]
-
- , concat [ ["-this-component-id", prettyShow this_cid ]
- | this_cid <- flag ghcOptThisComponentId ]
-
- , if null (ghcOptInstantiatedWith opts)
- then []
- else "-instantiated-with"
- : intercalate "," (map (\(n,m) -> prettyShow n ++ "="
- ++ prettyShow m)
- (ghcOptInstantiatedWith opts))
- : []
-
- , concat [ ["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode ]
-
- , [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ]
- , [ "-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules ]
- , [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]
-
- , packageDbArgs implInfo (ghcOptPackageDBs opts)
-
- , concat $ let space "" = ""
- space xs = ' ' : xs
+ in [cxxflag ++ opt | opt <- ghcOptCxxOptions opts]
+ , ["-opta" ++ opt | opt <- ghcOptAsmOptions opts]
+ , concat [["-pgmc", cc] | cc <- flag ghcOptCcProgram]
+ , -----------------
+ -- Linker stuff
+
+ ["-optl" ++ opt | opt <- ghcOptLinkOptions opts]
+ , ["-l" ++ lib | lib <- ghcOptLinkLibs opts]
+ , ["-L" ++ dir | dir <- flags ghcOptLinkLibPath]
+ , if isOSX
+ then
+ concat
+ [ ["-framework", fmwk]
+ | fmwk <- flags ghcOptLinkFrameworks
+ ]
+ else []
+ , if isOSX
+ then
+ concat
+ [ ["-framework-path", path]
+ | path <- flags ghcOptLinkFrameworkDirs
+ ]
+ else []
+ , ["-no-hs-main" | flagBool ghcOptLinkNoHsMain]
+ , ["-dynload deploy" | not (null (flags ghcOptRPaths))]
+ , concat
+ [ ["-optl-Wl,-rpath," ++ dir]
+ | dir <- flags ghcOptRPaths
+ ]
+ , [modDefFile | modDefFile <- flags ghcOptLinkModDefFiles]
+ , -------------
+ -- Packages
+
+ concat
+ [ [ case () of
+ _
+ | unitIdSupported comp -> "-this-unit-id"
+ | packageKeySupported comp -> "-this-package-key"
+ | otherwise -> "-package-name"
+ , this_arg
+ ]
+ | this_arg <- flag ghcOptThisUnitId
+ ]
+ , concat
+ [ ["-this-component-id", prettyShow this_cid]
+ | this_cid <- flag ghcOptThisComponentId
+ ]
+ , if null (ghcOptInstantiatedWith opts)
+ then []
+ else
+ "-instantiated-with"
+ : intercalate
+ ","
+ ( map
+ ( \(n, m) ->
+ prettyShow n
+ ++ "="
+ ++ prettyShow m
+ )
+ (ghcOptInstantiatedWith opts)
+ )
+ : []
+ , concat [["-fno-code", "-fwrite-interface"] | flagBool ghcOptNoCode]
+ , ["-hide-all-packages" | flagBool ghcOptHideAllPackages]
+ , ["-Wmissing-home-modules" | flagBool ghcOptWarnMissingHomeModules]
+ , ["-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages]
+ , packageDbArgs implInfo (ghcOptPackageDBs opts)
+ , concat $
+ let space "" = ""
+ space xs = ' ' : xs
in [ ["-package-id", prettyShow ipkgid ++ space (prettyShow rns)]
- | (ipkgid,rns) <- flags ghcOptPackages ]
-
- ----------------------------
- -- Language and extensions
-
- , if supportsHaskell2010 implInfo
- then [ "-X" ++ prettyShow lang | lang <- flag ghcOptLanguage ]
- else []
-
- , [ ext'
- | ext <- flags ghcOptExtensions
- , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of
- Just (Just arg) -> [arg]
- Just Nothing -> []
- Nothing ->
- error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "
- ++ prettyShow ext ++ " not present in ghcOptExtensionMap."
- ]
-
- ----------------
- -- GHCi
-
- , concat [ [ "-ghci-script", script ] | script <- ghcOptGHCiScripts opts
- , flagGhciScript implInfo ]
-
- ---------------
- -- Inputs
-
- -- Specify the input file(s) first, so that in ghci the `main-is` module is
- -- in scope instead of the first module defined in `other-modules`.
- , flags ghcOptInputFiles
- , concat [ [ "-x", "hs", script] | script <- flags ghcOptInputScripts ]
- , [ prettyShow modu | modu <- flags ghcOptInputModules ]
-
- , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]
- , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]
-
- ---------------
- -- Extra
-
- , ghcOptExtra opts
-
- ]
-
+ | (ipkgid, rns) <- flags ghcOptPackages
+ ]
+ , ----------------------------
+ -- Language and extensions
+
+ if supportsHaskell2010 implInfo
+ then ["-X" ++ prettyShow lang | lang <- flag ghcOptLanguage]
+ else []
+ , [ ext'
+ | ext <- flags ghcOptExtensions
+ , ext' <- case Map.lookup ext (ghcOptExtensionMap opts) of
+ Just (Just arg) -> [arg]
+ Just Nothing -> []
+ Nothing ->
+ error $
+ "Distribution.Simple.Program.GHC.renderGhcOptions: "
+ ++ prettyShow ext
+ ++ " not present in ghcOptExtensionMap."
+ ]
+ , ----------------
+ -- GHCi
+ concat
+ [ ["-ghci-script", script] | script <- ghcOptGHCiScripts opts, flagGhciScript implInfo
+ ]
+ , ---------------
+ -- Inputs
+
+ -- Specify the input file(s) first, so that in ghci the `main-is` module is
+ -- in scope instead of the first module defined in `other-modules`.
+ flags ghcOptInputFiles
+ , concat [["-x", "hs", script] | script <- flags ghcOptInputScripts]
+ , [prettyShow modu | modu <- flags ghcOptInputModules]
+ , concat [["-o", out] | out <- flag ghcOptOutputFile]
+ , concat [["-dyno", out] | out <- flag ghcOptOutputDynFile]
+ , ---------------
+ -- Extra
+
+ ghcOptExtra opts
+ ]
where
- implInfo = getImplInfo comp
- isOSX = os == OSX
- flag flg = flagToList (flg opts)
- flags flg = fromNubListR . flg $ opts
+ implInfo = getImplInfo comp
+ isOSX = os == OSX
+ flag flg = flagToList (flg opts)
+ flags flg = fromNubListR . flg $ opts
flagBool flg = fromFlagOrDefault False (flg opts)
verbosityOpts :: Verbosity -> [String]
verbosityOpts verbosity
| verbosity >= deafening = ["-v"]
- | verbosity >= normal = []
- | otherwise = ["-w", "-v0"]
-
+ | verbosity >= normal = []
+ | otherwise = ["-w", "-v0"]
-- | GHC <7.6 uses '-package-conf' instead of '-package-db'.
packageDbArgsConf :: PackageDBStack -> [String]
packageDbArgsConf dbstack = case dbstack of
- (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
- (GlobalPackageDB:dbs) -> ("-no-user-package-conf")
- : concatMap specific dbs
+ (GlobalPackageDB : UserPackageDB : dbs) -> concatMap specific dbs
+ (GlobalPackageDB : dbs) ->
+ ("-no-user-package-conf")
+ : concatMap specific dbs
_ -> ierror
where
- specific (SpecificPackageDB db) = [ "-package-conf", db ]
- specific _ = ierror
- ierror = error $ "internal error: unexpected package db stack: "
- ++ show dbstack
+ specific (SpecificPackageDB db) = ["-package-conf", db]
+ specific _ = ierror
+ ierror =
+ error $
+ "internal error: unexpected package db stack: "
+ ++ show dbstack
-- | GHC >= 7.6 uses the '-package-db' flag. See
-- https://gitlab.haskell.org/ghc/ghc/-/issues/5977.
packageDbArgsDb :: PackageDBStack -> [String]
-- special cases to make arguments prettier in common scenarios
packageDbArgsDb dbstack = case dbstack of
- (GlobalPackageDB:UserPackageDB:dbs)
- | all isSpecific dbs -> concatMap single dbs
- (GlobalPackageDB:dbs)
- | all isSpecific dbs -> "-no-user-package-db"
- : concatMap single dbs
- dbs -> "-clear-package-db"
- : concatMap single dbs
- where
- single (SpecificPackageDB db) = [ "-package-db", db ]
- single GlobalPackageDB = [ "-global-package-db" ]
- single UserPackageDB = [ "-user-package-db" ]
- isSpecific (SpecificPackageDB _) = True
- isSpecific _ = False
+ (GlobalPackageDB : UserPackageDB : dbs)
+ | all isSpecific dbs -> concatMap single dbs
+ (GlobalPackageDB : dbs)
+ | all isSpecific dbs ->
+ "-no-user-package-db"
+ : concatMap single dbs
+ dbs ->
+ "-clear-package-db"
+ : concatMap single dbs
+ where
+ single (SpecificPackageDB db) = ["-package-db", db]
+ single GlobalPackageDB = ["-global-package-db"]
+ single UserPackageDB = ["-user-package-db"]
+ isSpecific (SpecificPackageDB _) = True
+ isSpecific _ = False
packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String]
packageDbArgs implInfo
| flagPackageConf implInfo = packageDbArgsConf
- | otherwise = packageDbArgsDb
+ | otherwise = packageDbArgsDb
-- -----------------------------------------------------------------------------
-- Boilerplate Monoid instance for GhcOptions
diff --git a/Cabal/src/Distribution/Simple/Program/HcPkg.hs b/Cabal/src/Distribution/Simple/Program/HcPkg.hs
index 1a3e3258e8fa3385bb337107d59ddce778283e1b..8a39469c8757a06c11744a22d6bf12cf52d0ce90 100644
--- a/Cabal/src/Distribution/Simple/Program/HcPkg.hs
+++ b/Cabal/src/Distribution/Simple/Program/HcPkg.hs
@@ -1,9 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.HcPkg
-- Copyright : Duncan Coutts 2009, 2013
@@ -13,35 +14,34 @@
--
-- This module provides an library interface to the @hc-pkg@ program.
-- Currently only GHC and GHCJS have hc-pkg programs.
-
-module Distribution.Simple.Program.HcPkg (
- -- * Types
- HcPkgInfo(..),
- RegisterOptions(..),
- defaultRegisterOptions,
+module Distribution.Simple.Program.HcPkg
+ ( -- * Types
+ HcPkgInfo (..)
+ , RegisterOptions (..)
+ , defaultRegisterOptions
-- * Actions
- init,
- invoke,
- register,
- unregister,
- recache,
- expose,
- hide,
- dump,
- describe,
- list,
+ , init
+ , invoke
+ , register
+ , unregister
+ , recache
+ , expose
+ , hide
+ , dump
+ , describe
+ , list
-- * Program invocations
- initInvocation,
- registerInvocation,
- unregisterInvocation,
- recacheInvocation,
- exposeInvocation,
- hideInvocation,
- dumpInvocation,
- describeInvocation,
- listInvocation,
+ , initInvocation
+ , registerInvocation
+ , unregisterInvocation
+ , recacheInvocation
+ , exposeInvocation
+ , hideInvocation
+ , dumpInvocation
+ , describeInvocation
+ , listInvocation
) where
import Distribution.Compat.Prelude hiding (init)
@@ -59,42 +59,46 @@ import Distribution.Types.PackageId
import Distribution.Types.UnitId
import Distribution.Verbosity
-import Data.List (stripPrefix)
+import Data.List (stripPrefix)
import System.FilePath as FilePath (isPathSeparator, joinPath, splitDirectories, splitPath, (<.>), (</>))
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.List.NonEmpty as NE
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.List.NonEmpty as NE
import qualified System.FilePath.Posix as FilePath.Posix
-- | Information about the features and capabilities of an @hc-pkg@
-- program.
---
data HcPkgInfo = HcPkgInfo
- { hcPkgProgram :: ConfiguredProgram
- , noPkgDbStack :: Bool -- ^ no package DB stack supported
- , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags
- , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db
- , supportsDirDbs :: Bool -- ^ supports directory style package databases
- , requiresDirDbs :: Bool -- ^ requires directory style package databases
- , nativeMultiInstance :: Bool -- ^ supports --enable-multi-instance flag
- , recacheMultiInstance :: Bool -- ^ supports multi-instance via recache
- , suppressFilesCheck :: Bool -- ^ supports --force-files or equivalent
+ { hcPkgProgram :: ConfiguredProgram
+ , noPkgDbStack :: Bool
+ -- ^ no package DB stack supported
+ , noVerboseFlag :: Bool
+ -- ^ hc-pkg does not support verbosity flags
+ , flagPackageConf :: Bool
+ -- ^ use package-conf option instead of package-db
+ , supportsDirDbs :: Bool
+ -- ^ supports directory style package databases
+ , requiresDirDbs :: Bool
+ -- ^ requires directory style package databases
+ , nativeMultiInstance :: Bool
+ -- ^ supports --enable-multi-instance flag
+ , recacheMultiInstance :: Bool
+ -- ^ supports multi-instance via recache
+ , suppressFilesCheck :: Bool
+ -- ^ supports --force-files or equivalent
}
-
-- | Call @hc-pkg@ to initialise a package database at the location {path}.
--
-- > hc-pkg init {path}
---
init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init hpi verbosity preferCompat path
- | not (supportsDirDbs hpi)
- || (not (requiresDirDbs hpi) && preferCompat)
- = writeFile path "[]"
-
- | otherwise
- = runProgramInvocation verbosity (initInvocation hpi verbosity path)
+ | not (supportsDirDbs hpi)
+ || (not (requiresDirDbs hpi) && preferCompat) =
+ writeFile path "[]"
+ | otherwise =
+ runProgramInvocation verbosity (initInvocation hpi verbosity path)
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
@@ -102,194 +106,202 @@ invoke :: HcPkgInfo -> Verbosity -> PackageDBStack -> [String] -> IO ()
invoke hpi verbosity dbStack extraArgs =
runProgramInvocation verbosity invocation
where
- args = packageDbStackOpts hpi dbStack ++ extraArgs
+ args = packageDbStackOpts hpi dbStack ++ extraArgs
invocation = programInvocation (hcPkgProgram hpi) args
-- | Additional variations in the behaviour for 'register'.
-data RegisterOptions = RegisterOptions {
- -- | Allows re-registering \/ overwriting an existing package
- registerAllowOverwrite :: Bool,
-
- -- | Insist on the ability to register multiple instances of a
- -- single version of a single package. This will fail if the @hc-pkg@
- -- does not support it, see 'nativeMultiInstance' and
- -- 'recacheMultiInstance'.
- registerMultiInstance :: Bool,
-
- -- | Require that no checks are performed on the existence of package
- -- files mentioned in the registration info. This must be used if
- -- registering prior to putting the files in their final place. This will
- -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'.
- registerSuppressFilesCheck :: Bool
- }
+data RegisterOptions = RegisterOptions
+ { registerAllowOverwrite :: Bool
+ -- ^ Allows re-registering \/ overwriting an existing package
+ , registerMultiInstance :: Bool
+ -- ^ Insist on the ability to register multiple instances of a
+ -- single version of a single package. This will fail if the @hc-pkg@
+ -- does not support it, see 'nativeMultiInstance' and
+ -- 'recacheMultiInstance'.
+ , registerSuppressFilesCheck :: Bool
+ -- ^ Require that no checks are performed on the existence of package
+ -- files mentioned in the registration info. This must be used if
+ -- registering prior to putting the files in their final place. This will
+ -- fail if the @hc-pkg@ does not support it, see 'suppressFilesCheck'.
+ }
-- | Defaults are @True@, @False@ and @False@
defaultRegisterOptions :: RegisterOptions
-defaultRegisterOptions = RegisterOptions {
- registerAllowOverwrite = True,
- registerMultiInstance = False,
- registerSuppressFilesCheck = False
- }
+defaultRegisterOptions =
+ RegisterOptions
+ { registerAllowOverwrite = True
+ , registerMultiInstance = False
+ , registerSuppressFilesCheck = False
+ }
-- | Call @hc-pkg@ to register a package.
--
-- > hc-pkg register {filename | -} [--user | --global | --package-db]
---
-register :: HcPkgInfo -> Verbosity -> PackageDBStack
- -> InstalledPackageInfo
- -> RegisterOptions
- -> IO ()
+register
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDBStack
+ -> InstalledPackageInfo
+ -> RegisterOptions
+ -> IO ()
register hpi verbosity packagedbs pkgInfo registerOptions
| registerMultiInstance registerOptions
- , not (nativeMultiInstance hpi || recacheMultiInstance hpi)
- = die' verbosity $ "HcPkg.register: the compiler does not support "
- ++ "registering multiple instances of packages."
-
+ , not (nativeMultiInstance hpi || recacheMultiInstance hpi) =
+ die' verbosity $
+ "HcPkg.register: the compiler does not support "
+ ++ "registering multiple instances of packages."
| registerSuppressFilesCheck registerOptions
- , not (suppressFilesCheck hpi)
- = die' verbosity $ "HcPkg.register: the compiler does not support "
- ++ "suppressing checks on files."
-
- -- This is a trick. Older versions of GHC do not support the
- -- --enable-multi-instance flag for ghc-pkg register but it turns out that
- -- the same ability is available by using ghc-pkg recache. The recache
- -- command is there to support distro package managers that like to work
- -- by just installing files and running update commands, rather than
- -- special add/remove commands. So the way to register by this method is
- -- to write the package registration file directly into the package db and
- -- then call hc-pkg recache.
- --
+ , not (suppressFilesCheck hpi) =
+ die' verbosity $
+ "HcPkg.register: the compiler does not support "
+ ++ "suppressing checks on files."
+ -- This is a trick. Older versions of GHC do not support the
+ -- --enable-multi-instance flag for ghc-pkg register but it turns out that
+ -- the same ability is available by using ghc-pkg recache. The recache
+ -- command is there to support distro package managers that like to work
+ -- by just installing files and running update commands, rather than
+ -- special add/remove commands. So the way to register by this method is
+ -- to write the package registration file directly into the package db and
+ -- then call hc-pkg recache.
+ --
| registerMultiInstance registerOptions
- , recacheMultiInstance hpi
- = do let pkgdb = registrationPackageDB packagedbs
- writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo
- recache hpi verbosity pkgdb
-
- | otherwise
- = runProgramInvocation verbosity
- (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions)
-
-writeRegistrationFileDirectly :: Verbosity
- -> HcPkgInfo
- -> PackageDB
- -> InstalledPackageInfo
- -> IO ()
+ , recacheMultiInstance hpi =
+ do
+ let pkgdb = registrationPackageDB packagedbs
+ writeRegistrationFileDirectly verbosity hpi pkgdb pkgInfo
+ recache hpi verbosity pkgdb
+ | otherwise =
+ runProgramInvocation
+ verbosity
+ (registerInvocation hpi verbosity packagedbs pkgInfo registerOptions)
+
+writeRegistrationFileDirectly
+ :: Verbosity
+ -> HcPkgInfo
+ -> PackageDB
+ -> InstalledPackageInfo
+ -> IO ()
writeRegistrationFileDirectly verbosity hpi (SpecificPackageDB dir) pkgInfo
- | supportsDirDbs hpi
- = do let pkgfile = dir </> prettyShow (installedUnitId pkgInfo) <.> "conf"
- writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)
-
- | otherwise
- = die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"
-
+ | supportsDirDbs hpi =
+ do
+ let pkgfile = dir </> prettyShow (installedUnitId pkgInfo) <.> "conf"
+ writeUTF8File pkgfile (showInstalledPackageInfo pkgInfo)
+ | otherwise =
+ die' verbosity $ "HcPkg.writeRegistrationFileDirectly: compiler does not support dir style package dbs"
writeRegistrationFileDirectly verbosity _ _ _ =
- -- We don't know here what the dir for the global or user dbs are,
- -- if that's needed it'll require a bit more plumbing to support.
- die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"
-
+ -- We don't know here what the dir for the global or user dbs are,
+ -- if that's needed it'll require a bit more plumbing to support.
+ die' verbosity $ "HcPkg.writeRegistrationFileDirectly: only supports SpecificPackageDB for now"
-- | Call @hc-pkg@ to unregister a package
--
-- > hc-pkg unregister [pkgid] [--user | --global | --package-db]
---
unregister :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
unregister hpi verbosity packagedb pkgid =
- runProgramInvocation verbosity
+ runProgramInvocation
+ verbosity
(unregisterInvocation hpi verbosity packagedb pkgid)
-
-- | Call @hc-pkg@ to recache the registered packages.
--
-- > hc-pkg recache [--user | --global | --package-db]
---
recache :: HcPkgInfo -> Verbosity -> PackageDB -> IO ()
recache hpi verbosity packagedb =
- runProgramInvocation verbosity
+ runProgramInvocation
+ verbosity
(recacheInvocation hpi verbosity packagedb)
-
-- | Call @hc-pkg@ to expose a package.
--
-- > hc-pkg expose [pkgid] [--user | --global | --package-db]
---
expose :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
expose hpi verbosity packagedb pkgid =
- runProgramInvocation verbosity
+ runProgramInvocation
+ verbosity
(exposeInvocation hpi verbosity packagedb pkgid)
-- | Call @hc-pkg@ to retrieve a specific package
--
-- > hc-pkg describe [pkgid] [--user | --global | --package-db]
---
describe :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId -> IO [InstalledPackageInfo]
describe hpi verbosity packagedb pid = do
-
- output <- getProgramInvocationLBS verbosity
- (describeInvocation hpi verbosity packagedb pid)
- `catchIO` \_ -> return mempty
+ output <-
+ getProgramInvocationLBS
+ verbosity
+ (describeInvocation hpi verbosity packagedb pid)
+ `catchIO` \_ -> return mempty
case parsePackages output of
Left ok -> return ok
- _ -> die' verbosity $ "failed to parse output of '"
- ++ programId (hcPkgProgram hpi) ++ " describe " ++ prettyShow pid ++ "'"
+ _ ->
+ die' verbosity $
+ "failed to parse output of '"
+ ++ programId (hcPkgProgram hpi)
+ ++ " describe "
+ ++ prettyShow pid
+ ++ "'"
-- | Call @hc-pkg@ to hide a package.
--
-- > hc-pkg hide [pkgid] [--user | --global | --package-db]
---
hide :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId -> IO ()
hide hpi verbosity packagedb pkgid =
- runProgramInvocation verbosity
+ runProgramInvocation
+ verbosity
(hideInvocation hpi verbosity packagedb pkgid)
-
-- | Call @hc-pkg@ to get all the details of all the packages in the given
-- package database.
---
dump :: HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
dump hpi verbosity packagedb = do
-
- output <- getProgramInvocationLBS verbosity
- (dumpInvocation hpi verbosity packagedb)
- `catchIO` \e -> die' verbosity $ programId (hcPkgProgram hpi) ++ " dump failed: "
- ++ displayException e
+ output <-
+ getProgramInvocationLBS
+ verbosity
+ (dumpInvocation hpi verbosity packagedb)
+ `catchIO` \e ->
+ die' verbosity $
+ programId (hcPkgProgram hpi)
+ ++ " dump failed: "
+ ++ displayException e
case parsePackages output of
Left ok -> return ok
- _ -> die' verbosity $ "failed to parse output of '"
- ++ programId (hcPkgProgram hpi) ++ " dump'"
-
+ _ ->
+ die' verbosity $
+ "failed to parse output of '"
+ ++ programId (hcPkgProgram hpi)
+ ++ " dump'"
parsePackages :: LBS.ByteString -> Either [InstalledPackageInfo] [String]
parsePackages lbs0 =
- case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of
- Right ok -> Left [ setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok ]
- Left msgs -> Right (NE.toList msgs)
+ case traverse parseInstalledPackageInfo $ splitPkgs lbs0 of
+ Right ok -> Left [setUnitId . maybe id mungePackagePaths (pkgRoot pkg) $ pkg | (_, pkg) <- ok]
+ Left msgs -> Right (NE.toList msgs)
where
splitPkgs :: LBS.ByteString -> [BS.ByteString]
splitPkgs = checkEmpty . doSplit
where
-- Handle the case of there being no packages at all.
checkEmpty [s] | BS.all isSpace8 s = []
- checkEmpty ss = ss
+ checkEmpty ss = ss
isSpace8 :: Word8 -> Bool
- isSpace8 9 = True -- '\t'
+ isSpace8 9 = True -- '\t'
isSpace8 10 = True -- '\n'
isSpace8 13 = True -- '\r'
isSpace8 32 = True -- ' '
- isSpace8 _ = False
+ isSpace8 _ = False
doSplit :: LBS.ByteString -> [BS.ByteString]
doSplit lbs = go (LBS.findIndices (\w -> w == 10 || w == 13) lbs)
where
go :: [Int64] -> [BS.ByteString]
- go [] = [ LBS.toStrict lbs ]
- go (idx:idxs) =
- let (pfx, sfx) = LBS.splitAt idx lbs
- in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of
+ go [] = [LBS.toStrict lbs]
+ go (idx : idxs) =
+ let (pfx, sfx) = LBS.splitAt idx lbs
+ in case foldr (<|>) Nothing $ map (`lbsStripPrefix` sfx) separators of
Just sfx' -> LBS.toStrict pfx : doSplit sfx'
- Nothing -> go idxs
+ Nothing -> go idxs
separators :: [LBS.ByteString]
separators = ["\n---\n", "\r\n---\r\n", "\r---\r"]
@@ -303,26 +315,25 @@ lbsStripPrefix pfx lbs
| otherwise = Nothing
#endif
-
mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
mungePackagePaths pkgroot pkginfo =
- pkginfo {
- importDirs = mungePaths (importDirs pkginfo),
- includeDirs = mungePaths (includeDirs pkginfo),
- libraryDirs = mungePaths (libraryDirs pkginfo),
- libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo),
- libraryDynDirs = mungePaths (libraryDynDirs pkginfo),
- frameworkDirs = mungePaths (frameworkDirs pkginfo),
- haddockInterfaces = mungePaths (haddockInterfaces pkginfo),
- haddockHTMLs = mungeUrls (haddockHTMLs pkginfo)
+ pkginfo
+ { importDirs = mungePaths (importDirs pkginfo)
+ , includeDirs = mungePaths (includeDirs pkginfo)
+ , libraryDirs = mungePaths (libraryDirs pkginfo)
+ , libraryDirsStatic = mungePaths (libraryDirsStatic pkginfo)
+ , libraryDynDirs = mungePaths (libraryDynDirs pkginfo)
+ , frameworkDirs = mungePaths (frameworkDirs pkginfo)
+ , haddockInterfaces = mungePaths (haddockInterfaces pkginfo)
+ , haddockHTMLs = mungeUrls (haddockHTMLs pkginfo)
}
where
mungePaths = map mungePath
- mungeUrls = map mungeUrl
+ mungeUrls = map mungeUrl
mungePath p = case stripVarPrefix "${pkgroot}" p of
Just p' -> pkgroot </> p'
@@ -332,53 +343,59 @@ mungePackagePaths pkgroot pkginfo =
Just p' -> toUrlPath pkgroot p'
Nothing -> p
- toUrlPath r p = "file:///"
- -- URLs always use posix style '/' separators:
- ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
+ toUrlPath r p =
+ "file:///"
+ -- URLs always use posix style '/' separators:
+ ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p)
stripVarPrefix var p =
case splitPath p of
- (root:path') -> case stripPrefix var root of
+ (root : path') -> case stripPrefix var root of
Just [sep] | isPathSeparator sep -> Just (joinPath path')
- _ -> Nothing
- _ -> Nothing
-
+ _ -> Nothing
+ _ -> Nothing
-- Older installed package info files did not have the installedUnitId
-- field, so if it is missing then we fill it as the source package ID.
-- NB: Internal libraries not supported.
setUnitId :: InstalledPackageInfo -> InstalledPackageInfo
-setUnitId pkginfo@InstalledPackageInfo {
- installedUnitId = uid,
- sourcePackageId = pid
- } | unUnitId uid == ""
- = pkginfo {
- installedUnitId = mkLegacyUnitId pid,
- installedComponentId_ = mkComponentId (prettyShow pid)
- }
+setUnitId
+ pkginfo@InstalledPackageInfo
+ { installedUnitId = uid
+ , sourcePackageId = pid
+ }
+ | unUnitId uid == "" =
+ pkginfo
+ { installedUnitId = mkLegacyUnitId pid
+ , installedComponentId_ = mkComponentId (prettyShow pid)
+ }
setUnitId pkginfo = pkginfo
-
-- | Call @hc-pkg@ to get the source package Id of all the packages in the
-- given package database.
--
-- This is much less information than with 'dump', but also rather quicker.
-- Note in particular that it does not include the 'UnitId', just
-- the source 'PackageId' which is not necessarily unique in any package db.
---
-list :: HcPkgInfo -> Verbosity -> PackageDB
- -> IO [PackageId]
+list
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDB
+ -> IO [PackageId]
list hpi verbosity packagedb = do
-
- output <- getProgramInvocationOutput verbosity
- (listInvocation hpi verbosity packagedb)
- `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed"
+ output <-
+ getProgramInvocationOutput
+ verbosity
+ (listInvocation hpi verbosity packagedb)
+ `catchIO` \_ -> die' verbosity $ programId (hcPkgProgram hpi) ++ " list failed"
case parsePackageIds output of
Just ok -> return ok
- _ -> die' verbosity $ "failed to parse output of '"
- ++ programId (hcPkgProgram hpi) ++ " list'"
-
+ _ ->
+ die' verbosity $
+ "failed to parse output of '"
+ ++ programId (hcPkgProgram hpi)
+ ++ " list'"
where
parsePackageIds = traverse simpleParsec . words
@@ -388,130 +405,157 @@ list hpi verbosity packagedb = do
initInvocation :: HcPkgInfo -> Verbosity -> FilePath -> ProgramInvocation
initInvocation hpi verbosity path =
- programInvocation (hcPkgProgram hpi) args
+ programInvocation (hcPkgProgram hpi) args
where
- args = ["init", path]
+ args =
+ ["init", path]
++ verbosityOpts hpi verbosity
registerInvocation
- :: HcPkgInfo -> Verbosity -> PackageDBStack
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDBStack
-> InstalledPackageInfo
-> RegisterOptions
-> ProgramInvocation
registerInvocation hpi verbosity packagedbs pkgInfo registerOptions =
- (programInvocation (hcPkgProgram hpi) (args "-")) {
- progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo,
- progInvokeInputEncoding = IOEncodingUTF8
+ (programInvocation (hcPkgProgram hpi) (args "-"))
+ { progInvokeInput = Just $ IODataText $ showInstalledPackageInfo pkgInfo
+ , progInvokeInputEncoding = IOEncodingUTF8
}
where
cmdname
| registerAllowOverwrite registerOptions = "update"
- | registerMultiInstance registerOptions = "update"
- | otherwise = "register"
-
- args file = [cmdname, file]
- ++ packageDbStackOpts hpi packagedbs
- ++ [ "--enable-multi-instance"
- | registerMultiInstance registerOptions ]
- ++ [ "--force-files"
- | registerSuppressFilesCheck registerOptions ]
- ++ verbosityOpts hpi verbosity
-
-unregisterInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
- -> ProgramInvocation
+ | registerMultiInstance registerOptions = "update"
+ | otherwise = "register"
+
+ args file =
+ [cmdname, file]
+ ++ packageDbStackOpts hpi packagedbs
+ ++ [ "--enable-multi-instance"
+ | registerMultiInstance registerOptions
+ ]
+ ++ [ "--force-files"
+ | registerSuppressFilesCheck registerOptions
+ ]
+ ++ verbosityOpts hpi verbosity
+
+unregisterInvocation
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDB
+ -> PackageId
+ -> ProgramInvocation
unregisterInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
- ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid]
- ++ verbosityOpts hpi verbosity
+ ["unregister", packageDbOpts hpi packagedb, prettyShow pkgid]
+ ++ verbosityOpts hpi verbosity
-
-recacheInvocation :: HcPkgInfo -> Verbosity -> PackageDB
- -> ProgramInvocation
+recacheInvocation
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDB
+ -> ProgramInvocation
recacheInvocation hpi verbosity packagedb =
programInvocation (hcPkgProgram hpi) $
- ["recache", packageDbOpts hpi packagedb]
- ++ verbosityOpts hpi verbosity
-
-
-exposeInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
- -> ProgramInvocation
+ ["recache", packageDbOpts hpi packagedb]
+ ++ verbosityOpts hpi verbosity
+
+exposeInvocation
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDB
+ -> PackageId
+ -> ProgramInvocation
exposeInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
- ["expose", packageDbOpts hpi packagedb, prettyShow pkgid]
- ++ verbosityOpts hpi verbosity
-
-describeInvocation :: HcPkgInfo -> Verbosity -> PackageDBStack -> PackageId
- -> ProgramInvocation
+ ["expose", packageDbOpts hpi packagedb, prettyShow pkgid]
+ ++ verbosityOpts hpi verbosity
+
+describeInvocation
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDBStack
+ -> PackageId
+ -> ProgramInvocation
describeInvocation hpi verbosity packagedbs pkgid =
programInvocation (hcPkgProgram hpi) $
- ["describe", prettyShow pkgid]
- ++ packageDbStackOpts hpi packagedbs
- ++ verbosityOpts hpi verbosity
-
-hideInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> PackageId
- -> ProgramInvocation
+ ["describe", prettyShow pkgid]
+ ++ packageDbStackOpts hpi packagedbs
+ ++ verbosityOpts hpi verbosity
+
+hideInvocation
+ :: HcPkgInfo
+ -> Verbosity
+ -> PackageDB
+ -> PackageId
+ -> ProgramInvocation
hideInvocation hpi verbosity packagedb pkgid =
programInvocation (hcPkgProgram hpi) $
- ["hide", packageDbOpts hpi packagedb, prettyShow pkgid]
- ++ verbosityOpts hpi verbosity
-
+ ["hide", packageDbOpts hpi packagedb, prettyShow pkgid]
+ ++ verbosityOpts hpi verbosity
dumpInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
dumpInvocation hpi _verbosity packagedb =
- (programInvocation (hcPkgProgram hpi) args) {
- progInvokeOutputEncoding = IOEncodingUTF8
+ (programInvocation (hcPkgProgram hpi) args)
+ { progInvokeOutputEncoding = IOEncodingUTF8
}
where
- args = ["dump", packageDbOpts hpi packagedb]
+ args =
+ ["dump", packageDbOpts hpi packagedb]
++ verbosityOpts hpi silent
- -- We use verbosity level 'silent' because it is important that we
- -- do not contaminate the output with info/debug messages.
+
+-- We use verbosity level 'silent' because it is important that we
+-- do not contaminate the output with info/debug messages.
listInvocation :: HcPkgInfo -> Verbosity -> PackageDB -> ProgramInvocation
listInvocation hpi _verbosity packagedb =
- (programInvocation (hcPkgProgram hpi) args) {
- progInvokeOutputEncoding = IOEncodingUTF8
+ (programInvocation (hcPkgProgram hpi) args)
+ { progInvokeOutputEncoding = IOEncodingUTF8
}
where
- args = ["list", "--simple-output", packageDbOpts hpi packagedb]
+ args =
+ ["list", "--simple-output", packageDbOpts hpi packagedb]
++ verbosityOpts hpi silent
- -- We use verbosity level 'silent' because it is important that we
- -- do not contaminate the output with info/debug messages.
+-- We use verbosity level 'silent' because it is important that we
+-- do not contaminate the output with info/debug messages.
packageDbStackOpts :: HcPkgInfo -> PackageDBStack -> [String]
packageDbStackOpts hpi dbstack
| noPkgDbStack hpi = [packageDbOpts hpi (registrationPackageDB dbstack)]
- | otherwise = case dbstack of
- (GlobalPackageDB:UserPackageDB:dbs) -> "--global"
- : "--user"
- : map specific dbs
- (GlobalPackageDB:dbs) -> "--global"
- : ("--no-user-" ++ packageDbFlag hpi)
- : map specific dbs
- _ -> ierror
- where
- specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
- specific _ = ierror
- ierror :: a
- ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
+ | otherwise = case dbstack of
+ (GlobalPackageDB : UserPackageDB : dbs) ->
+ "--global"
+ : "--user"
+ : map specific dbs
+ (GlobalPackageDB : dbs) ->
+ "--global"
+ : ("--no-user-" ++ packageDbFlag hpi)
+ : map specific dbs
+ _ -> ierror
+ where
+ specific (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
+ specific _ = ierror
+ ierror :: a
+ ierror = error ("internal error: unexpected package db stack: " ++ show dbstack)
packageDbFlag :: HcPkgInfo -> String
packageDbFlag hpi
- | flagPackageConf hpi
- = "package-conf"
- | otherwise
- = "package-db"
+ | flagPackageConf hpi =
+ "package-conf"
+ | otherwise =
+ "package-db"
packageDbOpts :: HcPkgInfo -> PackageDB -> String
-packageDbOpts _ GlobalPackageDB = "--global"
-packageDbOpts _ UserPackageDB = "--user"
+packageDbOpts _ GlobalPackageDB = "--global"
+packageDbOpts _ UserPackageDB = "--user"
packageDbOpts hpi (SpecificPackageDB db) = "--" ++ packageDbFlag hpi ++ "=" ++ db
verbosityOpts :: HcPkgInfo -> Verbosity -> [String]
verbosityOpts hpi v
- | noVerboseFlag hpi
- = []
+ | noVerboseFlag hpi =
+ []
| v >= deafening = ["-v2"]
- | v == silent = ["-v0"]
- | otherwise = []
+ | v == silent = ["-v0"]
+ | otherwise = []
diff --git a/Cabal/src/Distribution/Simple/Program/Hpc.hs b/Cabal/src/Distribution/Simple/Program/Hpc.hs
index f86cde6b33d9b9ea5a274c1b159b2a1640c6969f..0fb210e72e3215c4c0e3266a6ce23fa0bda748a0 100644
--- a/Cabal/src/Distribution/Simple/Program/Hpc.hs
+++ b/Cabal/src/Distribution/Simple/Program/Hpc.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Hpc
-- Copyright : Thomas Tuegel 2011
@@ -10,21 +11,20 @@
-- Portability : portable
--
-- This module provides an library interface to the @hpc@ program.
-
module Distribution.Simple.Program.Hpc
- ( markup
- , union
- ) where
+ ( markup
+ , union
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import System.Directory (makeRelativeToCurrentDirectory)
import Distribution.ModuleName
+import Distribution.Pretty
import Distribution.Simple.Program.Run
import Distribution.Simple.Program.Types
-import Distribution.Pretty
import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Version
@@ -36,74 +36,103 @@ import Distribution.Version
-- first path in the list. This means that e.g. test suites that import their
-- library as a dependency can still work, but those that include the library
-- modules directly (in other-modules) don't.
-markup :: ConfiguredProgram
- -> Version
- -> Verbosity
- -> FilePath -- ^ Path to .tix file
- -> [FilePath] -- ^ Paths to .mix file directories
- -> FilePath -- ^ Path where html output should be located
- -> [ModuleName] -- ^ List of modules to include in the report
- -> IO ()
+markup
+ :: ConfiguredProgram
+ -> Version
+ -> Verbosity
+ -> FilePath
+ -- ^ Path to .tix file
+ -> [FilePath]
+ -- ^ Paths to .mix file directories
+ -> FilePath
+ -- ^ Path where html output should be located
+ -> [ModuleName]
+ -- ^ List of modules to include in the report
+ -> IO ()
markup hpc hpcVer verbosity tixFile hpcDirs destDir included = do
- hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)
- then return hpcDirs
- else do
- warn verbosity $ "Your version of HPC (" ++ prettyShow hpcVer
- ++ ") does not properly handle multiple search paths. "
- ++ "Coverage report generation may fail unexpectedly. These "
- ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "
- ++ "later)."
- ++ if null droppedDirs
- then ""
- else " The following search paths have been abandoned: "
- ++ show droppedDirs
- return passedDirs
+ hpcDirs' <-
+ if withinRange hpcVer (orLaterVersion version07)
+ then return hpcDirs
+ else do
+ warn verbosity $
+ "Your version of HPC ("
+ ++ prettyShow hpcVer
+ ++ ") does not properly handle multiple search paths. "
+ ++ "Coverage report generation may fail unexpectedly. These "
+ ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "
+ ++ "later)."
+ ++ if null droppedDirs
+ then ""
+ else
+ " The following search paths have been abandoned: "
+ ++ show droppedDirs
+ return passedDirs
- -- Prior to GHC 8.0, hpc assumes all .mix paths are relative.
- hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs'
+ -- Prior to GHC 8.0, hpc assumes all .mix paths are relative.
+ hpcDirs'' <- traverse makeRelativeToCurrentDirectory hpcDirs'
- runProgramInvocation verbosity
- (markupInvocation hpc tixFile hpcDirs'' destDir included)
+ runProgramInvocation
+ verbosity
+ (markupInvocation hpc tixFile hpcDirs'' destDir included)
where
version07 = mkVersion [0, 7]
(passedDirs, droppedDirs) = splitAt 1 hpcDirs
-markupInvocation :: ConfiguredProgram
- -> FilePath -- ^ Path to .tix file
- -> [FilePath] -- ^ Paths to .mix file directories
- -> FilePath -- ^ Path where html output should be
- -- located
- -> [ModuleName] -- ^ List of modules to include
- -> ProgramInvocation
+markupInvocation
+ :: ConfiguredProgram
+ -> FilePath
+ -- ^ Path to .tix file
+ -> [FilePath]
+ -- ^ Paths to .mix file directories
+ -> FilePath
+ -- ^ Path where html output should be
+ -- located
+ -> [ModuleName]
+ -- ^ List of modules to include
+ -> ProgramInvocation
markupInvocation hpc tixFile hpcDirs destDir included =
- let args = [ "markup", tixFile
- , "--destdir=" ++ destDir
- ]
- ++ map ("--hpcdir=" ++) hpcDirs
- ++ ["--include=" ++ prettyShow moduleName
- | moduleName <- included ]
- in programInvocation hpc args
+ let args =
+ [ "markup"
+ , tixFile
+ , "--destdir=" ++ destDir
+ ]
+ ++ map ("--hpcdir=" ++) hpcDirs
+ ++ [ "--include=" ++ prettyShow moduleName
+ | moduleName <- included
+ ]
+ in programInvocation hpc args
-union :: ConfiguredProgram
- -> Verbosity
- -> [FilePath] -- ^ Paths to .tix files
- -> FilePath -- ^ Path to resultant .tix file
- -> [ModuleName] -- ^ List of modules to exclude from union
- -> IO ()
+union
+ :: ConfiguredProgram
+ -> Verbosity
+ -> [FilePath]
+ -- ^ Paths to .tix files
+ -> FilePath
+ -- ^ Path to resultant .tix file
+ -> [ModuleName]
+ -- ^ List of modules to exclude from union
+ -> IO ()
union hpc verbosity tixFiles outFile excluded =
- runProgramInvocation verbosity
- (unionInvocation hpc tixFiles outFile excluded)
+ runProgramInvocation
+ verbosity
+ (unionInvocation hpc tixFiles outFile excluded)
-unionInvocation :: ConfiguredProgram
- -> [FilePath] -- ^ Paths to .tix files
- -> FilePath -- ^ Path to resultant .tix file
- -> [ModuleName] -- ^ List of modules to exclude from union
- -> ProgramInvocation
+unionInvocation
+ :: ConfiguredProgram
+ -> [FilePath]
+ -- ^ Paths to .tix files
+ -> FilePath
+ -- ^ Path to resultant .tix file
+ -> [ModuleName]
+ -- ^ List of modules to exclude from union
+ -> ProgramInvocation
unionInvocation hpc tixFiles outFile excluded =
- programInvocation hpc $ concat
- [ ["sum", "--union"]
- , tixFiles
- , ["--output=" ++ outFile]
- , ["--exclude=" ++ prettyShow moduleName
- | moduleName <- excluded ]
+ programInvocation hpc $
+ concat
+ [ ["sum", "--union"]
+ , tixFiles
+ , ["--output=" ++ outFile]
+ , [ "--exclude=" ++ prettyShow moduleName
+ | moduleName <- excluded
]
+ ]
diff --git a/Cabal/src/Distribution/Simple/Program/Internal.hs b/Cabal/src/Distribution/Simple/Program/Internal.hs
index c842a989c1469c5144c35797ebc468dfe9bc64a5..add9dd74d71ca807a8ae59411e3baed20531fb08 100644
--- a/Cabal/src/Distribution/Simple/Program/Internal.hs
+++ b/Cabal/src/Distribution/Simple/Program/Internal.hs
@@ -1,4 +1,5 @@
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Internal
--
@@ -6,14 +7,13 @@
-- Portability : portable
--
-- Internal utilities used by Distribution.Simple.Program.*.
-
-module Distribution.Simple.Program.Internal (
- stripExtractVersion,
+module Distribution.Simple.Program.Internal
+ ( stripExtractVersion
) where
-import Prelude ()
import Distribution.Compat.Prelude
-import Distribution.Utils.Generic(safeTail)
+import Distribution.Utils.Generic (safeTail)
+import Prelude ()
-- | Extract the version number from the output of 'strip --version'.
--
@@ -23,25 +23,24 @@ import Distribution.Utils.Generic(safeTail)
-- 'strip' doesn't appear to have a version flag.
stripExtractVersion :: String -> String
stripExtractVersion str =
- let numeric "" = False
- numeric (x:_) = isDigit x
+ let numeric "" = False
+ numeric (x : _) = isDigit x
-- Filter out everything in parentheses.
filterPar' :: Int -> [String] -> [String]
- filterPar' _ [] = []
- filterPar' n (x:xs)
- | n >= 0 && "(" `isPrefixOf` x = filterPar' (n+1) ((safeTail x):xs)
- | n > 0 && ")" `isSuffixOf` x = filterPar' (n-1) xs
- | n > 0 = filterPar' n xs
- | otherwise = x:filterPar' n xs
+ filterPar' _ [] = []
+ filterPar' n (x : xs)
+ | n >= 0 && "(" `isPrefixOf` x = filterPar' (n + 1) ((safeTail x) : xs)
+ | n > 0 && ")" `isSuffixOf` x = filterPar' (n - 1) xs
+ | n > 0 = filterPar' n xs
+ | otherwise = x : filterPar' n xs
filterPar = filterPar' 0
-
- in case dropWhile (not . numeric) (filterPar . words $ str) of
- (ver:_) ->
- -- take the first two version components
- let isDot = (== '.')
- (major, rest) = break isDot ver
- minor = takeWhile isDigit (dropWhile isDot rest)
- in major ++ "." ++ minor
- _ -> ""
+ in case dropWhile (not . numeric) (filterPar . words $ str) of
+ (ver : _) ->
+ -- take the first two version components
+ let isDot = (== '.')
+ (major, rest) = break isDot ver
+ minor = takeWhile isDigit (dropWhile isDot rest)
+ in major ++ "." ++ minor
+ _ -> ""
diff --git a/Cabal/src/Distribution/Simple/Program/Ld.hs b/Cabal/src/Distribution/Simple/Program/Ld.hs
index 9115d38d9d8b346dda622d2d590f6c142b5ab1d8..d7449b9396457bc0d5b518dffb377ca834a5fb3c 100644
--- a/Cabal/src/Distribution/Simple/Program/Ld.hs
+++ b/Cabal/src/Distribution/Simple/Program/Ld.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Ld
-- Copyright : Duncan Coutts 2009
@@ -10,60 +11,74 @@
-- Portability : portable
--
-- This module provides an library interface to the @ld@ linker program.
-
-module Distribution.Simple.Program.Ld (
- combineObjectFiles,
+module Distribution.Simple.Program.Ld
+ ( combineObjectFiles
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Simple.Compiler (arResponseFilesSupported)
-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))
+import Distribution.Simple.Flag
+ ( fromFlagOrDefault
+ )
+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..))
import Distribution.Simple.Program.ResponseFile
- ( withResponseFile )
+ ( withResponseFile
+ )
import Distribution.Simple.Program.Run
- ( ProgramInvocation, programInvocation, multiStageProgramInvocation
- , runProgramInvocation )
+ ( ProgramInvocation
+ , multiStageProgramInvocation
+ , programInvocation
+ , runProgramInvocation
+ )
import Distribution.Simple.Program.Types
- ( ConfiguredProgram(..) )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault )
+ ( ConfiguredProgram (..)
+ )
import Distribution.Simple.Setup.Config
- ( configUseResponseFiles )
+ ( configUseResponseFiles
+ )
import Distribution.Simple.Utils
- ( defaultTempFileOptions )
+ ( defaultTempFileOptions
+ )
import Distribution.Verbosity
- ( Verbosity )
+ ( Verbosity
+ )
import System.Directory
- ( renameFile )
+ ( renameFile
+ )
import System.FilePath
- ( (<.>), takeDirectory )
+ ( takeDirectory
+ , (<.>)
+ )
-- | Call @ld -r@ to link a bunch of object files together.
---
-combineObjectFiles :: Verbosity -> LocalBuildInfo -> ConfiguredProgram
- -> FilePath -> [FilePath] -> IO ()
+combineObjectFiles
+ :: Verbosity
+ -> LocalBuildInfo
+ -> ConfiguredProgram
+ -> FilePath
+ -> [FilePath]
+ -> IO ()
combineObjectFiles verbosity lbi ld target files = do
-
-- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is,
-- if we have more object files than fit on a single command line then we
-- have a slight problem. What we have to do is link files in batches into
-- a temp object file and then include that one in the next batch.
- let simpleArgs = ["-r", "-o", target]
+ let simpleArgs = ["-r", "-o", target]
initialArgs = ["-r", "-o", target]
- middleArgs = ["-r", "-o", target, tmpfile]
- finalArgs = middleArgs
+ middleArgs = ["-r", "-o", target, tmpfile]
+ finalArgs = middleArgs
- simple = programInvocation ld simpleArgs
- initial = programInvocation ld initialArgs
- middle = programInvocation ld middleArgs
- final = programInvocation ld finalArgs
+ simple = programInvocation ld simpleArgs
+ initial = programInvocation ld initialArgs
+ middle = programInvocation ld middleArgs
+ final = programInvocation ld finalArgs
- targetDir = takeDirectory target
+ targetDir = takeDirectory target
invokeWithResponesFile :: FilePath -> ProgramInvocation
invokeWithResponesFile atFile =
@@ -73,22 +88,19 @@ combineObjectFiles verbosity lbi ld target files = do
fromFlagOrDefault False $ configUseResponseFiles $ configFlags lbi
-- Whether ghc's ar supports response files is a good proxy for
-- whether ghc's ld supports them as well.
- responseArgumentsNotSupported =
+ responseArgumentsNotSupported =
not (arResponseFilesSupported (compiler lbi))
if oldVersionManualOverride || responseArgumentsNotSupported
- then
- run $ multiStageProgramInvocation simple (initial, middle, final) files
- else
- withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $
- \path -> runProgramInvocation verbosity $ invokeWithResponesFile path
-
+ then run $ multiStageProgramInvocation simple (initial, middle, final) files
+ else withResponseFile verbosity defaultTempFileOptions targetDir "ld.rsp" Nothing files $
+ \path -> runProgramInvocation verbosity $ invokeWithResponesFile path
where
- tmpfile = target <.> "tmp" -- perhaps should use a proper temp file
-
+ tmpfile = target <.> "tmp" -- perhaps should use a proper temp file
run :: [ProgramInvocation] -> IO ()
- run [] = return ()
- run [inv] = runProgramInvocation verbosity inv
- run (inv:invs) = do runProgramInvocation verbosity inv
- renameFile target tmpfile
- run invs
+ run [] = return ()
+ run [inv] = runProgramInvocation verbosity inv
+ run (inv : invs) = do
+ runProgramInvocation verbosity inv
+ renameFile target tmpfile
+ run invs
diff --git a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs
index 598f46b710633f05d0557e58cab0e0a0cc629ac1..8a477d3fdd4dfbdf272598c2e138968172543e3b 100644
--- a/Cabal/src/Distribution/Simple/Program/ResponseFile.hs
+++ b/Cabal/src/Distribution/Simple/Program/ResponseFile.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes #-}
+
+----------------------------------------------------------------------------
+
----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.ResponseFile
-- Copyright : (c) Sergey Vinokurov 2017
@@ -8,24 +12,26 @@
--
-- Maintainer : cabal-devel@haskell.org
-- Created : 23 July 2017
-----------------------------------------------------------------------------
-
module Distribution.Simple.Program.ResponseFile (withResponseFile) where
+import System.IO (TextEncoding, hClose, hPutStr, hSetEncoding)
import Prelude ()
-import System.IO (TextEncoding, hSetEncoding, hPutStr, hClose)
import Distribution.Compat.Prelude
-import Distribution.Simple.Utils (TempFileOptions, withTempFileEx, debug)
+import Distribution.Simple.Utils (TempFileOptions, debug, withTempFileEx)
import Distribution.Verbosity
withResponseFile
:: Verbosity
-> TempFileOptions
- -> FilePath -- ^ Working directory to create response file in.
- -> FilePath -- ^ Template for response file name.
- -> Maybe TextEncoding -- ^ Encoding to use for response file contents.
- -> [String] -- ^ Arguments to put into response file.
+ -> FilePath
+ -- ^ Working directory to create response file in.
+ -> FilePath
+ -- ^ Template for response file name.
+ -> Maybe TextEncoding
+ -- ^ Encoding to use for response file contents.
+ -> [String]
+ -- ^ Arguments to put into response file.
-> (FilePath -> IO a)
-> IO a
withResponseFile verbosity tmpFileOpts workDir fileNameTemplate encoding arguments f =
@@ -51,9 +57,9 @@ escapeResponseFileArg = reverse . foldl' escape []
escape :: String -> Char -> String
escape cs c =
case c of
- '\\' -> c:'\\':cs
- '\'' -> c:'\\':cs
- '"' -> c:'\\':cs
- _ | isSpace c -> c:'\\':cs
- | otherwise -> c:cs
-
+ '\\' -> c : '\\' : cs
+ '\'' -> c : '\\' : cs
+ '"' -> c : '\\' : cs
+ _
+ | isSpace c -> c : '\\' : cs
+ | otherwise -> c : cs
diff --git a/Cabal/src/Distribution/Simple/Program/Run.hs b/Cabal/src/Distribution/Simple/Program/Run.hs
index 66ab3ac82a7c6bcf431aecb9905823fe9f792cbf..bfc62896d91c68d257b7af8c94023ab2e3cdeb81 100644
--- a/Cabal/src/Distribution/Simple/Program/Run.hs
+++ b/Cabal/src/Distribution/Simple/Program/Run.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Run
-- Copyright : Duncan Coutts 2009
@@ -12,21 +13,18 @@
--
-- This module provides a data type for program invocations and functions to
-- run them.
-
-module Distribution.Simple.Program.Run (
- ProgramInvocation(..),
- IOEncoding(..),
- emptyProgramInvocation,
- simpleProgramInvocation,
- programInvocation,
- multiStageProgramInvocation,
-
- runProgramInvocation,
- getProgramInvocationOutput,
- getProgramInvocationLBS,
- getProgramInvocationOutputAndErrors,
-
- getEffectiveEnvironment,
+module Distribution.Simple.Program.Run
+ ( ProgramInvocation (..)
+ , IOEncoding (..)
+ , emptyProgramInvocation
+ , simpleProgramInvocation
+ , programInvocation
+ , multiStageProgramInvocation
+ , runProgramInvocation
+ , getProgramInvocationOutput
+ , getProgramInvocationLBS
+ , getProgramInvocationOutputAndErrors
+ , getEffectiveEnvironment
) where
import Distribution.Compat.Prelude
@@ -41,7 +39,7 @@ import Distribution.Verbosity
import System.FilePath (searchPathSeparator)
import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Map as Map
+import qualified Data.Map as Map
-- | Represents a specific invocation of a specific program.
--
@@ -49,176 +47,197 @@ import qualified Data.Map as Map
-- and actually doing it. This provides the opportunity to the caller to
-- adjust how the program will be called. These invocations can either be run
-- directly or turned into shell or batch scripts.
---
-data ProgramInvocation = ProgramInvocation {
- progInvokePath :: FilePath,
- progInvokeArgs :: [String],
- progInvokeEnv :: [(String, Maybe String)],
- -- Extra paths to add to PATH
- progInvokePathEnv :: [FilePath],
- progInvokeCwd :: Maybe FilePath,
- progInvokeInput :: Maybe IOData,
- progInvokeInputEncoding :: IOEncoding, -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.
- progInvokeOutputEncoding :: IOEncoding
- }
+data ProgramInvocation = ProgramInvocation
+ { progInvokePath :: FilePath
+ , progInvokeArgs :: [String]
+ , progInvokeEnv :: [(String, Maybe String)]
+ , -- Extra paths to add to PATH
+ progInvokePathEnv :: [FilePath]
+ , progInvokeCwd :: Maybe FilePath
+ , progInvokeInput :: Maybe IOData
+ , progInvokeInputEncoding :: IOEncoding
+ -- ^ TODO: remove this, make user decide when constructing 'progInvokeInput'.
+ , progInvokeOutputEncoding :: IOEncoding
+ }
-data IOEncoding = IOEncodingText -- locale mode text
- | IOEncodingUTF8 -- always utf8
+data IOEncoding
+ = IOEncodingText -- locale mode text
+ | IOEncodingUTF8 -- always utf8
encodeToIOData :: IOEncoding -> IOData -> IOData
-encodeToIOData _ iod@(IODataBinary _) = iod
-encodeToIOData IOEncodingText iod@(IODataText _) = iod
-encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str)
+encodeToIOData _ iod@(IODataBinary _) = iod
+encodeToIOData IOEncodingText iod@(IODataText _) = iod
+encodeToIOData IOEncodingUTF8 (IODataText str) = IODataBinary (toUTF8LBS str)
emptyProgramInvocation :: ProgramInvocation
emptyProgramInvocation =
- ProgramInvocation {
- progInvokePath = "",
- progInvokeArgs = [],
- progInvokeEnv = [],
- progInvokePathEnv = [],
- progInvokeCwd = Nothing,
- progInvokeInput = Nothing,
- progInvokeInputEncoding = IOEncodingText,
- progInvokeOutputEncoding = IOEncodingText
- }
+ ProgramInvocation
+ { progInvokePath = ""
+ , progInvokeArgs = []
+ , progInvokeEnv = []
+ , progInvokePathEnv = []
+ , progInvokeCwd = Nothing
+ , progInvokeInput = Nothing
+ , progInvokeInputEncoding = IOEncodingText
+ , progInvokeOutputEncoding = IOEncodingText
+ }
simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation
simpleProgramInvocation path args =
- emptyProgramInvocation {
- progInvokePath = path,
- progInvokeArgs = args
- }
+ emptyProgramInvocation
+ { progInvokePath = path
+ , progInvokeArgs = args
+ }
programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation
programInvocation prog args =
- emptyProgramInvocation {
- progInvokePath = programPath prog,
- progInvokeArgs = programDefaultArgs prog
- ++ args
- ++ programOverrideArgs prog,
- progInvokeEnv = programOverrideEnv prog
- }
-
+ emptyProgramInvocation
+ { progInvokePath = programPath prog
+ , progInvokeArgs =
+ programDefaultArgs prog
+ ++ args
+ ++ programOverrideArgs prog
+ , progInvokeEnv = programOverrideEnv prog
+ }
runProgramInvocation :: Verbosity -> ProgramInvocation -> IO ()
-runProgramInvocation verbosity
- ProgramInvocation {
- progInvokePath = path,
- progInvokeArgs = args,
- progInvokeEnv = [],
- progInvokePathEnv = [],
- progInvokeCwd = Nothing,
- progInvokeInput = Nothing
- } =
- rawSystemExit verbosity path args
-
-runProgramInvocation verbosity
- ProgramInvocation {
- progInvokePath = path,
- progInvokeArgs = args,
- progInvokeEnv = envOverrides,
- progInvokePathEnv = extraPath,
- progInvokeCwd = mcwd,
- progInvokeInput = Nothing
- } = do
+runProgramInvocation
+ verbosity
+ ProgramInvocation
+ { progInvokePath = path
+ , progInvokeArgs = args
+ , progInvokeEnv = []
+ , progInvokePathEnv = []
+ , progInvokeCwd = Nothing
+ , progInvokeInput = Nothing
+ } =
+ rawSystemExit verbosity path args
+runProgramInvocation
+ verbosity
+ ProgramInvocation
+ { progInvokePath = path
+ , progInvokeArgs = args
+ , progInvokeEnv = envOverrides
+ , progInvokePathEnv = extraPath
+ , progInvokeCwd = mcwd
+ , progInvokeInput = Nothing
+ } = do
pathOverride <- getExtraPathEnv envOverrides extraPath
menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
- maybeExit $ rawSystemIOWithEnv verbosity
- path args
- mcwd menv
- Nothing Nothing Nothing
-
-runProgramInvocation verbosity
- ProgramInvocation {
- progInvokePath = path,
- progInvokeArgs = args,
- progInvokeEnv = envOverrides,
- progInvokePathEnv = extraPath,
- progInvokeCwd = mcwd,
- progInvokeInput = Just inputStr,
- progInvokeInputEncoding = encoding
- } = do
+ maybeExit $
+ rawSystemIOWithEnv
+ verbosity
+ path
+ args
+ mcwd
+ menv
+ Nothing
+ Nothing
+ Nothing
+runProgramInvocation
+ verbosity
+ ProgramInvocation
+ { progInvokePath = path
+ , progInvokeArgs = args
+ , progInvokeEnv = envOverrides
+ , progInvokePathEnv = extraPath
+ , progInvokeCwd = mcwd
+ , progInvokeInput = Just inputStr
+ , progInvokeInputEncoding = encoding
+ } = do
pathOverride <- getExtraPathEnv envOverrides extraPath
menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
- (_, errors, exitCode) <- rawSystemStdInOut verbosity
- path args
- mcwd menv
- (Just input) IODataModeBinary
+ (_, errors, exitCode) <-
+ rawSystemStdInOut
+ verbosity
+ path
+ args
+ mcwd
+ menv
+ (Just input)
+ IODataModeBinary
when (exitCode /= ExitSuccess) $
- die' verbosity $ "'" ++ path ++ "' exited with an error:\n" ++ errors
- where
- input = encodeToIOData encoding inputStr
+ die' verbosity $
+ "'" ++ path ++ "' exited with an error:\n" ++ errors
+ where
+ input = encodeToIOData encoding inputStr
getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput verbosity inv = do
- (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv
- when (exitCode /= ExitSuccess) $
- die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors
- return output
+ (output, errors, exitCode) <- getProgramInvocationOutputAndErrors verbosity inv
+ when (exitCode /= ExitSuccess) $
+ die' verbosity $
+ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors
+ return output
getProgramInvocationLBS :: Verbosity -> ProgramInvocation -> IO LBS.ByteString
getProgramInvocationLBS verbosity inv = do
- (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary
- when (exitCode /= ExitSuccess) $
- die' verbosity $ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors
- return output
-
-getProgramInvocationOutputAndErrors :: Verbosity -> ProgramInvocation
- -> IO (String, String, ExitCode)
+ (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary
+ when (exitCode /= ExitSuccess) $
+ die' verbosity $
+ "'" ++ progInvokePath inv ++ "' exited with an error:\n" ++ errors
+ return output
+
+getProgramInvocationOutputAndErrors
+ :: Verbosity
+ -> ProgramInvocation
+ -> IO (String, String, ExitCode)
getProgramInvocationOutputAndErrors verbosity inv = case progInvokeOutputEncoding inv of
- IOEncodingText -> do
- (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText
- return (output, errors, exitCode)
- IOEncodingUTF8 -> do
- (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary
- return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode)
+ IOEncodingText -> do
+ (output, errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeText
+ return (output, errors, exitCode)
+ IOEncodingUTF8 -> do
+ (output', errors, exitCode) <- getProgramInvocationIODataAndErrors verbosity inv IODataModeBinary
+ return (normaliseLineEndings (fromUTF8LBS output'), errors, exitCode)
getProgramInvocationIODataAndErrors
- :: KnownIODataMode mode => Verbosity -> ProgramInvocation -> IODataMode mode
- -> IO (mode, String, ExitCode)
+ :: KnownIODataMode mode
+ => Verbosity
+ -> ProgramInvocation
+ -> IODataMode mode
+ -> IO (mode, String, ExitCode)
getProgramInvocationIODataAndErrors
verbosity
ProgramInvocation
- { progInvokePath = path
- , progInvokeArgs = args
- , progInvokeEnv = envOverrides
- , progInvokePathEnv = extraPath
- , progInvokeCwd = mcwd
- , progInvokeInput = minputStr
+ { progInvokePath = path
+ , progInvokeArgs = args
+ , progInvokeEnv = envOverrides
+ , progInvokePathEnv = extraPath
+ , progInvokeCwd = mcwd
+ , progInvokeInput = minputStr
, progInvokeInputEncoding = encoding
}
mode = do
pathOverride <- getExtraPathEnv envOverrides extraPath
menv <- getEffectiveEnvironment (envOverrides ++ pathOverride)
rawSystemStdInOut verbosity path args mcwd menv input mode
- where
- input = encodeToIOData encoding <$> minputStr
+ where
+ input = encodeToIOData encoding <$> minputStr
getExtraPathEnv :: [(String, Maybe String)] -> [FilePath] -> IO [(String, Maybe String)]
getExtraPathEnv _ [] = return []
getExtraPathEnv env extras = do
- mb_path <- case lookup "PATH" env of
- Just x -> return x
- Nothing -> lookupEnv "PATH"
- let extra = intercalate [searchPathSeparator] extras
- path' = case mb_path of
- Nothing -> extra
- Just path -> extra ++ searchPathSeparator : path
- return [("PATH", Just path')]
+ mb_path <- case lookup "PATH" env of
+ Just x -> return x
+ Nothing -> lookupEnv "PATH"
+ let extra = intercalate [searchPathSeparator] extras
+ path' = case mb_path of
+ Nothing -> extra
+ Just path -> extra ++ searchPathSeparator : path
+ return [("PATH", Just path')]
-- | Return the current environment extended with the given overrides.
-- If an entry is specified twice in @overrides@, the second entry takes
-- precedence.
---
-getEffectiveEnvironment :: [(String, Maybe String)]
- -> IO (Maybe [(String, String)])
-getEffectiveEnvironment [] = return Nothing
+getEffectiveEnvironment
+ :: [(String, Maybe String)]
+ -> IO (Maybe [(String, String)])
+getEffectiveEnvironment [] = return Nothing
getEffectiveEnvironment overrides =
- fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment
+ fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment
where
apply os env = foldl' (flip update) env os
- update (var, Nothing) = Map.delete var
+ update (var, Nothing) = Map.delete var
update (var, Just val) = Map.insert var val
-- | Like the unix xargs program. Useful for when we've got very long command
@@ -240,53 +259,51 @@ getEffectiveEnvironment overrides =
-- > $ middle args_2
-- > ...
-- > $ final args_n
---
multiStageProgramInvocation
:: ProgramInvocation
-> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
-> [String]
-> [ProgramInvocation]
multiStageProgramInvocation simple (initial, middle, final) args =
-
- let argSize inv = length (progInvokePath inv)
- + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv)
+ let argSize inv =
+ length (progInvokePath inv)
+ + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv)
fixedArgSize = maximum (map argSize [simple, initial, middle, final])
- chunkSize = maxCommandLineSize - fixedArgSize
-
+ chunkSize = maxCommandLineSize - fixedArgSize
in case splitChunks chunkSize args of
- [] -> [ simple ]
-
- [c] -> [ simple `appendArgs` c ]
-
- (c:c2:cs) | (xs, x) <- unsnocNE (c2:|cs) ->
- [ initial `appendArgs` c ]
- ++ [ middle `appendArgs` c'| c' <- xs ]
- ++ [ final `appendArgs` x ]
-
+ [] -> [simple]
+ [c] -> [simple `appendArgs` c]
+ (c : c2 : cs)
+ | (xs, x) <- unsnocNE (c2 :| cs) ->
+ [initial `appendArgs` c]
+ ++ [middle `appendArgs` c' | c' <- xs]
+ ++ [final `appendArgs` x]
where
appendArgs :: ProgramInvocation -> [String] -> ProgramInvocation
- inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as }
+ inv `appendArgs` as = inv{progInvokeArgs = progInvokeArgs inv ++ as}
splitChunks :: Int -> [[a]] -> [[[a]]]
splitChunks len = unfoldr $ \s ->
- if null s then Nothing
- else Just (chunk len s)
+ if null s
+ then Nothing
+ else Just (chunk len s)
chunk :: Int -> [[a]] -> ([[a]], [[a]])
- chunk len (s:_) | length s >= len = error toolong
- chunk len ss = chunk' [] len ss
+ chunk len (s : _) | length s >= len = error toolong
+ chunk len ss = chunk' [] len ss
chunk' :: [[a]] -> Int -> [[a]] -> ([[a]], [[a]])
- chunk' acc len (s:ss)
- | len' < len = chunk' (s:acc) (len-len'-1) ss
- where len' = length s
- chunk' acc _ ss = (reverse acc, ss)
-
- toolong = "multiStageProgramInvocation: a single program arg is larger "
- ++ "than the maximum command line length!"
+ chunk' acc len (s : ss)
+ | len' < len = chunk' (s : acc) (len - len' - 1) ss
+ where
+ len' = length s
+ chunk' acc _ ss = (reverse acc, ss)
+ toolong =
+ "multiStageProgramInvocation: a single program arg is larger "
+ ++ "than the maximum command line length!"
---FIXME: discover this at configure time or runtime on unix
+-- FIXME: discover this at configure time or runtime on unix
-- The value is 32k on Windows and posix specifies a minimum of 4k
-- but all sensible unixes use more than 4k.
-- we could use getSysVar ArgumentLimit but that's in the unix lib
diff --git a/Cabal/src/Distribution/Simple/Program/Script.hs b/Cabal/src/Distribution/Simple/Program/Script.hs
index 2b83f9796d4a2c70b218372751b4b20d033f101a..f89db34306e2c7bfb2b7afa3aa4575ee65b4a2b3 100644
--- a/Cabal/src/Distribution/Simple/Program/Script.hs
+++ b/Cabal/src/Distribution/Simple/Program/Script.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE GADTs #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Script
-- Copyright : Duncan Coutts 2009
@@ -9,16 +11,14 @@
--
-- This module provides an library interface to the @hc-pkg@ program.
-- Currently only GHC and LHC have hc-pkg programs.
-
-module Distribution.Simple.Program.Script (
-
- invocationAsSystemScript,
- invocationAsShellScript,
- invocationAsBatchFile,
+module Distribution.Simple.Program.Script
+ ( invocationAsSystemScript
+ , invocationAsShellScript
+ , invocationAsBatchFile
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Simple.Program.Run
import Distribution.Simple.Utils
@@ -26,89 +26,89 @@ import Distribution.System
-- | Generate a system script, either POSIX shell script or Windows batch file
-- as appropriate for the given system.
---
invocationAsSystemScript :: OS -> ProgramInvocation -> String
invocationAsSystemScript Windows = invocationAsBatchFile
-invocationAsSystemScript _ = invocationAsShellScript
-
+invocationAsSystemScript _ = invocationAsShellScript
-- | Generate a POSIX shell script that invokes a program.
---
invocationAsShellScript :: ProgramInvocation -> String
invocationAsShellScript
- ProgramInvocation {
- progInvokePath = path,
- progInvokeArgs = args,
- progInvokeEnv = envExtra,
- progInvokeCwd = mcwd,
- progInvokeInput = minput
- } = unlines $
- [ "#!/bin/sh" ]
- ++ concatMap setEnv envExtra
- ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]
- ++ [ (case minput of
- Nothing -> ""
- Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | ")
- ++ unwords (map quote $ path : args) ++ " \"$@\""]
-
- where
- setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var]
- setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]
-
- quote :: String -> String
- quote s = "'" ++ escape s ++ "'"
-
- escape [] = []
- escape ('\'':cs) = "'\\''" ++ escape cs
- escape (c :cs) = c : escape cs
+ ProgramInvocation
+ { progInvokePath = path
+ , progInvokeArgs = args
+ , progInvokeEnv = envExtra
+ , progInvokeCwd = mcwd
+ , progInvokeInput = minput
+ } =
+ unlines $
+ ["#!/bin/sh"]
+ ++ concatMap setEnv envExtra
+ ++ ["cd " ++ quote cwd | cwd <- maybeToList mcwd]
+ ++ [ ( case minput of
+ Nothing -> ""
+ Just input -> "printf '%s' " ++ quote (iodataToText input) ++ " | "
+ )
+ ++ unwords (map quote $ path : args)
+ ++ " \"$@\""
+ ]
+ where
+ setEnv (var, Nothing) = ["unset " ++ var, "export " ++ var]
+ setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]
+
+ quote :: String -> String
+ quote s = "'" ++ escape s ++ "'"
+
+ escape [] = []
+ escape ('\'' : cs) = "'\\''" ++ escape cs
+ escape (c : cs) = c : escape cs
iodataToText :: IOData -> String
-iodataToText (IODataText str) = str
+iodataToText (IODataText str) = str
iodataToText (IODataBinary lbs) = fromUTF8LBS lbs
-
-- | Generate a Windows batch file that invokes a program.
---
invocationAsBatchFile :: ProgramInvocation -> String
invocationAsBatchFile
- ProgramInvocation {
- progInvokePath = path,
- progInvokeArgs = args,
- progInvokeEnv = envExtra,
- progInvokeCwd = mcwd,
- progInvokeInput = minput
- } = unlines $
- [ "@echo off" ]
- ++ map setEnv envExtra
- ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ]
- ++ case minput of
- Nothing ->
- [ path ++ concatMap (' ':) args ]
-
- Just input ->
- [ "(" ]
- ++ [ "echo " ++ escape line | line <- lines $ iodataToText input ]
- ++ [ ") | "
- ++ "\"" ++ path ++ "\""
- ++ concatMap (\arg -> ' ':quote arg) args ]
-
- where
- setEnv (var, Nothing) = "set " ++ var ++ "="
- setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val
-
- quote :: String -> String
- quote s = "\"" ++ escapeQ s ++ "\""
-
- escapeQ [] = []
- escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs
- escapeQ (c :cs) = c : escapeQ cs
-
- escape [] = []
- escape ('|':cs) = "^|" ++ escape cs
- escape ('<':cs) = "^<" ++ escape cs
- escape ('>':cs) = "^>" ++ escape cs
- escape ('&':cs) = "^&" ++ escape cs
- escape ('(':cs) = "^(" ++ escape cs
- escape (')':cs) = "^)" ++ escape cs
- escape ('^':cs) = "^^" ++ escape cs
- escape (c :cs) = c : escape cs
+ ProgramInvocation
+ { progInvokePath = path
+ , progInvokeArgs = args
+ , progInvokeEnv = envExtra
+ , progInvokeCwd = mcwd
+ , progInvokeInput = minput
+ } =
+ unlines $
+ ["@echo off"]
+ ++ map setEnv envExtra
+ ++ ["cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd]
+ ++ case minput of
+ Nothing ->
+ [path ++ concatMap (' ' :) args]
+ Just input ->
+ ["("]
+ ++ ["echo " ++ escape line | line <- lines $ iodataToText input]
+ ++ [ ") | "
+ ++ "\""
+ ++ path
+ ++ "\""
+ ++ concatMap (\arg -> ' ' : quote arg) args
+ ]
+ where
+ setEnv (var, Nothing) = "set " ++ var ++ "="
+ setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val
+
+ quote :: String -> String
+ quote s = "\"" ++ escapeQ s ++ "\""
+
+ escapeQ [] = []
+ escapeQ ('"' : cs) = "\"\"\"" ++ escapeQ cs
+ escapeQ (c : cs) = c : escapeQ cs
+
+ escape [] = []
+ escape ('|' : cs) = "^|" ++ escape cs
+ escape ('<' : cs) = "^<" ++ escape cs
+ escape ('>' : cs) = "^>" ++ escape cs
+ escape ('&' : cs) = "^&" ++ escape cs
+ escape ('(' : cs) = "^(" ++ escape cs
+ escape (')' : cs) = "^)" ++ escape cs
+ escape ('^' : cs) = "^^" ++ escape cs
+ escape (c : cs) = c : escape cs
diff --git a/Cabal/src/Distribution/Simple/Program/Strip.hs b/Cabal/src/Distribution/Simple/Program/Strip.hs
index 6557d8356b92867cee436afcdea04a4fec43c7ed..bb43e5ed47d89544f44e5fa8490e757d1fd4c637 100644
--- a/Cabal/src/Distribution/Simple/Program/Strip.hs
+++ b/Cabal/src/Distribution/Simple/Program/Strip.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Strip
--
@@ -9,12 +10,11 @@
-- Portability : portable
--
-- This module provides an library interface to the @strip@ program.
-
module Distribution.Simple.Program.Strip (stripLib, stripExe)
- where
+where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Simple.Program
import Distribution.Simple.Utils
@@ -22,54 +22,62 @@ import Distribution.System
import Distribution.Verbosity
import Distribution.Version
-import System.FilePath (takeBaseName)
+import System.FilePath (takeBaseName)
runStrip :: Verbosity -> ProgramDb -> FilePath -> [String] -> IO ()
runStrip verbosity progDb path args =
case lookupProgram stripProgram progDb of
Just strip -> runProgram verbosity strip (args ++ [path])
- Nothing -> unless (buildOS == Windows) $
- -- Don't bother warning on windows, we don't expect them to
- -- have the strip program anyway.
- warn verbosity $ "Unable to strip executable or library '"
- ++ (takeBaseName path)
- ++ "' (missing the 'strip' program)"
+ Nothing ->
+ unless (buildOS == Windows) $
+ -- Don't bother warning on windows, we don't expect them to
+ -- have the strip program anyway.
+ warn verbosity $
+ "Unable to strip executable or library '"
+ ++ (takeBaseName path)
+ ++ "' (missing the 'strip' program)"
stripExe :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()
stripExe verbosity (Platform _arch os) progdb path =
runStrip verbosity progdb path args
where
args = case os of
- OSX -> ["-x"] -- By default, stripping the ghc binary on at least
- -- some OS X installations causes:
- -- HSbase-3.0.o: unknown symbol `_environ'"
- -- The -x flag fixes that.
- _ -> []
+ OSX -> ["-x"] -- By default, stripping the ghc binary on at least
+ -- some OS X installations causes:
+ -- HSbase-3.0.o: unknown symbol `_environ'"
+ -- The -x flag fixes that.
+ _ -> []
stripLib :: Verbosity -> Platform -> ProgramDb -> FilePath -> IO ()
stripLib verbosity (Platform arch os) progdb path = do
case os of
- OSX -> -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or
- -- Solaris. See #1630.
- return ()
+ OSX ->
+ -- '--strip-unneeded' is not supported on OS X, iOS, AIX, or
+ -- Solaris. See #1630.
+ return ()
IOS -> return ()
AIX -> return ()
Solaris -> return ()
- Windows -> -- Stripping triggers a bug in 'strip.exe' for
- -- libraries with lots identically named modules. See
- -- #1784.
- return()
- Linux | arch == I386 ->
- -- Versions of 'strip' on 32-bit Linux older than 2.18 are
- -- broken. See #2339.
- let okVersion = orLaterVersion (mkVersion [2,18])
- in case programVersion =<< lookupProgram stripProgram progdb of
- Just v | withinRange v okVersion ->
- runStrip verbosity progdb path args
- _ -> warn verbosity $ "Unable to strip library '"
- ++ (takeBaseName path)
- ++ "' (version of 'strip' too old; "
- ++ "requires >= 2.18 on 32-bit Linux)"
- _ -> runStrip verbosity progdb path args
+ Windows ->
+ -- Stripping triggers a bug in 'strip.exe' for
+ -- libraries with lots identically named modules. See
+ -- #1784.
+ return ()
+ Linux
+ | arch == I386 ->
+ -- Versions of 'strip' on 32-bit Linux older than 2.18 are
+ -- broken. See #2339.
+ let okVersion = orLaterVersion (mkVersion [2, 18])
+ in case programVersion =<< lookupProgram stripProgram progdb of
+ Just v
+ | withinRange v okVersion ->
+ runStrip verbosity progdb path args
+ _ ->
+ warn verbosity $
+ "Unable to strip library '"
+ ++ (takeBaseName path)
+ ++ "' (version of 'strip' too old; "
+ ++ "requires >= 2.18 on 32-bit Linux)"
+ _ -> runStrip verbosity progdb path args
where
args = ["--strip-unneeded"]
diff --git a/Cabal/src/Distribution/Simple/Program/Types.hs b/Cabal/src/Distribution/Simple/Program/Types.hs
index 4078f05018514f128f5e837e835336defecd9031..2186b23fc0143adb1fda64113bf393e22efadc4e 100644
--- a/Cabal/src/Distribution/Simple/Program/Types.hs
+++ b/Cabal/src/Distribution/Simple/Program/Types.hs
@@ -2,9 +2,9 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Program.Types
-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009
@@ -19,30 +19,29 @@
-- args). Configuring a program involves finding its location and if necessary
-- finding its version. There's reasonable default behavior for trying to find
-- \"foo\" in PATH, being able to override its location, etc.
---
-module Distribution.Simple.Program.Types (
- -- * Program and functions for constructing them
- Program(..),
- ProgramSearchPath,
- ProgramSearchPathEntry(..),
- simpleProgram,
+module Distribution.Simple.Program.Types
+ ( -- * Program and functions for constructing them
+ Program (..)
+ , ProgramSearchPath
+ , ProgramSearchPathEntry (..)
+ , simpleProgram
-- * Configured program and related functions
- ConfiguredProgram(..),
- programPath,
- suppressOverrideArgs,
- ProgArg,
- ProgramLocation(..),
- simpleConfiguredProgram,
+ , ConfiguredProgram (..)
+ , programPath
+ , suppressOverrideArgs
+ , ProgArg
+ , ProgramLocation (..)
+ , simpleConfiguredProgram
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.PackageDescription
import Distribution.Simple.Program.Find
-import Distribution.Version
import Distribution.Verbosity
+import Distribution.Version
import qualified Data.Map as Map
@@ -50,38 +49,36 @@ import qualified Data.Map as Map
--
-- Note: rather than constructing this directly, start with 'simpleProgram' and
-- override any extra fields.
---
-data Program = Program {
- -- | The simple name of the program, eg. ghc
- programName :: String,
-
- -- | A function to search for the program if its location was not
- -- specified by the user. Usually this will just be a call to
- -- 'findProgramOnSearchPath'.
- --
- -- It is supplied with the prevailing search path which will typically
- -- just be used as-is, but can be extended or ignored as needed.
- --
- -- For the purpose of change monitoring, in addition to the location
- -- where the program was found, it returns all the other places that
- -- were tried.
- --
- programFindLocation :: Verbosity -> ProgramSearchPath
- -> IO (Maybe (FilePath, [FilePath])),
-
- -- | Try to find the version of the program. For many programs this is
- -- not possible or is not necessary so it's OK to return Nothing.
- programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),
-
- -- | A function to do any additional configuration after we have
- -- located the program (and perhaps identified its version). For example
- -- it could add args, or environment vars.
- programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram,
- -- | A function that filters any arguments that don't impact the output
- -- from a commandline. Used to limit the volatility of dependency hashes
- -- when using new-build.
- programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String]
- }
+data Program = Program
+ { programName :: String
+ -- ^ The simple name of the program, eg. ghc
+ , programFindLocation
+ :: Verbosity
+ -> ProgramSearchPath
+ -> IO (Maybe (FilePath, [FilePath]))
+ -- ^ A function to search for the program if its location was not
+ -- specified by the user. Usually this will just be a call to
+ -- 'findProgramOnSearchPath'.
+ --
+ -- It is supplied with the prevailing search path which will typically
+ -- just be used as-is, but can be extended or ignored as needed.
+ --
+ -- For the purpose of change monitoring, in addition to the location
+ -- where the program was found, it returns all the other places that
+ -- were tried.
+ , programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version)
+ -- ^ Try to find the version of the program. For many programs this is
+ -- not possible or is not necessary so it's OK to return Nothing.
+ , programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+ -- ^ A function to do any additional configuration after we have
+ -- located the program (and perhaps identified its version). For example
+ -- it could add args, or environment vars.
+ , programNormaliseArgs :: Maybe Version -> PackageDescription -> [String] -> [String]
+ -- ^ A function that filters any arguments that don't impact the output
+ -- from a commandline. Used to limit the volatility of dependency hashes
+ -- when using new-build.
+ }
+
instance Show Program where
show (Program name _ _ _ _) = "Program: " ++ name
@@ -92,45 +89,36 @@ type ProgArg = String
-- These are usually made by configuring a 'Program', but if you have to
-- construct one directly then start with 'simpleConfiguredProgram' and
-- override any extra fields.
---
-data ConfiguredProgram = ConfiguredProgram {
- -- | Just the name again
- programId :: String,
-
- -- | The version of this program, if it is known.
- programVersion :: Maybe Version,
-
- -- | Default command-line args for this program.
- -- These flags will appear first on the command line, so they can be
- -- overridden by subsequent flags.
- programDefaultArgs :: [String],
-
- -- | Override command-line args for this program.
- -- These flags will appear last on the command line, so they override
- -- all earlier flags.
- programOverrideArgs :: [String],
-
- -- | Override environment variables for this program.
- -- These env vars will extend\/override the prevailing environment of
- -- the current to form the environment for the new process.
- programOverrideEnv :: [(String, Maybe String)],
-
- -- | A key-value map listing various properties of the program, useful
- -- for feature detection. Populated during the configuration step, key
- -- names depend on the specific program.
- programProperties :: Map.Map String String,
-
- -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@
- programLocation :: ProgramLocation,
-
- -- | In addition to the 'programLocation' where the program was found,
- -- these are additional locations that were looked at. The combination
- -- of ths found location and these not-found locations can be used to
- -- monitor to detect when the re-configuring the program might give a
- -- different result (e.g. found in a different location).
- --
- programMonitorFiles :: [FilePath]
- }
+data ConfiguredProgram = ConfiguredProgram
+ { programId :: String
+ -- ^ Just the name again
+ , programVersion :: Maybe Version
+ -- ^ The version of this program, if it is known.
+ , programDefaultArgs :: [String]
+ -- ^ Default command-line args for this program.
+ -- These flags will appear first on the command line, so they can be
+ -- overridden by subsequent flags.
+ , programOverrideArgs :: [String]
+ -- ^ Override command-line args for this program.
+ -- These flags will appear last on the command line, so they override
+ -- all earlier flags.
+ , programOverrideEnv :: [(String, Maybe String)]
+ -- ^ Override environment variables for this program.
+ -- These env vars will extend\/override the prevailing environment of
+ -- the current to form the environment for the new process.
+ , programProperties :: Map.Map String String
+ -- ^ A key-value map listing various properties of the program, useful
+ -- for feature detection. Populated during the configuration step, key
+ -- names depend on the specific program.
+ , programLocation :: ProgramLocation
+ -- ^ Location of the program. eg. @\/usr\/bin\/ghc-6.4@
+ , programMonitorFiles :: [FilePath]
+ -- ^ In addition to the 'programLocation' where the program was found,
+ -- these are additional locations that were looked at. The combination
+ -- of ths found location and these not-found locations can be used to
+ -- monitor to detect when the re-configuring the program might give a
+ -- different result (e.g. found in a different location).
+ }
deriving (Eq, Generic, Read, Show, Typeable)
instance Binary ConfiguredProgram
@@ -139,12 +127,12 @@ instance Structured ConfiguredProgram
-- | Where a program was found. Also tells us whether it's specified by user or
-- not. This includes not just the path, but the program as well.
data ProgramLocation
- = UserSpecified { locationPath :: FilePath }
- -- ^The user gave the path to this program,
- -- eg. --ghc-path=\/usr\/bin\/ghc-6.6
- | FoundOnSystem { locationPath :: FilePath }
- -- ^The program was found automatically.
- deriving (Eq, Generic, Read, Show, Typeable)
+ = -- | The user gave the path to this program,
+ -- eg. --ghc-path=\/usr\/bin\/ghc-6.6
+ UserSpecified {locationPath :: FilePath}
+ | -- | The program was found automatically.
+ FoundOnSystem {locationPath :: FilePath}
+ deriving (Eq, Generic, Read, Show, Typeable)
instance Binary ProgramLocation
instance Structured ProgramLocation
@@ -155,7 +143,7 @@ programPath = locationPath . programLocation
-- | Suppress any extra arguments added by the user.
suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram
-suppressOverrideArgs prog = prog { programOverrideArgs = [] }
+suppressOverrideArgs prog = prog{programOverrideArgs = []}
-- | Make a simple named program.
--
@@ -163,28 +151,28 @@ suppressOverrideArgs prog = prog { programOverrideArgs = [] }
-- version name. You can override these behaviours if necessary, eg:
--
-- > (simpleProgram "foo") { programFindLocation = ... , programFindVersion ... }
---
simpleProgram :: String -> Program
-simpleProgram name = Program {
- programName = name,
- programFindLocation = \v p -> findProgramOnSearchPath v p name,
- programFindVersion = \_ _ -> return Nothing,
- programPostConf = \_ p -> return p,
- programNormaliseArgs = \_ _ -> id
- }
+simpleProgram name =
+ Program
+ { programName = name
+ , programFindLocation = \v p -> findProgramOnSearchPath v p name
+ , programFindVersion = \_ _ -> return Nothing
+ , programPostConf = \_ p -> return p
+ , programNormaliseArgs = \_ _ -> id
+ }
-- | Make a simple 'ConfiguredProgram'.
--
-- > simpleConfiguredProgram "foo" (FoundOnSystem path)
---
simpleConfiguredProgram :: String -> ProgramLocation -> ConfiguredProgram
-simpleConfiguredProgram name loc = ConfiguredProgram {
- programId = name,
- programVersion = Nothing,
- programDefaultArgs = [],
- programOverrideArgs = [],
- programOverrideEnv = [],
- programProperties = Map.empty,
- programLocation = loc,
- programMonitorFiles = [] -- did not look in any other locations
- }
+simpleConfiguredProgram name loc =
+ ConfiguredProgram
+ { programId = name
+ , programVersion = Nothing
+ , programDefaultArgs = []
+ , programOverrideArgs = []
+ , programOverrideEnv = []
+ , programProperties = Map.empty
+ , programLocation = loc
+ , programMonitorFiles = [] -- did not look in any other locations
+ }
diff --git a/Cabal/src/Distribution/Simple/Register.hs b/Cabal/src/Distribution/Simple/Register.hs
index f71f340f44bff6c61e36cff17fc8b84e7e6c1eae..fc6075dc357ec91a30d04e5220b3eb99baac7b25 100644
--- a/Cabal/src/Distribution/Simple/Register.hs
+++ b/Cabal/src/Distribution/Simple/Register.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Register
-- Copyright : Isaac Jones 2003-2004
@@ -25,164 +26,194 @@
-- This module does not delegate anything to the per-compiler modules but just
-- mixes it all in this module, which is rather unsatisfactory. The script
-- generation and the unregister feature are not well used or tested.
-
-module Distribution.Simple.Register (
- register,
- unregister,
-
- internalPackageDBPath,
-
- initPackageDB,
- doesPackageDBExist,
- createPackageDB,
- deletePackageDB,
-
- abiHash,
- invokeHcPkg,
- registerPackage,
- HcPkg.RegisterOptions(..),
- HcPkg.defaultRegisterOptions,
- generateRegistrationInfo,
- inplaceInstalledPackageInfo,
- absoluteInstalledPackageInfo,
- generalInstalledPackageInfo,
+module Distribution.Simple.Register
+ ( register
+ , unregister
+ , internalPackageDBPath
+ , initPackageDB
+ , doesPackageDBExist
+ , createPackageDB
+ , deletePackageDB
+ , abiHash
+ , invokeHcPkg
+ , registerPackage
+ , HcPkg.RegisterOptions (..)
+ , HcPkg.defaultRegisterOptions
+ , generateRegistrationInfo
+ , inplaceInstalledPackageInfo
+ , absoluteInstalledPackageInfo
+ , generalInstalledPackageInfo
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.TargetInfo
-import Distribution.Types.LocalBuildInfo
import Distribution.Types.ComponentLocalBuildInfo
+import Distribution.Types.LocalBuildInfo
+import Distribution.Types.TargetInfo
-import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.BuildPaths
import Distribution.Simple.BuildTarget
+import Distribution.Simple.LocalBuildInfo
-import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
-import qualified Distribution.Simple.UHC as UHC
import qualified Distribution.Simple.HaskellSuite as HaskellSuite
import qualified Distribution.Simple.PackageIndex as Index
+import qualified Distribution.Simple.UHC as UHC
import Distribution.Backpack.DescribeUnitId
+import Distribution.Compat.Graph (IsNode (nodeKey))
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import qualified Distribution.InstalledPackageInfo as IPI
+import Distribution.License (licenseFromSPDX, licenseToSPDX)
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.Pretty
import Distribution.Simple.Compiler
+import Distribution.Simple.Flag
import Distribution.Simple.Program
-import Distribution.Simple.Program.Script
import qualified Distribution.Simple.Program.HcPkg as HcPkg
-import Distribution.Simple.Flag
+import Distribution.Simple.Program.Script
import Distribution.Simple.Setup.Register
-import Distribution.PackageDescription
-import Distribution.Package
-import Distribution.License (licenseToSPDX, licenseFromSPDX)
-import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import Distribution.Simple.Utils
-import Distribution.Utils.MapAccum
import Distribution.System
-import Distribution.Pretty
+import Distribution.Utils.MapAccum
import Distribution.Verbosity as Verbosity
import Distribution.Version
-import Distribution.Compat.Graph (IsNode(nodeKey))
-import System.FilePath ((</>), (<.>), isAbsolute)
import System.Directory
+import System.FilePath (isAbsolute, (<.>), (</>))
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-- -----------------------------------------------------------------------------
-- Registration
-register :: PackageDescription -> LocalBuildInfo
- -> RegisterFlags -- ^Install in the user's database?; verbose
- -> IO ()
+register
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> RegisterFlags
+ -- ^ Install in the user's database?; verbose
+ -> IO ()
register pkg_descr lbi0 flags =
- -- Duncan originally asked for us to not register/install files
- -- when there was no public library. But with per-component
- -- configure, we legitimately need to install internal libraries
- -- so that we can get them. So just unconditionally install.
- doRegister
- where
- doRegister = do
- targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags)
-
- -- It's important to register in build order, because ghc-pkg
- -- will complain if a dependency is not registered.
- let componentsToRegister
- = neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets)
-
- (_, ipi_mbs) <-
+ -- Duncan originally asked for us to not register/install files
+ -- when there was no public library. But with per-component
+ -- configure, we legitimately need to install internal libraries
+ -- so that we can get them. So just unconditionally install.
+ doRegister
+ where
+ doRegister = do
+ targets <- readTargetInfos verbosity pkg_descr lbi0 (regArgs flags)
+
+ -- It's important to register in build order, because ghc-pkg
+ -- will complain if a dependency is not registered.
+ let componentsToRegister =
+ neededTargetsInBuildOrder' pkg_descr lbi0 (map nodeKey targets)
+
+ (_, ipi_mbs) <-
mapAccumM `flip` installedPkgs lbi0 `flip` componentsToRegister $ \index tgt ->
- case targetComponent tgt of
- CLib lib -> do
- let clbi = targetCLBI tgt
- lbi = lbi0 { installedPkgs = index }
- ipi <- generateOne pkg_descr lib lbi clbi flags
- return (Index.insert ipi index, Just ipi)
- _ -> return (index, Nothing)
-
- registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs)
- where
- verbosity = fromFlag (regVerbosity flags)
-
-generateOne :: PackageDescription -> Library -> LocalBuildInfo -> ComponentLocalBuildInfo
- -> RegisterFlags
- -> IO InstalledPackageInfo
-generateOne pkg lib lbi clbi regFlags
- = do
- absPackageDBs <- absolutePackageDBPaths packageDbs
- installedPkgInfo <- generateRegistrationInfo
- verbosity pkg lib lbi clbi inplace reloc distPref
- (registrationPackageDB absPackageDBs)
+ case targetComponent tgt of
+ CLib lib -> do
+ let clbi = targetCLBI tgt
+ lbi = lbi0{installedPkgs = index}
+ ipi <- generateOne pkg_descr lib lbi clbi flags
+ return (Index.insert ipi index, Just ipi)
+ _ -> return (index, Nothing)
+
+ registerAll pkg_descr lbi0 flags (catMaybes ipi_mbs)
+ where
+ verbosity = fromFlag (regVerbosity flags)
+
+generateOne
+ :: PackageDescription
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> RegisterFlags
+ -> IO InstalledPackageInfo
+generateOne pkg lib lbi clbi regFlags =
+ do
+ absPackageDBs <- absolutePackageDBPaths packageDbs
+ installedPkgInfo <-
+ generateRegistrationInfo
+ verbosity
+ pkg
+ lib
+ lbi
+ clbi
+ inplace
+ reloc
+ distPref
+ (registrationPackageDB absPackageDBs)
info verbosity (IPI.showInstalledPackageInfo installedPkgInfo)
return installedPkgInfo
where
- inplace = fromFlag (regInPlace regFlags)
- reloc = relocatable lbi
+ inplace = fromFlag (regInPlace regFlags)
+ reloc = relocatable lbi
-- FIXME: there's really no guarantee this will work.
-- registering into a totally different db stack can
-- fail if dependencies cannot be satisfied.
- packageDbs = nub $ withPackageDB lbi
- ++ maybeToList (flagToMaybe (regPackageDB regFlags))
- distPref = fromFlag (regDistPref regFlags)
+ packageDbs =
+ nub $
+ withPackageDB lbi
+ ++ maybeToList (flagToMaybe (regPackageDB regFlags))
+ distPref = fromFlag (regDistPref regFlags)
verbosity = fromFlag (regVerbosity regFlags)
-registerAll :: PackageDescription -> LocalBuildInfo -> RegisterFlags
- -> [InstalledPackageInfo]
- -> IO ()
-registerAll pkg lbi regFlags ipis
- = do
+registerAll
+ :: PackageDescription
+ -> LocalBuildInfo
+ -> RegisterFlags
+ -> [InstalledPackageInfo]
+ -> IO ()
+registerAll pkg lbi regFlags ipis =
+ do
when (fromFlag (regPrintId regFlags)) $ do
for_ ipis $ \installedPkgInfo ->
-- Only print the public library's IPI
- when (packageId installedPkgInfo == packageId pkg
- && IPI.sourceLibName installedPkgInfo == LMainLibName) $
- putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo))
+ when
+ ( packageId installedPkgInfo == packageId pkg
+ && IPI.sourceLibName installedPkgInfo == LMainLibName
+ )
+ $ putStrLn (prettyShow (IPI.installedUnitId installedPkgInfo))
- -- Three different modes:
+ -- Three different modes:
case () of
- _ | modeGenerateRegFile -> writeRegistrationFileOrDirectory
- | modeGenerateRegScript -> writeRegisterScript
- | otherwise -> do
- for_ ipis $ \ipi -> do
- setupMessage' verbosity "Registering" (packageId pkg)
- (CLibName (IPI.sourceLibName ipi))
- (Just (IPI.instantiatedWith ipi))
- registerPackage verbosity (compiler lbi) (withPrograms lbi)
- packageDbs ipi HcPkg.defaultRegisterOptions
-
+ _
+ | modeGenerateRegFile -> writeRegistrationFileOrDirectory
+ | modeGenerateRegScript -> writeRegisterScript
+ | otherwise -> do
+ for_ ipis $ \ipi -> do
+ setupMessage'
+ verbosity
+ "Registering"
+ (packageId pkg)
+ (CLibName (IPI.sourceLibName ipi))
+ (Just (IPI.instantiatedWith ipi))
+ registerPackage
+ verbosity
+ (compiler lbi)
+ (withPrograms lbi)
+ packageDbs
+ ipi
+ HcPkg.defaultRegisterOptions
where
modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags))
- regFile = fromMaybe (prettyShow (packageId pkg) <.> "conf")
- (fromFlag (regGenPkgConf regFlags))
+ regFile =
+ fromMaybe
+ (prettyShow (packageId pkg) <.> "conf")
+ (fromFlag (regGenPkgConf regFlags))
modeGenerateRegScript = fromFlag (regGenScript regFlags)
-- FIXME: there's really no guarantee this will work.
-- registering into a totally different db stack can
-- fail if dependencies cannot be satisfied.
- packageDbs = nub $ withPackageDB lbi
- ++ maybeToList (flagToMaybe (regPackageDB regFlags))
+ packageDbs =
+ nub $
+ withPackageDB lbi
+ ++ maybeToList (flagToMaybe (regPackageDB regFlags))
verbosity = fromFlag (regVerbosity regFlags)
writeRegistrationFileOrDirectory = do
@@ -197,172 +228,247 @@ registerAll pkg lbi regFlags ipis
createDirectory regFile
let num_ipis = length ipis
lpad m xs = replicate (m - length ys) '0' ++ ys
- where ys = take m xs
+ where
+ ys = take m xs
number i = lpad (length (show num_ipis)) (show i)
- for_ (zip ([1..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->
- writeUTF8File (regFile </> (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo)))
- (IPI.showInstalledPackageInfo installedPkgInfo)
+ for_ (zip ([1 ..] :: [Int]) ipis) $ \(i, installedPkgInfo) ->
+ writeUTF8File
+ (regFile </> (number i ++ "-" ++ prettyShow (IPI.installedUnitId installedPkgInfo)))
+ (IPI.showInstalledPackageInfo installedPkgInfo)
writeRegisterScript =
case compilerFlavor (compiler lbi) of
UHC -> notice verbosity "Registration scripts not needed for uhc"
- _ -> withHcPkg verbosity
- "Registration scripts are not implemented for this compiler"
- (compiler lbi) (withPrograms lbi)
- (writeHcPkgRegisterScript verbosity ipis packageDbs)
-
-
-generateRegistrationInfo :: Verbosity
- -> PackageDescription
- -> Library
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> Bool
- -> Bool
- -> FilePath
- -> PackageDB
- -> IO InstalledPackageInfo
+ _ ->
+ withHcPkg
+ verbosity
+ "Registration scripts are not implemented for this compiler"
+ (compiler lbi)
+ (withPrograms lbi)
+ (writeHcPkgRegisterScript verbosity ipis packageDbs)
+
+generateRegistrationInfo
+ :: Verbosity
+ -> PackageDescription
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> Bool
+ -> Bool
+ -> FilePath
+ -> PackageDB
+ -> IO InstalledPackageInfo
generateRegistrationInfo verbosity pkg lib lbi clbi inplace reloc distPref packageDb = do
- --TODO: eliminate pwd!
+ -- TODO: eliminate pwd!
pwd <- getCurrentDirectory
installedPkgInfo <-
if inplace
- -- NB: With an inplace installation, the user may run './Setup
+ then -- NB: With an inplace installation, the user may run './Setup
-- build' to update the library files, without reregistering.
-- In this case, it is critical that the ABI hash not flip.
- then return (inplaceInstalledPackageInfo pwd distPref
- pkg (mkAbiHash "inplace") lib lbi clbi)
- else do
+
+ return
+ ( inplaceInstalledPackageInfo
+ pwd
+ distPref
+ pkg
+ (mkAbiHash "inplace")
+ lib
+ lbi
+ clbi
+ )
+ else do
abi_hash <- abiHash verbosity pkg distPref lbi lib clbi
if reloc
- then relocRegistrationInfo verbosity
- pkg lib lbi clbi abi_hash packageDb
- else return (absoluteInstalledPackageInfo
- pkg abi_hash lib lbi clbi)
-
+ then
+ relocRegistrationInfo
+ verbosity
+ pkg
+ lib
+ lbi
+ clbi
+ abi_hash
+ packageDb
+ else
+ return
+ ( absoluteInstalledPackageInfo
+ pkg
+ abi_hash
+ lib
+ lbi
+ clbi
+ )
return installedPkgInfo
-- | Compute the 'AbiHash' of a library that we built inplace.
-abiHash :: Verbosity
- -> PackageDescription
- -> FilePath
- -> LocalBuildInfo
- -> Library
- -> ComponentLocalBuildInfo
- -> IO AbiHash
+abiHash
+ :: Verbosity
+ -> PackageDescription
+ -> FilePath
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO AbiHash
abiHash verbosity pkg distPref lbi lib clbi =
- case compilerFlavor comp of
- GHC -> do
- fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi
- GHCJS -> do
- fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi
- _ -> return (mkAbiHash "")
+ case compilerFlavor comp of
+ GHC -> do
+ fmap mkAbiHash $ GHC.libAbiHash verbosity pkg lbi' lib clbi
+ GHCJS -> do
+ fmap mkAbiHash $ GHCJS.libAbiHash verbosity pkg lbi' lib clbi
+ _ -> return (mkAbiHash "")
where
comp = compiler lbi
- lbi' = lbi {
- withPackageDB = withPackageDB lbi
- ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
- }
-
-relocRegistrationInfo :: Verbosity
- -> PackageDescription
- -> Library
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> AbiHash
- -> PackageDB
- -> IO InstalledPackageInfo
+ lbi' =
+ lbi
+ { withPackageDB =
+ withPackageDB lbi
+ ++ [SpecificPackageDB (internalPackageDBPath lbi distPref)]
+ }
+
+relocRegistrationInfo
+ :: Verbosity
+ -> PackageDescription
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> AbiHash
+ -> PackageDB
+ -> IO InstalledPackageInfo
relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =
case (compilerFlavor (compiler lbi)) of
- GHC -> do fs <- GHC.pkgRoot verbosity lbi packageDb
- return (relocatableInstalledPackageInfo
- pkg abi_hash lib lbi clbi fs)
- _ -> die' verbosity
- "Distribution.Simple.Register.relocRegistrationInfo: \
- \not implemented for this compiler"
+ GHC -> do
+ fs <- GHC.pkgRoot verbosity lbi packageDb
+ return
+ ( relocatableInstalledPackageInfo
+ pkg
+ abi_hash
+ lib
+ lbi
+ clbi
+ fs
+ )
+ _ ->
+ die'
+ verbosity
+ "Distribution.Simple.Register.relocRegistrationInfo: \
+ \not implemented for this compiler"
initPackageDB :: Verbosity -> Compiler -> ProgramDb -> FilePath -> IO ()
initPackageDB verbosity comp progdb dbPath =
- createPackageDB verbosity comp progdb False dbPath
+ createPackageDB verbosity comp progdb False dbPath
-- | Create an empty package DB at the specified location.
-createPackageDB :: Verbosity -> Compiler -> ProgramDb -> Bool
- -> FilePath -> IO ()
+createPackageDB
+ :: Verbosity
+ -> Compiler
+ -> ProgramDb
+ -> Bool
+ -> FilePath
+ -> IO ()
createPackageDB verbosity comp progdb preferCompat dbPath =
- case compilerFlavor comp of
- GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath
- GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath
- UHC -> return ()
- HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath
- _ -> die' verbosity $
- "Distribution.Simple.Register.createPackageDB: "
- ++ "not implemented for this compiler"
+ case compilerFlavor comp of
+ GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath
+ GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath
+ UHC -> return ()
+ HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath
+ _ ->
+ die' verbosity $
+ "Distribution.Simple.Register.createPackageDB: "
+ ++ "not implemented for this compiler"
doesPackageDBExist :: FilePath -> IO Bool
doesPackageDBExist dbPath = do
- -- currently one impl for all compiler flavours, but could change if needed
- dir_exists <- doesDirectoryExist dbPath
- if dir_exists
- then return True
- else doesFileExist dbPath
+ -- currently one impl for all compiler flavours, but could change if needed
+ dir_exists <- doesDirectoryExist dbPath
+ if dir_exists
+ then return True
+ else doesFileExist dbPath
deletePackageDB :: FilePath -> IO ()
deletePackageDB dbPath = do
- -- currently one impl for all compiler flavours, but could change if needed
- dir_exists <- doesDirectoryExist dbPath
- if dir_exists
- then removeDirectoryRecursive dbPath
- else do file_exists <- doesFileExist dbPath
- when file_exists $ removeFile dbPath
+ -- currently one impl for all compiler flavours, but could change if needed
+ dir_exists <- doesDirectoryExist dbPath
+ if dir_exists
+ then removeDirectoryRecursive dbPath
+ else do
+ file_exists <- doesFileExist dbPath
+ when file_exists $ removeFile dbPath
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it.
-invokeHcPkg :: Verbosity -> Compiler -> ProgramDb -> PackageDBStack
- -> [String] -> IO ()
+invokeHcPkg
+ :: Verbosity
+ -> Compiler
+ -> ProgramDb
+ -> PackageDBStack
+ -> [String]
+ -> IO ()
invokeHcPkg verbosity comp progdb dbStack extraArgs =
- withHcPkg verbosity "invokeHcPkg" comp progdb
+ withHcPkg
+ verbosity
+ "invokeHcPkg"
+ comp
+ progdb
(\hpi -> HcPkg.invoke hpi verbosity dbStack extraArgs)
-withHcPkg :: Verbosity -> String -> Compiler -> ProgramDb
- -> (HcPkg.HcPkgInfo -> IO a) -> IO a
+withHcPkg
+ :: Verbosity
+ -> String
+ -> Compiler
+ -> ProgramDb
+ -> (HcPkg.HcPkgInfo -> IO a)
+ -> IO a
withHcPkg verbosity name comp progdb f =
case compilerFlavor comp of
- GHC -> f (GHC.hcPkgInfo progdb)
+ GHC -> f (GHC.hcPkgInfo progdb)
GHCJS -> f (GHCJS.hcPkgInfo progdb)
- _ -> die' verbosity ("Distribution.Simple.Register." ++ name ++ ":\
- \not implemented for this compiler")
-
-registerPackage :: Verbosity
- -> Compiler
- -> ProgramDb
- -> PackageDBStack
- -> InstalledPackageInfo
- -> HcPkg.RegisterOptions
- -> IO ()
+ _ ->
+ die'
+ verbosity
+ ( "Distribution.Simple.Register."
+ ++ name
+ ++ ":\
+ \not implemented for this compiler"
+ )
+
+registerPackage
+ :: Verbosity
+ -> Compiler
+ -> ProgramDb
+ -> PackageDBStack
+ -> InstalledPackageInfo
+ -> HcPkg.RegisterOptions
+ -> IO ()
registerPackage verbosity comp progdb packageDbs installedPkgInfo registerOptions =
case compilerFlavor comp of
- GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions
+ GHC -> GHC.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions
GHCJS -> GHCJS.registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions
- HaskellSuite {} ->
- HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo
- _ | HcPkg.registerMultiInstance registerOptions
- -> die' verbosity "Registering multiple package instances is not yet supported for this compiler"
- UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo
- _ -> die' verbosity "Registering is not implemented for this compiler"
-
-writeHcPkgRegisterScript :: Verbosity
- -> [InstalledPackageInfo]
- -> PackageDBStack
- -> HcPkg.HcPkgInfo
- -> IO ()
+ HaskellSuite{} ->
+ HaskellSuite.registerPackage verbosity progdb packageDbs installedPkgInfo
+ _
+ | HcPkg.registerMultiInstance registerOptions ->
+ die' verbosity "Registering multiple package instances is not yet supported for this compiler"
+ UHC -> UHC.registerPackage verbosity comp progdb packageDbs installedPkgInfo
+ _ -> die' verbosity "Registering is not implemented for this compiler"
+
+writeHcPkgRegisterScript
+ :: Verbosity
+ -> [InstalledPackageInfo]
+ -> PackageDBStack
+ -> HcPkg.HcPkgInfo
+ -> IO ()
writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
let genScript installedPkgInfo =
- let invocation = HcPkg.registerInvocation hpi Verbosity.normal
- packageDbs installedPkgInfo
- HcPkg.defaultRegisterOptions
- in invocationAsSystemScript buildOS invocation
+ let invocation =
+ HcPkg.registerInvocation
+ hpi
+ Verbosity.normal
+ packageDbs
+ installedPkgInfo
+ HcPkg.defaultRegisterOptions
+ in invocationAsSystemScript buildOS invocation
scripts = map genScript ipis
-- TODO: Do something more robust here
regScript = unlines scripts
@@ -373,19 +479,18 @@ writeHcPkgRegisterScript verbosity ipis packageDbs hpi = do
regScriptFileName :: FilePath
regScriptFileName = case buildOS of
- Windows -> "register.bat"
- _ -> "register.sh"
-
+ Windows -> "register.bat"
+ _ -> "register.sh"
-- -----------------------------------------------------------------------------
-- Making the InstalledPackageInfo
-- | Construct 'InstalledPackageInfo' for a library in a package, given a set
-- of installation directories.
---
generalInstalledPackageInfo
- :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to
- -- absolute paths.
+ :: ([FilePath] -> [FilePath])
+ -- ^ Translate relative include dir paths to
+ -- absolute paths.
-> PackageDescription
-> AbiHash
-> Library
@@ -394,87 +499,94 @@ generalInstalledPackageInfo
-> InstallDirs FilePath
-> InstalledPackageInfo
generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDirs =
- IPI.InstalledPackageInfo {
- IPI.sourcePackageId = packageId pkg,
- IPI.installedUnitId = componentUnitId clbi,
- IPI.installedComponentId_ = componentComponentId clbi,
- IPI.instantiatedWith = componentInstantiatedWith clbi,
- IPI.sourceLibName = libName lib,
- IPI.compatPackageKey = componentCompatPackageKey clbi,
- -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license
- IPI.license =
+ IPI.InstalledPackageInfo
+ { IPI.sourcePackageId = packageId pkg
+ , IPI.installedUnitId = componentUnitId clbi
+ , IPI.installedComponentId_ = componentComponentId clbi
+ , IPI.instantiatedWith = componentInstantiatedWith clbi
+ , IPI.sourceLibName = libName lib
+ , IPI.compatPackageKey = componentCompatPackageKey clbi
+ , -- If GHC >= 8.4 we register with SDPX, otherwise with legacy license
+ IPI.license =
if ghc84
- then Left $ either id licenseToSPDX $ licenseRaw pkg
- else Right $ either licenseFromSPDX id $ licenseRaw pkg,
- IPI.copyright = copyright pkg,
- IPI.maintainer = maintainer pkg,
- IPI.author = author pkg,
- IPI.stability = stability pkg,
- IPI.homepage = homepage pkg,
- IPI.pkgUrl = pkgUrl pkg,
- IPI.synopsis = synopsis pkg,
- IPI.description = description pkg,
- IPI.category = category pkg,
- IPI.abiHash = abi_hash,
- IPI.indefinite = componentIsIndefinite clbi,
- IPI.exposed = libExposed lib,
- IPI.exposedModules = componentExposedModules clbi
- -- add virtual modules into the list of exposed modules for the
- -- package database as well.
- ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi),
- IPI.hiddenModules = otherModules bi,
- IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo,
- IPI.importDirs = [ libdir installDirs | hasModules ],
- IPI.libraryDirs = libdirs,
- IPI.libraryDirsStatic = libdirsStatic,
- IPI.libraryDynDirs = dynlibdirs,
- IPI.dataDir = datadir installDirs,
- IPI.hsLibraries = (if hasLibrary
- then [getHSLibraryName (componentUnitId clbi)]
- else []) ++ extraBundledLibs bi,
- IPI.extraLibraries = extraLibs bi,
- IPI.extraLibrariesStatic = extraLibsStatic bi,
- IPI.extraGHCiLibraries = extraGHCiLibs bi,
- IPI.includeDirs = absinc ++ adjustRelIncDirs relinc,
- IPI.includes = includes bi,
- IPI.depends = depends,
- IPI.abiDepends = [], -- due to #5465
- IPI.ccOptions = [], -- Note. NOT ccOptions bi!
- -- We don't want cc-options to be propagated
- -- to C compilations in other packages.
- IPI.cxxOptions = [], -- Also. NOT cxxOptions bi!
- IPI.ldOptions = ldOptions bi,
- IPI.frameworks = frameworks bi,
- IPI.frameworkDirs = extraFrameworkDirs bi,
- IPI.haddockInterfaces = [haddockdir installDirs </> haddockName pkg],
- IPI.haddockHTMLs = [htmldir installDirs],
- IPI.pkgRoot = Nothing,
- IPI.libVisibility = libVisibility lib
- }
+ then Left $ either id licenseToSPDX $ licenseRaw pkg
+ else Right $ either licenseFromSPDX id $ licenseRaw pkg
+ , IPI.copyright = copyright pkg
+ , IPI.maintainer = maintainer pkg
+ , IPI.author = author pkg
+ , IPI.stability = stability pkg
+ , IPI.homepage = homepage pkg
+ , IPI.pkgUrl = pkgUrl pkg
+ , IPI.synopsis = synopsis pkg
+ , IPI.description = description pkg
+ , IPI.category = category pkg
+ , IPI.abiHash = abi_hash
+ , IPI.indefinite = componentIsIndefinite clbi
+ , IPI.exposed = libExposed lib
+ , IPI.exposedModules =
+ componentExposedModules clbi
+ -- add virtual modules into the list of exposed modules for the
+ -- package database as well.
+ ++ map (\name -> IPI.ExposedModule name Nothing) (virtualModules bi)
+ , IPI.hiddenModules = otherModules bi
+ , IPI.trusted = IPI.trusted IPI.emptyInstalledPackageInfo
+ , IPI.importDirs = [libdir installDirs | hasModules]
+ , IPI.libraryDirs = libdirs
+ , IPI.libraryDirsStatic = libdirsStatic
+ , IPI.libraryDynDirs = dynlibdirs
+ , IPI.dataDir = datadir installDirs
+ , IPI.hsLibraries =
+ ( if hasLibrary
+ then [getHSLibraryName (componentUnitId clbi)]
+ else []
+ )
+ ++ extraBundledLibs bi
+ , IPI.extraLibraries = extraLibs bi
+ , IPI.extraLibrariesStatic = extraLibsStatic bi
+ , IPI.extraGHCiLibraries = extraGHCiLibs bi
+ , IPI.includeDirs = absinc ++ adjustRelIncDirs relinc
+ , IPI.includes = includes bi
+ , IPI.depends = depends
+ , IPI.abiDepends = [] -- due to #5465
+ , IPI.ccOptions = [] -- Note. NOT ccOptions bi!
+ -- We don't want cc-options to be propagated
+ -- to C compilations in other packages.
+ , IPI.cxxOptions = [] -- Also. NOT cxxOptions bi!
+ , IPI.ldOptions = ldOptions bi
+ , IPI.frameworks = frameworks bi
+ , IPI.frameworkDirs = extraFrameworkDirs bi
+ , IPI.haddockInterfaces = [haddockdir installDirs </> haddockName pkg]
+ , IPI.haddockHTMLs = [htmldir installDirs]
+ , IPI.pkgRoot = Nothing
+ , IPI.libVisibility = libVisibility lib
+ }
where
ghc84 = case compilerId $ compiler lbi of
- CompilerId GHC v -> v >= mkVersion [8, 4]
- _ -> False
+ CompilerId GHC v -> v >= mkVersion [8, 4]
+ _ -> False
bi = libBuildInfo lib
- --TODO: unclear what the root cause of the
+ -- TODO: unclear what the root cause of the
-- duplication is, but we nub it here for now:
depends = ordNub $ map fst (componentPackageDeps clbi)
(absinc, relinc) = partition isAbsolute (includeDirs bi)
hasModules = not $ null (allLibModules lib clbi)
comp = compiler lbi
- hasLibrary = (hasModules || not (null (cSources bi))
- || not (null (asmSources bi))
- || not (null (cmmSources bi))
- || not (null (cxxSources bi))
- || (not (null (jsSources bi)) && hasJsSupport))
- && not (componentIsIndefinite clbi)
+ hasLibrary =
+ ( hasModules
+ || not (null (cSources bi))
+ || not (null (asmSources bi))
+ || not (null (cmmSources bi))
+ || not (null (cxxSources bi))
+ || (not (null (jsSources bi)) && hasJsSupport)
+ )
+ && not (componentIsIndefinite clbi)
hasJsSupport = case hostPlatform lbi of
Platform JavaScript _ -> True
- _ -> False
+ _ -> False
libdirsStatic
| hasLibrary = libdir installDirs : extraLibDirsStaticOrFallback
- | otherwise = extraLibDirsStaticOrFallback
+ | otherwise = extraLibDirsStaticOrFallback
where
-- If no static library dirs were given, the package likely makes no
-- distinction between fully static linking and otherwise.
@@ -483,128 +595,161 @@ generalInstalledPackageInfo adjustRelIncDirs pkg abi_hash lib lbi clbi installDi
[] -> extraLibDirs bi
dirs -> dirs
(libdirs, dynlibdirs)
- | not hasLibrary
- = (extraLibDirs bi, [])
+ | not hasLibrary =
+ (extraLibDirs bi, [])
-- the dynamic-library-dirs defaults to the library-dirs if not specified,
-- so this works whether the dynamic-library-dirs field is supported or not
- | libraryDynDirSupported comp
- = (libdir installDirs : extraLibDirs bi,
- dynlibdir installDirs : extraLibDirs bi)
+ | libraryDynDirSupported comp =
+ ( libdir installDirs : extraLibDirs bi
+ , dynlibdir installDirs : extraLibDirs bi
+ )
+ | otherwise =
+ (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])
- | otherwise
- = (libdir installDirs : dynlibdir installDirs : extraLibDirs bi, [])
- -- the compiler doesn't understand the dynamic-library-dirs field so we
- -- add the dyn directory to the "normal" list in the library-dirs field
+-- the compiler doesn't understand the dynamic-library-dirs field so we
+-- add the dyn directory to the "normal" list in the library-dirs field
-- | Construct 'InstalledPackageInfo' for a library that is in place in the
-- build tree.
--
-- This function knows about the layout of in place packages.
---
-inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree
- -> FilePath -- ^ location of the dist tree
- -> PackageDescription
- -> AbiHash
- -> Library
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> InstalledPackageInfo
+inplaceInstalledPackageInfo
+ :: FilePath
+ -- ^ top of the build tree
+ -> FilePath
+ -- ^ location of the dist tree
+ -> PackageDescription
+ -> AbiHash
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> InstalledPackageInfo
inplaceInstalledPackageInfo inplaceDir distPref pkg abi_hash lib lbi clbi =
- generalInstalledPackageInfo adjustRelativeIncludeDirs
- pkg abi_hash lib lbi clbi installDirs
+ generalInstalledPackageInfo
+ adjustRelativeIncludeDirs
+ pkg
+ abi_hash
+ lib
+ lbi
+ clbi
+ installDirs
where
adjustRelativeIncludeDirs = concatMap $ \d ->
- [ inplaceDir </> d -- local include-dir
- , inplaceDir </> libTargetDir </> d -- autogen include-dir
+ [ inplaceDir </> d -- local include-dir
+ , inplaceDir </> libTargetDir </> d -- autogen include-dir
]
libTargetDir = componentBuildDir lbi clbi
installDirs =
- (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest) {
- libdir = inplaceDir </> libTargetDir,
- dynlibdir = inplaceDir </> libTargetDir,
- datadir = inplaceDir </> dataDir pkg,
- docdir = inplaceDocdir,
- htmldir = inplaceHtmldir,
- haddockdir = inplaceHtmldir
- }
- inplaceDocdir = inplaceDir </> distPref </> "doc"
+ (absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest)
+ { libdir = inplaceDir </> libTargetDir
+ , dynlibdir = inplaceDir </> libTargetDir
+ , datadir = inplaceDir </> dataDir pkg
+ , docdir = inplaceDocdir
+ , htmldir = inplaceHtmldir
+ , haddockdir = inplaceHtmldir
+ }
+ inplaceDocdir = inplaceDir </> distPref </> "doc"
inplaceHtmldir = inplaceDocdir </> "html" </> prettyShow (packageName pkg)
-
-- | Construct 'InstalledPackageInfo' for the final install location of a
-- library package.
--
-- This function knows about the layout of installed packages.
---
-absoluteInstalledPackageInfo :: PackageDescription
- -> AbiHash
- -> Library
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> InstalledPackageInfo
+absoluteInstalledPackageInfo
+ :: PackageDescription
+ -> AbiHash
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> InstalledPackageInfo
absoluteInstalledPackageInfo pkg abi_hash lib lbi clbi =
- generalInstalledPackageInfo adjustReativeIncludeDirs
- pkg abi_hash lib lbi clbi installDirs
+ generalInstalledPackageInfo
+ adjustReativeIncludeDirs
+ pkg
+ abi_hash
+ lib
+ lbi
+ clbi
+ installDirs
where
-- For installed packages we install all include files into one dir,
-- whereas in the build tree they may live in multiple local dirs.
adjustReativeIncludeDirs _
| null (installIncludes bi) = []
- | otherwise = [includedir installDirs]
+ | otherwise = [includedir installDirs]
bi = libBuildInfo lib
installDirs = absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest
-
-relocatableInstalledPackageInfo :: PackageDescription
- -> AbiHash
- -> Library
- -> LocalBuildInfo
- -> ComponentLocalBuildInfo
- -> FilePath
- -> InstalledPackageInfo
+relocatableInstalledPackageInfo
+ :: PackageDescription
+ -> AbiHash
+ -> Library
+ -> LocalBuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> InstalledPackageInfo
relocatableInstalledPackageInfo pkg abi_hash lib lbi clbi pkgroot =
- generalInstalledPackageInfo adjustReativeIncludeDirs
- pkg abi_hash lib lbi clbi installDirs
+ generalInstalledPackageInfo
+ adjustReativeIncludeDirs
+ pkg
+ abi_hash
+ lib
+ lbi
+ clbi
+ installDirs
where
-- For installed packages we install all include files into one dir,
-- whereas in the build tree they may live in multiple local dirs.
adjustReativeIncludeDirs _
| null (installIncludes bi) = []
- | otherwise = [includedir installDirs]
+ | otherwise = [includedir installDirs]
bi = libBuildInfo lib
- installDirs = fmap (("${pkgroot}" </>) . shortRelativePath pkgroot)
- $ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest
+ installDirs =
+ fmap (("${pkgroot}" </>) . shortRelativePath pkgroot) $
+ absoluteComponentInstallDirs pkg lbi (componentUnitId clbi) NoCopyDest
-- -----------------------------------------------------------------------------
-- Unregistration
unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO ()
unregister pkg lbi regFlags = do
- let pkgid = packageId pkg
+ let pkgid = packageId pkg
genScript = fromFlag (regGenScript regFlags)
verbosity = fromFlag (regVerbosity regFlags)
- packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi))
- (regPackageDB regFlags)
+ packageDb =
+ fromFlagOrDefault
+ (registrationPackageDB (withPackageDB lbi))
+ (regPackageDB regFlags)
unreg hpi =
- let invocation = HcPkg.unregisterInvocation
- hpi Verbosity.normal packageDb pkgid
- in if genScript
- then writeFileAtomic unregScriptFileName
- (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)
- else runProgramInvocation verbosity invocation
+ let invocation =
+ HcPkg.unregisterInvocation
+ hpi
+ Verbosity.normal
+ packageDb
+ pkgid
+ in if genScript
+ then
+ writeFileAtomic
+ unregScriptFileName
+ (BS.Char8.pack $ invocationAsSystemScript buildOS invocation)
+ else runProgramInvocation verbosity invocation
setupMessage verbosity "Unregistering" pkgid
- withHcPkg verbosity "unregistering is only implemented for GHC and GHCJS"
- (compiler lbi) (withPrograms lbi) unreg
+ withHcPkg
+ verbosity
+ "unregistering is only implemented for GHC and GHCJS"
+ (compiler lbi)
+ (withPrograms lbi)
+ unreg
unregScriptFileName :: FilePath
unregScriptFileName = case buildOS of
- Windows -> "unregister.bat"
- _ -> "unregister.sh"
+ Windows -> "unregister.bat"
+ _ -> "unregister.sh"
internalPackageDBPath :: LocalBuildInfo -> FilePath -> FilePath
internalPackageDBPath lbi distPref =
- case compilerFlavor (compiler lbi) of
- UHC -> UHC.inplacePackageDbPath lbi
- _ -> distPref </> "package.conf.inplace"
+ case compilerFlavor (compiler lbi) of
+ UHC -> UHC.inplacePackageDbPath lbi
+ _ -> distPref </> "package.conf.inplace"
diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs
index e03cafd73050c5436114e4bb7674eb1d583a86a2..b1758d1ee9648f25fe840c7d37a23248e4bd9651 100644
--- a/Cabal/src/Distribution/Simple/Setup.hs
+++ b/Cabal/src/Distribution/Simple/Setup.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup
-- Copyright : Isaac Jones 2003-2004
@@ -31,53 +32,107 @@
-- needs is to unify it with the code for managing sets of fields that can be
-- read and written from files. This would allow us to save configure flags in
-- config files.
-
-module Distribution.Simple.Setup (
-
- GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
- ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,
- configPrograms,
- configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList,
- CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
- InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
- HaddockTarget(..),
- HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,
- Visibility(..),
- HaddockProjectFlags(..), emptyHaddockProjectFlags, defaultHaddockProjectFlags, haddockProjectCommand,
- HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
- BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand,
- DumpBuildInfo(..),
- ReplFlags(..), defaultReplFlags, replCommand,
- ReplOptions(..),
- CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand,
- RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,
- unregisterCommand,
- SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand,
- TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand,
- TestShowDetails(..),
- BenchmarkFlags(..), emptyBenchmarkFlags,
- defaultBenchmarkFlags, benchmarkCommand,
- CopyDest(..),
- configureArgs, configureOptions, configureCCompiler, configureLinker,
- buildOptions, haddockOptions, haddockProjectOptions, installDirsOptions,
- testOptions', benchmarkOptions',
- programDbOptions, programDbPaths',
- programFlagsDescription,
- replOptions,
- splitArgs,
-
- defaultDistPref, optionDistPref,
-
- Flag(..),
- toFlag,
- fromFlag,
- fromFlagOrDefault,
- flagToMaybe,
- flagToList,
- maybeToFlag,
- BooleanFlag(..),
- boolOpt, boolOpt', trueArg, falseArg,
- optionVerbosity, optionNumJobs) where
+module Distribution.Simple.Setup
+ ( GlobalFlags (..)
+ , emptyGlobalFlags
+ , defaultGlobalFlags
+ , globalCommand
+ , ConfigFlags (..)
+ , emptyConfigFlags
+ , defaultConfigFlags
+ , configureCommand
+ , configPrograms
+ , configAbsolutePaths
+ , readPackageDb
+ , readPackageDbList
+ , showPackageDb
+ , showPackageDbList
+ , CopyFlags (..)
+ , emptyCopyFlags
+ , defaultCopyFlags
+ , copyCommand
+ , InstallFlags (..)
+ , emptyInstallFlags
+ , defaultInstallFlags
+ , installCommand
+ , HaddockTarget (..)
+ , HaddockFlags (..)
+ , emptyHaddockFlags
+ , defaultHaddockFlags
+ , haddockCommand
+ , Visibility (..)
+ , HaddockProjectFlags (..)
+ , emptyHaddockProjectFlags
+ , defaultHaddockProjectFlags
+ , haddockProjectCommand
+ , HscolourFlags (..)
+ , emptyHscolourFlags
+ , defaultHscolourFlags
+ , hscolourCommand
+ , BuildFlags (..)
+ , emptyBuildFlags
+ , defaultBuildFlags
+ , buildCommand
+ , DumpBuildInfo (..)
+ , ReplFlags (..)
+ , defaultReplFlags
+ , replCommand
+ , ReplOptions (..)
+ , CleanFlags (..)
+ , emptyCleanFlags
+ , defaultCleanFlags
+ , cleanCommand
+ , RegisterFlags (..)
+ , emptyRegisterFlags
+ , defaultRegisterFlags
+ , registerCommand
+ , unregisterCommand
+ , SDistFlags (..)
+ , emptySDistFlags
+ , defaultSDistFlags
+ , sdistCommand
+ , TestFlags (..)
+ , emptyTestFlags
+ , defaultTestFlags
+ , testCommand
+ , TestShowDetails (..)
+ , BenchmarkFlags (..)
+ , emptyBenchmarkFlags
+ , defaultBenchmarkFlags
+ , benchmarkCommand
+ , CopyDest (..)
+ , configureArgs
+ , configureOptions
+ , configureCCompiler
+ , configureLinker
+ , buildOptions
+ , haddockOptions
+ , haddockProjectOptions
+ , installDirsOptions
+ , testOptions'
+ , benchmarkOptions'
+ , programDbOptions
+ , programDbPaths'
+ , programFlagsDescription
+ , replOptions
+ , splitArgs
+ , defaultDistPref
+ , optionDistPref
+ , Flag (..)
+ , toFlag
+ , fromFlag
+ , fromFlagOrDefault
+ , flagToMaybe
+ , flagToList
+ , maybeToFlag
+ , BooleanFlag (..)
+ , boolOpt
+ , boolOpt'
+ , trueArg
+ , falseArg
+ , optionVerbosity
+ , optionNumJobs
+ ) where
import Prelude ()
@@ -101,8 +156,8 @@ import Distribution.Simple.Setup.SDist
import Distribution.Simple.Setup.Test
-- The test cases kinda have to be rewritten from the ground up... :/
---hunitTests :: [Test]
---hunitTests =
+-- hunitTests :: [Test]
+-- hunitTests =
-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)]
-- (flags, commands', unkFlags, ers)
-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"]
diff --git a/Cabal/src/Distribution/Simple/Setup/Benchmark.hs b/Cabal/src/Distribution/Simple/Setup/Benchmark.hs
index 0b854f551ae048f6521647943b85b80765c2be5e..3f657c22466836270716f324e5afa737226764c5 100644
--- a/Cabal/src/Distribution/Simple/Setup/Benchmark.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Benchmark.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Benchmark
-- Copyright : Isaac Jones 2003-2004
@@ -16,79 +17,104 @@
--
-- Definition of the benchmarking command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Benchmark (
- BenchmarkFlags(..), emptyBenchmarkFlags,
- defaultBenchmarkFlags, benchmarkCommand,
- benchmarkOptions'
+module Distribution.Simple.Setup.Benchmark
+ ( BenchmarkFlags (..)
+ , emptyBenchmarkFlags
+ , defaultBenchmarkFlags
+ , benchmarkCommand
+ , benchmarkOptions'
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
import Distribution.Simple.InstallDirs
+import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Benchmark flags
+
-- ------------------------------------------------------------
-data BenchmarkFlags = BenchmarkFlags {
- benchmarkDistPref :: Flag FilePath,
- benchmarkVerbosity :: Flag Verbosity,
- benchmarkOptions :: [PathTemplate]
- } deriving (Show, Generic, Typeable)
+data BenchmarkFlags = BenchmarkFlags
+ { benchmarkDistPref :: Flag FilePath
+ , benchmarkVerbosity :: Flag Verbosity
+ , benchmarkOptions :: [PathTemplate]
+ }
+ deriving (Show, Generic, Typeable)
defaultBenchmarkFlags :: BenchmarkFlags
-defaultBenchmarkFlags = BenchmarkFlags {
- benchmarkDistPref = NoFlag,
- benchmarkVerbosity = Flag normal,
- benchmarkOptions = []
- }
+defaultBenchmarkFlags =
+ BenchmarkFlags
+ { benchmarkDistPref = NoFlag
+ , benchmarkVerbosity = Flag normal
+ , benchmarkOptions = []
+ }
benchmarkCommand :: CommandUI BenchmarkFlags
-benchmarkCommand = CommandUI
- { commandName = "bench"
- , commandSynopsis =
- "Run all/specific benchmarks."
- , commandDescription = Just $ \ _pname -> wrapText $
- testOrBenchmarkHelpText "benchmark"
- , commandNotes = Nothing
- , commandUsage = usageAlternatives "bench"
- [ "[FLAGS]"
- , "BENCHCOMPONENTS [FLAGS]"
- ]
- , commandDefaultFlags = defaultBenchmarkFlags
- , commandOptions = benchmarkOptions'
- }
+benchmarkCommand =
+ CommandUI
+ { commandName = "bench"
+ , commandSynopsis =
+ "Run all/specific benchmarks."
+ , commandDescription = Just $ \_pname ->
+ wrapText $
+ testOrBenchmarkHelpText "benchmark"
+ , commandNotes = Nothing
+ , commandUsage =
+ usageAlternatives
+ "bench"
+ [ "[FLAGS]"
+ , "BENCHCOMPONENTS [FLAGS]"
+ ]
+ , commandDefaultFlags = defaultBenchmarkFlags
+ , commandOptions = benchmarkOptions'
+ }
benchmarkOptions' :: ShowOrParseArgs -> [OptionField BenchmarkFlags]
benchmarkOptions' showOrParseArgs =
- [ optionVerbosity benchmarkVerbosity
- (\v flags -> flags { benchmarkVerbosity = v })
+ [ optionVerbosity
+ benchmarkVerbosity
+ (\v flags -> flags{benchmarkVerbosity = v})
, optionDistPref
- benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })
- showOrParseArgs
- , option [] ["benchmark-options"]
- ("give extra options to benchmark executables "
- ++ "(name templates can use $pkgid, $compiler, "
- ++ "$os, $arch, $benchmark)")
- benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
- (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
- (const []))
- , option [] ["benchmark-option"]
- ("give extra option to benchmark executables "
- ++ "(no need to quote options containing spaces, "
- ++ "name template can use $pkgid, $compiler, "
- ++ "$os, $arch, $benchmark)")
- benchmarkOptions (\v flags -> flags { benchmarkOptions = v })
- (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
- (map fromPathTemplate))
+ benchmarkDistPref
+ (\d flags -> flags{benchmarkDistPref = d})
+ showOrParseArgs
+ , option
+ []
+ ["benchmark-options"]
+ ( "give extra options to benchmark executables "
+ ++ "(name templates can use $pkgid, $compiler, "
+ ++ "$os, $arch, $benchmark)"
+ )
+ benchmarkOptions
+ (\v flags -> flags{benchmarkOptions = v})
+ ( reqArg'
+ "TEMPLATES"
+ (map toPathTemplate . splitArgs)
+ (const [])
+ )
+ , option
+ []
+ ["benchmark-option"]
+ ( "give extra option to benchmark executables "
+ ++ "(no need to quote options containing spaces, "
+ ++ "name template can use $pkgid, $compiler, "
+ ++ "$os, $arch, $benchmark)"
+ )
+ benchmarkOptions
+ (\v flags -> flags{benchmarkOptions = v})
+ ( reqArg'
+ "TEMPLATE"
+ (\x -> [toPathTemplate x])
+ (map fromPathTemplate)
+ )
]
emptyBenchmarkFlags :: BenchmarkFlags
@@ -100,4 +126,3 @@ instance Monoid BenchmarkFlags where
instance Semigroup BenchmarkFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Build.hs b/Cabal/src/Distribution/Simple/Setup/Build.hs
index 7adf67f3e019589875ac6059759496ef09fd40af..6888853285260b68d5e11a15a817c8d8ff6262e5 100644
--- a/Cabal/src/Distribution/Simple/Setup/Build.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Build.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Build
-- Copyright : Isaac Jones 2003-2004
@@ -16,107 +17,130 @@
--
-- Definition of the build command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Build (
- BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand,
- DumpBuildInfo(..),
- buildOptions,
+module Distribution.Simple.Setup.Build
+ ( BuildFlags (..)
+ , emptyBuildFlags
+ , defaultBuildFlags
+ , buildCommand
+ , DumpBuildInfo (..)
+ , buildOptions
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
import Distribution.Simple.Program
-import Distribution.Verbosity
+import Distribution.Simple.Utils
import Distribution.Types.DumpBuildInfo
+import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Build flags
+
-- ------------------------------------------------------------
-data BuildFlags = BuildFlags {
- buildProgramPaths :: [(String, FilePath)],
- buildProgramArgs :: [(String, [String])],
- buildDistPref :: Flag FilePath,
- buildVerbosity :: Flag Verbosity,
- buildNumJobs :: Flag (Maybe Int),
- -- TODO: this one should not be here, it's just that the silly
+data BuildFlags = BuildFlags
+ { buildProgramPaths :: [(String, FilePath)]
+ , buildProgramArgs :: [(String, [String])]
+ , buildDistPref :: Flag FilePath
+ , buildVerbosity :: Flag Verbosity
+ , buildNumJobs :: Flag (Maybe Int)
+ , -- TODO: this one should not be here, it's just that the silly
-- UserHooks stop us from passing extra info in other ways
- buildArgs :: [String],
- buildCabalFilePath :: Flag FilePath
+ buildArgs :: [String]
+ , buildCabalFilePath :: Flag FilePath
}
deriving (Read, Show, Generic, Typeable)
defaultBuildFlags :: BuildFlags
-defaultBuildFlags = BuildFlags {
- buildProgramPaths = mempty,
- buildProgramArgs = [],
- buildDistPref = mempty,
- buildVerbosity = Flag normal,
- buildNumJobs = mempty,
- buildArgs = [],
- buildCabalFilePath = mempty
- }
+defaultBuildFlags =
+ BuildFlags
+ { buildProgramPaths = mempty
+ , buildProgramArgs = []
+ , buildDistPref = mempty
+ , buildVerbosity = Flag normal
+ , buildNumJobs = mempty
+ , buildArgs = []
+ , buildCabalFilePath = mempty
+ }
buildCommand :: ProgramDb -> CommandUI BuildFlags
-buildCommand progDb = CommandUI
- { commandName = "build"
- , commandSynopsis = "Compile all/specific components."
- , commandDescription = Just $ \_ -> wrapText $
- "Components encompass executables, tests, and benchmarks.\n"
- ++ "\n"
- ++ "Affected by configuration options, see `configure`.\n"
- , commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " build "
- ++ " All the components in the package\n"
- ++ " " ++ pname ++ " build foo "
- ++ " A component (i.e. lib, exe, test suite)\n\n"
- ++ programFlagsDescription progDb
---TODO: re-enable once we have support for module/file targets
--- ++ " " ++ pname ++ " build Foo.Bar "
--- ++ " A module\n"
--- ++ " " ++ pname ++ " build Foo/Bar.hs"
--- ++ " A file\n\n"
--- ++ "If a target is ambiguous it can be qualified with the component "
--- ++ "name, e.g.\n"
--- ++ " " ++ pname ++ " build foo:Foo.Bar\n"
--- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"
- , commandUsage = usageAlternatives "build" $
- [ "[FLAGS]"
- , "COMPONENTS [FLAGS]"
- ]
- , commandDefaultFlags = defaultBuildFlags
- , commandOptions = \showOrParseArgs ->
- [ optionVerbosity
- buildVerbosity (\v flags -> flags { buildVerbosity = v })
-
- , optionDistPref
- buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs
- ]
- ++ buildOptions progDb showOrParseArgs
- }
-
-buildOptions :: ProgramDb -> ShowOrParseArgs
- -> [OptionField BuildFlags]
+buildCommand progDb =
+ CommandUI
+ { commandName = "build"
+ , commandSynopsis = "Compile all/specific components."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Components encompass executables, tests, and benchmarks.\n"
+ ++ "\n"
+ ++ "Affected by configuration options, see `configure`.\n"
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " build "
+ ++ " All the components in the package\n"
+ ++ " "
+ ++ pname
+ ++ " build foo "
+ ++ " A component (i.e. lib, exe, test suite)\n\n"
+ ++ programFlagsDescription progDb
+ , -- TODO: re-enable once we have support for module/file targets
+ -- ++ " " ++ pname ++ " build Foo.Bar "
+ -- ++ " A module\n"
+ -- ++ " " ++ pname ++ " build Foo/Bar.hs"
+ -- ++ " A file\n\n"
+ -- ++ "If a target is ambiguous it can be qualified with the component "
+ -- ++ "name, e.g.\n"
+ -- ++ " " ++ pname ++ " build foo:Foo.Bar\n"
+ -- ++ " " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"
+ commandUsage =
+ usageAlternatives "build" $
+ [ "[FLAGS]"
+ , "COMPONENTS [FLAGS]"
+ ]
+ , commandDefaultFlags = defaultBuildFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity
+ buildVerbosity
+ (\v flags -> flags{buildVerbosity = v})
+ , optionDistPref
+ buildDistPref
+ (\d flags -> flags{buildDistPref = d})
+ showOrParseArgs
+ ]
+ ++ buildOptions progDb showOrParseArgs
+ }
+
+buildOptions
+ :: ProgramDb
+ -> ShowOrParseArgs
+ -> [OptionField BuildFlags]
buildOptions progDb showOrParseArgs =
[ optionNumJobs
- buildNumJobs (\v flags -> flags { buildNumJobs = v })
+ buildNumJobs
+ (\v flags -> flags{buildNumJobs = v})
]
-
- ++ programDbPaths progDb showOrParseArgs
- buildProgramPaths (\v flags -> flags { buildProgramPaths = v})
-
- ++ programDbOption progDb showOrParseArgs
- buildProgramArgs (\v fs -> fs { buildProgramArgs = v })
-
- ++ programDbOptions progDb showOrParseArgs
- buildProgramArgs (\v flags -> flags { buildProgramArgs = v})
+ ++ programDbPaths
+ progDb
+ showOrParseArgs
+ buildProgramPaths
+ (\v flags -> flags{buildProgramPaths = v})
+ ++ programDbOption
+ progDb
+ showOrParseArgs
+ buildProgramArgs
+ (\v fs -> fs{buildProgramArgs = v})
+ ++ programDbOptions
+ progDb
+ showOrParseArgs
+ buildProgramArgs
+ (\v flags -> flags{buildProgramArgs = v})
emptyBuildFlags :: BuildFlags
emptyBuildFlags = mempty
@@ -127,4 +151,3 @@ instance Monoid BuildFlags where
instance Semigroup BuildFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Clean.hs b/Cabal/src/Distribution/Simple/Setup/Clean.hs
index e2b723c22a70d59b8e3f42245c28cb85cd849265..b08a3cac75c22f7893ebe27e380a3a9a3d154fb0 100644
--- a/Cabal/src/Distribution/Simple/Setup/Clean.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Clean.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Clean
-- Copyright : Isaac Jones 2003-2004
@@ -16,14 +17,15 @@
--
-- Definition of the clean command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Clean (
-
- CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand,
+module Distribution.Simple.Setup.Clean
+ ( CleanFlags (..)
+ , emptyCleanFlags
+ , defaultCleanFlags
+ , cleanCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
@@ -32,47 +34,54 @@ import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Clean flags
+
-- ------------------------------------------------------------
-data CleanFlags = CleanFlags {
- cleanSaveConf :: Flag Bool,
- cleanDistPref :: Flag FilePath,
- cleanVerbosity :: Flag Verbosity,
- cleanCabalFilePath :: Flag FilePath
+data CleanFlags = CleanFlags
+ { cleanSaveConf :: Flag Bool
+ , cleanDistPref :: Flag FilePath
+ , cleanVerbosity :: Flag Verbosity
+ , cleanCabalFilePath :: Flag FilePath
}
deriving (Show, Generic, Typeable)
defaultCleanFlags :: CleanFlags
-defaultCleanFlags = CleanFlags {
- cleanSaveConf = Flag False,
- cleanDistPref = NoFlag,
- cleanVerbosity = Flag normal,
- cleanCabalFilePath = mempty
- }
+defaultCleanFlags =
+ CleanFlags
+ { cleanSaveConf = Flag False
+ , cleanDistPref = NoFlag
+ , cleanVerbosity = Flag normal
+ , cleanCabalFilePath = mempty
+ }
cleanCommand :: CommandUI CleanFlags
-cleanCommand = CommandUI
- { commandName = "clean"
- , commandSynopsis = "Clean up after a build."
- , commandDescription = Just $ \_ ->
- "Removes .hi, .o, preprocessed sources, etc.\n"
- , commandNotes = Nothing
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " clean [FLAGS]\n"
- , commandDefaultFlags = defaultCleanFlags
- , commandOptions = \showOrParseArgs ->
- [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v })
- ,optionDistPref
- cleanDistPref (\d flags -> flags { cleanDistPref = d })
- showOrParseArgs
-
- ,option "s" ["save-configure"]
- "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure."
- cleanSaveConf (\v flags -> flags { cleanSaveConf = v })
- trueArg
- ]
- }
+cleanCommand =
+ CommandUI
+ { commandName = "clean"
+ , commandSynopsis = "Clean up after a build."
+ , commandDescription = Just $ \_ ->
+ "Removes .hi, .o, preprocessed sources, etc.\n"
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " clean [FLAGS]\n"
+ , commandDefaultFlags = defaultCleanFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity cleanVerbosity (\v flags -> flags{cleanVerbosity = v})
+ , optionDistPref
+ cleanDistPref
+ (\d flags -> flags{cleanDistPref = d})
+ showOrParseArgs
+ , option
+ "s"
+ ["save-configure"]
+ "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure."
+ cleanSaveConf
+ (\v flags -> flags{cleanSaveConf = v})
+ trueArg
+ ]
+ }
emptyCleanFlags :: CleanFlags
emptyCleanFlags = mempty
@@ -83,4 +92,3 @@ instance Monoid CleanFlags where
instance Semigroup CleanFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Common.hs b/Cabal/src/Distribution/Simple/Setup/Common.hs
index ff9187b45503e5c37a7529800dd10cf6b9cb7d53..f866ba3d8d4a9b4ce2f2b722896d023a5a08a932 100644
--- a/Cabal/src/Distribution/Simple/Setup/Common.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Common.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Common
-- Copyright : Isaac Jones 2003-2004
@@ -16,76 +17,91 @@
--
-- Common utilities for defining command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Common (
- CopyDest(..),
- configureCCompiler, configureLinker,
- programDbOption, programDbOptions,
- programDbPaths, programDbPaths',
- programFlagsDescription,
- splitArgs, testOrBenchmarkHelpText,
-
- defaultDistPref, optionDistPref,
-
- Flag(..),
- toFlag,
- fromFlag,
- fromFlagOrDefault,
- flagToMaybe,
- flagToList,
- maybeToFlag,
- BooleanFlag(..),
- boolOpt, boolOpt', trueArg, falseArg,
- reqArgFlag,
- optionVerbosity, optionNumJobs
+module Distribution.Simple.Setup.Common
+ ( CopyDest (..)
+ , configureCCompiler
+ , configureLinker
+ , programDbOption
+ , programDbOptions
+ , programDbPaths
+ , programDbPaths'
+ , programFlagsDescription
+ , splitArgs
+ , testOrBenchmarkHelpText
+ , defaultDistPref
+ , optionDistPref
+ , Flag (..)
+ , toFlag
+ , fromFlag
+ , fromFlagOrDefault
+ , flagToMaybe
+ , flagToList
+ , maybeToFlag
+ , BooleanFlag (..)
+ , boolOpt
+ , boolOpt'
+ , trueArg
+ , falseArg
+ , reqArgFlag
+ , optionVerbosity
+ , optionNumJobs
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
-import Distribution.Simple.Program
import Distribution.Simple.InstallDirs
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
import Distribution.Verbosity
-
-- FIXME Not sure where this should live
defaultDistPref :: FilePath
defaultDistPref = "dist"
-- | Help text for @test@ and @bench@ commands.
testOrBenchmarkHelpText
- :: String -- ^ Either @"test"@ or @"benchmark"@.
- -> String -- ^ Help text.
-testOrBenchmarkHelpText s = unlines $ map unwords
- [ [ "The package must have been build with configuration"
- , concat [ "flag `--enable-", s, "s`." ]
- ]
- , [] -- blank line
- , [ concat [ "Note that additional dependencies of the ", s, "s" ]
- , "must have already been installed."
- ]
- , []
- , [ "By defining UserHooks in a custom Setup.hs, the package can define"
- , concat [ "actions to be executed before and after running ", s, "s." ]
- ]
- ]
+ :: String
+ -- ^ Either @"test"@ or @"benchmark"@.
+ -> String
+ -- ^ Help text.
+testOrBenchmarkHelpText s =
+ unlines $
+ map
+ unwords
+ [
+ [ "The package must have been build with configuration"
+ , concat ["flag `--enable-", s, "s`."]
+ ]
+ , [] -- blank line
+ ,
+ [ concat ["Note that additional dependencies of the ", s, "s"]
+ , "must have already been installed."
+ ]
+ , []
+ ,
+ [ "By defining UserHooks in a custom Setup.hs, the package can define"
+ , concat ["actions to be executed before and after running ", s, "s."]
+ ]
+ ]
-- ------------------------------------------------------------
+
-- * Shared options utils
+
-- ------------------------------------------------------------
programFlagsDescription :: ProgramDb -> String
programFlagsDescription progDb =
- "The flags --with-PROG and --PROG-option(s) can be used with"
- ++ " the following programs:"
- ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort)
- [ programName prog | (prog, _) <- knownPrograms progDb ]
- ++ "\n"
+ "The flags --with-PROG and --PROG-option(s) can be used with"
+ ++ " the following programs:"
+ ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort)
+ [programName prog | (prog, _) <- knownPrograms progDb]
+ ++ "\n"
-- | For each known program @PROG@ in 'progDb', produce a @with-PROG@
-- 'OptionField'.
@@ -109,16 +125,24 @@ programDbPaths'
programDbPaths' mkName progDb showOrParseArgs get set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
- ShowArgs -> [withProgramPath "PROG"]
- ParseArgs -> map (withProgramPath . programName . fst)
- (knownPrograms progDb)
+ ShowArgs -> [withProgramPath "PROG"]
+ ParseArgs ->
+ map
+ (withProgramPath . programName . fst)
+ (knownPrograms progDb)
where
withProgramPath prog =
- option "" [mkName prog]
+ option
+ ""
+ [mkName prog]
("give the path to " ++ prog)
- get set
- (reqArg' "PATH" (\path -> [(prog, path)])
- (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))
+ get
+ set
+ ( reqArg'
+ "PATH"
+ (\path -> [(prog, path)])
+ (\progPaths -> [path | (prog', path) <- progPaths, prog == prog'])
+ )
-- | For each known program @PROG@ in 'progDb', produce a @PROG-option@
-- 'OptionField'.
@@ -131,19 +155,33 @@ programDbOption
programDbOption progDb showOrParseArgs get set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
- ShowArgs -> [programOption "PROG"]
- ParseArgs -> map (programOption . programName . fst)
- (knownPrograms progDb)
+ ShowArgs -> [programOption "PROG"]
+ ParseArgs ->
+ map
+ (programOption . programName . fst)
+ (knownPrograms progDb)
where
programOption prog =
- option "" [prog ++ "-option"]
- ("give an extra option to " ++ prog ++
- " (no need to quote options containing spaces)")
- get set
- (reqArg' "OPT" (\arg -> [(prog, [arg])])
- (\progArgs -> concat [ args
- | (prog', args) <- progArgs, prog==prog' ]))
-
+ option
+ ""
+ [prog ++ "-option"]
+ ( "give an extra option to "
+ ++ prog
+ ++ " (no need to quote options containing spaces)"
+ )
+ get
+ set
+ ( reqArg'
+ "OPT"
+ (\arg -> [(prog, [arg])])
+ ( \progArgs ->
+ concat
+ [ args
+ | (prog', args) <- progArgs
+ , prog == prog'
+ ]
+ )
+ )
-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@
-- 'OptionField'.
@@ -156,99 +194,144 @@ programDbOptions
programDbOptions progDb showOrParseArgs get set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
- ShowArgs -> [programOptions "PROG"]
- ParseArgs -> map (programOptions . programName . fst)
- (knownPrograms progDb)
+ ShowArgs -> [programOptions "PROG"]
+ ParseArgs ->
+ map
+ (programOptions . programName . fst)
+ (knownPrograms progDb)
where
programOptions prog =
- option "" [prog ++ "-options"]
+ option
+ ""
+ [prog ++ "-options"]
("give extra options to " ++ prog)
- get set
+ get
+ set
(reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))
-- ------------------------------------------------------------
+
-- * GetOpt Utils
+
-- ------------------------------------------------------------
-boolOpt :: SFlags -> SFlags
- -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
-boolOpt = Command.boolOpt flagToMaybe Flag
+boolOpt
+ :: SFlags
+ -> SFlags
+ -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
+boolOpt = Command.boolOpt flagToMaybe Flag
-boolOpt' :: OptFlags -> OptFlags
- -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
+boolOpt'
+ :: OptFlags
+ -> OptFlags
+ -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
boolOpt' = Command.boolOpt' flagToMaybe Flag
trueArg, falseArg :: MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a
-trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT
-falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF
-
-reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
- (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
+trueArg sfT lfT = boolOpt' (sfT, lfT) ([], []) sfT lfT
+falseArg sfF lfF = boolOpt' ([], []) (sfF, lfF) sfF lfF
+
+reqArgFlag
+ :: ArgPlaceHolder
+ -> SFlags
+ -> LFlags
+ -> Description
+ -> (b -> Flag String)
+ -> (Flag String -> b -> b)
+ -> OptDescr b
reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList
-optionDistPref :: (flags -> Flag FilePath)
- -> (Flag FilePath -> flags -> flags)
- -> ShowOrParseArgs
- -> OptionField flags
+optionDistPref
+ :: (flags -> Flag FilePath)
+ -> (Flag FilePath -> flags -> flags)
+ -> ShowOrParseArgs
+ -> OptionField flags
optionDistPref get set = \showOrParseArgs ->
- option "" (distPrefFlagName showOrParseArgs)
- ( "The directory where Cabal puts generated build files "
- ++ "(default " ++ defaultDistPref ++ ")")
- get set
+ option
+ ""
+ (distPrefFlagName showOrParseArgs)
+ ( "The directory where Cabal puts generated build files "
+ ++ "(default "
+ ++ defaultDistPref
+ ++ ")"
+ )
+ get
+ set
(reqArgFlag "DIR")
where
- distPrefFlagName ShowArgs = ["builddir"]
+ distPrefFlagName ShowArgs = ["builddir"]
distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"]
-optionVerbosity :: (flags -> Flag Verbosity)
- -> (Flag Verbosity -> flags -> flags)
- -> OptionField flags
+optionVerbosity
+ :: (flags -> Flag Verbosity)
+ -> (Flag Verbosity -> flags -> flags)
+ -> OptionField flags
optionVerbosity get set =
- option "v" ["verbose"]
+ option
+ "v"
+ ["verbose"]
"Control verbosity (n is 0--3, default verbosity level is 1)"
- get set
- (optArg "n" (fmap Flag flagToVerbosity)
- (Flag verbose) -- default Value if no n is given
- (fmap (Just . showForCabal) . flagToList))
-
-optionNumJobs :: (flags -> Flag (Maybe Int))
- -> (Flag (Maybe Int) -> flags -> flags)
- -> OptionField flags
+ get
+ set
+ ( optArg
+ "n"
+ (fmap Flag flagToVerbosity)
+ (Flag verbose) -- default Value if no n is given
+ (fmap (Just . showForCabal) . flagToList)
+ )
+
+optionNumJobs
+ :: (flags -> Flag (Maybe Int))
+ -> (Flag (Maybe Int) -> flags -> flags)
+ -> OptionField flags
optionNumJobs get set =
- option "j" ["jobs"]
+ option
+ "j"
+ ["jobs"]
"Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."
- get set
- (optArg "NUM" (fmap Flag numJobsParser)
- (Flag Nothing)
- (map (Just . maybe "$ncpus" show) . flagToList))
+ get
+ set
+ ( optArg
+ "NUM"
+ (fmap Flag numJobsParser)
+ (Flag Nothing)
+ (map (Just . maybe "$ncpus" show) . flagToList)
+ )
where
numJobsParser :: ReadE (Maybe Int)
numJobsParser = ReadE $ \s ->
case s of
"$ncpus" -> Right Nothing
- _ -> case reads s of
+ _ -> case reads s of
[(n, "")]
- | n < 1 -> Left "The number of jobs should be 1 or more."
+ | n < 1 -> Left "The number of jobs should be 1 or more."
| otherwise -> Right (Just n)
- _ -> Left "The jobs value should be a number or '$ncpus'"
+ _ -> Left "The jobs value should be a number or '$ncpus'"
-- ------------------------------------------------------------
+
-- * Other Utils
+
-- ------------------------------------------------------------
-configureCCompiler :: Verbosity -> ProgramDb
- -> IO (FilePath, [String])
+configureCCompiler
+ :: Verbosity
+ -> ProgramDb
+ -> IO (FilePath, [String])
configureCCompiler verbosity progdb = configureProg verbosity progdb gccProgram
configureLinker :: Verbosity -> ProgramDb -> IO (FilePath, [String])
configureLinker verbosity progdb = configureProg verbosity progdb ldProgram
-configureProg :: Verbosity -> ProgramDb -> Program
- -> IO (FilePath, [String])
+configureProg
+ :: Verbosity
+ -> ProgramDb
+ -> Program
+ -> IO (FilePath, [String])
configureProg verbosity programDb prog = do
- (p, _) <- requireProgram verbosity prog programDb
- let pInv = programInvocation p []
- return (progInvokePath pInv, progInvokeArgs pInv)
+ (p, _) <- requireProgram verbosity prog programDb
+ let pInv = programInvocation p []
+ return (progInvokePath pInv, progInvokeArgs pInv)
-- | Helper function to split a string into a list of arguments.
-- It's supposed to handle quoted things sensibly, eg:
@@ -258,27 +341,26 @@ configureProg verbosity programDb prog = do
--
-- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"
-- > = ["-DMSGSTR=\"foo bar\"","--baz"]
---
splitArgs :: String -> [String]
-splitArgs = space []
+splitArgs = space []
where
space :: String -> String -> [String]
- space w [] = word w []
- space w ( c :s)
- | isSpace c = word w (space [] s)
- space w ('"':s) = string w s
- space w s = nonstring w s
+ space w [] = word w []
+ space w (c : s)
+ | isSpace c = word w (space [] s)
+ space w ('"' : s) = string w s
+ space w s = nonstring w s
string :: String -> String -> [String]
- string w [] = word w []
- string w ('"':s) = space w s
- string w ('\\':'"':s) = string ('"':w) s
- string w ( c :s) = string (c:w) s
+ string w [] = word w []
+ string w ('"' : s) = space w s
+ string w ('\\' : '"' : s) = string ('"' : w) s
+ string w (c : s) = string (c : w) s
nonstring :: String -> String -> [String]
- nonstring w [] = word w []
- nonstring w ('"':s) = string w s
- nonstring w ( c :s) = space (c:w) s
+ nonstring w [] = word w []
+ nonstring w ('"' : s) = string w s
+ nonstring w (c : s) = space (c : w) s
word [] s = s
- word w s = reverse w : s
+ word w s = reverse w : s
diff --git a/Cabal/src/Distribution/Simple/Setup/Config.hs b/Cabal/src/Distribution/Simple/Setup/Config.hs
index 1de98c0c88fafb1f326e39b0cb8fcd96ef58184d..613d9a3c3d1ecef27c1fc2efdeacd22389a251d1 100644
--- a/Cabal/src/Distribution/Simple/Setup/Config.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Config.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Config
-- Copyright : Isaac Jones 2003-2004
@@ -16,46 +17,56 @@
--
-- Definition of the configure command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Config (
- ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand,
- configPrograms,
- configAbsolutePaths, readPackageDb, readPackageDbList, showPackageDb, showPackageDbList,
- configureArgs, configureOptions, installDirsOptions
+module Distribution.Simple.Setup.Config
+ ( ConfigFlags (..)
+ , emptyConfigFlags
+ , defaultConfigFlags
+ , configureCommand
+ , configPrograms
+ , configAbsolutePaths
+ , readPackageDb
+ , readPackageDbList
+ , showPackageDb
+ , showPackageDbList
+ , configureArgs
+ , configureOptions
+ , installDirsOptions
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
-import Distribution.Compiler
-import Distribution.ReadE
-import Distribution.Parsec
-import Distribution.Pretty
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import Distribution.Compiler
import Distribution.ModuleName
import Distribution.PackageDescription
+import Distribution.Parsec
+import Distribution.Pretty
+import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
-import Distribution.Simple.Program
import Distribution.Simple.InstallDirs
-import Distribution.Verbosity
-import Distribution.Utils.NubList
+import Distribution.Simple.Program
+import Distribution.Simple.Utils
import Distribution.Types.ComponentId
import Distribution.Types.DumpBuildInfo
import Distribution.Types.GivenComponent
import Distribution.Types.Module
import Distribution.Types.PackageVersionConstraint
+import Distribution.Utils.NubList
+import Distribution.Verbosity
+import qualified Text.PrettyPrint as Disp
-import Distribution.Compat.Stack
import Distribution.Compat.Semigroup (Last' (..), Option' (..))
+import Distribution.Compat.Stack
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Config flags
+
-- ------------------------------------------------------------
-- | Flags to @configure@ command.
@@ -63,102 +74,146 @@ import Distribution.Simple.Setup.Common
-- IMPORTANT: every time a new flag is added, 'D.C.Setup.filterConfigureFlags'
-- should be updated.
-- IMPORTANT: every time a new flag is added, it should be added to the Eq instance
-data ConfigFlags = ConfigFlags {
- -- This is the same hack as in 'buildArgs' and 'copyArgs'.
+data ConfigFlags = ConfigFlags
+ { -- This is the same hack as in 'buildArgs' and 'copyArgs'.
-- TODO: Stop using this eventually when 'UserHooks' gets changed
- configArgs :: [String],
-
- --FIXME: the configPrograms is only here to pass info through to configure
+ configArgs :: [String]
+ , -- FIXME: the configPrograms is only here to pass info through to configure
-- because the type of configure is constrained by the UserHooks.
-- when we change UserHooks next we should pass the initial
-- ProgramDb directly and not via ConfigFlags
- configPrograms_ :: Option' (Last' ProgramDb), -- ^All programs that
- -- @cabal@ may run
- configProgramPaths :: [(String, FilePath)], -- ^user specified programs paths
- configProgramArgs :: [(String, [String])], -- ^user specified programs args
- configProgramPathExtra :: NubList FilePath, -- ^Extend the $PATH
- configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the
- -- compiler, e.g. GHC.
- configHcPath :: Flag FilePath, -- ^given compiler location
- configHcPkg :: Flag FilePath, -- ^given hc-pkg location
- configVanillaLib :: Flag Bool, -- ^Enable vanilla library
- configProfLib :: Flag Bool, -- ^Enable profiling in the library
- configSharedLib :: Flag Bool, -- ^Build shared library
- configStaticLib :: Flag Bool, -- ^Build static library
- configDynExe :: Flag Bool, -- ^Enable dynamic linking of the
- -- executables.
- configFullyStaticExe :: Flag Bool, -- ^Enable fully static linking of the
- -- executables.
- configProfExe :: Flag Bool, -- ^Enable profiling in the
- -- executables.
- configProf :: Flag Bool, -- ^Enable profiling in the library
- -- and executables.
- configProfDetail :: Flag ProfDetailLevel, -- ^Profiling detail level
- -- in the library and executables.
- configProfLibDetail :: Flag ProfDetailLevel, -- ^Profiling detail level
- -- in the library
- configConfigureArgs :: [String], -- ^Extra arguments to @configure@
- configOptimization :: Flag OptimisationLevel, -- ^Enable optimization.
- configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix.
- configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix.
- configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation
- -- paths
- configScratchDir :: Flag FilePath,
- configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries
- configExtraLibDirsStatic :: [FilePath], -- ^ path to search for extra
- -- libraries when linking
- -- fully static executables
- configExtraFrameworkDirs :: [FilePath], -- ^ path to search for extra
- -- frameworks (OS X only)
- configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files
- configIPID :: Flag String, -- ^ explicit IPID to be used
- configCID :: Flag ComponentId, -- ^ explicit CID to be used
- configDeterministic :: Flag Bool, -- ^ be as deterministic as possible
- -- (e.g., invariant over GHC, database,
- -- etc). Used by the test suite
-
- configDistPref :: Flag FilePath, -- ^"dist" prefix
- configCabalFilePath :: Flag FilePath, -- ^ Cabal file to use
- configVerbosity :: Flag Verbosity, -- ^verbosity level
- configUserInstall :: Flag Bool, -- ^The --user\/--global flag
- configPackageDBs :: [Maybe PackageDB], -- ^Which package DBs to use
- configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi
- configSplitSections :: Flag Bool, -- ^Enable -split-sections with GHC
- configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC
- configStripExes :: Flag Bool, -- ^Enable executable stripping
- configStripLibs :: Flag Bool, -- ^Enable library stripping
- configConstraints :: [PackageVersionConstraint], -- ^Additional constraints for
- -- dependencies.
- configDependencies :: [GivenComponent],
- -- ^The packages depended on.
- configInstantiateWith :: [(ModuleName, Module)],
- -- ^ The requested Backpack instantiation. If empty, either this
- -- package does not use Backpack, or we just want to typecheck
- -- the indefinite package.
- configConfigurationsFlags :: FlagAssignment,
- configTests :: Flag Bool, -- ^Enable test suite compilation
- configBenchmarks :: Flag Bool, -- ^Enable benchmark compilation
- configCoverage :: Flag Bool, -- ^Enable program coverage
- configLibCoverage :: Flag Bool, -- ^Enable program coverage (deprecated)
- configExactConfiguration :: Flag Bool,
- -- ^All direct dependencies and flags are provided on the command line by
- -- the user via the '--dependency' and '--flags' options.
- configFlagError :: Flag String,
- -- ^Halt and show an error message indicating an error in flag assignment
- configRelocatable :: Flag Bool, -- ^ Enable relocatable package built
- configDebugInfo :: Flag DebugInfoLevel, -- ^ Emit debug info.
- configDumpBuildInfo :: Flag DumpBuildInfo,
- -- ^ Should we dump available build information on build?
- -- Dump build information to disk before attempting to build,
- -- tooling can parse these files and use them to compile the
- -- source files themselves.
- configUseResponseFiles :: Flag Bool,
- -- ^ Whether to use response files at all. They're used for such tools
- -- as haddock, or ld.
- configAllowDependingOnPrivateLibs :: Flag Bool
- -- ^ Allow depending on private sublibraries. This is used by external
- -- tools (like cabal-install) so they can add multiple-public-libraries
- -- compatibility to older ghcs by checking visibility externally.
+ configPrograms_ :: Option' (Last' ProgramDb)
+ -- ^ All programs that
+ -- @cabal@ may run
+ , configProgramPaths :: [(String, FilePath)]
+ -- ^ user specified programs paths
+ , configProgramArgs :: [(String, [String])]
+ -- ^ user specified programs args
+ , configProgramPathExtra :: NubList FilePath
+ -- ^ Extend the $PATH
+ , configHcFlavor :: Flag CompilerFlavor
+ -- ^ The \"flavor\" of the
+ -- compiler, e.g. GHC.
+ , configHcPath :: Flag FilePath
+ -- ^ given compiler location
+ , configHcPkg :: Flag FilePath
+ -- ^ given hc-pkg location
+ , configVanillaLib :: Flag Bool
+ -- ^ Enable vanilla library
+ , configProfLib :: Flag Bool
+ -- ^ Enable profiling in the library
+ , configSharedLib :: Flag Bool
+ -- ^ Build shared library
+ , configStaticLib :: Flag Bool
+ -- ^ Build static library
+ , configDynExe :: Flag Bool
+ -- ^ Enable dynamic linking of the
+ -- executables.
+ , configFullyStaticExe :: Flag Bool
+ -- ^ Enable fully static linking of the
+ -- executables.
+ , configProfExe :: Flag Bool
+ -- ^ Enable profiling in the
+ -- executables.
+ , configProf :: Flag Bool
+ -- ^ Enable profiling in the library
+ -- and executables.
+ , configProfDetail :: Flag ProfDetailLevel
+ -- ^ Profiling detail level
+ -- in the library and executables.
+ , configProfLibDetail :: Flag ProfDetailLevel
+ -- ^ Profiling detail level
+ -- in the library
+ , configConfigureArgs :: [String]
+ -- ^ Extra arguments to @configure@
+ , configOptimization :: Flag OptimisationLevel
+ -- ^ Enable optimization.
+ , configProgPrefix :: Flag PathTemplate
+ -- ^ Installed executable prefix.
+ , configProgSuffix :: Flag PathTemplate
+ -- ^ Installed executable suffix.
+ , configInstallDirs :: InstallDirs (Flag PathTemplate)
+ -- ^ Installation
+ -- paths
+ , configScratchDir :: Flag FilePath
+ , configExtraLibDirs :: [FilePath]
+ -- ^ path to search for extra libraries
+ , configExtraLibDirsStatic :: [FilePath]
+ -- ^ path to search for extra
+ -- libraries when linking
+ -- fully static executables
+ , configExtraFrameworkDirs :: [FilePath]
+ -- ^ path to search for extra
+ -- frameworks (OS X only)
+ , configExtraIncludeDirs :: [FilePath]
+ -- ^ path to search for header files
+ , configIPID :: Flag String
+ -- ^ explicit IPID to be used
+ , configCID :: Flag ComponentId
+ -- ^ explicit CID to be used
+ , configDeterministic :: Flag Bool
+ -- ^ be as deterministic as possible
+ -- (e.g., invariant over GHC, database,
+ -- etc). Used by the test suite
+ , configDistPref :: Flag FilePath
+ -- ^ "dist" prefix
+ , configCabalFilePath :: Flag FilePath
+ -- ^ Cabal file to use
+ , configVerbosity :: Flag Verbosity
+ -- ^ verbosity level
+ , configUserInstall :: Flag Bool
+ -- ^ The --user\/--global flag
+ , configPackageDBs :: [Maybe PackageDB]
+ -- ^ Which package DBs to use
+ , configGHCiLib :: Flag Bool
+ -- ^ Enable compiling library for GHCi
+ , configSplitSections :: Flag Bool
+ -- ^ Enable -split-sections with GHC
+ , configSplitObjs :: Flag Bool
+ -- ^ Enable -split-objs with GHC
+ , configStripExes :: Flag Bool
+ -- ^ Enable executable stripping
+ , configStripLibs :: Flag Bool
+ -- ^ Enable library stripping
+ , configConstraints :: [PackageVersionConstraint]
+ -- ^ Additional constraints for
+ -- dependencies.
+ , configDependencies :: [GivenComponent]
+ -- ^ The packages depended on.
+ , configInstantiateWith :: [(ModuleName, Module)]
+ -- ^ The requested Backpack instantiation. If empty, either this
+ -- package does not use Backpack, or we just want to typecheck
+ -- the indefinite package.
+ , configConfigurationsFlags :: FlagAssignment
+ , configTests :: Flag Bool
+ -- ^ Enable test suite compilation
+ , configBenchmarks :: Flag Bool
+ -- ^ Enable benchmark compilation
+ , configCoverage :: Flag Bool
+ -- ^ Enable program coverage
+ , configLibCoverage :: Flag Bool
+ -- ^ Enable program coverage (deprecated)
+ , configExactConfiguration :: Flag Bool
+ -- ^ All direct dependencies and flags are provided on the command line by
+ -- the user via the '--dependency' and '--flags' options.
+ , configFlagError :: Flag String
+ -- ^ Halt and show an error message indicating an error in flag assignment
+ , configRelocatable :: Flag Bool
+ -- ^ Enable relocatable package built
+ , configDebugInfo :: Flag DebugInfoLevel
+ -- ^ Emit debug info.
+ , configDumpBuildInfo :: Flag DumpBuildInfo
+ -- ^ Should we dump available build information on build?
+ -- Dump build information to disk before attempting to build,
+ -- tooling can parse these files and use them to compile the
+ -- source files themselves.
+ , configUseResponseFiles :: Flag Bool
+ -- ^ Whether to use response files at all. They're used for such tools
+ -- as haddock, or ld.
+ , configAllowDependingOnPrivateLibs :: Flag Bool
+ -- ^ Allow depending on private sublibraries. This is used by external
+ -- tools (like cabal-install) so they can add multiple-public-libraries
+ -- compatibility to older ghcs by checking visibility externally.
}
deriving (Generic, Read, Show, Typeable)
@@ -168,145 +223,163 @@ instance Structured ConfigFlags
-- | More convenient version of 'configPrograms'. Results in an
-- 'error' if internal invariant is violated.
configPrograms :: WithCallStack (ConfigFlags -> ProgramDb)
-configPrograms = fromMaybe (error "FIXME: remove configPrograms") . fmap getLast'
- . getOption' . configPrograms_
+configPrograms =
+ fromMaybe (error "FIXME: remove configPrograms")
+ . fmap getLast'
+ . getOption'
+ . configPrograms_
instance Eq ConfigFlags where
(==) a b =
-- configPrograms skipped: not user specified, has no Eq instance
equal configProgramPaths
- && equal configProgramArgs
- && equal configProgramPathExtra
- && equal configHcFlavor
- && equal configHcPath
- && equal configHcPkg
- && equal configVanillaLib
- && equal configProfLib
- && equal configSharedLib
- && equal configStaticLib
- && equal configDynExe
- && equal configFullyStaticExe
- && equal configProfExe
- && equal configProf
- && equal configProfDetail
- && equal configProfLibDetail
- && equal configConfigureArgs
- && equal configOptimization
- && equal configProgPrefix
- && equal configProgSuffix
- && equal configInstallDirs
- && equal configScratchDir
- && equal configExtraLibDirs
- && equal configExtraLibDirsStatic
- && equal configExtraIncludeDirs
- && equal configIPID
- && equal configDeterministic
- && equal configDistPref
- && equal configVerbosity
- && equal configUserInstall
- && equal configPackageDBs
- && equal configGHCiLib
- && equal configSplitSections
- && equal configSplitObjs
- && equal configStripExes
- && equal configStripLibs
- && equal configConstraints
- && equal configDependencies
- && equal configConfigurationsFlags
- && equal configTests
- && equal configBenchmarks
- && equal configCoverage
- && equal configLibCoverage
- && equal configExactConfiguration
- && equal configFlagError
- && equal configRelocatable
- && equal configDebugInfo
- && equal configDumpBuildInfo
- && equal configUseResponseFiles
+ && equal configProgramArgs
+ && equal configProgramPathExtra
+ && equal configHcFlavor
+ && equal configHcPath
+ && equal configHcPkg
+ && equal configVanillaLib
+ && equal configProfLib
+ && equal configSharedLib
+ && equal configStaticLib
+ && equal configDynExe
+ && equal configFullyStaticExe
+ && equal configProfExe
+ && equal configProf
+ && equal configProfDetail
+ && equal configProfLibDetail
+ && equal configConfigureArgs
+ && equal configOptimization
+ && equal configProgPrefix
+ && equal configProgSuffix
+ && equal configInstallDirs
+ && equal configScratchDir
+ && equal configExtraLibDirs
+ && equal configExtraLibDirsStatic
+ && equal configExtraIncludeDirs
+ && equal configIPID
+ && equal configDeterministic
+ && equal configDistPref
+ && equal configVerbosity
+ && equal configUserInstall
+ && equal configPackageDBs
+ && equal configGHCiLib
+ && equal configSplitSections
+ && equal configSplitObjs
+ && equal configStripExes
+ && equal configStripLibs
+ && equal configConstraints
+ && equal configDependencies
+ && equal configConfigurationsFlags
+ && equal configTests
+ && equal configBenchmarks
+ && equal configCoverage
+ && equal configLibCoverage
+ && equal configExactConfiguration
+ && equal configFlagError
+ && equal configRelocatable
+ && equal configDebugInfo
+ && equal configDumpBuildInfo
+ && equal configUseResponseFiles
where
equal f = on (==) f a b
configAbsolutePaths :: ConfigFlags -> IO ConfigFlags
configAbsolutePaths f =
- (\v -> f { configPackageDBs = v })
- `liftM` traverse (maybe (return Nothing) (liftM Just . absolutePackageDBPath))
- (configPackageDBs f)
+ (\v -> f{configPackageDBs = v})
+ `liftM` traverse
+ (maybe (return Nothing) (liftM Just . absolutePackageDBPath))
+ (configPackageDBs f)
+{- FOURMOLU_DISABLE -}
defaultConfigFlags :: ProgramDb -> ConfigFlags
-defaultConfigFlags progDb = emptyConfigFlags {
- configArgs = [],
- configPrograms_ = Option' (Just (Last' progDb)),
- configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor,
- configVanillaLib = Flag True,
- configProfLib = NoFlag,
- configSharedLib = NoFlag,
- configStaticLib = NoFlag,
- configDynExe = Flag False,
- configFullyStaticExe = Flag False,
- configProfExe = NoFlag,
- configProf = NoFlag,
- configProfDetail = NoFlag,
- configProfLibDetail= NoFlag,
- configOptimization = Flag NormalOptimisation,
- configProgPrefix = Flag (toPathTemplate ""),
- configProgSuffix = Flag (toPathTemplate ""),
- configDistPref = NoFlag,
- configCabalFilePath = NoFlag,
- configVerbosity = Flag normal,
- configUserInstall = Flag False, --TODO: reverse this
+defaultConfigFlags progDb =
+ emptyConfigFlags
+ { configArgs = []
+ , configPrograms_ = Option' (Just (Last' progDb))
+ , configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor
+ , configVanillaLib = Flag True
+ , configProfLib = NoFlag
+ , configSharedLib = NoFlag
+ , configStaticLib = NoFlag
+ , configDynExe = Flag False
+ , configFullyStaticExe = Flag False
+ , configProfExe = NoFlag
+ , configProf = NoFlag
+ , configProfDetail = NoFlag
+ , configProfLibDetail = NoFlag
+ , configOptimization = Flag NormalOptimisation
+ , configProgPrefix = Flag (toPathTemplate "")
+ , configProgSuffix = Flag (toPathTemplate "")
+ , configDistPref = NoFlag
+ , configCabalFilePath = NoFlag
+ , configVerbosity = Flag normal
+ , configUserInstall = Flag False -- TODO: reverse this
#if defined(mingw32_HOST_OS)
- -- See #8062 and GHC #21019.
- configGHCiLib = Flag False,
+ -- See #8062 and GHC #21019.
+ , configGHCiLib = Flag False
#else
- configGHCiLib = NoFlag,
+ , configGHCiLib = NoFlag
#endif
- configSplitSections = Flag False,
- configSplitObjs = Flag False, -- takes longer, so turn off by default
- configStripExes = NoFlag,
- configStripLibs = NoFlag,
- configTests = Flag False,
- configBenchmarks = Flag False,
- configCoverage = Flag False,
- configLibCoverage = NoFlag,
- configExactConfiguration = Flag False,
- configFlagError = NoFlag,
- configRelocatable = Flag False,
- configDebugInfo = Flag NoDebugInfo,
- configDumpBuildInfo = NoFlag,
- configUseResponseFiles = NoFlag
- }
+ , configSplitSections = Flag False
+ , configSplitObjs = Flag False -- takes longer, so turn off by default
+ , configStripExes = NoFlag
+ , configStripLibs = NoFlag
+ , configTests = Flag False
+ , configBenchmarks = Flag False
+ , configCoverage = Flag False
+ , configLibCoverage = NoFlag
+ , configExactConfiguration = Flag False
+ , configFlagError = NoFlag
+ , configRelocatable = Flag False
+ , configDebugInfo = Flag NoDebugInfo
+ , configDumpBuildInfo = NoFlag
+ , configUseResponseFiles = NoFlag
+ }
+{- FOURMOLU_ENABLE -}
configureCommand :: ProgramDb -> CommandUI ConfigFlags
-configureCommand progDb = CommandUI
- { commandName = "configure"
- , commandSynopsis = "Prepare to build the package."
- , commandDescription = Just $ \_ -> wrapText $
- "Configure how the package is built by setting "
- ++ "package (and other) flags.\n"
- ++ "\n"
- ++ "The configuration affects several other commands, "
- ++ "including build, test, bench, run, repl.\n"
- , commandNotes = Just $ \_pname -> programFlagsDescription progDb
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " configure [FLAGS]\n"
- , commandDefaultFlags = defaultConfigFlags progDb
- , commandOptions = \showOrParseArgs ->
- configureOptions showOrParseArgs
- ++ programDbPaths progDb showOrParseArgs
- configProgramPaths (\v fs -> fs { configProgramPaths = v })
- ++ programDbOption progDb showOrParseArgs
- configProgramArgs (\v fs -> fs { configProgramArgs = v })
- ++ programDbOptions progDb showOrParseArgs
- configProgramArgs (\v fs -> fs { configProgramArgs = v })
- }
+configureCommand progDb =
+ CommandUI
+ { commandName = "configure"
+ , commandSynopsis = "Prepare to build the package."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Configure how the package is built by setting "
+ ++ "package (and other) flags.\n"
+ ++ "\n"
+ ++ "The configuration affects several other commands, "
+ ++ "including build, test, bench, run, repl.\n"
+ , commandNotes = Just $ \_pname -> programFlagsDescription progDb
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " configure [FLAGS]\n"
+ , commandDefaultFlags = defaultConfigFlags progDb
+ , commandOptions = \showOrParseArgs ->
+ configureOptions showOrParseArgs
+ ++ programDbPaths
+ progDb
+ showOrParseArgs
+ configProgramPaths
+ (\v fs -> fs{configProgramPaths = v})
+ ++ programDbOption
+ progDb
+ showOrParseArgs
+ configProgramArgs
+ (\v fs -> fs{configProgramArgs = v})
+ ++ programDbOptions
+ progDb
+ showOrParseArgs
+ configProgramArgs
+ (\v fs -> fs{configProgramArgs = v})
+ }
-- | Inverse to 'dispModSubstEntry'.
parsecModSubstEntry :: ParsecParser (ModuleName, Module)
parsecModSubstEntry = do
- k <- parsec
- _ <- P.char '='
- v <- parsec
- return (k, v)
+ k <- parsec
+ _ <- P.char '='
+ v <- parsec
+ return (k, v)
-- | Pretty-print a single entry of a module substitution.
dispModSubstEntry :: (ModuleName, Module) -> Disp.Doc
@@ -314,313 +387,451 @@ dispModSubstEntry (k, v) = pretty k <<>> Disp.char '=' <<>> pretty v
configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions showOrParseArgs =
- [optionVerbosity configVerbosity
- (\v flags -> flags { configVerbosity = v })
- ,optionDistPref
- configDistPref (\d flags -> flags { configDistPref = d })
- showOrParseArgs
-
- ,option [] ["compiler"] "compiler"
- configHcFlavor (\v flags -> flags { configHcFlavor = v })
- (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC")
- , (Flag GHCJS, ([] , ["ghcjs"]), "compile with GHCJS")
- , (Flag UHC, ([] , ["uhc"]), "compile with UHC")
- -- "haskell-suite" compiler id string will be replaced
- -- by a more specific one during the configure stage
- , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),
- "compile with a haskell-suite compiler")])
-
- ,option "" ["cabal-file"]
- "use this Cabal file"
- configCabalFilePath (\v flags -> flags { configCabalFilePath = v })
- (reqArgFlag "PATH")
-
- ,option "w" ["with-compiler"]
- "give the path to a particular compiler"
- configHcPath (\v flags -> flags { configHcPath = v })
- (reqArgFlag "PATH")
-
- ,option "" ["with-hc-pkg"]
- "give the path to the package tool"
- configHcPkg (\v flags -> flags { configHcPkg = v })
- (reqArgFlag "PATH")
- ]
- ++ map liftInstallDirs installDirsOptions
- ++ [option "" ["program-prefix"]
+ [ optionVerbosity
+ configVerbosity
+ (\v flags -> flags{configVerbosity = v})
+ , optionDistPref
+ configDistPref
+ (\d flags -> flags{configDistPref = d})
+ showOrParseArgs
+ , option
+ []
+ ["compiler"]
+ "compiler"
+ configHcFlavor
+ (\v flags -> flags{configHcFlavor = v})
+ ( choiceOpt
+ [ (Flag GHC, ("g", ["ghc"]), "compile with GHC")
+ , (Flag GHCJS, ([], ["ghcjs"]), "compile with GHCJS")
+ , (Flag UHC, ([], ["uhc"]), "compile with UHC")
+ , -- "haskell-suite" compiler id string will be replaced
+ -- by a more specific one during the configure stage
+
+ ( Flag (HaskellSuite "haskell-suite")
+ , ([], ["haskell-suite"])
+ , "compile with a haskell-suite compiler"
+ )
+ ]
+ )
+ , option
+ ""
+ ["cabal-file"]
+ "use this Cabal file"
+ configCabalFilePath
+ (\v flags -> flags{configCabalFilePath = v})
+ (reqArgFlag "PATH")
+ , option
+ "w"
+ ["with-compiler"]
+ "give the path to a particular compiler"
+ configHcPath
+ (\v flags -> flags{configHcPath = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["with-hc-pkg"]
+ "give the path to the package tool"
+ configHcPkg
+ (\v flags -> flags{configHcPkg = v})
+ (reqArgFlag "PATH")
+ ]
+ ++ map liftInstallDirs installDirsOptions
+ ++ [ option
+ ""
+ ["program-prefix"]
"prefix to be applied to installed executables"
configProgPrefix
- (\v flags -> flags { configProgPrefix = v })
+ (\v flags -> flags{configProgPrefix = v})
(reqPathTemplateArgFlag "PREFIX")
-
- ,option "" ["program-suffix"]
+ , option
+ ""
+ ["program-suffix"]
"suffix to be applied to installed executables"
- configProgSuffix (\v flags -> flags { configProgSuffix = v } )
+ configProgSuffix
+ (\v flags -> flags{configProgSuffix = v})
(reqPathTemplateArgFlag "SUFFIX")
-
- ,option "" ["library-vanilla"]
- "Vanilla libraries"
- configVanillaLib (\v flags -> flags { configVanillaLib = v })
- (boolOpt [] [])
-
- ,option "p" ["library-profiling"]
- "Library profiling"
- configProfLib (\v flags -> flags { configProfLib = v })
- (boolOpt "p" [])
-
- ,option "" ["shared"]
- "Shared library"
- configSharedLib (\v flags -> flags { configSharedLib = v })
- (boolOpt [] [])
-
- ,option "" ["static"]
- "Static library"
- configStaticLib (\v flags -> flags { configStaticLib = v })
- (boolOpt [] [])
-
- ,option "" ["executable-dynamic"]
- "Executable dynamic linking"
- configDynExe (\v flags -> flags { configDynExe = v })
- (boolOpt [] [])
-
- ,option "" ["executable-static"]
- "Executable fully static linking"
- configFullyStaticExe (\v flags -> flags { configFullyStaticExe = v })
- (boolOpt [] [])
-
- ,option "" ["profiling"]
- "Executable and library profiling"
- configProf (\v flags -> flags { configProf = v })
- (boolOpt [] [])
-
- ,option "" ["executable-profiling"]
- "Executable profiling (DEPRECATED)"
- configProfExe (\v flags -> flags { configProfExe = v })
- (boolOpt [] [])
-
- ,option "" ["profiling-detail"]
- ("Profiling detail level for executable and library (default, " ++
- "none, exported-functions, toplevel-functions, all-functions, late).")
- configProfDetail (\v flags -> flags { configProfDetail = v })
- (reqArg' "level" (Flag . flagToProfDetailLevel)
- showProfDetailLevelFlag)
-
- ,option "" ["library-profiling-detail"]
- "Profiling detail level for libraries only."
- configProfLibDetail (\v flags -> flags { configProfLibDetail = v })
- (reqArg' "level" (Flag . flagToProfDetailLevel)
- showProfDetailLevelFlag)
-
- ,multiOption "optimization"
- configOptimization (\v flags -> flags { configOptimization = v })
- [optArg' "n" (Flag . flagToOptimisationLevel)
- (\f -> case f of
- Flag NoOptimisation -> []
- Flag NormalOptimisation -> [Nothing]
- Flag MaximumOptimisation -> [Just "2"]
- _ -> [])
- "O" ["enable-optimization","enable-optimisation"]
- "Build with optimization (n is 0--2, default is 1)",
- noArg (Flag NoOptimisation) []
- ["disable-optimization","disable-optimisation"]
- "Build without optimization"
- ]
-
- ,multiOption "debug-info"
- configDebugInfo (\v flags -> flags { configDebugInfo = v })
- [optArg' "n" (Flag . flagToDebugInfoLevel)
- (\f -> case f of
- Flag NoDebugInfo -> []
- Flag MinimalDebugInfo -> [Just "1"]
- Flag NormalDebugInfo -> [Nothing]
- Flag MaximalDebugInfo -> [Just "3"]
- _ -> [])
- "" ["enable-debug-info"]
- "Emit debug info (n is 0--3, default is 0)",
- noArg (Flag NoDebugInfo) []
- ["disable-debug-info"]
- "Don't emit debug info"
- ]
-
- , multiOption "build-info"
- configDumpBuildInfo
- (\v flags -> flags { configDumpBuildInfo = v })
- [noArg (Flag DumpBuildInfo) []
- ["enable-build-info"]
- "Enable build information generation during project building",
- noArg (Flag NoDumpBuildInfo) []
- ["disable-build-info"]
- "Disable build information generation during project building"
- ]
-
- ,option "" ["library-for-ghci"]
- "compile library for use with GHCi"
- configGHCiLib (\v flags -> flags { configGHCiLib = v })
- (boolOpt [] [])
-
- ,option "" ["split-sections"]
- "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)"
- configSplitSections (\v flags -> flags { configSplitSections = v })
- (boolOpt [] [])
-
- ,option "" ["split-objs"]
- "split library into smaller objects to reduce binary sizes (GHC 6.6+)"
- configSplitObjs (\v flags -> flags { configSplitObjs = v })
- (boolOpt [] [])
-
- ,option "" ["executable-stripping"]
- "strip executables upon installation to reduce binary sizes"
- configStripExes (\v flags -> flags { configStripExes = v })
- (boolOpt [] [])
-
- ,option "" ["library-stripping"]
- "strip libraries upon installation to reduce binary sizes"
- configStripLibs (\v flags -> flags { configStripLibs = v })
- (boolOpt [] [])
-
- ,option "" ["configure-option"]
- "Extra option for configure"
- configConfigureArgs (\v flags -> flags { configConfigureArgs = v })
- (reqArg' "OPT" (\x -> [x]) id)
-
- ,option "" ["user-install"]
- "doing a per-user installation"
- configUserInstall (\v flags -> flags { configUserInstall = v })
- (boolOpt' ([],["user"]) ([], ["global"]))
-
- ,option "" ["package-db"]
- ( "Append the given package database to the list of package"
- ++ " databases used (to satisfy dependencies and register into)."
- ++ " May be a specific file, 'global' or 'user'. The initial list"
- ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"
- ++ " depending on context. Use 'clear' to reset the list to empty."
- ++ " See the user guide for details.")
- configPackageDBs (\v flags -> flags { configPackageDBs = v })
- (reqArg' "DB" readPackageDbList showPackageDbList)
-
- ,option "f" ["flags"]
- "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."
- configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v })
- (reqArg "FLAGS"
+ , option
+ ""
+ ["library-vanilla"]
+ "Vanilla libraries"
+ configVanillaLib
+ (\v flags -> flags{configVanillaLib = v})
+ (boolOpt [] [])
+ , option
+ "p"
+ ["library-profiling"]
+ "Library profiling"
+ configProfLib
+ (\v flags -> flags{configProfLib = v})
+ (boolOpt "p" [])
+ , option
+ ""
+ ["shared"]
+ "Shared library"
+ configSharedLib
+ (\v flags -> flags{configSharedLib = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["static"]
+ "Static library"
+ configStaticLib
+ (\v flags -> flags{configStaticLib = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["executable-dynamic"]
+ "Executable dynamic linking"
+ configDynExe
+ (\v flags -> flags{configDynExe = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["executable-static"]
+ "Executable fully static linking"
+ configFullyStaticExe
+ (\v flags -> flags{configFullyStaticExe = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["profiling"]
+ "Executable and library profiling"
+ configProf
+ (\v flags -> flags{configProf = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["executable-profiling"]
+ "Executable profiling (DEPRECATED)"
+ configProfExe
+ (\v flags -> flags{configProfExe = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["profiling-detail"]
+ ( "Profiling detail level for executable and library (default, "
+ ++ "none, exported-functions, toplevel-functions, all-functions, late)."
+ )
+ configProfDetail
+ (\v flags -> flags{configProfDetail = v})
+ ( reqArg'
+ "level"
+ (Flag . flagToProfDetailLevel)
+ showProfDetailLevelFlag
+ )
+ , option
+ ""
+ ["library-profiling-detail"]
+ "Profiling detail level for libraries only."
+ configProfLibDetail
+ (\v flags -> flags{configProfLibDetail = v})
+ ( reqArg'
+ "level"
+ (Flag . flagToProfDetailLevel)
+ showProfDetailLevelFlag
+ )
+ , multiOption
+ "optimization"
+ configOptimization
+ (\v flags -> flags{configOptimization = v})
+ [ optArg'
+ "n"
+ (Flag . flagToOptimisationLevel)
+ ( \f -> case f of
+ Flag NoOptimisation -> []
+ Flag NormalOptimisation -> [Nothing]
+ Flag MaximumOptimisation -> [Just "2"]
+ _ -> []
+ )
+ "O"
+ ["enable-optimization", "enable-optimisation"]
+ "Build with optimization (n is 0--2, default is 1)"
+ , noArg
+ (Flag NoOptimisation)
+ []
+ ["disable-optimization", "disable-optimisation"]
+ "Build without optimization"
+ ]
+ , multiOption
+ "debug-info"
+ configDebugInfo
+ (\v flags -> flags{configDebugInfo = v})
+ [ optArg'
+ "n"
+ (Flag . flagToDebugInfoLevel)
+ ( \f -> case f of
+ Flag NoDebugInfo -> []
+ Flag MinimalDebugInfo -> [Just "1"]
+ Flag NormalDebugInfo -> [Nothing]
+ Flag MaximalDebugInfo -> [Just "3"]
+ _ -> []
+ )
+ ""
+ ["enable-debug-info"]
+ "Emit debug info (n is 0--3, default is 0)"
+ , noArg
+ (Flag NoDebugInfo)
+ []
+ ["disable-debug-info"]
+ "Don't emit debug info"
+ ]
+ , multiOption
+ "build-info"
+ configDumpBuildInfo
+ (\v flags -> flags{configDumpBuildInfo = v})
+ [ noArg
+ (Flag DumpBuildInfo)
+ []
+ ["enable-build-info"]
+ "Enable build information generation during project building"
+ , noArg
+ (Flag NoDumpBuildInfo)
+ []
+ ["disable-build-info"]
+ "Disable build information generation during project building"
+ ]
+ , option
+ ""
+ ["library-for-ghci"]
+ "compile library for use with GHCi"
+ configGHCiLib
+ (\v flags -> flags{configGHCiLib = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["split-sections"]
+ "compile library code such that unneeded definitions can be dropped from the final executable (GHC 7.8+)"
+ configSplitSections
+ (\v flags -> flags{configSplitSections = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["split-objs"]
+ "split library into smaller objects to reduce binary sizes (GHC 6.6+)"
+ configSplitObjs
+ (\v flags -> flags{configSplitObjs = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["executable-stripping"]
+ "strip executables upon installation to reduce binary sizes"
+ configStripExes
+ (\v flags -> flags{configStripExes = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["library-stripping"]
+ "strip libraries upon installation to reduce binary sizes"
+ configStripLibs
+ (\v flags -> flags{configStripLibs = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["configure-option"]
+ "Extra option for configure"
+ configConfigureArgs
+ (\v flags -> flags{configConfigureArgs = v})
+ (reqArg' "OPT" (\x -> [x]) id)
+ , option
+ ""
+ ["user-install"]
+ "doing a per-user installation"
+ configUserInstall
+ (\v flags -> flags{configUserInstall = v})
+ (boolOpt' ([], ["user"]) ([], ["global"]))
+ , option
+ ""
+ ["package-db"]
+ ( "Append the given package database to the list of package"
+ ++ " databases used (to satisfy dependencies and register into)."
+ ++ " May be a specific file, 'global' or 'user'. The initial list"
+ ++ " is ['global'], ['global', 'user'], or ['global', $sandbox],"
+ ++ " depending on context. Use 'clear' to reset the list to empty."
+ ++ " See the user guide for details."
+ )
+ configPackageDBs
+ (\v flags -> flags{configPackageDBs = v})
+ (reqArg' "DB" readPackageDbList showPackageDbList)
+ , option
+ "f"
+ ["flags"]
+ "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false."
+ configConfigurationsFlags
+ (\v flags -> flags{configConfigurationsFlags = v})
+ ( reqArg
+ "FLAGS"
(parsecToReadE (\err -> "Invalid flag assignment: " ++ err) legacyParsecFlagAssignment)
- legacyShowFlagAssignment')
-
- ,option "" ["extra-include-dirs"]
- "A list of directories to search for header files"
- configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v})
- (reqArg' "PATH" (\x -> [x]) id)
-
- ,option "" ["deterministic"]
- "Try to be as deterministic as possible (used by the test suite)"
- configDeterministic (\v flags -> flags {configDeterministic = v})
- (boolOpt [] [])
-
- ,option "" ["ipid"]
- "Installed package ID to compile this package as"
- configIPID (\v flags -> flags {configIPID = v})
- (reqArgFlag "IPID")
-
- ,option "" ["cid"]
- "Installed component ID to compile this component as"
- (fmap prettyShow . configCID) (\v flags -> flags {configCID = fmap mkComponentId v})
- (reqArgFlag "CID")
-
- ,option "" ["extra-lib-dirs"]
- "A list of directories to search for external libraries"
- configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})
- (reqArg' "PATH" (\x -> [x]) id)
-
- ,option "" ["extra-lib-dirs-static"]
- "A list of directories to search for external libraries when linking fully static executables"
- configExtraLibDirsStatic (\v flags -> flags {configExtraLibDirsStatic = v})
- (reqArg' "PATH" (\x -> [x]) id)
-
- ,option "" ["extra-framework-dirs"]
- "A list of directories to search for external frameworks (OS X only)"
- configExtraFrameworkDirs
- (\v flags -> flags {configExtraFrameworkDirs = v})
- (reqArg' "PATH" (\x -> [x]) id)
-
- ,option "" ["extra-prog-path"]
- "A list of directories to search for required programs (in addition to the normal search locations)"
- configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})
- (reqArg' "PATH" (\x -> toNubList [x]) fromNubList)
-
- ,option "" ["constraint"]
- "A list of additional constraints on the dependencies."
- configConstraints (\v flags -> flags { configConstraints = v})
- (reqArg "DEPENDENCY"
- (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec))
- (map prettyShow))
-
- ,option "" ["dependency"]
- "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""
- configDependencies (\v flags -> flags { configDependencies = v})
- (reqArg "NAME[:COMPONENT_NAME]=CID"
- (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent))
- (map (\(GivenComponent pn cn cid) ->
- prettyShow pn
- ++ case cn of LMainLibName -> ""
- LSubLibName n -> ":" ++ prettyShow n
- ++ "=" ++ prettyShow cid)))
-
- ,option "" ["instantiate-with"]
- "A mapping of signature names to concrete module instantiations."
- configInstantiateWith (\v flags -> flags { configInstantiateWith = v })
- (reqArg "NAME=MOD"
- (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (:[]) parsecModSubstEntry))
- (map (Disp.renderStyle defaultStyle . dispModSubstEntry)))
-
- ,option "" ["tests"]
- "dependency checking and compilation for test suites listed in the package description file."
- configTests (\v flags -> flags { configTests = v })
- (boolOpt [] [])
-
- ,option "" ["coverage"]
- "build package with Haskell Program Coverage. (GHC only)"
- configCoverage (\v flags -> flags { configCoverage = v })
- (boolOpt [] [])
-
- ,option "" ["library-coverage"]
- "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)"
- configLibCoverage (\v flags -> flags { configLibCoverage = v })
- (boolOpt [] [])
-
- ,option "" ["exact-configuration"]
- "All direct dependencies and flags are provided on the command line."
- configExactConfiguration
- (\v flags -> flags { configExactConfiguration = v })
- trueArg
-
- ,option "" ["benchmarks"]
- "dependency checking and compilation for benchmarks listed in the package description file."
- configBenchmarks (\v flags -> flags { configBenchmarks = v })
- (boolOpt [] [])
-
- ,option "" ["relocatable"]
- "building a package that is relocatable. (GHC only)"
- configRelocatable (\v flags -> flags { configRelocatable = v})
- (boolOpt [] [])
-
- ,option "" ["response-files"]
- "enable workaround for old versions of programs like \"ar\" that do not support @file arguments"
- configUseResponseFiles
- (\v flags -> flags { configUseResponseFiles = v })
- (boolOpt' ([], ["disable-response-files"]) ([], []))
-
- ,option "" ["allow-depending-on-private-libs"]
- ( "Allow depending on private libraries. "
- ++ "If set, the library visibility check MUST be done externally." )
- configAllowDependingOnPrivateLibs
- (\v flags -> flags { configAllowDependingOnPrivateLibs = v })
- trueArg
- ]
+ legacyShowFlagAssignment'
+ )
+ , option
+ ""
+ ["extra-include-dirs"]
+ "A list of directories to search for header files"
+ configExtraIncludeDirs
+ (\v flags -> flags{configExtraIncludeDirs = v})
+ (reqArg' "PATH" (\x -> [x]) id)
+ , option
+ ""
+ ["deterministic"]
+ "Try to be as deterministic as possible (used by the test suite)"
+ configDeterministic
+ (\v flags -> flags{configDeterministic = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["ipid"]
+ "Installed package ID to compile this package as"
+ configIPID
+ (\v flags -> flags{configIPID = v})
+ (reqArgFlag "IPID")
+ , option
+ ""
+ ["cid"]
+ "Installed component ID to compile this component as"
+ (fmap prettyShow . configCID)
+ (\v flags -> flags{configCID = fmap mkComponentId v})
+ (reqArgFlag "CID")
+ , option
+ ""
+ ["extra-lib-dirs"]
+ "A list of directories to search for external libraries"
+ configExtraLibDirs
+ (\v flags -> flags{configExtraLibDirs = v})
+ (reqArg' "PATH" (\x -> [x]) id)
+ , option
+ ""
+ ["extra-lib-dirs-static"]
+ "A list of directories to search for external libraries when linking fully static executables"
+ configExtraLibDirsStatic
+ (\v flags -> flags{configExtraLibDirsStatic = v})
+ (reqArg' "PATH" (\x -> [x]) id)
+ , option
+ ""
+ ["extra-framework-dirs"]
+ "A list of directories to search for external frameworks (OS X only)"
+ configExtraFrameworkDirs
+ (\v flags -> flags{configExtraFrameworkDirs = v})
+ (reqArg' "PATH" (\x -> [x]) id)
+ , option
+ ""
+ ["extra-prog-path"]
+ "A list of directories to search for required programs (in addition to the normal search locations)"
+ configProgramPathExtra
+ (\v flags -> flags{configProgramPathExtra = v})
+ (reqArg' "PATH" (\x -> toNubList [x]) fromNubList)
+ , option
+ ""
+ ["constraint"]
+ "A list of additional constraints on the dependencies."
+ configConstraints
+ (\v flags -> flags{configConstraints = v})
+ ( reqArg
+ "DEPENDENCY"
+ (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsec))
+ (map prettyShow)
+ )
+ , option
+ ""
+ ["dependency"]
+ "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""
+ configDependencies
+ (\v flags -> flags{configDependencies = v})
+ ( reqArg
+ "NAME[:COMPONENT_NAME]=CID"
+ (parsecToReadE (const "dependency expected") ((\x -> [x]) `fmap` parsecGivenComponent))
+ ( map
+ ( \(GivenComponent pn cn cid) ->
+ prettyShow pn
+ ++ case cn of
+ LMainLibName -> ""
+ LSubLibName n -> ":" ++ prettyShow n
+ ++ "="
+ ++ prettyShow cid
+ )
+ )
+ )
+ , option
+ ""
+ ["instantiate-with"]
+ "A mapping of signature names to concrete module instantiations."
+ configInstantiateWith
+ (\v flags -> flags{configInstantiateWith = v})
+ ( reqArg
+ "NAME=MOD"
+ (parsecToReadE ("Cannot parse module substitution: " ++) (fmap (: []) parsecModSubstEntry))
+ (map (Disp.renderStyle defaultStyle . dispModSubstEntry))
+ )
+ , option
+ ""
+ ["tests"]
+ "dependency checking and compilation for test suites listed in the package description file."
+ configTests
+ (\v flags -> flags{configTests = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["coverage"]
+ "build package with Haskell Program Coverage. (GHC only)"
+ configCoverage
+ (\v flags -> flags{configCoverage = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["library-coverage"]
+ "build package with Haskell Program Coverage. (GHC only) (DEPRECATED)"
+ configLibCoverage
+ (\v flags -> flags{configLibCoverage = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["exact-configuration"]
+ "All direct dependencies and flags are provided on the command line."
+ configExactConfiguration
+ (\v flags -> flags{configExactConfiguration = v})
+ trueArg
+ , option
+ ""
+ ["benchmarks"]
+ "dependency checking and compilation for benchmarks listed in the package description file."
+ configBenchmarks
+ (\v flags -> flags{configBenchmarks = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["relocatable"]
+ "building a package that is relocatable. (GHC only)"
+ configRelocatable
+ (\v flags -> flags{configRelocatable = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["response-files"]
+ "enable workaround for old versions of programs like \"ar\" that do not support @file arguments"
+ configUseResponseFiles
+ (\v flags -> flags{configUseResponseFiles = v})
+ (boolOpt' ([], ["disable-response-files"]) ([], []))
+ , option
+ ""
+ ["allow-depending-on-private-libs"]
+ ( "Allow depending on private libraries. "
+ ++ "If set, the library visibility check MUST be done externally."
+ )
+ configAllowDependingOnPrivateLibs
+ (\v flags -> flags{configAllowDependingOnPrivateLibs = v})
+ trueArg
+ ]
where
liftInstallDirs =
- liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v })
+ liftOption configInstallDirs (\v flags -> flags{configInstallDirs = v})
reqPathTemplateArgFlag title _sf _lf d get set =
- reqArgFlag title _sf _lf d
- (fmap fromPathTemplate . get) (set . fmap toPathTemplate)
+ reqArgFlag
+ title
+ _sf
+ _lf
+ d
+ (fmap fromPathTemplate . get)
+ (set . fmap toPathTemplate)
readPackageDbList :: String -> [Maybe PackageDB]
readPackageDbList str = [readPackageDb str]
@@ -629,10 +840,10 @@ readPackageDbList str = [readPackageDb str]
--
-- @since 3.7.0.0
readPackageDb :: String -> Maybe PackageDB
-readPackageDb "clear" = Nothing
+readPackageDb "clear" = Nothing
readPackageDb "global" = Just GlobalPackageDB
-readPackageDb "user" = Just UserPackageDB
-readPackageDb other = Just (SpecificPackageDB other)
+readPackageDb "user" = Just UserPackageDB
+readPackageDb other = Just (SpecificPackageDB other)
showPackageDbList :: [Maybe PackageDB] -> [String]
showPackageDbList = map showPackageDb
@@ -641,13 +852,13 @@ showPackageDbList = map showPackageDb
--
-- @since 3.7.0.0
showPackageDb :: Maybe PackageDB -> String
-showPackageDb Nothing = "clear"
-showPackageDb (Just GlobalPackageDB) = "global"
-showPackageDb (Just UserPackageDB) = "user"
+showPackageDb Nothing = "clear"
+showPackageDb (Just GlobalPackageDB) = "global"
+showPackageDb (Just UserPackageDB) = "user"
showPackageDb (Just (SpecificPackageDB db)) = db
showProfDetailLevelFlag :: Flag ProfDetailLevel -> [String]
-showProfDetailLevelFlag NoFlag = []
+showProfDetailLevelFlag NoFlag = []
showProfDetailLevelFlag (Flag dl) = [showProfDetailLevel dl]
parsecGivenComponent :: ParsecParser GivenComponent
@@ -656,84 +867,117 @@ parsecGivenComponent = do
ln <- P.option LMainLibName $ do
_ <- P.char ':'
ucn <- parsec
- return $ if unUnqualComponentName ucn == unPackageName pn
- then LMainLibName
- else LSubLibName ucn
+ return $
+ if unUnqualComponentName ucn == unPackageName pn
+ then LMainLibName
+ else LSubLibName ucn
_ <- P.char '='
cid <- parsec
return $ GivenComponent pn ln cid
installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))]
installDirsOptions =
- [ option "" ["prefix"]
+ [ option
+ ""
+ ["prefix"]
"bake this prefix in preparation of installation"
- prefix (\v flags -> flags { prefix = v })
+ prefix
+ (\v flags -> flags{prefix = v})
installDirArg
-
- , option "" ["bindir"]
+ , option
+ ""
+ ["bindir"]
"installation directory for executables"
- bindir (\v flags -> flags { bindir = v })
+ bindir
+ (\v flags -> flags{bindir = v})
installDirArg
-
- , option "" ["libdir"]
+ , option
+ ""
+ ["libdir"]
"installation directory for libraries"
- libdir (\v flags -> flags { libdir = v })
+ libdir
+ (\v flags -> flags{libdir = v})
installDirArg
-
- , option "" ["libsubdir"]
+ , option
+ ""
+ ["libsubdir"]
"subdirectory of libdir in which libs are installed"
- libsubdir (\v flags -> flags { libsubdir = v })
+ libsubdir
+ (\v flags -> flags{libsubdir = v})
installDirArg
-
- , option "" ["dynlibdir"]
+ , option
+ ""
+ ["dynlibdir"]
"installation directory for dynamic libraries"
- dynlibdir (\v flags -> flags { dynlibdir = v })
+ dynlibdir
+ (\v flags -> flags{dynlibdir = v})
installDirArg
-
- , option "" ["libexecdir"]
+ , option
+ ""
+ ["libexecdir"]
"installation directory for program executables"
- libexecdir (\v flags -> flags { libexecdir = v })
+ libexecdir
+ (\v flags -> flags{libexecdir = v})
installDirArg
-
- , option "" ["libexecsubdir"]
+ , option
+ ""
+ ["libexecsubdir"]
"subdirectory of libexecdir in which private executables are installed"
- libexecsubdir (\v flags -> flags { libexecsubdir = v })
+ libexecsubdir
+ (\v flags -> flags{libexecsubdir = v})
installDirArg
-
- , option "" ["datadir"]
+ , option
+ ""
+ ["datadir"]
"installation directory for read-only data"
- datadir (\v flags -> flags { datadir = v })
+ datadir
+ (\v flags -> flags{datadir = v})
installDirArg
-
- , option "" ["datasubdir"]
+ , option
+ ""
+ ["datasubdir"]
"subdirectory of datadir in which data files are installed"
- datasubdir (\v flags -> flags { datasubdir = v })
+ datasubdir
+ (\v flags -> flags{datasubdir = v})
installDirArg
-
- , option "" ["docdir"]
+ , option
+ ""
+ ["docdir"]
"installation directory for documentation"
- docdir (\v flags -> flags { docdir = v })
+ docdir
+ (\v flags -> flags{docdir = v})
installDirArg
-
- , option "" ["htmldir"]
+ , option
+ ""
+ ["htmldir"]
"installation directory for HTML documentation"
- htmldir (\v flags -> flags { htmldir = v })
+ htmldir
+ (\v flags -> flags{htmldir = v})
installDirArg
-
- , option "" ["haddockdir"]
+ , option
+ ""
+ ["haddockdir"]
"installation directory for haddock interfaces"
- haddockdir (\v flags -> flags { haddockdir = v })
+ haddockdir
+ (\v flags -> flags{haddockdir = v})
installDirArg
-
- , option "" ["sysconfdir"]
+ , option
+ ""
+ ["sysconfdir"]
"installation directory for configuration files"
- sysconfdir (\v flags -> flags { sysconfdir = v })
+ sysconfdir
+ (\v flags -> flags{sysconfdir = v})
installDirArg
]
where
installDirArg _sf _lf d get set =
- reqArgFlag "DIR" _sf _lf d
- (fmap fromPathTemplate . get) (set . fmap toPathTemplate)
+ reqArgFlag
+ "DIR"
+ _sf
+ _lf
+ d
+ (fmap fromPathTemplate . get)
+ (set . fmap toPathTemplate)
emptyConfigFlags :: ConfigFlags
emptyConfigFlags = mempty
@@ -745,32 +989,35 @@ instance Monoid ConfigFlags where
instance Semigroup ConfigFlags where
(<>) = gmappend
-
-- | Arguments to pass to a @configure@ script, e.g. generated by
-- @autoconf@.
configureArgs :: Bool -> ConfigFlags -> [String]
-configureArgs bcHack flags
- = hc_flag
- ++ optFlag "with-hc-pkg" configHcPkg
- ++ optFlag' "prefix" prefix
- ++ optFlag' "bindir" bindir
- ++ optFlag' "libdir" libdir
- ++ optFlag' "libexecdir" libexecdir
- ++ optFlag' "datadir" datadir
- ++ optFlag' "sysconfdir" sysconfdir
- ++ configConfigureArgs flags
+configureArgs bcHack flags =
+ hc_flag
+ ++ optFlag "with-hc-pkg" configHcPkg
+ ++ optFlag' "prefix" prefix
+ ++ optFlag' "bindir" bindir
+ ++ optFlag' "libdir" libdir
+ ++ optFlag' "libexecdir" libexecdir
+ ++ optFlag' "datadir" datadir
+ ++ optFlag' "sysconfdir" sysconfdir
+ ++ configConfigureArgs flags
where
- hc_flag = case (configHcFlavor flags, configHcPath flags) of
- (_, Flag hc_path) -> [hc_flag_name ++ hc_path]
- (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc]
- (NoFlag,NoFlag) -> []
- hc_flag_name
- --TODO kill off thic bc hack when defaultUserHooks is removed.
- | bcHack = "--with-hc="
- | otherwise = "--with-compiler="
- optFlag name config_field = case config_field flags of
- Flag p -> ["--" ++ name ++ "=" ++ p]
- NoFlag -> []
- optFlag' name config_field = optFlag name (fmap fromPathTemplate
- . config_field
- . configInstallDirs)
+ hc_flag = case (configHcFlavor flags, configHcPath flags) of
+ (_, Flag hc_path) -> [hc_flag_name ++ hc_path]
+ (Flag hc, NoFlag) -> [hc_flag_name ++ prettyShow hc]
+ (NoFlag, NoFlag) -> []
+ hc_flag_name
+ -- TODO kill off thic bc hack when defaultUserHooks is removed.
+ | bcHack = "--with-hc="
+ | otherwise = "--with-compiler="
+ optFlag name config_field = case config_field flags of
+ Flag p -> ["--" ++ name ++ "=" ++ p]
+ NoFlag -> []
+ optFlag' name config_field =
+ optFlag
+ name
+ ( fmap fromPathTemplate
+ . config_field
+ . configInstallDirs
+ )
diff --git a/Cabal/src/Distribution/Simple/Setup/Copy.hs b/Cabal/src/Distribution/Simple/Setup/Copy.hs
index 0da627a734b12629409f3941b46e766dffd2b4f7..56416ddae5d9729e093d5a12e4a8fddb042e22ca 100644
--- a/Cabal/src/Distribution/Simple/Setup/Copy.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Copy.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Copy
-- Copyright : Isaac Jones 2003-2004
@@ -16,99 +17,126 @@
--
-- Definition of the copy command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Copy (
-
- CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand,
+module Distribution.Simple.Setup.Copy
+ ( CopyFlags (..)
+ , emptyCopyFlags
+ , defaultCopyFlags
+ , copyCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
import Distribution.Simple.InstallDirs
+import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Copy flags
+
-- ------------------------------------------------------------
-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity)
-data CopyFlags = CopyFlags {
- copyDest :: Flag CopyDest,
- copyDistPref :: Flag FilePath,
- copyVerbosity :: Flag Verbosity,
- -- This is the same hack as in 'buildArgs'. But I (ezyang) don't
+data CopyFlags = CopyFlags
+ { copyDest :: Flag CopyDest
+ , copyDistPref :: Flag FilePath
+ , copyVerbosity :: Flag Verbosity
+ , -- This is the same hack as in 'buildArgs'. But I (ezyang) don't
-- think it's a hack, it's the right way to make hooks more robust
-- TODO: Stop using this eventually when 'UserHooks' gets changed
- copyArgs :: [String],
- copyCabalFilePath :: Flag FilePath
+ copyArgs :: [String]
+ , copyCabalFilePath :: Flag FilePath
}
deriving (Show, Generic)
defaultCopyFlags :: CopyFlags
-defaultCopyFlags = CopyFlags {
- copyDest = Flag NoCopyDest,
- copyDistPref = NoFlag,
- copyVerbosity = Flag normal,
- copyArgs = [],
- copyCabalFilePath = mempty
- }
+defaultCopyFlags =
+ CopyFlags
+ { copyDest = Flag NoCopyDest
+ , copyDistPref = NoFlag
+ , copyVerbosity = Flag normal
+ , copyArgs = []
+ , copyCabalFilePath = mempty
+ }
copyCommand :: CommandUI CopyFlags
-copyCommand = CommandUI
- { commandName = "copy"
- , commandSynopsis = "Copy the files of all/specific components to install locations."
- , commandDescription = Just $ \_ -> wrapText $
+copyCommand =
+ CommandUI
+ { commandName = "copy"
+ , commandSynopsis = "Copy the files of all/specific components to install locations."
+ , commandDescription = Just $ \_ ->
+ wrapText $
"Components encompass executables and libraries. "
- ++ "Does not call register, and allows a prefix at install time. "
- ++ "Without the --destdir flag, configure determines location.\n"
- , commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " copy "
- ++ " All the components in the package\n"
- ++ " " ++ pname ++ " copy foo "
- ++ " A component (i.e. lib, exe, test suite)"
- , commandUsage = usageAlternatives "copy" $
- [ "[FLAGS]"
- , "COMPONENTS [FLAGS]"
- ]
- , commandDefaultFlags = defaultCopyFlags
- , commandOptions = \showOrParseArgs -> case showOrParseArgs of
- ShowArgs -> filter ((`notElem` ["target-package-db"])
- . optionName) $ copyOptions ShowArgs
- ParseArgs -> copyOptions ParseArgs
-}
-
-copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags]
+ ++ "Does not call register, and allows a prefix at install time. "
+ ++ "Without the --destdir flag, configure determines location.\n"
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " copy "
+ ++ " All the components in the package\n"
+ ++ " "
+ ++ pname
+ ++ " copy foo "
+ ++ " A component (i.e. lib, exe, test suite)"
+ , commandUsage =
+ usageAlternatives "copy" $
+ [ "[FLAGS]"
+ , "COMPONENTS [FLAGS]"
+ ]
+ , commandDefaultFlags = defaultCopyFlags
+ , commandOptions = \showOrParseArgs -> case showOrParseArgs of
+ ShowArgs ->
+ filter
+ ( (`notElem` ["target-package-db"])
+ . optionName
+ )
+ $ copyOptions ShowArgs
+ ParseArgs -> copyOptions ParseArgs
+ }
+
+copyOptions :: ShowOrParseArgs -> [OptionField CopyFlags]
copyOptions showOrParseArgs =
- [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v })
-
- ,optionDistPref
- copyDistPref (\d flags -> flags { copyDistPref = d })
- showOrParseArgs
-
- ,option "" ["destdir"]
- "directory to copy files to, prepended to installation directories"
- copyDest (\v flags -> case copyDest flags of
- Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'."
- _ -> flags { copyDest = v })
- (reqArg "DIR" (succeedReadE (Flag . CopyTo))
- (\f -> case f of Flag (CopyTo p) -> [p]; _ -> []))
-
- ,option "" ["target-package-db"]
- "package database to copy files into. Required when using ${pkgroot} prefix."
- copyDest (\v flags -> case copyDest flags of
- NoFlag -> flags { copyDest = v }
- Flag NoCopyDest -> flags { copyDest = v }
- _ -> error "Use either 'destdir' or 'target-package-db'.")
- (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb))
- (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []))
+ [ optionVerbosity copyVerbosity (\v flags -> flags{copyVerbosity = v})
+ , optionDistPref
+ copyDistPref
+ (\d flags -> flags{copyDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["destdir"]
+ "directory to copy files to, prepended to installation directories"
+ copyDest
+ ( \v flags -> case copyDest flags of
+ Flag (CopyToDb _) -> error "Use either 'destdir' or 'target-package-db'."
+ _ -> flags{copyDest = v}
+ )
+ ( reqArg
+ "DIR"
+ (succeedReadE (Flag . CopyTo))
+ (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])
+ )
+ , option
+ ""
+ ["target-package-db"]
+ "package database to copy files into. Required when using ${pkgroot} prefix."
+ copyDest
+ ( \v flags -> case copyDest flags of
+ NoFlag -> flags{copyDest = v}
+ Flag NoCopyDest -> flags{copyDest = v}
+ _ -> error "Use either 'destdir' or 'target-package-db'."
+ )
+ ( reqArg
+ "DATABASE"
+ (succeedReadE (Flag . CopyToDb))
+ (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])
+ )
]
emptyCopyFlags :: CopyFlags
@@ -120,4 +148,3 @@ instance Monoid CopyFlags where
instance Semigroup CopyFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Global.hs b/Cabal/src/Distribution/Simple/Setup/Global.hs
index 35e7b60f842a2a52d662328fe14749465a2b17ab..c3c8ad9a566031de2037401262b0ee8f792f5535 100644
--- a/Cabal/src/Distribution/Simple/Setup/Global.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Global.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Global
-- Copyright : Isaac Jones 2003-2004
@@ -16,21 +17,24 @@
--
-- Definition of the global command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Global (
- GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand,
+module Distribution.Simple.Setup.Global
+ ( GlobalFlags (..)
+ , emptyGlobalFlags
+ , defaultGlobalFlags
+ , globalCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
import Distribution.Simple.Setup.Common
-
-- ------------------------------------------------------------
+
-- * Global flags
+
-- ------------------------------------------------------------
-- In fact since individual flags types are monoids and these are just sets of
@@ -40,55 +44,72 @@ import Distribution.Simple.Setup.Common
-- override with the ones we get from a file or the command line, or both.
-- | Flags that apply at the top level, not to any sub-command.
-data GlobalFlags = GlobalFlags {
- globalVersion :: Flag Bool,
- globalNumericVersion :: Flag Bool
- } deriving (Generic, Typeable)
+data GlobalFlags = GlobalFlags
+ { globalVersion :: Flag Bool
+ , globalNumericVersion :: Flag Bool
+ }
+ deriving (Generic, Typeable)
defaultGlobalFlags :: GlobalFlags
-defaultGlobalFlags = GlobalFlags {
- globalVersion = Flag False,
- globalNumericVersion = Flag False
- }
+defaultGlobalFlags =
+ GlobalFlags
+ { globalVersion = Flag False
+ , globalNumericVersion = Flag False
+ }
globalCommand :: [Command action] -> CommandUI GlobalFlags
-globalCommand commands = CommandUI
- { commandName = ""
- , commandSynopsis = ""
- , commandUsage = \pname ->
- "This Setup program uses the Haskell Cabal Infrastructure.\n"
- ++ "See http://www.haskell.org/cabal/ for more information.\n"
- ++ "\n"
- ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"
- , commandDescription = Just $ \pname ->
- let
- commands' = commands ++ [commandAddAction helpCommandUI undefined]
- cmdDescs = getNormalCommandDescriptions commands'
- maxlen = maximum $ [length name | (name, _) <- cmdDescs]
- align str = str ++ replicate (maxlen - length str) ' '
- in
- "Commands:\n"
- ++ unlines [ " " ++ align name ++ " " ++ descr
- | (name, descr) <- cmdDescs ]
- ++ "\n"
- ++ "For more information about a command use\n"
- ++ " " ++ pname ++ " COMMAND --help\n\n"
- ++ "Typical steps for installing Cabal packages:\n"
- ++ concat [ " " ++ pname ++ " " ++ x ++ "\n"
- | x <- ["configure", "build", "install"]]
- , commandNotes = Nothing
- , commandDefaultFlags = defaultGlobalFlags
- , commandOptions = \_ ->
- [option ['V'] ["version"]
- "Print version information"
- globalVersion (\v flags -> flags { globalVersion = v })
- trueArg
- ,option [] ["numeric-version"]
- "Print just the version number"
- globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
- trueArg
- ]
- }
+globalCommand commands =
+ CommandUI
+ { commandName = ""
+ , commandSynopsis = ""
+ , commandUsage = \pname ->
+ "This Setup program uses the Haskell Cabal Infrastructure.\n"
+ ++ "See http://www.haskell.org/cabal/ for more information.\n"
+ ++ "\n"
+ ++ "Usage: "
+ ++ pname
+ ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"
+ , commandDescription = Just $ \pname ->
+ let
+ commands' = commands ++ [commandAddAction helpCommandUI undefined]
+ cmdDescs = getNormalCommandDescriptions commands'
+ maxlen = maximum $ [length name | (name, _) <- cmdDescs]
+ align str = str ++ replicate (maxlen - length str) ' '
+ in
+ "Commands:\n"
+ ++ unlines
+ [ " " ++ align name ++ " " ++ descr
+ | (name, descr) <- cmdDescs
+ ]
+ ++ "\n"
+ ++ "For more information about a command use\n"
+ ++ " "
+ ++ pname
+ ++ " COMMAND --help\n\n"
+ ++ "Typical steps for installing Cabal packages:\n"
+ ++ concat
+ [ " " ++ pname ++ " " ++ x ++ "\n"
+ | x <- ["configure", "build", "install"]
+ ]
+ , commandNotes = Nothing
+ , commandDefaultFlags = defaultGlobalFlags
+ , commandOptions = \_ ->
+ [ option
+ ['V']
+ ["version"]
+ "Print version information"
+ globalVersion
+ (\v flags -> flags{globalVersion = v})
+ trueArg
+ , option
+ []
+ ["numeric-version"]
+ "Print just the version number"
+ globalNumericVersion
+ (\v flags -> flags{globalNumericVersion = v})
+ trueArg
+ ]
+ }
emptyGlobalFlags :: GlobalFlags
emptyGlobalFlags = mempty
@@ -99,4 +120,3 @@ instance Monoid GlobalFlags where
instance Semigroup GlobalFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Haddock.hs b/Cabal/src/Distribution/Simple/Setup/Haddock.hs
index 1a35e796bdec2ee2e62f7debadef6b32051a74f0..c1043bbef2de0cbcfd31231914a78168206c7c40 100644
--- a/Cabal/src/Distribution/Simple/Setup/Haddock.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Haddock.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Haddock
-- Copyright : Isaac Jones 2003-2004
@@ -16,35 +17,41 @@
--
-- Definition of the haddock command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Haddock (
-
- HaddockTarget(..),
- HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand,
- Visibility(..),
- HaddockProjectFlags(..), emptyHaddockProjectFlags, defaultHaddockProjectFlags, haddockProjectCommand,
- haddockOptions, haddockProjectOptions,
+module Distribution.Simple.Setup.Haddock
+ ( HaddockTarget (..)
+ , HaddockFlags (..)
+ , emptyHaddockFlags
+ , defaultHaddockFlags
+ , haddockCommand
+ , Visibility (..)
+ , HaddockProjectFlags (..)
+ , emptyHaddockProjectFlags
+ , defaultHaddockProjectFlags
+ , haddockProjectCommand
+ , haddockOptions
+ , haddockProjectOptions
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
+import qualified Distribution.Compat.CharParsing as P
import Distribution.Parsec
import Distribution.Pretty
-import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
-import Distribution.Simple.Program
import Distribution.Simple.InstallDirs
+import Distribution.Simple.Program
import Distribution.Verbosity
+import qualified Text.PrettyPrint as Disp
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Haddock flags
--- ------------------------------------------------------------
+-- ------------------------------------------------------------
-- | When we build haddock documentation, there are two cases:
--
@@ -63,217 +70,284 @@ instance Binary HaddockTarget
instance Structured HaddockTarget
instance Pretty HaddockTarget where
- pretty ForHackage = Disp.text "for-hackage"
- pretty ForDevelopment = Disp.text "for-development"
+ pretty ForHackage = Disp.text "for-hackage"
+ pretty ForDevelopment = Disp.text "for-development"
instance Parsec HaddockTarget where
- parsec = P.choice [ P.try $ P.string "for-hackage" >> return ForHackage
- , P.string "for-development" >> return ForDevelopment]
+ parsec =
+ P.choice
+ [ P.try $ P.string "for-hackage" >> return ForHackage
+ , P.string "for-development" >> return ForDevelopment
+ ]
-data HaddockFlags = HaddockFlags {
- haddockProgramPaths :: [(String, FilePath)],
- haddockProgramArgs :: [(String, [String])],
- haddockHoogle :: Flag Bool,
- haddockHtml :: Flag Bool,
- haddockHtmlLocation :: Flag String,
- haddockForHackage :: Flag HaddockTarget,
- haddockExecutables :: Flag Bool,
- haddockTestSuites :: Flag Bool,
- haddockBenchmarks :: Flag Bool,
- haddockForeignLibs :: Flag Bool,
- haddockInternal :: Flag Bool,
- haddockCss :: Flag FilePath,
- haddockLinkedSource :: Flag Bool,
- haddockQuickJump :: Flag Bool,
- haddockHscolourCss :: Flag FilePath,
- haddockContents :: Flag PathTemplate,
- haddockIndex :: Flag PathTemplate,
- haddockDistPref :: Flag FilePath,
- haddockKeepTempFiles:: Flag Bool,
- haddockVerbosity :: Flag Verbosity,
- haddockCabalFilePath :: Flag FilePath,
- haddockBaseUrl :: Flag String,
- haddockLib :: Flag String,
- haddockOutputDir :: Flag FilePath,
- haddockArgs :: [String]
+data HaddockFlags = HaddockFlags
+ { haddockProgramPaths :: [(String, FilePath)]
+ , haddockProgramArgs :: [(String, [String])]
+ , haddockHoogle :: Flag Bool
+ , haddockHtml :: Flag Bool
+ , haddockHtmlLocation :: Flag String
+ , haddockForHackage :: Flag HaddockTarget
+ , haddockExecutables :: Flag Bool
+ , haddockTestSuites :: Flag Bool
+ , haddockBenchmarks :: Flag Bool
+ , haddockForeignLibs :: Flag Bool
+ , haddockInternal :: Flag Bool
+ , haddockCss :: Flag FilePath
+ , haddockLinkedSource :: Flag Bool
+ , haddockQuickJump :: Flag Bool
+ , haddockHscolourCss :: Flag FilePath
+ , haddockContents :: Flag PathTemplate
+ , haddockIndex :: Flag PathTemplate
+ , haddockDistPref :: Flag FilePath
+ , haddockKeepTempFiles :: Flag Bool
+ , haddockVerbosity :: Flag Verbosity
+ , haddockCabalFilePath :: Flag FilePath
+ , haddockBaseUrl :: Flag String
+ , haddockLib :: Flag String
+ , haddockOutputDir :: Flag FilePath
+ , haddockArgs :: [String]
}
deriving (Show, Generic, Typeable)
defaultHaddockFlags :: HaddockFlags
-defaultHaddockFlags = HaddockFlags {
- haddockProgramPaths = mempty,
- haddockProgramArgs = [],
- haddockHoogle = Flag False,
- haddockHtml = Flag False,
- haddockHtmlLocation = NoFlag,
- haddockForHackage = NoFlag,
- haddockExecutables = Flag False,
- haddockTestSuites = Flag False,
- haddockBenchmarks = Flag False,
- haddockForeignLibs = Flag False,
- haddockInternal = Flag False,
- haddockCss = NoFlag,
- haddockLinkedSource = Flag False,
- haddockQuickJump = Flag False,
- haddockHscolourCss = NoFlag,
- haddockContents = NoFlag,
- haddockDistPref = NoFlag,
- haddockKeepTempFiles= Flag False,
- haddockVerbosity = Flag normal,
- haddockCabalFilePath = mempty,
- haddockIndex = NoFlag,
- haddockBaseUrl = NoFlag,
- haddockLib = NoFlag,
- haddockOutputDir = NoFlag,
- haddockArgs = mempty
- }
+defaultHaddockFlags =
+ HaddockFlags
+ { haddockProgramPaths = mempty
+ , haddockProgramArgs = []
+ , haddockHoogle = Flag False
+ , haddockHtml = Flag False
+ , haddockHtmlLocation = NoFlag
+ , haddockForHackage = NoFlag
+ , haddockExecutables = Flag False
+ , haddockTestSuites = Flag False
+ , haddockBenchmarks = Flag False
+ , haddockForeignLibs = Flag False
+ , haddockInternal = Flag False
+ , haddockCss = NoFlag
+ , haddockLinkedSource = Flag False
+ , haddockQuickJump = Flag False
+ , haddockHscolourCss = NoFlag
+ , haddockContents = NoFlag
+ , haddockDistPref = NoFlag
+ , haddockKeepTempFiles = Flag False
+ , haddockVerbosity = Flag normal
+ , haddockCabalFilePath = mempty
+ , haddockIndex = NoFlag
+ , haddockBaseUrl = NoFlag
+ , haddockLib = NoFlag
+ , haddockOutputDir = NoFlag
+ , haddockArgs = mempty
+ }
haddockCommand :: CommandUI HaddockFlags
-haddockCommand = CommandUI
- { commandName = "haddock"
- , commandSynopsis = "Generate Haddock HTML documentation."
- , commandDescription = Just $ \_ ->
- "Requires the program haddock, version 2.x.\n"
- , commandNotes = Nothing
- , commandUsage = usageAlternatives "haddock" $
- [ "[FLAGS]"
- , "COMPONENTS [FLAGS]"
- ]
- , commandDefaultFlags = defaultHaddockFlags
- , commandOptions = \showOrParseArgs ->
- haddockOptions showOrParseArgs
- ++ programDbPaths progDb ParseArgs
- haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})
- ++ programDbOption progDb showOrParseArgs
- haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })
- ++ programDbOptions progDb ParseArgs
- haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v})
- }
+haddockCommand =
+ CommandUI
+ { commandName = "haddock"
+ , commandSynopsis = "Generate Haddock HTML documentation."
+ , commandDescription = Just $ \_ ->
+ "Requires the program haddock, version 2.x.\n"
+ , commandNotes = Nothing
+ , commandUsage =
+ usageAlternatives "haddock" $
+ [ "[FLAGS]"
+ , "COMPONENTS [FLAGS]"
+ ]
+ , commandDefaultFlags = defaultHaddockFlags
+ , commandOptions = \showOrParseArgs ->
+ haddockOptions showOrParseArgs
+ ++ programDbPaths
+ progDb
+ ParseArgs
+ haddockProgramPaths
+ (\v flags -> flags{haddockProgramPaths = v})
+ ++ programDbOption
+ progDb
+ showOrParseArgs
+ haddockProgramArgs
+ (\v fs -> fs{haddockProgramArgs = v})
+ ++ programDbOptions
+ progDb
+ ParseArgs
+ haddockProgramArgs
+ (\v flags -> flags{haddockProgramArgs = v})
+ }
where
- progDb = addKnownProgram haddockProgram
- $ addKnownProgram ghcProgram
- $ emptyProgramDb
+ progDb =
+ addKnownProgram haddockProgram $
+ addKnownProgram ghcProgram $
+ emptyProgramDb
haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
haddockOptions showOrParseArgs =
- [optionVerbosity haddockVerbosity
- (\v flags -> flags { haddockVerbosity = v })
- ,optionDistPref
- haddockDistPref (\d flags -> flags { haddockDistPref = d })
- showOrParseArgs
-
- ,option "" ["keep-temp-files"]
- "Keep temporary files"
- haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })
- trueArg
-
- ,option "" ["hoogle"]
- "Generate a hoogle database"
- haddockHoogle (\v flags -> flags { haddockHoogle = v })
- trueArg
-
- ,option "" ["html"]
- "Generate HTML documentation (the default)"
- haddockHtml (\v flags -> flags { haddockHtml = v })
- trueArg
-
- ,option "" ["html-location"]
- "Location of HTML documentation for pre-requisite packages"
- haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v })
- (reqArgFlag "URL")
-
- ,option "" ["for-hackage"]
- "Collection of flags to generate documentation suitable for upload to hackage"
- haddockForHackage (\v flags -> flags { haddockForHackage = v })
- (noArg (Flag ForHackage))
-
- ,option "" ["executables"]
- "Run haddock for Executables targets"
- haddockExecutables (\v flags -> flags { haddockExecutables = v })
- trueArg
-
- ,option "" ["tests"]
- "Run haddock for Test Suite targets"
- haddockTestSuites (\v flags -> flags { haddockTestSuites = v })
- trueArg
-
- ,option "" ["benchmarks"]
- "Run haddock for Benchmark targets"
- haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })
- trueArg
-
- ,option "" ["foreign-libraries"]
- "Run haddock for Foreign Library targets"
- haddockForeignLibs (\v flags -> flags { haddockForeignLibs = v })
- trueArg
-
- ,option "" ["all"]
- "Run haddock for all targets"
- (\f -> allFlags [ haddockExecutables f
- , haddockTestSuites f
- , haddockBenchmarks f
- , haddockForeignLibs f
- ])
- (\v flags -> flags { haddockExecutables = v
- , haddockTestSuites = v
- , haddockBenchmarks = v
- , haddockForeignLibs = v
- })
- trueArg
-
- ,option "" ["internal"]
- "Run haddock for internal modules and include all symbols"
- haddockInternal (\v flags -> flags { haddockInternal = v })
- trueArg
-
- ,option "" ["css"]
- "Use PATH as the haddock stylesheet"
- haddockCss (\v flags -> flags { haddockCss = v })
- (reqArgFlag "PATH")
-
- ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"]
- "Hyperlink the documentation to the source code"
- haddockLinkedSource (\v flags -> flags { haddockLinkedSource = v })
- trueArg
-
- ,option "" ["quickjump"]
- "Generate an index for interactive documentation navigation"
- haddockQuickJump (\v flags -> flags { haddockQuickJump = v })
- trueArg
-
- ,option "" ["hscolour-css"]
- "Use PATH as the HsColour stylesheet"
- haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })
- (reqArgFlag "PATH")
-
- ,option "" ["contents-location"]
- "Bake URL in as the location for the contents page"
- haddockContents (\v flags -> flags { haddockContents = v })
- (reqArg' "URL"
- (toFlag . toPathTemplate)
- (flagToList . fmap fromPathTemplate))
-
- ,option "" ["index-location"]
- "Use a separately-generated HTML index"
- haddockIndex (\v flags -> flags { haddockIndex = v})
- (reqArg' "URL"
- (toFlag . toPathTemplate)
- (flagToList . fmap fromPathTemplate))
-
- ,option "" ["base-url"]
- "Base URL for static files."
- haddockBaseUrl (\v flags -> flags { haddockBaseUrl = v})
- (reqArgFlag "URL")
-
- ,option "" ["lib"]
- "location of Haddocks static / auxiliary files"
- haddockLib (\v flags -> flags { haddockLib = v})
- (reqArgFlag "DIR")
-
- ,option "" ["output-dir"]
- "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases."
- haddockOutputDir (\v flags -> flags { haddockOutputDir = v })
- (reqArgFlag "DIR")
+ [ optionVerbosity
+ haddockVerbosity
+ (\v flags -> flags{haddockVerbosity = v})
+ , optionDistPref
+ haddockDistPref
+ (\d flags -> flags{haddockDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["keep-temp-files"]
+ "Keep temporary files"
+ haddockKeepTempFiles
+ (\b flags -> flags{haddockKeepTempFiles = b})
+ trueArg
+ , option
+ ""
+ ["hoogle"]
+ "Generate a hoogle database"
+ haddockHoogle
+ (\v flags -> flags{haddockHoogle = v})
+ trueArg
+ , option
+ ""
+ ["html"]
+ "Generate HTML documentation (the default)"
+ haddockHtml
+ (\v flags -> flags{haddockHtml = v})
+ trueArg
+ , option
+ ""
+ ["html-location"]
+ "Location of HTML documentation for pre-requisite packages"
+ haddockHtmlLocation
+ (\v flags -> flags{haddockHtmlLocation = v})
+ (reqArgFlag "URL")
+ , option
+ ""
+ ["for-hackage"]
+ "Collection of flags to generate documentation suitable for upload to hackage"
+ haddockForHackage
+ (\v flags -> flags{haddockForHackage = v})
+ (noArg (Flag ForHackage))
+ , option
+ ""
+ ["executables"]
+ "Run haddock for Executables targets"
+ haddockExecutables
+ (\v flags -> flags{haddockExecutables = v})
+ trueArg
+ , option
+ ""
+ ["tests"]
+ "Run haddock for Test Suite targets"
+ haddockTestSuites
+ (\v flags -> flags{haddockTestSuites = v})
+ trueArg
+ , option
+ ""
+ ["benchmarks"]
+ "Run haddock for Benchmark targets"
+ haddockBenchmarks
+ (\v flags -> flags{haddockBenchmarks = v})
+ trueArg
+ , option
+ ""
+ ["foreign-libraries"]
+ "Run haddock for Foreign Library targets"
+ haddockForeignLibs
+ (\v flags -> flags{haddockForeignLibs = v})
+ trueArg
+ , option
+ ""
+ ["all"]
+ "Run haddock for all targets"
+ ( \f ->
+ allFlags
+ [ haddockExecutables f
+ , haddockTestSuites f
+ , haddockBenchmarks f
+ , haddockForeignLibs f
+ ]
+ )
+ ( \v flags ->
+ flags
+ { haddockExecutables = v
+ , haddockTestSuites = v
+ , haddockBenchmarks = v
+ , haddockForeignLibs = v
+ }
+ )
+ trueArg
+ , option
+ ""
+ ["internal"]
+ "Run haddock for internal modules and include all symbols"
+ haddockInternal
+ (\v flags -> flags{haddockInternal = v})
+ trueArg
+ , option
+ ""
+ ["css"]
+ "Use PATH as the haddock stylesheet"
+ haddockCss
+ (\v flags -> flags{haddockCss = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["hyperlink-source", "hyperlink-sources", "hyperlinked-source"]
+ "Hyperlink the documentation to the source code"
+ haddockLinkedSource
+ (\v flags -> flags{haddockLinkedSource = v})
+ trueArg
+ , option
+ ""
+ ["quickjump"]
+ "Generate an index for interactive documentation navigation"
+ haddockQuickJump
+ (\v flags -> flags{haddockQuickJump = v})
+ trueArg
+ , option
+ ""
+ ["hscolour-css"]
+ "Use PATH as the HsColour stylesheet"
+ haddockHscolourCss
+ (\v flags -> flags{haddockHscolourCss = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["contents-location"]
+ "Bake URL in as the location for the contents page"
+ haddockContents
+ (\v flags -> flags{haddockContents = v})
+ ( reqArg'
+ "URL"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate)
+ )
+ , option
+ ""
+ ["index-location"]
+ "Use a separately-generated HTML index"
+ haddockIndex
+ (\v flags -> flags{haddockIndex = v})
+ ( reqArg'
+ "URL"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate)
+ )
+ , option
+ ""
+ ["base-url"]
+ "Base URL for static files."
+ haddockBaseUrl
+ (\v flags -> flags{haddockBaseUrl = v})
+ (reqArgFlag "URL")
+ , option
+ ""
+ ["lib"]
+ "location of Haddocks static / auxiliary files"
+ haddockLib
+ (\v flags -> flags{haddockLib = v})
+ (reqArgFlag "DIR")
+ , option
+ ""
+ ["output-dir"]
+ "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases."
+ haddockOutputDir
+ (\v flags -> flags{haddockOutputDir = v})
+ (reqArgFlag "DIR")
]
emptyHaddockFlags :: HaddockFlags
@@ -287,240 +361,296 @@ instance Semigroup HaddockFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * HaddocksFlags flags
+
-- ------------------------------------------------------------
-- | Governs whether modules from a given interface should be visible or
-- hidden in the Haddock generated content page. We don't expose this
-- functionality to the user, but simply use 'Visible' for only local packages.
-- Visibility of modules is available since @haddock-2.26.1@.
---
data Visibility = Visible | Hidden
deriving (Eq, Show)
-data HaddockProjectFlags = HaddockProjectFlags {
- haddockProjectHackage :: Flag Bool,
- -- ^ a shortcut option which builds documentation linked to hackage. It implies:
- -- * `--html-location='https://hackage.haskell.org/package/$prg-$version/docs'
- -- * `--quickjump`
- -- * `--gen-index`
- -- * `--gen-contents`
- -- * `--hyperlinked-source`
- haddockProjectLocal :: Flag Bool,
- -- ^ a shortcut option which builds self contained directory which contains
- -- all the documentation, it implies:
- -- * `--quickjump`
- -- * `--gen-index`
- -- * `--gen-contents`
- -- * `--hyperlinked-source`
- --
- -- And it will also pass `--base-url` option to `haddock`.
-
- -- options passed to @haddock@ via 'createHaddockIndex'
- haddockProjectDir :: Flag String,
- -- ^ output directory of combined haddocks, the default is './haddocks'
- haddockProjectPrologue :: Flag String,
- haddockProjectGenIndex :: Flag Bool,
- haddockProjectGenContents :: Flag Bool,
- haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)],
- -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not
- -- exposed to the user.
-
- -- options passed to @haddock@ via 'HaddockFlags' when building
+data HaddockProjectFlags = HaddockProjectFlags
+ { haddockProjectHackage :: Flag Bool
+ -- ^ a shortcut option which builds documentation linked to hackage. It implies:
+ -- * `--html-location='https://hackage.haskell.org/package/$prg-$version/docs'
+ -- * `--quickjump`
+ -- * `--gen-index`
+ -- * `--gen-contents`
+ -- * `--hyperlinked-source`
+ , haddockProjectLocal :: Flag Bool
+ -- ^ a shortcut option which builds self contained directory which contains
+ -- all the documentation, it implies:
+ -- * `--quickjump`
+ -- * `--gen-index`
+ -- * `--gen-contents`
+ -- * `--hyperlinked-source`
+ --
+ -- And it will also pass `--base-url` option to `haddock`.
+ , -- options passed to @haddock@ via 'createHaddockIndex'
+ haddockProjectDir :: Flag String
+ -- ^ output directory of combined haddocks, the default is './haddocks'
+ , haddockProjectPrologue :: Flag String
+ , haddockProjectGenIndex :: Flag Bool
+ , haddockProjectGenContents :: Flag Bool
+ , haddockProjectInterfaces :: Flag [(FilePath, Maybe FilePath, Maybe FilePath, Visibility)]
+ -- ^ 'haddocksInterfaces' is inferred by the 'haddocksAction'; currently not
+ -- exposed to the user.
+ , -- options passed to @haddock@ via 'HaddockFlags' when building
-- documentation
- haddockProjectProgramPaths :: [(String, FilePath)],
- haddockProjectProgramArgs :: [(String, [String])],
- haddockProjectHoogle :: Flag Bool,
- -- haddockHtml is not supported
- haddockProjectHtmlLocation :: Flag String,
- -- haddockForHackage is not supported
- haddockProjectExecutables :: Flag Bool,
- haddockProjectTestSuites :: Flag Bool,
- haddockProjectBenchmarks :: Flag Bool,
- haddockProjectForeignLibs :: Flag Bool,
- haddockProjectInternal :: Flag Bool,
- haddockProjectCss :: Flag FilePath,
- haddockProjectLinkedSource :: Flag Bool,
- haddockProjectQuickJump :: Flag Bool,
- haddockProjectHscolourCss :: Flag FilePath,
- -- haddockContent is not supported, a fixed value is provided
+ haddockProjectProgramPaths :: [(String, FilePath)]
+ , haddockProjectProgramArgs :: [(String, [String])]
+ , haddockProjectHoogle :: Flag Bool
+ , -- haddockHtml is not supported
+ haddockProjectHtmlLocation :: Flag String
+ , -- haddockForHackage is not supported
+ haddockProjectExecutables :: Flag Bool
+ , haddockProjectTestSuites :: Flag Bool
+ , haddockProjectBenchmarks :: Flag Bool
+ , haddockProjectForeignLibs :: Flag Bool
+ , haddockProjectInternal :: Flag Bool
+ , haddockProjectCss :: Flag FilePath
+ , haddockProjectLinkedSource :: Flag Bool
+ , haddockProjectQuickJump :: Flag Bool
+ , haddockProjectHscolourCss :: Flag FilePath
+ , -- haddockContent is not supported, a fixed value is provided
-- haddockIndex is not supported, a fixed value is provided
-- haddockDistPerf is not supported, note: it changes location of the haddocks
- haddockProjectKeepTempFiles:: Flag Bool,
- haddockProjectVerbosity :: Flag Verbosity,
- -- haddockBaseUrl is not supported, a fixed value is provided
- haddockProjectLib :: Flag String,
- haddockProjectOutputDir :: Flag FilePath
+ haddockProjectKeepTempFiles :: Flag Bool
+ , haddockProjectVerbosity :: Flag Verbosity
+ , -- haddockBaseUrl is not supported, a fixed value is provided
+ haddockProjectLib :: Flag String
+ , haddockProjectOutputDir :: Flag FilePath
}
deriving (Show, Generic, Typeable)
defaultHaddockProjectFlags :: HaddockProjectFlags
-defaultHaddockProjectFlags = HaddockProjectFlags {
- haddockProjectHackage = Flag False,
- haddockProjectLocal = Flag False,
- haddockProjectDir = Flag "./haddocks",
- haddockProjectPrologue = NoFlag,
- haddockProjectGenIndex = Flag False,
- haddockProjectGenContents = Flag False,
- haddockProjectTestSuites = Flag False,
- haddockProjectProgramPaths = mempty,
- haddockProjectProgramArgs = mempty,
- haddockProjectHoogle = Flag False,
- haddockProjectHtmlLocation = NoFlag,
- haddockProjectExecutables = Flag False,
- haddockProjectBenchmarks = Flag False,
- haddockProjectForeignLibs = Flag False,
- haddockProjectInternal = Flag False,
- haddockProjectCss = NoFlag,
- haddockProjectLinkedSource = Flag False,
- haddockProjectQuickJump = Flag False,
- haddockProjectHscolourCss = NoFlag,
- haddockProjectKeepTempFiles= Flag False,
- haddockProjectVerbosity = Flag normal,
- haddockProjectLib = NoFlag,
- haddockProjectOutputDir = NoFlag,
- haddockProjectInterfaces = NoFlag
- }
+defaultHaddockProjectFlags =
+ HaddockProjectFlags
+ { haddockProjectHackage = Flag False
+ , haddockProjectLocal = Flag False
+ , haddockProjectDir = Flag "./haddocks"
+ , haddockProjectPrologue = NoFlag
+ , haddockProjectGenIndex = Flag False
+ , haddockProjectGenContents = Flag False
+ , haddockProjectTestSuites = Flag False
+ , haddockProjectProgramPaths = mempty
+ , haddockProjectProgramArgs = mempty
+ , haddockProjectHoogle = Flag False
+ , haddockProjectHtmlLocation = NoFlag
+ , haddockProjectExecutables = Flag False
+ , haddockProjectBenchmarks = Flag False
+ , haddockProjectForeignLibs = Flag False
+ , haddockProjectInternal = Flag False
+ , haddockProjectCss = NoFlag
+ , haddockProjectLinkedSource = Flag False
+ , haddockProjectQuickJump = Flag False
+ , haddockProjectHscolourCss = NoFlag
+ , haddockProjectKeepTempFiles = Flag False
+ , haddockProjectVerbosity = Flag normal
+ , haddockProjectLib = NoFlag
+ , haddockProjectOutputDir = NoFlag
+ , haddockProjectInterfaces = NoFlag
+ }
haddockProjectCommand :: CommandUI HaddockProjectFlags
-haddockProjectCommand = CommandUI
- { commandName = "v2-haddock-project"
- , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project."
- , commandDescription = Just $ \_ ->
- "Require the programm haddock, version 2.26.\n"
- , commandNotes = Nothing
- , commandUsage = usageAlternatives "haddocks" $
- [ "[FLAGS]"
- , "COMPONENTS [FLAGS]"
- ]
- , commandDefaultFlags = defaultHaddockProjectFlags
- , commandOptions = \showOrParseArgs ->
- haddockProjectOptions showOrParseArgs
- ++ programDbPaths progDb ParseArgs
- haddockProjectProgramPaths (\v flags -> flags { haddockProjectProgramPaths = v})
- ++ programDbOption progDb showOrParseArgs
- haddockProjectProgramArgs (\v fs -> fs { haddockProjectProgramArgs = v })
- ++ programDbOptions progDb ParseArgs
- haddockProjectProgramArgs (\v flags -> flags { haddockProjectProgramArgs = v})
- }
+haddockProjectCommand =
+ CommandUI
+ { commandName = "v2-haddock-project"
+ , commandSynopsis = "Generate Haddocks HTML documentation for the cabal project."
+ , commandDescription = Just $ \_ ->
+ "Require the programm haddock, version 2.26.\n"
+ , commandNotes = Nothing
+ , commandUsage =
+ usageAlternatives "haddocks" $
+ [ "[FLAGS]"
+ , "COMPONENTS [FLAGS]"
+ ]
+ , commandDefaultFlags = defaultHaddockProjectFlags
+ , commandOptions = \showOrParseArgs ->
+ haddockProjectOptions showOrParseArgs
+ ++ programDbPaths
+ progDb
+ ParseArgs
+ haddockProjectProgramPaths
+ (\v flags -> flags{haddockProjectProgramPaths = v})
+ ++ programDbOption
+ progDb
+ showOrParseArgs
+ haddockProjectProgramArgs
+ (\v fs -> fs{haddockProjectProgramArgs = v})
+ ++ programDbOptions
+ progDb
+ ParseArgs
+ haddockProjectProgramArgs
+ (\v flags -> flags{haddockProjectProgramArgs = v})
+ }
where
- progDb = addKnownProgram haddockProgram
- $ addKnownProgram ghcProgram
- $ emptyProgramDb
+ progDb =
+ addKnownProgram haddockProgram $
+ addKnownProgram ghcProgram $
+ emptyProgramDb
haddockProjectOptions :: ShowOrParseArgs -> [OptionField HaddockProjectFlags]
haddockProjectOptions _showOrParseArgs =
- [option "" ["hackage"]
- (concat ["A short-cut option to build documentation linked to hackage; "
- ,"it implies --quickjump, --gen-index, --gen-contents, "
- ,"--hyperlinked-source and --html-location"
- ])
- haddockProjectHackage (\v flags -> flags { haddockProjectHackage = v })
- trueArg
-
- ,option "" ["local"]
- (concat ["A short-cut option to build self contained documentation; "
- ,"it implies --quickjump, --gen-index, --gen-contents "
- ,"and --hyperlinked-source."
- ])
- haddockProjectLocal (\v flags -> flags { haddockProjectLocal = v })
- trueArg
-
- ,option "" ["output"]
+ [ option
+ ""
+ ["hackage"]
+ ( concat
+ [ "A short-cut option to build documentation linked to hackage; "
+ , "it implies --quickjump, --gen-index, --gen-contents, "
+ , "--hyperlinked-source and --html-location"
+ ]
+ )
+ haddockProjectHackage
+ (\v flags -> flags{haddockProjectHackage = v})
+ trueArg
+ , option
+ ""
+ ["local"]
+ ( concat
+ [ "A short-cut option to build self contained documentation; "
+ , "it implies --quickjump, --gen-index, --gen-contents "
+ , "and --hyperlinked-source."
+ ]
+ )
+ haddockProjectLocal
+ (\v flags -> flags{haddockProjectLocal = v})
+ trueArg
+ , option
+ ""
+ ["output"]
"Output directory"
- haddockProjectDir (\v flags -> flags { haddockProjectDir = v })
+ haddockProjectDir
+ (\v flags -> flags{haddockProjectDir = v})
(optArg' "DIRECTORY" maybeToFlag (fmap Just . flagToList))
-
- ,option "" ["prologue"]
- "File path to a prologue file in haddock format"
- haddockProjectPrologue (\v flags -> flags { haddockProjectPrologue = v})
- (optArg' "PATH" maybeToFlag (fmap Just . flagToList))
-
- ,option "" ["gen-index"]
- "Generate index"
- haddockProjectGenIndex (\v flags -> flags { haddockProjectGenIndex = v})
- trueArg
-
- ,option "" ["gen-contents"]
- "Generate contents"
- haddockProjectGenContents (\v flags -> flags { haddockProjectGenContents = v})
- trueArg
-
- ,option "" ["hoogle"]
- "Generate a hoogle database"
- haddockProjectHoogle (\v flags -> flags { haddockProjectHoogle = v })
- trueArg
-
- ,option "" ["html-location"]
- "Location of HTML documentation for pre-requisite packages"
- haddockProjectHtmlLocation (\v flags -> flags { haddockProjectHtmlLocation = v })
- (reqArgFlag "URL")
-
- ,option "" ["executables"]
- "Run haddock for Executables targets"
- haddockProjectExecutables (\v flags -> flags { haddockProjectExecutables = v })
- trueArg
-
- ,option "" ["tests"]
- "Run haddock for Test Suite targets"
- haddockProjectTestSuites (\v flags -> flags { haddockProjectTestSuites = v })
- trueArg
-
- ,option "" ["benchmarks"]
- "Run haddock for Benchmark targets"
- haddockProjectBenchmarks (\v flags -> flags { haddockProjectBenchmarks = v })
- trueArg
-
- ,option "" ["foreign-libraries"]
- "Run haddock for Foreign Library targets"
- haddockProjectForeignLibs (\v flags -> flags { haddockProjectForeignLibs = v })
- trueArg
-
- ,option "" ["internal"]
- "Run haddock for internal modules and include all symbols"
- haddockProjectInternal (\v flags -> flags { haddockProjectInternal = v })
- trueArg
-
- ,option "" ["css"]
- "Use PATH as the haddock stylesheet"
- haddockProjectCss (\v flags -> flags { haddockProjectCss = v })
- (reqArgFlag "PATH")
-
- ,option "" ["hyperlink-source","hyperlink-sources","hyperlinked-source"]
- "Hyperlink the documentation to the source code"
- haddockProjectLinkedSource (\v flags -> flags { haddockProjectLinkedSource = v })
- trueArg
-
- ,option "" ["quickjump"]
- "Generate an index for interactive documentation navigation"
- haddockProjectQuickJump (\v flags -> flags { haddockProjectQuickJump = v })
- trueArg
-
- ,option "" ["hscolour-css"]
- "Use PATH as the HsColour stylesheet"
- haddockProjectHscolourCss (\v flags -> flags { haddockProjectHscolourCss = v })
- (reqArgFlag "PATH")
-
- ,option "" ["keep-temp-files"]
- "Keep temporary files"
- haddockProjectKeepTempFiles (\b flags -> flags { haddockProjectKeepTempFiles = b })
- trueArg
-
- ,optionVerbosity haddockProjectVerbosity
- (\v flags -> flags { haddockProjectVerbosity = v })
-
- ,option "" ["lib"]
- "location of Haddocks static / auxiliary files"
- haddockProjectLib (\v flags -> flags { haddockProjectLib = v})
- (reqArgFlag "DIR")
-
- ,option "" ["output-dir"]
- "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases."
- haddockProjectOutputDir (\v flags -> flags { haddockProjectOutputDir = v})
- (reqArgFlag "DIR")
- ]
-
+ , option
+ ""
+ ["prologue"]
+ "File path to a prologue file in haddock format"
+ haddockProjectPrologue
+ (\v flags -> flags{haddockProjectPrologue = v})
+ (optArg' "PATH" maybeToFlag (fmap Just . flagToList))
+ , option
+ ""
+ ["gen-index"]
+ "Generate index"
+ haddockProjectGenIndex
+ (\v flags -> flags{haddockProjectGenIndex = v})
+ trueArg
+ , option
+ ""
+ ["gen-contents"]
+ "Generate contents"
+ haddockProjectGenContents
+ (\v flags -> flags{haddockProjectGenContents = v})
+ trueArg
+ , option
+ ""
+ ["hoogle"]
+ "Generate a hoogle database"
+ haddockProjectHoogle
+ (\v flags -> flags{haddockProjectHoogle = v})
+ trueArg
+ , option
+ ""
+ ["html-location"]
+ "Location of HTML documentation for pre-requisite packages"
+ haddockProjectHtmlLocation
+ (\v flags -> flags{haddockProjectHtmlLocation = v})
+ (reqArgFlag "URL")
+ , option
+ ""
+ ["executables"]
+ "Run haddock for Executables targets"
+ haddockProjectExecutables
+ (\v flags -> flags{haddockProjectExecutables = v})
+ trueArg
+ , option
+ ""
+ ["tests"]
+ "Run haddock for Test Suite targets"
+ haddockProjectTestSuites
+ (\v flags -> flags{haddockProjectTestSuites = v})
+ trueArg
+ , option
+ ""
+ ["benchmarks"]
+ "Run haddock for Benchmark targets"
+ haddockProjectBenchmarks
+ (\v flags -> flags{haddockProjectBenchmarks = v})
+ trueArg
+ , option
+ ""
+ ["foreign-libraries"]
+ "Run haddock for Foreign Library targets"
+ haddockProjectForeignLibs
+ (\v flags -> flags{haddockProjectForeignLibs = v})
+ trueArg
+ , option
+ ""
+ ["internal"]
+ "Run haddock for internal modules and include all symbols"
+ haddockProjectInternal
+ (\v flags -> flags{haddockProjectInternal = v})
+ trueArg
+ , option
+ ""
+ ["css"]
+ "Use PATH as the haddock stylesheet"
+ haddockProjectCss
+ (\v flags -> flags{haddockProjectCss = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["hyperlink-source", "hyperlink-sources", "hyperlinked-source"]
+ "Hyperlink the documentation to the source code"
+ haddockProjectLinkedSource
+ (\v flags -> flags{haddockProjectLinkedSource = v})
+ trueArg
+ , option
+ ""
+ ["quickjump"]
+ "Generate an index for interactive documentation navigation"
+ haddockProjectQuickJump
+ (\v flags -> flags{haddockProjectQuickJump = v})
+ trueArg
+ , option
+ ""
+ ["hscolour-css"]
+ "Use PATH as the HsColour stylesheet"
+ haddockProjectHscolourCss
+ (\v flags -> flags{haddockProjectHscolourCss = v})
+ (reqArgFlag "PATH")
+ , option
+ ""
+ ["keep-temp-files"]
+ "Keep temporary files"
+ haddockProjectKeepTempFiles
+ (\b flags -> flags{haddockProjectKeepTempFiles = b})
+ trueArg
+ , optionVerbosity
+ haddockProjectVerbosity
+ (\v flags -> flags{haddockProjectVerbosity = v})
+ , option
+ ""
+ ["lib"]
+ "location of Haddocks static / auxiliary files"
+ haddockProjectLib
+ (\v flags -> flags{haddockProjectLib = v})
+ (reqArgFlag "DIR")
+ , option
+ ""
+ ["output-dir"]
+ "Generate haddock documentation into this directory. This flag is provided as a technology preview and is subject to change in the next releases."
+ haddockProjectOutputDir
+ (\v flags -> flags{haddockProjectOutputDir = v})
+ (reqArgFlag "DIR")
+ ]
emptyHaddockProjectFlags :: HaddockProjectFlags
emptyHaddockProjectFlags = mempty
@@ -531,4 +661,3 @@ instance Monoid HaddockProjectFlags where
instance Semigroup HaddockProjectFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Hscolour.hs b/Cabal/src/Distribution/Simple/Setup/Hscolour.hs
index 44debdad5ca9d0ae479c337ce90c9385efebde5a..6b5e2761133a0a4629db41988ae2a03d86a8cd34 100644
--- a/Cabal/src/Distribution/Simple/Setup/Hscolour.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Hscolour.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Hscolour
-- Copyright : Isaac Jones 2003-2004
@@ -16,14 +17,15 @@
--
-- Definition of the hscolour command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Hscolour (
-
- HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,
+module Distribution.Simple.Setup.Hscolour
+ ( HscolourFlags (..)
+ , emptyHscolourFlags
+ , defaultHscolourFlags
+ , hscolourCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
@@ -32,35 +34,38 @@ import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * HsColour flags
+
-- ------------------------------------------------------------
-data HscolourFlags = HscolourFlags {
- hscolourCSS :: Flag FilePath,
- hscolourExecutables :: Flag Bool,
- hscolourTestSuites :: Flag Bool,
- hscolourBenchmarks :: Flag Bool,
- hscolourForeignLibs :: Flag Bool,
- hscolourDistPref :: Flag FilePath,
- hscolourVerbosity :: Flag Verbosity,
- hscolourCabalFilePath :: Flag FilePath
- }
+data HscolourFlags = HscolourFlags
+ { hscolourCSS :: Flag FilePath
+ , hscolourExecutables :: Flag Bool
+ , hscolourTestSuites :: Flag Bool
+ , hscolourBenchmarks :: Flag Bool
+ , hscolourForeignLibs :: Flag Bool
+ , hscolourDistPref :: Flag FilePath
+ , hscolourVerbosity :: Flag Verbosity
+ , hscolourCabalFilePath :: Flag FilePath
+ }
deriving (Show, Generic, Typeable)
emptyHscolourFlags :: HscolourFlags
emptyHscolourFlags = mempty
defaultHscolourFlags :: HscolourFlags
-defaultHscolourFlags = HscolourFlags {
- hscolourCSS = NoFlag,
- hscolourExecutables = Flag False,
- hscolourTestSuites = Flag False,
- hscolourBenchmarks = Flag False,
- hscolourDistPref = NoFlag,
- hscolourForeignLibs = Flag False,
- hscolourVerbosity = Flag normal,
- hscolourCabalFilePath = mempty
- }
+defaultHscolourFlags =
+ HscolourFlags
+ { hscolourCSS = NoFlag
+ , hscolourExecutables = Flag False
+ , hscolourTestSuites = Flag False
+ , hscolourBenchmarks = Flag False
+ , hscolourDistPref = NoFlag
+ , hscolourForeignLibs = Flag False
+ , hscolourVerbosity = Flag normal
+ , hscolourCabalFilePath = mempty
+ }
instance Monoid HscolourFlags where
mempty = gmempty
@@ -70,61 +75,80 @@ instance Semigroup HscolourFlags where
(<>) = gmappend
hscolourCommand :: CommandUI HscolourFlags
-hscolourCommand = CommandUI
- { commandName = "hscolour"
- , commandSynopsis =
- "Generate HsColour colourised code, in HTML format."
- , commandDescription = Just (\_ -> "Requires the hscolour program.\n")
- , commandNotes = Just $ \_ ->
- "Deprecated in favour of 'cabal haddock --hyperlink-source'."
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " hscolour [FLAGS]\n"
- , commandDefaultFlags = defaultHscolourFlags
- , commandOptions = \showOrParseArgs ->
- [optionVerbosity hscolourVerbosity
- (\v flags -> flags { hscolourVerbosity = v })
- ,optionDistPref
- hscolourDistPref (\d flags -> flags { hscolourDistPref = d })
- showOrParseArgs
-
- ,option "" ["executables"]
- "Run hscolour for Executables targets"
- hscolourExecutables (\v flags -> flags { hscolourExecutables = v })
- trueArg
-
- ,option "" ["tests"]
- "Run hscolour for Test Suite targets"
- hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })
- trueArg
-
- ,option "" ["benchmarks"]
- "Run hscolour for Benchmark targets"
- hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })
- trueArg
-
- ,option "" ["foreign-libraries"]
- "Run hscolour for Foreign Library targets"
- hscolourForeignLibs (\v flags -> flags { hscolourForeignLibs = v })
- trueArg
-
- ,option "" ["all"]
- "Run hscolour for all targets"
- (\f -> allFlags [ hscolourExecutables f
- , hscolourTestSuites f
- , hscolourBenchmarks f
- , hscolourForeignLibs f
- ])
- (\v flags -> flags { hscolourExecutables = v
- , hscolourTestSuites = v
- , hscolourBenchmarks = v
- , hscolourForeignLibs = v
- })
- trueArg
-
- ,option "" ["css"]
- "Use a cascading style sheet"
- hscolourCSS (\v flags -> flags { hscolourCSS = v })
- (reqArgFlag "PATH")
- ]
- }
-
+hscolourCommand =
+ CommandUI
+ { commandName = "hscolour"
+ , commandSynopsis =
+ "Generate HsColour colourised code, in HTML format."
+ , commandDescription = Just (\_ -> "Requires the hscolour program.\n")
+ , commandNotes = Just $ \_ ->
+ "Deprecated in favour of 'cabal haddock --hyperlink-source'."
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " hscolour [FLAGS]\n"
+ , commandDefaultFlags = defaultHscolourFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity
+ hscolourVerbosity
+ (\v flags -> flags{hscolourVerbosity = v})
+ , optionDistPref
+ hscolourDistPref
+ (\d flags -> flags{hscolourDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["executables"]
+ "Run hscolour for Executables targets"
+ hscolourExecutables
+ (\v flags -> flags{hscolourExecutables = v})
+ trueArg
+ , option
+ ""
+ ["tests"]
+ "Run hscolour for Test Suite targets"
+ hscolourTestSuites
+ (\v flags -> flags{hscolourTestSuites = v})
+ trueArg
+ , option
+ ""
+ ["benchmarks"]
+ "Run hscolour for Benchmark targets"
+ hscolourBenchmarks
+ (\v flags -> flags{hscolourBenchmarks = v})
+ trueArg
+ , option
+ ""
+ ["foreign-libraries"]
+ "Run hscolour for Foreign Library targets"
+ hscolourForeignLibs
+ (\v flags -> flags{hscolourForeignLibs = v})
+ trueArg
+ , option
+ ""
+ ["all"]
+ "Run hscolour for all targets"
+ ( \f ->
+ allFlags
+ [ hscolourExecutables f
+ , hscolourTestSuites f
+ , hscolourBenchmarks f
+ , hscolourForeignLibs f
+ ]
+ )
+ ( \v flags ->
+ flags
+ { hscolourExecutables = v
+ , hscolourTestSuites = v
+ , hscolourBenchmarks = v
+ , hscolourForeignLibs = v
+ }
+ )
+ trueArg
+ , option
+ ""
+ ["css"]
+ "Use a cascading style sheet"
+ hscolourCSS
+ (\v flags -> flags{hscolourCSS = v})
+ (reqArgFlag "PATH")
+ ]
+ }
diff --git a/Cabal/src/Distribution/Simple/Setup/Install.hs b/Cabal/src/Distribution/Simple/Setup/Install.hs
index 5465164284f63fcc0c47920644958a33994aabdb..b038a18a0b140e61a63bd880c583494c185a9edf 100644
--- a/Cabal/src/Distribution/Simple/Setup/Install.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Install.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Install
-- Copyright : Isaac Jones 2003-2004
@@ -16,100 +17,134 @@
--
-- Definition of the install command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Install (
- InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand,
+module Distribution.Simple.Setup.Install
+ ( InstallFlags (..)
+ , emptyInstallFlags
+ , defaultInstallFlags
+ , installCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
import Distribution.Simple.InstallDirs
+import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Install flags
+
-- ------------------------------------------------------------
-- | Flags to @install@: (package db, verbosity)
-data InstallFlags = InstallFlags {
- installPackageDB :: Flag PackageDB,
- installDest :: Flag CopyDest,
- installDistPref :: Flag FilePath,
- installUseWrapper :: Flag Bool,
- installInPlace :: Flag Bool,
- installVerbosity :: Flag Verbosity,
- -- this is only here, because we can not
+data InstallFlags = InstallFlags
+ { installPackageDB :: Flag PackageDB
+ , installDest :: Flag CopyDest
+ , installDistPref :: Flag FilePath
+ , installUseWrapper :: Flag Bool
+ , installInPlace :: Flag Bool
+ , installVerbosity :: Flag Verbosity
+ , -- this is only here, because we can not
-- change the hooks API.
installCabalFilePath :: Flag FilePath
}
deriving (Show, Generic)
defaultInstallFlags :: InstallFlags
-defaultInstallFlags = InstallFlags {
- installPackageDB = NoFlag,
- installDest = Flag NoCopyDest,
- installDistPref = NoFlag,
- installUseWrapper = Flag False,
- installInPlace = Flag False,
- installVerbosity = Flag normal,
- installCabalFilePath = mempty
- }
+defaultInstallFlags =
+ InstallFlags
+ { installPackageDB = NoFlag
+ , installDest = Flag NoCopyDest
+ , installDistPref = NoFlag
+ , installUseWrapper = Flag False
+ , installInPlace = Flag False
+ , installVerbosity = Flag normal
+ , installCabalFilePath = mempty
+ }
installCommand :: CommandUI InstallFlags
-installCommand = CommandUI
- { commandName = "install"
- , commandSynopsis =
- "Copy the files into the install locations. Run register."
- , commandDescription = Just $ \_ -> wrapText $
- "Unlike the copy command, install calls the register command."
- ++ "If you want to install into a location that is not what was"
- ++ "specified in the configure step, use the copy command.\n"
- , commandNotes = Nothing
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " install [FLAGS]\n"
- , commandDefaultFlags = defaultInstallFlags
- , commandOptions = \showOrParseArgs -> case showOrParseArgs of
- ShowArgs -> filter ((`notElem` ["target-package-db"])
- . optionName) $ installOptions ShowArgs
- ParseArgs -> installOptions ParseArgs
- }
-
-installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]
+installCommand =
+ CommandUI
+ { commandName = "install"
+ , commandSynopsis =
+ "Copy the files into the install locations. Run register."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Unlike the copy command, install calls the register command."
+ ++ "If you want to install into a location that is not what was"
+ ++ "specified in the configure step, use the copy command.\n"
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " install [FLAGS]\n"
+ , commandDefaultFlags = defaultInstallFlags
+ , commandOptions = \showOrParseArgs -> case showOrParseArgs of
+ ShowArgs ->
+ filter
+ ( (`notElem` ["target-package-db"])
+ . optionName
+ )
+ $ installOptions ShowArgs
+ ParseArgs -> installOptions ParseArgs
+ }
+
+installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
- [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v })
- ,optionDistPref
- installDistPref (\d flags -> flags { installDistPref = d })
- showOrParseArgs
-
- ,option "" ["inplace"]
- "install the package in the install subdirectory of the dist prefix, so it can be used without being installed"
- installInPlace (\v flags -> flags { installInPlace = v })
- trueArg
-
- ,option "" ["shell-wrappers"]
- "using shell script wrappers around executables"
- installUseWrapper (\v flags -> flags { installUseWrapper = v })
- (boolOpt [] [])
-
- ,option "" ["package-db"] ""
- installPackageDB (\v flags -> flags { installPackageDB = v })
- (choiceOpt [ (Flag UserPackageDB, ([],["user"]),
- "upon configuration register this package in the user's local package database")
- , (Flag GlobalPackageDB, ([],["global"]),
- "(default) upon configuration register this package in the system-wide package database")])
- ,option "" ["target-package-db"]
- "package database to install into. Required when using ${pkgroot} prefix."
- installDest (\v flags -> flags { installDest = v })
- (reqArg "DATABASE" (succeedReadE (Flag . CopyToDb))
- (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> []))
+ [ optionVerbosity installVerbosity (\v flags -> flags{installVerbosity = v})
+ , optionDistPref
+ installDistPref
+ (\d flags -> flags{installDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["inplace"]
+ "install the package in the install subdirectory of the dist prefix, so it can be used without being installed"
+ installInPlace
+ (\v flags -> flags{installInPlace = v})
+ trueArg
+ , option
+ ""
+ ["shell-wrappers"]
+ "using shell script wrappers around executables"
+ installUseWrapper
+ (\v flags -> flags{installUseWrapper = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["package-db"]
+ ""
+ installPackageDB
+ (\v flags -> flags{installPackageDB = v})
+ ( choiceOpt
+ [
+ ( Flag UserPackageDB
+ , ([], ["user"])
+ , "upon configuration register this package in the user's local package database"
+ )
+ ,
+ ( Flag GlobalPackageDB
+ , ([], ["global"])
+ , "(default) upon configuration register this package in the system-wide package database"
+ )
+ ]
+ )
+ , option
+ ""
+ ["target-package-db"]
+ "package database to install into. Required when using ${pkgroot} prefix."
+ installDest
+ (\v flags -> flags{installDest = v})
+ ( reqArg
+ "DATABASE"
+ (succeedReadE (Flag . CopyToDb))
+ (\f -> case f of Flag (CopyToDb p) -> [p]; _ -> [])
+ )
]
emptyInstallFlags :: InstallFlags
@@ -121,4 +156,3 @@ instance Monoid InstallFlags where
instance Semigroup InstallFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Register.hs b/Cabal/src/Distribution/Simple/Setup/Register.hs
index 2211bbc9a83d8b14e2542c44712a7cb46ee5d6da..ee1fc0d587bfa6266685f3bb1560fa8639b8d66d 100644
--- a/Cabal/src/Distribution/Simple/Setup/Register.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Register.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Register
-- Copyright : Isaac Jones 2003-2004
@@ -16,14 +17,16 @@
--
-- Definition of the register command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Register (
- RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,
- unregisterCommand,
+module Distribution.Simple.Setup.Register
+ ( RegisterFlags (..)
+ , emptyRegisterFlags
+ , defaultRegisterFlags
+ , registerCommand
+ , unregisterCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Compiler
@@ -33,112 +36,153 @@ import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Register flags
+
-- ------------------------------------------------------------
-- | Flags to @register@ and @unregister@: (user package, gen-script,
-- in-place, verbosity)
-data RegisterFlags = RegisterFlags {
- regPackageDB :: Flag PackageDB,
- regGenScript :: Flag Bool,
- regGenPkgConf :: Flag (Maybe FilePath),
- regInPlace :: Flag Bool,
- regDistPref :: Flag FilePath,
- regPrintId :: Flag Bool,
- regVerbosity :: Flag Verbosity,
- -- Same as in 'buildArgs' and 'copyArgs'
- regArgs :: [String],
- regCabalFilePath :: Flag FilePath
+data RegisterFlags = RegisterFlags
+ { regPackageDB :: Flag PackageDB
+ , regGenScript :: Flag Bool
+ , regGenPkgConf :: Flag (Maybe FilePath)
+ , regInPlace :: Flag Bool
+ , regDistPref :: Flag FilePath
+ , regPrintId :: Flag Bool
+ , regVerbosity :: Flag Verbosity
+ , -- Same as in 'buildArgs' and 'copyArgs'
+ regArgs :: [String]
+ , regCabalFilePath :: Flag FilePath
}
deriving (Show, Generic, Typeable)
defaultRegisterFlags :: RegisterFlags
-defaultRegisterFlags = RegisterFlags {
- regPackageDB = NoFlag,
- regGenScript = Flag False,
- regGenPkgConf = NoFlag,
- regInPlace = Flag False,
- regDistPref = NoFlag,
- regPrintId = Flag False,
- regArgs = [],
- regCabalFilePath = mempty,
- regVerbosity = Flag normal
- }
+defaultRegisterFlags =
+ RegisterFlags
+ { regPackageDB = NoFlag
+ , regGenScript = Flag False
+ , regGenPkgConf = NoFlag
+ , regInPlace = Flag False
+ , regDistPref = NoFlag
+ , regPrintId = Flag False
+ , regArgs = []
+ , regCabalFilePath = mempty
+ , regVerbosity = Flag normal
+ }
registerCommand :: CommandUI RegisterFlags
-registerCommand = CommandUI
- { commandName = "register"
- , commandSynopsis =
- "Register this package with the compiler."
- , commandDescription = Nothing
- , commandNotes = Nothing
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " register [FLAGS]\n"
- , commandDefaultFlags = defaultRegisterFlags
- , commandOptions = \showOrParseArgs ->
- [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })
- ,optionDistPref
- regDistPref (\d flags -> flags { regDistPref = d })
- showOrParseArgs
-
- ,option "" ["packageDB"] ""
- regPackageDB (\v flags -> flags { regPackageDB = v })
- (choiceOpt [ (Flag UserPackageDB, ([],["user"]),
- "upon registration, register this package in the user's local package database")
- , (Flag GlobalPackageDB, ([],["global"]),
- "(default)upon registration, register this package in the system-wide package database")])
-
- ,option "" ["inplace"]
- "register the package in the build location, so it can be used without being installed"
- regInPlace (\v flags -> flags { regInPlace = v })
- trueArg
-
- ,option "" ["gen-script"]
- "instead of registering, generate a script to register later"
- regGenScript (\v flags -> flags { regGenScript = v })
- trueArg
-
- ,option "" ["gen-pkg-config"]
- "instead of registering, generate a package registration file/directory"
- regGenPkgConf (\v flags -> flags { regGenPkgConf = v })
- (optArg' "PKG" Flag flagToList)
-
- ,option "" ["print-ipid"]
- "print the installed package ID calculated for this package"
- regPrintId (\v flags -> flags { regPrintId = v })
- trueArg
- ]
- }
+registerCommand =
+ CommandUI
+ { commandName = "register"
+ , commandSynopsis =
+ "Register this package with the compiler."
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " register [FLAGS]\n"
+ , commandDefaultFlags = defaultRegisterFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity regVerbosity (\v flags -> flags{regVerbosity = v})
+ , optionDistPref
+ regDistPref
+ (\d flags -> flags{regDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["packageDB"]
+ ""
+ regPackageDB
+ (\v flags -> flags{regPackageDB = v})
+ ( choiceOpt
+ [
+ ( Flag UserPackageDB
+ , ([], ["user"])
+ , "upon registration, register this package in the user's local package database"
+ )
+ ,
+ ( Flag GlobalPackageDB
+ , ([], ["global"])
+ , "(default)upon registration, register this package in the system-wide package database"
+ )
+ ]
+ )
+ , option
+ ""
+ ["inplace"]
+ "register the package in the build location, so it can be used without being installed"
+ regInPlace
+ (\v flags -> flags{regInPlace = v})
+ trueArg
+ , option
+ ""
+ ["gen-script"]
+ "instead of registering, generate a script to register later"
+ regGenScript
+ (\v flags -> flags{regGenScript = v})
+ trueArg
+ , option
+ ""
+ ["gen-pkg-config"]
+ "instead of registering, generate a package registration file/directory"
+ regGenPkgConf
+ (\v flags -> flags{regGenPkgConf = v})
+ (optArg' "PKG" Flag flagToList)
+ , option
+ ""
+ ["print-ipid"]
+ "print the installed package ID calculated for this package"
+ regPrintId
+ (\v flags -> flags{regPrintId = v})
+ trueArg
+ ]
+ }
unregisterCommand :: CommandUI RegisterFlags
-unregisterCommand = CommandUI
- { commandName = "unregister"
- , commandSynopsis =
- "Unregister this package with the compiler."
- , commandDescription = Nothing
- , commandNotes = Nothing
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " unregister [FLAGS]\n"
- , commandDefaultFlags = defaultRegisterFlags
- , commandOptions = \showOrParseArgs ->
- [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v })
- ,optionDistPref
- regDistPref (\d flags -> flags { regDistPref = d })
- showOrParseArgs
-
- ,option "" ["user"] ""
- regPackageDB (\v flags -> flags { regPackageDB = v })
- (choiceOpt [ (Flag UserPackageDB, ([],["user"]),
- "unregister this package in the user's local package database")
- , (Flag GlobalPackageDB, ([],["global"]),
- "(default) unregister this package in the system-wide package database")])
-
- ,option "" ["gen-script"]
- "Instead of performing the unregister command, generate a script to unregister later"
- regGenScript (\v flags -> flags { regGenScript = v })
- trueArg
- ]
- }
+unregisterCommand =
+ CommandUI
+ { commandName = "unregister"
+ , commandSynopsis =
+ "Unregister this package with the compiler."
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " unregister [FLAGS]\n"
+ , commandDefaultFlags = defaultRegisterFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity regVerbosity (\v flags -> flags{regVerbosity = v})
+ , optionDistPref
+ regDistPref
+ (\d flags -> flags{regDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["user"]
+ ""
+ regPackageDB
+ (\v flags -> flags{regPackageDB = v})
+ ( choiceOpt
+ [
+ ( Flag UserPackageDB
+ , ([], ["user"])
+ , "unregister this package in the user's local package database"
+ )
+ ,
+ ( Flag GlobalPackageDB
+ , ([], ["global"])
+ , "(default) unregister this package in the system-wide package database"
+ )
+ ]
+ )
+ , option
+ ""
+ ["gen-script"]
+ "Instead of performing the unregister command, generate a script to unregister later"
+ regGenScript
+ (\v flags -> flags{regGenScript = v})
+ trueArg
+ ]
+ }
emptyRegisterFlags :: RegisterFlags
emptyRegisterFlags = mempty
@@ -149,4 +193,3 @@ instance Monoid RegisterFlags where
instance Semigroup RegisterFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Repl.hs b/Cabal/src/Distribution/Simple/Setup/Repl.hs
index 2ae90e57c91cb206e3fea4ef10a64f5014914508..8ae7d729fb76e08f9cf869f65368369f2aededc6 100644
--- a/Cabal/src/Distribution/Simple/Setup/Repl.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Repl.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.Repl
-- Copyright : Isaac Jones 2003-2004
@@ -16,40 +17,41 @@
--
-- Definition of the repl command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Repl (
-
- ReplFlags(..), defaultReplFlags, replCommand,
- ReplOptions(..),
- replOptions,
+module Distribution.Simple.Setup.Repl
+ ( ReplFlags (..)
+ , defaultReplFlags
+ , replCommand
+ , ReplOptions (..)
+ , replOptions
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
import Distribution.Simple.Program
+import Distribution.Simple.Utils
import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * REPL Flags
+
-- ------------------------------------------------------------
-data ReplOptions = ReplOptions {
- replOptionsFlags :: [String],
- replOptionsNoLoad :: Flag Bool
+data ReplOptions = ReplOptions
+ { replOptionsFlags :: [String]
+ , replOptionsNoLoad :: Flag Bool
}
deriving (Show, Generic, Typeable)
instance Binary ReplOptions
instance Structured ReplOptions
-
instance Monoid ReplOptions where
mempty = ReplOptions mempty (Flag False)
mappend = (<>)
@@ -57,25 +59,26 @@ instance Monoid ReplOptions where
instance Semigroup ReplOptions where
(<>) = gmappend
-data ReplFlags = ReplFlags {
- replProgramPaths :: [(String, FilePath)],
- replProgramArgs :: [(String, [String])],
- replDistPref :: Flag FilePath,
- replVerbosity :: Flag Verbosity,
- replReload :: Flag Bool,
- replReplOptions :: ReplOptions
+data ReplFlags = ReplFlags
+ { replProgramPaths :: [(String, FilePath)]
+ , replProgramArgs :: [(String, [String])]
+ , replDistPref :: Flag FilePath
+ , replVerbosity :: Flag Verbosity
+ , replReload :: Flag Bool
+ , replReplOptions :: ReplOptions
}
deriving (Show, Generic, Typeable)
defaultReplFlags :: ReplFlags
-defaultReplFlags = ReplFlags {
- replProgramPaths = mempty,
- replProgramArgs = [],
- replDistPref = NoFlag,
- replVerbosity = Flag normal,
- replReload = Flag False,
- replReplOptions = mempty
- }
+defaultReplFlags =
+ ReplFlags
+ { replProgramPaths = mempty
+ , replProgramArgs = []
+ , replDistPref = NoFlag
+ , replVerbosity = Flag normal
+ , replReload = Flag False
+ , replReplOptions = mempty
+ }
instance Monoid ReplFlags where
mempty = gmempty
@@ -85,85 +88,107 @@ instance Semigroup ReplFlags where
(<>) = gmappend
replCommand :: ProgramDb -> CommandUI ReplFlags
-replCommand progDb = CommandUI
- { commandName = "repl"
- , commandSynopsis =
- "Open an interpreter session for the given component."
- , commandDescription = Just $ \pname -> wrapText $
- "If the current directory contains no package, ignores COMPONENT "
- ++ "parameters and opens an interactive interpreter session; if a "
- ++ "sandbox is present, its package database will be used.\n"
- ++ "\n"
- ++ "Otherwise, (re)configures with the given or default flags, and "
- ++ "loads the interpreter with the relevant modules. For executables, "
- ++ "tests and benchmarks, loads the main module (and its "
- ++ "dependencies); for libraries all exposed/other modules.\n"
- ++ "\n"
- ++ "The default component is the library itself, or the executable "
- ++ "if that is the only component.\n"
- ++ "\n"
- ++ "Support for loading specific modules is planned but not "
- ++ "implemented yet. For certain scenarios, `" ++ pname
- ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "
- ++ "not (re)configure and you will have to specify the location of "
- ++ "other modules, if required.\n"
-
- , commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " repl "
- ++ " The first component in the package\n"
- ++ " " ++ pname ++ " repl foo "
- ++ " A named component (i.e. lib, exe, test suite)\n"
- ++ " " ++ pname ++ " repl --repl-options=\"-lstdc++\""
- ++ " Specifying flags for interpreter\n"
---TODO: re-enable once we have support for module/file targets
--- ++ " " ++ pname ++ " repl Foo.Bar "
--- ++ " A module\n"
--- ++ " " ++ pname ++ " repl Foo/Bar.hs"
--- ++ " A file\n\n"
--- ++ "If a target is ambiguous it can be qualified with the component "
--- ++ "name, e.g.\n"
--- ++ " " ++ pname ++ " repl foo:Foo.Bar\n"
--- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"
- , commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"
- , commandDefaultFlags = defaultReplFlags
- , commandOptions = \showOrParseArgs ->
- optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })
- : optionDistPref
- replDistPref (\d flags -> flags { replDistPref = d })
- showOrParseArgs
-
- : programDbPaths progDb showOrParseArgs
- replProgramPaths (\v flags -> flags { replProgramPaths = v})
-
- ++ programDbOption progDb showOrParseArgs
- replProgramArgs (\v flags -> flags { replProgramArgs = v})
-
- ++ programDbOptions progDb showOrParseArgs
- replProgramArgs (\v flags -> flags { replProgramArgs = v})
-
- ++ case showOrParseArgs of
- ParseArgs ->
- [ option "" ["reload"]
- "Used from within an interpreter to update files."
- replReload (\v flags -> flags { replReload = v })
- trueArg
- ]
- _ -> []
- ++ map liftReplOption (replOptions showOrParseArgs)
- }
+replCommand progDb =
+ CommandUI
+ { commandName = "repl"
+ , commandSynopsis =
+ "Open an interpreter session for the given component."
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "If the current directory contains no package, ignores COMPONENT "
+ ++ "parameters and opens an interactive interpreter session; if a "
+ ++ "sandbox is present, its package database will be used.\n"
+ ++ "\n"
+ ++ "Otherwise, (re)configures with the given or default flags, and "
+ ++ "loads the interpreter with the relevant modules. For executables, "
+ ++ "tests and benchmarks, loads the main module (and its "
+ ++ "dependencies); for libraries all exposed/other modules.\n"
+ ++ "\n"
+ ++ "The default component is the library itself, or the executable "
+ ++ "if that is the only component.\n"
+ ++ "\n"
+ ++ "Support for loading specific modules is planned but not "
+ ++ "implemented yet. For certain scenarios, `"
+ ++ pname
+ ++ " exec -- ghci :l Foo` may be used instead. Note that `exec` will "
+ ++ "not (re)configure and you will have to specify the location of "
+ ++ "other modules, if required.\n"
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " repl "
+ ++ " The first component in the package\n"
+ ++ " "
+ ++ pname
+ ++ " repl foo "
+ ++ " A named component (i.e. lib, exe, test suite)\n"
+ ++ " "
+ ++ pname
+ ++ " repl --repl-options=\"-lstdc++\""
+ ++ " Specifying flags for interpreter\n"
+ , -- TODO: re-enable once we have support for module/file targets
+ -- ++ " " ++ pname ++ " repl Foo.Bar "
+ -- ++ " A module\n"
+ -- ++ " " ++ pname ++ " repl Foo/Bar.hs"
+ -- ++ " A file\n\n"
+ -- ++ "If a target is ambiguous it can be qualified with the component "
+ -- ++ "name, e.g.\n"
+ -- ++ " " ++ pname ++ " repl foo:Foo.Bar\n"
+ -- ++ " " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"
+ commandUsage = \pname -> "Usage: " ++ pname ++ " repl [COMPONENT] [FLAGS]\n"
+ , commandDefaultFlags = defaultReplFlags
+ , commandOptions = \showOrParseArgs ->
+ optionVerbosity replVerbosity (\v flags -> flags{replVerbosity = v})
+ : optionDistPref
+ replDistPref
+ (\d flags -> flags{replDistPref = d})
+ showOrParseArgs
+ : programDbPaths
+ progDb
+ showOrParseArgs
+ replProgramPaths
+ (\v flags -> flags{replProgramPaths = v})
+ ++ programDbOption
+ progDb
+ showOrParseArgs
+ replProgramArgs
+ (\v flags -> flags{replProgramArgs = v})
+ ++ programDbOptions
+ progDb
+ showOrParseArgs
+ replProgramArgs
+ (\v flags -> flags{replProgramArgs = v})
+ ++ case showOrParseArgs of
+ ParseArgs ->
+ [ option
+ ""
+ ["reload"]
+ "Used from within an interpreter to update files."
+ replReload
+ (\v flags -> flags{replReload = v})
+ trueArg
+ ]
+ _ -> []
+ ++ map liftReplOption (replOptions showOrParseArgs)
+ }
where
- liftReplOption = liftOption replReplOptions (\v flags -> flags { replReplOptions = v })
+ liftReplOption = liftOption replReplOptions (\v flags -> flags{replReplOptions = v})
replOptions :: ShowOrParseArgs -> [OptionField ReplOptions]
replOptions _ =
- [ option [] ["repl-no-load"]
- "Disable loading of project modules at REPL startup."
- replOptionsNoLoad (\p flags -> flags { replOptionsNoLoad = p })
- trueArg
- , option [] ["repl-options"]
- "Use the option(s) for the repl"
- replOptionsFlags (\p flags -> flags { replOptionsFlags = p })
- (reqArg "FLAG" (succeedReadE words) id)
+ [ option
+ []
+ ["repl-no-load"]
+ "Disable loading of project modules at REPL startup."
+ replOptionsNoLoad
+ (\p flags -> flags{replOptionsNoLoad = p})
+ trueArg
+ , option
+ []
+ ["repl-options"]
+ "Use the option(s) for the repl"
+ replOptionsFlags
+ (\p flags -> flags{replOptionsFlags = p})
+ (reqArg "FLAG" (succeedReadE words) id)
]
-
diff --git a/Cabal/src/Distribution/Simple/Setup/SDist.hs b/Cabal/src/Distribution/Simple/Setup/SDist.hs
index 214c9222ff2b0ad9af5b7de384dae4ee2ae098d3..56dde313fbb79b38d3038a28fd6f9b19c19a3c68 100644
--- a/Cabal/src/Distribution/Simple/Setup/SDist.hs
+++ b/Cabal/src/Distribution/Simple/Setup/SDist.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Setup.SDist
-- Copyright : Isaac Jones 2003-2004
@@ -16,14 +17,15 @@
--
-- Definition of the sdist command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.SDist (
-
- SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand,
+module Distribution.Simple.Setup.SDist
+ ( SDistFlags (..)
+ , emptySDistFlags
+ , defaultSDistFlags
+ , sdistCommand
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
@@ -32,61 +34,73 @@ import Distribution.Verbosity
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * SDist flags
+
-- ------------------------------------------------------------
-- | Flags to @sdist@: (snapshot, verbosity)
-data SDistFlags = SDistFlags {
- sDistSnapshot :: Flag Bool,
- sDistDirectory :: Flag FilePath,
- sDistDistPref :: Flag FilePath,
- sDistListSources :: Flag FilePath,
- sDistVerbosity :: Flag Verbosity
+data SDistFlags = SDistFlags
+ { sDistSnapshot :: Flag Bool
+ , sDistDirectory :: Flag FilePath
+ , sDistDistPref :: Flag FilePath
+ , sDistListSources :: Flag FilePath
+ , sDistVerbosity :: Flag Verbosity
}
deriving (Show, Generic, Typeable)
defaultSDistFlags :: SDistFlags
-defaultSDistFlags = SDistFlags {
- sDistSnapshot = Flag False,
- sDistDirectory = mempty,
- sDistDistPref = NoFlag,
- sDistListSources = mempty,
- sDistVerbosity = Flag normal
- }
+defaultSDistFlags =
+ SDistFlags
+ { sDistSnapshot = Flag False
+ , sDistDirectory = mempty
+ , sDistDistPref = NoFlag
+ , sDistListSources = mempty
+ , sDistVerbosity = Flag normal
+ }
sdistCommand :: CommandUI SDistFlags
-sdistCommand = CommandUI
- { commandName = "sdist"
- , commandSynopsis =
- "Generate a source distribution file (.tar.gz)."
- , commandDescription = Nothing
- , commandNotes = Nothing
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " sdist [FLAGS]\n"
- , commandDefaultFlags = defaultSDistFlags
- , commandOptions = \showOrParseArgs ->
- [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })
- ,optionDistPref
- sDistDistPref (\d flags -> flags { sDistDistPref = d })
- showOrParseArgs
-
- ,option "" ["list-sources"]
- "Just write a list of the package's sources to a file"
- sDistListSources (\v flags -> flags { sDistListSources = v })
- (reqArgFlag "FILE")
-
- ,option "" ["snapshot"]
- "Produce a snapshot source distribution"
- sDistSnapshot (\v flags -> flags { sDistSnapshot = v })
- trueArg
-
- ,option "" ["output-directory"]
- ("Generate a source distribution in the given directory, "
- ++ "without creating a tarball")
- sDistDirectory (\v flags -> flags { sDistDirectory = v })
- (reqArgFlag "DIR")
- ]
- }
+sdistCommand =
+ CommandUI
+ { commandName = "sdist"
+ , commandSynopsis =
+ "Generate a source distribution file (.tar.gz)."
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " sdist [FLAGS]\n"
+ , commandDefaultFlags = defaultSDistFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity sDistVerbosity (\v flags -> flags{sDistVerbosity = v})
+ , optionDistPref
+ sDistDistPref
+ (\d flags -> flags{sDistDistPref = d})
+ showOrParseArgs
+ , option
+ ""
+ ["list-sources"]
+ "Just write a list of the package's sources to a file"
+ sDistListSources
+ (\v flags -> flags{sDistListSources = v})
+ (reqArgFlag "FILE")
+ , option
+ ""
+ ["snapshot"]
+ "Produce a snapshot source distribution"
+ sDistSnapshot
+ (\v flags -> flags{sDistSnapshot = v})
+ trueArg
+ , option
+ ""
+ ["output-directory"]
+ ( "Generate a source distribution in the given directory, "
+ ++ "without creating a tarball"
+ )
+ sDistDirectory
+ (\v flags -> flags{sDistDirectory = v})
+ (reqArgFlag "DIR")
+ ]
+ }
emptySDistFlags :: SDistFlags
emptySDistFlags = mempty
@@ -97,4 +111,3 @@ instance Monoid SDistFlags where
instance Semigroup SDistFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/Setup/Test.hs b/Cabal/src/Distribution/Simple/Setup/Test.hs
index afbcbdd104d940ff27b16320c8668c08183d6822..bee0ccbef1a909ad3f9f2d9565934579cb5f1c72 100644
--- a/Cabal/src/Distribution/Simple/Setup/Test.hs
+++ b/Cabal/src/Distribution/Simple/Setup/Test.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Test
-- Copyright : Isaac Jones 2003-2004
@@ -16,170 +17,231 @@
--
-- Definition of the testing command-line options.
-- See: @Distribution.Simple.Setup@
-
-module Distribution.Simple.Setup.Test (
-
- TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand,
- TestShowDetails(..),
- testOptions' ,
+module Distribution.Simple.Setup.Test
+ ( TestFlags (..)
+ , emptyTestFlags
+ , defaultTestFlags
+ , testCommand
+ , TestShowDetails (..)
+ , testOptions'
) where
-import Prelude ()
import Distribution.Compat.Prelude hiding (get)
+import Prelude ()
-import Distribution.ReadE
+import qualified Distribution.Compat.CharParsing as P
import Distribution.Parsec
import Distribution.Pretty
-import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import Distribution.ReadE
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import Distribution.Simple.Flag
-import Distribution.Simple.Utils
import Distribution.Simple.InstallDirs
+import Distribution.Simple.Utils
import Distribution.Verbosity
+import qualified Text.PrettyPrint as Disp
import Distribution.Simple.Setup.Common
-- ------------------------------------------------------------
+
-- * Test flags
+
-- ------------------------------------------------------------
data TestShowDetails = Never | Failures | Always | Streaming | Direct
- deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable)
+ deriving (Eq, Ord, Enum, Bounded, Generic, Show, Typeable)
instance Binary TestShowDetails
instance Structured TestShowDetails
knownTestShowDetails :: [TestShowDetails]
-knownTestShowDetails = [minBound..maxBound]
+knownTestShowDetails = [minBound .. maxBound]
instance Pretty TestShowDetails where
- pretty = Disp.text . lowercase . show
+ pretty = Disp.text . lowercase . show
instance Parsec TestShowDetails where
- parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident
- where
- ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-')
- classify str = lookup (lowercase str) enumMap
- enumMap :: [(String, TestShowDetails)]
- enumMap = [ (prettyShow x, x)
- | x <- knownTestShowDetails ]
-
---TODO: do we need this instance?
+ parsec = maybe (fail "invalid TestShowDetails") return . classify =<< ident
+ where
+ ident = P.munch1 (\c -> isAlpha c || c == '_' || c == '-')
+ classify str = lookup (lowercase str) enumMap
+ enumMap :: [(String, TestShowDetails)]
+ enumMap =
+ [ (prettyShow x, x)
+ | x <- knownTestShowDetails
+ ]
+
+-- TODO: do we need this instance?
instance Monoid TestShowDetails where
- mempty = Never
- mappend = (<>)
+ mempty = Never
+ mappend = (<>)
instance Semigroup TestShowDetails where
- a <> b = if a < b then b else a
-
-data TestFlags = TestFlags {
- testDistPref :: Flag FilePath,
- testVerbosity :: Flag Verbosity,
- testHumanLog :: Flag PathTemplate,
- testMachineLog :: Flag PathTemplate,
- testShowDetails :: Flag TestShowDetails,
- testKeepTix :: Flag Bool,
- testWrapper :: Flag FilePath,
- testFailWhenNoTestSuites :: Flag Bool,
- -- TODO: think about if/how options are passed to test exes
- testOptions :: [PathTemplate]
- } deriving (Show, Generic, Typeable)
+ a <> b = if a < b then b else a
+
+data TestFlags = TestFlags
+ { testDistPref :: Flag FilePath
+ , testVerbosity :: Flag Verbosity
+ , testHumanLog :: Flag PathTemplate
+ , testMachineLog :: Flag PathTemplate
+ , testShowDetails :: Flag TestShowDetails
+ , testKeepTix :: Flag Bool
+ , testWrapper :: Flag FilePath
+ , testFailWhenNoTestSuites :: Flag Bool
+ , -- TODO: think about if/how options are passed to test exes
+ testOptions :: [PathTemplate]
+ }
+ deriving (Show, Generic, Typeable)
defaultTestFlags :: TestFlags
-defaultTestFlags = TestFlags {
- testDistPref = NoFlag,
- testVerbosity = Flag normal,
- testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",
- testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",
- testShowDetails = toFlag Direct,
- testKeepTix = toFlag False,
- testWrapper = NoFlag,
- testFailWhenNoTestSuites = toFlag False,
- testOptions = []
- }
+defaultTestFlags =
+ TestFlags
+ { testDistPref = NoFlag
+ , testVerbosity = Flag normal
+ , testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log"
+ , testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log"
+ , testShowDetails = toFlag Direct
+ , testKeepTix = toFlag False
+ , testWrapper = NoFlag
+ , testFailWhenNoTestSuites = toFlag False
+ , testOptions = []
+ }
testCommand :: CommandUI TestFlags
-testCommand = CommandUI
- { commandName = "test"
- , commandSynopsis =
- "Run all/specific tests in the test suite."
- , commandDescription = Just $ \ _pname -> wrapText $
- testOrBenchmarkHelpText "test"
- , commandNotes = Nothing
- , commandUsage = usageAlternatives "test"
- [ "[FLAGS]"
- , "TESTCOMPONENTS [FLAGS]"
- ]
- , commandDefaultFlags = defaultTestFlags
- , commandOptions = testOptions'
- }
-
-testOptions' :: ShowOrParseArgs -> [OptionField TestFlags]
+testCommand =
+ CommandUI
+ { commandName = "test"
+ , commandSynopsis =
+ "Run all/specific tests in the test suite."
+ , commandDescription = Just $ \_pname ->
+ wrapText $
+ testOrBenchmarkHelpText "test"
+ , commandNotes = Nothing
+ , commandUsage =
+ usageAlternatives
+ "test"
+ [ "[FLAGS]"
+ , "TESTCOMPONENTS [FLAGS]"
+ ]
+ , commandDefaultFlags = defaultTestFlags
+ , commandOptions = testOptions'
+ }
+
+testOptions' :: ShowOrParseArgs -> [OptionField TestFlags]
testOptions' showOrParseArgs =
- [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v })
+ [ optionVerbosity testVerbosity (\v flags -> flags{testVerbosity = v})
, optionDistPref
- testDistPref (\d flags -> flags { testDistPref = d })
- showOrParseArgs
- , option [] ["log"]
- ("Log all test suite results to file (name template can use "
- ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)")
- testHumanLog (\v flags -> flags { testHumanLog = v })
- (reqArg' "TEMPLATE"
- (toFlag . toPathTemplate)
- (flagToList . fmap fromPathTemplate))
- , option [] ["machine-log"]
- ("Produce a machine-readable log file (name template can use "
- ++ "$pkgid, $compiler, $os, $arch, $result)")
- testMachineLog (\v flags -> flags { testMachineLog = v })
- (reqArg' "TEMPLATE"
- (toFlag . toPathTemplate)
- (flagToList . fmap fromPathTemplate))
- , option [] ["show-details"]
- ("'always': always show results of individual test cases. "
- ++ "'never': never show results of individual test cases. "
- ++ "'failures': show results of failing test cases. "
- ++ "'streaming': show results of test cases in real time."
- ++ "'direct': send results of test cases in real time; no log file.")
- testShowDetails (\v flags -> flags { testShowDetails = v })
- (reqArg "FILTER"
- (parsecToReadE (\_ -> "--show-details flag expects one of "
- ++ intercalate ", "
- (map prettyShow knownTestShowDetails))
- (fmap toFlag parsec))
- (flagToList . fmap prettyShow))
- , option [] ["keep-tix-files"]
- "keep .tix files for HPC between test runs"
- testKeepTix (\v flags -> flags { testKeepTix = v})
- trueArg
- , option [] ["test-wrapper"]
- "Run test through a wrapper."
- testWrapper (\v flags -> flags { testWrapper = v })
- (reqArg' "FILE" (toFlag :: FilePath -> Flag FilePath)
- (flagToList :: Flag FilePath -> [FilePath]))
- , option [] ["fail-when-no-test-suites"]
- ("Exit with failure when no test suites are found.")
- testFailWhenNoTestSuites (\v flags -> flags { testFailWhenNoTestSuites = v})
- trueArg
- , option [] ["test-options"]
- ("give extra options to test executables "
- ++ "(name templates can use $pkgid, $compiler, "
- ++ "$os, $arch, $test-suite)")
- testOptions (\v flags -> flags { testOptions = v })
- (reqArg' "TEMPLATES" (map toPathTemplate . splitArgs)
- (const []))
- , option [] ["test-option"]
- ("give extra option to test executables "
- ++ "(no need to quote options containing spaces, "
- ++ "name template can use $pkgid, $compiler, "
- ++ "$os, $arch, $test-suite)")
- testOptions (\v flags -> flags { testOptions = v })
- (reqArg' "TEMPLATE" (\x -> [toPathTemplate x])
- (map fromPathTemplate))
+ testDistPref
+ (\d flags -> flags{testDistPref = d})
+ showOrParseArgs
+ , option
+ []
+ ["log"]
+ ( "Log all test suite results to file (name template can use "
+ ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)"
+ )
+ testHumanLog
+ (\v flags -> flags{testHumanLog = v})
+ ( reqArg'
+ "TEMPLATE"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate)
+ )
+ , option
+ []
+ ["machine-log"]
+ ( "Produce a machine-readable log file (name template can use "
+ ++ "$pkgid, $compiler, $os, $arch, $result)"
+ )
+ testMachineLog
+ (\v flags -> flags{testMachineLog = v})
+ ( reqArg'
+ "TEMPLATE"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate)
+ )
+ , option
+ []
+ ["show-details"]
+ ( "'always': always show results of individual test cases. "
+ ++ "'never': never show results of individual test cases. "
+ ++ "'failures': show results of failing test cases. "
+ ++ "'streaming': show results of test cases in real time."
+ ++ "'direct': send results of test cases in real time; no log file."
+ )
+ testShowDetails
+ (\v flags -> flags{testShowDetails = v})
+ ( reqArg
+ "FILTER"
+ ( parsecToReadE
+ ( \_ ->
+ "--show-details flag expects one of "
+ ++ intercalate
+ ", "
+ (map prettyShow knownTestShowDetails)
+ )
+ (fmap toFlag parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ []
+ ["keep-tix-files"]
+ "keep .tix files for HPC between test runs"
+ testKeepTix
+ (\v flags -> flags{testKeepTix = v})
+ trueArg
+ , option
+ []
+ ["test-wrapper"]
+ "Run test through a wrapper."
+ testWrapper
+ (\v flags -> flags{testWrapper = v})
+ ( reqArg'
+ "FILE"
+ (toFlag :: FilePath -> Flag FilePath)
+ (flagToList :: Flag FilePath -> [FilePath])
+ )
+ , option
+ []
+ ["fail-when-no-test-suites"]
+ ("Exit with failure when no test suites are found.")
+ testFailWhenNoTestSuites
+ (\v flags -> flags{testFailWhenNoTestSuites = v})
+ trueArg
+ , option
+ []
+ ["test-options"]
+ ( "give extra options to test executables "
+ ++ "(name templates can use $pkgid, $compiler, "
+ ++ "$os, $arch, $test-suite)"
+ )
+ testOptions
+ (\v flags -> flags{testOptions = v})
+ ( reqArg'
+ "TEMPLATES"
+ (map toPathTemplate . splitArgs)
+ (const [])
+ )
+ , option
+ []
+ ["test-option"]
+ ( "give extra option to test executables "
+ ++ "(no need to quote options containing spaces, "
+ ++ "name template can use $pkgid, $compiler, "
+ ++ "$os, $arch, $test-suite)"
+ )
+ testOptions
+ (\v flags -> flags{testOptions = v})
+ ( reqArg'
+ "TEMPLATE"
+ (\x -> [toPathTemplate x])
+ (map fromPathTemplate)
+ )
]
emptyTestFlags :: TestFlags
-emptyTestFlags = mempty
+emptyTestFlags = mempty
instance Monoid TestFlags where
mempty = gmempty
@@ -187,4 +249,3 @@ instance Monoid TestFlags where
instance Semigroup TestFlags where
(<>) = gmappend
-
diff --git a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs
index 6cfecd8f463eb4a272f3fe05772e1c3c7ba3bed9..4f84f3ed8e487ac84b2bee983ac1c79fc4051fa0 100644
--- a/Cabal/src/Distribution/Simple/ShowBuildInfo.hs
+++ b/Cabal/src/Distribution/Simple/ShowBuildInfo.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
-- |
-- This module defines a simple JSON-based format for exporting basic
-- information about a Cabal package and the compiler configuration Cabal
@@ -55,12 +57,11 @@
-- * @src-files@: any other Haskell sources needed by the component
--
-- Note: At the moment this is only supported when using the GHC compiler.
---
-
-{-# LANGUAGE OverloadedStrings #-}
-
-module Distribution.Simple.ShowBuildInfo (
- mkBuildInfo, mkBuildInfo', mkCompilerInfo, mkComponentInfo
+module Distribution.Simple.ShowBuildInfo
+ ( mkBuildInfo
+ , mkBuildInfo'
+ , mkCompilerInfo
+ , mkComponentInfo
) where
import System.FilePath
@@ -68,37 +69,42 @@ import System.FilePath
import Distribution.Compat.Prelude
import Prelude ()
-import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.Program.GHC as GHC
-import Distribution.PackageDescription
import Distribution.Compiler
-import Distribution.Verbosity
-import Distribution.Simple.Compiler (Compiler, showCompilerId, compilerFlavor)
+import Distribution.PackageDescription
+import Distribution.Pretty
+import Distribution.Simple.Compiler (Compiler, compilerFlavor, showCompilerId)
import Distribution.Simple.Program
-import Distribution.Simple.Setup.Build ( BuildFlags )
+import Distribution.Simple.Setup.Build (BuildFlags)
import Distribution.Simple.Utils (cabalVersion)
-import Distribution.Utils.Json
+import Distribution.Text
import Distribution.Types.Component
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
-import Distribution.Text
-import Distribution.Pretty
+import Distribution.Utils.Json
+import Distribution.Verbosity
-- | Construct a JSON document describing the build information for a
-- package.
mkBuildInfo
- :: FilePath -- ^ The source directory of the package
- -> PackageDescription -- ^ Mostly information from the .cabal file
- -> LocalBuildInfo -- ^ Configuration information
- -> BuildFlags -- ^ Flags that the user passed to build
+ :: FilePath
+ -- ^ The source directory of the package
+ -> PackageDescription
+ -- ^ Mostly information from the .cabal file
+ -> LocalBuildInfo
+ -- ^ Configuration information
+ -> BuildFlags
+ -- ^ Flags that the user passed to build
-> (ConfiguredProgram, Compiler)
-- ^ Compiler information.
-- Needs to be passed explicitly, as we can't extract that information here
-- without some partial function.
-> [TargetInfo]
- -> ([String], Json) -- ^ Json representation of buildinfo alongside generated warnings
+ -> ([String], Json)
+ -- ^ Json representation of buildinfo alongside generated warnings
mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, JsonObject buildInfoFields)
where
buildInfoFields = mkBuildInfo' (uncurry mkCompilerInfo compilerInfo) componentInfos
@@ -113,33 +119,40 @@ mkBuildInfo wdir pkg_descr lbi _flags compilerInfo targetsToBuild = (warnings, J
-- the schema at @\/doc\/json-schemas\/build-info.schema.json@ and the docs of
-- @--enable-build-info@\/@--disable-build-info@.
mkBuildInfo'
- :: Json -- ^ The 'Json' from 'mkCompilerInfo'
- -> [Json] -- ^ The 'Json' from 'mkComponentInfo'
+ :: Json
+ -- ^ The 'Json' from 'mkCompilerInfo'
+ -> [Json]
+ -- ^ The 'Json' from 'mkComponentInfo'
-> [(String, Json)]
mkBuildInfo' compilerInfo componentInfos =
[ "cabal-lib-version" .= JsonString (display cabalVersion)
- , "compiler" .= compilerInfo
- , "components" .= JsonArray componentInfos
+ , "compiler" .= compilerInfo
+ , "components" .= JsonArray componentInfos
]
mkCompilerInfo :: ConfiguredProgram -> Compiler -> Json
-mkCompilerInfo compilerProgram compilerInfo = JsonObject
- [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo)
- , "compiler-id" .= JsonString (showCompilerId compilerInfo)
- , "path" .= JsonString (programPath compilerProgram)
- ]
+mkCompilerInfo compilerProgram compilerInfo =
+ JsonObject
+ [ "flavour" .= JsonString (prettyShow $ compilerFlavor compilerInfo)
+ , "compiler-id" .= JsonString (showCompilerId compilerInfo)
+ , "path" .= JsonString (programPath compilerProgram)
+ ]
mkComponentInfo :: FilePath -> PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> ([String], Json)
-mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $
- [ "type" .= JsonString compType
- , "name" .= JsonString (prettyShow name)
- , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)
- , "compiler-args" .= JsonArray (map JsonString compilerArgs)
- , "modules" .= JsonArray (map (JsonString . display) modules)
- , "src-files" .= JsonArray (map JsonString sourceFiles)
- , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi)
- , "src-dir" .= JsonString (addTrailingPathSeparator wdir)
- ] <> cabalFile)
+mkComponentInfo wdir pkg_descr lbi clbi =
+ ( warnings
+ , JsonObject $
+ [ "type" .= JsonString compType
+ , "name" .= JsonString (prettyShow name)
+ , "unit-id" .= JsonString (prettyShow $ componentUnitId clbi)
+ , "compiler-args" .= JsonArray (map JsonString compilerArgs)
+ , "modules" .= JsonArray (map (JsonString . display) modules)
+ , "src-files" .= JsonArray (map JsonString sourceFiles)
+ , "hs-src-dirs" .= JsonArray (map (JsonString . prettyShow) $ hsSourceDirs bi)
+ , "src-dir" .= JsonString (addTrailingPathSeparator wdir)
+ ]
+ <> cabalFile
+ )
where
(warnings, compilerArgs) = getCompilerArgs bi lbi clbi
name = componentLocalName clbi
@@ -147,11 +160,11 @@ mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $
-- If this error happens, a cabal invariant has been violated
comp = fromMaybe (error $ "mkBuildInfo: no component " ++ prettyShow name) $ lookupComponent pkg_descr name
compType = case comp of
- CLib _ -> "lib"
- CExe _ -> "exe"
- CTest _ -> "test"
+ CLib _ -> "lib"
+ CExe _ -> "exe"
+ CTest _ -> "test"
CBench _ -> "bench"
- CFLib _ -> "flib"
+ CFLib _ -> "flib"
modules = case comp of
CLib lib -> explicitLibModules lib
CExe exe -> exeModules exe
@@ -163,7 +176,7 @@ mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $
CBench bench -> benchmarkModules bench
CFLib flib -> foreignLibModules flib
sourceFiles = case comp of
- CLib _ -> []
+ CLib _ -> []
CExe exe -> [modulePath exe]
CTest test ->
case testInterface test of
@@ -173,11 +186,10 @@ mkComponentInfo wdir pkg_descr lbi clbi = (warnings, JsonObject $
CBench bench -> case benchmarkInterface bench of
BenchmarkExeV10 _ fp -> [fp]
BenchmarkUnsupported _ -> []
-
CFLib _ -> []
cabalFile
| Just fp <- pkgDescrFile lbi = [("cabal-file", JsonString fp)]
- | otherwise = []
+ | otherwise = []
-- | Get the command-line arguments that would be passed
-- to the compiler to build the given component.
@@ -188,12 +200,16 @@ getCompilerArgs
-> ([String], [String])
getCompilerArgs bi lbi clbi =
case compilerFlavor $ compiler lbi of
- GHC -> ([], ghc)
- GHCJS -> ([], ghc)
- c ->
- ( ["ShowBuildInfo.getCompilerArgs: Don't know how to get build "
- ++ " arguments for compiler " ++ show c]
- , [])
+ GHC -> ([], ghc)
+ GHCJS -> ([], ghc)
+ c ->
+ (
+ [ "ShowBuildInfo.getCompilerArgs: Don't know how to get build "
+ ++ " arguments for compiler "
+ ++ show c
+ ]
+ , []
+ )
where
-- This is absolutely awful
ghc = GHC.renderGhcOptions (compiler lbi) (hostPlatform lbi) baseOpts
diff --git a/Cabal/src/Distribution/Simple/SrcDist.hs b/Cabal/src/Distribution/Simple/SrcDist.hs
index e3bf177ac246c5ff1d6d23de7fb7e2e19897a66b..86748bee38c67e1c14370ca711c655117ec613aa 100644
--- a/Cabal/src/Distribution/Simple/SrcDist.hs
+++ b/Cabal/src/Distribution/Simple/SrcDist.hs
@@ -2,6 +2,10 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
+-- NOTE: FIX: we don't have a great way of testing this module, since
+-- we can't easily look inside a tarball once its created.
+
-- |
-- Module : Distribution.Simple.SrcDist
-- Copyright : Simon Marlow 2004
@@ -19,68 +23,67 @@
-- The 'createArchive' action uses the external @tar@ program and assumes that
-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows.
-- The 'sdist' action now also does some distribution QA checks.
+module Distribution.Simple.SrcDist
+ ( -- * The top level action
+ sdist
+
+ -- ** Parts of 'sdist'
+ , printPackageProblems
+ , prepareTree
+ , createArchive
+
+ -- ** Snapshots
+ , prepareSnapshotTree
+ , snapshotPackage
+ , snapshotVersion
+ , dateToSnapshotNumber
+
+ -- * Extracting the source files
+ , listPackageSources
+ , listPackageSourcesWithDie
+ ) where
--- NOTE: FIX: we don't have a great way of testing this module, since
--- we can't easily look inside a tarball once its created.
-
-module Distribution.Simple.SrcDist (
- -- * The top level action
- sdist,
-
- -- ** Parts of 'sdist'
- printPackageProblems,
- prepareTree,
- createArchive,
-
- -- ** Snapshots
- prepareSnapshotTree,
- snapshotPackage,
- snapshotVersion,
- dateToSnapshotNumber,
-
- -- * Extracting the source files
- listPackageSources,
- listPackageSourcesWithDie,
-
- ) where
-
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.PackageDescription
-import Distribution.PackageDescription.Check hiding (doesFileExist)
-import Distribution.Package
import Distribution.ModuleName
import qualified Distribution.ModuleName as ModuleName
-import Distribution.Version
+import Distribution.Package
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Check hiding (doesFileExist)
+import Distribution.Pretty
+import Distribution.Simple.BuildPaths
import Distribution.Simple.Configure (findDistPrefOrDefault)
-import Distribution.Simple.Glob (matchDirFileGlobWithDie)
-import Distribution.Simple.Utils
import Distribution.Simple.Flag
-import Distribution.Simple.Setup.SDist
+import Distribution.Simple.Glob (matchDirFileGlobWithDie)
import Distribution.Simple.PreProcess
-import Distribution.Simple.BuildPaths
import Distribution.Simple.Program
-import Distribution.Pretty
-import Distribution.Verbosity
+import Distribution.Simple.Setup.SDist
+import Distribution.Simple.Utils
import Distribution.Utils.Path
+import Distribution.Verbosity
+import Distribution.Version
import qualified Data.Map as Map
import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)
-import System.Directory ( doesFileExist )
-import System.IO (IOMode(WriteMode), hPutStrLn, withFile)
-import System.FilePath ((</>), (<.>), dropExtension, isRelative)
-
--- |Create a source distribution.
-sdist :: PackageDescription -- ^ information from the tarball
- -> SDistFlags -- ^ verbosity & snapshot
- -> (FilePath -> FilePath) -- ^ build prefix (temp dir)
- -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)
- -> IO ()
+import System.Directory (doesFileExist)
+import System.FilePath (dropExtension, isRelative, (<.>), (</>))
+import System.IO (IOMode (WriteMode), hPutStrLn, withFile)
+
+-- | Create a source distribution.
+sdist
+ :: PackageDescription
+ -- ^ information from the tarball
+ -> SDistFlags
+ -- ^ verbosity & snapshot
+ -> (FilePath -> FilePath)
+ -- ^ build prefix (temp dir)
+ -> [PPSuffixHandler]
+ -- ^ extra preprocessors (includes suffixes)
+ -> IO ()
sdist pkg flags mkTmpDir pps = do
-
distPref <- findDistPrefOrDefault $ sDistDistPref flags
- let targetPref = distPref
+ let targetPref = distPref
tmpTargetDir = mkTmpDir distPref
-- When given --list-sources, just output the list of sources to a file.
@@ -89,20 +92,19 @@ sdist pkg flags mkTmpDir pps = do
ordinary <- listPackageSources verbosity "." pkg pps
traverse_ (hPutStrLn outHandle) ordinary
notice verbosity $ "List of package sources written to file '" ++ path ++ "'"
-
- NoFlag -> do
+ NoFlag -> do
-- do some QA
printPackageProblems verbosity pkg
date <- getCurrentTime
- let pkg' | snapshot = snapshotPackage date pkg
- | otherwise = pkg
+ let pkg'
+ | snapshot = snapshotPackage date pkg
+ | otherwise = pkg
case flagToMaybe (sDistDirectory flags) of
Just targetDir -> do
generateSourceDir targetDir pkg'
info verbosity $ "Source directory created: " ++ targetDir
-
Nothing -> do
createDirectoryIfMissingVerbose verbosity True tmpTargetDir
withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
@@ -110,7 +112,6 @@ sdist pkg flags mkTmpDir pps = do
generateSourceDir targetDir pkg'
targzFile <- createArchive verbosity pkg' tmpDir targetPref
notice verbosity $ "Source tarball created: " ++ targzFile
-
where
generateSourceDir :: FilePath -> PackageDescription -> IO ()
generateSourceDir targetDir pkg' = do
@@ -120,22 +121,26 @@ sdist pkg flags mkTmpDir pps = do
overwriteSnapshotPackageDesc verbosity pkg' targetDir
verbosity = fromFlag (sDistVerbosity flags)
- snapshot = fromFlag (sDistSnapshot flags)
+ snapshot = fromFlag (sDistSnapshot flags)
-- | List all source files of a package.
--
-- Since @Cabal-3.4@ returns a single list. There shouldn't be any
-- executable files, they are hardly portable.
---
listPackageSources
- :: Verbosity -- ^ verbosity
- -> FilePath -- ^ directory with cabal file
- -> PackageDescription -- ^ info from the cabal file
- -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)
- -> IO [FilePath] -- ^ relative paths
+ :: Verbosity
+ -- ^ verbosity
+ -> FilePath
+ -- ^ directory with cabal file
+ -> PackageDescription
+ -- ^ info from the cabal file
+ -> [PPSuffixHandler]
+ -- ^ extra preprocessors (include suffixes)
+ -> IO [FilePath]
+ -- ^ relative paths
listPackageSources verbosity cwd pkg_descr0 pps = do
- -- Call helpers that actually do all work.
- listPackageSources' verbosity die' cwd pkg_descr pps
+ -- Call helpers that actually do all work.
+ listPackageSources' verbosity die' cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
@@ -145,163 +150,170 @@ listPackageSources verbosity cwd pkg_descr0 pps = do
--
-- Since @3.4.0.0
listPackageSourcesWithDie
- :: Verbosity -- ^ verbosity
- -> (Verbosity -> String -> IO [FilePath])
- -- ^ 'die'' alternative.
- -- Since 'die'' prefixes the error message with 'errorPrefix',
- -- whatever is passed in here and wants to die should do the same.
- -- See issue #7331.
- -> FilePath -- ^ directory with cabal file
- -> PackageDescription -- ^ info from the cabal file
- -> [PPSuffixHandler] -- ^ extra preprocessors (include suffixes)
- -> IO [FilePath] -- ^ relative paths
+ :: Verbosity
+ -- ^ verbosity
+ -> (Verbosity -> String -> IO [FilePath])
+ -- ^ 'die'' alternative.
+ -- Since 'die'' prefixes the error message with 'errorPrefix',
+ -- whatever is passed in here and wants to die should do the same.
+ -- See issue #7331.
+ -> FilePath
+ -- ^ directory with cabal file
+ -> PackageDescription
+ -- ^ info from the cabal file
+ -> [PPSuffixHandler]
+ -- ^ extra preprocessors (include suffixes)
+ -> IO [FilePath]
+ -- ^ relative paths
listPackageSourcesWithDie verbosity rip cwd pkg_descr0 pps = do
- -- Call helpers that actually do all work.
- listPackageSources' verbosity rip cwd pkg_descr pps
+ -- Call helpers that actually do all work.
+ listPackageSources' verbosity rip cwd pkg_descr pps
where
pkg_descr = filterAutogenModules pkg_descr0
-
listPackageSources'
:: Verbosity
- -- ^ verbosity
+ -- ^ verbosity
-> (Verbosity -> String -> IO [FilePath])
- -- ^ 'die'' alternative.
- -- Since 'die'' prefixes the error message with 'errorPrefix',
- -- whatever is passed in here and wants to die should do the same.
- -- See issue #7331.
+ -- ^ 'die'' alternative.
+ -- Since 'die'' prefixes the error message with 'errorPrefix',
+ -- whatever is passed in here and wants to die should do the same.
+ -- See issue #7331.
-> FilePath
- -- ^ directory with cabal file
+ -- ^ directory with cabal file
-> PackageDescription
- -- ^ info from the cabal file
+ -- ^ info from the cabal file
-> [PPSuffixHandler]
- -- ^ extra preprocessors (include suffixes)
+ -- ^ extra preprocessors (include suffixes)
-> IO [FilePath]
- -- ^ relative paths
+ -- ^ relative paths
listPackageSources' verbosity rip cwd pkg_descr pps =
fmap concat . sequenceA $
- [
- -- Library sources.
- fmap concat
- . withAllLib $ \Library {
- exposedModules = modules,
- signatures = sigs,
- libBuildInfo = libBi
- } ->
- allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)
-
- -- Executables sources.
- , fmap concat
- . withAllExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do
- biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps []
- mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath
- return (mainSrc:biSrcs)
-
- -- Foreign library sources
- , fmap concat
- . withAllFLib $ \flib@(ForeignLib { foreignLibBuildInfo = flibBi }) -> do
- biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []
- defFiles <- traverse (findModDefFile verbosity cwd flibBi pps)
- (foreignLibModDefFile flib)
- return (defFiles ++ biSrcs)
-
- -- Test suites sources.
- , fmap concat
- . withAllTest $ \t -> do
- let bi = testBuildInfo t
- case testInterface t of
- TestSuiteExeV10 _ mainPath -> do
- biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
- srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
- return (srcMainFile:biSrcs)
- TestSuiteLibV09 _ m ->
- allSourcesBuildInfo verbosity rip cwd bi pps [m]
- TestSuiteUnsupported tp ->
- rip verbosity $ "Unsupported test suite type: " ++ show tp
-
- -- Benchmarks sources.
- , fmap concat
- . withAllBenchmark $ \bm -> do
- let bi = benchmarkBuildInfo bm
- case benchmarkInterface bm of
- BenchmarkExeV10 _ mainPath -> do
- biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
- srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
- return (srcMainFile:biSrcs)
- BenchmarkUnsupported tp ->
- rip verbosity $ "Unsupported benchmark type: " ++ show tp
-
- -- Data files.
- , fmap concat
- . for (dataFiles pkg_descr) $ \filename -> do
- let srcDataDirRaw = dataDir pkg_descr
- srcDataDir | null srcDataDirRaw = "."
- | otherwise = srcDataDirRaw
- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
-
- -- Extra source files.
- , fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath
-
- -- Extra doc files.
- , fmap concat
- . for (extraDocFiles pkg_descr) $ \ filename ->
- matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename
-
- -- License file(s).
- , return (map getSymbolicPath $ licenseFiles pkg_descr)
-
- -- Install-include files, without autogen-include files
- , fmap concat
- . withAllLib $ \ l -> do
- let lbi = libBuildInfo l
- incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)
- relincdirs = "." : filter isRelative (includeDirs lbi)
- traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls
-
- -- Setup script, if it exists.
- , fmap (maybe [] (\f -> [f])) $ findSetupFile cwd
-
- -- The .cabal file itself.
- , fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")
-
- ]
+ [ -- Library sources.
+ fmap concat
+ . withAllLib
+ $ \Library
+ { exposedModules = modules
+ , signatures = sigs
+ , libBuildInfo = libBi
+ } ->
+ allSourcesBuildInfo verbosity rip cwd libBi pps (modules ++ sigs)
+ , -- Executables sources.
+ fmap concat
+ . withAllExe
+ $ \Executable{modulePath = mainPath, buildInfo = exeBi} -> do
+ biSrcs <- allSourcesBuildInfo verbosity rip cwd exeBi pps []
+ mainSrc <- findMainExeFile verbosity cwd exeBi pps mainPath
+ return (mainSrc : biSrcs)
+ , -- Foreign library sources
+ fmap concat
+ . withAllFLib
+ $ \flib@(ForeignLib{foreignLibBuildInfo = flibBi}) -> do
+ biSrcs <- allSourcesBuildInfo verbosity rip cwd flibBi pps []
+ defFiles <-
+ traverse
+ (findModDefFile verbosity cwd flibBi pps)
+ (foreignLibModDefFile flib)
+ return (defFiles ++ biSrcs)
+ , -- Test suites sources.
+ fmap concat
+ . withAllTest
+ $ \t -> do
+ let bi = testBuildInfo t
+ case testInterface t of
+ TestSuiteExeV10 _ mainPath -> do
+ biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
+ srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
+ return (srcMainFile : biSrcs)
+ TestSuiteLibV09 _ m ->
+ allSourcesBuildInfo verbosity rip cwd bi pps [m]
+ TestSuiteUnsupported tp ->
+ rip verbosity $ "Unsupported test suite type: " ++ show tp
+ , -- Benchmarks sources.
+ fmap concat
+ . withAllBenchmark
+ $ \bm -> do
+ let bi = benchmarkBuildInfo bm
+ case benchmarkInterface bm of
+ BenchmarkExeV10 _ mainPath -> do
+ biSrcs <- allSourcesBuildInfo verbosity rip cwd bi pps []
+ srcMainFile <- findMainExeFile verbosity cwd bi pps mainPath
+ return (srcMainFile : biSrcs)
+ BenchmarkUnsupported tp ->
+ rip verbosity $ "Unsupported benchmark type: " ++ show tp
+ , -- Data files.
+ fmap concat
+ . for (dataFiles pkg_descr)
+ $ \filename -> do
+ let srcDataDirRaw = dataDir pkg_descr
+ srcDataDir
+ | null srcDataDirRaw = "."
+ | otherwise = srcDataDirRaw
+ matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd (srcDataDir </> filename)
+ , -- Extra source files.
+ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath ->
+ matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd fpath
+ , -- Extra doc files.
+ fmap concat
+ . for (extraDocFiles pkg_descr)
+ $ \filename ->
+ matchDirFileGlobWithDie verbosity rip (specVersion pkg_descr) cwd filename
+ , -- License file(s).
+ return (map getSymbolicPath $ licenseFiles pkg_descr)
+ , -- Install-include files, without autogen-include files
+ fmap concat
+ . withAllLib
+ $ \l -> do
+ let lbi = libBuildInfo l
+ incls = filter (`notElem` autogenIncludes lbi) (installIncludes lbi)
+ relincdirs = "." : filter isRelative (includeDirs lbi)
+ traverse (fmap snd . findIncludeFile verbosity cwd relincdirs) incls
+ , -- Setup script, if it exists.
+ fmap (maybe [] (\f -> [f])) $ findSetupFile cwd
+ , -- The .cabal file itself.
+ fmap (\d -> [d]) (tryFindPackageDescCwd verbosity cwd ".")
+ ]
where
-- We have to deal with all libs and executables, so we have local
-- versions of these functions that ignore the 'buildable' attribute:
- withAllLib action = traverse action (allLibraries pkg_descr)
- withAllFLib action = traverse action (foreignLibs pkg_descr)
- withAllExe action = traverse action (executables pkg_descr)
- withAllTest action = traverse action (testSuites pkg_descr)
+ withAllLib action = traverse action (allLibraries pkg_descr)
+ withAllFLib action = traverse action (foreignLibs pkg_descr)
+ withAllExe action = traverse action (executables pkg_descr)
+ withAllTest action = traverse action (testSuites pkg_descr)
withAllBenchmark action = traverse action (benchmarks pkg_descr)
-
--- |Prepare a directory tree of source files.
-prepareTree :: Verbosity -- ^ verbosity
- -> PackageDescription -- ^ info from the cabal file
- -> FilePath -- ^ source tree to populate
- -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes)
- -> IO ()
+-- | Prepare a directory tree of source files.
+prepareTree
+ :: Verbosity
+ -- ^ verbosity
+ -> PackageDescription
+ -- ^ info from the cabal file
+ -> FilePath
+ -- ^ source tree to populate
+ -> [PPSuffixHandler]
+ -- ^ extra preprocessors (includes suffixes)
+ -> IO ()
prepareTree verbosity pkg_descr0 targetDir pps = do
- ordinary <- listPackageSources verbosity "." pkg_descr pps
- installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
- maybeCreateDefaultSetupScript targetDir
+ ordinary <- listPackageSources verbosity "." pkg_descr pps
+ installOrdinaryFiles verbosity targetDir (zip (repeat []) ordinary)
+ maybeCreateDefaultSetupScript targetDir
where
pkg_descr = filterAutogenModules pkg_descr0
-- | Find the setup script file, if it exists.
findSetupFile :: FilePath -> IO (Maybe FilePath)
findSetupFile targetDir = do
- hsExists <- doesFileExist (targetDir </> setupHs)
+ hsExists <- doesFileExist (targetDir </> setupHs)
lhsExists <- doesFileExist (targetDir </> setupLhs)
if hsExists
then return (Just setupHs)
- else if lhsExists
- then return (Just setupLhs)
- else return Nothing
- where
- setupHs = "Setup.hs"
- setupLhs = "Setup.lhs"
+ else
+ if lhsExists
+ then return (Just setupLhs)
+ else return Nothing
+ where
+ setupHs = "Setup.hs"
+ setupLhs = "Setup.lhs"
-- | Create a default setup script in the target directory, if it doesn't exist.
maybeCreateDefaultSetupScript :: FilePath -> IO ()
@@ -309,22 +321,30 @@ maybeCreateDefaultSetupScript targetDir = do
mSetupFile <- findSetupFile targetDir
case mSetupFile of
Just _setupFile -> return ()
- Nothing -> do
- writeUTF8File (targetDir </> "Setup.hs") $ unlines [
- "import Distribution.Simple",
- "main = defaultMain"]
+ Nothing -> do
+ writeUTF8File (targetDir </> "Setup.hs") $
+ unlines
+ [ "import Distribution.Simple"
+ , "main = defaultMain"
+ ]
-- | Find the main executable file.
findMainExeFile
:: Verbosity
- -> FilePath -- ^ cwd
+ -> FilePath
+ -- ^ cwd
-> BuildInfo
-> [PPSuffixHandler]
- -> FilePath -- ^ main-is
+ -> FilePath
+ -- ^ main-is
-> IO FilePath
findMainExeFile verbosity cwd exeBi pps mainPath = do
- ppFile <- findFileCwdWithExtension cwd (ppSuffixes pps) (map getSymbolicPath (hsSourceDirs exeBi))
- (dropExtension mainPath)
+ ppFile <-
+ findFileCwdWithExtension
+ cwd
+ (ppSuffixes pps)
+ (map getSymbolicPath (hsSourceDirs exeBi))
+ (dropExtension mainPath)
case ppFile of
Nothing -> findFileCwd verbosity cwd (map getSymbolicPath (hsSourceDirs exeBi)) mainPath
Just pp -> return pp
@@ -335,153 +355,184 @@ findMainExeFile verbosity cwd exeBi pps mainPath = do
findModDefFile
:: Verbosity -> FilePath -> BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath
findModDefFile verbosity cwd flibBi _pps modDefPath =
- findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath
+ findFileCwd verbosity cwd ("." : map getSymbolicPath (hsSourceDirs flibBi)) modDefPath
-- | Given a list of include paths, try to find the include file named
-- @f@. Return the name of the file and the full path, or exit with error if
-- there's no such file.
findIncludeFile :: Verbosity -> FilePath -> [FilePath] -> String -> IO (String, FilePath)
findIncludeFile verbosity _ [] f = die' verbosity ("can't find include file " ++ f)
-findIncludeFile verbosity cwd (d:ds) f = do
+findIncludeFile verbosity cwd (d : ds) f = do
let path = (d </> f)
b <- doesFileExist (cwd </> path)
- if b then return (f,path) else findIncludeFile verbosity cwd ds f
+ if b then return (f, path) else findIncludeFile verbosity cwd ds f
-- | Remove the auto-generated modules (like 'Paths_*') from 'exposed-modules'
-- and 'other-modules'.
filterAutogenModules :: PackageDescription -> PackageDescription
-filterAutogenModules pkg_descr0 = mapLib filterAutogenModuleLib $
- mapAllBuildInfo filterAutogenModuleBI pkg_descr0
+filterAutogenModules pkg_descr0 =
+ mapLib filterAutogenModuleLib $
+ mapAllBuildInfo filterAutogenModuleBI pkg_descr0
where
- mapLib f pkg = pkg { library = fmap f (library pkg)
- , subLibraries = map f (subLibraries pkg) }
- filterAutogenModuleLib lib = lib {
- exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)
- }
- filterAutogenModuleBI bi = bi {
- otherModules = filter (filterFunction bi) (otherModules bi)
- }
+ mapLib f pkg =
+ pkg
+ { library = fmap f (library pkg)
+ , subLibraries = map f (subLibraries pkg)
+ }
+ filterAutogenModuleLib lib =
+ lib
+ { exposedModules = filter (filterFunction (libBuildInfo lib)) (exposedModules lib)
+ }
+ filterAutogenModuleBI bi =
+ bi
+ { otherModules = filter (filterFunction bi) (otherModules bi)
+ }
pathsModule = autogenPathsModuleName pkg_descr0
packageInfoModule = autogenPackageInfoModuleName pkg_descr0
filterFunction bi = \mn ->
- mn /= pathsModule
- && mn /= packageInfoModule
- && not (mn `elem` autogenModules bi)
+ mn /= pathsModule
+ && mn /= packageInfoModule
+ && not (mn `elem` autogenModules bi)
-- | Prepare a directory tree of source files for a snapshot version.
-- It is expected that the appropriate snapshot version has already been set
-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.
---
prepareSnapshotTree
- :: Verbosity -- ^verbosity
- -> PackageDescription -- ^info from the cabal file
- -> FilePath -- ^source tree to populate
- -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes)
+ :: Verbosity
+ -- ^ verbosity
+ -> PackageDescription
+ -- ^ info from the cabal file
+ -> FilePath
+ -- ^ source tree to populate
+ -> [PPSuffixHandler]
+ -- ^ extra preprocessors (includes suffixes)
-> IO ()
prepareSnapshotTree verbosity pkg targetDir pps = do
prepareTree verbosity pkg targetDir pps
overwriteSnapshotPackageDesc verbosity pkg targetDir
-overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity
- -> PackageDescription -- ^info from the cabal file
- -> FilePath -- ^source tree
- -> IO ()
+overwriteSnapshotPackageDesc
+ :: Verbosity
+ -- ^ verbosity
+ -> PackageDescription
+ -- ^ info from the cabal file
+ -> FilePath
+ -- ^ source tree
+ -> IO ()
overwriteSnapshotPackageDesc verbosity pkg targetDir = do
- -- We could just writePackageDescription targetDescFile pkg_descr,
- -- but that would lose comments and formatting.
- descFile <- defaultPackageDesc verbosity
- withUTF8FileContents descFile $
- writeUTF8File (targetDir </> descFile)
- . unlines . map (replaceVersion (packageVersion pkg)) . lines
-
+ -- We could just writePackageDescription targetDescFile pkg_descr,
+ -- but that would lose comments and formatting.
+ descFile <- defaultPackageDesc verbosity
+ withUTF8FileContents descFile $
+ writeUTF8File (targetDir </> descFile)
+ . unlines
+ . map (replaceVersion (packageVersion pkg))
+ . lines
where
replaceVersion :: Version -> String -> String
replaceVersion version line
- | "version:" `isPrefixOf` map toLower line
- = "version: " ++ prettyShow version
+ | "version:" `isPrefixOf` map toLower line =
+ "version: " ++ prettyShow version
| otherwise = line
-- | Modifies a 'PackageDescription' by appending a snapshot number
-- corresponding to the given date.
---
snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription
snapshotPackage date pkg =
- pkg {
- package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }
- }
- where pkgid = packageId pkg
+ pkg
+ { package = pkgid{pkgVersion = snapshotVersion date (pkgVersion pkgid)}
+ }
+ where
+ pkgid = packageId pkg
-- | Modifies a 'Version' by appending a snapshot number corresponding
-- to the given date.
---
snapshotVersion :: UTCTime -> Version -> Version
snapshotVersion date = alterVersion (++ [dateToSnapshotNumber date])
-- | Given a date produce a corresponding integer representation.
-- For example given a date @18/03/2008@ produce the number @20080318@.
---
dateToSnapshotNumber :: UTCTime -> Int
dateToSnapshotNumber date = case toGregorian (utctDay date) of
- (year, month, day) ->
- fromIntegral year * 10000
- + month * 100
- + day
+ (year, month, day) ->
+ fromIntegral year * 10000
+ + month * 100
+ + day
-- | Create an archive from a tree of source files, and clean up the tree.
createArchive
- :: Verbosity -- ^ verbosity
- -> PackageDescription -- ^ info from cabal file
- -> FilePath -- ^ source tree to archive
- -> FilePath -- ^ name of archive to create
- -> IO FilePath
+ :: Verbosity
+ -- ^ verbosity
+ -> PackageDescription
+ -- ^ info from cabal file
+ -> FilePath
+ -- ^ source tree to archive
+ -> FilePath
+ -- ^ name of archive to create
+ -> IO FilePath
createArchive verbosity pkg_descr tmpDir targetPref = do
let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"
(tarProg, _) <- requireProgram verbosity tarProgram defaultProgramDb
- let formatOptSupported = maybe False (== "YES") $
- Map.lookup "Supports --format"
- (programProperties tarProg)
+ let formatOptSupported =
+ maybe False (== "YES") $
+ Map.lookup
+ "Supports --format"
+ (programProperties tarProg)
runProgram verbosity tarProg $
-- Hmm: I could well be skating on thinner ice here by using the -C option
-- (=> seems to be supported at least by GNU and *BSD tar) [The
-- prev. solution used pipes and sub-command sequences to set up the paths
-- correctly, which is problematic in a Windows setting.]
["-czf", tarBallFilePath, "-C", tmpDir]
- ++ (if formatOptSupported then ["--format", "ustar"] else [])
- ++ [tarBallName pkg_descr]
+ ++ (if formatOptSupported then ["--format", "ustar"] else [])
+ ++ [tarBallName pkg_descr]
return tarBallFilePath
-- | Given a buildinfo, return the names of all source files.
allSourcesBuildInfo
- :: Verbosity
- -> (Verbosity -> String -> IO [FilePath])
- -- ^ 'die'' alternative.
- -- Since 'die'' prefixes the error message with 'errorPrefix',
- -- whatever is passed in here and wants to die should do the same.
- -- See issue #7331.
- -> FilePath -- ^ cwd -- change me to 'BuildPath Absolute PackageDir'
- -> BuildInfo
- -> [PPSuffixHandler] -- ^ Extra preprocessors
- -> [ModuleName] -- ^ Exposed modules
- -> IO [FilePath]
+ :: Verbosity
+ -> (Verbosity -> String -> IO [FilePath])
+ -- ^ 'die'' alternative.
+ -- Since 'die'' prefixes the error message with 'errorPrefix',
+ -- whatever is passed in here and wants to die should do the same.
+ -- See issue #7331.
+ -> FilePath
+ -- ^ cwd -- change me to 'BuildPath Absolute PackageDir'
+ -> BuildInfo
+ -> [PPSuffixHandler]
+ -- ^ Extra preprocessors
+ -> [ModuleName]
+ -- ^ Exposed modules
+ -> IO [FilePath]
allSourcesBuildInfo verbosity rip cwd bi pps modules = do
let searchDirs = map getSymbolicPath (hsSourceDirs bi)
- sources <- fmap concat $ sequenceA $
- [ let file = ModuleName.toFilePath module_
- -- NB: *Not* findFileWithExtension, because the same source
- -- file may show up in multiple paths due to a conditional;
- -- we need to package all of them. See #367.
- in findAllFilesCwdWithExtension cwd suffixes searchDirs file
- >>= nonEmpty' (notFound module_) return
- | module_ <- modules ++ otherModules bi ]
- bootFiles <- sequenceA
- [ let file = ModuleName.toFilePath module_
- fileExts = ["hs-boot", "lhs-boot"]
- in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file
- | module_ <- modules ++ otherModules bi ]
-
- return $ sources ++ catMaybes bootFiles ++ cSources bi ++ cxxSources bi ++
- cmmSources bi ++ asmSources bi ++ jsSources bi
-
+ sources <-
+ fmap concat $
+ sequenceA $
+ [ let file = ModuleName.toFilePath module_
+ in -- NB: *Not* findFileWithExtension, because the same source
+ -- file may show up in multiple paths due to a conditional;
+ -- we need to package all of them. See #367.
+ findAllFilesCwdWithExtension cwd suffixes searchDirs file
+ >>= nonEmpty' (notFound module_) return
+ | module_ <- modules ++ otherModules bi
+ ]
+ bootFiles <-
+ sequenceA
+ [ let file = ModuleName.toFilePath module_
+ fileExts = ["hs-boot", "lhs-boot"]
+ in findFileCwdWithExtension cwd fileExts (map getSymbolicPath (hsSourceDirs bi)) file
+ | module_ <- modules ++ otherModules bi
+ ]
+
+ return $
+ sources
+ ++ catMaybes bootFiles
+ ++ cSources bi
+ ++ cxxSources bi
+ ++ cmmSources bi
+ ++ asmSources bi
+ ++ jsSources bi
where
nonEmpty' :: b -> ([a] -> b) -> [a] -> b
nonEmpty' x _ [] = x
@@ -490,48 +541,56 @@ allSourcesBuildInfo verbosity rip cwd bi pps modules = do
suffixes = ppSuffixes pps ++ ["hs", "lhs", "hsig", "lhsig"]
notFound :: ModuleName -> IO [FilePath]
- notFound m = rip verbosity $ "Could not find module: " ++ prettyShow m
- ++ " with any suffix: " ++ show suffixes ++ ". If the module "
- ++ "is autogenerated it should be added to 'autogen-modules'."
-
+ notFound m =
+ rip verbosity $
+ "Could not find module: "
+ ++ prettyShow m
+ ++ " with any suffix: "
+ ++ show suffixes
+ ++ ". If the module "
+ ++ "is autogenerated it should be added to 'autogen-modules'."
-- | Note: must be called with the CWD set to the directory containing
-- the '.cabal' file.
printPackageProblems :: Verbosity -> PackageDescription -> IO ()
printPackageProblems verbosity pkg_descr = do
- ioChecks <- checkPackageFiles verbosity pkg_descr "."
+ ioChecks <- checkPackageFiles verbosity pkg_descr "."
let pureChecks = checkConfiguredPackage pkg_descr
(errors, warnings) = partition isHackageDistError (pureChecks ++ ioChecks)
unless (null errors) $
- notice verbosity $ "Distribution quality errors:\n"
- ++ unlines (map ppPackageCheck errors)
+ notice verbosity $
+ "Distribution quality errors:\n"
+ ++ unlines (map ppPackageCheck errors)
unless (null warnings) $
- notice verbosity $ "Distribution quality warnings:\n"
- ++ unlines (map ppPackageCheck warnings)
+ notice verbosity $
+ "Distribution quality warnings:\n"
+ ++ unlines (map ppPackageCheck warnings)
unless (null errors) $
- notice verbosity
- "Note: the public hackage server would reject this package."
+ notice
+ verbosity
+ "Note: the public hackage server would reject this package."
------------------------------------------------------------
-- | The name of the tarball without extension
---
tarBallName :: PackageDescription -> String
tarBallName = prettyShow . packageId
-mapAllBuildInfo :: (BuildInfo -> BuildInfo)
- -> (PackageDescription -> PackageDescription)
-mapAllBuildInfo f pkg = pkg {
- library = fmap mapLibBi (library pkg),
- subLibraries = fmap mapLibBi (subLibraries pkg),
- foreignLibs = fmap mapFLibBi (foreignLibs pkg),
- executables = fmap mapExeBi (executables pkg),
- testSuites = fmap mapTestBi (testSuites pkg),
- benchmarks = fmap mapBenchBi (benchmarks pkg)
- }
+mapAllBuildInfo
+ :: (BuildInfo -> BuildInfo)
+ -> (PackageDescription -> PackageDescription)
+mapAllBuildInfo f pkg =
+ pkg
+ { library = fmap mapLibBi (library pkg)
+ , subLibraries = fmap mapLibBi (subLibraries pkg)
+ , foreignLibs = fmap mapFLibBi (foreignLibs pkg)
+ , executables = fmap mapExeBi (executables pkg)
+ , testSuites = fmap mapTestBi (testSuites pkg)
+ , benchmarks = fmap mapBenchBi (benchmarks pkg)
+ }
where
- mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) }
- mapFLibBi flib = flib { foreignLibBuildInfo = f (foreignLibBuildInfo flib) }
- mapExeBi exe = exe { buildInfo = f (buildInfo exe) }
- mapTestBi tst = tst { testBuildInfo = f (testBuildInfo tst) }
- mapBenchBi bm = bm { benchmarkBuildInfo = f (benchmarkBuildInfo bm) }
+ mapLibBi lib = lib{libBuildInfo = f (libBuildInfo lib)}
+ mapFLibBi flib = flib{foreignLibBuildInfo = f (foreignLibBuildInfo flib)}
+ mapExeBi exe = exe{buildInfo = f (buildInfo exe)}
+ mapTestBi tst = tst{testBuildInfo = f (testBuildInfo tst)}
+ mapBenchBi bm = bm{benchmarkBuildInfo = f (benchmarkBuildInfo bm)}
diff --git a/Cabal/src/Distribution/Simple/Test.hs b/Cabal/src/Distribution/Simple/Test.hs
index 90adfb3852e16c5244db403742e7b63c553ae089..0a8406e25740b8d76b03c3a479c81aa38ebbdf28 100644
--- a/Cabal/src/Distribution/Simple/Test.hs
+++ b/Cabal/src/Distribution/Simple/Test.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Test
-- Copyright : Thomas Tuegel 2010
@@ -13,125 +14,145 @@
-- This is the entry point into testing a built package. It performs the
-- \"@.\/setup test@\" action. It runs test suites designated in the package
-- description and reports on the results.
-
module Distribution.Simple.Test
- ( test
- ) where
+ ( test
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
import qualified Distribution.PackageDescription as PD
+import Distribution.Pretty
import Distribution.Simple.Compiler
+import Distribution.Simple.Flag (fromFlag)
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
-import qualified Distribution.Types.LocalBuildInfo as LBI
-import Distribution.Simple.Flag ( fromFlag )
import Distribution.Simple.Setup.Test
-import Distribution.Simple.UserHooks
import qualified Distribution.Simple.Test.ExeV10 as ExeV10
import qualified Distribution.Simple.Test.LibV09 as LibV09
import Distribution.Simple.Test.Log
+import Distribution.Simple.UserHooks
import Distribution.Simple.Utils
import Distribution.TestSuite
-import Distribution.Pretty
+import qualified Distribution.Types.LocalBuildInfo as LBI
+import Distribution.Types.UnqualComponentName
import System.Directory
- ( createDirectoryIfMissing, doesFileExist, getDirectoryContents
- , removeFile )
-import System.FilePath ( (</>) )
-
--- |Perform the \"@.\/setup test@\" action.
-test :: Args -- ^positional command-line arguments
- -> PD.PackageDescription -- ^information from the .cabal file
- -> LBI.LocalBuildInfo -- ^information from the configure step
- -> TestFlags -- ^flags sent to test
- -> IO ()
+ ( createDirectoryIfMissing
+ , doesFileExist
+ , getDirectoryContents
+ , removeFile
+ )
+import System.FilePath ((</>))
+
+-- | Perform the \"@.\/setup test@\" action.
+test
+ :: Args
+ -- ^ positional command-line arguments
+ -> PD.PackageDescription
+ -- ^ information from the .cabal file
+ -> LBI.LocalBuildInfo
+ -- ^ information from the configure step
+ -> TestFlags
+ -- ^ flags sent to test
+ -> IO ()
test args pkg_descr lbi flags = do
- let verbosity = fromFlag $ testVerbosity flags
- machineTemplate = fromFlag $ testMachineLog flags
- distPref = fromFlag $ testDistPref flags
- testLogDir = distPref </> "test"
- testNames = args
- pkgTests = PD.testSuites pkg_descr
- enabledTests = LBI.enabledTestLBIs pkg_descr lbi
-
- doTest :: ((PD.TestSuite, LBI.ComponentLocalBuildInfo),
- Maybe TestSuiteLog) -> IO TestSuiteLog
- doTest ((suite, clbi), _) =
- case PD.testInterface suite of
- PD.TestSuiteExeV10 _ _ ->
- ExeV10.runTest pkg_descr lbi clbi flags suite
-
- PD.TestSuiteLibV09 _ _ ->
- LibV09.runTest pkg_descr lbi clbi flags suite
-
- _ -> return TestSuiteLog
- { testSuiteName = PD.testName suite
- , testLogs = TestLog
+ let verbosity = fromFlag $ testVerbosity flags
+ machineTemplate = fromFlag $ testMachineLog flags
+ distPref = fromFlag $ testDistPref flags
+ testLogDir = distPref </> "test"
+ testNames = args
+ pkgTests = PD.testSuites pkg_descr
+ enabledTests = LBI.enabledTestLBIs pkg_descr lbi
+
+ doTest
+ :: ( (PD.TestSuite, LBI.ComponentLocalBuildInfo)
+ , Maybe TestSuiteLog
+ )
+ -> IO TestSuiteLog
+ doTest ((suite, clbi), _) =
+ case PD.testInterface suite of
+ PD.TestSuiteExeV10 _ _ ->
+ ExeV10.runTest pkg_descr lbi clbi flags suite
+ PD.TestSuiteLibV09 _ _ ->
+ LibV09.runTest pkg_descr lbi clbi flags suite
+ _ ->
+ return
+ TestSuiteLog
+ { testSuiteName = PD.testName suite
+ , testLogs =
+ TestLog
{ testName = unUnqualComponentName $ PD.testName suite
, testOptionsReturned = []
, testResult =
- Error $ "No support for running test suite type: "
- ++ show (pretty $ PD.testType suite)
+ Error $
+ "No support for running test suite type: "
+ ++ show (pretty $ PD.testType suite)
}
- , logFile = ""
- }
-
- unless (PD.hasTests pkg_descr) $ do
- notice verbosity "Package has no test suites."
- exitSuccess
-
- when (PD.hasTests pkg_descr && null enabledTests) $
- die' verbosity $
- "No test suites enabled. Did you remember to configure with "
- ++ "\'--enable-tests\'?"
-
- testsToRun <- case testNames of
- [] -> return $ zip enabledTests $ repeat Nothing
- names -> for names $ \tName ->
- let testMap = zip enabledNames enabledTests
- enabledNames = map (PD.testName . fst) enabledTests
- allNames = map PD.testName pkgTests
- tCompName = mkUnqualComponentName tName
- in case lookup tCompName testMap of
- Just t -> return (t, Nothing)
- _ | tCompName `elem` allNames ->
- die' verbosity $ "Package configured with test suite "
- ++ tName ++ " disabled."
- | otherwise -> die' verbosity $ "no such test: " ++ tName
-
- createDirectoryIfMissing True testLogDir
-
- -- Delete ordinary files from test log directory.
- getDirectoryContents testLogDir
- >>= filterM doesFileExist . map (testLogDir </>)
- >>= traverse_ removeFile
-
- let totalSuites = length testsToRun
- notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
- suites <- traverse doTest testsToRun
- let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites }
- packageLogFile = (</>) testLogDir
- $ packageLogPath machineTemplate pkg_descr lbi
- allOk <- summarizePackage verbosity packageLog
- writeFile packageLogFile $ show packageLog
-
- when (LBI.testCoverage lbi) $
- markupPackage verbosity lbi distPref pkg_descr $
- map (fst . fst) testsToRun
-
- unless allOk exitFailure
-
-packageLogPath :: PathTemplate
- -> PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> FilePath
+ , logFile = ""
+ }
+
+ unless (PD.hasTests pkg_descr) $ do
+ notice verbosity "Package has no test suites."
+ exitSuccess
+
+ when (PD.hasTests pkg_descr && null enabledTests) $
+ die' verbosity $
+ "No test suites enabled. Did you remember to configure with "
+ ++ "\'--enable-tests\'?"
+
+ testsToRun <- case testNames of
+ [] -> return $ zip enabledTests $ repeat Nothing
+ names -> for names $ \tName ->
+ let testMap = zip enabledNames enabledTests
+ enabledNames = map (PD.testName . fst) enabledTests
+ allNames = map PD.testName pkgTests
+ tCompName = mkUnqualComponentName tName
+ in case lookup tCompName testMap of
+ Just t -> return (t, Nothing)
+ _
+ | tCompName `elem` allNames ->
+ die' verbosity $
+ "Package configured with test suite "
+ ++ tName
+ ++ " disabled."
+ | otherwise -> die' verbosity $ "no such test: " ++ tName
+
+ createDirectoryIfMissing True testLogDir
+
+ -- Delete ordinary files from test log directory.
+ getDirectoryContents testLogDir
+ >>= filterM doesFileExist . map (testLogDir </>)
+ >>= traverse_ removeFile
+
+ let totalSuites = length testsToRun
+ notice verbosity $ "Running " ++ show totalSuites ++ " test suites..."
+ suites <- traverse doTest testsToRun
+ let packageLog = (localPackageLog pkg_descr lbi){testSuites = suites}
+ packageLogFile =
+ (</>) testLogDir $
+ packageLogPath machineTemplate pkg_descr lbi
+ allOk <- summarizePackage verbosity packageLog
+ writeFile packageLogFile $ show packageLog
+
+ when (LBI.testCoverage lbi) $
+ markupPackage verbosity lbi distPref pkg_descr $
+ map (fst . fst) testsToRun
+
+ unless allOk exitFailure
+
+packageLogPath
+ :: PathTemplate
+ -> PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> FilePath
packageLogPath template pkg_descr lbi =
- fromPathTemplate $ substPathTemplate env template
- where
- env = initialPathTemplateEnv
- (PD.package pkg_descr) (LBI.localUnitId lbi)
- (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
+ fromPathTemplate $ substPathTemplate env template
+ where
+ env =
+ initialPathTemplateEnv
+ (PD.package pkg_descr)
+ (LBI.localUnitId lbi)
+ (compilerInfo $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
diff --git a/Cabal/src/Distribution/Simple/Test/ExeV10.hs b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
index 6d120bc58c58a5ff572fac0ccc2499b98fbc7635..927e1fce1a8ffc05c37b5f53b518419c12f32c86 100644
--- a/Cabal/src/Distribution/Simple/Test/ExeV10.hs
+++ b/Cabal/src/Distribution/Simple/Test/ExeV10.hs
@@ -2,155 +2,183 @@
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Test.ExeV10
- ( runTest
- ) where
+ ( runTest
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.UnqualComponentName
import Distribution.Compat.Environment
import qualified Distribution.PackageDescription as PD
+import Distribution.Pretty
import Distribution.Simple.Build.PathsModule
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
+import Distribution.Simple.Flag
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
-import qualified Distribution.Types.LocalBuildInfo as LBI
-import Distribution.Simple.Flag
import Distribution.Simple.Setup.Test
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
-import Distribution.Pretty
+import qualified Distribution.Types.LocalBuildInfo as LBI
+import Distribution.Types.UnqualComponentName
import Distribution.Verbosity
import System.Directory
- ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
- , getCurrentDirectory, removeDirectoryRecursive )
-import System.FilePath ( (</>), (<.>) )
-import System.IO ( stdout, stderr )
-import System.Process ( createPipe )
+ ( createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ , getCurrentDirectory
+ , removeDirectoryRecursive
+ )
+import System.FilePath ((<.>), (</>))
+import System.IO (stderr, stdout)
+import System.Process (createPipe)
import qualified Data.ByteString.Lazy as LBS
-runTest :: PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> LBI.ComponentLocalBuildInfo
- -> TestFlags
- -> PD.TestSuite
- -> IO TestSuiteLog
+runTest
+ :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> LBI.ComponentLocalBuildInfo
+ -> TestFlags
+ -> PD.TestSuite
+ -> IO TestSuiteLog
runTest pkg_descr lbi clbi flags suite = do
- let isCoverageEnabled = LBI.testCoverage lbi
- way = guessWay lbi
- tixDir_ = tixDir distPref way testName'
-
- pwd <- getCurrentDirectory
- existingEnv <- getEnvironment
-
- let cmd = LBI.buildDir lbi </> testName'
- </> testName' <.> exeExtension (LBI.hostPlatform lbi)
- -- Check that the test executable exists.
- exists <- doesFileExist cmd
- unless exists $ die' verbosity $ "Could not find test program \"" ++ cmd
- ++ "\". Did you build the package first?"
-
- -- Remove old .tix files if appropriate.
- unless (fromFlag $ testKeepTix flags) $ do
- exists' <- doesDirectoryExist tixDir_
- when exists' $ removeDirectoryRecursive tixDir_
-
- -- Create directory for HPC files.
- createDirectoryIfMissing True tixDir_
-
- -- Write summary notices indicating start of test suite
- notice verbosity $ summarizeSuiteStart $ testName'
-
-
- -- Run the test executable
- let opts = map (testOption pkg_descr lbi suite)
- (testOptions flags)
- dataDirPath = pwd </> PD.dataDir pkg_descr
- tixFile = pwd </> tixFilePath distPref way (testName')
- pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
- : existingEnv
- shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
-
- -- Add (DY)LD_LIBRARY_PATH if needed
- shellEnv' <- if LBI.withDynExe lbi
- then do let (Platform _ os) = LBI.hostPlatform lbi
- paths <- LBI.depLibraryPaths True False lbi clbi
- return (addLibraryPath os paths shellEnv)
- else return shellEnv
-
- -- Output logger
- (wOut, wErr, getLogText) <- case details of
- Direct -> return (stdout, stderr, return LBS.empty)
- _ -> do
- (rOut, wOut) <- createPipe
-
- return $ (,,) wOut wOut $ do
- -- Read test executables' output
- logText <- LBS.hGetContents rOut
-
- -- '--show-details=streaming': print the log output in another thread
- when (details == Streaming) $ LBS.putStr logText
-
- -- drain the output.
- evaluate (force logText)
-
- (exit, logText) <- case testWrapper flags of
- Flag path -> rawSystemIOWithEnvAndAction
- verbosity path (cmd:opts) Nothing (Just shellEnv')
- getLogText
- -- these handles are automatically closed
- Nothing (Just wOut) (Just wErr)
-
- NoFlag -> rawSystemIOWithEnvAndAction
- verbosity cmd opts Nothing (Just shellEnv')
- getLogText
- -- these handles are automatically closed
- Nothing (Just wOut) (Just wErr)
-
- -- Generate TestSuiteLog from executable exit code and a machine-
- -- readable test log.
- let suiteLog = buildLog exit
-
- -- Write summary notice to log file indicating start of test suite
- appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
-
- -- Append contents of temporary log file to the final human-
- -- readable log file
- LBS.appendFile (logFile suiteLog) logText
-
- -- Write end-of-suite summary notice to log file
- appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
-
- -- Show the contents of the human-readable log file on the terminal
- -- if there is a failure and/or detailed output is requested
- let whenPrinting = when $
- ( details == Always ||
- details == Failures && not (suitePassed $ testLogs suiteLog))
+ let isCoverageEnabled = LBI.testCoverage lbi
+ way = guessWay lbi
+ tixDir_ = tixDir distPref way testName'
+
+ pwd <- getCurrentDirectory
+ existingEnv <- getEnvironment
+
+ let cmd =
+ LBI.buildDir lbi
+ </> testName'
+ </> testName' <.> exeExtension (LBI.hostPlatform lbi)
+ -- Check that the test executable exists.
+ exists <- doesFileExist cmd
+ unless exists $
+ die' verbosity $
+ "Could not find test program \""
+ ++ cmd
+ ++ "\". Did you build the package first?"
+
+ -- Remove old .tix files if appropriate.
+ unless (fromFlag $ testKeepTix flags) $ do
+ exists' <- doesDirectoryExist tixDir_
+ when exists' $ removeDirectoryRecursive tixDir_
+
+ -- Create directory for HPC files.
+ createDirectoryIfMissing True tixDir_
+
+ -- Write summary notices indicating start of test suite
+ notice verbosity $ summarizeSuiteStart $ testName'
+
+ -- Run the test executable
+ let opts =
+ map
+ (testOption pkg_descr lbi suite)
+ (testOptions flags)
+ dataDirPath = pwd </> PD.dataDir pkg_descr
+ tixFile = pwd </> tixFilePath distPref way (testName')
+ pkgPathEnv =
+ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
+ : existingEnv
+ shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled] ++ pkgPathEnv
+
+ -- Add (DY)LD_LIBRARY_PATH if needed
+ shellEnv' <-
+ if LBI.withDynExe lbi
+ then do
+ let (Platform _ os) = LBI.hostPlatform lbi
+ paths <- LBI.depLibraryPaths True False lbi clbi
+ return (addLibraryPath os paths shellEnv)
+ else return shellEnv
+
+ -- Output logger
+ (wOut, wErr, getLogText) <- case details of
+ Direct -> return (stdout, stderr, return LBS.empty)
+ _ -> do
+ (rOut, wOut) <- createPipe
+
+ return $ (,,) wOut wOut $ do
+ -- Read test executables' output
+ logText <- LBS.hGetContents rOut
+
+ -- '--show-details=streaming': print the log output in another thread
+ when (details == Streaming) $ LBS.putStr logText
+
+ -- drain the output.
+ evaluate (force logText)
+
+ (exit, logText) <- case testWrapper flags of
+ Flag path ->
+ rawSystemIOWithEnvAndAction
+ verbosity
+ path
+ (cmd : opts)
+ Nothing
+ (Just shellEnv')
+ getLogText
+ -- these handles are automatically closed
+ Nothing
+ (Just wOut)
+ (Just wErr)
+ NoFlag ->
+ rawSystemIOWithEnvAndAction
+ verbosity
+ cmd
+ opts
+ Nothing
+ (Just shellEnv')
+ getLogText
+ -- these handles are automatically closed
+ Nothing
+ (Just wOut)
+ (Just wErr)
+
+ -- Generate TestSuiteLog from executable exit code and a machine-
+ -- readable test log.
+ let suiteLog = buildLog exit
+
+ -- Write summary notice to log file indicating start of test suite
+ appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
+
+ -- Append contents of temporary log file to the final human-
+ -- readable log file
+ LBS.appendFile (logFile suiteLog) logText
+
+ -- Write end-of-suite summary notice to log file
+ appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
+
+ -- Show the contents of the human-readable log file on the terminal
+ -- if there is a failure and/or detailed output is requested
+ let whenPrinting =
+ when $
+ ( details == Always
+ || details == Failures && not (suitePassed $ testLogs suiteLog)
+ )
-- verbosity overrides show-details
&& verbosity >= normal
- whenPrinting $ do
- LBS.putStr logText
- putChar '\n'
-
- -- Write summary notice to terminal indicating end of test suite
- notice verbosity $ summarizeSuiteFinish suiteLog
+ whenPrinting $ do
+ LBS.putStr logText
+ putChar '\n'
- when isCoverageEnabled $
- case PD.library pkg_descr of
- Nothing ->
- die' verbosity "Test coverage is only supported for packages with a library component."
+ -- Write summary notice to terminal indicating end of test suite
+ notice verbosity $ summarizeSuiteFinish suiteLog
- Just library ->
- markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+ when isCoverageEnabled $
+ case PD.library pkg_descr of
+ Nothing ->
+ die' verbosity "Test coverage is only supported for packages with a library component."
+ Just library ->
+ markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
- return suiteLog
+ return suiteLog
where
testName' = unUnqualComponentName $ PD.testName suite
@@ -160,35 +188,44 @@ runTest pkg_descr lbi clbi flags suite = do
testLogDir = distPref </> "test"
buildLog exit =
- let r = case exit of
- ExitSuccess -> Pass
- ExitFailure c -> Fail $ "exit code: " ++ show c
- --n = unUnqualComponentName $ PD.testName suite
- l = TestLog
- { testName = testName'
- , testOptionsReturned = []
- , testResult = r
- }
- in TestSuiteLog
- { testSuiteName = PD.testName suite
- , testLogs = l
- , logFile =
- testLogDir
- </> testSuiteLogPath (fromFlag $ testHumanLog flags)
- pkg_descr lbi testName' l
- }
+ let r = case exit of
+ ExitSuccess -> Pass
+ ExitFailure c -> Fail $ "exit code: " ++ show c
+ -- n = unUnqualComponentName $ PD.testName suite
+ l =
+ TestLog
+ { testName = testName'
+ , testOptionsReturned = []
+ , testResult = r
+ }
+ in TestSuiteLog
+ { testSuiteName = PD.testName suite
+ , testLogs = l
+ , logFile =
+ testLogDir
+ </> testSuiteLogPath
+ (fromFlag $ testHumanLog flags)
+ pkg_descr
+ lbi
+ testName'
+ l
+ }
-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't
-- necessarily a path.
-testOption :: PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> PD.TestSuite
- -> PathTemplate
- -> String
+testOption
+ :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> PD.TestSuite
+ -> PathTemplate
+ -> String
testOption pkg_descr lbi suite template =
- fromPathTemplate $ substPathTemplate env template
+ fromPathTemplate $ substPathTemplate env template
where
- env = initialPathTemplateEnv
- (PD.package pkg_descr) (LBI.localUnitId lbi)
- (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
- [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]
+ env =
+ initialPathTemplateEnv
+ (PD.package pkg_descr)
+ (LBI.localUnitId lbi)
+ (compilerInfo $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
+ ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]
diff --git a/Cabal/src/Distribution/Simple/Test/LibV09.hs b/Cabal/src/Distribution/Simple/Test/LibV09.hs
index f1cc099d691c8d1759a2d4c87136f9a2c16d978a..4da061921413596bdb04cc6559327fa36378a4c4 100644
--- a/Cabal/src/Distribution/Simple/Test/LibV09.hs
+++ b/Cabal/src/Distribution/Simple/Test/LibV09.hs
@@ -2,198 +2,231 @@
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Test.LibV09
- ( runTest
- -- Test stub
- , simpleTestStub
- , stubFilePath, stubMain, stubName, stubWriteLog
- , writeSimpleTestStub
- ) where
+ ( runTest
+ -- Test stub
+ , simpleTestStub
+ , stubFilePath
+ , stubMain
+ , stubName
+ , stubWriteLog
+ , writeSimpleTestStub
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
+import Prelude ()
import Distribution.Compat.Environment
import Distribution.Compat.Internal.TempFile
import Distribution.ModuleName
import qualified Distribution.PackageDescription as PD
+import Distribution.Pretty
import Distribution.Simple.Build.PathsModule
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
+import Distribution.Simple.Flag (Flag (Flag, NoFlag), fromFlag)
import Distribution.Simple.Hpc
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
-import qualified Distribution.Types.LocalBuildInfo as LBI
-import Distribution.Simple.Flag ( Flag(NoFlag, Flag), fromFlag )
import Distribution.Simple.Setup.Test
import Distribution.Simple.Test.Log
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
-import Distribution.Pretty
+import qualified Distribution.Types.LocalBuildInfo as LBI
import Distribution.Verbosity
import qualified Control.Exception as CE
import qualified Data.ByteString.Lazy as LBS
-import System.Directory
- ( createDirectoryIfMissing, canonicalizePath
- , doesDirectoryExist, doesFileExist
- , getCurrentDirectory, removeDirectoryRecursive, removeFile
- , setCurrentDirectory )
-import System.FilePath ( (</>), (<.>) )
-import System.IO ( hClose, hPutStr )
import Distribution.Compat.Process (proc)
+import System.Directory
+ ( canonicalizePath
+ , createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ , getCurrentDirectory
+ , removeDirectoryRecursive
+ , removeFile
+ , setCurrentDirectory
+ )
+import System.FilePath ((<.>), (</>))
+import System.IO (hClose, hPutStr)
import qualified System.Process as Process
-runTest :: PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> LBI.ComponentLocalBuildInfo
- -> TestFlags
- -> PD.TestSuite
- -> IO TestSuiteLog
+runTest
+ :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> LBI.ComponentLocalBuildInfo
+ -> TestFlags
+ -> PD.TestSuite
+ -> IO TestSuiteLog
runTest pkg_descr lbi clbi flags suite = do
- let isCoverageEnabled = LBI.testCoverage lbi
- way = guessWay lbi
-
- pwd <- getCurrentDirectory
- existingEnv <- getEnvironment
-
- let cmd = LBI.buildDir lbi </> stubName suite
- </> stubName suite <.> exeExtension (LBI.hostPlatform lbi)
- -- Check that the test executable exists.
- exists <- doesFileExist cmd
- unless exists $
- die' verbosity $ "Could not find test program \"" ++ cmd
- ++ "\". Did you build the package first?"
-
- -- Remove old .tix files if appropriate.
- unless (fromFlag $ testKeepTix flags) $ do
- let tDir = tixDir distPref way testName'
- exists' <- doesDirectoryExist tDir
- when exists' $ removeDirectoryRecursive tDir
-
- -- Create directory for HPC files.
- createDirectoryIfMissing True $ tixDir distPref way testName'
-
- -- Write summary notices indicating start of test suite
- notice verbosity $ summarizeSuiteStart testName'
-
- suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
-
- -- Run test executable
- let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
- dataDirPath = pwd </> PD.dataDir pkg_descr
- tixFile = pwd </> tixFilePath distPref way testName'
- pkgPathEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
- : existingEnv
- shellEnv = [("HPCTIXFILE", tixFile) | isCoverageEnabled]
- ++ pkgPathEnv
- -- Add (DY)LD_LIBRARY_PATH if needed
- shellEnv' <-
- if LBI.withDynExe lbi
- then do
- let (Platform _ os) = LBI.hostPlatform lbi
- paths <- LBI.depLibraryPaths True False lbi clbi
- cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
- return (addLibraryPath os (cpath : paths) shellEnv)
- else return shellEnv
- let (cmd', opts') = case testWrapper flags of
- Flag path -> (path, cmd:opts)
- NoFlag -> (cmd, opts)
-
- -- TODO: this setup is broken,
- -- if the test output is too big, we will deadlock.
- (rOut, wOut) <- Process.createPipe
- (exitcode, logText) <- rawSystemProcAction verbosity
- (proc cmd' opts') { Process.env = Just shellEnv'
- , Process.std_in = Process.CreatePipe
- , Process.std_out = Process.UseHandle wOut
- , Process.std_err = Process.UseHandle wOut
- } $ \mIn _ _ -> do
- let wIn = fromCreatePipe mIn
- hPutStr wIn $ show (tempLog, PD.testName suite)
- hClose wIn
-
- -- Append contents of temporary log file to the final human-
- -- readable log file
- logText <- LBS.hGetContents rOut
- -- Force the IO manager to drain the test output pipe
- _ <- evaluate (force logText)
- return logText
- unless (exitcode == ExitSuccess) $
- debug verbosity $ cmd ++ " returned " ++ show exitcode
-
- -- Generate final log file name
- let finalLogName l = testLogDir
- </> testSuiteLogPath
- (fromFlag $ testHumanLog flags) pkg_descr lbi
- (unUnqualComponentName $ testSuiteName l) (testLogs l)
- -- Generate TestSuiteLog from executable exit code and a machine-
- -- readable test log
- suiteLog <- fmap (\s -> (\l -> l { logFile = finalLogName l })
- . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s) $ readMaybe s) -- TODO: eradicateNoParse
- $ readFile tempLog
-
- -- Write summary notice to log file indicating start of test suite
- appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
-
- LBS.appendFile (logFile suiteLog) logText
-
- -- Write end-of-suite summary notice to log file
- appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
-
- -- Show the contents of the human-readable log file on the terminal
- -- if there is a failure and/or detailed output is requested
- let details = fromFlag $ testShowDetails flags
- whenPrinting = when $ (details > Never)
- && (not (suitePassed $ testLogs suiteLog) || details == Always)
- && verbosity >= normal
- whenPrinting $ do
- LBS.putStr logText
- putChar '\n'
-
- return suiteLog
-
- -- Write summary notice to terminal indicating end of test suite
- notice verbosity $ summarizeSuiteFinish suiteLog
-
- when isCoverageEnabled $
- case PD.library pkg_descr of
- Nothing ->
- die' verbosity "Test coverage is only supported for packages with a library component."
- Just library ->
- markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+ let isCoverageEnabled = LBI.testCoverage lbi
+ way = guessWay lbi
+
+ pwd <- getCurrentDirectory
+ existingEnv <- getEnvironment
+
+ let cmd =
+ LBI.buildDir lbi
+ </> stubName suite
+ </> stubName suite <.> exeExtension (LBI.hostPlatform lbi)
+ -- Check that the test executable exists.
+ exists <- doesFileExist cmd
+ unless exists $
+ die' verbosity $
+ "Could not find test program \""
+ ++ cmd
+ ++ "\". Did you build the package first?"
+
+ -- Remove old .tix files if appropriate.
+ unless (fromFlag $ testKeepTix flags) $ do
+ let tDir = tixDir distPref way testName'
+ exists' <- doesDirectoryExist tDir
+ when exists' $ removeDirectoryRecursive tDir
+
+ -- Create directory for HPC files.
+ createDirectoryIfMissing True $ tixDir distPref way testName'
+
+ -- Write summary notices indicating start of test suite
+ notice verbosity $ summarizeSuiteStart testName'
+
+ suiteLog <- CE.bracket openCabalTemp deleteIfExists $ \tempLog -> do
+ -- Run test executable
+ let opts = map (testOption pkg_descr lbi suite) $ testOptions flags
+ dataDirPath = pwd </> PD.dataDir pkg_descr
+ tixFile = pwd </> tixFilePath distPref way testName'
+ pkgPathEnv =
+ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)
+ : existingEnv
+ shellEnv =
+ [("HPCTIXFILE", tixFile) | isCoverageEnabled]
+ ++ pkgPathEnv
+ -- Add (DY)LD_LIBRARY_PATH if needed
+ shellEnv' <-
+ if LBI.withDynExe lbi
+ then do
+ let (Platform _ os) = LBI.hostPlatform lbi
+ paths <- LBI.depLibraryPaths True False lbi clbi
+ cpath <- canonicalizePath $ LBI.componentBuildDir lbi clbi
+ return (addLibraryPath os (cpath : paths) shellEnv)
+ else return shellEnv
+ let (cmd', opts') = case testWrapper flags of
+ Flag path -> (path, cmd : opts)
+ NoFlag -> (cmd, opts)
+
+ -- TODO: this setup is broken,
+ -- if the test output is too big, we will deadlock.
+ (rOut, wOut) <- Process.createPipe
+ (exitcode, logText) <- rawSystemProcAction
+ verbosity
+ (proc cmd' opts')
+ { Process.env = Just shellEnv'
+ , Process.std_in = Process.CreatePipe
+ , Process.std_out = Process.UseHandle wOut
+ , Process.std_err = Process.UseHandle wOut
+ }
+ $ \mIn _ _ -> do
+ let wIn = fromCreatePipe mIn
+ hPutStr wIn $ show (tempLog, PD.testName suite)
+ hClose wIn
+
+ -- Append contents of temporary log file to the final human-
+ -- readable log file
+ logText <- LBS.hGetContents rOut
+ -- Force the IO manager to drain the test output pipe
+ _ <- evaluate (force logText)
+ return logText
+ unless (exitcode == ExitSuccess) $
+ debug verbosity $
+ cmd ++ " returned " ++ show exitcode
+
+ -- Generate final log file name
+ let finalLogName l =
+ testLogDir
+ </> testSuiteLogPath
+ (fromFlag $ testHumanLog flags)
+ pkg_descr
+ lbi
+ (unUnqualComponentName $ testSuiteName l)
+ (testLogs l)
+ -- Generate TestSuiteLog from executable exit code and a machine-
+ -- readable test log
+ suiteLog <-
+ fmap
+ ( \s ->
+ (\l -> l{logFile = finalLogName l})
+ . fromMaybe (error $ "panic! read @TestSuiteLog " ++ show s)
+ $ readMaybe s -- TODO: eradicateNoParse
+ )
+ $ readFile tempLog
+
+ -- Write summary notice to log file indicating start of test suite
+ appendFile (logFile suiteLog) $ summarizeSuiteStart testName'
+
+ LBS.appendFile (logFile suiteLog) logText
+
+ -- Write end-of-suite summary notice to log file
+ appendFile (logFile suiteLog) $ summarizeSuiteFinish suiteLog
+
+ -- Show the contents of the human-readable log file on the terminal
+ -- if there is a failure and/or detailed output is requested
+ let details = fromFlag $ testShowDetails flags
+ whenPrinting =
+ when $
+ (details > Never)
+ && (not (suitePassed $ testLogs suiteLog) || details == Always)
+ && verbosity >= normal
+ whenPrinting $ do
+ LBS.putStr logText
+ putChar '\n'
return suiteLog
+
+ -- Write summary notice to terminal indicating end of test suite
+ notice verbosity $ summarizeSuiteFinish suiteLog
+
+ when isCoverageEnabled $
+ case PD.library pkg_descr of
+ Nothing ->
+ die' verbosity "Test coverage is only supported for packages with a library component."
+ Just library ->
+ markupTest verbosity lbi distPref (prettyShow $ PD.package pkg_descr) suite library
+
+ return suiteLog
where
testName' = unUnqualComponentName $ PD.testName suite
deleteIfExists file = do
- exists <- doesFileExist file
- when exists $ removeFile file
+ exists <- doesFileExist file
+ when exists $ removeFile file
testLogDir = distPref </> "test"
openCabalTemp = do
- (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"
- hClose h >> return f
+ (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"
+ hClose h >> return f
distPref = fromFlag $ testDistPref flags
verbosity = fromFlag $ testVerbosity flags
-- TODO: This is abusing the notion of a 'PathTemplate'. The result isn't
-- necessarily a path.
-testOption :: PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> PD.TestSuite
- -> PathTemplate
- -> String
+testOption
+ :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> PD.TestSuite
+ -> PathTemplate
+ -> String
testOption pkg_descr lbi suite template =
- fromPathTemplate $ substPathTemplate env template
+ fromPathTemplate $ substPathTemplate env template
where
- env = initialPathTemplateEnv
- (PD.package pkg_descr) (LBI.localUnitId lbi)
- (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi) ++
- [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]
+ env =
+ initialPathTemplateEnv
+ (PD.package pkg_descr)
+ (LBI.localUnitId lbi)
+ (compilerInfo $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
+ ++ [(TestSuiteNameVar, toPathTemplate $ unUnqualComponentName $ PD.testName suite)]
-- Test stub ----------
@@ -207,22 +240,26 @@ stubFilePath :: PD.TestSuite -> FilePath
stubFilePath t = stubName t <.> "hs"
-- | Write the source file for a library 'TestSuite' stub executable.
-writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub
- -- is being created
- -> FilePath -- ^ path to directory where stub source
- -- should be located
- -> IO ()
+writeSimpleTestStub
+ :: PD.TestSuite
+ -- ^ library 'TestSuite' for which a stub
+ -- is being created
+ -> FilePath
+ -- ^ path to directory where stub source
+ -- should be located
+ -> IO ()
writeSimpleTestStub t dir = do
- createDirectoryIfMissing True dir
- let filename = dir </> stubFilePath t
- m = case PD.testInterface t of
- PD.TestSuiteLibV09 _ m' -> m'
- _ -> error "writeSimpleTestStub: invalid TestSuite passed"
- writeFile filename $ simpleTestStub m
+ createDirectoryIfMissing True dir
+ let filename = dir </> stubFilePath t
+ m = case PD.testInterface t of
+ PD.TestSuiteLibV09 _ m' -> m'
+ _ -> error "writeSimpleTestStub: invalid TestSuite passed"
+ writeFile filename $ simpleTestStub m
-- | Source code for library test suite stub executable
simpleTestStub :: ModuleName -> String
-simpleTestStub m = unlines
+simpleTestStub m =
+ unlines
[ "module Main ( main ) where"
, "import Distribution.Simple.Test.LibV09 ( stubMain )"
, "import " ++ show (pretty m) ++ " ( tests )"
@@ -235,18 +272,22 @@ simpleTestStub m = unlines
-- of detectable errors when Cabal is compiled.
stubMain :: IO [Test] -> IO ()
stubMain tests = do
- (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse
- dir <- getCurrentDirectory
- results <- (tests >>= stubRunTests) `CE.catch` errHandler
- setCurrentDirectory dir
- stubWriteLog f n results
+ (f, n) <- fmap (\s -> fromMaybe (error $ "panic! read " ++ show s) $ readMaybe s) getContents -- TODO: eradicateNoParse
+ dir <- getCurrentDirectory
+ results <- (tests >>= stubRunTests) `CE.catch` errHandler
+ setCurrentDirectory dir
+ stubWriteLog f n results
where
errHandler :: CE.SomeException -> IO TestLogs
errHandler e = case CE.fromException e of
- Just CE.UserInterrupt -> CE.throwIO e
- _ -> return $ TestLog { testName = "Cabal test suite exception",
- testOptionsReturned = [],
- testResult = Error $ show e }
+ Just CE.UserInterrupt -> CE.throwIO e
+ _ ->
+ return $
+ TestLog
+ { testName = "Cabal test suite exception"
+ , testOptionsReturned = []
+ , testResult = Error $ show e
+ }
-- | The test runner used in library "TestSuite" stub executables. Runs a list
-- of 'Test's. An executable calling this function is meant to be invoked as
@@ -257,35 +298,36 @@ stubMain tests = do
-- by the calling Cabal process.
stubRunTests :: [Test] -> IO TestLogs
stubRunTests tests = do
- logs <- traverse stubRunTests' tests
- return $ GroupLogs "Default" logs
+ logs <- traverse stubRunTests' tests
+ return $ GroupLogs "Default" logs
where
stubRunTests' (Test t) = do
- l <- run t >>= finish
- summarizeTest normal Always l
- return l
+ l <- run t >>= finish
+ summarizeTest normal Always l
+ return l
where
finish (Finished result) =
- return TestLog
- { testName = name t
- , testOptionsReturned = defaultOptions t
- , testResult = result
- }
+ return
+ TestLog
+ { testName = name t
+ , testOptionsReturned = defaultOptions t
+ , testResult = result
+ }
finish (Progress _ next) = next >>= finish
- stubRunTests' g@(Group {}) = do
- logs <- traverse stubRunTests' $ groupTests g
- return $ GroupLogs (groupName g) logs
+ stubRunTests' g@(Group{}) = do
+ logs <- traverse stubRunTests' $ groupTests g
+ return $ GroupLogs (groupName g) logs
stubRunTests' (ExtraOptions _ t) = stubRunTests' t
maybeDefaultOption opt =
- maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt
+ maybe Nothing (\d -> Just (optionName opt, d)) $ optionDefault opt
defaultOptions testInst = mapMaybe maybeDefaultOption $ options testInst
-- | From a test stub, write the 'TestSuiteLog' to temporary file for the calling
-- Cabal process to read.
stubWriteLog :: FilePath -> UnqualComponentName -> TestLogs -> IO ()
stubWriteLog f n logs = do
- let testLog = TestSuiteLog { testSuiteName = n, testLogs = logs, logFile = f }
- writeFile (logFile testLog) $ show testLog
- when (suiteError logs) $ exitWith $ ExitFailure 2
- when (suiteFailed logs) $ exitWith $ ExitFailure 1
- exitSuccess
+ let testLog = TestSuiteLog{testSuiteName = n, testLogs = logs, logFile = f}
+ writeFile (logFile testLog) $ show testLog
+ when (suiteError logs) $ exitWith $ ExitFailure 2
+ when (suiteFailed logs) $ exitWith $ ExitFailure 1
+ exitSuccess
diff --git a/Cabal/src/Distribution/Simple/Test/Log.hs b/Cabal/src/Distribution/Simple/Test/Log.hs
index 973d56f358b196622130b7886b36647b5f6a11bd..8287b30f6bfcc212bab3190809f5594584ab0be6 100644
--- a/Cabal/src/Distribution/Simple/Test/Log.hs
+++ b/Cabal/src/Distribution/Simple/Test/Log.hs
@@ -2,49 +2,53 @@
{-# LANGUAGE RankNTypes #-}
module Distribution.Simple.Test.Log
- ( PackageLog(..)
- , TestLogs(..)
- , TestSuiteLog(..)
- , countTestResults
- , localPackageLog
- , summarizePackage
- , summarizeSuiteFinish, summarizeSuiteStart
- , summarizeTest
- , suiteError, suiteFailed, suitePassed
- , testSuiteLogPath
- ) where
+ ( PackageLog (..)
+ , TestLogs (..)
+ , TestSuiteLog (..)
+ , countTestResults
+ , localPackageLog
+ , summarizePackage
+ , summarizeSuiteFinish
+ , summarizeSuiteStart
+ , summarizeTest
+ , suiteError
+ , suiteFailed
+ , suitePassed
+ , testSuiteLogPath
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Package
-import Distribution.Types.UnqualComponentName
import qualified Distribution.PackageDescription as PD
+import Distribution.Pretty
import Distribution.Simple.Compiler
import Distribution.Simple.InstallDirs
import qualified Distribution.Simple.LocalBuildInfo as LBI
-import Distribution.Simple.Setup.Test ( TestShowDetails(Always, Never) )
+import Distribution.Simple.Setup.Test (TestShowDetails (Always, Never))
import Distribution.Simple.Utils
import Distribution.System
import Distribution.TestSuite
+import Distribution.Types.UnqualComponentName
import Distribution.Verbosity
-import Distribution.Pretty
import qualified Prelude (foldl1)
-- | Logs all test results for a package, broken down first by test suite and
-- then by test case.
data PackageLog = PackageLog
- { package :: PackageId
- , compiler :: CompilerId
- , platform :: Platform
- , testSuites :: [TestSuiteLog]
- }
- deriving (Read, Show, Eq)
+ { package :: PackageId
+ , compiler :: CompilerId
+ , platform :: Platform
+ , testSuites :: [TestSuiteLog]
+ }
+ deriving (Read, Show, Eq)
-- | A 'PackageLog' with package and platform information specified.
localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog
-localPackageLog pkg_descr lbi = PackageLog
+localPackageLog pkg_descr lbi =
+ PackageLog
{ package = PD.package pkg_descr
, compiler = compilerId $ LBI.compiler lbi
, platform = LBI.hostPlatform lbi
@@ -53,114 +57,137 @@ localPackageLog pkg_descr lbi = PackageLog
-- | Logs test suite results, itemized by test case.
data TestSuiteLog = TestSuiteLog
- { testSuiteName :: UnqualComponentName
- , testLogs :: TestLogs
- , logFile :: FilePath -- path to human-readable log file
- }
- deriving (Read, Show, Eq)
+ { testSuiteName :: UnqualComponentName
+ , testLogs :: TestLogs
+ , logFile :: FilePath -- path to human-readable log file
+ }
+ deriving (Read, Show, Eq)
data TestLogs
- = TestLog
- { testName :: String
- , testOptionsReturned :: Options
- , testResult :: Result
- }
- | GroupLogs String [TestLogs]
- deriving (Read, Show, Eq)
+ = TestLog
+ { testName :: String
+ , testOptionsReturned :: Options
+ , testResult :: Result
+ }
+ | GroupLogs String [TestLogs]
+ deriving (Read, Show, Eq)
-- | Count the number of pass, fail, and error test results in a 'TestLogs'
-- tree.
-countTestResults :: TestLogs
- -> (Int, Int, Int) -- ^ Passes, fails, and errors,
- -- respectively.
+countTestResults
+ :: TestLogs
+ -> (Int, Int, Int)
+ -- ^ Passes, fails, and errors,
+ -- respectively.
countTestResults = go (0, 0, 0)
where
- go (p, f, e) (TestLog { testResult = r }) =
- case r of
- Pass -> (p + 1, f, e)
- Fail _ -> (p, f + 1, e)
- Error _ -> (p, f, e + 1)
+ go (p, f, e) (TestLog{testResult = r}) =
+ case r of
+ Pass -> (p + 1, f, e)
+ Fail _ -> (p, f + 1, e)
+ Error _ -> (p, f, e + 1)
go (p, f, e) (GroupLogs _ ts) = foldl go (p, f, e) ts
-- | From a 'TestSuiteLog', determine if the test suite passed.
suitePassed :: TestLogs -> Bool
suitePassed l =
- case countTestResults l of
- (_, 0, 0) -> True
- _ -> False
+ case countTestResults l of
+ (_, 0, 0) -> True
+ _ -> False
-- | From a 'TestSuiteLog', determine if the test suite failed.
suiteFailed :: TestLogs -> Bool
suiteFailed l =
- case countTestResults l of
- (_, 0, _) -> False
- _ -> True
+ case countTestResults l of
+ (_, 0, _) -> False
+ _ -> True
-- | From a 'TestSuiteLog', determine if the test suite encountered errors.
suiteError :: TestLogs -> Bool
suiteError l =
- case countTestResults l of
- (_, _, 0) -> False
- _ -> True
+ case countTestResults l of
+ (_, _, 0) -> False
+ _ -> True
resultString :: TestLogs -> String
-resultString l | suiteError l = "error"
- | suiteFailed l = "fail"
- | otherwise = "pass"
-
-testSuiteLogPath :: PathTemplate
- -> PD.PackageDescription
- -> LBI.LocalBuildInfo
- -> String -- ^ test suite name
- -> TestLogs -- ^ test suite results
- -> FilePath
+resultString l
+ | suiteError l = "error"
+ | suiteFailed l = "fail"
+ | otherwise = "pass"
+
+testSuiteLogPath
+ :: PathTemplate
+ -> PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> String
+ -- ^ test suite name
+ -> TestLogs
+ -- ^ test suite results
+ -> FilePath
testSuiteLogPath template pkg_descr lbi test_name result =
- fromPathTemplate $ substPathTemplate env template
- where
- env = initialPathTemplateEnv
- (PD.package pkg_descr) (LBI.localUnitId lbi)
- (compilerInfo $ LBI.compiler lbi) (LBI.hostPlatform lbi)
- ++ [ (TestSuiteNameVar, toPathTemplate test_name)
- , (TestSuiteResultVar, toPathTemplate $ resultString result)
- ]
+ fromPathTemplate $ substPathTemplate env template
+ where
+ env =
+ initialPathTemplateEnv
+ (PD.package pkg_descr)
+ (LBI.localUnitId lbi)
+ (compilerInfo $ LBI.compiler lbi)
+ (LBI.hostPlatform lbi)
+ ++ [ (TestSuiteNameVar, toPathTemplate test_name)
+ , (TestSuiteResultVar, toPathTemplate $ resultString result)
+ ]
-- | Print a summary to the console after all test suites have been run
-- indicating the number of successful test suites and cases. Returns 'True' if
-- all test suites passed and 'False' otherwise.
summarizePackage :: Verbosity -> PackageLog -> IO Bool
summarizePackage verbosity packageLog = do
- let counts = map (countTestResults . testLogs) $ testSuites packageLog
- (passed, failed, errors) = Prelude.foldl1 addTriple counts
- totalCases = passed + failed + errors
- passedSuites = length
- $ filter (suitePassed . testLogs)
- $ testSuites packageLog
- totalSuites = length $ testSuites packageLog
- notice verbosity $ show passedSuites ++ " of " ++ show totalSuites
- ++ " test suites (" ++ show passed ++ " of "
- ++ show totalCases ++ " test cases) passed."
- return $! passedSuites == totalSuites
+ let counts = map (countTestResults . testLogs) $ testSuites packageLog
+ (passed, failed, errors) = Prelude.foldl1 addTriple counts
+ totalCases = passed + failed + errors
+ passedSuites =
+ length $
+ filter (suitePassed . testLogs) $
+ testSuites packageLog
+ totalSuites = length $ testSuites packageLog
+ notice verbosity $
+ show passedSuites
+ ++ " of "
+ ++ show totalSuites
+ ++ " test suites ("
+ ++ show passed
+ ++ " of "
+ ++ show totalCases
+ ++ " test cases) passed."
+ return $! passedSuites == totalSuites
where
addTriple (p1, f1, e1) (p2, f2, e2) = (p1 + p2, f1 + f2, e1 + e2)
-- | Print a summary of a single test case's result to the console, suppressing
-- output for certain verbosity or test filter levels.
summarizeTest :: Verbosity -> TestShowDetails -> TestLogs -> IO ()
-summarizeTest _ _ (GroupLogs {}) = return ()
+summarizeTest _ _ (GroupLogs{}) = return ()
summarizeTest verbosity details t =
- when shouldPrint $ notice verbosity $ "Test case " ++ testName t
- ++ ": " ++ show (testResult t)
- where shouldPrint = (details > Never) && (notPassed || details == Always)
- notPassed = testResult t /= Pass
+ when shouldPrint $
+ notice verbosity $
+ "Test case "
+ ++ testName t
+ ++ ": "
+ ++ show (testResult t)
+ where
+ shouldPrint = (details > Never) && (notPassed || details == Always)
+ notPassed = testResult t /= Pass
-- | Print a summary of the test suite's results on the console, suppressing
-- output for certain verbosity or test filter levels.
summarizeSuiteFinish :: TestSuiteLog -> String
-summarizeSuiteFinish testLog = unlines
+summarizeSuiteFinish testLog =
+ unlines
[ "Test suite " ++ prettyShow (testSuiteName testLog) ++ ": " ++ resStr
, "Test suite logged to: " ++ logFile testLog
]
- where resStr = map toUpper (resultString $ testLogs testLog)
+ where
+ resStr = map toUpper (resultString $ testLogs testLog)
summarizeSuiteStart :: String -> String
summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"
diff --git a/Cabal/src/Distribution/Simple/UHC.hs b/Cabal/src/Distribution/Simple/UHC.hs
index afc886c423c1e98c985a620b4b343d27efe12cd3..ce6bb95d0e77dc5ecfee24692d3582b1903a5db0 100644
--- a/Cabal/src/Distribution/Simple/UHC.hs
+++ b/Cabal/src/Distribution/Simple/UHC.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.UHC
-- Copyright : Andres Loeh 2009
@@ -16,57 +17,67 @@
-- Thanks to the authors of the other implementation-specific files, in
-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for
-- inspiration on how to design this module.
-
-module Distribution.Simple.UHC (
- configure, getInstalledPackages,
- buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
+module Distribution.Simple.UHC
+ ( configure
+ , getInstalledPackages
+ , buildLib
+ , buildExe
+ , installLib
+ , registerPackage
+ , inplacePackageDbPath
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.InstalledPackageInfo
import Distribution.Package hiding (installedUnitId)
import Distribution.PackageDescription
+import Distribution.Parsec
+import Distribution.Pretty
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Utils
-import Distribution.Pretty
-import Distribution.Parsec
+import Distribution.System
import Distribution.Types.MungedPackageId
+import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version
-import Distribution.System
import Language.Haskell.Extension
-import Distribution.Utils.Path
-import qualified Data.Map as Map ( empty )
+import qualified Data.Map as Map (empty)
import System.Directory
import System.FilePath
-- -----------------------------------------------------------------------------
-- Configuring
-configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
- -> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)
+configure
+ :: Verbosity
+ -> Maybe FilePath
+ -> Maybe FilePath
+ -> ProgramDb
+ -> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity hcPath _hcPkgPath progdb = do
-
(_uhcProg, uhcVersion, progdb') <-
- requireProgramVersion verbosity uhcProgram
- (orLaterVersion (mkVersion [1,0,2]))
- (userMaybeSpecifyPath "uhc" hcPath progdb)
-
- let comp = Compiler {
- compilerId = CompilerId UHC uhcVersion,
- compilerAbiTag = NoAbiTag,
- compilerCompat = [],
- compilerLanguages = uhcLanguages,
- compilerExtensions = uhcLanguageExtensions,
- compilerProperties = Map.empty
- }
+ requireProgramVersion
+ verbosity
+ uhcProgram
+ (orLaterVersion (mkVersion [1, 0, 2]))
+ (userMaybeSpecifyPath "uhc" hcPath progdb)
+
+ let comp =
+ Compiler
+ { compilerId = CompilerId UHC uhcVersion
+ , compilerAbiTag = NoAbiTag
+ , compilerCompat = []
+ , compilerLanguages = uhcLanguages
+ , compilerExtensions = uhcLanguageExtensions
+ , compilerProperties = Map.empty
+ }
compPlatform = Nothing
return (comp, compPlatform, progdb')
@@ -76,64 +87,78 @@ uhcLanguages = [(Haskell98, "")]
-- | The flags for the supported extensions.
uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)]
uhcLanguageExtensions =
- let doFlag (f, (enable, disable)) = [(EnableExtension f, enable),
- (DisableExtension f, disable)]
- alwaysOn = (Nothing, Nothing{- wrong -})
- in concatMap doFlag
- [(CPP, (Just "--cpp", Nothing{- wrong -})),
- (PolymorphicComponents, alwaysOn),
- (ExistentialQuantification, alwaysOn),
- (ForeignFunctionInterface, alwaysOn),
- (UndecidableInstances, alwaysOn),
- (MultiParamTypeClasses, alwaysOn),
- (Rank2Types, alwaysOn),
- (PatternSignatures, alwaysOn),
- (EmptyDataDecls, alwaysOn),
- (ImplicitPrelude, (Nothing, Just "--no-prelude"{- wrong -})),
- (TypeOperators, alwaysOn),
- (OverlappingInstances, alwaysOn),
- (FlexibleInstances, alwaysOn)]
-
-getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb
- -> IO InstalledPackageIndex
+ let doFlag (f, (enable, disable)) =
+ [ (EnableExtension f, enable)
+ , (DisableExtension f, disable)
+ ]
+ alwaysOn = (Nothing, Nothing {- wrong -})
+ in concatMap
+ doFlag
+ [ (CPP, (Just "--cpp", Nothing {- wrong -}))
+ , (PolymorphicComponents, alwaysOn)
+ , (ExistentialQuantification, alwaysOn)
+ , (ForeignFunctionInterface, alwaysOn)
+ , (UndecidableInstances, alwaysOn)
+ , (MultiParamTypeClasses, alwaysOn)
+ , (Rank2Types, alwaysOn)
+ , (PatternSignatures, alwaysOn)
+ , (EmptyDataDecls, alwaysOn)
+ , (ImplicitPrelude, (Nothing, Just "--no-prelude" {- wrong -}))
+ , (TypeOperators, alwaysOn)
+ , (OverlappingInstances, alwaysOn)
+ , (FlexibleInstances, alwaysOn)
+ ]
+
+getInstalledPackages
+ :: Verbosity
+ -> Compiler
+ -> PackageDBStack
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity comp packagedbs progdb = do
let compilerid = compilerId comp
systemPkgDir <- getGlobalPackageDir verbosity progdb
- userPkgDir <- getUserPackageDir
- let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)
+ userPkgDir <- getUserPackageDir
+ let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)
-- putStrLn $ "pkgdirs: " ++ show pkgDirs
- pkgs <- liftM (map addBuiltinVersions . concat) $
- traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))
- pkgDirs
+ pkgs <-
+ liftM (map addBuiltinVersions . concat) $
+ traverse
+ (\d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))
+ pkgDirs
-- putStrLn $ "pkgs: " ++ show pkgs
let iPkgs =
map mkInstalledPackageInfo $
- concatMap parsePackage $
- pkgs
+ concatMap parsePackage $
+ pkgs
-- putStrLn $ "installed pkgs: " ++ show iPkgs
return (fromList iPkgs)
getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
getGlobalPackageDir verbosity progdb = do
- output <- getDbProgramOutput verbosity
- uhcProgram progdb ["--meta-pkgdir-system"]
- -- we need to trim because pkgdir contains an extra newline at the end
- let pkgdir = trimEnd output
- return pkgdir
+ output <-
+ getDbProgramOutput
+ verbosity
+ uhcProgram
+ progdb
+ ["--meta-pkgdir-system"]
+ -- we need to trim because pkgdir contains an extra newline at the end
+ let pkgdir = trimEnd output
+ return pkgdir
where
trimEnd = dropWhileEnd isSpace
getUserPackageDir :: IO FilePath
getUserPackageDir = do
- homeDir <- getHomeDirectory
- return $ homeDir </> ".cabal" </> "lib" -- TODO: determine in some other way
+ homeDir <- getHomeDirectory
+ return $ homeDir </> ".cabal" </> "lib" -- TODO: determine in some other way
packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]
packageDbPaths user system db =
case db of
- GlobalPackageDB -> [ system ]
- UserPackageDB -> [ user ]
- SpecificPackageDB path -> [ path ]
+ GlobalPackageDB -> [system]
+ UserPackageDB -> [user]
+ SpecificPackageDB path -> [path]
-- | Hack to add version numbers to UHC-built-in packages. This should sooner or
-- later be fixed on the UHC side.
@@ -143,7 +168,7 @@ addBuiltinVersions "uhcbase" = "uhcbase-1.0"
addBuiltinVersions "base" = "base-3.0"
addBuiltinVersions "array" = "array-0.2"
-}
-addBuiltinVersions xs = xs
+addBuiltinVersions xs = xs
-- | Name of the installed package config file.
installedPkgConfig :: String
@@ -153,121 +178,164 @@ installedPkgConfig = "installed-pkg-config"
-- looking only for the presence of an installed package configuration.
-- TODO: Actually make use of the information provided in the file.
isPkgDir :: String -> String -> String -> IO Bool
-isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a .
-isPkgDir c dir xs = do
- let candidate = dir </> uhcPackageDir xs c
- -- putStrLn $ "trying: " ++ candidate
- doesFileExist (candidate </> installedPkgConfig)
+isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a .
+isPkgDir c dir xs = do
+ let candidate = dir </> uhcPackageDir xs c
+ -- putStrLn $ "trying: " ++ candidate
+ doesFileExist (candidate </> installedPkgConfig)
parsePackage :: String -> [PackageId]
-parsePackage = toList . simpleParsec
+parsePackage = toList . simpleParsec
-- | Create a trivial package info from a directory name.
mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
-mkInstalledPackageInfo p = emptyInstalledPackageInfo
- { installedUnitId = mkLegacyUnitId p,
- sourcePackageId = p }
-
+mkInstalledPackageInfo p =
+ emptyInstalledPackageInfo
+ { installedUnitId = mkLegacyUnitId p
+ , sourcePackageId = p
+ }
-- -----------------------------------------------------------------------------
-- Building
-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Library -> ComponentLocalBuildInfo -> IO ()
+buildLib
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildLib verbosity pkg_descr lbi lib clbi = do
-
systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
- userPkgDir <- getUserPackageDir
+ userPkgDir <- getUserPackageDir
let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
- let uhcArgs = -- set package name
- ["--pkg-build=" ++ prettyShow (packageId pkg_descr)]
- -- common flags lib/exe
- ++ constructUHCCmdLine userPkgDir systemPkgDir
- lbi (libBuildInfo lib) clbi
- (buildDir lbi) verbosity
- -- source files
- -- suboptimal: UHC does not understand module names, so
- -- we replace periods by path separators
- ++ map (map (\ c -> if c == '.' then pathSeparator else c))
- (map prettyShow (allLibModules lib clbi))
+ let uhcArgs =
+ -- set package name
+ ["--pkg-build=" ++ prettyShow (packageId pkg_descr)]
+ -- common flags lib/exe
+ ++ constructUHCCmdLine
+ userPkgDir
+ systemPkgDir
+ lbi
+ (libBuildInfo lib)
+ clbi
+ (buildDir lbi)
+ verbosity
+ -- source files
+ -- suboptimal: UHC does not understand module names, so
+ -- we replace periods by path separators
+ ++ map
+ (map (\c -> if c == '.' then pathSeparator else c))
+ (map prettyShow (allLibModules lib clbi))
runUhcProg uhcArgs
return ()
-buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
- -> Executable -> ComponentLocalBuildInfo -> IO ()
+buildExe
+ :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> Executable
+ -> ComponentLocalBuildInfo
+ -> IO ()
buildExe verbosity _pkg_descr lbi exe clbi = do
systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
- userPkgDir <- getUserPackageDir
+ userPkgDir <- getUserPackageDir
let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
- let uhcArgs = -- common flags lib/exe
- constructUHCCmdLine userPkgDir systemPkgDir
- lbi (buildInfo exe) clbi
- (buildDir lbi) verbosity
- -- output file
- ++ ["--output", buildDir lbi </> prettyShow (exeName exe)]
- -- main source module
- ++ [modulePath exe]
+ let uhcArgs =
+ -- common flags lib/exe
+ constructUHCCmdLine
+ userPkgDir
+ systemPkgDir
+ lbi
+ (buildInfo exe)
+ clbi
+ (buildDir lbi)
+ verbosity
+ -- output file
+ ++ ["--output", buildDir lbi </> prettyShow (exeName exe)]
+ -- main source module
+ ++ [modulePath exe]
runUhcProg uhcArgs
-constructUHCCmdLine :: FilePath -> FilePath
- -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
- -> FilePath -> Verbosity -> [String]
+constructUHCCmdLine
+ :: FilePath
+ -> FilePath
+ -> LocalBuildInfo
+ -> BuildInfo
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> Verbosity
+ -> [String]
constructUHCCmdLine user system lbi bi clbi odir verbosity =
- -- verbosity
- (if verbosity >= deafening then ["-v4"]
- else if verbosity >= normal then []
- else ["-v0"])
- ++ hcOptions UHC bi
- -- flags for language extensions
- ++ languageToFlags (compiler lbi) (defaultLanguage bi)
- ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
- -- packages
- ++ ["--hide-all-packages"]
- ++ uhcPackageDbOptions user system (withPackageDB lbi)
- ++ ["--package=uhcbase"]
- ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]
- -- search paths
- ++ ["-i" ++ odir]
- ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)]
- ++ ["-i" ++ autogenComponentModulesDir lbi clbi]
- ++ ["-i" ++ autogenPackageModulesDir lbi]
- -- cpp options
- ++ ["--optP=" ++ opt | opt <- cppOptions bi]
- -- output path
- ++ ["--odir=" ++ odir]
- -- optimization
- ++ (case withOptimization lbi of
- NoOptimisation -> ["-O0"]
- NormalOptimisation -> ["-O1"]
- MaximumOptimisation -> ["-O2"])
+ -- verbosity
+ ( if verbosity >= deafening
+ then ["-v4"]
+ else
+ if verbosity >= normal
+ then []
+ else ["-v0"]
+ )
+ ++ hcOptions UHC bi
+ -- flags for language extensions
+ ++ languageToFlags (compiler lbi) (defaultLanguage bi)
+ ++ extensionsToFlags (compiler lbi) (usedExtensions bi)
+ -- packages
+ ++ ["--hide-all-packages"]
+ ++ uhcPackageDbOptions user system (withPackageDB lbi)
+ ++ ["--package=uhcbase"]
+ ++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi]
+ -- search paths
+ ++ ["-i" ++ odir]
+ ++ ["-i" ++ getSymbolicPath l | l <- nub (hsSourceDirs bi)]
+ ++ ["-i" ++ autogenComponentModulesDir lbi clbi]
+ ++ ["-i" ++ autogenPackageModulesDir lbi]
+ -- cpp options
+ ++ ["--optP=" ++ opt | opt <- cppOptions bi]
+ -- output path
+ ++ ["--odir=" ++ odir]
+ -- optimization
+ ++ ( case withOptimization lbi of
+ NoOptimisation -> ["-O0"]
+ NormalOptimisation -> ["-O1"]
+ MaximumOptimisation -> ["-O2"]
+ )
uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]
-uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)
- (concatMap (packageDbPaths user system) db)
+uhcPackageDbOptions user system db =
+ map
+ (\x -> "--pkg-searchpath=" ++ x)
+ (concatMap (packageDbPaths user system) db)
-- -----------------------------------------------------------------------------
-- Installation
-installLib :: Verbosity -> LocalBuildInfo
- -> FilePath -> FilePath -> FilePath
- -> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()
+installLib
+ :: Verbosity
+ -> LocalBuildInfo
+ -> FilePath
+ -> FilePath
+ -> FilePath
+ -> PackageDescription
+ -> Library
+ -> ComponentLocalBuildInfo
+ -> IO ()
installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do
- -- putStrLn $ "dest: " ++ targetDir
- -- putStrLn $ "built: " ++ builtDir
- installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir
+ -- putStrLn $ "dest: " ++ targetDir
+ -- putStrLn $ "built: " ++ builtDir
+ installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir
-- currently hard-coded UHC code generator and variant to use
uhcTarget, uhcTargetVariant :: String
-uhcTarget = "bc"
+uhcTarget = "bc"
uhcTargetVariant = "plain"
-- root directory for a package in UHC
-uhcPackageDir :: String -> String -> FilePath
-uhcPackageSubDir :: String -> FilePath
-uhcPackageDir pkgid compilerid = pkgid </> uhcPackageSubDir compilerid
-uhcPackageSubDir compilerid = compilerid </> uhcTarget </> uhcTargetVariant
+uhcPackageDir :: String -> String -> FilePath
+uhcPackageSubDir :: String -> FilePath
+uhcPackageDir pkgid compilerid = pkgid </> uhcPackageSubDir compilerid
+uhcPackageSubDir compilerid = compilerid </> uhcTarget </> uhcTargetVariant
-- -----------------------------------------------------------------------------
-- Registering
@@ -280,16 +348,17 @@ registerPackage
-> InstalledPackageInfo
-> IO ()
registerPackage verbosity comp progdb packageDbs installedPkgInfo = do
- dbdir <- case registrationPackageDB packageDbs of
- GlobalPackageDB -> getGlobalPackageDir verbosity progdb
- UserPackageDB -> getUserPackageDir
- SpecificPackageDB dir -> return dir
- let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid)
- createDirectoryIfMissingVerbose verbosity True pkgdir
- writeUTF8File (pkgdir </> installedPkgConfig)
- (showInstalledPackageInfo installedPkgInfo)
+ dbdir <- case registrationPackageDB packageDbs of
+ GlobalPackageDB -> getGlobalPackageDir verbosity progdb
+ UserPackageDB -> getUserPackageDir
+ SpecificPackageDB dir -> return dir
+ let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid)
+ createDirectoryIfMissingVerbose verbosity True pkgdir
+ writeUTF8File
+ (pkgdir </> installedPkgConfig)
+ (showInstalledPackageInfo installedPkgInfo)
where
- pkgid = sourcePackageId installedPkgInfo
+ pkgid = sourcePackageId installedPkgInfo
compilerid = compilerId comp
inplacePackageDbPath :: LocalBuildInfo -> FilePath
diff --git a/Cabal/src/Distribution/Simple/UserHooks.hs b/Cabal/src/Distribution/Simple/UserHooks.hs
index 19454e4a71307475ac5e359d790a574b8f8ffdeb..b27cd0b875f43a9c2ec6baffbfadf0166f8d74a9 100644
--- a/Cabal/src/Distribution/Simple/UserHooks.hs
+++ b/Cabal/src/Distribution/Simple/UserHooks.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.UserHooks
-- Copyright : Isaac Jones 2003-2005
@@ -25,21 +26,21 @@
-- pass any extra parameters to most of the functions that implement the
-- various phases because it would involve changing the types of the
-- corresponding hook. At some point it will have to be replaced.
-
-module Distribution.Simple.UserHooks (
- UserHooks(..), Args,
- emptyUserHooks,
+module Distribution.Simple.UserHooks
+ ( UserHooks (..)
+ , Args
+ , emptyUserHooks
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.PackageDescription
-import Distribution.Simple.Program
import Distribution.Simple.Command
+import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PreProcess
+import Distribution.Simple.Program
import Distribution.Simple.Setup
-import Distribution.Simple.LocalBuildInfo
type Args = [String]
@@ -49,149 +50,137 @@ type Args = [String]
-- * WARNING: The hooks interface is under rather constant flux as we try to
-- understand users needs. Setup files that depend on this interface may
-- break in future releases.
-data UserHooks = UserHooks {
-
- -- | Read the description file
- readDesc :: IO (Maybe GenericPackageDescription),
- -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.
- hookedPreProcessors :: [ PPSuffixHandler ],
- -- | These programs are detected at configure time. Arguments for them are
- -- added to the configure command.
- hookedPrograms :: [Program],
-
- -- |Hook to run before configure command
- preConf :: Args -> ConfigFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during configure.
- confHook :: (GenericPackageDescription, HookedBuildInfo)
- -> ConfigFlags -> IO LocalBuildInfo,
- -- |Hook to run after configure command
- postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before build command. Second arg indicates verbosity level.
- preBuild :: Args -> BuildFlags -> IO HookedBuildInfo,
-
- -- |Over-ride this hook to get different behavior during build.
- buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (),
- -- |Hook to run after build command. Second arg indicates verbosity level.
- postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before repl command. Second arg indicates verbosity level.
- preRepl :: Args -> ReplFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during interpretation.
- replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (),
- -- |Hook to run after repl command. Second arg indicates verbosity level.
- postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before clean command. Second arg indicates verbosity level.
- preClean :: Args -> CleanFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during clean.
- cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (),
- -- |Hook to run after clean command. Second arg indicates verbosity level.
- postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (),
-
- -- |Hook to run before copy command
- preCopy :: Args -> CopyFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during copy.
- copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (),
- -- |Hook to run after copy command
- postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before install command
- preInst :: Args -> InstallFlags -> IO HookedBuildInfo,
-
- -- |Over-ride this hook to get different behavior during install.
- instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (),
- -- |Hook to run after install command. postInst should be run
- -- on the target, not on the build machine.
- postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before register command
- preReg :: Args -> RegisterFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during registration.
- regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),
- -- |Hook to run after register command
- postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before unregister command
- preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during unregistration.
- unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),
- -- |Hook to run after unregister command
- postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before hscolour command. Second arg indicates verbosity level.
- preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during hscolour.
- hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (),
- -- |Hook to run after hscolour command. Second arg indicates verbosity level.
- postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before haddock command. Second arg indicates verbosity level.
- preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during haddock.
- haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (),
- -- |Hook to run after haddock command. Second arg indicates verbosity level.
- postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before test command.
- preTest :: Args -> TestFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during test.
- testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),
- -- |Hook to run after test command.
- postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO (),
-
- -- |Hook to run before bench command.
- preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo,
- -- |Over-ride this hook to get different behavior during bench.
- benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO (),
- -- |Hook to run after bench command.
- postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+data UserHooks = UserHooks
+ { readDesc :: IO (Maybe GenericPackageDescription)
+ -- ^ Read the description file
+ , hookedPreProcessors :: [PPSuffixHandler]
+ -- ^ Custom preprocessors in addition to and overriding 'knownSuffixHandlers'.
+ , hookedPrograms :: [Program]
+ -- ^ These programs are detected at configure time. Arguments for them are
+ -- added to the configure command.
+ , preConf :: Args -> ConfigFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before configure command
+ , confHook
+ :: (GenericPackageDescription, HookedBuildInfo)
+ -> ConfigFlags
+ -> IO LocalBuildInfo
+ -- ^ Over-ride this hook to get different behavior during configure.
+ , postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after configure command
+ , preBuild :: Args -> BuildFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before build command. Second arg indicates verbosity level.
+ , buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during build.
+ , postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after build command. Second arg indicates verbosity level.
+ , preRepl :: Args -> ReplFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before repl command. Second arg indicates verbosity level.
+ , replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO ()
+ -- ^ Over-ride this hook to get different behavior during interpretation.
+ , postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after repl command. Second arg indicates verbosity level.
+ , preClean :: Args -> CleanFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before clean command. Second arg indicates verbosity level.
+ , cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during clean.
+ , postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO ()
+ -- ^ Hook to run after clean command. Second arg indicates verbosity level.
+ , preCopy :: Args -> CopyFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before copy command
+ , copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during copy.
+ , postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after copy command
+ , preInst :: Args -> InstallFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before install command
+ , instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during install.
+ , postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after install command. postInst should be run
+ -- on the target, not on the build machine.
+ , preReg :: Args -> RegisterFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before register command
+ , regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during registration.
+ , postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after register command
+ , preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before unregister command
+ , unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during unregistration.
+ , postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after unregister command
+ , preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before hscolour command. Second arg indicates verbosity level.
+ , hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during hscolour.
+ , postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after hscolour command. Second arg indicates verbosity level.
+ , preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before haddock command. Second arg indicates verbosity level.
+ , haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during haddock.
+ , postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after haddock command. Second arg indicates verbosity level.
+ , preTest :: Args -> TestFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before test command.
+ , testHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during test.
+ , postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after test command.
+ , preBench :: Args -> BenchmarkFlags -> IO HookedBuildInfo
+ -- ^ Hook to run before bench command.
+ , benchHook :: Args -> PackageDescription -> LocalBuildInfo -> UserHooks -> BenchmarkFlags -> IO ()
+ -- ^ Over-ride this hook to get different behavior during bench.
+ , postBench :: Args -> BenchmarkFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ -- ^ Hook to run after bench command.
}
--- |Empty 'UserHooks' which do nothing.
+-- | Empty 'UserHooks' which do nothing.
emptyUserHooks :: UserHooks
-emptyUserHooks
- = UserHooks {
- readDesc = return Nothing,
- hookedPreProcessors = [],
- hookedPrograms = [],
- preConf = rn',
- confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),
- postConf = ru,
- preBuild = rn',
- buildHook = ru,
- postBuild = ru,
- preRepl = \_ _ -> return emptyHookedBuildInfo,
- replHook = \_ _ _ _ _ -> return (),
- postRepl = ru,
- preClean = rn,
- cleanHook = ru,
- postClean = ru,
- preCopy = rn',
- copyHook = ru,
- postCopy = ru,
- preInst = rn,
- instHook = ru,
- postInst = ru,
- preReg = rn',
- regHook = ru,
- postReg = ru,
- preUnreg = rn,
- unregHook = ru,
- postUnreg = ru,
- preHscolour = rn,
- hscolourHook = ru,
- postHscolour = ru,
- preHaddock = rn',
- haddockHook = ru,
- postHaddock = ru,
- preTest = rn',
- testHook = \_ -> ru,
- postTest = ru,
- preBench = rn',
- benchHook = \_ -> ru,
- postBench = ru
+emptyUserHooks =
+ UserHooks
+ { readDesc = return Nothing
+ , hookedPreProcessors = []
+ , hookedPrograms = []
+ , preConf = rn'
+ , confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook."))
+ , postConf = ru
+ , preBuild = rn'
+ , buildHook = ru
+ , postBuild = ru
+ , preRepl = \_ _ -> return emptyHookedBuildInfo
+ , replHook = \_ _ _ _ _ -> return ()
+ , postRepl = ru
+ , preClean = rn
+ , cleanHook = ru
+ , postClean = ru
+ , preCopy = rn'
+ , copyHook = ru
+ , postCopy = ru
+ , preInst = rn
+ , instHook = ru
+ , postInst = ru
+ , preReg = rn'
+ , regHook = ru
+ , postReg = ru
+ , preUnreg = rn
+ , unregHook = ru
+ , postUnreg = ru
+ , preHscolour = rn
+ , hscolourHook = ru
+ , postHscolour = ru
+ , preHaddock = rn'
+ , haddockHook = ru
+ , postHaddock = ru
+ , preTest = rn'
+ , testHook = \_ -> ru
+ , postTest = ru
+ , preBench = rn'
+ , benchHook = \_ -> ru
+ , postBench = ru
}
- where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo
- rn' _ _ = return emptyHookedBuildInfo
- ru _ _ _ _ = return ()
+ where
+ rn args _ = noExtraFlags args >> return emptyHookedBuildInfo
+ rn' _ _ = return emptyHookedBuildInfo
+ ru _ _ _ _ = return ()
diff --git a/Cabal/src/Distribution/Simple/Utils.hs b/Cabal/src/Distribution/Simple/Utils.hs
index 3fb6f56c7381cf4680940cbce49f6b85496be6c5..e141e5bbff43d0589430a93220bc5082fce599c1 100644
--- a/Cabal/src/Distribution/Simple/Utils.hs
+++ b/Cabal/src/Distribution/Simple/Utils.hs
@@ -1,13 +1,14 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Simple.Utils
-- Copyright : Isaac Jones, Simon Marlow 2003-2004
@@ -22,176 +23,185 @@
-- lib like @cabal-install@. It has a very simple set of logging actions. It
-- has low level functions for running programs, a bunch of wrappers for
-- various directory and file functions that do extra logging.
+module Distribution.Simple.Utils
+ ( cabalVersion
+
+ -- * logging and errors
+ , dieNoVerbosity
+ , die'
+ , dieWithLocation'
+ , dieNoWrap
+ , topHandler
+ , topHandlerWith
+ , warn
+ , notice
+ , noticeNoWrap
+ , noticeDoc
+ , setupMessage
+ , info
+ , infoNoWrap
+ , debug
+ , debugNoWrap
+ , chattyTry
+ , annotateIO
+ , withOutputMarker
+
+ -- * exceptions
+ , handleDoesNotExist
+ , ignoreSigPipe
+
+ -- * running programs
+ , rawSystemExit
+ , rawSystemExitCode
+ , rawSystemProc
+ , rawSystemProcAction
+ , rawSystemExitWithEnv
+ , rawSystemStdout
+ , rawSystemStdInOut
+ , rawSystemIOWithEnv
+ , rawSystemIOWithEnvAndAction
+ , fromCreatePipe
+ , maybeExit
+ , xargs
+ , findProgramVersion
+
+ -- ** 'IOData' re-export
-module Distribution.Simple.Utils (
- cabalVersion,
-
- -- * logging and errors
- dieNoVerbosity,
- die', dieWithLocation',
- dieNoWrap,
- topHandler, topHandlerWith,
- warn,
- notice, noticeNoWrap, noticeDoc,
- setupMessage,
- info, infoNoWrap,
- debug, debugNoWrap,
- chattyTry,
- annotateIO,
- withOutputMarker,
-
- -- * exceptions
- handleDoesNotExist,
- ignoreSigPipe,
-
- -- * running programs
- rawSystemExit,
- rawSystemExitCode,
- rawSystemProc,
- rawSystemProcAction,
- rawSystemExitWithEnv,
- rawSystemStdout,
- rawSystemStdInOut,
- rawSystemIOWithEnv,
- rawSystemIOWithEnvAndAction,
- fromCreatePipe,
- maybeExit,
- xargs,
- findProgramVersion,
-
- -- ** 'IOData' re-export
- --
- -- These types are re-exported from
- -- "Distribution.Utils.IOData" for convenience as they're
- -- exposed in the API of 'rawSystemStdInOut'
- IOData(..),
- KnownIODataMode (..),
- IODataMode (..),
-
- -- * copying files
- createDirectoryIfMissingVerbose,
- copyFileVerbose,
- copyFiles,
- copyFileTo,
-
- -- * installing files
- installOrdinaryFile,
- installExecutableFile,
- installMaybeExecutableFile,
- installOrdinaryFiles,
- installExecutableFiles,
- installMaybeExecutableFiles,
- installDirectoryContents,
- copyDirectoryRecursive,
-
- -- * File permissions
- doesExecutableExist,
- setFileOrdinary,
- setFileExecutable,
-
- -- * file names
- currentDir,
- shortRelativePath,
- dropExeExtension,
- exeExtensions,
-
- -- * finding files
- findFileEx,
- findFileCwd,
- findFirstFile,
- findFileWithExtension,
- findFileCwdWithExtension,
- findFileWithExtension',
- findAllFilesWithExtension,
- findAllFilesCwdWithExtension,
- findModuleFileEx,
- findModuleFilesEx,
- getDirectoryContentsRecursive,
-
- -- * environment variables
- isInSearchPath,
- addLibraryPath,
-
- -- * modification time
- moreRecentFile,
- existsAndIsMoreRecentThan,
-
- -- * temp files and dirs
- TempFileOptions(..), defaultTempFileOptions,
- withTempFile, withTempFileEx,
- withTempDirectory, withTempDirectoryEx,
- createTempDirectory,
-
- -- * .cabal and .buildinfo files
- defaultPackageDesc,
- findPackageDesc,
- findPackageDescCwd,
- tryFindPackageDesc,
- tryFindPackageDescCwd,
- findHookedPackageDesc,
-
- -- * reading and writing files safely
- withFileContents,
- writeFileAtomic,
- rewriteFileEx,
- rewriteFileLBS,
-
- -- * Unicode
- fromUTF8BS,
- fromUTF8LBS,
- toUTF8BS,
- toUTF8LBS,
- readUTF8File,
- withUTF8FileContents,
- writeUTF8File,
- normaliseLineEndings,
-
- -- * BOM
- ignoreBOM,
-
- -- * generic utils
- dropWhileEndLE,
- takeWhileEndLE,
- equating,
- comparing,
- isInfixOf,
- intercalate,
- lowercase,
- listUnion,
- listUnionRight,
- ordNub,
- ordNubBy,
- ordNubRight,
- safeHead,
- safeTail,
- safeLast,
- safeInit,
- unintersperse,
- wrapText,
- wrapLine,
-
- -- * FilePath stuff
- isAbsoluteOnAnyPlatform,
- isRelativeOnAnyPlatform,
+ --
+ -- These types are re-exported from
+ -- "Distribution.Utils.IOData" for convenience as they're
+ -- exposed in the API of 'rawSystemStdInOut'
+ , IOData (..)
+ , KnownIODataMode (..)
+ , IODataMode (..)
+
+ -- * copying files
+ , createDirectoryIfMissingVerbose
+ , copyFileVerbose
+ , copyFiles
+ , copyFileTo
+
+ -- * installing files
+ , installOrdinaryFile
+ , installExecutableFile
+ , installMaybeExecutableFile
+ , installOrdinaryFiles
+ , installExecutableFiles
+ , installMaybeExecutableFiles
+ , installDirectoryContents
+ , copyDirectoryRecursive
+
+ -- * File permissions
+ , doesExecutableExist
+ , setFileOrdinary
+ , setFileExecutable
+
+ -- * file names
+ , currentDir
+ , shortRelativePath
+ , dropExeExtension
+ , exeExtensions
+
+ -- * finding files
+ , findFileEx
+ , findFileCwd
+ , findFirstFile
+ , findFileWithExtension
+ , findFileCwdWithExtension
+ , findFileWithExtension'
+ , findAllFilesWithExtension
+ , findAllFilesCwdWithExtension
+ , findModuleFileEx
+ , findModuleFilesEx
+ , getDirectoryContentsRecursive
+
+ -- * environment variables
+ , isInSearchPath
+ , addLibraryPath
+
+ -- * modification time
+ , moreRecentFile
+ , existsAndIsMoreRecentThan
+
+ -- * temp files and dirs
+ , TempFileOptions (..)
+ , defaultTempFileOptions
+ , withTempFile
+ , withTempFileEx
+ , withTempDirectory
+ , withTempDirectoryEx
+ , createTempDirectory
+
+ -- * .cabal and .buildinfo files
+ , defaultPackageDesc
+ , findPackageDesc
+ , findPackageDescCwd
+ , tryFindPackageDesc
+ , tryFindPackageDescCwd
+ , findHookedPackageDesc
+
+ -- * reading and writing files safely
+ , withFileContents
+ , writeFileAtomic
+ , rewriteFileEx
+ , rewriteFileLBS
+
+ -- * Unicode
+ , fromUTF8BS
+ , fromUTF8LBS
+ , toUTF8BS
+ , toUTF8LBS
+ , readUTF8File
+ , withUTF8FileContents
+ , writeUTF8File
+ , normaliseLineEndings
+
+ -- * BOM
+ , ignoreBOM
+
+ -- * generic utils
+ , dropWhileEndLE
+ , takeWhileEndLE
+ , equating
+ , comparing
+ , isInfixOf
+ , intercalate
+ , lowercase
+ , listUnion
+ , listUnionRight
+ , ordNub
+ , ordNubBy
+ , ordNubRight
+ , safeHead
+ , safeTail
+ , safeLast
+ , safeInit
+ , unintersperse
+ , wrapText
+ , wrapLine
+
+ -- * FilePath stuff
+ , isAbsoluteOnAnyPlatform
+ , isRelativeOnAnyPlatform
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Utils.Generic
-import Distribution.Utils.IOData (IOData(..), IODataMode (..), KnownIODataMode (..))
-import qualified Distribution.Utils.IOData as IOData
-import Distribution.ModuleName as ModuleName
-import Distribution.System
-import Distribution.Version
import Distribution.Compat.Async (waitCatch, withAsyncNF)
import Distribution.Compat.CopyFile
import Distribution.Compat.FilePath as FilePath
import Distribution.Compat.Internal.TempFile
import Distribution.Compat.Lens (Lens', over)
import Distribution.Compat.Stack
-import Distribution.Verbosity
+import Distribution.ModuleName as ModuleName
+import Distribution.System
import Distribution.Types.PackageId
+import Distribution.Utils.Generic
+import Distribution.Utils.IOData (IOData (..), IODataMode (..), KnownIODataMode (..))
+import qualified Distribution.Utils.IOData as IOData
+import Distribution.Verbosity
+import Distribution.Version
#ifdef CURRENT_PACKAGE_KEY
#define BOOTSTRAPPED_CABAL 1
@@ -201,37 +211,64 @@ import Distribution.Types.PackageId
import qualified Paths_Cabal (version)
#endif
-import Distribution.Pretty
import Distribution.Parsec
+import Distribution.Pretty
-import Data.Typeable
- ( cast )
import qualified Data.ByteString.Lazy as BS
+import Data.Typeable
+ ( cast
+ )
+import qualified Control.Exception as Exception
import System.Directory
- ( Permissions(executable), getDirectoryContents, getPermissions
- , doesDirectoryExist, doesFileExist, removeFile
- , getModificationTime, createDirectory, removeDirectoryRecursive )
+ ( Permissions (executable)
+ , createDirectory
+ , doesDirectoryExist
+ , doesFileExist
+ , getDirectoryContents
+ , getModificationTime
+ , getPermissions
+ , removeDirectoryRecursive
+ , removeFile
+ )
import System.Environment
- ( getProgName )
+ ( getProgName
+ )
import System.FilePath as FilePath
- ( normalise, (</>), (<.>)
- , getSearchPath, joinPath, takeDirectory, splitExtension
- , splitDirectories, searchPathSeparator )
+ ( getSearchPath
+ , joinPath
+ , normalise
+ , searchPathSeparator
+ , splitDirectories
+ , splitExtension
+ , takeDirectory
+ , (<.>)
+ , (</>)
+ )
import System.IO
- ( Handle, hSetBinaryMode, hGetContents, stderr, stdout, hPutStr, hFlush
- , hClose, hSetBuffering, BufferMode(..), hPutStrLn )
+ ( BufferMode (..)
+ , Handle
+ , hClose
+ , hFlush
+ , hGetContents
+ , hPutStr
+ , hPutStrLn
+ , hSetBinaryMode
+ , hSetBuffering
+ , stderr
+ , stdout
+ )
import System.IO.Error
import System.IO.Unsafe
- ( unsafeInterleaveIO )
-import qualified Control.Exception as Exception
+ ( unsafeInterleaveIO
+ )
+import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
+import Distribution.Compat.Process (proc)
import Foreign.C.Error (Errno (..), ePIPE)
-import Data.Time.Clock.POSIX (getPOSIXTime, POSIXTime)
+import qualified GHC.IO.Exception as GHC
import Numeric (showFFloat)
-import Distribution.Compat.Process (proc)
import qualified System.Process as Process
-import qualified GHC.IO.Exception as GHC
import qualified Text.PrettyPrint as Disp
@@ -299,8 +336,8 @@ cabalVersion = mkVersion [3,0] --used when bootstrapping
--
dieNoVerbosity :: String -> IO a
-dieNoVerbosity msg
- = ioError (userError msg)
+dieNoVerbosity msg =
+ ioError (userError msg)
where
_ = callStack -- TODO: Attach CallStack to exception
@@ -319,37 +356,41 @@ verbatimUserError = ioeSetVerbatim . userError
dieWithLocation' :: Verbosity -> FilePath -> Maybe Int -> String -> IO a
dieWithLocation' verbosity filename mb_lineno msg =
- die' verbosity $
- filename ++ (case mb_lineno of
- Just lineno -> ":" ++ show lineno
- Nothing -> "") ++
- ": " ++ msg
+ die' verbosity $
+ filename
+ ++ ( case mb_lineno of
+ Just lineno -> ":" ++ show lineno
+ Nothing -> ""
+ )
+ ++ ": "
+ ++ msg
die' :: Verbosity -> String -> IO a
die' verbosity msg = withFrozenCallStack $ do
- ioError . verbatimUserError
- =<< annotateErrorString verbosity
- =<< pure . wrapTextVerbosity verbosity
- =<< pure . addErrorPrefix
- =<< prefixWithProgName msg
+ ioError . verbatimUserError
+ =<< annotateErrorString verbosity
+ =<< pure . wrapTextVerbosity verbosity
+ =<< pure . addErrorPrefix
+ =<< prefixWithProgName msg
dieNoWrap :: Verbosity -> String -> IO a
dieNoWrap verbosity msg = withFrozenCallStack $ do
- -- TODO: should this have program name or not?
- ioError . verbatimUserError
- =<< annotateErrorString verbosity
- (addErrorPrefix msg)
+ -- TODO: should this have program name or not?
+ ioError . verbatimUserError
+ =<< annotateErrorString
+ verbosity
+ (addErrorPrefix msg)
-- | Prefixing a message to indicate that it is a fatal error,
-- if the 'errorPrefix' is not already present.
addErrorPrefix :: String -> String
addErrorPrefix msg
| errorPrefix `isPrefixOf` msg = msg
- -- Backpack prefixes its errors already with "Error:", see
- -- 'Distribution.Utils.LogProgress.dieProgress'.
- -- Taking it away there destroys the layout, so we rather
- -- check here whether the prefix is already present.
- | otherwise = unwords [errorPrefix, msg]
+ -- Backpack prefixes its errors already with "Error:", see
+ -- 'Distribution.Utils.LogProgress.dieProgress'.
+ -- Taking it away there destroys the layout, so we rather
+ -- check here whether the prefix is already present.
+ | otherwise = unwords [errorPrefix, msg]
-- | A prefix indicating that a message is a fatal error.
errorPrefix :: String
@@ -358,14 +399,14 @@ errorPrefix = "Error:"
-- | Prefix an error string with program name from 'getProgName'
prefixWithProgName :: String -> IO String
prefixWithProgName msg = do
- pname <- getProgName
- return $ pname ++ ": " ++ msg
+ pname <- getProgName
+ return $ pname ++ ": " ++ msg
-- | Annotate an error string with timestamp and 'withMetadata'.
annotateErrorString :: Verbosity -> String -> IO String
annotateErrorString verbosity msg = do
- ts <- getPOSIXTime
- return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg
+ ts <- getPOSIXTime
+ return $ withMetadata ts AlwaysMark VerboseTrace verbosity msg
-- | Given a block of IO code that may raise an exception, annotate
-- it with the metadata from the current scope. Use this as close
@@ -374,9 +415,10 @@ annotateErrorString verbosity msg = do
-- (so it is NOT idempotent.)
annotateIO :: Verbosity -> IO a -> IO a
annotateIO verbosity act = do
- ts <- getPOSIXTime
- flip modifyIOError act $
- ioeModifyErrorString $ withMetadata ts NeverMark VerboseTrace verbosity
+ ts <- getPOSIXTime
+ flip modifyIOError act $
+ ioeModifyErrorString $
+ withMetadata ts NeverMark VerboseTrace verbosity
-- | A semantic editor for the error message inside an 'IOError'.
ioeModifyErrorString :: (String -> String) -> IOError -> IOError
@@ -386,18 +428,18 @@ ioeModifyErrorString = over ioeErrorString
ioeErrorString :: Lens' IOError String
ioeErrorString f ioe = ioeSetErrorString ioe <$> f (ioeGetErrorString ioe)
-
{-# NOINLINE topHandlerWith #-}
topHandlerWith :: forall a. (Exception.SomeException -> IO a) -> IO a -> IO a
topHandlerWith cont prog = do
- -- By default, stderr to a terminal device is NoBuffering. But this
- -- is *really slow*
- hSetBuffering stderr LineBuffering
- Exception.catches prog [
- Exception.Handler rethrowAsyncExceptions
- , Exception.Handler rethrowExitStatus
- , Exception.Handler handle
- ]
+ -- By default, stderr to a terminal device is NoBuffering. But this
+ -- is *really slow*
+ hSetBuffering stderr LineBuffering
+ Exception.catches
+ prog
+ [ Exception.Handler rethrowAsyncExceptions
+ , Exception.Handler rethrowExitStatus
+ , Exception.Handler handle
+ ]
where
-- Let async exceptions rise to the top for the default top-handler
rethrowAsyncExceptions :: Exception.AsyncException -> IO a
@@ -419,18 +461,18 @@ topHandlerWith cont prog = do
message pname (Exception.SomeException se) =
case cast se :: Maybe Exception.IOException of
Just ioe
- | ioeGetVerbatim ioe ->
- -- Use the message verbatim
- ioeGetErrorString ioe ++ "\n"
- | isUserError ioe ->
- let file = case ioeGetFileName ioe of
- Nothing -> ""
- Just path -> path ++ location ++ ": "
- location = case ioeGetLocation ioe of
- l@(n:_) | isDigit n -> ':' : l
- _ -> ""
- detail = ioeGetErrorString ioe
- in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail
+ | ioeGetVerbatim ioe ->
+ -- Use the message verbatim
+ ioeGetErrorString ioe ++ "\n"
+ | isUserError ioe ->
+ let file = case ioeGetFileName ioe of
+ Nothing -> ""
+ Just path -> path ++ location ++ ": "
+ location = case ioeGetLocation ioe of
+ l@(n : _) | isDigit n -> ':' : l
+ _ -> ""
+ detail = ioeGetErrorString ioe
+ in wrapText $ addErrorPrefix $ pname ++ ": " ++ file ++ detail
_ ->
displaySomeException se ++ "\n"
@@ -444,21 +486,21 @@ topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog
-- | Depending on 'isVerboseStderr', set the output handle to 'stderr' or 'stdout'.
verbosityHandle :: Verbosity -> Handle
verbosityHandle verbosity
- | isVerboseStderr verbosity = stderr
- | otherwise = stdout
+ | isVerboseStderr verbosity = stderr
+ | otherwise = stdout
-- | Non fatal conditions that may be indicative of an error or problem.
--
-- We display these at the 'normal' verbosity level.
---
warn :: Verbosity -> String -> IO ()
warn verbosity msg = withFrozenCallStack $ do
when ((verbosity >= normal) && not (isVerboseNoWarn verbosity)) $ do
ts <- getPOSIXTime
hFlush stdout
- hPutStr stderr . withMetadata ts NormalMark FlagTrace verbosity
- . wrapTextVerbosity verbosity
- $ "Warning: " ++ msg
+ hPutStr stderr
+ . withMetadata ts NormalMark FlagTrace verbosity
+ . wrapTextVerbosity verbosity
+ $ "Warning: " ++ msg
-- | Useful status messages.
--
@@ -466,20 +508,18 @@ warn verbosity msg = withFrozenCallStack $ do
--
-- This is for the ordinary helpful status messages that users see. Just
-- enough information to know that things are working but not floods of detail.
---
notice :: Verbosity -> String -> IO ()
notice verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do
let h = verbosityHandle verbosity
ts <- getPOSIXTime
- hPutStr h
- $ withMetadata ts NormalMark FlagTrace verbosity
- $ wrapTextVerbosity verbosity
- $ msg
+ hPutStr h $
+ withMetadata ts NormalMark FlagTrace verbosity $
+ wrapTextVerbosity verbosity $
+ msg
-- | Display a message at 'normal' verbosity level, but without
-- wrapping.
---
noticeNoWrap :: Verbosity -> String -> IO ()
noticeNoWrap verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do
@@ -489,59 +529,56 @@ noticeNoWrap verbosity msg = withFrozenCallStack $ do
-- | Pretty-print a 'Disp.Doc' status message at 'normal' verbosity
-- level. Use this if you need fancy formatting.
---
noticeDoc :: Verbosity -> Disp.Doc -> IO ()
noticeDoc verbosity msg = withFrozenCallStack $ do
when (verbosity >= normal) $ do
let h = verbosityHandle verbosity
ts <- getPOSIXTime
- hPutStr h
- $ withMetadata ts NormalMark FlagTrace verbosity
- $ Disp.renderStyle defaultStyle
- $ msg
+ hPutStr h $
+ withMetadata ts NormalMark FlagTrace verbosity $
+ Disp.renderStyle defaultStyle $
+ msg
-- | Display a "setup status message". Prefer using setupMessage'
-- if possible.
---
setupMessage :: Verbosity -> String -> PackageIdentifier -> IO ()
setupMessage verbosity msg pkgid = withFrozenCallStack $ do
- noticeNoWrap verbosity (msg ++ ' ': prettyShow pkgid ++ "...")
+ noticeNoWrap verbosity (msg ++ ' ' : prettyShow pkgid ++ "...")
-- | More detail on the operation of some action.
--
-- We display these messages when the verbosity level is 'verbose'
---
info :: Verbosity -> String -> IO ()
info verbosity msg = withFrozenCallStack $
when (verbosity >= verbose) $ do
let h = verbosityHandle verbosity
ts <- getPOSIXTime
- hPutStr h
- $ withMetadata ts NeverMark FlagTrace verbosity
- $ wrapTextVerbosity verbosity
- $ msg
+ hPutStr h $
+ withMetadata ts NeverMark FlagTrace verbosity $
+ wrapTextVerbosity verbosity $
+ msg
infoNoWrap :: Verbosity -> String -> IO ()
infoNoWrap verbosity msg = withFrozenCallStack $
when (verbosity >= verbose) $ do
let h = verbosityHandle verbosity
ts <- getPOSIXTime
- hPutStr h
- $ withMetadata ts NeverMark FlagTrace verbosity
- $ msg
+ hPutStr h $
+ withMetadata ts NeverMark FlagTrace verbosity $
+ msg
-- | Detailed internal debugging information
--
-- We display these messages when the verbosity level is 'deafening'
---
debug :: Verbosity -> String -> IO ()
debug verbosity msg = withFrozenCallStack $
when (verbosity >= deafening) $ do
let h = verbosityHandle verbosity
ts <- getPOSIXTime
- hPutStr h $ withMetadata ts NeverMark FlagTrace verbosity
- $ wrapTextVerbosity verbosity
- $ msg
+ hPutStr h $
+ withMetadata ts NeverMark FlagTrace verbosity $
+ wrapTextVerbosity verbosity $
+ msg
-- ensure that we don't lose output if we segfault/infinite loop
hFlush stdout
@@ -552,17 +589,20 @@ debugNoWrap verbosity msg = withFrozenCallStack $
when (verbosity >= deafening) $ do
let h = verbosityHandle verbosity
ts <- getPOSIXTime
- hPutStr h
- $ withMetadata ts NeverMark FlagTrace verbosity
- $ msg
+ hPutStr h $
+ withMetadata ts NeverMark FlagTrace verbosity $
+ msg
-- ensure that we don't lose output if we segfault/infinite loop
hFlush stdout
-- | Perform an IO action, catching any IO exceptions and printing an error
-- if one occurs.
-chattyTry :: String -- ^ a description of the action we were attempting
- -> IO () -- ^ the action itself
- -> IO ()
+chattyTry
+ :: String
+ -- ^ a description of the action we were attempting
+ -> IO ()
+ -- ^ the action itself
+ -> IO ()
chattyTry desc action =
catchIO action $ \exception ->
hPutStrLn stderr $ "Error while " ++ desc ++ ": " ++ show exception
@@ -571,9 +611,9 @@ chattyTry desc action =
-- does not exist" error.
handleDoesNotExist :: a -> IO a -> IO a
handleDoesNotExist e =
- Exception.handleJust
- (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
- (\_ -> return e)
+ Exception.handleJust
+ (\ioe -> if isDoesNotExistError ioe then Just ioe else Nothing)
+ (\_ -> return e)
-- -----------------------------------------------------------------------------
-- Helper functions
@@ -582,21 +622,19 @@ handleDoesNotExist e =
wrapTextVerbosity :: Verbosity -> String -> String
wrapTextVerbosity verb
| isVerboseNoWrap verb = withTrailingNewline
- | otherwise = withTrailingNewline . wrapText
-
+ | otherwise = withTrailingNewline . wrapText
-- | Prepends a timestamp if @+timestamp@ verbosity flag is set
--
-- This is used by 'withMetadata'
---
withTimestamp :: Verbosity -> POSIXTime -> String -> String
withTimestamp v ts msg
- | isVerboseTimestamp v = msg'
- | otherwise = msg -- no-op
+ | isVerboseTimestamp v = msg'
+ | otherwise = msg -- no-op
where
msg' = case lines msg of
- [] -> tsstr "\n"
- l1:rest -> unlines (tsstr (' ':l1) : map (contpfx++) rest)
+ [] -> tsstr "\n"
+ l1 : rest -> unlines (tsstr (' ' : l1) : map (contpfx ++) rest)
-- format timestamp to be prepended to first line with msec precision
tsstr = showFFloat (Just 3) (realToFrac ts :: Double)
@@ -615,93 +653,96 @@ withTimestamp v ts msg
-- we don't have the ability to interpose on the output.
--
-- This is used by 'withMetadata'
---
withOutputMarker :: Verbosity -> String -> String
withOutputMarker v xs | not (isVerboseMarkOutput v) = xs
withOutputMarker _ "" = "" -- Minor optimization, don't mark uselessly
withOutputMarker _ xs =
- "-----BEGIN CABAL OUTPUT-----\n" ++
- withTrailingNewline xs ++
- "-----END CABAL OUTPUT-----\n"
+ "-----BEGIN CABAL OUTPUT-----\n"
+ ++ withTrailingNewline xs
+ ++ "-----END CABAL OUTPUT-----\n"
-- | Append a trailing newline to a string if it does not
-- already have a trailing newline.
---
withTrailingNewline :: String -> String
withTrailingNewline "" = ""
-withTrailingNewline (x:xs) = x : go x xs
+withTrailingNewline (x : xs) = x : go x xs
where
- go _ (c:cs) = c : go c cs
+ go _ (c : cs) = c : go c cs
go '\n' "" = ""
- go _ "" = "\n"
+ go _ "" = "\n"
-- | Prepend a call-site and/or call-stack based on Verbosity
---
withCallStackPrefix :: WithCallStack (TraceWhen -> Verbosity -> String -> String)
-withCallStackPrefix tracer verbosity s = withFrozenCallStack $
- (if isVerboseCallSite verbosity
- then parentSrcLocPrefix ++
- -- Hack: need a newline before starting output marker :(
- if isVerboseMarkOutput verbosity
- then "\n"
- else ""
- else "") ++
- (case traceWhen verbosity tracer of
- Just pre -> pre ++ prettyCallStack callStack ++ "\n"
- Nothing -> "") ++
- s
+withCallStackPrefix tracer verbosity s =
+ withFrozenCallStack $
+ ( if isVerboseCallSite verbosity
+ then
+ parentSrcLocPrefix
+ ++
+ -- Hack: need a newline before starting output marker :(
+ if isVerboseMarkOutput verbosity
+ then "\n"
+ else ""
+ else ""
+ )
+ ++ ( case traceWhen verbosity tracer of
+ Just pre -> pre ++ prettyCallStack callStack ++ "\n"
+ Nothing -> ""
+ )
+ ++ s
-- | When should we emit the call stack? We always emit
-- for internal errors, emit the trace for errors when we
-- are in verbose mode, and otherwise only emit it if
-- explicitly asked for using the @+callstack@ verbosity
-- flag. (At the moment, 'AlwaysTrace' is not used.
---
data TraceWhen
- = AlwaysTrace
- | VerboseTrace
- | FlagTrace
- deriving (Eq)
+ = AlwaysTrace
+ | VerboseTrace
+ | FlagTrace
+ deriving (Eq)
-- | Determine if we should emit a call stack.
-- If we trace, it also emits any prefix we should append.
traceWhen :: Verbosity -> TraceWhen -> Maybe String
traceWhen _ AlwaysTrace = Just ""
-traceWhen v VerboseTrace | v >= verbose = Just ""
-traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n"
+traceWhen v VerboseTrace | v >= verbose = Just ""
+traceWhen v FlagTrace | isVerboseCallStack v = Just "----\n"
traceWhen _ _ = Nothing
-- | When should we output the marker? Things like 'die'
-- always get marked, but a 'NormalMark' will only be
-- output if we're not a quiet verbosity.
---
data MarkWhen = AlwaysMark | NormalMark | NeverMark
-- | Add all necessary metadata to a logging message
---
withMetadata :: WithCallStack (POSIXTime -> MarkWhen -> TraceWhen -> Verbosity -> String -> String)
-withMetadata ts marker tracer verbosity x = withFrozenCallStack $
+withMetadata ts marker tracer verbosity x =
+ withFrozenCallStack
+ $
-- NB: order matters. Output marker first because we
-- don't want to capture call stacks.
- withTrailingNewline
- . withCallStackPrefix tracer verbosity
- . (case marker of
- AlwaysMark -> withOutputMarker verbosity
- NormalMark | not (isVerboseQuiet verbosity)
- -> withOutputMarker verbosity
- | otherwise
- -> id
- NeverMark -> id)
- -- Clear out any existing markers
- . clearMarkers
- . withTimestamp verbosity ts
+ withTrailingNewline
+ . withCallStackPrefix tracer verbosity
+ . ( case marker of
+ AlwaysMark -> withOutputMarker verbosity
+ NormalMark
+ | not (isVerboseQuiet verbosity) ->
+ withOutputMarker verbosity
+ | otherwise ->
+ id
+ NeverMark -> id
+ )
+ -- Clear out any existing markers
+ . clearMarkers
+ . withTimestamp verbosity ts
$ x
clearMarkers :: String -> String
clearMarkers s = unlines . filter isMarker $ lines s
where
isMarker "-----BEGIN CABAL OUTPUT-----" = False
- isMarker "-----END CABAL OUTPUT-----" = False
+ isMarker "-----END CABAL OUTPUT-----" = False
isMarker _ = True
-- -----------------------------------------------------------------------------
@@ -724,12 +765,12 @@ maybeExit cmd = do
-- | Log a command execution (that's typically about to happen)
-- at info level, and log working directory and environment overrides
-- at debug level if specified.
---
logCommand :: Verbosity -> Process.CreateProcess -> IO ()
logCommand verbosity cp = do
- infoNoWrap verbosity $ "Running: " <> case Process.cmdspec cp of
- Process.ShellCommand sh -> sh
- Process.RawCommand path args -> Process.showCommandForUser path args
+ infoNoWrap verbosity $
+ "Running: " <> case Process.cmdspec cp of
+ Process.ShellCommand sh -> sh
+ Process.RawCommand path args -> Process.showCommandForUser path args
case Process.env cp of
Just env -> debugNoWrap verbosity $ "with environment: " ++ show env
Nothing -> return ()
@@ -740,17 +781,19 @@ logCommand verbosity cp = do
-- | Execute the given command with the given arguments, exiting
-- with the same exit code if the command fails.
---
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
-rawSystemExit verbosity path args = withFrozenCallStack $
- maybeExit $ rawSystemExitCode verbosity path args
+rawSystemExit verbosity path args =
+ withFrozenCallStack $
+ maybeExit $
+ rawSystemExitCode verbosity path args
-- | Execute the given command with the given arguments, returning
-- the command's exit code.
---
rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
-rawSystemExitCode verbosity path args = withFrozenCallStack $
- rawSystemProc verbosity $ proc path args
+rawSystemExitCode verbosity path args =
+ withFrozenCallStack $
+ rawSystemProc verbosity $
+ proc path args
-- | Execute the given command with the given arguments, returning
-- the command's exit code.
@@ -758,7 +801,6 @@ rawSystemExitCode verbosity path args = withFrozenCallStack $
-- Create the process argument with 'Distribution.Compat.Process.proc'
-- to ensure consistent options with other 'rawSystem' functions in this
-- module.
---
rawSystemProc :: Verbosity -> Process.CreateProcess -> IO ExitCode
rawSystemProc verbosity cp = withFrozenCallStack $ do
(exitcode, _) <- rawSystemProcAction verbosity cp $ \_ _ _ -> return ()
@@ -772,10 +814,11 @@ rawSystemProc verbosity cp = withFrozenCallStack $ do
-- Create the process argument with 'Distribution.Compat.Process.proc'
-- to ensure consistent options with other 'rawSystem' functions in this
-- module.
---
-rawSystemProcAction :: Verbosity -> Process.CreateProcess
- -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
- -> IO (ExitCode, a)
+rawSystemProcAction
+ :: Verbosity
+ -> Process.CreateProcess
+ -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> IO a)
+ -> IO (ExitCode, a)
rawSystemProcAction verbosity cp action = withFrozenCallStack $ do
logCommand verbosity cp
(exitcode, a) <- Process.withCreateProcess cp $ \mStdin mStdout mStderr p -> do
@@ -792,41 +835,57 @@ rawSystemProcAction verbosity cp action = withFrozenCallStack $ do
-- | fromJust for dealing with 'Maybe Handle' values as obtained via
-- 'System.Process.CreatePipe'. Creating a pipe using 'CreatePipe' guarantees
-- a 'Just' value for the corresponding handle.
---
fromCreatePipe :: Maybe Handle -> Handle
fromCreatePipe = maybe (error "fromCreatePipe: Nothing") id
-- | Execute the given command with the given arguments and
-- environment, exiting with the same exit code if the command fails.
---
-rawSystemExitWithEnv :: Verbosity
- -> FilePath
- -> [String]
- -> [(String, String)]
- -> IO ()
-rawSystemExitWithEnv verbosity path args env = withFrozenCallStack $
- maybeExit $ rawSystemProc verbosity $
- (proc path args) { Process.env = Just env
- }
+rawSystemExitWithEnv
+ :: Verbosity
+ -> FilePath
+ -> [String]
+ -> [(String, String)]
+ -> IO ()
+rawSystemExitWithEnv verbosity path args env =
+ withFrozenCallStack $
+ maybeExit $
+ rawSystemProc verbosity $
+ (proc path args)
+ { Process.env = Just env
+ }
-- | Execute the given command with the given arguments, returning
-- the command's exit code.
--
-- Optional arguments allow setting working directory, environment
-- and input and output handles.
---
-rawSystemIOWithEnv :: Verbosity
- -> FilePath
- -> [String]
- -> Maybe FilePath -- ^ New working dir or inherit
- -> Maybe [(String, String)] -- ^ New environment or inherit
- -> Maybe Handle -- ^ stdin
- -> Maybe Handle -- ^ stdout
- -> Maybe Handle -- ^ stderr
- -> IO ExitCode
+rawSystemIOWithEnv
+ :: Verbosity
+ -> FilePath
+ -> [String]
+ -> Maybe FilePath
+ -- ^ New working dir or inherit
+ -> Maybe [(String, String)]
+ -- ^ New environment or inherit
+ -> Maybe Handle
+ -- ^ stdin
+ -> Maybe Handle
+ -- ^ stdout
+ -> Maybe Handle
+ -- ^ stderr
+ -> IO ExitCode
rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallStack $ do
- (exitcode, _) <- rawSystemIOWithEnvAndAction
- verbosity path args mcwd menv action inp out err
+ (exitcode, _) <-
+ rawSystemIOWithEnvAndAction
+ verbosity
+ path
+ args
+ mcwd
+ menv
+ action
+ inp
+ out
+ err
return exitcode
where
action = return ()
@@ -838,25 +897,32 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = withFrozenCallSta
--
-- Optional arguments allow setting working directory, environment
-- and input and output handles.
---
rawSystemIOWithEnvAndAction
- :: Verbosity
- -> FilePath
- -> [String]
- -> Maybe FilePath -- ^ New working dir or inherit
- -> Maybe [(String, String)] -- ^ New environment or inherit
- -> IO a -- ^ action to perform after process is created, but before 'waitForProcess'.
- -> Maybe Handle -- ^ stdin
- -> Maybe Handle -- ^ stdout
- -> Maybe Handle -- ^ stderr
- -> IO (ExitCode, a)
+ :: Verbosity
+ -> FilePath
+ -> [String]
+ -> Maybe FilePath
+ -- ^ New working dir or inherit
+ -> Maybe [(String, String)]
+ -- ^ New environment or inherit
+ -> IO a
+ -- ^ action to perform after process is created, but before 'waitForProcess'.
+ -> Maybe Handle
+ -- ^ stdin
+ -> Maybe Handle
+ -- ^ stdout
+ -> Maybe Handle
+ -- ^ stderr
+ -> IO (ExitCode, a)
rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = withFrozenCallStack $ do
- let cp = (proc path args) { Process.cwd = mcwd
- , Process.env = menv
- , Process.std_in = mbToStd inp
- , Process.std_out = mbToStd out
- , Process.std_err = mbToStd err
- }
+ let cp =
+ (proc path args)
+ { Process.cwd = mcwd
+ , Process.env = menv
+ , Process.std_in = mbToStd inp
+ , Process.std_out = mbToStd out
+ , Process.std_err = mbToStd err
+ }
rawSystemProcAction verbosity cp (\_ _ _ -> action)
where
mbToStd :: Maybe Handle -> Process.StdStream
@@ -866,11 +932,17 @@ rawSystemIOWithEnvAndAction verbosity path args mcwd menv action inp out err = w
-- the command's output. Exits if the command exits with error.
--
-- Provides control over the binary/text mode of the output.
---
rawSystemStdout :: forall mode. KnownIODataMode mode => Verbosity -> FilePath -> [String] -> IO mode
rawSystemStdout verbosity path args = withFrozenCallStack $ do
- (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
- Nothing Nothing Nothing (IOData.iodataMode :: IODataMode mode)
+ (output, errors, exitCode) <-
+ rawSystemStdInOut
+ verbosity
+ path
+ args
+ Nothing
+ Nothing
+ Nothing
+ (IOData.iodataMode :: IODataMode mode)
when (exitCode /= ExitSuccess) $
die' verbosity errors
return output
@@ -882,23 +954,32 @@ rawSystemStdout verbosity path args = withFrozenCallStack $ do
-- and command input.
--
-- Provides control over the binary/text mode of the input and output.
---
-rawSystemStdInOut :: KnownIODataMode mode
- => Verbosity
- -> FilePath -- ^ Program location
- -> [String] -- ^ Arguments
- -> Maybe FilePath -- ^ New working dir or inherit
- -> Maybe [(String, String)] -- ^ New environment or inherit
- -> Maybe IOData -- ^ input text and binary mode
- -> IODataMode mode -- ^ iodata mode, acts as proxy
- -> IO (mode, String, ExitCode) -- ^ output, errors, exit
+rawSystemStdInOut
+ :: KnownIODataMode mode
+ => Verbosity
+ -> FilePath
+ -- ^ Program location
+ -> [String]
+ -- ^ Arguments
+ -> Maybe FilePath
+ -- ^ New working dir or inherit
+ -> Maybe [(String, String)]
+ -- ^ New environment or inherit
+ -> Maybe IOData
+ -- ^ input text and binary mode
+ -> IODataMode mode
+ -- ^ iodata mode, acts as proxy
+ -> IO (mode, String, ExitCode)
+ -- ^ output, errors, exit
rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $ do
- let cp = (proc path args) { Process.cwd = mcwd
- , Process.env = menv
- , Process.std_in = Process.CreatePipe
- , Process.std_out = Process.CreatePipe
- , Process.std_err = Process.CreatePipe
- }
+ let cp =
+ (proc path args)
+ { Process.cwd = mcwd
+ , Process.env = menv
+ , Process.std_in = Process.CreatePipe
+ , Process.std_out = Process.CreatePipe
+ , Process.std_err = Process.CreatePipe
+ }
(exitcode, (mberr1, mberr2)) <- rawSystemProcAction verbosity cp $ \mb_in mb_out mb_err -> do
let (inh, outh, errh) = (fromCreatePipe mb_in, fromCreatePipe mb_out, fromCreatePipe mb_err)
@@ -913,7 +994,7 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $
withAsyncNF (hGetContents errh) $ \errA -> withAsyncNF (IOData.hGetIODataContents outh) $ \outA -> do
-- push all the input, if any
ignoreSigPipe $ case input of
- Nothing -> hClose inh
+ Nothing -> hClose inh
Just inputData -> IOData.hPutContents inh inputData
-- wait for both to finish
@@ -925,14 +1006,20 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $
err <- reportOutputIOError mberr2
unless (exitcode == ExitSuccess) $
- debug verbosity $ path ++ " returned " ++ show exitcode
- ++ if null err then "" else
- " with error message:\n" ++ err
- ++ case input of
- Nothing -> ""
- Just d | IOData.null d -> ""
- Just (IODataText inp) -> "\nstdin input:\n" ++ inp
- Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp
+ debug verbosity $
+ path
+ ++ " returned "
+ ++ show exitcode
+ ++ if null err
+ then ""
+ else
+ " with error message:\n"
+ ++ err
+ ++ case input of
+ Nothing -> ""
+ Just d | IOData.null d -> ""
+ Just (IODataText inp) -> "\nstdin input:\n" ++ inp
+ Just (IODataBinary inp) -> "\nstdin input (binary):\n" ++ show inp
-- Check if we hit an exception while consuming the output
-- (e.g. a text decoding error)
@@ -943,40 +1030,46 @@ rawSystemStdInOut verbosity path args mcwd menv input _ = withFrozenCallStack $
reportOutputIOError :: Either Exception.SomeException a -> IO a
reportOutputIOError (Right x) = return x
reportOutputIOError (Left exc) = case fromException exc of
- Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))
- Nothing -> throwIO exc
+ Just ioe -> throwIO (ioeSetFileName ioe ("output of " ++ path))
+ Nothing -> throwIO exc
-- | Ignore SIGPIPE in a subcomputation.
---
ignoreSigPipe :: IO () -> IO ()
ignoreSigPipe = Exception.handle $ \case
- GHC.IOError { GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe }
- | Errno ioe == ePIPE -> return ()
- e -> throwIO e
+ GHC.IOError{GHC.ioe_type = GHC.ResourceVanished, GHC.ioe_errno = Just ioe}
+ | Errno ioe == ePIPE -> return ()
+ e -> throwIO e
-- | Look for a program and try to find it's version number. It can accept
-- either an absolute path or the name of a program binary, in which case we
-- will look for the program on the path.
---
-findProgramVersion :: String -- ^ version args
- -> (String -> String) -- ^ function to select version
- -- number from program output
- -> Verbosity
- -> FilePath -- ^ location
- -> IO (Maybe Version)
+findProgramVersion
+ :: String
+ -- ^ version args
+ -> (String -> String)
+ -- ^ function to select version
+ -- number from program output
+ -> Verbosity
+ -> FilePath
+ -- ^ location
+ -> IO (Maybe Version)
findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack $ do
- str <- rawSystemStdout verbosity path [versionArg]
- `catchIO` (\_ -> return "")
- `catchExit` (\_ -> return "")
+ str <-
+ rawSystemStdout verbosity path [versionArg]
+ `catchIO` (\_ -> return "")
+ `catchExit` (\_ -> return "")
let version :: Maybe Version
version = simpleParsec (selectVersion str)
case version of
- Nothing -> warn verbosity $ "cannot determine version of " ++ path
- ++ " :\n" ++ show str
- Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v
+ Nothing ->
+ warn verbosity $
+ "cannot determine version of "
+ ++ path
+ ++ " :\n"
+ ++ show str
+ Just v -> debug verbosity $ path ++ " is version " ++ prettyShow v
return version
-
-- | Like the Unix xargs program. Useful for when we've got very long command
-- lines that might overflow an OS limit on command line length and so you
-- need to invoke a command multiple times to get all the args in.
@@ -984,143 +1077,177 @@ findProgramVersion versionArg selectVersion verbosity path = withFrozenCallStack
-- Use it with either of the rawSystem variants above. For example:
--
-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
---
-xargs :: Int -> ([String] -> IO ())
- -> [String] -> [String] -> IO ()
+xargs
+ :: Int
+ -> ([String] -> IO ())
+ -> [String]
+ -> [String]
+ -> IO ()
xargs maxSize rawSystemFun fixedArgs bigArgs =
let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
chunkSize = maxSize - fixedArgSize
in traverse_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
-
- where chunks len = unfoldr $ \s ->
- if null s then Nothing
- else Just (chunk [] len s)
-
- chunk acc _ [] = (reverse acc,[])
- chunk acc len (s:ss)
- | len' < len = chunk (s:acc) (len-len'-1) ss
- | otherwise = (reverse acc, s:ss)
- where len' = length s
+ where
+ chunks len = unfoldr $ \s ->
+ if null s
+ then Nothing
+ else Just (chunk [] len s)
+
+ chunk acc _ [] = (reverse acc, [])
+ chunk acc len (s : ss)
+ | len' < len = chunk (s : acc) (len - len' - 1) ss
+ | otherwise = (reverse acc, s : ss)
+ where
+ len' = length s
-- ------------------------------------------------------------
+
-- * File Utilities
+
-- ------------------------------------------------------------
----------------
-- Finding files
-
-- | Find a file by looking in a search path. The file path must match exactly.
--
-- @since 3.4.0.0
findFileCwd
- :: Verbosity
- -> FilePath -- ^ cwd
- -> [FilePath] -- ^ relative search location
- -> FilePath -- ^ File Name
- -> IO FilePath
+ :: Verbosity
+ -> FilePath
+ -- ^ cwd
+ -> [FilePath]
+ -- ^ relative search location
+ -> FilePath
+ -- ^ File Name
+ -> IO FilePath
findFileCwd verbosity cwd searchPath fileName =
- findFirstFile (cwd </>)
+ findFirstFile
+ (cwd </>)
[ path </> fileName
- | path <- nub searchPath]
- >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return
+ | path <- nub searchPath
+ ]
+ >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return
-- | Find a file by looking in a search path. The file path must match exactly.
---
-findFileEx :: Verbosity
- -> [FilePath] -- ^search locations
- -> FilePath -- ^File Name
- -> IO FilePath
+findFileEx
+ :: Verbosity
+ -> [FilePath]
+ -- ^ search locations
+ -> FilePath
+ -- ^ File Name
+ -> IO FilePath
findFileEx verbosity searchPath fileName =
- findFirstFile id
+ findFirstFile
+ id
[ path </> fileName
- | path <- nub searchPath]
- >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return
+ | path <- nub searchPath
+ ]
+ >>= maybe (die' verbosity $ fileName ++ " doesn't exist") return
-- | Find a file by looking in a search path with one of a list of possible
-- file extensions. The file base name should be given and it will be tried
-- with each of the extensions in each element of the search path.
---
-findFileWithExtension :: [String]
- -> [FilePath]
- -> FilePath
- -> IO (Maybe FilePath)
+findFileWithExtension
+ :: [String]
+ -> [FilePath]
+ -> FilePath
+ -> IO (Maybe FilePath)
findFileWithExtension extensions searchPath baseName =
- findFirstFile id
+ findFirstFile
+ id
[ path </> baseName <.> ext
| path <- nub searchPath
- , ext <- nub extensions ]
+ , ext <- nub extensions
+ ]
-- | @since 3.4.0.0
findFileCwdWithExtension
- :: FilePath
- -> [String]
- -> [FilePath]
- -> FilePath
- -> IO (Maybe FilePath)
+ :: FilePath
+ -> [String]
+ -> [FilePath]
+ -> FilePath
+ -> IO (Maybe FilePath)
findFileCwdWithExtension cwd extensions searchPath baseName =
- findFirstFile (cwd </>)
+ findFirstFile
+ (cwd </>)
[ path </> baseName <.> ext
| path <- nub searchPath
- , ext <- nub extensions ]
+ , ext <- nub extensions
+ ]
-- | @since 3.4.0.0
findAllFilesCwdWithExtension
- :: FilePath -- ^ cwd
- -> [String] -- ^ extensions
- -> [FilePath] -- ^ relative search locations
- -> FilePath -- ^ basename
- -> IO [FilePath]
+ :: FilePath
+ -- ^ cwd
+ -> [String]
+ -- ^ extensions
+ -> [FilePath]
+ -- ^ relative search locations
+ -> FilePath
+ -- ^ basename
+ -> IO [FilePath]
findAllFilesCwdWithExtension cwd extensions searchPath basename =
- findAllFiles (cwd </>)
+ findAllFiles
+ (cwd </>)
[ path </> basename <.> ext
| path <- nub searchPath
- , ext <- nub extensions ]
-
-findAllFilesWithExtension :: [String]
- -> [FilePath]
- -> FilePath
- -> IO [FilePath]
+ , ext <- nub extensions
+ ]
+
+findAllFilesWithExtension
+ :: [String]
+ -> [FilePath]
+ -> FilePath
+ -> IO [FilePath]
findAllFilesWithExtension extensions searchPath basename =
- findAllFiles id
+ findAllFiles
+ id
[ path </> basename <.> ext
| path <- nub searchPath
- , ext <- nub extensions ]
+ , ext <- nub extensions
+ ]
-- | Like 'findFileWithExtension' but returns which element of the search path
-- the file was found in, and the file path relative to that base directory.
---
-findFileWithExtension' :: [String]
- -> [FilePath]
- -> FilePath
- -> IO (Maybe (FilePath, FilePath))
+findFileWithExtension'
+ :: [String]
+ -> [FilePath]
+ -> FilePath
+ -> IO (Maybe (FilePath, FilePath))
findFileWithExtension' extensions searchPath baseName =
- findFirstFile (uncurry (</>))
+ findFirstFile
+ (uncurry (</>))
[ (path, baseName <.> ext)
| path <- nub searchPath
- , ext <- nub extensions ]
+ , ext <- nub extensions
+ ]
findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
findFirstFile file = findFirst
- where findFirst [] = return Nothing
- findFirst (x:xs) = do exists <- doesFileExist (file x)
- if exists
- then return (Just x)
- else findFirst xs
+ where
+ findFirst [] = return Nothing
+ findFirst (x : xs) = do
+ exists <- doesFileExist (file x)
+ if exists
+ then return (Just x)
+ else findFirst xs
findAllFiles :: (a -> FilePath) -> [a] -> IO [a]
findAllFiles file = filterM (doesFileExist . file)
-
-- | Finds the files corresponding to a list of Haskell module names.
--
-- As 'findModuleFile' but for a list of module names.
---
-findModuleFilesEx :: Verbosity
- -> [FilePath] -- ^ build prefix (location of objects)
- -> [String] -- ^ search suffixes
- -> [ModuleName] -- ^ modules
- -> IO [(FilePath, FilePath)]
+findModuleFilesEx
+ :: Verbosity
+ -> [FilePath]
+ -- ^ build prefix (location of objects)
+ -> [String]
+ -- ^ search suffixes
+ -> [ModuleName]
+ -- ^ modules
+ -> IO [(FilePath, FilePath)]
findModuleFilesEx verbosity searchPath extensions moduleNames =
traverse (findModuleFileEx verbosity searchPath extensions) moduleNames
@@ -1128,53 +1255,64 @@ findModuleFilesEx verbosity searchPath extensions moduleNames =
--
-- This is similar to 'findFileWithExtension'' but specialised to a module
-- name. The function fails if the file corresponding to the module is missing.
---
-findModuleFileEx :: Verbosity
- -> [FilePath] -- ^ build prefix (location of objects)
- -> [String] -- ^ search suffixes
- -> ModuleName -- ^ module
- -> IO (FilePath, FilePath)
+findModuleFileEx
+ :: Verbosity
+ -> [FilePath]
+ -- ^ build prefix (location of objects)
+ -> [String]
+ -- ^ search suffixes
+ -> ModuleName
+ -- ^ module
+ -> IO (FilePath, FilePath)
findModuleFileEx verbosity searchPath extensions mod_name =
- maybe notFound return
- =<< findFileWithExtension' extensions searchPath
- (ModuleName.toFilePath mod_name)
+ maybe notFound return
+ =<< findFileWithExtension'
+ extensions
+ searchPath
+ (ModuleName.toFilePath mod_name)
where
- notFound = die' verbosity $
- "Could not find module: " ++ prettyShow mod_name
- ++ " with any suffix: " ++ show extensions
- ++ " in the search path: " ++ show searchPath
+ notFound =
+ die' verbosity $
+ "Could not find module: "
+ ++ prettyShow mod_name
+ ++ " with any suffix: "
+ ++ show extensions
+ ++ " in the search path: "
+ ++ show searchPath
-- | List all the files in a directory and all subdirectories.
--
-- The order places files in sub-directories after all the files in their
-- parent directories. The list is generated lazily so is not well defined if
-- the source directory structure changes before the list is used.
---
getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
getDirectoryContentsRecursive topdir = recurseDirectories [""]
where
recurseDirectories :: [FilePath] -> IO [FilePath]
- recurseDirectories [] = return []
- recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
+ recurseDirectories [] = return []
+ recurseDirectories (dir : dirs) = unsafeInterleaveIO $ do
(files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
files' <- recurseDirectories (dirs' ++ dirs)
return (files ++ files')
-
where
- collect files dirs' [] = return (reverse files
- ,reverse dirs')
- collect files dirs' (entry:entries) | ignore entry
- = collect files dirs' entries
- collect files dirs' (entry:entries) = do
+ collect files dirs' [] =
+ return
+ ( reverse files
+ , reverse dirs'
+ )
+ collect files dirs' (entry : entries)
+ | ignore entry =
+ collect files dirs' entries
+ collect files dirs' (entry : entries) = do
let dirEntry = dir </> entry
isDirectory <- doesDirectoryExist (topdir </> dirEntry)
if isDirectory
- then collect files (dirEntry:dirs') entries
- else collect (dirEntry:files) dirs' entries
+ then collect files (dirEntry : dirs') entries
+ else collect (dirEntry : files) dirs' entries
- ignore ['.'] = True
+ ignore ['.'] = True
ignore ['.', '.'] = True
- ignore _ = False
+ ignore _ = False
------------------------
-- Environment variables
@@ -1183,24 +1321,25 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
isInSearchPath :: FilePath -> IO Bool
isInSearchPath path = fmap (elem path) getSearchPath
-addLibraryPath :: OS
- -> [FilePath]
- -> [(String,String)]
- -> [(String,String)]
+addLibraryPath
+ :: OS
+ -> [FilePath]
+ -> [(String, String)]
+ -> [(String, String)]
addLibraryPath os paths = addEnv
where
pathsString = intercalate [searchPathSeparator] paths
ldPath = case os of
- OSX -> "DYLD_LIBRARY_PATH"
- _ -> "LD_LIBRARY_PATH"
+ OSX -> "DYLD_LIBRARY_PATH"
+ _ -> "LD_LIBRARY_PATH"
- addEnv [] = [(ldPath,pathsString)]
- addEnv ((key,value):xs)
+ addEnv [] = [(ldPath, pathsString)]
+ addEnv ((key, value) : xs)
| key == ldPath =
if null value
- then (key,pathsString):xs
- else (key,value ++ (searchPathSeparator:pathsString)):xs
- | otherwise = (key,value):addEnv xs
+ then (key, pathsString) : xs
+ else (key, value ++ (searchPathSeparator : pathsString)) : xs
+ | otherwise = (key, value) : addEnv xs
--------------------
-- Modification time
@@ -1209,15 +1348,15 @@ addLibraryPath os paths = addEnv
-- than the second. The first file must exist but the second need not.
-- The expected use case is when the second file is generated using the first.
-- In this use case, if the result is True then the second file is out of date.
---
moreRecentFile :: FilePath -> FilePath -> IO Bool
moreRecentFile a b = do
exists <- doesFileExist b
if not exists
then return True
- else do tb <- getModificationTime b
- ta <- getModificationTime a
- return (ta > tb)
+ else do
+ tb <- getModificationTime b
+ ta <- getModificationTime a
+ return (ta > tb)
-- | Like 'moreRecentFile', but also checks that the first file exists.
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
@@ -1231,20 +1370,21 @@ existsAndIsMoreRecentThan a b = do
-- Copying and installing files and dirs
-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
---
-createDirectoryIfMissingVerbose :: Verbosity
- -> Bool -- ^ Create its parents too?
- -> FilePath
- -> IO ()
+createDirectoryIfMissingVerbose
+ :: Verbosity
+ -> Bool
+ -- ^ Create its parents too?
+ -> FilePath
+ -> IO ()
createDirectoryIfMissingVerbose verbosity create_parents path0
| create_parents = withFrozenCallStack $ createDirs (parents path0)
- | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0))
+ | otherwise = withFrozenCallStack $ createDirs (take 1 (parents path0))
where
parents = reverse . scanl1 (</>) . splitDirectories . normalise
- createDirs [] = return ()
- createDirs (dir:[]) = createDir dir throwIO
- createDirs (dir:dirs) =
+ createDirs [] = return ()
+ createDirs (dir : []) = createDir dir throwIO
+ createDirs (dir : dirs) =
createDir dir $ \_ -> do
createDirs dirs
createDir dir throwIO
@@ -1253,9 +1393,9 @@ createDirectoryIfMissingVerbose verbosity create_parents path0
createDir dir notExistHandler = do
r <- tryIO $ createDirectoryVerbose verbosity dir
case (r :: Either IOException ()) of
- Right () -> return ()
- Left e
- | isDoesNotExistError e -> notExistHandler e
+ Right () -> return ()
+ Left e
+ | isDoesNotExistError e -> notExistHandler e
-- createDirectory (and indeed POSIX mkdir) does not distinguish
-- between a dir already existing and a file already existing. So we
-- check for it here. Unfortunately there is a slight race condition
@@ -1263,11 +1403,13 @@ createDirectoryIfMissingVerbose verbosity create_parents path0
-- the case that the dir did exist but another process deletes the
-- directory and creates a file in its place before we can check
-- that the directory did indeed exist.
- | isAlreadyExistsError e -> (do
- isDir <- doesDirectoryExist dir
- unless isDir $ throwIO e
- ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())
- | otherwise -> throwIO e
+ | isAlreadyExistsError e ->
+ ( do
+ isDir <- doesDirectoryExist dir
+ unless isDir $ throwIO e
+ )
+ `catchIO` ((\_ -> return ()) :: IOException -> IO ())
+ | otherwise -> throwIO e
createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
createDirectoryVerbose verbosity dir = withFrozenCallStack $ do
@@ -1279,7 +1421,6 @@ createDirectoryVerbose verbosity dir = withFrozenCallStack $ do
-- with default permissions. Any existing target file is replaced.
--
-- At higher verbosity levels it logs an info message.
---
copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
copyFileVerbose verbosity src dest = withFrozenCallStack $ do
info verbosity ("copy " ++ src ++ " to " ++ dest)
@@ -1288,7 +1429,6 @@ copyFileVerbose verbosity src dest = withFrozenCallStack $ do
-- | Install an ordinary file. This is like a file copy but the permissions
-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"
-- while on Windows it uses the default permissions for the target directory.
---
installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
installOrdinaryFile verbosity src dest = withFrozenCallStack $ do
info verbosity ("Installing " ++ src ++ " to " ++ dest)
@@ -1297,7 +1437,6 @@ installOrdinaryFile verbosity src dest = withFrozenCallStack $ do
-- | Install an executable file. This is like a file copy but the permissions
-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"
-- while on Windows it uses the default permissions for the target directory.
---
installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installExecutableFile verbosity src dest = withFrozenCallStack $ do
info verbosity ("Installing executable " ++ src ++ " to " ++ dest)
@@ -1307,9 +1446,9 @@ installExecutableFile verbosity src dest = withFrozenCallStack $ do
installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
installMaybeExecutableFile verbosity src dest = withFrozenCallStack $ do
perms <- getPermissions src
- if (executable perms) --only checks user x bit
+ if (executable perms) -- only checks user x bit
then installExecutableFile verbosity src dest
- else installOrdinaryFile verbosity src dest
+ else installOrdinaryFile verbosity src dest
-- | Given a relative path to a file, copy it to the given directory, preserving
-- the relative path and creating the parent directories if needed.
@@ -1321,19 +1460,24 @@ copyFileTo verbosity dir file = withFrozenCallStack $ do
-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())
- -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
+copyFilesWith
+ :: (Verbosity -> FilePath -> FilePath -> IO ())
+ -> Verbosity
+ -> FilePath
+ -> [(FilePath, FilePath)]
+ -> IO ()
copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do
-
-- Create parent directories for everything
let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
traverse_ (createDirectoryIfMissingVerbose verbosity True) dirs
-- Copy all the files
- sequence_ [ let src = srcBase </> srcFile
- dest = targetDir </> srcFile
- in doCopy verbosity src dest
- | (srcBase, srcFile) <- srcFiles ]
+ sequence_
+ [ let src = srcBase </> srcFile
+ dest = targetDir </> srcFile
+ in doCopy verbosity src dest
+ | (srcBase, srcFile) <- srcFiles
+ ]
-- | Copies a bunch of files to a target directory, preserving the directory
-- structure in the target location. The target directories are created if they
@@ -1355,44 +1499,50 @@ copyFilesWith doCopy verbosity targetDir srcFiles = withFrozenCallStack $ do
-- missing source files) leaves the target in an unknown state so it is best to
-- use it with a freshly created directory so that it can be simply deleted if
-- anything goes wrong.
---
copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
copyFiles v fp fs = withFrozenCallStack (copyFilesWith copyFileVerbose v fp fs)
-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
---
installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
installOrdinaryFiles v fp fs = withFrozenCallStack (copyFilesWith installOrdinaryFile v fp fs)
-- | This is like 'copyFiles' but uses 'installExecutableFile'.
---
-installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
- -> IO ()
+installExecutableFiles
+ :: Verbosity
+ -> FilePath
+ -> [(FilePath, FilePath)]
+ -> IO ()
installExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installExecutableFile v fp fs)
-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.
---
-installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]
- -> IO ()
+installMaybeExecutableFiles
+ :: Verbosity
+ -> FilePath
+ -> [(FilePath, FilePath)]
+ -> IO ()
installMaybeExecutableFiles v fp fs = withFrozenCallStack (copyFilesWith installMaybeExecutableFile v fp fs)
-- | This installs all the files in a directory to a target location,
-- preserving the directory layout. All the files are assumed to be ordinary
-- rather than executable files.
---
installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
installDirectoryContents verbosity srcDir destDir = withFrozenCallStack $ do
info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
srcFiles <- getDirectoryContentsRecursive srcDir
- installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]
+ installOrdinaryFiles verbosity destDir [(srcDir, f) | f <- srcFiles]
-- | Recursively copy the contents of one directory to another path.
copyDirectoryRecursive :: Verbosity -> FilePath -> FilePath -> IO ()
copyDirectoryRecursive verbosity srcDir destDir = withFrozenCallStack $ do
info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
srcFiles <- getDirectoryContentsRecursive srcDir
- copyFilesWith (const copyFile) verbosity destDir [ (srcDir, f)
- | f <- srcFiles ]
+ copyFilesWith
+ (const copyFile)
+ verbosity
+ destDir
+ [ (srcDir, f)
+ | f <- srcFiles
+ ]
-------------------
-- File permissions
@@ -1402,41 +1552,53 @@ doesExecutableExist :: FilePath -> IO Bool
doesExecutableExist f = do
exists <- doesFileExist f
if exists
- then do perms <- getPermissions f
- return (executable perms)
+ then do
+ perms <- getPermissions f
+ return (executable perms)
else return False
---------------------------
-- Temporary files and dirs
-- | Advanced options for 'withTempFile' and 'withTempDirectory'.
-data TempFileOptions = TempFileOptions {
- optKeepTempFiles :: Bool -- ^ Keep temporary files?
+data TempFileOptions = TempFileOptions
+ { optKeepTempFiles :: Bool
+ -- ^ Keep temporary files?
}
defaultTempFileOptions :: TempFileOptions
-defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }
+defaultTempFileOptions = TempFileOptions{optKeepTempFiles = False}
-- | Use a temporary filename that doesn't already exist.
---
-withTempFile :: FilePath -- ^ Temp dir to create the file in
- -> String -- ^ File name template. See 'openTempFile'.
- -> (FilePath -> Handle -> IO a) -> IO a
+withTempFile
+ :: FilePath
+ -- ^ Temp dir to create the file in
+ -> String
+ -- ^ File name template. See 'openTempFile'.
+ -> (FilePath -> Handle -> IO a)
+ -> IO a
withTempFile tmpDir template action =
withTempFileEx defaultTempFileOptions tmpDir template action
-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'
-- argument.
-withTempFileEx :: TempFileOptions
- -> FilePath -- ^ Temp dir to create the file in
- -> String -- ^ File name template. See 'openTempFile'.
- -> (FilePath -> Handle -> IO a) -> IO a
+withTempFileEx
+ :: TempFileOptions
+ -> FilePath
+ -- ^ Temp dir to create the file in
+ -> String
+ -- ^ File name template. See 'openTempFile'.
+ -> (FilePath -> Handle -> IO a)
+ -> IO a
withTempFileEx opts tmpDir template action =
Exception.bracket
(openTempFile tmpDir template)
- (\(name, handle) -> do hClose handle
- unless (optKeepTempFiles opts) $
- handleDoesNotExist () . removeFile $ name)
+ ( \(name, handle) -> do
+ hClose handle
+ unless (optKeepTempFiles opts) $
+ handleDoesNotExist () . removeFile $
+ name
+ )
(withLexicalCallStack (\x -> uncurry action x))
-- | Create and use a temporary directory.
@@ -1448,22 +1610,34 @@ withTempFileEx opts tmpDir template action =
--
-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
-- @src/sdist.342@.
---
withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a
-withTempDirectory verbosity targetDir template f = withFrozenCallStack $
- withTempDirectoryEx verbosity defaultTempFileOptions targetDir template
- (withLexicalCallStack (\x -> f x))
+withTempDirectory verbosity targetDir template f =
+ withFrozenCallStack $
+ withTempDirectoryEx
+ verbosity
+ defaultTempFileOptions
+ targetDir
+ template
+ (withLexicalCallStack (\x -> f x))
-- | A version of 'withTempDirectory' that additionally takes a
-- 'TempFileOptions' argument.
-withTempDirectoryEx :: Verbosity -> TempFileOptions
- -> FilePath -> String -> (FilePath -> IO a) -> IO a
-withTempDirectoryEx _verbosity opts targetDir template f = withFrozenCallStack $
- Exception.bracket
- (createTempDirectory targetDir template)
- (unless (optKeepTempFiles opts)
- . handleDoesNotExist () . removeDirectoryRecursive)
- (withLexicalCallStack (\x -> f x))
+withTempDirectoryEx
+ :: Verbosity
+ -> TempFileOptions
+ -> FilePath
+ -> String
+ -> (FilePath -> IO a)
+ -> IO a
+withTempDirectoryEx _verbosity opts targetDir template f =
+ withFrozenCallStack $
+ Exception.bracket
+ (createTempDirectory targetDir template)
+ ( unless (optKeepTempFiles opts)
+ . handleDoesNotExist ()
+ . removeDirectoryRecursive
+ )
+ (withLexicalCallStack (\x -> f x))
-----------------------------------
-- Safely reading and writing files
@@ -1489,11 +1663,11 @@ rewriteFileLBS verbosity path newContent =
annotateIO verbosity $
writeFileAtomic path newContent
where
- mightNotExist e | isDoesNotExistError e
- = annotateIO verbosity $ writeFileAtomic path newContent
- | otherwise
- = ioError e
-
+ mightNotExist e
+ | isDoesNotExistError e =
+ annotateIO verbosity $ writeFileAtomic path newContent
+ | otherwise =
+ ioError e
-- | The path name that represents the current directory.
-- In Unix, it's @\".\"@, but this is system-specific.
@@ -1503,13 +1677,13 @@ currentDir = "."
shortRelativePath :: FilePath -> FilePath -> FilePath
shortRelativePath from to =
- case dropCommonPrefix (splitDirectories from) (splitDirectories to) of
- (stuff, path) -> joinPath (map (const "..") stuff ++ path)
+ case dropCommonPrefix (splitDirectories from) (splitDirectories to) of
+ (stuff, path) -> joinPath (map (const "..") stuff ++ path)
where
- dropCommonPrefix :: Eq a => [a] -> [a] -> ([a],[a])
- dropCommonPrefix (x:xs) (y:ys)
- | x == y = dropCommonPrefix xs ys
- dropCommonPrefix xs ys = (xs,ys)
+ dropCommonPrefix :: Eq a => [a] -> [a] -> ([a], [a])
+ dropCommonPrefix (x : xs) (y : ys)
+ | x == y = dropCommonPrefix xs ys
+ dropCommonPrefix xs ys = (xs, ys)
-- | Drop the extension if it's one of 'exeExtensions', or return the path
-- unchanged.
@@ -1527,10 +1701,10 @@ dropExeExtension filepath =
--
-- Since by "" in exeExtensions we mean 'no extension' anyways we can
-- just always ignore it here.
- let exts = [ ext | ext <- exeExtensions, ext /= "" ] in
- fromMaybe filepath $ do
- ext <- find (`FilePath.isExtensionOf` filepath) exts
- ext `FilePath.stripExtension` filepath
+ let exts = [ext | ext <- exeExtensions, ext /= ""]
+ in fromMaybe filepath $ do
+ ext <- find (`FilePath.isExtensionOf` filepath) exts
+ ext `FilePath.stripExtension` filepath
-- | List of possible executable file extensions on the current build
-- platform.
@@ -1540,54 +1714,67 @@ exeExtensions = case (buildArch, buildOS) of
-- PATHEXT environment variable. By default PATHEXT is ".com; .exe; .bat;
-- .cmd".
(_, Windows) -> ["", "exe"]
- (_, Ghcjs) -> ["", "exe"]
- (Wasm32, _) -> ["", "wasm"]
- _ -> [""]
+ (_, Ghcjs) -> ["", "exe"]
+ (Wasm32, _) -> ["", "wasm"]
+ _ -> [""]
-- ------------------------------------------------------------
+
-- * Finding the description file
+
-- ------------------------------------------------------------
-- | Package description file (/pkgname/@.cabal@)
defaultPackageDesc :: Verbosity -> IO FilePath
defaultPackageDesc verbosity = tryFindPackageDesc verbosity currentDir
--- |Find a package description file in the given directory. Looks for
--- @.cabal@ files.
-findPackageDesc :: FilePath -- ^Where to look
- -> IO (Either String FilePath) -- ^<pkgname>.cabal
+-- | Find a package description file in the given directory. Looks for
+-- @.cabal@ files.
+findPackageDesc
+ :: FilePath
+ -- ^ Where to look
+ -> IO (Either String FilePath)
+ -- ^ <pkgname>.cabal
findPackageDesc = findPackageDescCwd "."
-- | @since 3.4.0.0
findPackageDescCwd
- :: FilePath -- ^ project root
- -> FilePath -- ^ relative directory
- -> IO (Either String FilePath) -- ^ <pkgname>.cabal relative to the project root
-findPackageDescCwd cwd dir
- = do files <- getDirectoryContents (cwd </> dir)
- -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
- -- file we filter to exclude dirs and null base file names:
- cabalFiles <- filterM (doesFileExist . snd)
- [ (dir </> file, cwd </> dir </> file)
- | file <- files
- , let (name, ext) = splitExtension file
- , not (null name) && ext == ".cabal" ]
- case map fst cabalFiles of
- [] -> return (Left noDesc)
- [cabalFile] -> return (Right cabalFile)
- multiple -> return (Left $ multiDesc multiple)
-
+ :: FilePath
+ -- ^ project root
+ -> FilePath
+ -- ^ relative directory
+ -> IO (Either String FilePath)
+ -- ^ <pkgname>.cabal relative to the project root
+findPackageDescCwd cwd dir =
+ do
+ files <- getDirectoryContents (cwd </> dir)
+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
+ -- file we filter to exclude dirs and null base file names:
+ cabalFiles <-
+ filterM
+ (doesFileExist . snd)
+ [ (dir </> file, cwd </> dir </> file)
+ | file <- files
+ , let (name, ext) = splitExtension file
+ , not (null name) && ext == ".cabal"
+ ]
+ case map fst cabalFiles of
+ [] -> return (Left noDesc)
+ [cabalFile] -> return (Right cabalFile)
+ multiple -> return (Left $ multiDesc multiple)
where
noDesc :: String
- noDesc = "No cabal file found.\n"
- ++ "Please create a package description file <pkgname>.cabal"
+ noDesc =
+ "No cabal file found.\n"
+ ++ "Please create a package description file <pkgname>.cabal"
multiDesc :: [String] -> String
- multiDesc l = "Multiple cabal files found.\n"
- ++ "Please use only one of: "
- ++ intercalate ", " l
+ multiDesc l =
+ "Multiple cabal files found.\n"
+ ++ "Please use only one of: "
+ ++ intercalate ", " l
--- |Like 'findPackageDesc', but calls 'die' in case of error.
+-- | Like 'findPackageDesc', but calls 'die' in case of error.
tryFindPackageDesc :: Verbosity -> FilePath -> IO FilePath
tryFindPackageDesc verbosity dir =
either (die' verbosity) return =<< findPackageDesc dir
@@ -1599,23 +1786,28 @@ tryFindPackageDescCwd :: Verbosity -> FilePath -> FilePath -> IO FilePath
tryFindPackageDescCwd verbosity cwd dir =
either (die' verbosity) return =<< findPackageDescCwd cwd dir
--- |Find auxiliary package information in the given directory.
--- Looks for @.buildinfo@ files.
+-- | Find auxiliary package information in the given directory.
+-- Looks for @.buildinfo@ files.
findHookedPackageDesc
- :: Verbosity
- -> FilePath -- ^Directory to search
- -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present
+ :: Verbosity
+ -> FilePath
+ -- ^ Directory to search
+ -> IO (Maybe FilePath)
+ -- ^ /dir/@\/@/pkgname/@.buildinfo@, if present
findHookedPackageDesc verbosity dir = do
- files <- getDirectoryContents dir
- buildInfoFiles <- filterM doesFileExist
- [ dir </> file
- | file <- files
- , let (name, ext) = splitExtension file
- , not (null name) && ext == buildInfoExt ]
- case buildInfoFiles of
- [] -> return Nothing
- [f] -> return (Just f)
- _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt)
-
-buildInfoExt :: String
+ files <- getDirectoryContents dir
+ buildInfoFiles <-
+ filterM
+ doesFileExist
+ [ dir </> file
+ | file <- files
+ , let (name, ext) = splitExtension file
+ , not (null name) && ext == buildInfoExt
+ ]
+ case buildInfoFiles of
+ [] -> return Nothing
+ [f] -> return (Just f)
+ _ -> die' verbosity ("Multiple files with extension " ++ buildInfoExt)
+
+buildInfoExt :: String
buildInfoExt = ".buildinfo"
diff --git a/Cabal/src/Distribution/TestSuite.hs b/Cabal/src/Distribution/TestSuite.hs
index 7276bfa2c390201253ac0a9117983505204639ca..5e6fa42dac26893b3b3d3509be20de51b531995b 100644
--- a/Cabal/src/Distribution/TestSuite.hs
+++ b/Cabal/src/Distribution/TestSuite.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.TestSuite
-- Copyright : Thomas Tuegel 2010
@@ -12,91 +13,97 @@
--
-- This module defines the detailed test suite interface which makes it
-- possible to expose individual tests to Cabal or other test agents.
-
module Distribution.TestSuite
- ( TestInstance(..)
- , OptionDescr(..)
- , OptionType(..)
- , Test(..)
- , Options
- , Progress(..)
- , Result(..)
- , testGroup
- ) where
+ ( TestInstance (..)
+ , OptionDescr (..)
+ , OptionType (..)
+ , Test (..)
+ , Options
+ , Progress (..)
+ , Result (..)
+ , testGroup
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
data TestInstance = TestInstance
- { run :: IO Progress -- ^ Perform the test.
- , name :: String -- ^ A name for the test, unique within a
- -- test suite.
- , tags :: [String] -- ^ Users can select groups of tests by
- -- their tags.
- , options :: [OptionDescr] -- ^ Descriptions of the options recognized
- -- by this test.
- , setOption :: String -> String -> Either String TestInstance
- -- ^ Try to set the named option to the given value. Returns an error
- -- message if the option is not supported or the value could not be
- -- correctly parsed; otherwise, a 'TestInstance' with the option set to
- -- the given value is returned.
- }
+ { run :: IO Progress
+ -- ^ Perform the test.
+ , name :: String
+ -- ^ A name for the test, unique within a
+ -- test suite.
+ , tags :: [String]
+ -- ^ Users can select groups of tests by
+ -- their tags.
+ , options :: [OptionDescr]
+ -- ^ Descriptions of the options recognized
+ -- by this test.
+ , setOption :: String -> String -> Either String TestInstance
+ -- ^ Try to set the named option to the given value. Returns an error
+ -- message if the option is not supported or the value could not be
+ -- correctly parsed; otherwise, a 'TestInstance' with the option set to
+ -- the given value is returned.
+ }
data OptionDescr = OptionDescr
- { optionName :: String
- , optionDescription :: String -- ^ A human-readable description of the
- -- option to guide the user setting it.
- , optionType :: OptionType
- , optionDefault :: Maybe String
- }
+ { optionName :: String
+ , optionDescription :: String
+ -- ^ A human-readable description of the
+ -- option to guide the user setting it.
+ , optionType :: OptionType
+ , optionDefault :: Maybe String
+ }
deriving (Eq, Read, Show)
data OptionType
- = OptionFile
- { optionFileMustExist :: Bool
- , optionFileIsDir :: Bool
- , optionFileExtensions :: [String]
- }
- | OptionString
- { optionStringMultiline :: Bool
- }
- | OptionNumber
- { optionNumberIsInt :: Bool
- , optionNumberBounds :: (Maybe String, Maybe String)
- }
- | OptionBool
- | OptionEnum [String]
- | OptionSet [String]
- | OptionRngSeed
+ = OptionFile
+ { optionFileMustExist :: Bool
+ , optionFileIsDir :: Bool
+ , optionFileExtensions :: [String]
+ }
+ | OptionString
+ { optionStringMultiline :: Bool
+ }
+ | OptionNumber
+ { optionNumberIsInt :: Bool
+ , optionNumberBounds :: (Maybe String, Maybe String)
+ }
+ | OptionBool
+ | OptionEnum [String]
+ | OptionSet [String]
+ | OptionRngSeed
deriving (Eq, Read, Show)
data Test
- = Test TestInstance
- | Group
- { groupName :: String
- , concurrently :: Bool
- -- ^ If true, then children of this group may be run in parallel.
- -- Note that this setting is not inherited by children. In
- -- particular, consider a group F with "concurrently = False" that
- -- has some children, including a group T with "concurrently =
- -- True". The children of group T may be run concurrently with each
- -- other, as long as none are run at the same time as any of the
- -- direct children of group F.
- , groupTests :: [Test]
- }
- | ExtraOptions [OptionDescr] Test
+ = Test TestInstance
+ | Group
+ { groupName :: String
+ , concurrently :: Bool
+ -- ^ If true, then children of this group may be run in parallel.
+ -- Note that this setting is not inherited by children. In
+ -- particular, consider a group F with "concurrently = False" that
+ -- has some children, including a group T with "concurrently =
+ -- True". The children of group T may be run concurrently with each
+ -- other, as long as none are run at the same time as any of the
+ -- direct children of group F.
+ , groupTests :: [Test]
+ }
+ | ExtraOptions [OptionDescr] Test
type Options = [(String, String)]
-data Progress = Finished Result
- | Progress String (IO Progress)
+data Progress
+ = Finished Result
+ | Progress String (IO Progress)
-data Result = Pass
- | Fail String
- | Error String
+data Result
+ = Pass
+ | Fail String
+ | Error String
deriving (Eq, Read, Show)
-- | Create a named group of tests, which are assumed to be safe to run in
-- parallel.
testGroup :: String -> [Test] -> Test
-testGroup n ts = Group { groupName = n, concurrently = True, groupTests = ts }
+testGroup n ts = Group{groupName = n, concurrently = True, groupTests = ts}
diff --git a/Cabal/src/Distribution/Types/AnnotatedId.hs b/Cabal/src/Distribution/Types/AnnotatedId.hs
index 49a3c0f40390365fce46de582eb7f5daa539855f..a273fadde3421d8817562b995d6affa83c43d201 100644
--- a/Cabal/src/Distribution/Types/AnnotatedId.hs
+++ b/Cabal/src/Distribution/Types/AnnotatedId.hs
@@ -1,9 +1,9 @@
-module Distribution.Types.AnnotatedId (
- AnnotatedId(..)
-) where
+module Distribution.Types.AnnotatedId
+ ( AnnotatedId (..)
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.Package
import Distribution.Types.ComponentName
@@ -14,21 +14,21 @@ import Distribution.Types.ComponentName
--
-- Invariant: if ann_id x == ann_id y, then ann_pid x == ann_pid y
-- and ann_cname x == ann_cname y
-data AnnotatedId id = AnnotatedId {
- ann_pid :: PackageId,
- ann_cname :: ComponentName,
- ann_id :: id
- }
- deriving (Show)
+data AnnotatedId id = AnnotatedId
+ { ann_pid :: PackageId
+ , ann_cname :: ComponentName
+ , ann_id :: id
+ }
+ deriving (Show)
instance Eq id => Eq (AnnotatedId id) where
- x == y = ann_id x == ann_id y
+ x == y = ann_id x == ann_id y
instance Ord id => Ord (AnnotatedId id) where
- compare x y = compare (ann_id x) (ann_id y)
+ compare x y = compare (ann_id x) (ann_id y)
instance Package (AnnotatedId id) where
- packageId = ann_pid
+ packageId = ann_pid
instance Functor AnnotatedId where
- fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x)
+ fmap f (AnnotatedId pid cn x) = AnnotatedId pid cn (f x)
diff --git a/Cabal/src/Distribution/Types/ComponentInclude.hs b/Cabal/src/Distribution/Types/ComponentInclude.hs
index f60f696808f078d3fe097977b0c3567f075386b4..6999b6544d750b5718e0be21d23c1b24901dc220 100644
--- a/Cabal/src/Distribution/Types/ComponentInclude.hs
+++ b/Cabal/src/Distribution/Types/ComponentInclude.hs
@@ -1,25 +1,25 @@
-module Distribution.Types.ComponentInclude (
- ComponentInclude(..),
- ci_id,
- ci_pkgid,
- ci_cname
-) where
+module Distribution.Types.ComponentInclude
+ ( ComponentInclude (..)
+ , ci_id
+ , ci_pkgid
+ , ci_cname
+ ) where
-import Distribution.Types.PackageId
-import Distribution.Types.ComponentName
import Distribution.Types.AnnotatedId
+import Distribution.Types.ComponentName
+import Distribution.Types.PackageId
-- Once ci_id is refined to an 'OpenUnitId' or 'DefUnitId',
-- the 'includeRequiresRn' is not so useful (because it
-- includes the requirements renaming that is no longer
-- needed); use 'ci_prov_renaming' instead.
-data ComponentInclude id rn = ComponentInclude {
- ci_ann_id :: AnnotatedId id,
- ci_renaming :: rn,
- -- | Did this come from an entry in @mixins@, or
- -- was implicitly generated by @build-depends@?
- ci_implicit :: Bool
- }
+data ComponentInclude id rn = ComponentInclude
+ { ci_ann_id :: AnnotatedId id
+ , ci_renaming :: rn
+ , ci_implicit :: Bool
+ -- ^ Did this come from an entry in @mixins@, or
+ -- was implicitly generated by @build-depends@?
+ }
ci_id :: ComponentInclude id rn -> id
ci_id = ann_id . ci_ann_id
diff --git a/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs b/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs
index 02aa65511521602daa0c3da0540c0a77dc704204..0728656620e91d739e082be5e5b9f8bb6f019278 100644
--- a/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs
+++ b/Cabal/src/Distribution/Types/ComponentLocalBuildInfo.hs
@@ -2,128 +2,127 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
-module Distribution.Types.ComponentLocalBuildInfo (
- ComponentLocalBuildInfo(..),
- componentIsIndefinite,
- maybeComponentInstantiatedWith,
+module Distribution.Types.ComponentLocalBuildInfo
+ ( ComponentLocalBuildInfo (..)
+ , componentIsIndefinite
+ , maybeComponentInstantiatedWith
) where
-import Prelude ()
import Distribution.Compat.Prelude
import Distribution.ModuleName
+import Prelude ()
import Distribution.Backpack
import Distribution.Compat.Graph
import Distribution.Types.ComponentId
-import Distribution.Types.MungedPackageId
-import Distribution.Types.UnitId
import Distribution.Types.ComponentName
-import Distribution.Types.MungedPackageName
import Distribution.Types.ModuleRenaming
+import Distribution.Types.MungedPackageId
+import Distribution.Types.MungedPackageName
+import Distribution.Types.UnitId
import qualified Distribution.InstalledPackageInfo as Installed
-- | The first five fields are common across all algebraic variants.
data ComponentLocalBuildInfo
- = LibComponentLocalBuildInfo {
- -- | It would be very convenient to store the literal Library here,
- -- but if we do that, it will get serialized (via the Binary)
- -- instance twice. So instead we just provide the ComponentName,
- -- which can be used to find the Component in the
- -- PackageDescription. NB: eventually, this will NOT uniquely
- -- identify the ComponentLocalBuildInfo.
- componentLocalName :: ComponentName,
- -- | The computed 'ComponentId' of this component.
- componentComponentId :: ComponentId,
- -- | The computed 'UnitId' which uniquely identifies this
- -- component. Might be hashed.
- componentUnitId :: UnitId,
- -- | Is this an indefinite component (i.e. has unfilled holes)?
- componentIsIndefinite_ :: Bool,
- -- | How the component was instantiated
- componentInstantiatedWith :: [(ModuleName, OpenModule)],
- -- | Resolved internal and external package dependencies for this component.
- -- The 'BuildInfo' specifies a set of build dependencies that must be
- -- satisfied in terms of version ranges. This field fixes those dependencies
- -- to the specific versions available on this machine for this compiler.
- componentPackageDeps :: [(UnitId, MungedPackageId)],
- -- | The set of packages that are brought into scope during
- -- compilation, including a 'ModuleRenaming' which may used
- -- to hide or rename modules. This is what gets translated into
- -- @-package-id@ arguments. This is a modernized version of
- -- 'componentPackageDeps', which is kept around for BC purposes.
- componentIncludes :: [(OpenUnitId, ModuleRenaming)],
- componentExeDeps :: [UnitId],
- -- | The internal dependencies which induce a graph on the
- -- 'ComponentLocalBuildInfo' of this package. This does NOT
- -- coincide with 'componentPackageDeps' because it ALSO records
- -- 'build-tool' dependencies on executables. Maybe one day
- -- @cabal-install@ will also handle these correctly too!
- componentInternalDeps :: [UnitId],
- -- | Compatibility "package key" that we pass to older versions of GHC.
- componentCompatPackageKey :: String,
- -- | Compatibility "package name" that we register this component as.
- componentCompatPackageName :: MungedPackageName,
- -- | A list of exposed modules (either defined in this component,
- -- or reexported from another component.)
- componentExposedModules :: [Installed.ExposedModule],
- -- | Convenience field, specifying whether or not this is the
- -- "public library" that has the same name as the package.
- componentIsPublic :: Bool
- }
- -- TODO: refactor all these duplicates
- | FLibComponentLocalBuildInfo {
- componentLocalName :: ComponentName,
- componentComponentId :: ComponentId,
- componentUnitId :: UnitId,
- componentPackageDeps :: [(UnitId, MungedPackageId)],
- componentIncludes :: [(OpenUnitId, ModuleRenaming)],
- componentExeDeps :: [UnitId],
- componentInternalDeps :: [UnitId]
- }
- | ExeComponentLocalBuildInfo {
- componentLocalName :: ComponentName,
- componentComponentId :: ComponentId,
- componentUnitId :: UnitId,
- componentPackageDeps :: [(UnitId, MungedPackageId)],
- componentIncludes :: [(OpenUnitId, ModuleRenaming)],
- componentExeDeps :: [UnitId],
- componentInternalDeps :: [UnitId]
- }
- | TestComponentLocalBuildInfo {
- componentLocalName :: ComponentName,
- componentComponentId :: ComponentId,
- componentUnitId :: UnitId,
- componentPackageDeps :: [(UnitId, MungedPackageId)],
- componentIncludes :: [(OpenUnitId, ModuleRenaming)],
- componentExeDeps :: [UnitId],
- componentInternalDeps :: [UnitId]
-
- }
- | BenchComponentLocalBuildInfo {
- componentLocalName :: ComponentName,
- componentComponentId :: ComponentId,
- componentUnitId :: UnitId,
- componentPackageDeps :: [(UnitId, MungedPackageId)],
- componentIncludes :: [(OpenUnitId, ModuleRenaming)],
- componentExeDeps :: [UnitId],
- componentInternalDeps :: [UnitId]
- }
+ = LibComponentLocalBuildInfo
+ { componentLocalName :: ComponentName
+ -- ^ It would be very convenient to store the literal Library here,
+ -- but if we do that, it will get serialized (via the Binary)
+ -- instance twice. So instead we just provide the ComponentName,
+ -- which can be used to find the Component in the
+ -- PackageDescription. NB: eventually, this will NOT uniquely
+ -- identify the ComponentLocalBuildInfo.
+ , componentComponentId :: ComponentId
+ -- ^ The computed 'ComponentId' of this component.
+ , componentUnitId :: UnitId
+ -- ^ The computed 'UnitId' which uniquely identifies this
+ -- component. Might be hashed.
+ , componentIsIndefinite_ :: Bool
+ -- ^ Is this an indefinite component (i.e. has unfilled holes)?
+ , componentInstantiatedWith :: [(ModuleName, OpenModule)]
+ -- ^ How the component was instantiated
+ , componentPackageDeps :: [(UnitId, MungedPackageId)]
+ -- ^ Resolved internal and external package dependencies for this component.
+ -- The 'BuildInfo' specifies a set of build dependencies that must be
+ -- satisfied in terms of version ranges. This field fixes those dependencies
+ -- to the specific versions available on this machine for this compiler.
+ , componentIncludes :: [(OpenUnitId, ModuleRenaming)]
+ -- ^ The set of packages that are brought into scope during
+ -- compilation, including a 'ModuleRenaming' which may used
+ -- to hide or rename modules. This is what gets translated into
+ -- @-package-id@ arguments. This is a modernized version of
+ -- 'componentPackageDeps', which is kept around for BC purposes.
+ , componentExeDeps :: [UnitId]
+ , componentInternalDeps :: [UnitId]
+ -- ^ The internal dependencies which induce a graph on the
+ -- 'ComponentLocalBuildInfo' of this package. This does NOT
+ -- coincide with 'componentPackageDeps' because it ALSO records
+ -- 'build-tool' dependencies on executables. Maybe one day
+ -- @cabal-install@ will also handle these correctly too!
+ , componentCompatPackageKey :: String
+ -- ^ Compatibility "package key" that we pass to older versions of GHC.
+ , componentCompatPackageName :: MungedPackageName
+ -- ^ Compatibility "package name" that we register this component as.
+ , componentExposedModules :: [Installed.ExposedModule]
+ -- ^ A list of exposed modules (either defined in this component,
+ -- or reexported from another component.)
+ , componentIsPublic :: Bool
+ -- ^ Convenience field, specifying whether or not this is the
+ -- "public library" that has the same name as the package.
+ }
+ | -- TODO: refactor all these duplicates
+ FLibComponentLocalBuildInfo
+ { componentLocalName :: ComponentName
+ , componentComponentId :: ComponentId
+ , componentUnitId :: UnitId
+ , componentPackageDeps :: [(UnitId, MungedPackageId)]
+ , componentIncludes :: [(OpenUnitId, ModuleRenaming)]
+ , componentExeDeps :: [UnitId]
+ , componentInternalDeps :: [UnitId]
+ }
+ | ExeComponentLocalBuildInfo
+ { componentLocalName :: ComponentName
+ , componentComponentId :: ComponentId
+ , componentUnitId :: UnitId
+ , componentPackageDeps :: [(UnitId, MungedPackageId)]
+ , componentIncludes :: [(OpenUnitId, ModuleRenaming)]
+ , componentExeDeps :: [UnitId]
+ , componentInternalDeps :: [UnitId]
+ }
+ | TestComponentLocalBuildInfo
+ { componentLocalName :: ComponentName
+ , componentComponentId :: ComponentId
+ , componentUnitId :: UnitId
+ , componentPackageDeps :: [(UnitId, MungedPackageId)]
+ , componentIncludes :: [(OpenUnitId, ModuleRenaming)]
+ , componentExeDeps :: [UnitId]
+ , componentInternalDeps :: [UnitId]
+ }
+ | BenchComponentLocalBuildInfo
+ { componentLocalName :: ComponentName
+ , componentComponentId :: ComponentId
+ , componentUnitId :: UnitId
+ , componentPackageDeps :: [(UnitId, MungedPackageId)]
+ , componentIncludes :: [(OpenUnitId, ModuleRenaming)]
+ , componentExeDeps :: [UnitId]
+ , componentInternalDeps :: [UnitId]
+ }
deriving (Generic, Read, Show, Typeable)
instance Binary ComponentLocalBuildInfo
instance Structured ComponentLocalBuildInfo
instance IsNode ComponentLocalBuildInfo where
- type Key ComponentLocalBuildInfo = UnitId
- nodeKey = componentUnitId
- nodeNeighbors = componentInternalDeps
+ type Key ComponentLocalBuildInfo = UnitId
+ nodeKey = componentUnitId
+ nodeNeighbors = componentInternalDeps
componentIsIndefinite :: ComponentLocalBuildInfo -> Bool
-componentIsIndefinite LibComponentLocalBuildInfo{ componentIsIndefinite_ = b } = b
+componentIsIndefinite LibComponentLocalBuildInfo{componentIsIndefinite_ = b} = b
componentIsIndefinite _ = False
maybeComponentInstantiatedWith :: ComponentLocalBuildInfo -> Maybe [(ModuleName, OpenModule)]
maybeComponentInstantiatedWith
- LibComponentLocalBuildInfo { componentInstantiatedWith = insts } = Just insts
+ LibComponentLocalBuildInfo{componentInstantiatedWith = insts} = Just insts
maybeComponentInstantiatedWith _ = Nothing
diff --git a/Cabal/src/Distribution/Types/DumpBuildInfo.hs b/Cabal/src/Distribution/Types/DumpBuildInfo.hs
index 5657a65aa718c7cc88907429b4cf760797750150..2b3dae8888f94125e4eb6aec1cda994c685d8725 100644
--- a/Cabal/src/Distribution/Types/DumpBuildInfo.hs
+++ b/Cabal/src/Distribution/Types/DumpBuildInfo.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Types.DumpBuildInfo
- ( DumpBuildInfo(..)
- ) where
+ ( DumpBuildInfo (..)
+ ) where
import Distribution.Compat.Prelude
diff --git a/Cabal/src/Distribution/Types/GivenComponent.hs b/Cabal/src/Distribution/Types/GivenComponent.hs
index 3908ec07cc98cc5695cf4bf7283a56f1a3b463ef..c8314311d898348f1f33be6df655ca4f842bc0db 100644
--- a/Cabal/src/Distribution/Types/GivenComponent.hs
+++ b/Cabal/src/Distribution/Types/GivenComponent.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Types.GivenComponent (
- GivenComponent(..)
-) where
+
+module Distribution.Types.GivenComponent
+ ( GivenComponent (..)
+ ) where
import Distribution.Compat.Prelude
@@ -16,12 +17,12 @@ import Distribution.Types.PackageName
-- It enables Cabal to know which 'ComponentId' to associate with a library
--
-- @since 2.3.0.0
-data GivenComponent =
- GivenComponent
- { givenComponentPackage :: PackageName
- , givenComponentName :: LibraryName -- --dependency is for libraries
- -- only, not for any component
- , givenComponentId :: ComponentId }
+data GivenComponent = GivenComponent
+ { givenComponentPackage :: PackageName
+ , givenComponentName :: LibraryName -- --dependency is for libraries
+ -- only, not for any component
+ , givenComponentId :: ComponentId
+ }
deriving (Generic, Read, Show, Eq, Typeable)
instance Binary GivenComponent
diff --git a/Cabal/src/Distribution/Types/LocalBuildInfo.hs b/Cabal/src/Distribution/Types/LocalBuildInfo.hs
index c8753d68200d558269a2a96b9c2ea70a59343b59..ef2a1c8c875a97c1b288b020434227f5f8652629 100644
--- a/Cabal/src/Distribution/Types/LocalBuildInfo.hs
+++ b/Cabal/src/Distribution/Types/LocalBuildInfo.hs
@@ -3,161 +3,183 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-module Distribution.Types.LocalBuildInfo (
- -- * The type
-
- LocalBuildInfo(..),
+module Distribution.Types.LocalBuildInfo
+ ( -- * The type
+ LocalBuildInfo (..)
-- * Convenience accessors
-
- localComponentId,
- localUnitId,
- localCompatPackageKey,
- localPackage,
+ , localComponentId
+ , localUnitId
+ , localCompatPackageKey
+ , localPackage
-- * Build targets of the 'LocalBuildInfo'.
-
- componentNameCLBIs,
-
- -- NB: the primes mean that they take a 'PackageDescription'
- -- which may not match 'localPkgDescr' in 'LocalBuildInfo'.
- -- More logical types would drop this argument, but
- -- at the moment, this is the ONLY supported function, because
- -- 'localPkgDescr' is not guaranteed to match. At some point
- -- we will fix it and then we can use the (free) unprimed
- -- namespace for the correct commands.
- --
- -- See https://github.com/haskell/cabal/issues/3606 for more
- -- details.
-
- componentNameTargets',
- unitIdTarget',
- allTargetsInBuildOrder',
- withAllTargetsInBuildOrder',
- neededTargetsInBuildOrder',
- withNeededTargetsInBuildOrder',
- testCoverage,
+ , componentNameCLBIs
+ -- NB: the primes mean that they take a 'PackageDescription'
+ -- which may not match 'localPkgDescr' in 'LocalBuildInfo'.
+ -- More logical types would drop this argument, but
+ -- at the moment, this is the ONLY supported function, because
+ -- 'localPkgDescr' is not guaranteed to match. At some point
+ -- we will fix it and then we can use the (free) unprimed
+ -- namespace for the correct commands.
+ --
+ -- See https://github.com/haskell/cabal/issues/3606 for more
+ -- details.
+
+ , componentNameTargets'
+ , unitIdTarget'
+ , allTargetsInBuildOrder'
+ , withAllTargetsInBuildOrder'
+ , neededTargetsInBuildOrder'
+ , withNeededTargetsInBuildOrder'
+ , testCoverage
-- * Functions you SHOULD NOT USE (yet), but are defined here to
- -- prevent someone from accidentally defining them
- componentNameTargets,
- unitIdTarget,
- allTargetsInBuildOrder,
- withAllTargetsInBuildOrder,
- neededTargetsInBuildOrder,
- withNeededTargetsInBuildOrder,
+ -- prevent someone from accidentally defining them
+
+ , componentNameTargets
+ , unitIdTarget
+ , allTargetsInBuildOrder
+ , withAllTargetsInBuildOrder
+ , neededTargetsInBuildOrder
+ , withNeededTargetsInBuildOrder
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.PackageDescription
+import Distribution.Types.ComponentId
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.ComponentRequestedSpec
-import Distribution.Types.ComponentId
+import Distribution.Types.PackageDescription
import Distribution.Types.PackageId
-import Distribution.Types.UnitId
import Distribution.Types.TargetInfo
+import Distribution.Types.UnitId
-import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs,
- prefixRelativeInstallDirs,
- substPathTemplate, )
-import Distribution.Simple.Program
import Distribution.PackageDescription
+import Distribution.Pretty
import Distribution.Simple.Compiler
+import Distribution.Simple.InstallDirs hiding
+ ( absoluteInstallDirs
+ , prefixRelativeInstallDirs
+ , substPathTemplate
+ )
import Distribution.Simple.PackageIndex
+import Distribution.Simple.Program
import Distribution.Simple.Setup.Config
import Distribution.System
-import Distribution.Pretty
+import qualified Data.Map as Map
import Distribution.Compat.Graph (Graph)
import qualified Distribution.Compat.Graph as Graph
-import qualified Data.Map as Map
-- | Data cached after configuration step. See also
-- 'Distribution.Simple.Setup.ConfigFlags'.
-data LocalBuildInfo = LocalBuildInfo {
- configFlags :: ConfigFlags,
- -- ^ Options passed to the configuration step.
- -- Needed to re-run configuration when .cabal is out of date
- flagAssignment :: FlagAssignment,
- -- ^ The final set of flags which were picked for this package
- componentEnabledSpec :: ComponentRequestedSpec,
- -- ^ What components were enabled during configuration, and why.
- extraConfigArgs :: [String],
- -- ^ Extra args on the command line for the configuration step.
- -- Needed to re-run configuration when .cabal is out of date
- installDirTemplates :: InstallDirTemplates,
- -- ^ The installation directories for the various different
- -- kinds of files
- --TODO: inplaceDirTemplates :: InstallDirs FilePath
- compiler :: Compiler,
- -- ^ The compiler we're building with
- hostPlatform :: Platform,
- -- ^ The platform we're building for
- buildDir :: FilePath,
- -- ^ Where to build the package.
- cabalFilePath :: Maybe FilePath,
- -- ^ Path to the cabal file, if given during configuration.
- componentGraph :: Graph ComponentLocalBuildInfo,
- -- ^ All the components to build, ordered by topological
- -- sort, and with their INTERNAL dependencies over the
- -- intrapackage dependency graph.
- -- TODO: this is assumed to be short; otherwise we want
- -- some sort of ordered map.
- componentNameMap :: Map ComponentName [ComponentLocalBuildInfo],
- -- ^ A map from component name to all matching
- -- components. These coincide with 'componentGraph'
- installedPkgs :: InstalledPackageIndex,
- -- ^ All the info about the installed packages that the
- -- current package depends on (directly or indirectly).
- -- The copy saved on disk does NOT include internal
- -- dependencies (because we just don't have enough
- -- information at this point to have an
- -- 'InstalledPackageInfo' for an internal dep), but we
- -- will often update it with the internal dependencies;
- -- see for example 'Distribution.Simple.Build.build'.
- -- (This admonition doesn't apply for per-component builds.)
- pkgDescrFile :: Maybe FilePath,
- -- ^ the filename containing the .cabal file, if available
- localPkgDescr :: PackageDescription,
- -- ^ WARNING WARNING WARNING Be VERY careful about using
- -- this function; we haven't deprecated it but using it
- -- could introduce subtle bugs related to
- -- 'HookedBuildInfo'.
- --
- -- In principle, this is supposed to contain the
- -- resolved package description, that does not contain
- -- any conditionals. However, it MAY NOT contain
- -- the description with a 'HookedBuildInfo' applied
- -- to it; see 'HookedBuildInfo' for the whole sordid saga.
- -- As much as possible, Cabal library should avoid using
- -- this parameter.
- withPrograms :: ProgramDb, -- ^Location and args for all programs
- withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user
- withVanillaLib:: Bool, -- ^Whether to build normal libs.
- withProfLib :: Bool, -- ^Whether to build profiling versions of libs.
- withSharedLib :: Bool, -- ^Whether to build shared versions of libs.
- withStaticLib :: Bool, -- ^Whether to build static versions of libs (with all other libs rolled in)
- withDynExe :: Bool, -- ^Whether to link executables dynamically
- withFullyStaticExe :: Bool, -- ^Whether to link executables fully statically
- withProfExe :: Bool, -- ^Whether to build executables for profiling.
- withProfLibDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.
- withProfExeDetail :: ProfDetailLevel, -- ^Level of automatic profile detail.
- withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available).
- withDebugInfo :: DebugInfoLevel, -- ^Whether to emit debug info (if available).
- withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi.
- splitSections :: Bool, -- ^Use -split-sections with GHC, if available
- splitObjs :: Bool, -- ^Use -split-objs with GHC, if available
- stripExes :: Bool, -- ^Whether to strip executables during install
- stripLibs :: Bool, -- ^Whether to strip libraries during install
- exeCoverage :: Bool, -- ^Whether to enable executable program coverage
- libCoverage :: Bool, -- ^Whether to enable library program coverage
- progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables
- progSuffix :: PathTemplate, -- ^Suffix to be appended to installed executables
- relocatable :: Bool -- ^Whether to build a relocatable package
- } deriving (Generic, Read, Show, Typeable)
+data LocalBuildInfo = LocalBuildInfo
+ { configFlags :: ConfigFlags
+ -- ^ Options passed to the configuration step.
+ -- Needed to re-run configuration when .cabal is out of date
+ , flagAssignment :: FlagAssignment
+ -- ^ The final set of flags which were picked for this package
+ , componentEnabledSpec :: ComponentRequestedSpec
+ -- ^ What components were enabled during configuration, and why.
+ , extraConfigArgs :: [String]
+ -- ^ Extra args on the command line for the configuration step.
+ -- Needed to re-run configuration when .cabal is out of date
+ , installDirTemplates :: InstallDirTemplates
+ -- ^ The installation directories for the various different
+ -- kinds of files
+ -- TODO: inplaceDirTemplates :: InstallDirs FilePath
+ , compiler :: Compiler
+ -- ^ The compiler we're building with
+ , hostPlatform :: Platform
+ -- ^ The platform we're building for
+ , buildDir :: FilePath
+ -- ^ Where to build the package.
+ , cabalFilePath :: Maybe FilePath
+ -- ^ Path to the cabal file, if given during configuration.
+ , componentGraph :: Graph ComponentLocalBuildInfo
+ -- ^ All the components to build, ordered by topological
+ -- sort, and with their INTERNAL dependencies over the
+ -- intrapackage dependency graph.
+ -- TODO: this is assumed to be short; otherwise we want
+ -- some sort of ordered map.
+ , componentNameMap :: Map ComponentName [ComponentLocalBuildInfo]
+ -- ^ A map from component name to all matching
+ -- components. These coincide with 'componentGraph'
+ , installedPkgs :: InstalledPackageIndex
+ -- ^ All the info about the installed packages that the
+ -- current package depends on (directly or indirectly).
+ -- The copy saved on disk does NOT include internal
+ -- dependencies (because we just don't have enough
+ -- information at this point to have an
+ -- 'InstalledPackageInfo' for an internal dep), but we
+ -- will often update it with the internal dependencies;
+ -- see for example 'Distribution.Simple.Build.build'.
+ -- (This admonition doesn't apply for per-component builds.)
+ , pkgDescrFile :: Maybe FilePath
+ -- ^ the filename containing the .cabal file, if available
+ , localPkgDescr :: PackageDescription
+ -- ^ WARNING WARNING WARNING Be VERY careful about using
+ -- this function; we haven't deprecated it but using it
+ -- could introduce subtle bugs related to
+ -- 'HookedBuildInfo'.
+ --
+ -- In principle, this is supposed to contain the
+ -- resolved package description, that does not contain
+ -- any conditionals. However, it MAY NOT contain
+ -- the description with a 'HookedBuildInfo' applied
+ -- to it; see 'HookedBuildInfo' for the whole sordid saga.
+ -- As much as possible, Cabal library should avoid using
+ -- this parameter.
+ , withPrograms :: ProgramDb
+ -- ^ Location and args for all programs
+ , withPackageDB :: PackageDBStack
+ -- ^ What package database to use, global\/user
+ , withVanillaLib :: Bool
+ -- ^ Whether to build normal libs.
+ , withProfLib :: Bool
+ -- ^ Whether to build profiling versions of libs.
+ , withSharedLib :: Bool
+ -- ^ Whether to build shared versions of libs.
+ , withStaticLib :: Bool
+ -- ^ Whether to build static versions of libs (with all other libs rolled in)
+ , withDynExe :: Bool
+ -- ^ Whether to link executables dynamically
+ , withFullyStaticExe :: Bool
+ -- ^ Whether to link executables fully statically
+ , withProfExe :: Bool
+ -- ^ Whether to build executables for profiling.
+ , withProfLibDetail :: ProfDetailLevel
+ -- ^ Level of automatic profile detail.
+ , withProfExeDetail :: ProfDetailLevel
+ -- ^ Level of automatic profile detail.
+ , withOptimization :: OptimisationLevel
+ -- ^ Whether to build with optimization (if available).
+ , withDebugInfo :: DebugInfoLevel
+ -- ^ Whether to emit debug info (if available).
+ , withGHCiLib :: Bool
+ -- ^ Whether to build libs suitable for use with GHCi.
+ , splitSections :: Bool
+ -- ^ Use -split-sections with GHC, if available
+ , splitObjs :: Bool
+ -- ^ Use -split-objs with GHC, if available
+ , stripExes :: Bool
+ -- ^ Whether to strip executables during install
+ , stripLibs :: Bool
+ -- ^ Whether to strip libraries during install
+ , exeCoverage :: Bool
+ -- ^ Whether to enable executable program coverage
+ , libCoverage :: Bool
+ -- ^ Whether to enable library program coverage
+ , progPrefix :: PathTemplate
+ -- ^ Prefix to be prepended to installed executables
+ , progSuffix :: PathTemplate
+ -- ^ Suffix to be appended to installed executables
+ , relocatable :: Bool -- ^Whether to build a relocatable package
+ }
+ deriving (Generic, Read, Show, Typeable)
instance Binary LocalBuildInfo
instance Structured LocalBuildInfo
@@ -173,10 +195,10 @@ instance Structured LocalBuildInfo
-- on the package ID.
localComponentId :: LocalBuildInfo -> ComponentId
localComponentId lbi =
- case componentNameCLBIs lbi (CLibName LMainLibName) of
- [LibComponentLocalBuildInfo { componentComponentId = cid }]
- -> cid
- _ -> mkComponentId (prettyShow (localPackage lbi))
+ case componentNameCLBIs lbi (CLibName LMainLibName) of
+ [LibComponentLocalBuildInfo{componentComponentId = cid}] ->
+ cid
+ _ -> mkComponentId (prettyShow (localPackage lbi))
-- | Extract the 'PackageIdentifier' of a 'LocalBuildInfo'.
-- This is a "safe" use of 'localPkgDescr'
@@ -188,32 +210,34 @@ localPackage lbi = package (localPkgDescr lbi)
-- the package ID.
localUnitId :: LocalBuildInfo -> UnitId
localUnitId lbi =
- case componentNameCLBIs lbi (CLibName LMainLibName) of
- [LibComponentLocalBuildInfo { componentUnitId = uid }]
- -> uid
- _ -> mkLegacyUnitId $ localPackage lbi
+ case componentNameCLBIs lbi (CLibName LMainLibName) of
+ [LibComponentLocalBuildInfo{componentUnitId = uid}] ->
+ uid
+ _ -> mkLegacyUnitId $ localPackage lbi
-- | Extract the compatibility package key from the public library component of a
-- 'LocalBuildInfo' if it exists, or make a fake package key based
-- on the package ID.
localCompatPackageKey :: LocalBuildInfo -> String
localCompatPackageKey lbi =
- case componentNameCLBIs lbi (CLibName LMainLibName) of
- [LibComponentLocalBuildInfo { componentCompatPackageKey = pk }]
- -> pk
- _ -> prettyShow (localPackage lbi)
+ case componentNameCLBIs lbi (CLibName LMainLibName) of
+ [LibComponentLocalBuildInfo{componentCompatPackageKey = pk}] ->
+ pk
+ _ -> prettyShow (localPackage lbi)
-- | Convenience function to generate a default 'TargetInfo' from a
-- 'ComponentLocalBuildInfo'. The idea is to call this once, and then
-- use 'TargetInfo' everywhere else. Private to this module.
mkTargetInfo :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> TargetInfo
mkTargetInfo pkg_descr _lbi clbi =
- TargetInfo {
- targetCLBI = clbi,
- -- NB: @pkg_descr@, not @localPkgDescr lbi@!
- targetComponent = getComponent pkg_descr
- (componentLocalName clbi)
- }
+ TargetInfo
+ { targetCLBI = clbi
+ , -- NB: @pkg_descr@, not @localPkgDescr lbi@!
+ targetComponent =
+ getComponent
+ pkg_descr
+ (componentLocalName clbi)
+ }
-- | Return all 'TargetInfo's associated with 'ComponentName'.
-- In the presence of Backpack there may be more than one!
@@ -221,23 +245,23 @@ mkTargetInfo pkg_descr _lbi clbi =
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
componentNameTargets' :: PackageDescription -> LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets' pkg_descr lbi cname =
- case Map.lookup cname (componentNameMap lbi) of
- Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis
- Nothing -> []
+ case Map.lookup cname (componentNameMap lbi) of
+ Just clbis -> map (mkTargetInfo pkg_descr lbi) clbis
+ Nothing -> []
unitIdTarget' :: PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo
unitIdTarget' pkg_descr lbi uid =
- case Graph.lookup uid (componentGraph lbi) of
- Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)
- Nothing -> Nothing
+ case Graph.lookup uid (componentGraph lbi) of
+ Just clbi -> Just (mkTargetInfo pkg_descr lbi clbi)
+ Nothing -> Nothing
-- | Return all 'ComponentLocalBuildInfo's associated with 'ComponentName'.
-- In the presence of Backpack there may be more than one!
componentNameCLBIs :: LocalBuildInfo -> ComponentName -> [ComponentLocalBuildInfo]
componentNameCLBIs lbi cname =
- case Map.lookup cname (componentNameMap lbi) of
- Just clbis -> clbis
- Nothing -> []
+ case Map.lookup cname (componentNameMap lbi) of
+ Just clbis -> clbis
+ Nothing -> []
-- TODO: Maybe cache topsort (Graph can do this)
@@ -246,16 +270,16 @@ componentNameCLBIs lbi cname =
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
allTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [TargetInfo]
-allTargetsInBuildOrder' pkg_descr lbi
- = map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi))
+allTargetsInBuildOrder' pkg_descr lbi =
+ map (mkTargetInfo pkg_descr lbi) (Graph.revTopSort (componentGraph lbi))
-- | Execute @f@ for every 'TargetInfo' in the package, respecting the
-- build dependency order. (TODO: We should use Shake!)
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
withAllTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()
-withAllTargetsInBuildOrder' pkg_descr lbi f
- = sequence_ [ f target | target <- allTargetsInBuildOrder' pkg_descr lbi ]
+withAllTargetsInBuildOrder' pkg_descr lbi f =
+ sequence_ [f target | target <- allTargetsInBuildOrder' pkg_descr lbi]
-- | Return the list of all targets needed to build the @uids@, in
-- the order they need to be built.
@@ -272,8 +296,8 @@ neededTargetsInBuildOrder' pkg_descr lbi uids =
-- Has a prime because it takes a 'PackageDescription' argument
-- which may disagree with 'localPkgDescr' in 'LocalBuildInfo'.
withNeededTargetsInBuildOrder' :: PackageDescription -> LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()
-withNeededTargetsInBuildOrder' pkg_descr lbi uids f
- = sequence_ [ f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids ]
+withNeededTargetsInBuildOrder' pkg_descr lbi uids f =
+ sequence_ [f target | target <- neededTargetsInBuildOrder' pkg_descr lbi uids]
-- | Is coverage enabled for test suites? In practice, this requires library
-- and executable profiling to be enabled.
@@ -284,21 +308,15 @@ testCoverage lbi = exeCoverage lbi && libCoverage lbi
-- Stub functions to prevent someone from accidentally defining them
{-# WARNING componentNameTargets, unitIdTarget, allTargetsInBuildOrder, withAllTargetsInBuildOrder, neededTargetsInBuildOrder, withNeededTargetsInBuildOrder "By using this function, you may be introducing a bug where you retrieve a 'Component' which does not have 'HookedBuildInfo' applied to it. See the documentation for 'HookedBuildInfo' for an explanation of the issue. If you have a 'PackageDescription' handy (NOT from the 'LocalBuildInfo'), try using the primed version of the function, which takes it as an extra argument." #-}
-
componentNameTargets :: LocalBuildInfo -> ComponentName -> [TargetInfo]
componentNameTargets lbi = componentNameTargets' (localPkgDescr lbi) lbi
-
unitIdTarget :: LocalBuildInfo -> UnitId -> Maybe TargetInfo
unitIdTarget lbi = unitIdTarget' (localPkgDescr lbi) lbi
-
allTargetsInBuildOrder :: LocalBuildInfo -> [TargetInfo]
allTargetsInBuildOrder lbi = allTargetsInBuildOrder' (localPkgDescr lbi) lbi
-
withAllTargetsInBuildOrder :: LocalBuildInfo -> (TargetInfo -> IO ()) -> IO ()
withAllTargetsInBuildOrder lbi = withAllTargetsInBuildOrder' (localPkgDescr lbi) lbi
-
neededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> [TargetInfo]
neededTargetsInBuildOrder lbi = neededTargetsInBuildOrder' (localPkgDescr lbi) lbi
-
withNeededTargetsInBuildOrder :: LocalBuildInfo -> [UnitId] -> (TargetInfo -> IO ()) -> IO ()
withNeededTargetsInBuildOrder lbi = withNeededTargetsInBuildOrder' (localPkgDescr lbi) lbi
diff --git a/Cabal/src/Distribution/Types/TargetInfo.hs b/Cabal/src/Distribution/Types/TargetInfo.hs
index 52b11308fe1d7be7d577df0fb2bf0958612892be..8f724d894d176d6096e3914b73b986308e800cb2 100644
--- a/Cabal/src/Distribution/Types/TargetInfo.hs
+++ b/Cabal/src/Distribution/Types/TargetInfo.hs
@@ -1,33 +1,34 @@
{-# LANGUAGE TypeFamilies #-}
-module Distribution.Types.TargetInfo (
- TargetInfo(..)
-) where
-import Prelude ()
+module Distribution.Types.TargetInfo
+ ( TargetInfo (..)
+ ) where
+
import Distribution.Compat.Prelude
+import Prelude ()
-import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.Component
+import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.UnitId
-import Distribution.Compat.Graph (IsNode(..))
+import Distribution.Compat.Graph (IsNode (..))
-- | The 'TargetInfo' contains all the information necessary to build a
-- specific target (e.g., component/module/file) in a package. In
-- principle, one can get the 'Component' from a
-- 'ComponentLocalBuildInfo' and 'LocalBuildInfo', but it is much more
-- convenient to have the component in hand.
-data TargetInfo = TargetInfo {
- targetCLBI :: ComponentLocalBuildInfo,
- targetComponent :: Component
- -- TODO: BuildTargets supporting parsing these is dumb,
- -- we don't have support for compiling single modules or
- -- file paths. Accommodating it now is premature
- -- generalization. Figure it out later.
- -- targetSub :: Maybe (Either ModuleName FilePath)
- }
+data TargetInfo = TargetInfo
+ { targetCLBI :: ComponentLocalBuildInfo
+ , targetComponent :: Component
+ -- TODO: BuildTargets supporting parsing these is dumb,
+ -- we don't have support for compiling single modules or
+ -- file paths. Accommodating it now is premature
+ -- generalization. Figure it out later.
+ -- targetSub :: Maybe (Either ModuleName FilePath)
+ }
instance IsNode TargetInfo where
- type Key TargetInfo = UnitId
- nodeKey = nodeKey . targetCLBI
- nodeNeighbors = nodeNeighbors . targetCLBI
+ type Key TargetInfo = UnitId
+ nodeKey = nodeKey . targetCLBI
+ nodeNeighbors = nodeNeighbors . targetCLBI
diff --git a/Cabal/src/Distribution/Utils/IOData.hs b/Cabal/src/Distribution/Utils/IOData.hs
index e71fb5099a4d663ec6c3ad09dcb6e363a2cc169f..074576ceaf97a85279cc4bca00c79e0622c69886 100644
--- a/Cabal/src/Distribution/Utils/IOData.hs
+++ b/Cabal/src/Distribution/Utils/IOData.hs
@@ -1,78 +1,78 @@
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+
-- | @since 2.2.0
module Distribution.Utils.IOData
- ( -- * 'IOData' & 'IODataMode' type
- IOData (..)
- , IODataMode (..)
- , KnownIODataMode (..)
- , withIOData
- , null
- , hPutContents
- ) where
+ ( -- * 'IOData' & 'IODataMode' type
+ IOData (..)
+ , IODataMode (..)
+ , KnownIODataMode (..)
+ , withIOData
+ , null
+ , hPutContents
+ ) where
import qualified Data.ByteString.Lazy as LBS
-import Distribution.Compat.Prelude hiding (null)
-import qualified Prelude
+import Distribution.Compat.Prelude hiding (null)
import qualified System.IO
+import qualified Prelude
-- | Represents either textual or binary data passed via I/O functions
-- which support binary/text mode
--
-- @since 2.2
data IOData
- = IODataText String
- -- ^ How Text gets encoded is usually locale-dependent.
- | IODataBinary LBS.ByteString
- -- ^ Raw binary which gets read/written in binary mode.
+ = -- | How Text gets encoded is usually locale-dependent.
+ IODataText String
+ | -- | Raw binary which gets read/written in binary mode.
+ IODataBinary LBS.ByteString
withIOData :: IOData -> (forall mode. IODataMode mode -> mode -> r) -> r
-withIOData (IODataText str) k = k IODataModeText str
+withIOData (IODataText str) k = k IODataModeText str
withIOData (IODataBinary lbs) k = k IODataModeBinary lbs
-- | Test whether 'IOData' is empty
null :: IOData -> Bool
-null (IODataText s) = Prelude.null s
+null (IODataText s) = Prelude.null s
null (IODataBinary b) = LBS.null b
instance NFData IOData where
- rnf (IODataText s) = rnf s
- rnf (IODataBinary lbs) = rnf lbs
+ rnf (IODataText s) = rnf s
+ rnf (IODataBinary lbs) = rnf lbs
-- | @since 2.2
class NFData mode => KnownIODataMode mode where
- -- | 'IOData' Wrapper for 'System.IO.hGetContents'
- --
- -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all
- -- data to be read and consequently the internal file handle to be
- -- closed.
- --
- hGetIODataContents :: System.IO.Handle -> Prelude.IO mode
+ -- | 'IOData' Wrapper for 'System.IO.hGetContents'
+ --
+ -- __Note__: This operation uses lazy I/O. Use 'NFData' to force all
+ -- data to be read and consequently the internal file handle to be
+ -- closed.
+ hGetIODataContents :: System.IO.Handle -> Prelude.IO mode
- toIOData :: mode -> IOData
- iodataMode :: IODataMode mode
+ toIOData :: mode -> IOData
+ iodataMode :: IODataMode mode
-- | @since 3.2
data IODataMode mode where
- IODataModeText :: IODataMode String
- IODataModeBinary :: IODataMode LBS.ByteString
+ IODataModeText :: IODataMode String
+ IODataModeBinary :: IODataMode LBS.ByteString
instance a ~ Char => KnownIODataMode [a] where
- hGetIODataContents h = do
- System.IO.hSetBinaryMode h False
- System.IO.hGetContents h
+ hGetIODataContents h = do
+ System.IO.hSetBinaryMode h False
+ System.IO.hGetContents h
- toIOData = IODataText
- iodataMode = IODataModeText
+ toIOData = IODataText
+ iodataMode = IODataModeText
instance KnownIODataMode LBS.ByteString where
- hGetIODataContents h = do
- System.IO.hSetBinaryMode h True
- LBS.hGetContents h
+ hGetIODataContents h = do
+ System.IO.hSetBinaryMode h True
+ LBS.hGetContents h
- toIOData = IODataBinary
- iodataMode = IODataModeBinary
+ toIOData = IODataBinary
+ iodataMode = IODataModeBinary
-- | 'IOData' Wrapper for 'System.IO.hPutStr' and 'System.IO.hClose'
--
@@ -84,10 +84,10 @@ instance KnownIODataMode LBS.ByteString where
-- @since 2.2
hPutContents :: System.IO.Handle -> IOData -> Prelude.IO ()
hPutContents h (IODataText c) = do
- System.IO.hSetBinaryMode h False
- System.IO.hPutStr h c
- System.IO.hClose h
+ System.IO.hSetBinaryMode h False
+ System.IO.hPutStr h c
+ System.IO.hClose h
hPutContents h (IODataBinary c) = do
- System.IO.hSetBinaryMode h True
- LBS.hPutStr h c
- System.IO.hClose h
+ System.IO.hSetBinaryMode h True
+ LBS.hPutStr h c
+ System.IO.hClose h
diff --git a/Cabal/src/Distribution/Utils/Json.hs b/Cabal/src/Distribution/Utils/Json.hs
index cef32f04d6d50864dbd7b0df5bfc75fd92b95a4c..873e60631ace752387480b36442d9605577ec0ac 100644
--- a/Cabal/src/Distribution/Utils/Json.hs
+++ b/Cabal/src/Distribution/Utils/Json.hs
@@ -1,55 +1,60 @@
-{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
--- | Extremely simple JSON helper. Don't do anything too fancy with this!
+{-# LANGUAGE RankNTypes #-}
+-- | Extremely simple JSON helper. Don't do anything too fancy with this!
module Distribution.Utils.Json
- ( Json(..)
- , (.=)
- , renderJson
- ) where
+ ( Json (..)
+ , (.=)
+ , renderJson
+ ) where
-import Distribution.Compat.Prelude
-import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Builder
- ( Builder, stringUtf8, intDec, toLazyByteString )
+ ( Builder
+ , intDec
+ , stringUtf8
+ , toLazyByteString
+ )
+import qualified Data.ByteString.Lazy as LBS
+import Distribution.Compat.Prelude
-data Json = JsonArray [Json]
- | JsonBool !Bool
- | JsonNull
- | JsonNumber !Int -- No support for Floats, Doubles just yet
- | JsonObject [(String, Json)]
- | JsonString !String
- deriving Show
+data Json
+ = JsonArray [Json]
+ | JsonBool !Bool
+ | JsonNull
+ | JsonNumber !Int -- No support for Floats, Doubles just yet
+ | JsonObject [(String, Json)]
+ | JsonString !String
+ deriving (Show)
-- | Convert a 'Json' into a 'ByteString'
renderJson :: Json -> LBS.ByteString
renderJson json = toLazyByteString (go json)
where
- go (JsonArray objs) =
+ go (JsonArray objs) =
surround "[" "]" $ mconcat $ intersperse "," $ map go objs
- go (JsonBool True) = stringUtf8 "true"
- go (JsonBool False) = stringUtf8 "false"
- go JsonNull = stringUtf8 "null"
- go (JsonNumber n) = intDec n
+ go (JsonBool True) = stringUtf8 "true"
+ go (JsonBool False) = stringUtf8 "false"
+ go JsonNull = stringUtf8 "null"
+ go (JsonNumber n) = intDec n
go (JsonObject attrs) =
surround "{" "}" $ mconcat $ intersperse "," $ map render attrs
where
- render (k,v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v
- go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s)
+ render (k, v) = (surround "\"" "\"" $ stringUtf8 (escape k)) <> ":" <> go v
+ go (JsonString s) = surround "\"" "\"" $ stringUtf8 (escape s)
surround :: Builder -> Builder -> Builder -> Builder
-surround begin end middle = mconcat [ begin , middle , end]
+surround begin end middle = mconcat [begin, middle, end]
escape :: String -> String
-escape ('\"':xs) = "\\\"" <> escape xs
-escape ('\\':xs) = "\\\\" <> escape xs
-escape ('\b':xs) = "\\b" <> escape xs
-escape ('\f':xs) = "\\f" <> escape xs
-escape ('\n':xs) = "\\n" <> escape xs
-escape ('\r':xs) = "\\r" <> escape xs
-escape ('\t':xs) = "\\t" <> escape xs
-escape (x:xs) = x : escape xs
-escape [] = mempty
+escape ('\"' : xs) = "\\\"" <> escape xs
+escape ('\\' : xs) = "\\\\" <> escape xs
+escape ('\b' : xs) = "\\b" <> escape xs
+escape ('\f' : xs) = "\\f" <> escape xs
+escape ('\n' : xs) = "\\n" <> escape xs
+escape ('\r' : xs) = "\\r" <> escape xs
+escape ('\t' : xs) = "\\t" <> escape xs
+escape (x : xs) = x : escape xs
+escape [] = mempty
-- | A shorthand for building up 'JsonObject's
-- >>> JsonObject [ "a" .= JsonNumber 42, "b" .= JsonBool True ]
diff --git a/Cabal/src/Distribution/Utils/LogProgress.hs b/Cabal/src/Distribution/Utils/LogProgress.hs
index 9a2dced9392c9aae1a2a997e85ed862b2b8e9101..114e01ab5a59c32e0802a371aba74f2f84f3febe 100644
--- a/Cabal/src/Distribution/Utils/LogProgress.hs
+++ b/Cabal/src/Distribution/Utils/LogProgress.hs
@@ -1,83 +1,85 @@
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE FlexibleContexts #-}
-module Distribution.Utils.LogProgress (
- LogProgress,
- runLogProgress,
- warnProgress,
- infoProgress,
- dieProgress,
- addProgressCtx,
-) where
-import Prelude ()
+module Distribution.Utils.LogProgress
+ ( LogProgress
+ , runLogProgress
+ , warnProgress
+ , infoProgress
+ , dieProgress
+ , addProgressCtx
+ ) where
+
import Distribution.Compat.Prelude
+import Prelude ()
+import Distribution.Simple.Utils
import Distribution.Utils.Progress
import Distribution.Verbosity
-import Distribution.Simple.Utils
import Text.PrettyPrint
type CtxMsg = Doc
type LogMsg = Doc
type ErrMsg = Doc
-data LogEnv = LogEnv {
- le_verbosity :: Verbosity,
- le_context :: [CtxMsg]
- }
+data LogEnv = LogEnv
+ { le_verbosity :: Verbosity
+ , le_context :: [CtxMsg]
+ }
-- | The 'Progress' monad with specialized logging and
-- error messages.
-newtype LogProgress a = LogProgress { unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a }
+newtype LogProgress a = LogProgress {unLogProgress :: LogEnv -> Progress LogMsg ErrMsg a}
instance Functor LogProgress where
- fmap f (LogProgress m) = LogProgress (fmap (fmap f) m)
+ fmap f (LogProgress m) = LogProgress (fmap (fmap f) m)
instance Applicative LogProgress where
- pure x = LogProgress (pure (pure x))
- LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r
+ pure x = LogProgress (pure (pure x))
+ LogProgress f <*> LogProgress x = LogProgress $ \r -> f r `ap` x r
instance Monad LogProgress where
- return = pure
- LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r
+ return = pure
+ LogProgress m >>= f = LogProgress $ \r -> m r >>= \x -> unLogProgress (f x) r
-- | Run 'LogProgress', outputting traces according to 'Verbosity',
-- 'die' if there is an error.
runLogProgress :: Verbosity -> LogProgress a -> IO a
runLogProgress verbosity (LogProgress m) =
- foldProgress step_fn fail_fn return (m env)
+ foldProgress step_fn fail_fn return (m env)
where
- env = LogEnv {
- le_verbosity = verbosity,
- le_context = []
- }
+ env =
+ LogEnv
+ { le_verbosity = verbosity
+ , le_context = []
+ }
step_fn :: LogMsg -> IO a -> IO a
step_fn doc go = do
- putStrLn (render doc)
- go
+ putStrLn (render doc)
+ go
fail_fn :: Doc -> IO a
fail_fn doc = do
- dieNoWrap verbosity (render doc)
+ dieNoWrap verbosity (render doc)
-- | Output a warning trace message in 'LogProgress'.
warnProgress :: Doc -> LogProgress ()
warnProgress s = LogProgress $ \env ->
- when (le_verbosity env >= normal) $
- stepProgress $
- hang (text "Warning:") 4 (formatMsg (le_context env) s)
+ when (le_verbosity env >= normal) $
+ stepProgress $
+ hang (text "Warning:") 4 (formatMsg (le_context env) s)
-- | Output an informational trace message in 'LogProgress'.
infoProgress :: Doc -> LogProgress ()
infoProgress s = LogProgress $ \env ->
- when (le_verbosity env >= verbose) $
- stepProgress s
+ when (le_verbosity env >= verbose) $
+ stepProgress s
-- | Fail the computation with an error message.
dieProgress :: Doc -> LogProgress a
dieProgress s = LogProgress $ \env ->
- failProgress $
- hang (text "Error:") 4 (formatMsg (le_context env) s)
+ failProgress $
+ hang (text "Error:") 4 (formatMsg (le_context env) s)
-- | Format a message with context. (Something simple for now.)
formatMsg :: [CtxMsg] -> Doc -> Doc
@@ -86,4 +88,4 @@ formatMsg ctx doc = doc $$ vcat ctx
-- | Add a message to the error/warning context.
addProgressCtx :: CtxMsg -> LogProgress a -> LogProgress a
addProgressCtx s (LogProgress m) = LogProgress $ \env ->
- m env { le_context = s : le_context env }
+ m env{le_context = s : le_context env}
diff --git a/Cabal/src/Distribution/Utils/MapAccum.hs b/Cabal/src/Distribution/Utils/MapAccum.hs
index 6dc3d2509d1d9ae7794f39737863017c250b0428..31f62d7d02f2ea3e2994cc78523021dc310f4f85 100644
--- a/Cabal/src/Distribution/Utils/MapAccum.hs
+++ b/Cabal/src/Distribution/Utils/MapAccum.hs
@@ -1,22 +1,28 @@
{-# LANGUAGE CPP #-}
+
module Distribution.Utils.MapAccum (mapAccumM) where
import Distribution.Compat.Prelude
import Prelude ()
-- Like StateT but with return tuple swapped
-newtype StateM s m a = StateM { runStateM :: s -> m (s, a) }
+newtype StateM s m a = StateM {runStateM :: s -> m (s, a)}
instance Functor m => Functor (StateM s m) where
- fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s)
+ fmap f (StateM x) = StateM $ \s -> fmap (\(s', a) -> (s', f a)) (x s)
instance Monad m => Applicative (StateM s m) where
- pure x = StateM $ \s -> return (s, x)
- StateM f <*> StateM x = StateM $ \s -> do (s', f') <- f s
- (s'', x') <- x s'
- return (s'', f' x')
+ pure x = StateM $ \s -> return (s, x)
+ StateM f <*> StateM x = StateM $ \s -> do
+ (s', f') <- f s
+ (s'', x') <- x s'
+ return (s'', f' x')
-- | Monadic variant of 'mapAccumL'.
-mapAccumM :: (Monad m, Traversable t)
- => (a -> b -> m (a, c)) -> a -> t b -> m (a, t c)
+mapAccumM
+ :: (Monad m, Traversable t)
+ => (a -> b -> m (a, c))
+ -> a
+ -> t b
+ -> m (a, t c)
mapAccumM f s t = runStateM (traverse (\x -> StateM (\s' -> f s' x)) t) s
diff --git a/Cabal/src/Distribution/Utils/NubList.hs b/Cabal/src/Distribution/Utils/NubList.hs
index 25b8b74d6483e98c504465335198d4bbdf697e08..2a7e69a7a857f88f8cd218e505f864b1581fa2b5 100644
--- a/Cabal/src/Distribution/Utils/NubList.hs
+++ b/Cabal/src/Distribution/Utils/NubList.hs
@@ -1,17 +1,17 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Utils.NubList
- ( NubList -- opaque
- , toNubList -- smart constructor
- , fromNubList
- , overNubList
- , NubListR
- , toNubListR
- , fromNubListR
- , overNubListR
- ) where
+module Distribution.Utils.NubList
+ ( NubList -- opaque
+ , toNubList -- smart constructor
+ , fromNubList
+ , overNubList
+ , NubListR
+ , toNubListR
+ , fromNubListR
+ , overNubListR
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
@@ -21,9 +21,8 @@ import Distribution.Simple.Utils
import qualified Text.Read as R
-- | NubList : A de-duplicated list that maintains the original order.
-newtype NubList a =
- NubList { fromNubList :: [a] }
- deriving (Eq, Generic, Typeable)
+newtype NubList a = NubList {fromNubList :: [a]}
+ deriving (Eq, Generic, Typeable)
-- NubList assumes that nub retains the list order while removing duplicate
-- elements (keeping the first occurrence). Documentation for "Data.List.nub"
@@ -51,30 +50,29 @@ overNubList f (NubList list) = toNubList . f $ list
--
-- Closure : appending two lists of type a and removing duplicates obviously
-- does not change the type.
-
instance Ord a => Monoid (NubList a) where
- mempty = NubList []
- mappend = (<>)
+ mempty = NubList []
+ mappend = (<>)
instance Ord a => Semigroup (NubList a) where
- (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys
+ (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys
instance Show a => Show (NubList a) where
- show (NubList list) = show list
+ show (NubList list) = show list
instance (Ord a, Read a) => Read (NubList a) where
- readPrec = readNubList toNubList
+ readPrec = readNubList toNubList
-- | Helper used by NubList/NubListR's Read instances.
-readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)
+readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a)
readNubList listToL = R.parens . R.prec 10 $ fmap listToL R.readPrec
-- | Binary instance for 'NubList a' is the same as for '[a]'. For 'put', we
-- just pull off constructor and put the list. For 'get', we get the list and
-- make a 'NubList' out of it using 'toNubList'.
instance (Ord a, Binary a) => Binary (NubList a) where
- put (NubList l) = put l
- get = fmap toNubList get
+ put (NubList l) = put l
+ get = fmap toNubList get
instance Structured a => Structured (NubList a)
@@ -82,9 +80,8 @@ instance Structured a => Structured (NubList a)
-- ["-XNoFoo", "-XFoo", "-XNoFoo"]@ will result in @["-XFoo", "-XNoFoo"]@,
-- unlike the normal 'NubList', which is left-biased. Built on top of
-- 'ordNubRight' and 'listUnionRight'.
-newtype NubListR a =
- NubListR { fromNubListR :: [a] }
- deriving Eq
+newtype NubListR a = NubListR {fromNubListR :: [a]}
+ deriving (Eq)
-- | Smart constructor for the NubListR type.
toNubListR :: Ord a => [a] -> NubListR a
@@ -105,4 +102,4 @@ instance Show a => Show (NubListR a) where
show (NubListR list) = show list
instance (Ord a, Read a) => Read (NubListR a) where
- readPrec = readNubList toNubListR
+ readPrec = readNubList toNubListR
diff --git a/Cabal/src/Distribution/Utils/Progress.hs b/Cabal/src/Distribution/Utils/Progress.hs
index d834c87962c30cccca1494fac9a7ff6d07079690..a2c17b69113132958c346945b04935d0428f2517 100644
--- a/Cabal/src/Distribution/Utils/Progress.hs
+++ b/Cabal/src/Distribution/Utils/Progress.hs
@@ -1,22 +1,22 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
+
-- Note: This module was copied from cabal-install.
-- | A progress monad, which we use to report failure and logging from
-- otherwise pure code.
module Distribution.Utils.Progress
- ( Progress
- , stepProgress
- , failProgress
- , foldProgress
- ) where
+ ( Progress
+ , stepProgress
+ , failProgress
+ , foldProgress
+ ) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import qualified Data.Monoid as Mon
-
-- | A type to represent the unfolding of an expensive long running
-- calculation that may fail (or maybe not expensive, but complicated!)
-- We may get intermediate steps before the final
@@ -25,14 +25,13 @@ import qualified Data.Monoid as Mon
-- TODO: Apply Codensity to avoid left-associativity problem.
-- See http://comonad.com/reader/2011/free-monads-for-less/ and
-- http://blog.ezyang.com/2012/01/problem-set-the-codensity-transformation/
---
-data Progress step fail done = Step step (Progress step fail done)
- | Fail fail
- | Done done
+data Progress step fail done
+ = Step step (Progress step fail done)
+ | Fail fail
+ | Done done
deriving (Functor)
-- | Emit a step and then continue.
---
stepProgress :: step -> Progress step fail ()
stepProgress step = Step step (Done ())
@@ -46,22 +45,26 @@ failProgress err = Fail err
-- Eg to convert into a simple 'Either' result use:
--
-- > foldProgress (flip const) Left Right
---
-foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)
- -> Progress step fail done -> a
+foldProgress
+ :: (step -> a -> a)
+ -> (fail -> a)
+ -> (done -> a)
+ -> Progress step fail done
+ -> a
foldProgress step err done = fold
- where fold (Step s p) = step s (fold p)
- fold (Fail f) = err f
- fold (Done r) = done r
+ where
+ fold (Step s p) = step s (fold p)
+ fold (Fail f) = err f
+ fold (Done r) = done r
instance Monad (Progress step fail) where
- return = pure
- p >>= f = foldProgress Step Fail f p
+ return = pure
+ p >>= f = foldProgress Step Fail f p
instance Applicative (Progress step fail) where
- pure a = Done a
+ pure a = Done a
p <*> x = foldProgress Step Fail (flip fmap x) p
instance Monoid fail => Alternative (Progress step fail) where
- empty = Fail Mon.mempty
+ empty = Fail Mon.mempty
p <|> q = foldProgress Step (const q) Done p
diff --git a/Cabal/src/Distribution/Utils/UnionFind.hs b/Cabal/src/Distribution/Utils/UnionFind.hs
index 7af4177ccae193bf2ed4b1e53bb09c44e666d898..b22f07c0e43d2b4944fff4e10da44ff32baf91a6 100644
--- a/Cabal/src/Distribution/Utils/UnionFind.hs
+++ b/Cabal/src/Distribution/Utils/UnionFind.hs
@@ -1,27 +1,27 @@
{-# LANGUAGE NondecreasingIndentation #-}
+
-- | A simple mutable union-find data structure.
--
-- It is used in a unification algorithm for backpack mix-in linking.
--
-- This implementation is based off of the one in \"The Essence of ML Type
-- Inference\". (N.B. the union-find package is also based off of this.)
---
-module Distribution.Utils.UnionFind (
- Point,
- fresh,
- find,
- union,
- equivalent,
-) where
+module Distribution.Utils.UnionFind
+ ( Point
+ , fresh
+ , find
+ , union
+ , equivalent
+ ) where
-import Data.STRef
import Control.Monad
import Control.Monad.ST
+import Data.STRef
-- | A variable which can be unified; alternately, this can be thought
-- of as an equivalence class with a distinguished representative.
newtype Point s a = Point (STRef s (Link s a))
- deriving (Eq)
+ deriving (Eq)
-- | Mutable write to a 'Point'
writePoint :: Point s a -> Link s a -> ST s ()
@@ -35,39 +35,41 @@ readPoint (Point v) = readSTRef v
-- the representative element of an equivalence class, or a link to
-- the 'Point' that actually stores the representative type.
data Link s a
- -- NB: it is too bad we can't say STRef Int#; the weights remain boxed
- = Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)
- | Link {-# UNPACK #-} !(Point s a)
+ = -- NB: it is too bad we can't say STRef Int#; the weights remain boxed
+ Info {-# UNPACK #-} !(STRef s Int) {-# UNPACK #-} !(STRef s a)
+ | Link {-# UNPACK #-} !(Point s a)
-- | Create a fresh equivalence class with one element.
fresh :: a -> ST s (Point s a)
fresh desc = do
- weight <- newSTRef 1
- descriptor <- newSTRef desc
- Point `fmap` newSTRef (Info weight descriptor)
+ weight <- newSTRef 1
+ descriptor <- newSTRef desc
+ Point `fmap` newSTRef (Info weight descriptor)
-- | Flatten any chains of links, returning a 'Point'
-- which points directly to the canonical representation.
repr :: Point s a -> ST s (Point s a)
-repr point = readPoint point >>= \r ->
- case r of
- Link point' -> do
+repr point =
+ readPoint point >>= \r ->
+ case r of
+ Link point' -> do
point'' <- repr point'
when (point'' /= point') $ do
- writePoint point =<< readPoint point'
+ writePoint point =<< readPoint point'
return point''
- Info _ _ -> return point
+ Info _ _ -> return point
-- | Return the canonical element of an equivalence
-- class 'Point'.
find :: Point s a -> ST s a
find point =
- -- Optimize length 0 and 1 case at expense of
- -- general case
- readPoint point >>= \r ->
- case r of
- Info _ d_ref -> readSTRef d_ref
- Link point' -> readPoint point' >>= \r' ->
+ -- Optimize length 0 and 1 case at expense of
+ -- general case
+ readPoint point >>= \r ->
+ case r of
+ Info _ d_ref -> readSTRef d_ref
+ Link point' ->
+ readPoint point' >>= \r' ->
case r' of
Info _ d_ref -> readSTRef d_ref
Link _ -> repr point >>= find
@@ -76,26 +78,26 @@ find point =
-- a canonical element. Keeps the descriptor of point2.
union :: Point s a -> Point s a -> ST s ()
union refpoint1 refpoint2 = do
- point1 <- repr refpoint1
- point2 <- repr refpoint2
- when (point1 /= point2) $ do
+ point1 <- repr refpoint1
+ point2 <- repr refpoint2
+ when (point1 /= point2) $ do
l1 <- readPoint point1
l2 <- readPoint point2
case (l1, l2) of
- (Info wref1 dref1, Info wref2 dref2) -> do
- weight1 <- readSTRef wref1
- weight2 <- readSTRef wref2
- -- Should be able to optimize the == case separately
- if weight1 >= weight2
- then do
- writePoint point2 (Link point1)
- -- The weight calculation here seems a bit dodgy
- writeSTRef wref1 (weight1 + weight2)
- writeSTRef dref1 =<< readSTRef dref2
- else do
- writePoint point1 (Link point2)
- writeSTRef wref2 (weight1 + weight2)
- _ -> error "UnionFind.union: repr invariant broken"
+ (Info wref1 dref1, Info wref2 dref2) -> do
+ weight1 <- readSTRef wref1
+ weight2 <- readSTRef wref2
+ -- Should be able to optimize the == case separately
+ if weight1 >= weight2
+ then do
+ writePoint point2 (Link point1)
+ -- The weight calculation here seems a bit dodgy
+ writeSTRef wref1 (weight1 + weight2)
+ writeSTRef dref1 =<< readSTRef dref2
+ else do
+ writePoint point1 (Link point2)
+ writeSTRef wref2 (weight1 + weight2)
+ _ -> error "UnionFind.union: repr invariant broken"
-- | Test if two points are in the same equivalence class.
equivalent :: Point s a -> Point s a -> ST s Bool
diff --git a/Cabal/src/Distribution/Verbosity.hs b/Cabal/src/Distribution/Verbosity.hs
index d7fdeae24e96b937ea8995c84a2dcc089156d024..bab48bbed2147b8b0a0337ddbe71cd39213d09e9 100644
--- a/Cabal/src/Distribution/Verbosity.hs
+++ b/Cabal/src/Distribution/Verbosity.hs
@@ -2,6 +2,9 @@
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
+
+-- Verbosity for Cabal functions.
+
-- |
-- Module : Distribution.Verbosity
-- Copyright : Ian Lynagh 2007
@@ -21,79 +24,92 @@
-- settings (e.g., so that you can trace only particular things you
-- are interested in.) It's important to note that the instances
-- for 'Verbosity' assume that this does not exist.
-
--- Verbosity for Cabal functions.
-
-module Distribution.Verbosity (
- -- * Verbosity
- Verbosity,
- silent, normal, verbose, deafening,
- moreVerbose, lessVerbose, isVerboseQuiet,
- intToVerbosity, flagToVerbosity,
- showForCabal, showForGHC,
- verboseNoFlags, verboseHasFlags,
- modifyVerbosity,
-
- -- * Call stacks
- verboseCallSite, verboseCallStack,
- isVerboseCallSite, isVerboseCallStack,
-
- -- * Output markets
- verboseMarkOutput, isVerboseMarkOutput,
- verboseUnmarkOutput,
-
- -- * Line wrapping
- verboseNoWrap, isVerboseNoWrap,
-
- -- * Time stamps
- verboseTimestamp, isVerboseTimestamp,
- verboseNoTimestamp,
-
- -- * Stderr
- verboseStderr, isVerboseStderr,
- verboseNoStderr,
-
- -- * No warnings
- verboseNoWarn, isVerboseNoWarn
+module Distribution.Verbosity
+ ( -- * Verbosity
+ Verbosity
+ , silent
+ , normal
+ , verbose
+ , deafening
+ , moreVerbose
+ , lessVerbose
+ , isVerboseQuiet
+ , intToVerbosity
+ , flagToVerbosity
+ , showForCabal
+ , showForGHC
+ , verboseNoFlags
+ , verboseHasFlags
+ , modifyVerbosity
+
+ -- * Call stacks
+ , verboseCallSite
+ , verboseCallStack
+ , isVerboseCallSite
+ , isVerboseCallStack
+
+ -- * Output markets
+ , verboseMarkOutput
+ , isVerboseMarkOutput
+ , verboseUnmarkOutput
+
+ -- * Line wrapping
+ , verboseNoWrap
+ , isVerboseNoWrap
+
+ -- * Time stamps
+ , verboseTimestamp
+ , isVerboseTimestamp
+ , verboseNoTimestamp
+
+ -- * Stderr
+ , verboseStderr
+ , isVerboseStderr
+ , verboseNoStderr
+
+ -- * No warnings
+ , verboseNoWarn
+ , isVerboseNoWarn
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
import Distribution.ReadE
import Data.List (elemIndex)
import Distribution.Parsec
import Distribution.Pretty
-import Distribution.Verbosity.Internal
import Distribution.Utils.Generic (isAsciiAlpha)
+import Distribution.Verbosity.Internal
import qualified Data.Set as Set
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as PP
-data Verbosity = Verbosity {
- vLevel :: VerbosityLevel,
- vFlags :: Set VerbosityFlag,
- vQuiet :: Bool
- } deriving (Generic, Show, Read, Typeable)
+data Verbosity = Verbosity
+ { vLevel :: VerbosityLevel
+ , vFlags :: Set VerbosityFlag
+ , vQuiet :: Bool
+ }
+ deriving (Generic, Show, Read, Typeable)
mkVerbosity :: VerbosityLevel -> Verbosity
-mkVerbosity l = Verbosity { vLevel = l, vFlags = Set.empty, vQuiet = False }
+mkVerbosity l = Verbosity{vLevel = l, vFlags = Set.empty, vQuiet = False}
instance Eq Verbosity where
- x == y = vLevel x == vLevel y
+ x == y = vLevel x == vLevel y
instance Ord Verbosity where
- compare x y = compare (vLevel x) (vLevel y)
+ compare x y = compare (vLevel x) (vLevel y)
instance Enum Verbosity where
- toEnum = mkVerbosity . toEnum
- fromEnum = fromEnum . vLevel
+ toEnum = mkVerbosity . toEnum
+ fromEnum = fromEnum . vLevel
instance Bounded Verbosity where
- minBound = mkVerbosity minBound
- maxBound = mkVerbosity maxBound
+ minBound = mkVerbosity minBound
+ maxBound = mkVerbosity maxBound
instance Binary Verbosity
instance Structured Verbosity
@@ -118,21 +134,21 @@ deafening = mkVerbosity Deafening
-- | Increase verbosity level, but stay 'silent' if we are.
moreVerbose :: Verbosity -> Verbosity
moreVerbose v =
- case vLevel v of
- Silent -> v -- silent should stay silent
- Normal -> v { vLevel = Verbose }
- Verbose -> v { vLevel = Deafening }
- Deafening -> v
+ case vLevel v of
+ Silent -> v -- silent should stay silent
+ Normal -> v{vLevel = Verbose}
+ Verbose -> v{vLevel = Deafening}
+ Deafening -> v
-- | Decrease verbosity level, but stay 'deafening' if we are.
lessVerbose :: Verbosity -> Verbosity
lessVerbose v =
- verboseQuiet $
+ verboseQuiet $
case vLevel v of
- Deafening -> v -- deafening stays deafening
- Verbose -> v { vLevel = Normal }
- Normal -> v { vLevel = Silent }
- Silent -> v
+ Deafening -> v -- deafening stays deafening
+ Verbose -> v{vLevel = Normal}
+ Normal -> v{vLevel = Silent}
+ Silent -> v
-- | Combinator for transforming verbosity level while retaining the
-- original hidden state.
@@ -146,7 +162,7 @@ lessVerbose v =
--
-- @since 2.0.1.0
modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity
-modifyVerbosity f v = v { vLevel = vLevel (f v) }
+modifyVerbosity f v = v{vLevel = vLevel (f v)}
-- | Numeric verbosity level @0..3@: @0@ is 'silent', @3@ is 'deafening'.
intToVerbosity :: Int -> Maybe Verbosity
@@ -177,81 +193,82 @@ intToVerbosity _ = Nothing
-- Right (Verbosity {vLevel = Deafening, vFlags = fromList [VCallStack,VCallSite,VNoWrap,VStderr], vQuiet = False})
--
-- /Note:/ this parser will eat trailing spaces.
---
instance Parsec Verbosity where
- parsec = parsecVerbosity
+ parsec = parsecVerbosity
instance Pretty Verbosity where
- pretty = PP.text . showForCabal
+ pretty = PP.text . showForCabal
parsecVerbosity :: CabalParsing m => m Verbosity
parsecVerbosity = parseIntVerbosity <|> parseStringVerbosity
where
parseIntVerbosity = do
- i <- P.integral
- case intToVerbosity i of
- Just v -> return v
- Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3"
+ i <- P.integral
+ case intToVerbosity i of
+ Just v -> return v
+ Nothing -> P.unexpected $ "Bad integral verbosity: " ++ show i ++ ". Valid values are 0..3"
parseStringVerbosity = do
- level <- parseVerbosityLevel
- _ <- P.spaces
- flags <- many (parseFlag <* P.spaces)
- return $ foldl' (flip ($)) (mkVerbosity level) flags
+ level <- parseVerbosityLevel
+ _ <- P.spaces
+ flags <- many (parseFlag <* P.spaces)
+ return $ foldl' (flip ($)) (mkVerbosity level) flags
parseVerbosityLevel = do
- token <- P.munch1 isAsciiAlpha
- case token of
- "silent" -> return Silent
- "normal" -> return Normal
- "verbose" -> return Verbose
- "debug" -> return Deafening
- "deafening" -> return Deafening
- _ -> P.unexpected $ "Bad verbosity level: " ++ token
+ token <- P.munch1 isAsciiAlpha
+ case token of
+ "silent" -> return Silent
+ "normal" -> return Normal
+ "verbose" -> return Verbose
+ "debug" -> return Deafening
+ "deafening" -> return Deafening
+ _ -> P.unexpected $ "Bad verbosity level: " ++ token
parseFlag = do
- _ <- P.char '+'
- token <- P.munch1 isAsciiAlpha
- case token of
- "callsite" -> return verboseCallSite
- "callstack" -> return verboseCallStack
- "nowrap" -> return verboseNoWrap
- "markoutput" -> return verboseMarkOutput
- "timestamp" -> return verboseTimestamp
- "stderr" -> return verboseStderr
- "stdout" -> return verboseNoStderr
- "nowarn" -> return verboseNoWarn
- _ -> P.unexpected $ "Bad verbosity flag: " ++ token
+ _ <- P.char '+'
+ token <- P.munch1 isAsciiAlpha
+ case token of
+ "callsite" -> return verboseCallSite
+ "callstack" -> return verboseCallStack
+ "nowrap" -> return verboseNoWrap
+ "markoutput" -> return verboseMarkOutput
+ "timestamp" -> return verboseTimestamp
+ "stderr" -> return verboseStderr
+ "stdout" -> return verboseNoStderr
+ "nowarn" -> return verboseNoWarn
+ _ -> P.unexpected $ "Bad verbosity flag: " ++ token
flagToVerbosity :: ReadE Verbosity
flagToVerbosity = parsecToReadE id parsecVerbosity
showForCabal :: Verbosity -> String
showForCabal v
- | Set.null (vFlags v)
- = maybe (error "unknown verbosity") show $
- elemIndex v [silent,normal,verbose,deafening]
- | otherwise
- = unwords
- $ showLevel (vLevel v)
- : concatMap showFlag (Set.toList (vFlags v))
+ | Set.null (vFlags v) =
+ maybe (error "unknown verbosity") show $
+ elemIndex v [silent, normal, verbose, deafening]
+ | otherwise =
+ unwords $
+ showLevel (vLevel v)
+ : concatMap showFlag (Set.toList (vFlags v))
where
- showLevel Silent = "silent"
- showLevel Normal = "normal"
- showLevel Verbose = "verbose"
+ showLevel Silent = "silent"
+ showLevel Normal = "normal"
+ showLevel Verbose = "verbose"
showLevel Deafening = "debug"
- showFlag VCallSite = ["+callsite"]
- showFlag VCallStack = ["+callstack"]
- showFlag VNoWrap = ["+nowrap"]
+ showFlag VCallSite = ["+callsite"]
+ showFlag VCallStack = ["+callstack"]
+ showFlag VNoWrap = ["+nowrap"]
showFlag VMarkOutput = ["+markoutput"]
- showFlag VTimestamp = ["+timestamp"]
- showFlag VStderr = ["+stderr"]
- showFlag VNoWarn = ["+nowarn"]
+ showFlag VTimestamp = ["+timestamp"]
+ showFlag VStderr = ["+stderr"]
+ showFlag VNoWarn = ["+nowarn"]
showForGHC :: Verbosity -> String
-showForGHC v = maybe (error "unknown verbosity") show $
- elemIndex v [silent,normal,__,verbose,deafening]
- where __ = silent -- this will be always ignored by elemIndex
+showForGHC v =
+ maybe (error "unknown verbosity") show $
+ elemIndex v [silent, normal, __, verbose, deafening]
+ where
+ __ = silent -- this will be always ignored by elemIndex
-- | Turn on verbose call-site printing when we log.
verboseCallSite :: Verbosity -> Verbosity
@@ -276,7 +293,7 @@ verboseNoWrap = verboseFlag VNoWrap
-- | Mark the verbosity as quiet.
verboseQuiet :: Verbosity -> Verbosity
-verboseQuiet v = v { vQuiet = True }
+verboseQuiet v = v{vQuiet = True}
-- | Turn on timestamps for log messages.
verboseTimestamp :: Verbosity -> Verbosity
@@ -304,15 +321,15 @@ verboseNoWarn = verboseFlag VNoWarn
-- | Helper function for flag enabling functions.
verboseFlag :: VerbosityFlag -> (Verbosity -> Verbosity)
-verboseFlag flag v = v { vFlags = Set.insert flag (vFlags v) }
+verboseFlag flag v = v{vFlags = Set.insert flag (vFlags v)}
-- | Helper function for flag disabling functions.
verboseNoFlag :: VerbosityFlag -> (Verbosity -> Verbosity)
-verboseNoFlag flag v = v { vFlags = Set.delete flag (vFlags v) }
+verboseNoFlag flag v = v{vFlags = Set.delete flag (vFlags v)}
-- | Turn off all flags.
verboseNoFlags :: Verbosity -> Verbosity
-verboseNoFlags v = v { vFlags = Set.empty }
+verboseNoFlags v = v{vFlags = Set.empty}
verboseHasFlags :: Verbosity -> Bool
verboseHasFlags = not . Set.null . vFlags
diff --git a/Cabal/src/Distribution/Verbosity/Internal.hs b/Cabal/src/Distribution/Verbosity/Internal.hs
index 21a4e6932c291ea477da9a7349dc7d01d28a5f36..b8f55cf5b98e1323dd50e784069ffedc74caa65e 100644
--- a/Cabal/src/Distribution/Verbosity/Internal.hs
+++ b/Cabal/src/Distribution/Verbosity/Internal.hs
@@ -1,28 +1,30 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Verbosity.Internal
- ( VerbosityLevel(..)
- , VerbosityFlag(..)
+ ( VerbosityLevel (..)
+ , VerbosityFlag (..)
) where
-import Prelude ()
import Distribution.Compat.Prelude
+import Prelude ()
data VerbosityLevel = Silent | Normal | Verbose | Deafening
- deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)
+ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)
instance Binary VerbosityLevel
instance Structured VerbosityLevel
data VerbosityFlag
- = VCallStack
- | VCallSite
- | VNoWrap
- | VMarkOutput
- | VTimestamp
- | VStderr -- ^ @since 3.4.0.0
- | VNoWarn
- deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)
+ = VCallStack
+ | VCallSite
+ | VNoWrap
+ | VMarkOutput
+ | VTimestamp
+ | -- | @since 3.4.0.0
+ VStderr
+ | VNoWarn
+ deriving (Generic, Show, Read, Eq, Ord, Enum, Bounded, Typeable)
instance Binary VerbosityFlag
instance Structured VerbosityFlag
diff --git a/Cabal/src/Distribution/ZinzaPrelude.hs b/Cabal/src/Distribution/ZinzaPrelude.hs
index 61e8295617b0b816db8b87a126842c722223be95..bc1d0ed6a709faf5b93f9806194dbca52e21af16 100644
--- a/Cabal/src/Distribution/ZinzaPrelude.hs
+++ b/Cabal/src/Distribution/ZinzaPrelude.hs
@@ -1,40 +1,41 @@
-- | A small prelude used in @zinza@ generated
-- template modules.
-module Distribution.ZinzaPrelude (
- Writer,
- execWriter,
- tell,
+module Distribution.ZinzaPrelude
+ ( Writer
+ , execWriter
+ , tell
+
-- * Re-exports
- forM_,
- Generic,
- PackageName,
- Version,
- prettyShow
- ) where
+ , forM_
+ , Generic
+ , PackageName
+ , Version
+ , prettyShow
+ ) where
import Distribution.Compat.Prelude
import Prelude ()
-import Control.Monad (forM_)
-import Distribution.Pretty (prettyShow)
+import Control.Monad (forM_)
+import Distribution.Pretty (prettyShow)
import Distribution.Types.PackageName (PackageName)
-import Distribution.Types.Version (Version)
+import Distribution.Types.Version (Version)
-newtype Writer a = W { unW :: ShowS -> (ShowS, a) }
+newtype Writer a = W {unW :: ShowS -> (ShowS, a)}
instance Functor Writer where
- fmap = liftM
+ fmap = liftM
instance Applicative Writer where
- pure x = W $ \ss -> (ss, x)
- (<*>) = ap
+ pure x = W $ \ss -> (ss, x)
+ (<*>) = ap
instance Monad Writer where
- return = pure
- m >>= k = W $ \s1 ->
- let (s2, x) = unW m s1
- in unW (k x) s2
- {-# INLINE (>>=) #-}
+ return = pure
+ m >>= k = W $ \s1 ->
+ let (s2, x) = unW m s1
+ in unW (k x) s2
+ {-# INLINE (>>=) #-}
execWriter :: Writer a -> String
execWriter w = fst (unW w id) ""
diff --git a/cabal-install/Setup.hs b/cabal-install/Setup.hs
index b55cb1695392fd9cdb3d8e148e455bc4cfbeb3e2..00bfe1fe44155953e866958b155c10612bb88a76 100644
--- a/cabal-install/Setup.hs
+++ b/cabal-install/Setup.hs
@@ -1,3 +1,4 @@
import Distribution.Simple
+
main :: IO ()
main = defaultMain
diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs
index 56898bd8be292b1f5046c0bfdf4f7d843d7db088..767da7d011884bcad3d2dd687d8c52c7c9c95c17 100644
--- a/cabal-install/main/Main.hs
+++ b/cabal-install/main/Main.hs
@@ -1,7 +1,7 @@
module Main (main) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import System.Environment (getArgs)
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs
index 6e483e2f8156884bfe1b35533b45dd7f42a1832c..ce1d1665327fde7154bd18eccfb76b82dc70cfbd 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Anonymous.hs
@@ -1,6 +1,10 @@
-{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE OverloadedStrings #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Reporting
-- Copyright : (c) David Waern 2008
@@ -11,22 +15,20 @@
-- Portability : portable
--
-- Anonymous build report data structure, printing and parsing
---
------------------------------------------------------------------------------
-module Distribution.Client.BuildReports.Anonymous (
- BuildReport(..),
- InstallOutcome(..),
- Outcome(..),
+module Distribution.Client.BuildReports.Anonymous
+ ( BuildReport (..)
+ , InstallOutcome (..)
+ , Outcome (..)
-- * Constructing and writing reports
- newBuildReport,
+ , newBuildReport
-- * parsing and pretty printing
- parseBuildReport,
- parseBuildReportList,
- showBuildReport,
- cabalInstallID
--- showList,
+ , parseBuildReport
+ , parseBuildReportList
+ , showBuildReport
+ , cabalInstallID
+ -- showList,
) where
import Distribution.Client.Compat.Prelude
@@ -34,64 +36,70 @@ import Prelude ()
import Distribution.CabalSpecVersion
import Distribution.Client.BuildReports.Types
-import Distribution.Client.Version (cabalInstallVersion)
-import Distribution.Compiler (CompilerId (..))
+import Distribution.Client.Version (cabalInstallVersion)
+import Distribution.Compiler (CompilerId (..))
import Distribution.FieldGrammar
import Distribution.Fields
-import Distribution.Package (PackageIdentifier (..), mkPackageName)
-import Distribution.PackageDescription (FlagAssignment)
+import Distribution.Package (PackageIdentifier (..), mkPackageName)
+import Distribution.PackageDescription (FlagAssignment)
import Distribution.Parsec
-import Distribution.System (Arch, OS)
+import Distribution.System (Arch, OS)
import qualified Distribution.Client.BuildReports.Lens as L
-import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))
+import qualified Distribution.Client.Types as BR (BuildFailure (..), BuildOutcome, BuildResult (..), DocsResult (..), TestsResult (..))
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
-
-------------------------------------------------------------------------------
-- New
-------------------------------------------------------------------------------
-newBuildReport :: OS -> Arch -> CompilerId -> PackageIdentifier -> FlagAssignment
- -> [PackageIdentifier] -> BR.BuildOutcome -> BuildReport
+newBuildReport
+ :: OS
+ -> Arch
+ -> CompilerId
+ -> PackageIdentifier
+ -> FlagAssignment
+ -> [PackageIdentifier]
+ -> BR.BuildOutcome
+ -> BuildReport
newBuildReport os' arch' comp pkgid flags deps result =
- BuildReport {
- package = pkgid,
- os = os',
- arch = arch',
- compiler = comp,
- client = cabalInstallID,
- flagAssignment = flags,
- dependencies = deps,
- installOutcome = convertInstallOutcome,
--- cabalVersion = undefined
- docsOutcome = convertDocsOutcome,
- testsOutcome = convertTestsOutcome
- }
+ BuildReport
+ { package = pkgid
+ , os = os'
+ , arch = arch'
+ , compiler = comp
+ , client = cabalInstallID
+ , flagAssignment = flags
+ , dependencies = deps
+ , installOutcome = convertInstallOutcome
+ , -- cabalVersion = undefined
+ docsOutcome = convertDocsOutcome
+ , testsOutcome = convertTestsOutcome
+ }
where
convertInstallOutcome = case result of
- Left BR.PlanningFailed -> PlanningFailed
- Left (BR.GracefulFailure _) -> PlanningFailed
- Left (BR.DependentFailed p) -> DependencyFailed p
- Left (BR.DownloadFailed _) -> DownloadFailed
- Left (BR.UnpackFailed _) -> UnpackFailed
- Left (BR.ConfigureFailed _) -> ConfigureFailed
- Left (BR.BuildFailed _) -> BuildFailed
- Left (BR.TestsFailed _) -> TestsFailed
- Left (BR.InstallFailed _) -> InstallFailed
+ Left BR.PlanningFailed -> PlanningFailed
+ Left (BR.GracefulFailure _) -> PlanningFailed
+ Left (BR.DependentFailed p) -> DependencyFailed p
+ Left (BR.DownloadFailed _) -> DownloadFailed
+ Left (BR.UnpackFailed _) -> UnpackFailed
+ Left (BR.ConfigureFailed _) -> ConfigureFailed
+ Left (BR.BuildFailed _) -> BuildFailed
+ Left (BR.TestsFailed _) -> TestsFailed
+ Left (BR.InstallFailed _) -> InstallFailed
Right (BR.BuildResult _ _ _) -> InstallOk
convertDocsOutcome = case result of
- Left _ -> NotTried
- Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried
- Right (BR.BuildResult BR.DocsFailed _ _) -> Failed
- Right (BR.BuildResult BR.DocsOk _ _) -> Ok
+ Left _ -> NotTried
+ Right (BR.BuildResult BR.DocsNotTried _ _) -> NotTried
+ Right (BR.BuildResult BR.DocsFailed _ _) -> Failed
+ Right (BR.BuildResult BR.DocsOk _ _) -> Ok
convertTestsOutcome = case result of
- Left (BR.TestsFailed _) -> Failed
- Left _ -> NotTried
+ Left (BR.TestsFailed _) -> Failed
+ Left _ -> NotTried
Right (BR.BuildResult _ BR.TestsNotTried _) -> NotTried
- Right (BR.BuildResult _ BR.TestsOk _) -> Ok
+ Right (BR.BuildResult _ BR.TestsOk _) -> Ok
cabalInstallID :: PackageIdentifier
cabalInstallID =
@@ -102,35 +110,37 @@ cabalInstallID =
-------------------------------------------------------------------------------
fieldDescrs
- :: ( Applicative (g BuildReport), FieldGrammar c g
- , c (Identity Arch)
- , c (Identity CompilerId)
- , c (Identity FlagAssignment)
- , c (Identity InstallOutcome)
- , c (Identity OS)
- , c (Identity Outcome)
- , c (Identity PackageIdentifier)
- , c (List VCat (Identity PackageIdentifier) PackageIdentifier)
- )
- => g BuildReport BuildReport
-fieldDescrs = BuildReport
- <$> uniqueField "package" L.package
- <*> uniqueField "os" L.os
- <*> uniqueField "arch" L.arch
- <*> uniqueField "compiler" L.compiler
- <*> uniqueField "client" L.client
- <*> monoidalField "flags" L.flagAssignment
- <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
- <*> uniqueField "install-outcome" L.installOutcome
- <*> uniqueField "docs-outcome" L.docsOutcome
- <*> uniqueField "tests-outcome" L.testsOutcome
+ :: ( Applicative (g BuildReport)
+ , FieldGrammar c g
+ , c (Identity Arch)
+ , c (Identity CompilerId)
+ , c (Identity FlagAssignment)
+ , c (Identity InstallOutcome)
+ , c (Identity OS)
+ , c (Identity Outcome)
+ , c (Identity PackageIdentifier)
+ , c (List VCat (Identity PackageIdentifier) PackageIdentifier)
+ )
+ => g BuildReport BuildReport
+fieldDescrs =
+ BuildReport
+ <$> uniqueField "package" L.package
+ <*> uniqueField "os" L.os
+ <*> uniqueField "arch" L.arch
+ <*> uniqueField "compiler" L.compiler
+ <*> uniqueField "client" L.client
+ <*> monoidalField "flags" L.flagAssignment
+ <*> monoidalFieldAla "dependencies" (alaList VCat) L.dependencies
+ <*> uniqueField "install-outcome" L.installOutcome
+ <*> uniqueField "docs-outcome" L.docsOutcome
+ <*> uniqueField "tests-outcome" L.testsOutcome
-- -----------------------------------------------------------------------------
-- Parsing
parseBuildReport :: BS.ByteString -> Either String BuildReport
parseBuildReport s = case snd $ runParseResult $ parseFields s of
- Left (_, perrors) -> Left $ unlines [ err | PError _ err <- toList perrors ]
+ Left (_, perrors) -> Left $ unlines [err | PError _ err <- toList perrors]
Right report -> Right report
parseFields :: BS.ByteString -> ParseResult BuildReport
@@ -138,18 +148,17 @@ parseFields input = do
fields <- either (parseFatalFailure zeroPos . show) pure $ readFields input
case partitionFields fields of
(fields', []) -> parseFieldGrammar CabalSpecV2_4 fields' fieldDescrs
- _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport"
+ _otherwise -> parseFatalFailure zeroPos "found sections in BuildReport"
parseBuildReportList :: BS.ByteString -> [BuildReport]
parseBuildReportList str =
- [ report | Right report <- map parseBuildReport (split str) ]
-
+ [report | Right report <- map parseBuildReport (split str)]
where
split :: BS.ByteString -> [BS.ByteString]
split = filter (not . BS.null) . unfoldr chunk . BS8.lines
chunk [] = Nothing
chunk ls = case break BS.null ls of
- (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)
+ (r, rs) -> Just (BS8.unlines r, dropWhile BS.null rs)
-- -----------------------------------------------------------------------------
-- Pretty-printing
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Lens.hs b/cabal-install/src/Distribution/Client/BuildReports/Lens.hs
index ca38c46341528761a680c0a82330380a0a850190..bbf7216ee61133ed67563bccb637e5f76298357d 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Lens.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Lens.hs
@@ -1,46 +1,46 @@
-module Distribution.Client.BuildReports.Lens (
- BuildReport,
- module Distribution.Client.BuildReports.Lens,
-) where
+module Distribution.Client.BuildReports.Lens
+ ( BuildReport
+ , module Distribution.Client.BuildReports.Lens
+ ) where
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Lens
import Prelude ()
import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome)
-import Distribution.Compiler (CompilerId)
-import Distribution.System (Arch, OS)
-import Distribution.Types.Flag (FlagAssignment)
-import Distribution.Types.PackageId (PackageIdentifier)
+import Distribution.Compiler (CompilerId)
+import Distribution.System (Arch, OS)
+import Distribution.Types.Flag (FlagAssignment)
+import Distribution.Types.PackageId (PackageIdentifier)
import qualified Distribution.Client.BuildReports.Types as T
package :: Lens' BuildReport PackageIdentifier
-package f s = fmap (\x -> s { T.package = x }) (f (T.package s))
+package f s = fmap (\x -> s{T.package = x}) (f (T.package s))
os :: Lens' BuildReport OS
-os f s = fmap (\x -> s { T.os = x }) (f (T.os s))
+os f s = fmap (\x -> s{T.os = x}) (f (T.os s))
arch :: Lens' BuildReport Arch
-arch f s = fmap (\x -> s { T.arch = x }) (f (T.arch s))
+arch f s = fmap (\x -> s{T.arch = x}) (f (T.arch s))
compiler :: Lens' BuildReport CompilerId
-compiler f s = fmap (\x -> s { T.compiler = x }) (f (T.compiler s))
+compiler f s = fmap (\x -> s{T.compiler = x}) (f (T.compiler s))
client :: Lens' BuildReport PackageIdentifier
-client f s = fmap (\x -> s { T.client = x }) (f (T.client s))
+client f s = fmap (\x -> s{T.client = x}) (f (T.client s))
flagAssignment :: Lens' BuildReport FlagAssignment
-flagAssignment f s = fmap (\x -> s { T.flagAssignment = x }) (f (T.flagAssignment s))
+flagAssignment f s = fmap (\x -> s{T.flagAssignment = x}) (f (T.flagAssignment s))
dependencies :: Lens' BuildReport [PackageIdentifier]
-dependencies f s = fmap (\x -> s { T.dependencies = x }) (f (T.dependencies s))
+dependencies f s = fmap (\x -> s{T.dependencies = x}) (f (T.dependencies s))
installOutcome :: Lens' BuildReport InstallOutcome
-installOutcome f s = fmap (\x -> s { T.installOutcome = x }) (f (T.installOutcome s))
+installOutcome f s = fmap (\x -> s{T.installOutcome = x}) (f (T.installOutcome s))
docsOutcome :: Lens' BuildReport Outcome
-docsOutcome f s = fmap (\x -> s { T.docsOutcome = x }) (f (T.docsOutcome s))
+docsOutcome f s = fmap (\x -> s{T.docsOutcome = x}) (f (T.docsOutcome s))
testsOutcome :: Lens' BuildReport Outcome
-testsOutcome f s = fmap (\x -> s { T.testsOutcome = x }) (f (T.testsOutcome s))
+testsOutcome f s = fmap (\x -> s{T.testsOutcome = x}) (f (T.testsOutcome s))
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs
index a20f8697259b0a9607af58466b2c930362ce7c7b..34f2c38003549b3017e776c1f63f1e4341d5b838 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Storage.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Storage.hs
@@ -1,5 +1,9 @@
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Reporting
-- Copyright : (c) David Waern 2008
@@ -10,154 +14,204 @@
-- Portability : portable
--
-- Anonymous build report data structure, printing and parsing
---
------------------------------------------------------------------------------
-module Distribution.Client.BuildReports.Storage (
-
- -- * Storing and retrieving build reports
- storeAnonymous,
- storeLocal,
--- retrieve,
+module Distribution.Client.BuildReports.Storage
+ ( -- * Storing and retrieving build reports
+ storeAnonymous
+ , storeLocal
+ -- retrieve,
-- * 'InstallPlan' support
- fromInstallPlan,
- fromPlanningFailure,
+ , fromInstallPlan
+ , fromPlanningFailure
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport, newBuildReport)
+import Distribution.Client.BuildReports.Anonymous (BuildReport, newBuildReport, showBuildReport)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
-import Distribution.Client.Types
-import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan
- ( InstallPlan )
+ ( InstallPlan
+ )
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.Types
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.SourcePackage
+import Distribution.Compiler
+ ( CompilerId (..)
+ , CompilerInfo (..)
+ )
import Distribution.Package
- ( PackageId, packageId )
+ ( PackageId
+ , packageId
+ )
import Distribution.PackageDescription
- ( FlagAssignment )
+ ( FlagAssignment
+ )
import Distribution.Simple.InstallDirs
- ( PathTemplate, fromPathTemplate
- , initialPathTemplateEnv, substPathTemplate )
-import Distribution.System
- ( Platform(Platform) )
-import Distribution.Compiler
- ( CompilerId(..), CompilerInfo(..) )
+ ( PathTemplate
+ , fromPathTemplate
+ , initialPathTemplateEnv
+ , substPathTemplate
+ )
import Distribution.Simple.Utils
- ( equating )
+ ( equating
+ )
+import Distribution.System
+ ( Platform (Platform)
+ )
-import Data.List.NonEmpty
- ( groupBy )
import qualified Data.List as L
-import System.FilePath
- ( (</>), takeDirectory )
+import Data.List.NonEmpty
+ ( groupBy
+ )
import System.Directory
- ( createDirectoryIfMissing )
+ ( createDirectoryIfMissing
+ )
+import System.FilePath
+ ( takeDirectory
+ , (</>)
+ )
storeAnonymous :: [(BuildReport, Maybe Repo)] -> IO ()
-storeAnonymous reports = sequence_
- [ appendFile file (concatMap format reports')
- | (repo, reports') <- separate reports
- , let file = repoLocalDir repo </> "build-reports.log" ]
- --TODO: make this concurrency safe, either lock the report file or make sure
- -- the writes for each report are atomic (under 4k and flush at boundaries)
-
+storeAnonymous reports =
+ sequence_
+ [ appendFile file (concatMap format reports')
+ | (repo, reports') <- separate reports
+ , let file = repoLocalDir repo </> "build-reports.log"
+ ]
where
+ -- TODO: make this concurrency safe, either lock the report file or make sure
+ -- the writes for each report are atomic (under 4k and flush at boundaries)
+
format r = '\n' : showBuildReport r ++ "\n"
- separate :: [(BuildReport, Maybe Repo)]
- -> [(Repo, [BuildReport])]
- separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
- . map (concatMap toList)
- . L.groupBy (equating (repoName' . head))
- . sortBy (comparing (repoName' . head))
- . groupBy (equating repoName')
- . onlyRemote
-
- repoName' (_,_,rrepo) = remoteRepoName rrepo
-
- onlyRemote :: [(BuildReport, Maybe Repo)]
- -> [(BuildReport, Repo, RemoteRepo)]
+ separate
+ :: [(BuildReport, Maybe Repo)]
+ -> [(Repo, [BuildReport])]
+ separate =
+ map (\rs@((_, repo, _) : _) -> (repo, [r | (r, _, _) <- rs]))
+ . map (concatMap toList)
+ . L.groupBy (equating (repoName' . head))
+ . sortBy (comparing (repoName' . head))
+ . groupBy (equating repoName')
+ . onlyRemote
+
+ repoName' (_, _, rrepo) = remoteRepoName rrepo
+
+ onlyRemote
+ :: [(BuildReport, Maybe Repo)]
+ -> [(BuildReport, Repo, RemoteRepo)]
onlyRemote rs =
[ (report, repo, remoteRepo)
| (report, Just repo) <- rs
- , Just remoteRepo <- [maybeRepoRemote repo]
+ , Just remoteRepo <- [maybeRepoRemote repo]
]
-storeLocal :: CompilerInfo -> [PathTemplate] -> [(BuildReport, Maybe Repo)]
- -> Platform -> IO ()
-storeLocal cinfo templates reports platform = sequence_
- [ do createDirectoryIfMissing True (takeDirectory file)
- appendFile file output
- --TODO: make this concurrency safe, either lock the report file or make
- -- sure the writes for each report are atomic
- | (file, reports') <- groupByFileName
- [ (reportFileName template report, report)
- | template <- templates
- , (report, _repo) <- reports ]
- , let output = concatMap format reports'
- ]
+storeLocal
+ :: CompilerInfo
+ -> [PathTemplate]
+ -> [(BuildReport, Maybe Repo)]
+ -> Platform
+ -> IO ()
+storeLocal cinfo templates reports platform =
+ sequence_
+ [ do
+ createDirectoryIfMissing True (takeDirectory file)
+ appendFile file output
+ | -- TODO: make this concurrency safe, either lock the report file or make
+ -- sure the writes for each report are atomic
+ (file, reports') <-
+ groupByFileName
+ [ (reportFileName template report, report)
+ | template <- templates
+ , (report, _repo) <- reports
+ ]
+ , let output = concatMap format reports'
+ ]
where
format r = '\n' : showBuildReport r ++ "\n"
reportFileName template report =
- fromPathTemplate (substPathTemplate env template)
- where env = initialPathTemplateEnv
- (BuildReport.package report)
- -- TODO: In principle, we can support $pkgkey, but only
- -- if the configure step succeeds. So add a Maybe field
- -- to the build report, and either use that or make up
- -- a fake identifier if it's not available.
- (error "storeLocal: package key not available")
- cinfo
- platform
-
- groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))
- . L.groupBy (equating fst)
- . sortBy (comparing fst)
+ fromPathTemplate (substPathTemplate env template)
+ where
+ env =
+ initialPathTemplateEnv
+ (BuildReport.package report)
+ -- TODO: In principle, we can support $pkgkey, but only
+ -- if the configure step succeeds. So add a Maybe field
+ -- to the build report, and either use that or make up
+ -- a fake identifier if it's not available.
+ (error "storeLocal: package key not available")
+ cinfo
+ platform
+
+ groupByFileName =
+ map (\grp@((filename, _) : _) -> (filename, map snd grp))
+ . L.groupBy (equating fst)
+ . sortBy (comparing fst)
-- ------------------------------------------------------------
+
-- * InstallPlan support
+
-- ------------------------------------------------------------
-fromInstallPlan :: Platform -> CompilerId
- -> InstallPlan
- -> BuildOutcomes
- -> [(BuildReport, Maybe Repo)]
+fromInstallPlan
+ :: Platform
+ -> CompilerId
+ -> InstallPlan
+ -> BuildOutcomes
+ -> [(BuildReport, Maybe Repo)]
fromInstallPlan platform comp plan buildOutcomes =
- mapMaybe (\pkg -> fromPlanPackage
- platform comp pkg
- (InstallPlan.lookupBuildOutcome pkg buildOutcomes))
- . InstallPlan.toList
- $ plan
-
-fromPlanPackage :: Platform -> CompilerId
- -> InstallPlan.PlanPackage
- -> Maybe BuildOutcome
- -> Maybe (BuildReport, Maybe Repo)
-fromPlanPackage (Platform arch os) comp
- (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))
- (Just buildResult) =
- Just ( newBuildReport os arch comp
- (packageId srcPkg) flags
- (map packageId (CD.nonSetupDeps deps))
- buildResult
- , extractRepo srcPkg)
- where
- extractRepo (SourcePackage { srcpkgSource = RepoTarballPackage repo _ _ })
- = Just repo
- extractRepo _ = Nothing
-
+ mapMaybe
+ ( \pkg ->
+ fromPlanPackage
+ platform
+ comp
+ pkg
+ (InstallPlan.lookupBuildOutcome pkg buildOutcomes)
+ )
+ . InstallPlan.toList
+ $ plan
+
+fromPlanPackage
+ :: Platform
+ -> CompilerId
+ -> InstallPlan.PlanPackage
+ -> Maybe BuildOutcome
+ -> Maybe (BuildReport, Maybe Repo)
+fromPlanPackage
+ (Platform arch os)
+ comp
+ (InstallPlan.Configured (ConfiguredPackage _ srcPkg flags _ deps))
+ (Just buildResult) =
+ Just
+ ( newBuildReport
+ os
+ arch
+ comp
+ (packageId srcPkg)
+ flags
+ (map packageId (CD.nonSetupDeps deps))
+ buildResult
+ , extractRepo srcPkg
+ )
+ where
+ extractRepo (SourcePackage{srcpkgSource = RepoTarballPackage repo _ _}) =
+ Just repo
+ extractRepo _ = Nothing
fromPlanPackage _ _ _ _ = Nothing
-
-fromPlanningFailure :: Platform -> CompilerId
- -> [PackageId] -> FlagAssignment -> [(BuildReport, Maybe Repo)]
+fromPlanningFailure
+ :: Platform
+ -> CompilerId
+ -> [PackageId]
+ -> FlagAssignment
+ -> [(BuildReport, Maybe Repo)]
fromPlanningFailure (Platform arch os) comp pkgids flags =
[ (newBuildReport os arch comp pkgid flags [] (Left PlanningFailed), Nothing)
- | pkgid <- pkgids ]
+ | pkgid <- pkgids
+ ]
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Types.hs b/cabal-install/src/Distribution/Client/BuildReports/Types.hs
index dc5b8e2ce1b1722de28cf2e50b8d8df3e65f44f9..576d058c4bfc03871595dada381ebdbe4a4649b3 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Types.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Types.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE DeriveGeneric #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.BuildReports.Types
-- Copyright : (c) Duncan Coutts 2009
@@ -9,25 +13,23 @@
-- Portability : portable
--
-- Types related to build reporting
---
------------------------------------------------------------------------------
-module Distribution.Client.BuildReports.Types (
- ReportLevel(..),
- BuildReport (..),
- InstallOutcome(..),
- Outcome(..),
-) where
+module Distribution.Client.BuildReports.Types
+ ( ReportLevel (..)
+ , BuildReport (..)
+ , InstallOutcome (..)
+ , Outcome (..)
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-import Distribution.Compiler (CompilerId (..))
+import Distribution.Compiler (CompilerId (..))
import Distribution.PackageDescription (FlagAssignment)
-import Distribution.System (Arch, OS)
-import Distribution.Types.PackageId (PackageIdentifier)
+import Distribution.System (Arch, OS)
+import Distribution.Types.PackageId (PackageIdentifier)
-------------------------------------------------------------------------------
-- ReportLevel
@@ -40,18 +42,18 @@ instance Binary ReportLevel
instance Structured ReportLevel
instance Pretty ReportLevel where
- pretty NoReports = Disp.text "none"
+ pretty NoReports = Disp.text "none"
pretty AnonymousReports = Disp.text "anonymous"
- pretty DetailedReports = Disp.text "detailed"
+ pretty DetailedReports = Disp.text "detailed"
instance Parsec ReportLevel where
parsec = do
name <- P.munch1 isAlpha
case lowercase name of
- "none" -> return NoReports
- "anonymous" -> return AnonymousReports
- "detailed" -> return DetailedReports
- _ -> P.unexpected $ "ReportLevel: " ++ name
+ "none" -> return NoReports
+ "anonymous" -> return AnonymousReports
+ "detailed" -> return DetailedReports
+ _ -> P.unexpected $ "ReportLevel: " ++ name
lowercase :: String -> String
lowercase = map toLower
@@ -60,89 +62,79 @@ lowercase = map toLower
-- BuildReport
-------------------------------------------------------------------------------
-data BuildReport = BuildReport {
- -- | The package this build report is about
- package :: PackageIdentifier,
-
- -- | The OS and Arch the package was built on
- os :: OS,
- arch :: Arch,
-
- -- | The Haskell compiler (and hopefully version) used
- compiler :: CompilerId,
-
- -- | The uploading client, ie cabal-install-x.y.z
- client :: PackageIdentifier,
-
- -- | Which configurations flags we used
- flagAssignment :: FlagAssignment,
-
- -- | Which dependent packages we were using exactly
- dependencies :: [PackageIdentifier],
-
- -- | Did installing work ok?
- installOutcome :: InstallOutcome,
-
- -- Which version of the Cabal library was used to compile the Setup.hs
--- cabalVersion :: Version,
+data BuildReport = BuildReport
+ { package :: PackageIdentifier
+ -- ^ The package this build report is about
+ , os :: OS
+ -- ^ The OS and Arch the package was built on
+ , arch :: Arch
+ , compiler :: CompilerId
+ -- ^ The Haskell compiler (and hopefully version) used
+ , client :: PackageIdentifier
+ -- ^ The uploading client, ie cabal-install-x.y.z
+ , flagAssignment :: FlagAssignment
+ -- ^ Which configurations flags we used
+ , dependencies :: [PackageIdentifier]
+ -- ^ Which dependent packages we were using exactly
+ , installOutcome :: InstallOutcome
+ -- ^ Did installing work ok?
+ , -- Which version of the Cabal library was used to compile the Setup.hs
+ -- cabalVersion :: Version,
-- Which build tools we were using (with versions)
--- tools :: [PackageIdentifier],
-
- -- | Configure outcome, did configure work ok?
- docsOutcome :: Outcome,
+ -- tools :: [PackageIdentifier],
- -- | Configure outcome, did configure work ok?
- testsOutcome :: Outcome
+ docsOutcome :: Outcome
+ -- ^ Configure outcome, did configure work ok?
+ , testsOutcome :: Outcome
+ -- ^ Configure outcome, did configure work ok?
}
deriving (Eq, Show, Generic)
-
-
-------------------------------------------------------------------------------
-- InstallOutcome
-------------------------------------------------------------------------------
data InstallOutcome
- = PlanningFailed
- | DependencyFailed PackageIdentifier
- | DownloadFailed
- | UnpackFailed
- | SetupFailed
- | ConfigureFailed
- | BuildFailed
- | TestsFailed
- | InstallFailed
- | InstallOk
+ = PlanningFailed
+ | DependencyFailed PackageIdentifier
+ | DownloadFailed
+ | UnpackFailed
+ | SetupFailed
+ | ConfigureFailed
+ | BuildFailed
+ | TestsFailed
+ | InstallFailed
+ | InstallOk
deriving (Eq, Show, Generic)
instance Pretty InstallOutcome where
- pretty PlanningFailed = Disp.text "PlanningFailed"
+ pretty PlanningFailed = Disp.text "PlanningFailed"
pretty (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> pretty pkgid
- pretty DownloadFailed = Disp.text "DownloadFailed"
- pretty UnpackFailed = Disp.text "UnpackFailed"
- pretty SetupFailed = Disp.text "SetupFailed"
+ pretty DownloadFailed = Disp.text "DownloadFailed"
+ pretty UnpackFailed = Disp.text "UnpackFailed"
+ pretty SetupFailed = Disp.text "SetupFailed"
pretty ConfigureFailed = Disp.text "ConfigureFailed"
- pretty BuildFailed = Disp.text "BuildFailed"
- pretty TestsFailed = Disp.text "TestsFailed"
- pretty InstallFailed = Disp.text "InstallFailed"
- pretty InstallOk = Disp.text "InstallOk"
+ pretty BuildFailed = Disp.text "BuildFailed"
+ pretty TestsFailed = Disp.text "TestsFailed"
+ pretty InstallFailed = Disp.text "InstallFailed"
+ pretty InstallOk = Disp.text "InstallOk"
instance Parsec InstallOutcome where
parsec = do
name <- P.munch1 isAlpha
case name of
- "PlanningFailed" -> return PlanningFailed
+ "PlanningFailed" -> return PlanningFailed
"DependencyFailed" -> DependencyFailed <$ P.spaces <*> parsec
- "DownloadFailed" -> return DownloadFailed
- "UnpackFailed" -> return UnpackFailed
- "SetupFailed" -> return SetupFailed
- "ConfigureFailed" -> return ConfigureFailed
- "BuildFailed" -> return BuildFailed
- "TestsFailed" -> return TestsFailed
- "InstallFailed" -> return InstallFailed
- "InstallOk" -> return InstallOk
- _ -> P.unexpected $ "InstallOutcome: " ++ name
+ "DownloadFailed" -> return DownloadFailed
+ "UnpackFailed" -> return UnpackFailed
+ "SetupFailed" -> return SetupFailed
+ "ConfigureFailed" -> return ConfigureFailed
+ "BuildFailed" -> return BuildFailed
+ "TestsFailed" -> return TestsFailed
+ "InstallFailed" -> return InstallFailed
+ "InstallOk" -> return InstallOk
+ _ -> P.unexpected $ "InstallOutcome: " ++ name
-------------------------------------------------------------------------------
-- Outcome
@@ -153,14 +145,14 @@ data Outcome = NotTried | Failed | Ok
instance Pretty Outcome where
pretty NotTried = Disp.text "NotTried"
- pretty Failed = Disp.text "Failed"
- pretty Ok = Disp.text "Ok"
+ pretty Failed = Disp.text "Failed"
+ pretty Ok = Disp.text "Ok"
instance Parsec Outcome where
parsec = do
name <- P.munch1 isAlpha
case name of
"NotTried" -> return NotTried
- "Failed" -> return Failed
- "Ok" -> return Ok
- _ -> P.unexpected $ "Outcome: " ++ name
+ "Failed" -> return Failed
+ "Ok" -> return Ok
+ _ -> P.unexpected $ "Outcome: " ++ name
diff --git a/cabal-install/src/Distribution/Client/BuildReports/Upload.hs b/cabal-install/src/Distribution/Client/BuildReports/Upload.hs
index 28ca9353882c6ba45a78d953ea58711223b07bab..d7ce5d0e7bc49c228a4ab170681d72b6fda3ab41 100644
--- a/cabal-install/src/Distribution/Client/BuildReports/Upload.hs
+++ b/cabal-install/src/Distribution/Client/BuildReports/Upload.hs
@@ -1,11 +1,13 @@
-{-# LANGUAGE CPP, PatternGuards #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PatternGuards #-}
+
-- This is a quick hack for uploading build reports to Hackage.
module Distribution.Client.BuildReports.Upload
- ( BuildLog
- , BuildReportId
- , uploadReports
- ) where
+ ( BuildLog
+ , BuildReportId
+ , uploadReports
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
@@ -18,16 +20,18 @@ import Network.HTTP
, Request(..), RequestMethod(..), Response(..) )
import Network.TCP (HandleStream)
-}
-import Network.URI (URI, uriPath) --parseRelativeReference, relativeTo)
+import Network.URI (URI, uriPath) -- parseRelativeReference, relativeTo)
-import System.FilePath.Posix
- ( (</>) )
-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (BuildReport, showBuildReport)
-import Distribution.Simple.Utils (die')
+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.HttpUtils
import Distribution.Client.Setup
- ( RepoContext(..) )
+ ( RepoContext (..)
+ )
+import Distribution.Simple.Utils (die')
+import System.FilePath.Posix
+ ( (</>)
+ )
type BuildReportId = URI
type BuildLog = String
@@ -35,20 +39,21 @@ type BuildLog = String
uploadReports :: Verbosity -> RepoContext -> (String, String) -> URI -> [(BuildReport, Maybe BuildLog)] -> IO ()
uploadReports verbosity repoCtxt auth uri reports = do
for_ reports $ \(report, mbBuildLog) -> do
- buildId <- postBuildReport verbosity repoCtxt auth uri report
- case mbBuildLog of
- Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog
- Nothing -> return ()
+ buildId <- postBuildReport verbosity repoCtxt auth uri report
+ case mbBuildLog of
+ Just buildLog -> putBuildLog verbosity repoCtxt auth buildId buildLog
+ Nothing -> return ()
postBuildReport :: Verbosity -> RepoContext -> (String, String) -> URI -> BuildReport -> IO BuildReportId
postBuildReport verbosity repoCtxt auth uri buildReport = do
- let fullURI = uri { uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports" }
+ let fullURI = uri{uriPath = "/package" </> prettyShow (BuildReport.package buildReport) </> "reports"}
transport <- repoContextGetTransport repoCtxt
res <- postHttp transport verbosity fullURI (showBuildReport buildReport) (Just auth)
case res of
- (303, redir) -> return $ undefined redir --TODO parse redir
+ (303, redir) -> return $ undefined redir -- TODO parse redir
_ -> die' verbosity "unrecognized response" -- give response
+{- FOURMOLU_DISABLE -}
{-
setAllowRedirects False
(_, response) <- request Request {
@@ -75,15 +80,19 @@ postBuildReport verbosity repoCtxt auth uri buildReport = do
_ -> error "Unrecognised response from server."
where body = BuildReport.show buildReport
-}
-
+{- FOURMOLU_ENABLE -}
-- TODO force this to be a PUT?
-putBuildLog :: Verbosity -> RepoContext -> (String, String)
- -> BuildReportId -> BuildLog
- -> IO ()
+putBuildLog
+ :: Verbosity
+ -> RepoContext
+ -> (String, String)
+ -> BuildReportId
+ -> BuildLog
+ -> IO ()
putBuildLog verbosity repoCtxt auth reportId buildLog = do
- let fullURI = reportId {uriPath = uriPath reportId </> "log"}
+ let fullURI = reportId{uriPath = uriPath reportId </> "log"}
transport <- repoContextGetTransport repoCtxt
res <- postHttp transport verbosity fullURI buildLog (Just auth)
case res of
diff --git a/cabal-install/src/Distribution/Client/Check.hs b/cabal-install/src/Distribution/Client/Check.hs
index f032b1485553007b92f85ba01f995e296a56805f..654725971bc8f311c0966c7a23b009c518d3e4e5 100644
--- a/cabal-install/src/Distribution/Client/Check.hs
+++ b/cabal-install/src/Distribution/Client/Check.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Check
-- Copyright : (c) Lennart Kolmodin 2008
@@ -10,43 +14,42 @@
-- Portability : portable
--
-- Check a package for common mistakes
---
------------------------------------------------------------------------------
-module Distribution.Client.Check (
- check
+module Distribution.Client.Check
+ ( check
) where
-
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.Utils.Parsec (renderParseError)
-import Distribution.PackageDescription (GenericPackageDescription)
+import Distribution.Client.Utils.Parsec (renderParseError)
+import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.PackageDescription.Check
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
import Distribution.PackageDescription.Parsec
- (parseGenericPackageDescription, runParseResult)
-import Distribution.Parsec (PWarning (..), showPError)
-import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn)
-import System.IO (hPutStr, stderr)
+ ( parseGenericPackageDescription
+ , runParseResult
+ )
+import Distribution.Parsec (PWarning (..), showPError)
+import Distribution.Simple.Utils (defaultPackageDesc, die', notice, warn)
+import System.IO (hPutStr, stderr)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as BS
import qualified System.Directory as Dir
readGenericPackageDescriptionCheck :: Verbosity -> FilePath -> IO ([PWarning], GenericPackageDescription)
readGenericPackageDescriptionCheck verbosity fpath = do
- exists <- Dir.doesFileExist fpath
- unless exists $
- die' verbosity $
- "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
- bs <- BS.readFile fpath
- let (warnings, result) = runParseResult (parseGenericPackageDescription bs)
- case result of
- Left (_, errors) -> do
- traverse_ (warn verbosity . showPError fpath) errors
- hPutStr stderr $ renderParseError fpath bs errors warnings
- die' verbosity "parse error"
- Right x -> return (warnings, x)
+ exists <- Dir.doesFileExist fpath
+ unless exists $
+ die' verbosity $
+ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue."
+ bs <- BS.readFile fpath
+ let (warnings, result) = runParseResult (parseGenericPackageDescription bs)
+ case result of
+ Left (_, errors) -> do
+ traverse_ (warn verbosity . showPError fpath) errors
+ hPutStr stderr $ renderParseError fpath bs errors warnings
+ die' verbosity "parse error"
+ Right x -> return (warnings, x)
-- | Checks a packge for common errors. Returns @True@ if the package
-- is fit to upload to Hackage, @False@ otherwise.
@@ -54,59 +57,60 @@ readGenericPackageDescriptionCheck verbosity fpath = do
-- the '.cabal' file.
check :: Verbosity -> IO Bool
check verbosity = do
- pdfile <- defaultPackageDesc verbosity
- (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile
- -- convert parse warnings into PackageChecks
- let ws' = map (wrapParseWarning pdfile) ws
- -- flatten the generic package description into a regular package
- -- description
- -- TODO: this may give more warnings than it should give;
- -- consider two branches of a condition, one saying
- -- ghc-options: -Wall
- -- and the other
- -- ghc-options: -Werror
- -- joined into
- -- ghc-options: -Wall -Werror
- -- checkPackages will yield a warning on the last line, but it
- -- would not on each individual branch.
- -- However, this is the same way hackage does it, so we will yield
- -- the exact same errors as it will.
- let pkg_desc = flattenPackageDescription ppd
- ioChecks <- checkPackageFiles verbosity pkg_desc "."
- let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws'
- buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]
- buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ]
- distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ]
- ++ [ x | x@PackageDistSuspiciousWarn {} <- packageChecks ]
- distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ]
-
- unless (null buildImpossible) $ do
- warn verbosity "The package will not build sanely due to these errors:"
- printCheckMessages buildImpossible
-
- unless (null buildWarning) $ do
- warn verbosity "The following warnings are likely to affect your build negatively:"
- printCheckMessages buildWarning
-
- unless (null distSuspicious) $ do
- warn verbosity "These warnings may cause trouble when distributing the package:"
- printCheckMessages distSuspicious
-
- unless (null distInexusable) $ do
- warn verbosity "The following errors will cause portability problems on other environments:"
- printCheckMessages distInexusable
-
- let errors = filter isHackageDistError packageChecks
-
- unless (null errors) $
- warn verbosity "Hackage would reject this package."
-
- when (null packageChecks) $
- notice verbosity "No errors or warnings could be found in the package."
-
- return (null errors)
+ pdfile <- defaultPackageDesc verbosity
+ (ws, ppd) <- readGenericPackageDescriptionCheck verbosity pdfile
+ -- convert parse warnings into PackageChecks
+ let ws' = map (wrapParseWarning pdfile) ws
+ -- flatten the generic package description into a regular package
+ -- description
+ -- TODO: this may give more warnings than it should give;
+ -- consider two branches of a condition, one saying
+ -- ghc-options: -Wall
+ -- and the other
+ -- ghc-options: -Werror
+ -- joined into
+ -- ghc-options: -Wall -Werror
+ -- checkPackages will yield a warning on the last line, but it
+ -- would not on each individual branch.
+ -- However, this is the same way hackage does it, so we will yield
+ -- the exact same errors as it will.
+ let pkg_desc = flattenPackageDescription ppd
+ ioChecks <- checkPackageFiles verbosity pkg_desc "."
+ let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) ++ ws'
+ buildImpossible = [x | x@PackageBuildImpossible{} <- packageChecks]
+ buildWarning = [x | x@PackageBuildWarning{} <- packageChecks]
+ distSuspicious =
+ [x | x@PackageDistSuspicious{} <- packageChecks]
+ ++ [x | x@PackageDistSuspiciousWarn{} <- packageChecks]
+ distInexusable = [x | x@PackageDistInexcusable{} <- packageChecks]
+
+ unless (null buildImpossible) $ do
+ warn verbosity "The package will not build sanely due to these errors:"
+ printCheckMessages buildImpossible
+ unless (null buildWarning) $ do
+ warn verbosity "The following warnings are likely to affect your build negatively:"
+ printCheckMessages buildWarning
+
+ unless (null distSuspicious) $ do
+ warn verbosity "These warnings may cause trouble when distributing the package:"
+ printCheckMessages distSuspicious
+
+ unless (null distInexusable) $ do
+ warn verbosity "The following errors will cause portability problems on other environments:"
+ printCheckMessages distInexusable
+
+ let errors = filter isHackageDistError packageChecks
+
+ unless (null errors) $
+ warn verbosity "Hackage would reject this package."
+
+ when (null packageChecks) $
+ notice verbosity "No errors or warnings could be found in the package."
+
+ return (null errors)
where
printCheckMessages :: [PackageCheck] -> IO ()
printCheckMessages = traverse_ (warn verbosity) . map show
- -- xxx mapM_ o traverse?
+
+-- xxx mapM_ o traverse?
diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs
index ee90cf09498fe4219c953900eade4ce9c93662b9..8c69633ac966707285542500ac6b09b92615b6de 100644
--- a/cabal-install/src/Distribution/Client/CmdBench.hs
+++ b/cabal-install/src/Distribution/Client/CmdBench.hs
@@ -1,81 +1,106 @@
{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: bench
---
-module Distribution.Client.CmdBench (
- -- * The @bench@ CLI and action
- benchCommand,
- benchAction,
+module Distribution.Client.CmdBench
+ ( -- * The @bench@ CLI and action
+ benchCommand
+ , benchAction
-- * Internals exposed for testing
- componentNotBenchmarkProblem,
- isSubComponentProblem,
- noBenchmarksProblem,
- selectPackageTargets,
- selectComponentTarget
+ , componentNotBenchmarkProblem
+ , isSubComponentProblem
+ , noBenchmarksProblem
+ , selectPackageTargets
+ , selectComponentTarget
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
- ( renderTargetSelector, showTargetSelector, renderTargetProblem,
- renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
- targetSelectorFilter )
-import Distribution.Client.TargetProblem
- ( TargetProblem (..) )
+ ( plural
+ , renderTargetProblem
+ , renderTargetProblemNoTargets
+ , renderTargetSelector
+ , showTargetSelector
+ , targetSelectorFilter
+ , targetSelectorPluralPkgs
+ )
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
+import Distribution.Client.ProjectOrchestration
import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..) )
+ ( ConfigFlags (..)
+ , GlobalFlags
+ )
+import Distribution.Client.TargetProblem
+ ( TargetProblem (..)
+ )
import Distribution.Client.Utils
- ( giveRTSWarning )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault )
+ ( giveRTSWarning
+ )
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives )
-import Distribution.Verbosity
- ( normal )
+ ( CommandUI (..)
+ , usageAlternatives
+ )
+import Distribution.Simple.Flag
+ ( fromFlagOrDefault
+ )
import Distribution.Simple.Utils
- ( wrapText, die', warn )
+ ( die'
+ , warn
+ , wrapText
+ )
+import Distribution.Verbosity
+ ( normal
+ )
import GHC.Environment
- ( getFullArgs )
+ ( getFullArgs
+ )
benchCommand :: CommandUI (NixStyleFlags ())
-benchCommand = CommandUI {
- commandName = "v2-bench",
- commandSynopsis = "Run benchmarks.",
- commandUsage = usageAlternatives "v2-bench" [ "[TARGETS] [FLAGS]" ],
- commandDescription = Just $ \_ -> wrapText $
- "Runs the specified benchmarks, first ensuring they are up to "
- ++ "date.\n\n"
-
- ++ "Any benchmark in any package in the project can be specified. "
- ++ "A package can be specified in which case all the benchmarks in the "
- ++ "package are run. The default is to run all the benchmarks in the "
- ++ "package in the current directory.\n\n"
-
- ++ "Dependencies are built or rebuilt as necessary. Additional "
- ++ "configuration flags can be specified on the command line and these "
- ++ "extend the project configuration from the 'cabal.project', "
- ++ "'cabal.project.local' and other files.",
- commandNotes = Just $ \pname ->
+benchCommand =
+ CommandUI
+ { commandName = "v2-bench"
+ , commandSynopsis = "Run benchmarks."
+ , commandUsage = usageAlternatives "v2-bench" ["[TARGETS] [FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Runs the specified benchmarks, first ensuring they are up to "
+ ++ "date.\n\n"
+ ++ "Any benchmark in any package in the project can be specified. "
+ ++ "A package can be specified in which case all the benchmarks in the "
+ ++ "package are run. The default is to run all the benchmarks in the "
+ ++ "package in the current directory.\n\n"
+ ++ "Dependencies are built or rebuilt as necessary. Additional "
+ ++ "configuration flags can be specified on the command line and these "
+ ++ "extend the project configuration from the 'cabal.project', "
+ ++ "'cabal.project.local' and other files."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v2-bench\n"
- ++ " Run all the benchmarks in the package in the current directory\n"
- ++ " " ++ pname ++ " v2-bench pkgname\n"
- ++ " Run all the benchmarks in the package named pkgname\n"
- ++ " " ++ pname ++ " v2-bench cname\n"
- ++ " Run the benchmark named cname\n"
- ++ " " ++ pname ++ " v2-bench cname -O2\n"
- ++ " Run the benchmark built with '-O2' (including local libs used)\n"
-
- , commandDefaultFlags = defaultNixStyleFlags ()
- , commandOptions = nixStyleOptions (const [])
- }
-
+ ++ " "
+ ++ pname
+ ++ " v2-bench\n"
+ ++ " Run all the benchmarks in the package in the current directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-bench pkgname\n"
+ ++ " Run all the benchmarks in the package named pkgname\n"
+ ++ " "
+ ++ pname
+ ++ " v2-bench cname\n"
+ ++ " Run the benchmark named cname\n"
+ ++ " "
+ ++ pname
+ ++ " v2-bench cname -O2\n"
+ ++ " Run the benchmark built with '-O2' (including local libs used)\n"
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ , commandOptions = nixStyleOptions (const [])
+ }
-- | The @build@ command does a lot. It brings the install plan up to date,
-- selects that part of the plan needed by the given or implicit targets and
@@ -83,52 +108,56 @@ benchCommand = CommandUI {
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
benchAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
-
- baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
-
- targetSelectors <- either (reportTargetSelectorProblems verbosity) return
- =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings
-
- buildCtx <-
- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-
- when (buildSettingOnlyDeps (buildSettings baseCtx)) $
- die' verbosity $
- "The bench command does not support '--only-dependencies'. "
- ++ "You may wish to use 'build --only-dependencies' and then "
- ++ "use 'bench'."
-
- fullArgs <- getFullArgs
- when ("+RTS" `elem` fullArgs) $
- warn verbosity $ giveRTSWarning "bench"
-
- -- Interpret the targets on the command line as bench targets
- -- (as opposed to say build or haddock targets).
- targets <- either (reportTargetProblems verbosity) return
- $ resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- let elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionBench
- targets
- elaboratedPlan
- return (elaboratedPlan', targets)
-
- printPlan verbosity baseCtx buildCtx
-
- buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
- runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do
+ baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
+
+ targetSelectors <-
+ either (reportTargetSelectorProblems verbosity) return
+ =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings
+
+ buildCtx <-
+ runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
+ when (buildSettingOnlyDeps (buildSettings baseCtx)) $
+ die' verbosity $
+ "The bench command does not support '--only-dependencies'. "
+ ++ "You may wish to use 'build --only-dependencies' and then "
+ ++ "use 'bench'."
+
+ fullArgs <- getFullArgs
+ when ("+RTS" `elem` fullArgs) $
+ warn verbosity $
+ giveRTSWarning "bench"
+
+ -- Interpret the targets on the command line as bench targets
+ -- (as opposed to say build or haddock targets).
+ targets <-
+ either (reportTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionBench
+ targets
+ elaboratedPlan
+ return (elaboratedPlan', targets)
+
+ printPlan verbosity baseCtx buildCtx
+
+ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
+ runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
- cliConfig = commandLineFlagsToProjectConfig globalFlags flags
- mempty -- ClientInstallFlags, not needed here
+ cliConfig =
+ commandLineFlagsToProjectConfig
+ globalFlags
+ flags
+ mempty -- ClientInstallFlags, not needed here
-- | This defines what a 'TargetSelector' means for the @bench@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
@@ -136,126 +165,133 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
--
-- For the @bench@ command we select all buildable benchmarks,
-- or fail if there are no benchmarks or no buildable benchmarks.
---
-selectPackageTargets :: TargetSelector
- -> [AvailableTarget k] -> Either BenchTargetProblem [k]
+selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either BenchTargetProblem [k]
selectPackageTargets targetSelector targets
-
- -- If there are any buildable benchmark targets then we select those
- | not (null targetsBenchBuildable)
- = Right targetsBenchBuildable
-
- -- If there are benchmarks but none are buildable then we report those
- | not (null targetsBench)
- = Left (TargetProblemNoneEnabled targetSelector targetsBench)
-
- -- If there are no benchmarks but some other targets then we report that
- | not (null targets)
- = Left (noBenchmarksProblem targetSelector)
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ -- If there are any buildable benchmark targets then we select those
+ | not (null targetsBenchBuildable) =
+ Right targetsBenchBuildable
+ -- If there are benchmarks but none are buildable then we report those
+ | not (null targetsBench) =
+ Left (TargetProblemNoneEnabled targetSelector targetsBench)
+ -- If there are no benchmarks but some other targets then we report that
+ | not (null targets) =
+ Left (noBenchmarksProblem targetSelector)
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
- targetsBenchBuildable = selectBuildableTargets
- . filterTargetsKind BenchKind
- $ targets
-
- targetsBench = forgetTargetsDetail
- . filterTargetsKind BenchKind
- $ targets
+ targetsBenchBuildable =
+ selectBuildableTargets
+ . filterTargetsKind BenchKind
+ $ targets
+ targetsBench =
+ forgetTargetsDetail
+ . filterTargetsKind BenchKind
+ $ targets
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @bench@ command we just need to check it is a benchmark, in addition
-- to the basic checks on being buildable etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either BenchTargetProblem k
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either BenchTargetProblem k
selectComponentTarget subtarget@WholeComponent t
- | CBenchName _ <- availableTargetComponentName t
- = selectComponentTargetBasic subtarget t
- | otherwise
- = Left (componentNotBenchmarkProblem
- (availableTargetPackageId t)
- (availableTargetComponentName t))
-
-selectComponentTarget subtarget t
- = Left (isSubComponentProblem
- (availableTargetPackageId t)
- (availableTargetComponentName t)
- subtarget)
+ | CBenchName _ <- availableTargetComponentName t =
+ selectComponentTargetBasic subtarget t
+ | otherwise =
+ Left
+ ( componentNotBenchmarkProblem
+ (availableTargetPackageId t)
+ (availableTargetComponentName t)
+ )
+selectComponentTarget subtarget t =
+ Left
+ ( isSubComponentProblem
+ (availableTargetPackageId t)
+ (availableTargetComponentName t)
+ subtarget
+ )
-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @bench@ command.
---
-data BenchProblem =
- -- | The 'TargetSelector' matches targets but no benchmarks
- TargetProblemNoBenchmarks TargetSelector
-
- -- | The 'TargetSelector' refers to a component that is not a benchmark
- | TargetProblemComponentNotBenchmark PackageId ComponentName
-
- -- | Asking to benchmark an individual file or module is not supported
- | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
+data BenchProblem
+ = -- | The 'TargetSelector' matches targets but no benchmarks
+ TargetProblemNoBenchmarks TargetSelector
+ | -- | The 'TargetSelector' refers to a component that is not a benchmark
+ TargetProblemComponentNotBenchmark PackageId ComponentName
+ | -- | Asking to benchmark an individual file or module is not supported
+ TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
deriving (Eq, Show)
-
type BenchTargetProblem = TargetProblem BenchProblem
noBenchmarksProblem :: TargetSelector -> TargetProblem BenchProblem
noBenchmarksProblem = CustomTargetProblem . TargetProblemNoBenchmarks
componentNotBenchmarkProblem :: PackageId -> ComponentName -> TargetProblem BenchProblem
-componentNotBenchmarkProblem pkgid name = CustomTargetProblem $
- TargetProblemComponentNotBenchmark pkgid name
+componentNotBenchmarkProblem pkgid name =
+ CustomTargetProblem $
+ TargetProblemComponentNotBenchmark pkgid name
isSubComponentProblem
:: PackageId
-> ComponentName
-> SubComponentTarget
-> TargetProblem BenchProblem
-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $
+isSubComponentProblem pkgid name subcomponent =
+ CustomTargetProblem $
TargetProblemIsSubComponent pkgid name subcomponent
reportTargetProblems :: Verbosity -> [BenchTargetProblem] -> IO a
reportTargetProblems verbosity =
- die' verbosity . unlines . map renderBenchTargetProblem
+ die' verbosity . unlines . map renderBenchTargetProblem
renderBenchTargetProblem :: BenchTargetProblem -> String
renderBenchTargetProblem (TargetProblemNoTargets targetSelector) =
- case targetSelectorFilter targetSelector of
- Just kind | kind /= BenchKind
- -> "The bench command is for running benchmarks, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
-
- _ -> renderTargetProblemNoTargets "benchmark" targetSelector
+ case targetSelectorFilter targetSelector of
+ Just kind
+ | kind /= BenchKind ->
+ "The bench command is for running benchmarks, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
+ _ -> renderTargetProblemNoTargets "benchmark" targetSelector
renderBenchTargetProblem problem =
- renderTargetProblem "benchmark" renderBenchProblem problem
+ renderTargetProblem "benchmark" renderBenchProblem problem
renderBenchProblem :: BenchProblem -> String
renderBenchProblem (TargetProblemNoBenchmarks targetSelector) =
- "Cannot run benchmarks for the target '" ++ showTargetSelector targetSelector
- ++ "' which refers to " ++ renderTargetSelector targetSelector
- ++ " because "
- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
- ++ " not contain any benchmarks."
-
+ "Cannot run benchmarks for the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' which refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " because "
+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
+ ++ " not contain any benchmarks."
renderBenchProblem (TargetProblemComponentNotBenchmark pkgid cname) =
- "The bench command is for running benchmarks, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " from the package "
- ++ prettyShow pkgid ++ "."
+ "The bench command is for running benchmarks, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " from the package "
+ ++ prettyShow pkgid
+ ++ "."
where
targetSelector = TargetComponent pkgid cname WholeComponent
-
renderBenchProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
- "The bench command can only run benchmarks as a whole, "
- ++ "not files or modules within them, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
+ "The bench command can only run benchmarks as a whole, "
+ ++ "not files or modules within them, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
where
targetSelector = TargetComponent pkgid cname subtarget
diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs
index 9c8943d939e0cf7fd83556f240486f58c4203a2c..8f423cd0839b5cec1edeedece582886e4f0997ff 100644
--- a/cabal-install/src/Distribution/Client/CmdBuild.hs
+++ b/cabal-install/src/Distribution/Client/CmdBuild.hs
@@ -1,94 +1,128 @@
{-# LANGUAGE RecordWildCards #-}
--- | cabal-install CLI command: build
---
-module Distribution.Client.CmdBuild (
- -- * The @build@ CLI and action
- buildCommand,
- buildAction,
- BuildFlags(..),
- defaultBuildFlags,
+-- | cabal-install CLI command: build
+module Distribution.Client.CmdBuild
+ ( -- * The @build@ CLI and action
+ buildCommand
+ , buildAction
+ , BuildFlags (..)
+ , defaultBuildFlags
-- * Internals exposed for testing
- selectPackageTargets,
- selectComponentTarget
+ , selectPackageTargets
+ , selectComponentTarget
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
+import Distribution.Client.CmdErrorMessages
import Distribution.Client.ProjectFlags
- ( removeIgnoreProjectOption )
+ ( removeIgnoreProjectOption
+ )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.TargetProblem
- ( TargetProblem (..), TargetProblem' )
-import Distribution.Client.CmdErrorMessages
+ ( TargetProblem (..)
+ , TargetProblem'
+ )
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
+import Distribution.Client.ScriptUtils
+ ( AcceptNoTargets (..)
+ , TargetContext (..)
+ , updateContextAndWriteProjectFile
+ , withContextAndSelectors
+ )
import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..), yesNoOpt )
-import Distribution.Simple.Flag ( Flag(..), toFlag, fromFlag, fromFlagOrDefault )
+ ( ConfigFlags (..)
+ , GlobalFlags
+ , yesNoOpt
+ )
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives, option )
-import Distribution.Verbosity
- ( normal )
+ ( CommandUI (..)
+ , option
+ , usageAlternatives
+ )
+import Distribution.Simple.Flag (Flag (..), fromFlag, fromFlagOrDefault, toFlag)
import Distribution.Simple.Utils
- ( wrapText, die' )
-import Distribution.Client.ScriptUtils
- ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) )
+ ( die'
+ , wrapText
+ )
+import Distribution.Verbosity
+ ( normal
+ )
import qualified Data.Map as Map
-
buildCommand :: CommandUI (NixStyleFlags BuildFlags)
-buildCommand = CommandUI {
- commandName = "v2-build",
- commandSynopsis = "Compile targets within the project.",
- commandUsage = usageAlternatives "v2-build" [ "[TARGETS] [FLAGS]" ],
- commandDescription = Just $ \_ -> wrapText $
- "Build one or more targets from within the project. The available "
- ++ "targets are the packages in the project as well as individual "
- ++ "components within those packages, including libraries, executables, "
- ++ "test-suites or benchmarks. Targets can be specified by name or "
- ++ "location. If no target is specified then the default is to build "
- ++ "the package in the current directory.\n\n"
-
- ++ "Dependencies are built or rebuilt as necessary. Additional "
- ++ "configuration flags can be specified on the command line and these "
- ++ "extend the project configuration from the 'cabal.project', "
- ++ "'cabal.project.local' and other files.",
- commandNotes = Just $ \pname ->
+buildCommand =
+ CommandUI
+ { commandName = "v2-build"
+ , commandSynopsis = "Compile targets within the project."
+ , commandUsage = usageAlternatives "v2-build" ["[TARGETS] [FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Build one or more targets from within the project. The available "
+ ++ "targets are the packages in the project as well as individual "
+ ++ "components within those packages, including libraries, executables, "
+ ++ "test-suites or benchmarks. Targets can be specified by name or "
+ ++ "location. If no target is specified then the default is to build "
+ ++ "the package in the current directory.\n\n"
+ ++ "Dependencies are built or rebuilt as necessary. Additional "
+ ++ "configuration flags can be specified on the command line and these "
+ ++ "extend the project configuration from the 'cabal.project', "
+ ++ "'cabal.project.local' and other files."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v2-build\n"
- ++ " Build the package in the current directory "
- ++ "or all packages in the project\n"
- ++ " " ++ pname ++ " v2-build pkgname\n"
- ++ " Build the package named pkgname in the project\n"
- ++ " " ++ pname ++ " v2-build ./pkgfoo\n"
- ++ " Build the package in the ./pkgfoo directory\n"
- ++ " " ++ pname ++ " v2-build cname\n"
- ++ " Build the component named cname in the project\n"
- ++ " " ++ pname ++ " v2-build cname --enable-profiling\n"
- ++ " Build the component in profiling mode "
- ++ "(including dependencies as needed)\n"
-
- , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags
- , commandOptions = removeIgnoreProjectOption
- . nixStyleOptions (\showOrParseArgs ->
- [ option [] ["only-configure"]
- "Instead of performing a full build just run the configure step"
- buildOnlyConfigure (\v flags -> flags { buildOnlyConfigure = v })
- (yesNoOpt showOrParseArgs)
- ])
- }
+ ++ " "
+ ++ pname
+ ++ " v2-build\n"
+ ++ " Build the package in the current directory "
+ ++ "or all packages in the project\n"
+ ++ " "
+ ++ pname
+ ++ " v2-build pkgname\n"
+ ++ " Build the package named pkgname in the project\n"
+ ++ " "
+ ++ pname
+ ++ " v2-build ./pkgfoo\n"
+ ++ " Build the package in the ./pkgfoo directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-build cname\n"
+ ++ " Build the component named cname in the project\n"
+ ++ " "
+ ++ pname
+ ++ " v2-build cname --enable-profiling\n"
+ ++ " Build the component in profiling mode "
+ ++ "(including dependencies as needed)\n"
+ , commandDefaultFlags = defaultNixStyleFlags defaultBuildFlags
+ , commandOptions =
+ removeIgnoreProjectOption
+ . nixStyleOptions
+ ( \showOrParseArgs ->
+ [ option
+ []
+ ["only-configure"]
+ "Instead of performing a full build just run the configure step"
+ buildOnlyConfigure
+ (\v flags -> flags{buildOnlyConfigure = v})
+ (yesNoOpt showOrParseArgs)
+ ]
+ )
+ }
data BuildFlags = BuildFlags
- { buildOnlyConfigure :: Flag Bool
- }
+ { buildOnlyConfigure :: Flag Bool
+ }
defaultBuildFlags :: BuildFlags
-defaultBuildFlags = BuildFlags
+defaultBuildFlags =
+ BuildFlags
{ buildOnlyConfigure = toFlag False
}
@@ -98,47 +132,52 @@ defaultBuildFlags = BuildFlags
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()
-buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings globalFlags
- = withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do
+buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globalFlags =
+ withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do
-- TODO: This flags defaults business is ugly
- let onlyConfigure = fromFlag (buildOnlyConfigure defaultBuildFlags
- <> buildOnlyConfigure buildFlags)
+ let onlyConfigure =
+ fromFlag
+ ( buildOnlyConfigure defaultBuildFlags
+ <> buildOnlyConfigure buildFlags
+ )
targetAction
- | onlyConfigure = TargetActionConfigure
- | otherwise = TargetActionBuild
+ | onlyConfigure = TargetActionConfigure
+ | otherwise = TargetActionBuild
baseCtx <- case targetCtx of
- ProjectContext -> return ctx
- GlobalContext -> return ctx
+ ProjectContext -> return ctx
+ GlobalContext -> return ctx
ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-
- -- Interpret the targets on the command line as build targets
- -- (as opposed to say repl or haddock targets).
- targets <- either (reportBuildTargetProblems verbosity) return
- $ resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- let elaboratedPlan' = pruneInstallPlanToTargets
- targetAction
- targets
- elaboratedPlan
- elaboratedPlan'' <-
- if buildSettingOnlyDeps (buildSettings baseCtx)
- then either (reportCannotPruneDependencies verbosity) return $
- pruneInstallPlanToDependencies (Map.keysSet targets)
- elaboratedPlan'
- else return elaboratedPlan'
-
- return (elaboratedPlan'', targets)
+ -- Interpret the targets on the command line as build targets
+ -- (as opposed to say repl or haddock targets).
+ targets <-
+ either (reportBuildTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ targetAction
+ targets
+ elaboratedPlan
+ elaboratedPlan'' <-
+ if buildSettingOnlyDeps (buildSettings baseCtx)
+ then
+ either (reportCannotPruneDependencies verbosity) return $
+ pruneInstallPlanToDependencies
+ (Map.keysSet targets)
+ elaboratedPlan'
+ else return elaboratedPlan'
+
+ return (elaboratedPlan'', targets)
printPlan verbosity baseCtx buildCtx
@@ -154,42 +193,42 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
---
-selectPackageTargets :: TargetSelector
- -> [AvailableTarget k] -> Either TargetProblem' [k]
+selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either TargetProblem' [k]
selectPackageTargets targetSelector targets
-
- -- If there are any buildable targets then we select those
- | not (null targetsBuildable)
- = Right targetsBuildable
-
- -- If there are targets but none are buildable then we report those
- | not (null targets)
- = Left (TargetProblemNoneEnabled targetSelector targets')
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ -- If there are any buildable targets then we select those
+ | not (null targetsBuildable) =
+ Right targetsBuildable
+ -- If there are targets but none are buildable then we report those
+ | not (null targets) =
+ Left (TargetProblemNoneEnabled targetSelector targets')
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
- targets' = forgetTargetsDetail targets
- targetsBuildable = selectBuildableTargetsWith
- (buildable targetSelector)
- targets
+ targets' = forgetTargetsDetail targets
+ targetsBuildable =
+ selectBuildableTargetsWith
+ (buildable targetSelector)
+ targets
-- When there's a target filter like "pkg:tests" then we do select tests,
-- but if it's just a target like "pkg" then we don't build tests unless
-- they are requested by default (i.e. by using --enable-tests)
- buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
- buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
+ buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
+ buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
buildable _ _ = True
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @build@ command we just need the basic checks on being buildable etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either TargetProblem' k
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either TargetProblem' k
selectComponentTarget = selectComponentTargetBasic
reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
@@ -198,4 +237,4 @@ reportBuildTargetProblems verbosity problems =
reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies verbosity =
- die' verbosity . renderCannotPruneDependencies
+ die' verbosity . renderCannotPruneDependencies
diff --git a/cabal-install/src/Distribution/Client/CmdClean.hs b/cabal-install/src/Distribution/Client/CmdClean.hs
index f09e7ccb603091bbaab6a50bcd7492f3cb1b4664..fda4b38921d03ff44241f07c7d2128bfa8999b9f 100644
--- a/cabal-install/src/Distribution/Client/CmdClean.hs
+++ b/cabal-install/src/Distribution/Client/CmdClean.hs
@@ -1,146 +1,191 @@
{-# LANGUAGE RecordWildCards #-}
+
module Distribution.Client.CmdClean (cleanCommand, cleanAction) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Distribution.Client.Config
- ( defaultScriptBuildsDir )
+ ( defaultScriptBuildsDir
+ )
import Distribution.Client.DistDirLayout
- ( DistDirLayout(..), defaultDistDirLayout )
+ ( DistDirLayout (..)
+ , defaultDistDirLayout
+ )
import Distribution.Client.ProjectConfig
- ( findProjectRoot )
+ ( findProjectRoot
+ )
import Distribution.Client.Setup
- ( GlobalFlags )
-import Distribution.ReadE ( succeedReadE )
-import Distribution.Simple.Setup
- ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
- , optionDistPref, optionVerbosity, falseArg
- )
+ ( GlobalFlags
+ )
+import Distribution.ReadE (succeedReadE)
import Distribution.Simple.Command
- ( CommandUI(..), option, reqArg )
+ ( CommandUI (..)
+ , option
+ , reqArg
+ )
+import Distribution.Simple.Setup
+ ( Flag (..)
+ , falseArg
+ , flagToList
+ , flagToMaybe
+ , fromFlagOrDefault
+ , optionDistPref
+ , optionVerbosity
+ , toFlag
+ )
import Distribution.Simple.Utils
- ( info, die', wrapText, handleDoesNotExist )
+ ( die'
+ , handleDoesNotExist
+ , info
+ , wrapText
+ )
import Distribution.Verbosity
- ( normal )
+ ( normal
+ )
import Control.Monad
- ( forM, forM_, mapM )
+ ( forM
+ , forM_
+ , mapM
+ )
import qualified Data.Set as Set
import System.Directory
- ( removeDirectoryRecursive, removeFile
- , doesDirectoryExist, doesFileExist
- , getDirectoryContents, listDirectory
- , canonicalizePath )
+ ( canonicalizePath
+ , doesDirectoryExist
+ , doesFileExist
+ , getDirectoryContents
+ , listDirectory
+ , removeDirectoryRecursive
+ , removeFile
+ )
import System.FilePath
- ( (</>) )
+ ( (</>)
+ )
data CleanFlags = CleanFlags
- { cleanSaveConfig :: Flag Bool
- , cleanVerbosity :: Flag Verbosity
- , cleanDistDir :: Flag FilePath
- , cleanProjectDir :: Flag FilePath
- , cleanProjectFile :: Flag FilePath
- } deriving (Eq)
+ { cleanSaveConfig :: Flag Bool
+ , cleanVerbosity :: Flag Verbosity
+ , cleanDistDir :: Flag FilePath
+ , cleanProjectDir :: Flag FilePath
+ , cleanProjectFile :: Flag FilePath
+ }
+ deriving (Eq)
defaultCleanFlags :: CleanFlags
-defaultCleanFlags = CleanFlags
- { cleanSaveConfig = toFlag False
- , cleanVerbosity = toFlag normal
- , cleanDistDir = NoFlag
- , cleanProjectDir = mempty
+defaultCleanFlags =
+ CleanFlags
+ { cleanSaveConfig = toFlag False
+ , cleanVerbosity = toFlag normal
+ , cleanDistDir = NoFlag
+ , cleanProjectDir = mempty
, cleanProjectFile = mempty
}
cleanCommand :: CommandUI CleanFlags
-cleanCommand = CommandUI
- { commandName = "v2-clean"
- , commandSynopsis = "Clean the package store and remove temporary files."
- , commandUsage = \pname ->
+cleanCommand =
+ CommandUI
+ { commandName = "v2-clean"
+ , commandSynopsis = "Clean the package store and remove temporary files."
+ , commandUsage = \pname ->
"Usage: " ++ pname ++ " new-clean [FLAGS]\n"
- , commandDescription = Just $ \_ -> wrapText $
- "Removes all temporary files created during the building process "
- ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "
- ++ "local caches (by default).\n\n"
- , commandNotes = Nothing
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Removes all temporary files created during the building process "
+ ++ "(.hi, .o, preprocessed sources, etc.) and also empties out the "
+ ++ "local caches (by default).\n\n"
+ , commandNotes = Nothing
, commandDefaultFlags = defaultCleanFlags
- , commandOptions = \showOrParseArgs ->
+ , commandOptions = \showOrParseArgs ->
[ optionVerbosity
- cleanVerbosity (\v flags -> flags { cleanVerbosity = v })
+ cleanVerbosity
+ (\v flags -> flags{cleanVerbosity = v})
, optionDistPref
- cleanDistDir (\dd flags -> flags { cleanDistDir = dd })
+ cleanDistDir
+ (\dd flags -> flags{cleanDistDir = dd})
showOrParseArgs
- , option [] ["project-dir"]
+ , option
+ []
+ ["project-dir"]
"Set the path of the project directory"
- cleanProjectDir (\path flags -> flags {cleanProjectDir = path})
+ cleanProjectDir
+ (\path flags -> flags{cleanProjectDir = path})
(reqArg "DIR" (succeedReadE Flag) flagToList)
- , option [] ["project-file"]
+ , option
+ []
+ ["project-file"]
"Set the path of the cabal.project file (relative to the project directory when relative)"
- cleanProjectFile (\pf flags -> flags {cleanProjectFile = pf})
+ cleanProjectFile
+ (\pf flags -> flags{cleanProjectFile = pf})
(reqArg "FILE" (succeedReadE Flag) flagToList)
- , option ['s'] ["save-config"]
+ , option
+ ['s']
+ ["save-config"]
"Save configuration, only remove build artifacts"
- cleanSaveConfig (\sc flags -> flags { cleanSaveConfig = sc })
+ cleanSaveConfig
+ (\sc flags -> flags{cleanSaveConfig = sc})
falseArg
]
- }
+ }
cleanAction :: CleanFlags -> [String] -> GlobalFlags -> IO ()
cleanAction CleanFlags{..} extraArgs _ = do
- let verbosity = fromFlagOrDefault normal cleanVerbosity
- saveConfig = fromFlagOrDefault False cleanSaveConfig
- mdistDirectory = flagToMaybe cleanDistDir
- mprojectDir = flagToMaybe cleanProjectDir
- mprojectFile = flagToMaybe cleanProjectFile
-
- -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
- --
- -- For now assume all files passed are the names of scripts
- notScripts <- filterM (fmap not . doesFileExist) extraArgs
- unless (null notScripts) $
- die' verbosity $ "'clean' extra arguments should be script files: "
- ++ unwords notScripts
-
- projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
-
- let distLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
-
- -- Do not clean a project if just running a script in it's directory
- when (null extraArgs || isJust mdistDirectory) $ do
- if saveConfig then do
- let buildRoot = distBuildRootDirectory distLayout
-
- buildRootExists <- doesDirectoryExist buildRoot
-
- when buildRootExists $ do
- info verbosity ("Deleting build root (" ++ buildRoot ++ ")")
- handleDoesNotExist () $ removeDirectoryRecursive buildRoot
- else do
- let distRoot = distDirectory distLayout
-
- info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
- handleDoesNotExist () $ removeDirectoryRecursive distRoot
-
- removeEnvFiles (distProjectRootDirectory distLayout)
-
- -- Clean specified script build caches and orphaned caches.
- -- There is currently no good way to specify to only clean orphaned caches.
- -- It would be better as part of an explicit gc step (see issue #3333)
- toClean <- Set.fromList <$> mapM canonicalizePath extraArgs
- cacheDir <- defaultScriptBuildsDir
- existsCD <- doesDirectoryExist cacheDir
- caches <- if existsCD then listDirectory cacheDir else return []
- paths <- fmap concat . forM caches $ \cache -> do
- let locFile = cacheDir </> cache </> "scriptlocation"
- exists <- doesFileExist locFile
- if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []
- forM_ paths $ \(cache, script) -> do
- exists <- doesFileExist script
- when (not exists || script `Set.member` toClean) $ do
- info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")
- removeDirectoryRecursive cache
+ let verbosity = fromFlagOrDefault normal cleanVerbosity
+ saveConfig = fromFlagOrDefault False cleanSaveConfig
+ mdistDirectory = flagToMaybe cleanDistDir
+ mprojectDir = flagToMaybe cleanProjectDir
+ mprojectFile = flagToMaybe cleanProjectFile
+
+ -- TODO interpret extraArgs as targets and clean those targets only (issue #7506)
+ --
+ -- For now assume all files passed are the names of scripts
+ notScripts <- filterM (fmap not . doesFileExist) extraArgs
+ unless (null notScripts) $
+ die' verbosity $
+ "'clean' extra arguments should be script files: "
+ ++ unwords notScripts
+
+ projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
+
+ let distLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
+
+ -- Do not clean a project if just running a script in it's directory
+ when (null extraArgs || isJust mdistDirectory) $ do
+ if saveConfig
+ then do
+ let buildRoot = distBuildRootDirectory distLayout
+
+ buildRootExists <- doesDirectoryExist buildRoot
+
+ when buildRootExists $ do
+ info verbosity ("Deleting build root (" ++ buildRoot ++ ")")
+ handleDoesNotExist () $ removeDirectoryRecursive buildRoot
+ else do
+ let distRoot = distDirectory distLayout
+
+ info verbosity ("Deleting dist-newstyle (" ++ distRoot ++ ")")
+ handleDoesNotExist () $ removeDirectoryRecursive distRoot
+
+ removeEnvFiles (distProjectRootDirectory distLayout)
+
+ -- Clean specified script build caches and orphaned caches.
+ -- There is currently no good way to specify to only clean orphaned caches.
+ -- It would be better as part of an explicit gc step (see issue #3333)
+ toClean <- Set.fromList <$> mapM canonicalizePath extraArgs
+ cacheDir <- defaultScriptBuildsDir
+ existsCD <- doesDirectoryExist cacheDir
+ caches <- if existsCD then listDirectory cacheDir else return []
+ paths <- fmap concat . forM caches $ \cache -> do
+ let locFile = cacheDir </> cache </> "scriptlocation"
+ exists <- doesFileExist locFile
+ if exists then pure . (,) (cacheDir </> cache) <$> readFile locFile else return []
+ forM_ paths $ \(cache, script) -> do
+ exists <- doesFileExist script
+ when (not exists || script `Set.member` toClean) $ do
+ info verbosity ("Deleting cache (" ++ cache ++ ") for script (" ++ script ++ ")")
+ removeDirectoryRecursive cache
removeEnvFiles :: FilePath -> IO ()
removeEnvFiles dir =
(traverse_ (removeFile . (dir </>)) . filter ((".ghc.environment" ==) . take 16))
- =<< getDirectoryContents dir
+ =<< getDirectoryContents dir
diff --git a/cabal-install/src/Distribution/Client/CmdConfigure.hs b/cabal-install/src/Distribution/Client/CmdConfigure.hs
index 80742f4fcffa9dd7ea44685da0e74d48ea045230..d8e91668095c0802d279cfb4b9d214199c3c40ee 100644
--- a/cabal-install/src/Distribution/Client/CmdConfigure.hs
+++ b/cabal-install/src/Distribution/Client/CmdConfigure.hs
@@ -1,10 +1,10 @@
{-# LANGUAGE RecordWildCards #-}
+
-- | cabal-install CLI command: configure
---
-module Distribution.Client.CmdConfigure (
- configureCommand,
- configureAction,
- configureAction',
+module Distribution.Client.CmdConfigure
+ ( configureCommand
+ , configureAction
+ , configureAction'
) where
import Distribution.Client.Compat.Prelude
@@ -13,77 +13,97 @@ import Prelude ()
import System.Directory
import System.FilePath
-import Distribution.Simple.Flag
-import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectConfig
- ( writeProjectLocalExtraConfig, readProjectLocalExtraConfig )
+ ( readProjectLocalExtraConfig
+ , writeProjectLocalExtraConfig
+ )
import Distribution.Client.ProjectFlags
- ( removeIgnoreProjectOption )
+ ( removeIgnoreProjectOption
+ )
+import Distribution.Client.ProjectOrchestration
+import Distribution.Simple.Flag
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..), ConfigExFlags(..) )
+ ( ConfigExFlags (..)
+ , ConfigFlags (..)
+ , GlobalFlags
+ )
import Distribution.Verbosity
- ( normal )
+ ( normal
+ )
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives )
+ ( CommandUI (..)
+ , usageAlternatives
+ )
import Distribution.Simple.Utils
- ( wrapText, notice, die' )
+ ( die'
+ , notice
+ , wrapText
+ )
import Distribution.Client.DistDirLayout
- ( DistDirLayout(..) )
-import Distribution.Client.RebuildMonad (runRebuild)
-import Distribution.Client.ProjectConfig.Types
+ ( DistDirLayout (..)
+ )
import Distribution.Client.HttpUtils
-import Distribution.Utils.NubList
- ( fromNubList )
+import Distribution.Client.ProjectConfig.Types
+import Distribution.Client.RebuildMonad (runRebuild)
import Distribution.Types.CondTree
- ( CondTree (..) )
+ ( CondTree (..)
+ )
+import Distribution.Utils.NubList
+ ( fromNubList
+ )
configureCommand :: CommandUI (NixStyleFlags ())
-configureCommand = CommandUI {
- commandName = "v2-configure",
- commandSynopsis = "Add extra project configuration.",
- commandUsage = usageAlternatives "v2-configure" [ "[FLAGS]" ],
- commandDescription = Just $ \_ -> wrapText $
- "Adjust how the project is built by setting additional package flags "
- ++ "and other flags.\n\n"
-
- ++ "The configuration options are written to the 'cabal.project.local' "
- ++ "file (or '$project_file.local', if '--project-file' is specified) "
- ++ "which extends the configuration from the 'cabal.project' file "
- ++ "(if any). This combination is used as the project configuration for "
- ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it "
- ++ "can be extended/overridden on a per-command basis.\n\n"
-
- ++ "The v2-configure command also checks that the project configuration "
- ++ "will work. In particular it checks that there is a consistent set of "
- ++ "dependencies for the project as a whole.\n\n"
-
- ++ "The 'cabal.project.local' file persists across 'v2-clean' but is "
- ++ "overwritten on the next use of the 'v2-configure' command. The "
- ++ "intention is that the 'cabal.project' file should be kept in source "
- ++ "control but the 'cabal.project.local' should not.\n\n"
-
- ++ "It is never necessary to use the 'v2-configure' command. It is "
- ++ "merely a convenience in cases where you do not want to specify flags "
- ++ "to 'v2-build' (and other commands) every time and yet do not want "
- ++ "to alter the 'cabal.project' persistently.",
- commandNotes = Just $ \pname ->
+configureCommand =
+ CommandUI
+ { commandName = "v2-configure"
+ , commandSynopsis = "Add extra project configuration."
+ , commandUsage = usageAlternatives "v2-configure" ["[FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Adjust how the project is built by setting additional package flags "
+ ++ "and other flags.\n\n"
+ ++ "The configuration options are written to the 'cabal.project.local' "
+ ++ "file (or '$project_file.local', if '--project-file' is specified) "
+ ++ "which extends the configuration from the 'cabal.project' file "
+ ++ "(if any). This combination is used as the project configuration for "
+ ++ "all other commands (such as 'v2-build', 'v2-repl' etc) though it "
+ ++ "can be extended/overridden on a per-command basis.\n\n"
+ ++ "The v2-configure command also checks that the project configuration "
+ ++ "will work. In particular it checks that there is a consistent set of "
+ ++ "dependencies for the project as a whole.\n\n"
+ ++ "The 'cabal.project.local' file persists across 'v2-clean' but is "
+ ++ "overwritten on the next use of the 'v2-configure' command. The "
+ ++ "intention is that the 'cabal.project' file should be kept in source "
+ ++ "control but the 'cabal.project.local' should not.\n\n"
+ ++ "It is never necessary to use the 'v2-configure' command. It is "
+ ++ "merely a convenience in cases where you do not want to specify flags "
+ ++ "to 'v2-build' (and other commands) every time and yet do not want "
+ ++ "to alter the 'cabal.project' persistently."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v2-configure --with-compiler ghc-7.10.3\n"
- ++ " Adjust the project configuration to use the given compiler\n"
- ++ " program and check the resulting configuration works.\n"
- ++ " " ++ pname ++ " v2-configure\n"
- ++ " Reset the local configuration to empty. To check that the\n"
- ++ " project configuration works, use 'cabal build'.\n"
-
- , commandDefaultFlags = defaultNixStyleFlags ()
- , commandOptions = removeIgnoreProjectOption
- . nixStyleOptions (const [])
- }
+ ++ " "
+ ++ pname
+ ++ " v2-configure --with-compiler ghc-7.10.3\n"
+ ++ " Adjust the project configuration to use the given compiler\n"
+ ++ " program and check the resulting configuration works.\n"
+ ++ " "
+ ++ pname
+ ++ " v2-configure\n"
+ ++ " Reset the local configuration to empty. To check that the\n"
+ ++ " project configuration works, use 'cabal build'.\n"
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ , commandOptions =
+ removeIgnoreProjectOption
+ . nixStyleOptions (const [])
+ }
-- | To a first approximation, the @configure@ just runs the first phase of
-- the @build@ command where we bring the install plan up to date (thus
@@ -94,60 +114,65 @@ configureCommand = CommandUI {
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
configureAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-configureAction flags@NixStyleFlags {..} extraArgs globalFlags = do
- (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags
+configureAction flags@NixStyleFlags{..} extraArgs globalFlags = do
+ (baseCtx, projConfig) <- configureAction' flags extraArgs globalFlags
- if shouldNotWriteFile baseCtx
- then notice v "Config file not written due to flag(s)."
- else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig
+ if shouldNotWriteFile baseCtx
+ then notice v "Config file not written due to flag(s)."
+ else writeProjectLocalExtraConfig (distDirLayout baseCtx) projConfig
where
v = fromFlagOrDefault normal (configVerbosity configFlags)
configureAction' :: NixStyleFlags () -> [String] -> GlobalFlags -> IO (ProjectBaseContext, ProjectConfig)
-configureAction' flags@NixStyleFlags {..} _extraArgs globalFlags = do
- --TODO: deal with _extraArgs, since flags with wrong syntax end up there
-
- baseCtx <- establishProjectBaseContext v cliConfig OtherCommand
-
- let localFile = distProjectFile (distDirLayout baseCtx) "local"
- -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~
- let backups = fromFlagOrDefault True $ configBackup configExFlags
- appends = fromFlagOrDefault False $ configAppend configExFlags
- backupFile = localFile <> "~"
-
- if shouldNotWriteFile baseCtx
- then
- return (baseCtx, cliConfig)
- else do
- exists <- doesFileExist localFile
- when (exists && backups) $ do
- notice v $
- quote (takeFileName localFile) <> " already exists, backing it up to "
- <> quote (takeFileName backupFile) <> "."
- copyFile localFile backupFile
-
- -- If the flag @configAppend@ is set to true, append and do not overwrite
- if exists && appends
- then do
- httpTransport <- configureTransport v
- (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
- (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
- (CondNode conf imps bs) <- runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
+configureAction' flags@NixStyleFlags{..} _extraArgs globalFlags = do
+ -- TODO: deal with _extraArgs, since flags with wrong syntax end up there
+
+ baseCtx <- establishProjectBaseContext v cliConfig OtherCommand
+
+ let localFile = distProjectFile (distDirLayout baseCtx) "local"
+ -- If cabal.project.local already exists, and the flags allow, back up to cabal.project.local~
+ let backups = fromFlagOrDefault True $ configBackup configExFlags
+ appends = fromFlagOrDefault False $ configAppend configExFlags
+ backupFile = localFile <> "~"
+
+ if shouldNotWriteFile baseCtx
+ then return (baseCtx, cliConfig)
+ else do
+ exists <- doesFileExist localFile
+ when (exists && backups) $ do
+ notice v $
+ quote (takeFileName localFile)
+ <> " already exists, backing it up to "
+ <> quote (takeFileName backupFile)
+ <> "."
+ copyFile localFile backupFile
+
+ -- If the flag @configAppend@ is set to true, append and do not overwrite
+ if exists && appends
+ then do
+ httpTransport <-
+ configureTransport
+ v
+ (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
+ (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
+ (CondNode conf imps bs) <-
+ runRebuild (distProjectRootDirectory . distDirLayout $ baseCtx) $
readProjectLocalExtraConfig v httpTransport (distDirLayout baseCtx)
- when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update"
- return (baseCtx, conf <> cliConfig)
- else
- return (baseCtx, cliConfig)
+ when (not (null imps && null bs)) $ die' v "local project file has conditional and/or import logic, unable to perform and automatic in-place update"
+ return (baseCtx, conf <> cliConfig)
+ else return (baseCtx, cliConfig)
where
v = fromFlagOrDefault normal (configVerbosity configFlags)
- cliConfig = commandLineFlagsToProjectConfig globalFlags flags
- mempty -- ClientInstallFlags, not needed here
+ cliConfig =
+ commandLineFlagsToProjectConfig
+ globalFlags
+ flags
+ mempty -- ClientInstallFlags, not needed here
quote s = "'" <> s <> "'"
-- Config file should not be written when certain flags are present
shouldNotWriteFile :: ProjectBaseContext -> Bool
shouldNotWriteFile baseCtx =
- buildSettingDryRun (buildSettings baseCtx)
- || buildSettingOnlyDownload (buildSettings baseCtx)
+ buildSettingDryRun (buildSettings baseCtx)
+ || buildSettingOnlyDownload (buildSettings baseCtx)
diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs
index cf41fc4ebac3ccfd06b31ad60b2e76ea5957e35e..e8b5a415db62d7d44024cf1367ce67a556157a56 100644
--- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs
+++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs
@@ -2,64 +2,74 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
-
-- | Utilities to help format error messages for the various CLI commands.
---
-module Distribution.Client.CmdErrorMessages (
- module Distribution.Client.CmdErrorMessages,
- module Distribution.Client.TargetSelector,
+module Distribution.Client.CmdErrorMessages
+ ( module Distribution.Client.CmdErrorMessages
+ , module Distribution.Client.TargetSelector
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.ProjectPlanning
- ( AvailableTarget(..), AvailableTargetStatus(..),
- CannotPruneDependencies(..), TargetRequested(..) )
-import Distribution.Client.TargetSelector
- ( SubComponentTarget(..) )
+ ( AvailableTarget (..)
+ , AvailableTargetStatus (..)
+ , CannotPruneDependencies (..)
+ , TargetRequested (..)
+ )
import Distribution.Client.TargetProblem
- ( TargetProblem(..), TargetProblem' )
+ ( TargetProblem (..)
+ , TargetProblem'
+ )
import Distribution.Client.TargetSelector
- ( ComponentKind(..), ComponentKindFilter, TargetSelector(..),
- componentKind, showTargetSelector )
+ ( ComponentKind (..)
+ , ComponentKindFilter
+ , SubComponentTarget (..)
+ , TargetSelector (..)
+ , componentKind
+ , showTargetSelector
+ )
import Distribution.Package
- ( PackageId, packageId, PackageName, packageName )
+ ( PackageId
+ , PackageName
+ , packageId
+ , packageName
+ )
import Distribution.Simple.Utils
- ( die' )
+ ( die'
+ )
+import Distribution.Solver.Types.OptionalStanza
+ ( OptionalStanza (..)
+ )
import Distribution.Types.ComponentName
- ( ComponentName(..), showComponentName )
+ ( ComponentName (..)
+ , showComponentName
+ )
import Distribution.Types.LibraryName
- ( LibraryName(..) )
-import Distribution.Solver.Types.OptionalStanza
- ( OptionalStanza(..) )
+ ( LibraryName (..)
+ )
import qualified Data.List.NonEmpty as NE
-
-----------------------
-- Singular or plural
--
-- | A tag used in rendering messages to distinguish singular or plural.
---
data Plural = Singular | Plural
-- | Used to render a singular or plural version of something
--
-- > plural (listPlural theThings) "it is" "they are"
---
plural :: Plural -> a -> a -> a
plural Singular si _pl = si
-plural Plural _si pl = pl
+plural Plural _si pl = pl
-- | Singular for singleton lists and plural otherwise.
---
listPlural :: [a] -> Plural
listPlural [_] = Singular
-listPlural _ = Plural
-
+listPlural _ = Plural
--------------------
-- Rendering lists
@@ -67,24 +77,26 @@ listPlural _ = Plural
-- | Render a list of things in the style @foo, bar and baz@
renderListCommaAnd :: [String] -> String
-renderListCommaAnd [] = ""
-renderListCommaAnd [x] = x
-renderListCommaAnd [x,x'] = x ++ " and " ++ x'
-renderListCommaAnd (x:xs) = x ++ ", " ++ renderListCommaAnd xs
+renderListCommaAnd [] = ""
+renderListCommaAnd [x] = x
+renderListCommaAnd [x, x'] = x ++ " and " ++ x'
+renderListCommaAnd (x : xs) = x ++ ", " ++ renderListCommaAnd xs
renderListTabular :: [String] -> String
-renderListTabular = ("\n"++) . unlines . map ("| * "++)
+renderListTabular = ("\n" ++) . unlines . map ("| * " ++)
renderListPretty :: [String] -> String
-renderListPretty xs = if length xs > 5 then renderListTabular xs
- else renderListCommaAnd xs
+renderListPretty xs =
+ if length xs > 5
+ then renderListTabular xs
+ else renderListCommaAnd xs
-- | Render a list of things in the style @blah blah; this that; and the other@
renderListSemiAnd :: [String] -> String
-renderListSemiAnd [] = ""
-renderListSemiAnd [x] = x
-renderListSemiAnd [x,x'] = x ++ "; and " ++ x'
-renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs
+renderListSemiAnd [] = ""
+renderListSemiAnd [x] = x
+renderListSemiAnd [x, x'] = x ++ "; and " ++ x'
+renderListSemiAnd (x : xs) = x ++ "; " ++ renderListSemiAnd xs
-- | When rendering lists of things it often reads better to group related
-- things, e.g. grouping components by package name
@@ -93,12 +105,11 @@ renderListSemiAnd (x:xs) = x ++ "; " ++ renderListSemiAnd xs
-- > [ "the package " ++ prettyShow pkgname ++ " components "
-- > ++ renderListCommaAnd showComponentName components
-- > | (pkgname, components) <- sortGroupOn packageName allcomponents ]
---
sortGroupOn :: Ord b => (a -> b) -> [a] -> [(b, [a])]
-sortGroupOn key = map (\(x:|xs) -> (key x, x:xs))
- . NE.groupBy ((==) `on` key)
- . sortBy (compare `on` key)
-
+sortGroupOn key =
+ map (\(x :| xs) -> (key x, x : xs))
+ . NE.groupBy ((==) `on` key)
+ . sortBy (compare `on` key)
----------------------------------------------------
-- Rendering for a few project and package types
@@ -106,107 +117,109 @@ sortGroupOn key = map (\(x:|xs) -> (key x, x:xs))
renderTargetSelector :: TargetSelector -> String
renderTargetSelector (TargetPackage _ pkgids Nothing) =
- "the " ++ plural (listPlural pkgids) "package" "packages" ++ " "
- ++ renderListCommaAnd (map prettyShow pkgids)
-
+ "the "
+ ++ plural (listPlural pkgids) "package" "packages"
+ ++ " "
+ ++ renderListCommaAnd (map prettyShow pkgids)
renderTargetSelector (TargetPackage _ pkgids (Just kfilter)) =
- "the " ++ renderComponentKind Plural kfilter
- ++ " in the " ++ plural (listPlural pkgids) "package" "packages" ++ " "
- ++ renderListCommaAnd (map prettyShow pkgids)
-
+ "the "
+ ++ renderComponentKind Plural kfilter
+ ++ " in the "
+ ++ plural (listPlural pkgids) "package" "packages"
+ ++ " "
+ ++ renderListCommaAnd (map prettyShow pkgids)
renderTargetSelector (TargetPackageNamed pkgname Nothing) =
- "the package " ++ prettyShow pkgname
-
+ "the package " ++ prettyShow pkgname
renderTargetSelector (TargetPackageNamed pkgname (Just kfilter)) =
- "the " ++ renderComponentKind Plural kfilter
- ++ " in the package " ++ prettyShow pkgname
-
+ "the "
+ ++ renderComponentKind Plural kfilter
+ ++ " in the package "
+ ++ prettyShow pkgname
renderTargetSelector (TargetAllPackages Nothing) =
- "all the packages in the project"
-
+ "all the packages in the project"
renderTargetSelector (TargetAllPackages (Just kfilter)) =
- "all the " ++ renderComponentKind Plural kfilter
- ++ " in the project"
-
+ "all the "
+ ++ renderComponentKind Plural kfilter
+ ++ " in the project"
renderTargetSelector (TargetComponent pkgid cname subtarget) =
- renderSubComponentTarget subtarget ++ "the "
- ++ renderComponentName (packageName pkgid) cname
-
+ renderSubComponentTarget subtarget
+ ++ "the "
+ ++ renderComponentName (packageName pkgid) cname
renderTargetSelector (TargetComponentUnknown pkgname (Left ucname) subtarget) =
- renderSubComponentTarget subtarget ++ "the component " ++ prettyShow ucname
- ++ " in the package " ++ prettyShow pkgname
-
+ renderSubComponentTarget subtarget
+ ++ "the component "
+ ++ prettyShow ucname
+ ++ " in the package "
+ ++ prettyShow pkgname
renderTargetSelector (TargetComponentUnknown pkgname (Right cname) subtarget) =
- renderSubComponentTarget subtarget ++ "the "
- ++ renderComponentName pkgname cname
+ renderSubComponentTarget subtarget
+ ++ "the "
+ ++ renderComponentName pkgname cname
renderSubComponentTarget :: SubComponentTarget -> String
-renderSubComponentTarget WholeComponent = ""
-renderSubComponentTarget (FileTarget filename) =
+renderSubComponentTarget WholeComponent = ""
+renderSubComponentTarget (FileTarget filename) =
"the file " ++ filename ++ " in "
renderSubComponentTarget (ModuleTarget modname) =
"the module " ++ prettyShow modname ++ " in "
-
renderOptionalStanza :: Plural -> OptionalStanza -> String
-renderOptionalStanza Singular TestStanzas = "test suite"
-renderOptionalStanza Plural TestStanzas = "test suites"
+renderOptionalStanza Singular TestStanzas = "test suite"
+renderOptionalStanza Plural TestStanzas = "test suites"
renderOptionalStanza Singular BenchStanzas = "benchmark"
-renderOptionalStanza Plural BenchStanzas = "benchmarks"
+renderOptionalStanza Plural BenchStanzas = "benchmarks"
-- | The optional stanza type (test suite or benchmark), if it is one.
optionalStanza :: ComponentName -> Maybe OptionalStanza
-optionalStanza (CTestName _) = Just TestStanzas
+optionalStanza (CTestName _) = Just TestStanzas
optionalStanza (CBenchName _) = Just BenchStanzas
-optionalStanza _ = Nothing
+optionalStanza _ = Nothing
-- | Does the 'TargetSelector' potentially refer to one package or many?
---
targetSelectorPluralPkgs :: TargetSelector -> Plural
-targetSelectorPluralPkgs (TargetAllPackages _) = Plural
-targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids
-targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular
-targetSelectorPluralPkgs TargetComponent{} = Singular
-targetSelectorPluralPkgs TargetComponentUnknown{} = Singular
+targetSelectorPluralPkgs (TargetAllPackages _) = Plural
+targetSelectorPluralPkgs (TargetPackage _ pids _) = listPlural pids
+targetSelectorPluralPkgs (TargetPackageNamed _ _) = Singular
+targetSelectorPluralPkgs TargetComponent{} = Singular
+targetSelectorPluralPkgs TargetComponentUnknown{} = Singular
-- | Does the 'TargetSelector' refer to packages or to components?
targetSelectorRefersToPkgs :: TargetSelector -> Bool
-targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter
-targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter
+targetSelectorRefersToPkgs (TargetAllPackages mkfilter) = isNothing mkfilter
+targetSelectorRefersToPkgs (TargetPackage _ _ mkfilter) = isNothing mkfilter
targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter
-targetSelectorRefersToPkgs TargetComponent{} = False
-targetSelectorRefersToPkgs TargetComponentUnknown{} = False
+targetSelectorRefersToPkgs TargetComponent{} = False
+targetSelectorRefersToPkgs TargetComponentUnknown{} = False
targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter
-targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter
+targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter
targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter
-targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter
-targetSelectorFilter TargetComponent{} = Nothing
-targetSelectorFilter TargetComponentUnknown{} = Nothing
+targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter
+targetSelectorFilter TargetComponent{} = Nothing
+targetSelectorFilter TargetComponentUnknown{} = Nothing
renderComponentName :: PackageName -> ComponentName -> String
renderComponentName pkgname (CLibName LMainLibName) = "library " ++ prettyShow pkgname
renderComponentName _ (CLibName (LSubLibName name)) = "library " ++ prettyShow name
-renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name
-renderComponentName _ (CExeName name) = "executable " ++ prettyShow name
-renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name
-renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name
+renderComponentName _ (CFLibName name) = "foreign library " ++ prettyShow name
+renderComponentName _ (CExeName name) = "executable " ++ prettyShow name
+renderComponentName _ (CTestName name) = "test suite " ++ prettyShow name
+renderComponentName _ (CBenchName name) = "benchmark " ++ prettyShow name
renderComponentKind :: Plural -> ComponentKind -> String
renderComponentKind Singular ckind = case ckind of
- LibKind -> "library" -- internal/sub libs?
- FLibKind -> "foreign library"
- ExeKind -> "executable"
- TestKind -> "test suite"
+ LibKind -> "library" -- internal/sub libs?
+ FLibKind -> "foreign library"
+ ExeKind -> "executable"
+ TestKind -> "test suite"
BenchKind -> "benchmark"
renderComponentKind Plural ckind = case ckind of
- LibKind -> "libraries" -- internal/sub libs?
- FLibKind -> "foreign libraries"
- ExeKind -> "executables"
- TestKind -> "test suites"
+ LibKind -> "libraries" -- internal/sub libs?
+ FLibKind -> "foreign libraries"
+ ExeKind -> "executables"
+ TestKind -> "test suites"
BenchKind -> "benchmarks"
-
-------------------------------------------------------
-- Rendering error messages for TargetProblem
--
@@ -218,95 +231,135 @@ reportTargetProblems verbosity verb =
-- | Default implementation of 'renderTargetProblem'.
renderTargetProblem
- :: String -- ^ verb
- -> (a -> String) -- ^ how to render custom problems
- -> TargetProblem a
- -> String
+ :: String
+ -- ^ verb
+ -> (a -> String)
+ -- ^ how to render custom problems
+ -> TargetProblem a
+ -> String
renderTargetProblem _verb f (CustomTargetProblem x) = f x
-renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) =
- renderTargetProblemNoneEnabled verb targetSelector targets
-renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) =
- renderTargetProblemNoTargets verb targetSelector
-
+renderTargetProblem verb _ (TargetProblemNoneEnabled targetSelector targets) =
+ renderTargetProblemNoneEnabled verb targetSelector targets
+renderTargetProblem verb _ (TargetProblemNoTargets targetSelector) =
+ renderTargetProblemNoTargets verb targetSelector
renderTargetProblem verb _ (TargetNotInProject pkgname) =
- "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "
- ++ "in this project (either directly or indirectly). If you want to add it "
- ++ "to the project then edit the cabal.project file."
-
+ "Cannot "
+ ++ verb
+ ++ " the package "
+ ++ prettyShow pkgname
+ ++ ", it is not "
+ ++ "in this project (either directly or indirectly). If you want to add it "
+ ++ "to the project then edit the cabal.project file."
renderTargetProblem verb _ (TargetAvailableInIndex pkgname) =
- "Cannot " ++ verb ++ " the package " ++ prettyShow pkgname ++ ", it is not "
- ++ "in this project (either directly or indirectly), but it is in the current "
- ++ "package index. If you want to add it to the project then edit the "
- ++ "cabal.project file."
-
+ "Cannot "
+ ++ verb
+ ++ " the package "
+ ++ prettyShow pkgname
+ ++ ", it is not "
+ ++ "in this project (either directly or indirectly), but it is in the current "
+ ++ "package index. If you want to add it to the project then edit the "
+ ++ "cabal.project file."
renderTargetProblem verb _ (TargetComponentNotProjectLocal pkgid cname _) =
- "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "
- ++ "package " ++ prettyShow pkgid ++ " is not local to the project, and cabal "
- ++ "does not currently support building test suites or benchmarks of "
- ++ "non-local dependencies. To run test suites or benchmarks from "
- ++ "dependencies you can unpack the package locally and adjust the "
- ++ "cabal.project file to include that package directory."
-
+ "Cannot "
+ ++ verb
+ ++ " the "
+ ++ showComponentName cname
+ ++ " because the "
+ ++ "package "
+ ++ prettyShow pkgid
+ ++ " is not local to the project, and cabal "
+ ++ "does not currently support building test suites or benchmarks of "
+ ++ "non-local dependencies. To run test suites or benchmarks from "
+ ++ "dependencies you can unpack the package locally and adjust the "
+ ++ "cabal.project file to include that package directory."
renderTargetProblem verb _ (TargetComponentNotBuildable pkgid cname _) =
- "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because it is "
- ++ "marked as 'buildable: False' within the '" ++ prettyShow (packageName pkgid)
- ++ ".cabal' file (at least for the current configuration). If you believe it "
- ++ "should be buildable then check the .cabal file to see if the buildable "
- ++ "property is conditional on flags. Alternatively you may simply have to "
- ++ "edit the .cabal file to declare it as buildable and fix any resulting "
- ++ "build problems."
-
+ "Cannot "
+ ++ verb
+ ++ " the "
+ ++ showComponentName cname
+ ++ " because it is "
+ ++ "marked as 'buildable: False' within the '"
+ ++ prettyShow (packageName pkgid)
+ ++ ".cabal' file (at least for the current configuration). If you believe it "
+ ++ "should be buildable then check the .cabal file to see if the buildable "
+ ++ "property is conditional on flags. Alternatively you may simply have to "
+ ++ "edit the .cabal file to declare it as buildable and fix any resulting "
+ ++ "build problems."
renderTargetProblem verb _ (TargetOptionalStanzaDisabledByUser _ cname _) =
- "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because "
- ++ "building " ++ compkinds ++ " has been explicitly disabled in the "
- ++ "configuration. You can adjust this configuration in the "
- ++ "cabal.project{.local} file either for all packages in the project or on "
- ++ "a per-package basis. Note that if you do not explicitly disable "
- ++ compkinds ++ " then the solver will merely try to make a plan with "
- ++ "them available, so you may wish to explicitly enable them which will "
- ++ "require the solver to find a plan with them available or to fail with an "
- ++ "explanation."
- where
- compkinds = renderComponentKind Plural (componentKind cname)
-
+ "Cannot "
+ ++ verb
+ ++ " the "
+ ++ showComponentName cname
+ ++ " because "
+ ++ "building "
+ ++ compkinds
+ ++ " has been explicitly disabled in the "
+ ++ "configuration. You can adjust this configuration in the "
+ ++ "cabal.project{.local} file either for all packages in the project or on "
+ ++ "a per-package basis. Note that if you do not explicitly disable "
+ ++ compkinds
+ ++ " then the solver will merely try to make a plan with "
+ ++ "them available, so you may wish to explicitly enable them which will "
+ ++ "require the solver to find a plan with them available or to fail with an "
+ ++ "explanation."
+ where
+ compkinds = renderComponentKind Plural (componentKind cname)
renderTargetProblem verb _ (TargetOptionalStanzaDisabledBySolver pkgid cname _) =
- "Cannot " ++ verb ++ " the " ++ showComponentName cname ++ " because the "
- ++ "solver did not find a plan that included the " ++ compkinds
- ++ " for " ++ prettyShow pkgid ++ ". It is probably worth trying again with "
- ++ compkinds ++ " explicitly enabled in the configuration in the "
- ++ "cabal.project{.local} file. This will ask the solver to find a plan with "
- ++ "the " ++ compkinds ++ " available. It will either fail with an "
- ++ "explanation or find a different plan that uses different versions of some "
- ++ "other packages. Use the '--dry-run' flag to see package versions and "
- ++ "check that you are happy with the choices."
- where
- compkinds = renderComponentKind Plural (componentKind cname)
-
+ "Cannot "
+ ++ verb
+ ++ " the "
+ ++ showComponentName cname
+ ++ " because the "
+ ++ "solver did not find a plan that included the "
+ ++ compkinds
+ ++ " for "
+ ++ prettyShow pkgid
+ ++ ". It is probably worth trying again with "
+ ++ compkinds
+ ++ " explicitly enabled in the configuration in the "
+ ++ "cabal.project{.local} file. This will ask the solver to find a plan with "
+ ++ "the "
+ ++ compkinds
+ ++ " available. It will either fail with an "
+ ++ "explanation or find a different plan that uses different versions of some "
+ ++ "other packages. Use the '--dry-run' flag to see package versions and "
+ ++ "check that you are happy with the choices."
+ where
+ compkinds = renderComponentKind Plural (componentKind cname)
renderTargetProblem verb _ (TargetProblemUnknownComponent pkgname ecname) =
- "Cannot " ++ verb ++ " the "
- ++ (case ecname of
- Left ucname -> "component " ++ prettyShow ucname
- Right cname -> renderComponentName pkgname cname)
- ++ " from the package " ++ prettyShow pkgname
- ++ ", because the package does not contain a "
- ++ (case ecname of
- Left _ -> "component"
- Right cname -> renderComponentKind Singular (componentKind cname))
- ++ " with that name."
-
+ "Cannot "
+ ++ verb
+ ++ " the "
+ ++ ( case ecname of
+ Left ucname -> "component " ++ prettyShow ucname
+ Right cname -> renderComponentName pkgname cname
+ )
+ ++ " from the package "
+ ++ prettyShow pkgname
+ ++ ", because the package does not contain a "
+ ++ ( case ecname of
+ Left _ -> "component"
+ Right cname -> renderComponentKind Singular (componentKind cname)
+ )
+ ++ " with that name."
renderTargetProblem verb _ (TargetProblemNoSuchPackage pkgid) =
- "Internal error when trying to " ++ verb ++ " the package "
- ++ prettyShow pkgid ++ ". The package is not in the set of available targets "
- ++ "for the project plan, which would suggest an inconsistency "
- ++ "between readTargetSelectors and resolveTargets."
-
+ "Internal error when trying to "
+ ++ verb
+ ++ " the package "
+ ++ prettyShow pkgid
+ ++ ". The package is not in the set of available targets "
+ ++ "for the project plan, which would suggest an inconsistency "
+ ++ "between readTargetSelectors and resolveTargets."
renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) =
- "Internal error when trying to " ++ verb ++ " the "
- ++ showComponentName cname ++ " from the package " ++ prettyShow pkgid
- ++ ". The package,component pair is not in the set of available targets "
- ++ "for the project plan, which would suggest an inconsistency "
- ++ "between readTargetSelectors and resolveTargets."
-
+ "Internal error when trying to "
+ ++ verb
+ ++ " the "
+ ++ showComponentName cname
+ ++ " from the package "
+ ++ prettyShow pkgid
+ ++ ". The package,component pair is not in the set of available targets "
+ ++ "for the project plan, which would suggest an inconsistency "
+ ++ "between readTargetSelectors and resolveTargets."
------------------------------------------------------------
-- Rendering error messages for TargetProblemNoneEnabled
@@ -314,65 +367,79 @@ renderTargetProblem verb _ (TargetProblemNoSuchComponent pkgid cname) =
-- | Several commands have a @TargetProblemNoneEnabled@ problem constructor.
-- This renders an error message for those cases.
---
-renderTargetProblemNoneEnabled :: String
- -> TargetSelector
- -> [AvailableTarget ()]
- -> String
+renderTargetProblemNoneEnabled
+ :: String
+ -> TargetSelector
+ -> [AvailableTarget ()]
+ -> String
renderTargetProblemNoneEnabled verb targetSelector targets =
- "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector
- ++ " because none of the components are available to build: "
- ++ renderListSemiAnd
- [ case (status, mstanza) of
+ "Cannot "
+ ++ verb
+ ++ " "
+ ++ renderTargetSelector targetSelector
+ ++ " because none of the components are available to build: "
+ ++ renderListSemiAnd
+ [ case (status, mstanza) of
(TargetDisabledByUser, Just stanza) ->
- renderListCommaAnd
- [ "the " ++ showComponentName availableTargetComponentName
- | AvailableTarget {availableTargetComponentName} <- targets' ]
- ++ plural (listPlural targets') " is " " are "
- ++ " not available because building "
- ++ renderOptionalStanza Plural stanza
- ++ " has been disabled in the configuration"
+ renderListCommaAnd
+ [ "the " ++ showComponentName availableTargetComponentName
+ | AvailableTarget{availableTargetComponentName} <- targets'
+ ]
+ ++ plural (listPlural targets') " is " " are "
+ ++ " not available because building "
+ ++ renderOptionalStanza Plural stanza
+ ++ " has been disabled in the configuration"
(TargetDisabledBySolver, Just stanza) ->
- renderListCommaAnd
- [ "the " ++ showComponentName availableTargetComponentName
- | AvailableTarget {availableTargetComponentName} <- targets' ]
- ++ plural (listPlural targets') " is " " are "
- ++ "not available because the solver picked a plan that does not "
- ++ "include the " ++ renderOptionalStanza Plural stanza
- ++ ", perhaps because no such plan exists. To see the error message "
- ++ "explaining the problems with such plans, force the solver to "
- ++ "include the " ++ renderOptionalStanza Plural stanza ++ " for all "
- ++ "packages, by adding the line 'tests: True' to the "
- ++ "'cabal.project.local' file."
+ renderListCommaAnd
+ [ "the " ++ showComponentName availableTargetComponentName
+ | AvailableTarget{availableTargetComponentName} <- targets'
+ ]
+ ++ plural (listPlural targets') " is " " are "
+ ++ "not available because the solver picked a plan that does not "
+ ++ "include the "
+ ++ renderOptionalStanza Plural stanza
+ ++ ", perhaps because no such plan exists. To see the error message "
+ ++ "explaining the problems with such plans, force the solver to "
+ ++ "include the "
+ ++ renderOptionalStanza Plural stanza
+ ++ " for all "
+ ++ "packages, by adding the line 'tests: True' to the "
+ ++ "'cabal.project.local' file."
(TargetNotBuildable, _) ->
- renderListCommaAnd
- [ "the " ++ showComponentName availableTargetComponentName
- | AvailableTarget {availableTargetComponentName} <- targets' ]
- ++ plural (listPlural targets') " is " " are all "
- ++ "marked as 'buildable: False'"
+ renderListCommaAnd
+ [ "the " ++ showComponentName availableTargetComponentName
+ | AvailableTarget{availableTargetComponentName} <- targets'
+ ]
+ ++ plural (listPlural targets') " is " " are all "
+ ++ "marked as 'buildable: False'"
(TargetNotLocal, _) ->
- renderListCommaAnd
- [ "the " ++ showComponentName availableTargetComponentName
- | AvailableTarget {availableTargetComponentName} <- targets' ]
- ++ " cannot be built because cabal does not currently support "
- ++ "building test suites or benchmarks of non-local dependencies"
+ renderListCommaAnd
+ [ "the " ++ showComponentName availableTargetComponentName
+ | AvailableTarget{availableTargetComponentName} <- targets'
+ ]
+ ++ " cannot be built because cabal does not currently support "
+ ++ "building test suites or benchmarks of non-local dependencies"
(TargetBuildable () TargetNotRequestedByDefault, Just stanza) ->
- renderListCommaAnd
- [ "the " ++ showComponentName availableTargetComponentName
- | AvailableTarget {availableTargetComponentName} <- targets' ]
- ++ " will not be built because " ++ renderOptionalStanza Plural stanza
- ++ " are not built by default in the current configuration (but you "
- ++ "can still build them specifically)" --TODO: say how
- _ -> error $ "renderBuildTargetProblem: unexpected status "
- ++ show (status, mstanza)
- | ((status, mstanza), targets') <- sortGroupOn groupingKey targets
- ]
+ renderListCommaAnd
+ [ "the " ++ showComponentName availableTargetComponentName
+ | AvailableTarget{availableTargetComponentName} <- targets'
+ ]
+ ++ " will not be built because "
+ ++ renderOptionalStanza Plural stanza
+ ++ " are not built by default in the current configuration (but you "
+ ++ "can still build them specifically)" -- TODO: say how
+ _ ->
+ error $
+ "renderBuildTargetProblem: unexpected status "
+ ++ show (status, mstanza)
+ | ((status, mstanza), targets') <- sortGroupOn groupingKey targets
+ ]
where
groupingKey t =
( availableTargetStatus t
, case availableTargetStatus t of
TargetNotBuildable -> Nothing
- TargetNotLocal -> Nothing
+ TargetNotLocal -> Nothing
_ -> optionalStanza (availableTargetComponentName t)
)
@@ -382,34 +449,39 @@ renderTargetProblemNoneEnabled verb targetSelector targets =
-- | Several commands have a @TargetProblemNoTargets@ problem constructor.
-- This renders an error message for those cases.
---
renderTargetProblemNoTargets :: String -> TargetSelector -> String
renderTargetProblemNoTargets verb targetSelector =
- "Cannot " ++ verb ++ " " ++ renderTargetSelector targetSelector
- ++ " because " ++ reason targetSelector ++ ". "
- ++ "Check the .cabal "
- ++ plural (targetSelectorPluralPkgs targetSelector)
+ "Cannot "
+ ++ verb
+ ++ " "
+ ++ renderTargetSelector targetSelector
+ ++ " because "
+ ++ reason targetSelector
+ ++ ". "
+ ++ "Check the .cabal "
+ ++ plural
+ (targetSelectorPluralPkgs targetSelector)
"file for the package and make sure that it properly declares "
"files for the packages and make sure that they properly declare "
- ++ "the components that you expect."
+ ++ "the components that you expect."
where
reason (TargetPackage _ _ Nothing) =
- "it does not contain any components at all"
+ "it does not contain any components at all"
reason (TargetPackage _ _ (Just kfilter)) =
- "it does not contain any " ++ renderComponentKind Plural kfilter
+ "it does not contain any " ++ renderComponentKind Plural kfilter
reason (TargetPackageNamed _ Nothing) =
- "it does not contain any components at all"
+ "it does not contain any components at all"
reason (TargetPackageNamed _ (Just kfilter)) =
- "it does not contain any " ++ renderComponentKind Plural kfilter
+ "it does not contain any " ++ renderComponentKind Plural kfilter
reason (TargetAllPackages Nothing) =
- "none of them contain any components at all"
+ "none of them contain any components at all"
reason (TargetAllPackages (Just kfilter)) =
- "none of the packages contain any "
- ++ renderComponentKind Plural kfilter
+ "none of the packages contain any "
+ ++ renderComponentKind Plural kfilter
reason ts@TargetComponent{} =
- error $ "renderTargetProblemNoTargets: " ++ show ts
+ error $ "renderTargetProblemNoTargets: " ++ show ts
reason ts@TargetComponentUnknown{} =
- error $ "renderTargetProblemNoTargets: " ++ show ts
+ error $ "renderTargetProblemNoTargets: " ++ show ts
-----------------------------------------------------------
-- Rendering error messages for CannotPruneDependencies
@@ -417,13 +489,16 @@ renderTargetProblemNoTargets verb targetSelector =
renderCannotPruneDependencies :: CannotPruneDependencies -> String
renderCannotPruneDependencies (CannotPruneDependencies brokenPackages) =
- "Cannot select only the dependencies (as requested by the "
- ++ "'--only-dependencies' flag), "
- ++ (case pkgids of
+ "Cannot select only the dependencies (as requested by the "
+ ++ "'--only-dependencies' flag), "
+ ++ ( case pkgids of
[pkgid] -> "the package " ++ prettyShow pkgid ++ " is "
- _ -> "the packages "
- ++ renderListCommaAnd (map prettyShow pkgids) ++ " are ")
- ++ "required by a dependency of one of the other targets."
+ _ ->
+ "the packages "
+ ++ renderListCommaAnd (map prettyShow pkgids)
+ ++ " are "
+ )
+ ++ "required by a dependency of one of the other targets."
where
-- throw away the details and just list the deps that are needed
pkgids :: [PackageId]
diff --git a/cabal-install/src/Distribution/Client/CmdExec.hs b/cabal-install/src/Distribution/Client/CmdExec.hs
index 802205924982094acc1bded0f9df1d651a4dec93..9ac7a101fc8b77139881cf4cefed05836c0e12a2 100644
--- a/cabal-install/src/Distribution/Client/CmdExec.hs
+++ b/cabal-install/src/Distribution/Client/CmdExec.hs
@@ -1,4 +1,7 @@
-------------------------------------------------------------------------------
+-------------------------------------------------------------------------------
+{-# LANGUAGE RecordWildCards #-}
+
-- |
-- Module : Distribution.Client.Exec
-- Maintainer : cabal-devel@haskell.org
@@ -6,153 +9,165 @@
--
-- Implementation of the 'v2-exec' command for running an arbitrary executable
-- in an environment suited to the part of the store built for a project.
--------------------------------------------------------------------------------
-
-{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.CmdExec
( execAction
, execCommand
) where
import Distribution.Client.DistDirLayout
- ( DistDirLayout(..)
+ ( DistDirLayout (..)
)
import Distribution.Client.InstallPlan
- ( GenericPlanPackage(..)
+ ( GenericPlanPackage (..)
, toGraph
)
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
-import Distribution.Client.Setup
- ( ConfigFlags(configVerbosity)
- , GlobalFlags
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
)
import Distribution.Client.ProjectFlags
( removeIgnoreProjectOption
)
import Distribution.Client.ProjectOrchestration
- ( ProjectBuildContext(..)
- , runProjectPreBuildPhase
- , CurrentCommand(..)
- , establishProjectBaseContext
- , distDirLayout
+ ( BuildTimeSettings (..)
+ , CurrentCommand (..)
+ , ProjectBaseContext (..)
+ , ProjectBuildContext (..)
, commandLineFlagsToProjectConfig
- , ProjectBaseContext(..)
- , BuildTimeSettings(..)
+ , distDirLayout
+ , establishProjectBaseContext
+ , runProjectPreBuildPhase
)
import Distribution.Client.ProjectPlanOutput
- ( updatePostBuildProjectStatus
- , createPackageEnvironment
+ ( PostBuildProjectStatus
, argsEquivalentOfGhcEnvironmentFile
- , PostBuildProjectStatus
+ , createPackageEnvironment
+ , updatePostBuildProjectStatus
)
-import qualified Distribution.Client.ProjectPlanning as Planning
import Distribution.Client.ProjectPlanning
( ElaboratedInstallPlan
- , ElaboratedSharedConfig(..)
+ , ElaboratedSharedConfig (..)
+ )
+import qualified Distribution.Client.ProjectPlanning as Planning
+import Distribution.Client.Setup
+ ( ConfigFlags (configVerbosity)
+ , GlobalFlags
)
import Distribution.Simple.Command
- ( CommandUI(..) )
+ ( CommandUI (..)
+ )
+import Distribution.Simple.Flag
+ ( fromFlagOrDefault
+ )
+import Distribution.Simple.GHC
+ ( GhcImplInfo (supportsPkgEnvFiles)
+ , getImplInfo
+ )
import Distribution.Simple.Program.Db
- ( modifyProgramSearchPath
+ ( configuredPrograms
+ , modifyProgramSearchPath
, requireProgram
- , configuredPrograms
)
import Distribution.Simple.Program.Find
- ( ProgramSearchPathEntry(..)
+ ( ProgramSearchPathEntry (..)
)
import Distribution.Simple.Program.Run
( programInvocation
, runProgramInvocation
)
import Distribution.Simple.Program.Types
- ( programOverrideEnv
+ ( ConfiguredProgram
, programDefaultArgs
+ , programOverrideEnv
, programPath
, simpleProgram
- , ConfiguredProgram
- )
-import Distribution.Simple.GHC
- ( getImplInfo
- , GhcImplInfo(supportsPkgEnvFiles) )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault
)
import Distribution.Simple.Utils
- ( die'
+ ( createDirectoryIfMissingVerbose
+ , die'
, info
- , createDirectoryIfMissingVerbose
+ , notice
, withTempDirectory
, wrapText
- , notice
)
import Distribution.Verbosity
( normal
)
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import qualified Data.Set as S
import qualified Data.Map as M
+import qualified Data.Set as S
execCommand :: CommandUI (NixStyleFlags ())
-execCommand = CommandUI
- { commandName = "v2-exec"
- , commandSynopsis = "Give a command access to the store."
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n"
- , commandDescription = Just $ \pname -> wrapText $
- "During development it is often useful to run build tasks and perform"
- ++ " one-off program executions to experiment with the behavior of build"
- ++ " tools. It is convenient to run these tools in the same way " ++ pname
- ++ " itself would. The `" ++ pname ++ " v2-exec` command provides a way to"
- ++ " do so.\n"
- ++ "\n"
- ++ "Compiler tools will be configured to see the same subset of the store"
- ++ " that builds would see. The PATH is modified to make all executables in"
- ++ " the dependency tree available (provided they have been built already)."
- ++ " Commands are also rewritten in the way cabal itself would. For"
- ++ " example, `" ++ pname ++ " v2-exec ghc` will consult the configuration"
- ++ " to choose an appropriate version of ghc and to include any"
- ++ " ghc-specific flags requested."
- , commandNotes = Nothing
- , commandOptions = removeIgnoreProjectOption
- . nixStyleOptions (const [])
- , commandDefaultFlags = defaultNixStyleFlags ()
- }
+execCommand =
+ CommandUI
+ { commandName = "v2-exec"
+ , commandSynopsis = "Give a command access to the store."
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " v2-exec [FLAGS] [--] COMMAND [--] [ARGS]\n"
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "During development it is often useful to run build tasks and perform"
+ ++ " one-off program executions to experiment with the behavior of build"
+ ++ " tools. It is convenient to run these tools in the same way "
+ ++ pname
+ ++ " itself would. The `"
+ ++ pname
+ ++ " v2-exec` command provides a way to"
+ ++ " do so.\n"
+ ++ "\n"
+ ++ "Compiler tools will be configured to see the same subset of the store"
+ ++ " that builds would see. The PATH is modified to make all executables in"
+ ++ " the dependency tree available (provided they have been built already)."
+ ++ " Commands are also rewritten in the way cabal itself would. For"
+ ++ " example, `"
+ ++ pname
+ ++ " v2-exec ghc` will consult the configuration"
+ ++ " to choose an appropriate version of ghc and to include any"
+ ++ " ghc-specific flags requested."
+ , commandNotes = Nothing
+ , commandOptions =
+ removeIgnoreProjectOption
+ . nixStyleOptions (const [])
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ }
execAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-execAction flags@NixStyleFlags {..} extraArgs globalFlags = do
-
+execAction flags@NixStyleFlags{..} extraArgs globalFlags = do
baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
-- To set up the environment, we'd like to select the libraries in our
-- dependency tree that we've already built. So first we set up an install
-- plan, but we walk the dependency tree without first executing the plan.
- buildCtx <- runProjectPreBuildPhase
- verbosity
- baseCtx
- (\plan -> return (plan, M.empty))
+ buildCtx <-
+ runProjectPreBuildPhase
+ verbosity
+ baseCtx
+ (\plan -> return (plan, M.empty))
-- We use the build status below to decide what libraries to include in the
-- compiler environment, but we don't want to actually build anything. So we
-- pass mempty to indicate that nothing happened and we just want the current
-- status.
- buildStatus <- updatePostBuildProjectStatus
- verbosity
- (distDirLayout baseCtx)
- (elaboratedPlanOriginal buildCtx)
- (pkgsBuildStatus buildCtx)
- mempty
+ buildStatus <-
+ updatePostBuildProjectStatus
+ verbosity
+ (distDirLayout baseCtx)
+ (elaboratedPlanOriginal buildCtx)
+ (pkgsBuildStatus buildCtx)
+ mempty
-- Some dependencies may have executables. Let's put those on the PATH.
extraPaths <- pathAdditions verbosity baseCtx buildCtx
- let programDb = modifyProgramSearchPath
- (map ProgramSearchPathDir extraPaths ++)
- . pkgConfigCompilerProgs
- . elaboratedShared
- $ buildCtx
+ let programDb =
+ modifyProgramSearchPath
+ (map ProgramSearchPathDir extraPaths ++)
+ . pkgConfigCompilerProgs
+ . elaboratedShared
+ $ buildCtx
-- Now that we have the packages, set up the environment. We accomplish this
-- by creating an environment file that selects the databases and packages we
@@ -164,7 +179,7 @@ execAction flags@NixStyleFlags {..} extraArgs globalFlags = do
envFilesSupported = supportsPkgEnvFiles (getImplInfo compiler)
case extraArgs of
[] -> die' verbosity "Please specify an executable to run"
- exe:args -> do
+ exe : args -> do
(program, _) <- requireProgram verbosity (simpleProgram exe) programDb
let argOverrides =
argsEquivalentOfGhcEnvironmentFile
@@ -172,89 +187,103 @@ execAction flags@NixStyleFlags {..} extraArgs globalFlags = do
(distDirLayout baseCtx)
(elaboratedPlanOriginal buildCtx)
buildStatus
- programIsConfiguredCompiler = matchCompilerPath
- (elaboratedShared buildCtx)
- program
+ programIsConfiguredCompiler =
+ matchCompilerPath
+ (elaboratedShared buildCtx)
+ program
argOverrides' =
if envFilesSupported
- || not programIsConfiguredCompiler
- then []
- else argOverrides
+ || not programIsConfiguredCompiler
+ then []
+ else argOverrides
- (if envFilesSupported
- then withTempEnvFile verbosity baseCtx buildCtx buildStatus
- else \f -> f []) $ \envOverrides -> do
- let program' = withOverrides
- envOverrides
- argOverrides'
- program
- invocation = programInvocation program' args
- dryRun = buildSettingDryRun (buildSettings baseCtx)
+ ( if envFilesSupported
+ then withTempEnvFile verbosity baseCtx buildCtx buildStatus
+ else \f -> f []
+ )
+ $ \envOverrides -> do
+ let program' =
+ withOverrides
+ envOverrides
+ argOverrides'
+ program
+ invocation = programInvocation program' args
+ dryRun =
+ buildSettingDryRun (buildSettings baseCtx)
|| buildSettingOnlyDownload (buildSettings baseCtx)
- if dryRun
- then notice verbosity "Running of executable suppressed by flag(s)"
- else runProgramInvocation verbosity invocation
+ if dryRun
+ then notice verbosity "Running of executable suppressed by flag(s)"
+ else runProgramInvocation verbosity invocation
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
- cliConfig = commandLineFlagsToProjectConfig globalFlags flags
- mempty -- ClientInstallFlags, not needed here
- withOverrides env args program = program
- { programOverrideEnv = programOverrideEnv program ++ env
- , programDefaultArgs = programDefaultArgs program ++ args}
+ cliConfig =
+ commandLineFlagsToProjectConfig
+ globalFlags
+ flags
+ mempty -- ClientInstallFlags, not needed here
+ withOverrides env args program =
+ program
+ { programOverrideEnv = programOverrideEnv program ++ env
+ , programDefaultArgs = programDefaultArgs program ++ args
+ }
matchCompilerPath :: ElaboratedSharedConfig -> ConfiguredProgram -> Bool
matchCompilerPath elaboratedShared program =
programPath program
- `elem`
- (programPath <$> configuredCompilers)
+ `elem` (programPath <$> configuredCompilers)
where
configuredCompilers = configuredPrograms $ pkgConfigCompilerProgs elaboratedShared
-- | Execute an action with a temporary .ghc.environment file reflecting the
-- current environment. The action takes an environment containing the env
-- variable which points ghc to the file.
-withTempEnvFile :: Verbosity
- -> ProjectBaseContext
- -> ProjectBuildContext
- -> PostBuildProjectStatus
- -> ([(String, Maybe String)] -> IO a)
- -> IO a
+withTempEnvFile
+ :: Verbosity
+ -> ProjectBaseContext
+ -> ProjectBuildContext
+ -> PostBuildProjectStatus
+ -> ([(String, Maybe String)] -> IO a)
+ -> IO a
withTempEnvFile verbosity baseCtx buildCtx buildStatus action = do
createDirectoryIfMissingVerbose verbosity True (distTempDirectory (distDirLayout baseCtx))
withTempDirectory
- verbosity
- (distTempDirectory (distDirLayout baseCtx))
- "environment."
- (\tmpDir -> do
- envOverrides <- createPackageEnvironment
- verbosity
- tmpDir
- (elaboratedPlanToExecute buildCtx)
- (elaboratedShared buildCtx)
- buildStatus
- action envOverrides)
+ verbosity
+ (distTempDirectory (distDirLayout baseCtx))
+ "environment."
+ ( \tmpDir -> do
+ envOverrides <-
+ createPackageEnvironment
+ verbosity
+ tmpDir
+ (elaboratedPlanToExecute buildCtx)
+ (elaboratedShared buildCtx)
+ buildStatus
+ action envOverrides
+ )
pathAdditions :: Verbosity -> ProjectBaseContext -> ProjectBuildContext -> IO [FilePath]
-pathAdditions verbosity ProjectBaseContext{..}ProjectBuildContext{..} = do
- info verbosity . unlines $ "Including the following directories in PATH:"
- : paths
+pathAdditions verbosity ProjectBaseContext{..} ProjectBuildContext{..} = do
+ info verbosity . unlines $
+ "Including the following directories in PATH:"
+ : paths
return paths
where
- paths = S.toList
- $ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute
+ paths =
+ S.toList $
+ binDirectories distDirLayout elaboratedShared elaboratedPlanToExecute
binDirectories
:: DistDirLayout
-> ElaboratedSharedConfig
-> ElaboratedInstallPlan
-> Set FilePath
-binDirectories layout config = fromElaboratedInstallPlan where
- fromElaboratedInstallPlan = fromGraph . toGraph
- fromGraph = foldMap fromPlan
- fromSrcPkg = S.fromList . Planning.binDirectories layout config
-
- fromPlan (PreExisting _) = mempty
- fromPlan (Configured pkg) = fromSrcPkg pkg
- fromPlan (Installed pkg) = fromSrcPkg pkg
+binDirectories layout config = fromElaboratedInstallPlan
+ where
+ fromElaboratedInstallPlan = fromGraph . toGraph
+ fromGraph = foldMap fromPlan
+ fromSrcPkg = S.fromList . Planning.binDirectories layout config
+ fromPlan (PreExisting _) = mempty
+ fromPlan (Configured pkg) = fromSrcPkg pkg
+ fromPlan (Installed pkg) = fromSrcPkg pkg
diff --git a/cabal-install/src/Distribution/Client/CmdFreeze.hs b/cabal-install/src/Distribution/Client/CmdFreeze.hs
index 273e90468330deb1417a6178a840d472f33bccd2..db8ef81fca2ff78b4157115ee3a05f4c1607dfaa 100644
--- a/cabal-install/src/Distribution/Client/CmdFreeze.hs
+++ b/cabal-install/src/Distribution/Client/CmdFreeze.hs
@@ -1,92 +1,120 @@
-{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: freeze
---
-module Distribution.Client.CmdFreeze (
- freezeCommand,
- freezeAction,
+module Distribution.Client.CmdFreeze
+ ( freezeCommand
+ , freezeAction
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
+import Distribution.Client.DistDirLayout
+ ( DistDirLayout (distProjectFile)
+ )
+import Distribution.Client.IndexUtils (ActiveRepos, TotalIndexState, filterSkippedActiveRepos)
+import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
+import Distribution.Client.ProjectConfig
+ ( ProjectConfig (..)
+ , ProjectConfigShared (..)
+ , writeProjectLocalFreezeConfig
+ )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
-import Distribution.Client.ProjectConfig
- ( ProjectConfig(..), ProjectConfigShared(..)
- , writeProjectLocalFreezeConfig )
-import Distribution.Client.IndexUtils (TotalIndexState, ActiveRepos, filterSkippedActiveRepos)
import Distribution.Client.Targets
- ( UserQualifier(..), UserConstraintScope(..), UserConstraint(..) )
-import Distribution.Solver.Types.PackageConstraint
- ( PackageProperty(..) )
+ ( UserConstraint (..)
+ , UserConstraintScope (..)
+ , UserQualifier (..)
+ )
import Distribution.Solver.Types.ConstraintSource
- ( ConstraintSource(..) )
-import Distribution.Client.DistDirLayout
- ( DistDirLayout(distProjectFile) )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-
+ ( ConstraintSource (..)
+ )
+import Distribution.Solver.Types.PackageConstraint
+ ( PackageProperty (..)
+ )
+import Distribution.Client.Setup
+ ( ConfigFlags (..)
+ , GlobalFlags
+ )
import Distribution.Package
- ( PackageName, packageName, packageVersion )
-import Distribution.Version
- ( VersionRange, thisVersion
- , unionVersionRanges, simplifyVersionRange )
+ ( PackageName
+ , packageName
+ , packageVersion
+ )
import Distribution.PackageDescription
- ( FlagAssignment, nullFlagAssignment )
-import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..) )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault )
-import Distribution.Simple.Flag (Flag (..))
+ ( FlagAssignment
+ , nullFlagAssignment
+ )
+import Distribution.Simple.Flag (Flag (..), fromFlagOrDefault)
import Distribution.Simple.Utils
- ( die', notice, wrapText )
+ ( die'
+ , notice
+ , wrapText
+ )
import Distribution.Verbosity
- ( normal )
+ ( normal
+ )
+import Distribution.Version
+ ( VersionRange
+ , simplifyVersionRange
+ , thisVersion
+ , unionVersionRanges
+ )
import qualified Data.Map as Map
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives )
+ ( CommandUI (..)
+ , usageAlternatives
+ )
freezeCommand :: CommandUI (NixStyleFlags ())
-freezeCommand = CommandUI {
- commandName = "v2-freeze",
- commandSynopsis = "Freeze dependencies.",
- commandUsage = usageAlternatives "v2-freeze" [ "[FLAGS]" ],
- commandDescription = Just $ \_ -> wrapText $
- "The project configuration is frozen so that it will be reproducible "
- ++ "in future.\n\n"
-
- ++ "The precise dependency configuration for the project is written to "
- ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "
- ++ "'--project-file' is specified). This file extends the configuration "
- ++ "from the 'cabal.project' file and thus is used as the project "
- ++ "configuration for all other commands (such as 'v2-build', "
- ++ "'v2-repl' etc).\n\n"
-
- ++ "The freeze file can be kept in source control. To make small "
- ++ "adjustments it may be edited manually, or to make bigger changes "
- ++ "you may wish to delete the file and re-freeze. For more control, "
- ++ "one approach is to try variations using 'v2-build --dry-run' with "
- ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "
- ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "
- ++ "with the same set of flags.",
-
- commandNotes = Just $ \pname ->
+freezeCommand =
+ CommandUI
+ { commandName = "v2-freeze"
+ , commandSynopsis = "Freeze dependencies."
+ , commandUsage = usageAlternatives "v2-freeze" ["[FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "The project configuration is frozen so that it will be reproducible "
+ ++ "in future.\n\n"
+ ++ "The precise dependency configuration for the project is written to "
+ ++ "the 'cabal.project.freeze' file (or '$project_file.freeze' if "
+ ++ "'--project-file' is specified). This file extends the configuration "
+ ++ "from the 'cabal.project' file and thus is used as the project "
+ ++ "configuration for all other commands (such as 'v2-build', "
+ ++ "'v2-repl' etc).\n\n"
+ ++ "The freeze file can be kept in source control. To make small "
+ ++ "adjustments it may be edited manually, or to make bigger changes "
+ ++ "you may wish to delete the file and re-freeze. For more control, "
+ ++ "one approach is to try variations using 'v2-build --dry-run' with "
+ ++ "solver flags such as '--constraint=\"pkg < 1.2\"' and once you have "
+ ++ "a satisfactory solution to freeze it using the 'v2-freeze' command "
+ ++ "with the same set of flags."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v2-freeze\n"
- ++ " Freeze the configuration of the current project\n\n"
- ++ " " ++ pname ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"
- ++ " Check what a solution with the given constraints would look like\n"
- ++ " " ++ pname ++ " v2-freeze --constraint=\"aeson < 1\"\n"
- ++ " Freeze a solution using the given constraints\n"
-
- , commandDefaultFlags = defaultNixStyleFlags ()
- , commandOptions = nixStyleOptions (const [])
- }
+ ++ " "
+ ++ pname
+ ++ " v2-freeze\n"
+ ++ " Freeze the configuration of the current project\n\n"
+ ++ " "
+ ++ pname
+ ++ " v2-build --dry-run --constraint=\"aeson < 1\"\n"
+ ++ " Check what a solution with the given constraints would look like\n"
+ ++ " "
+ ++ pname
+ ++ " v2-freeze --constraint=\"aeson < 1\"\n"
+ ++ " Freeze a solution using the given constraints\n"
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ , commandOptions = nixStyleOptions (const [])
+ }
-- | To a first approximation, the @freeze@ command runs the first phase of
-- the @build@ command where we bring the install plan up to date, and then
@@ -94,60 +122,66 @@ freezeCommand = CommandUI {
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
freezeAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-freezeAction flags@NixStyleFlags {..} extraArgs globalFlags = do
-
- unless (null extraArgs) $
- die' verbosity $ "'freeze' doesn't take any extra arguments: "
- ++ unwords extraArgs
-
- ProjectBaseContext {
- distDirLayout,
- cabalDirLayout,
- projectConfig,
- localPackages,
- buildSettings
- } <- establishProjectBaseContext verbosity cliConfig OtherCommand
-
- (_, elaboratedPlan, _, totalIndexState, activeRepos) <-
- rebuildInstallPlan verbosity
- distDirLayout cabalDirLayout
- projectConfig
- localPackages
- Nothing
-
- let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos
- dryRun = buildSettingDryRun buildSettings
- || buildSettingOnlyDownload buildSettings
-
- if dryRun
- then notice verbosity "Freeze file not written due to flag(s)"
- else do
- writeProjectLocalFreezeConfig distDirLayout freezeConfig
- notice verbosity $
- "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
+freezeAction flags@NixStyleFlags{..} extraArgs globalFlags = do
+ unless (null extraArgs) $
+ die' verbosity $
+ "'freeze' doesn't take any extra arguments: "
+ ++ unwords extraArgs
+
+ ProjectBaseContext
+ { distDirLayout
+ , cabalDirLayout
+ , projectConfig
+ , localPackages
+ , buildSettings
+ } <-
+ establishProjectBaseContext verbosity cliConfig OtherCommand
+
+ (_, elaboratedPlan, _, totalIndexState, activeRepos) <-
+ rebuildInstallPlan
+ verbosity
+ distDirLayout
+ cabalDirLayout
+ projectConfig
+ localPackages
+ Nothing
+ let freezeConfig = projectFreezeConfig elaboratedPlan totalIndexState activeRepos
+ dryRun =
+ buildSettingDryRun buildSettings
+ || buildSettingOnlyDownload buildSettings
+
+ if dryRun
+ then notice verbosity "Freeze file not written due to flag(s)"
+ else do
+ writeProjectLocalFreezeConfig distDirLayout freezeConfig
+ notice verbosity $
+ "Wrote freeze file: " ++ distProjectFile distDirLayout "freeze"
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
- cliConfig = commandLineFlagsToProjectConfig globalFlags flags
- mempty -- ClientInstallFlags, not needed here
+ cliConfig =
+ commandLineFlagsToProjectConfig
+ globalFlags
+ flags
+ mempty -- ClientInstallFlags, not needed here
-- | Given the install plan, produce a config value with constraints that
-- freezes the versions of packages used in the plan.
---
projectFreezeConfig
- :: ElaboratedInstallPlan
- -> TotalIndexState
- -> ActiveRepos
- -> ProjectConfig
-projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty
- { projectConfigShared = mempty
- { projectConfigConstraints =
- concat (Map.elems (projectFreezeConstraints elaboratedPlan))
- , projectConfigIndexState = Flag totalIndexState
- , projectConfigActiveRepos = Flag activeRepos
- }
+ :: ElaboratedInstallPlan
+ -> TotalIndexState
+ -> ActiveRepos
+ -> ProjectConfig
+projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 =
+ mempty
+ { projectConfigShared =
+ mempty
+ { projectConfigConstraints =
+ concat (Map.elems (projectFreezeConstraints elaboratedPlan))
+ , projectConfigIndexState = Flag totalIndexState
+ , projectConfigActiveRepos = Flag activeRepos
+ }
}
where
activeRepos :: ActiveRepos
@@ -155,50 +189,60 @@ projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 = mempty
-- | Given the install plan, produce solver constraints that will ensure the
-- solver picks the same solution again in future in different environments.
---
-projectFreezeConstraints :: ElaboratedInstallPlan
- -> Map PackageName [(UserConstraint, ConstraintSource)]
+projectFreezeConstraints
+ :: ElaboratedInstallPlan
+ -> Map PackageName [(UserConstraint, ConstraintSource)]
projectFreezeConstraints plan =
- --
- -- TODO: [required eventually] this is currently an underapproximation
- -- since the constraints language is not expressive enough to specify the
- -- precise solution. See https://github.com/haskell/cabal/issues/3502.
- --
- -- For the moment we deal with multiple versions in the solution by using
- -- constraints that allow either version. Also, we do not include any
- -- /version/ constraints for packages that are local to the project (e.g.
- -- if the solution has two instances of Cabal, one from the local project
- -- and one pulled in as a setup deps then we exclude all constraints on
- -- Cabal, not just the constraint for the local instance since any
- -- constraint would apply to both instances). We do however keep flag
- -- constraints of local packages.
- --
- deleteLocalPackagesVersionConstraints
- (Map.unionWith (++) versionConstraints flagConstraints)
+ --
+ -- TODO: [required eventually] this is currently an underapproximation
+ -- since the constraints language is not expressive enough to specify the
+ -- precise solution. See https://github.com/haskell/cabal/issues/3502.
+ --
+ -- For the moment we deal with multiple versions in the solution by using
+ -- constraints that allow either version. Also, we do not include any
+ -- /version/ constraints for packages that are local to the project (e.g.
+ -- if the solution has two instances of Cabal, one from the local project
+ -- and one pulled in as a setup deps then we exclude all constraints on
+ -- Cabal, not just the constraint for the local instance since any
+ -- constraint would apply to both instances). We do however keep flag
+ -- constraints of local packages.
+ --
+ deleteLocalPackagesVersionConstraints
+ (Map.unionWith (++) versionConstraints flagConstraints)
where
versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
versionConstraints =
Map.mapWithKey
- (\p v -> [(UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v),
- ConstraintSourceFreeze)])
+ ( \p v ->
+ [
+ ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v)
+ , ConstraintSourceFreeze
+ )
+ ]
+ )
versionRanges
versionRanges :: Map PackageName VersionRange
versionRanges =
Map.map simplifyVersionRange $
- Map.fromListWith unionVersionRanges $
+ Map.fromListWith unionVersionRanges $
[ (packageName pkg, thisVersion (packageVersion pkg))
| InstallPlan.PreExisting pkg <- InstallPlan.toList plan
]
- ++ [ (packageName pkg, thisVersion (packageVersion pkg))
- | InstallPlan.Configured pkg <- InstallPlan.toList plan
- ]
+ ++ [ (packageName pkg, thisVersion (packageVersion pkg))
+ | InstallPlan.Configured pkg <- InstallPlan.toList plan
+ ]
flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
flagConstraints =
Map.mapWithKey
- (\p f -> [(UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f),
- ConstraintSourceFreeze)])
+ ( \p f ->
+ [
+ ( UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f)
+ , ConstraintSourceFreeze
+ )
+ ]
+ )
flagAssignments
flagAssignments :: Map PackageName FlagAssignment
@@ -206,9 +250,10 @@ projectFreezeConstraints plan =
Map.fromList
[ (pkgname, flags)
| InstallPlan.Configured elab <- InstallPlan.toList plan
- , let flags = elabFlagAssignment elab
+ , let flags = elabFlagAssignment elab
pkgname = packageName elab
- , not (nullFlagAssignment flags) ]
+ , not (nullFlagAssignment flags)
+ ]
-- As described above, remove the version constraints on local packages,
-- but leave any flag constraints.
@@ -217,15 +262,17 @@ projectFreezeConstraints plan =
-> Map PackageName [(UserConstraint, ConstraintSource)]
deleteLocalPackagesVersionConstraints =
Map.mergeWithKey
- (\_pkgname () constraints ->
+ ( \_pkgname () constraints ->
case filter (not . isVersionConstraint . fst) constraints of
- [] -> Nothing
- constraints' -> Just constraints')
- (const Map.empty) id
+ [] -> Nothing
+ constraints' -> Just constraints'
+ )
+ (const Map.empty)
+ id
localPackages
isVersionConstraint (UserConstraint _ (PackagePropertyVersion _)) = True
- isVersionConstraint _ = False
+ isVersionConstraint _ = False
localPackages :: Map PackageName ()
localPackages =
diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs
index f3c7baa17ca5692d78e98497ba6f6e5c56f7baaa..fea0cb4411d16a152168832f63ea27e5ee4fea67 100644
--- a/cabal-install/src/Distribution/Client/CmdHaddock.hs
+++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs
@@ -1,173 +1,217 @@
{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: haddock
---
-module Distribution.Client.CmdHaddock (
- -- * The @haddock@ CLI and action
- haddockCommand,
- haddockAction,
-
- ClientHaddockFlags(..),
+module Distribution.Client.CmdHaddock
+ ( -- * The @haddock@ CLI and action
+ haddockCommand
+ , haddockAction
+ , ClientHaddockFlags (..)
-- * Internals exposed for testing
- selectPackageTargets,
- selectComponentTarget
+ , selectPackageTargets
+ , selectComponentTarget
) where
import Distribution.Client.Compat.Prelude
-import Prelude ()
import System.Directory (makeAbsolute)
+import Prelude ()
+import Distribution.Client.CmdErrorMessages
+import Distribution.Client.NixStyleOptions
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
import Distribution.Client.ProjectConfig.Types
- (PackageConfig (..), ProjectConfig (..))
+ ( PackageConfig (..)
+ , ProjectConfig (..)
+ )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
- ( ElaboratedSharedConfig(..) )
-import Distribution.Client.CmdErrorMessages
-import Distribution.Client.TargetProblem
- ( TargetProblem (..), TargetProblem' )
-import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+ ( ElaboratedSharedConfig (..)
+ )
import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..), InstallFlags (..))
-import Distribution.Simple.Setup
- ( HaddockFlags(..), fromFlagOrDefault, trueArg )
+ ( ConfigFlags (..)
+ , GlobalFlags
+ , InstallFlags (..)
+ )
+import Distribution.Client.TargetProblem
+ ( TargetProblem (..)
+ , TargetProblem'
+ )
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives, ShowOrParseArgs, OptionField, option )
+ ( CommandUI (..)
+ , OptionField
+ , ShowOrParseArgs
+ , option
+ , usageAlternatives
+ )
+import Distribution.Simple.Flag (Flag (..))
import Distribution.Simple.Program.Builtin
- ( haddockProgram )
+ ( haddockProgram
+ )
import Distribution.Simple.Program.Db
- ( addKnownProgram, reconfigurePrograms )
-import Distribution.Verbosity
- ( normal )
+ ( addKnownProgram
+ , reconfigurePrograms
+ )
+import Distribution.Simple.Setup
+ ( HaddockFlags (..)
+ , fromFlagOrDefault
+ , trueArg
+ )
import Distribution.Simple.Utils
- ( wrapText, die', notice )
-import Distribution.Simple.Flag (Flag(..))
+ ( die'
+ , notice
+ , wrapText
+ )
+import Distribution.Verbosity
+ ( normal
+ )
import qualified System.Exit (exitSuccess)
-newtype ClientHaddockFlags = ClientHaddockFlags { openInBrowser :: Flag Bool }
+newtype ClientHaddockFlags = ClientHaddockFlags {openInBrowser :: Flag Bool}
haddockCommand :: CommandUI (NixStyleFlags ClientHaddockFlags)
-haddockCommand = CommandUI {
- commandName = "v2-haddock",
- commandSynopsis = "Build Haddock documentation.",
- commandUsage = usageAlternatives "v2-haddock" [ "[FLAGS] TARGET" ],
- commandDescription = Just $ \_ -> wrapText $
- "Build Haddock documentation for the specified packages within the "
- ++ "project.\n\n"
-
- ++ "Any package in the project can be specified. If no package is "
- ++ "specified, the default is to build the documentation for the package "
- ++ "in the current directory. The default behaviour is to build "
- ++ "documentation for the exposed modules of the library component (if "
- ++ "any). This can be changed with the '--internal', '--executables', "
- ++ "'--tests', '--benchmarks' or '--all' flags.\n\n"
-
- ++ "Currently, documentation for dependencies is NOT built. This "
- ++ "behavior may change in future.\n\n"
-
- ++ "Additional configuration flags can be specified on the command line "
- ++ "and these extend the project configuration from the 'cabal.project', "
- ++ "'cabal.project.local' and other files.",
- commandNotes = Just $ \pname ->
+haddockCommand =
+ CommandUI
+ { commandName = "v2-haddock"
+ , commandSynopsis = "Build Haddock documentation."
+ , commandUsage = usageAlternatives "v2-haddock" ["[FLAGS] TARGET"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Build Haddock documentation for the specified packages within the "
+ ++ "project.\n\n"
+ ++ "Any package in the project can be specified. If no package is "
+ ++ "specified, the default is to build the documentation for the package "
+ ++ "in the current directory. The default behaviour is to build "
+ ++ "documentation for the exposed modules of the library component (if "
+ ++ "any). This can be changed with the '--internal', '--executables', "
+ ++ "'--tests', '--benchmarks' or '--all' flags.\n\n"
+ ++ "Currently, documentation for dependencies is NOT built. This "
+ ++ "behavior may change in future.\n\n"
+ ++ "Additional configuration flags can be specified on the command line "
+ ++ "and these extend the project configuration from the 'cabal.project', "
+ ++ "'cabal.project.local' and other files."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v2-haddock pkgname"
- ++ " Build documentation for the package named pkgname\n"
- , commandOptions = nixStyleOptions haddockOptions
- , commandDefaultFlags = defaultNixStyleFlags (ClientHaddockFlags (Flag False))
- }
- --TODO: [nice to have] support haddock on specific components, not just
- -- whole packages and the silly --executables etc modifiers.
+ ++ " "
+ ++ pname
+ ++ " v2-haddock pkgname"
+ ++ " Build documentation for the package named pkgname\n"
+ , commandOptions = nixStyleOptions haddockOptions
+ , commandDefaultFlags = defaultNixStyleFlags (ClientHaddockFlags (Flag False))
+ }
+
+-- TODO: [nice to have] support haddock on specific components, not just
+-- whole packages and the silly --executables etc modifiers.
haddockOptions :: ShowOrParseArgs -> [OptionField ClientHaddockFlags]
haddockOptions _ =
- [ option [] ["open"] "Open generated documentation in the browser"
- openInBrowser (\v f -> f { openInBrowser = v}) trueArg
+ [ option
+ []
+ ["open"]
+ "Open generated documentation in the browser"
+ openInBrowser
+ (\v f -> f{openInBrowser = v})
+ trueArg
]
mkConfigAbsolute :: ProjectConfig -> IO ProjectConfig
mkConfigAbsolute relConfig = do
let relPackageConfig = projectConfigLocalPackages relConfig
absHaddockOutputDir <- traverse makeAbsolute (packageConfigHaddockOutputDir relPackageConfig)
- return (relConfig { projectConfigLocalPackages = relPackageConfig {
- packageConfigHaddockOutputDir = absHaddockOutputDir} })
+ return
+ ( relConfig
+ { projectConfigLocalPackages =
+ relPackageConfig
+ { packageConfigHaddockOutputDir = absHaddockOutputDir
+ }
+ }
+ )
mkFlagsAbsolute :: NixStyleFlags ClientHaddockFlags -> IO (NixStyleFlags ClientHaddockFlags)
mkFlagsAbsolute relFlags = do
let relHaddockFlags = haddockFlags relFlags
absHaddockOutputDir <- traverse makeAbsolute (haddockOutputDir relHaddockFlags)
- return (relFlags { haddockFlags = relHaddockFlags { haddockOutputDir = absHaddockOutputDir } })
+ return (relFlags{haddockFlags = relHaddockFlags{haddockOutputDir = absHaddockOutputDir}})
-- | The @haddock@ command is TODO.
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
haddockAction :: NixStyleFlags ClientHaddockFlags -> [String] -> GlobalFlags -> IO ()
haddockAction relFlags targetStrings globalFlags = do
- -- It's important to make --haddock-output-dir absolute since we change the working directory later.
- flags@NixStyleFlags {..} <- mkFlagsAbsolute relFlags
-
- let
- verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
- installDoc = fromFlagOrDefault True (installDocumentation installFlags)
- flags' = flags { installFlags = installFlags { installDocumentation = Flag installDoc } }
- cliConfig = commandLineFlagsToProjectConfig globalFlags flags' mempty -- ClientInstallFlags, not needed here
-
- projCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand
-
- let relBaseCtx@ProjectBaseContext { projectConfig = relProjectConfig }
- | fromFlagOrDefault False (openInBrowser extraFlags)
- = projCtx { buildSettings = (buildSettings projCtx) { buildSettingHaddockOpen = True } }
- | otherwise
- = projCtx
- absProjectConfig <- mkConfigAbsolute relProjectConfig
- let baseCtx = relBaseCtx { projectConfig = absProjectConfig }
-
- targetSelectors <- either (reportTargetSelectorProblems verbosity) return
- =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings
-
- buildCtx <-
- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-
- when (buildSettingOnlyDeps (buildSettings baseCtx)) $
- die' verbosity
- "The haddock command does not support '--only-dependencies'."
-
- -- When we interpret the targets on the command line, interpret them as
- -- haddock targets
- targets <- either (reportBuildDocumentationTargetProblems verbosity) return
- $ resolveTargets
- (selectPackageTargets haddockFlags)
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- let elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionHaddock
- targets
- elaboratedPlan
- return (elaboratedPlan', targets)
-
- printPlan verbosity baseCtx buildCtx
-
- progs <- reconfigurePrograms verbosity
- (haddockProgramPaths haddockFlags)
- (haddockProgramArgs haddockFlags)
- -- we need to insert 'haddockProgram' before we reconfigure it,
- -- otherwise 'set
- . addKnownProgram haddockProgram
- . pkgConfigCompilerProgs
- . elaboratedShared
- $ buildCtx
- let buildCtx' = buildCtx { elaboratedShared =
- (elaboratedShared buildCtx)
- { pkgConfigCompilerProgs = progs } }
-
- buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx'
- runProjectPostBuildPhase verbosity baseCtx buildCtx' buildOutcomes
+ -- It's important to make --haddock-output-dir absolute since we change the working directory later.
+ flags@NixStyleFlags{..} <- mkFlagsAbsolute relFlags
+
+ let
+ verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
+ installDoc = fromFlagOrDefault True (installDocumentation installFlags)
+ flags' = flags{installFlags = installFlags{installDocumentation = Flag installDoc}}
+ cliConfig = commandLineFlagsToProjectConfig globalFlags flags' mempty -- ClientInstallFlags, not needed here
+ projCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand
+
+ let relBaseCtx@ProjectBaseContext{projectConfig = relProjectConfig}
+ | fromFlagOrDefault False (openInBrowser extraFlags) =
+ projCtx{buildSettings = (buildSettings projCtx){buildSettingHaddockOpen = True}}
+ | otherwise =
+ projCtx
+ absProjectConfig <- mkConfigAbsolute relProjectConfig
+ let baseCtx = relBaseCtx{projectConfig = absProjectConfig}
+
+ targetSelectors <-
+ either (reportTargetSelectorProblems verbosity) return
+ =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings
+
+ buildCtx <-
+ runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
+ when (buildSettingOnlyDeps (buildSettings baseCtx)) $
+ die'
+ verbosity
+ "The haddock command does not support '--only-dependencies'."
+
+ -- When we interpret the targets on the command line, interpret them as
+ -- haddock targets
+ targets <-
+ either (reportBuildDocumentationTargetProblems verbosity) return $
+ resolveTargets
+ (selectPackageTargets haddockFlags)
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionHaddock
+ targets
+ elaboratedPlan
+ return (elaboratedPlan', targets)
+
+ printPlan verbosity baseCtx buildCtx
+
+ progs <-
+ reconfigurePrograms
+ verbosity
+ (haddockProgramPaths haddockFlags)
+ (haddockProgramArgs haddockFlags)
+ -- we need to insert 'haddockProgram' before we reconfigure it,
+ -- otherwise 'set
+ . addKnownProgram haddockProgram
+ . pkgConfigCompilerProgs
+ . elaboratedShared
+ $ buildCtx
+ let buildCtx' =
+ buildCtx
+ { elaboratedShared =
+ (elaboratedShared buildCtx)
+ { pkgConfigCompilerProgs = progs
+ }
+ }
+
+ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx'
+ runProjectPostBuildPhase verbosity baseCtx buildCtx' buildOutcomes
-- | This defines what a 'TargetSelector' means for the @haddock@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
@@ -176,38 +220,37 @@ haddockAction relFlags targetStrings globalFlags = do
-- For the @haddock@ command we select all buildable libraries. Additionally,
-- depending on the @--executables@ flag we also select all the buildable exes.
-- We do similarly for test-suites, benchmarks and foreign libs.
---
-selectPackageTargets :: HaddockFlags -> TargetSelector
- -> [AvailableTarget k] -> Either TargetProblem' [k]
+selectPackageTargets
+ :: HaddockFlags
+ -> TargetSelector
+ -> [AvailableTarget k]
+ -> Either TargetProblem' [k]
selectPackageTargets haddockFlags targetSelector targets
-
- -- If there are any buildable targets then we select those
- | not (null targetsBuildable)
- = Right targetsBuildable
-
- -- If there are targets but none are buildable then we report those
- | not (null targets)
- = Left (TargetProblemNoneEnabled targetSelector targets')
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ -- If there are any buildable targets then we select those
+ | not (null targetsBuildable) =
+ Right targetsBuildable
+ -- If there are targets but none are buildable then we report those
+ | not (null targets) =
+ Left (TargetProblemNoneEnabled targetSelector targets')
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
- targets' = forgetTargetsDetail (map disableNotRequested targets)
+ targets' = forgetTargetsDetail (map disableNotRequested targets)
targetsBuildable = selectBuildableTargets (map disableNotRequested targets)
-- When there's a target filter like "pkg:exes" then we do select exes,
-- but if it's just a target like "pkg" then we don't build docs for exes
-- unless they are requested by default (i.e. by using --executables)
disableNotRequested t@(AvailableTarget _ cname (TargetBuildable _ _) _)
- | not (isRequested targetSelector (componentKind cname))
- = t { availableTargetStatus = TargetDisabledByUser }
+ | not (isRequested targetSelector (componentKind cname)) =
+ t{availableTargetStatus = TargetDisabledByUser}
disableNotRequested t = t
isRequested (TargetPackage _ _ (Just _)) _ = True
isRequested (TargetAllPackages (Just _)) _ = True
- isRequested _ LibKind = True
--- isRequested _ SubLibKind = True --TODO: what about sublibs?
+ isRequested _ LibKind = True
+ -- isRequested _ SubLibKind = True --TODO: what about sublibs?
-- TODO/HACK, we encode some defaults here as v2-haddock's logic;
-- make sure this matches the defaults applied in
@@ -215,31 +258,32 @@ selectPackageTargets haddockFlags targetSelector targets
-- to be done properly
--
-- See also https://github.com/haskell/cabal/pull/4886
- isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags)
- isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags)
- isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags)
- isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags)
-
+ isRequested _ FLibKind = fromFlagOrDefault False (haddockForeignLibs haddockFlags)
+ isRequested _ ExeKind = fromFlagOrDefault False (haddockExecutables haddockFlags)
+ isRequested _ TestKind = fromFlagOrDefault False (haddockTestSuites haddockFlags)
+ isRequested _ BenchKind = fromFlagOrDefault False (haddockBenchmarks haddockFlags)
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @haddock@ command we just need the basic checks on being buildable
-- etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either TargetProblem' k
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either TargetProblem' k
selectComponentTarget = selectComponentTargetBasic
reportBuildDocumentationTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
reportBuildDocumentationTargetProblems verbosity problems =
case problems of
[TargetProblemNoneEnabled _ _] -> do
- notice verbosity $ unwords
- [ "No documentation was generated as this package does not contain a library."
- , "Perhaps you want to use the --haddock-all flag, or one or more of the"
- , "--haddock-executables, --haddock-tests, --haddock-benchmarks or"
- , "--haddock-internal flags."
- ]
+ notice verbosity $
+ unwords
+ [ "No documentation was generated as this package does not contain a library."
+ , "Perhaps you want to use the --haddock-all flag, or one or more of the"
+ , "--haddock-executables, --haddock-tests, --haddock-benchmarks or"
+ , "--haddock-internal flags."
+ ]
System.Exit.exitSuccess
_ -> reportTargetProblems verbosity "build documentation for" problems
diff --git a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
index aaa65f837cc364e3e70471342e5018e449812a3a..535d2aacb3dc5139d58d1534caece40f7375aa6f 100644
--- a/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
+++ b/cabal-install/src/Distribution/Client/CmdHaddockProject.hs
@@ -3,299 +3,368 @@ module Distribution.Client.CmdHaddockProject
, haddockProjectAction
) where
-import Prelude ()
import Data.Bool (bool)
import Distribution.Client.Compat.Prelude hiding (get)
+import Prelude ()
-import qualified Distribution.Client.CmdBuild as CmdBuild
+import qualified Distribution.Client.CmdBuild as CmdBuild
import qualified Distribution.Client.CmdHaddock as CmdHaddock
-import Distribution.Client.DistDirLayout (DistDirLayout(..)
- ,CabalDirLayout(..)
- ,StoreDirLayout(..))
-import Distribution.Client.InstallPlan (foldPlanPackage)
+import Distribution.Client.DistDirLayout
+ ( CabalDirLayout (..)
+ , DistDirLayout (..)
+ , StoreDirLayout (..)
+ )
+import Distribution.Client.InstallPlan (foldPlanPackage)
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.NixStyleOptions as NixStyleOptions
import Distribution.Client.ProjectOrchestration
- (AvailableTarget(..)
- ,AvailableTargetStatus(..)
- ,CurrentCommand(..)
- ,ProjectBaseContext(..)
- ,ProjectBuildContext(..)
- ,TargetSelector(..)
- ,printPlan
- ,pruneInstallPlanToTargets
- ,resolveTargets
- ,runProjectPreBuildPhase
- ,selectComponentTargetBasic)
-import Distribution.Client.ProjectPlanning (ElaboratedConfiguredPackage(..)
- ,ElaboratedInstallPlan
- ,ElaboratedSharedConfig(..)
- ,TargetAction(..))
+ ( AvailableTarget (..)
+ , AvailableTargetStatus (..)
+ , CurrentCommand (..)
+ , ProjectBaseContext (..)
+ , ProjectBuildContext (..)
+ , TargetSelector (..)
+ , printPlan
+ , pruneInstallPlanToTargets
+ , resolveTargets
+ , runProjectPreBuildPhase
+ , selectComponentTargetBasic
+ )
+import Distribution.Client.ProjectPlanning
+ ( ElaboratedConfiguredPackage (..)
+ , ElaboratedInstallPlan
+ , ElaboratedSharedConfig (..)
+ , TargetAction (..)
+ )
import Distribution.Client.ProjectPlanning.Types
- (elabDistDirParams)
-import Distribution.Client.Setup (GlobalFlags(..)
- ,ConfigFlags(..))
-import Distribution.Client.ScriptUtils (AcceptNoTargets(..)
- ,TargetContext(..)
- ,updateContextAndWriteProjectFile
- ,withContextAndSelectors)
-import Distribution.Client.TargetProblem (TargetProblem(..))
+ ( elabDistDirParams
+ )
+import Distribution.Client.ScriptUtils
+ ( AcceptNoTargets (..)
+ , TargetContext (..)
+ , updateContextAndWriteProjectFile
+ , withContextAndSelectors
+ )
+import Distribution.Client.Setup
+ ( ConfigFlags (..)
+ , GlobalFlags (..)
+ )
+import Distribution.Client.TargetProblem (TargetProblem (..))
-import Distribution.Types.PackageId (pkgName)
-import Distribution.Types.PackageName (unPackageName)
-import Distribution.Types.Version (mkVersion)
-import Distribution.Types.VersionRange (orLaterVersion)
-import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
import Distribution.Simple.Command
- ( CommandUI(..) )
+ ( CommandUI (..)
+ )
import Distribution.Simple.Compiler
- ( Compiler (..) )
+ ( Compiler (..)
+ )
import Distribution.Simple.Flag
- ( Flag(..)
- , flagElim
- , flagToList
- , fromFlag
- , fromFlagOrDefault
- )
-import Distribution.Simple.InstallDirs
- ( toPathTemplate )
+ ( Flag (..)
+ , flagElim
+ , flagToList
+ , fromFlag
+ , fromFlagOrDefault
+ )
import Distribution.Simple.Haddock (createHaddockIndex)
-import Distribution.Simple.Utils
- ( die', createDirectoryIfMissingVerbose
- , copyDirectoryRecursive, warn )
+import Distribution.Simple.InstallDirs
+ ( toPathTemplate
+ )
import Distribution.Simple.Program.Builtin
- ( haddockProgram )
+ ( haddockProgram
+ )
import Distribution.Simple.Program.Db
- ( addKnownProgram, reconfigurePrograms, requireProgramVersion )
+ ( addKnownProgram
+ , reconfigurePrograms
+ , requireProgramVersion
+ )
import Distribution.Simple.Setup
- ( HaddockFlags(..), defaultHaddockFlags
- , HaddockProjectFlags(..)
- , Visibility(..)
- , haddockProjectCommand
- )
+ ( HaddockFlags (..)
+ , HaddockProjectFlags (..)
+ , Visibility (..)
+ , defaultHaddockFlags
+ , haddockProjectCommand
+ )
+import Distribution.Simple.Utils
+ ( copyDirectoryRecursive
+ , createDirectoryIfMissingVerbose
+ , die'
+ , warn
+ )
+import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo (..))
+import Distribution.Types.PackageId (pkgName)
+import Distribution.Types.PackageName (unPackageName)
+import Distribution.Types.Version (mkVersion)
+import Distribution.Types.VersionRange (orLaterVersion)
import Distribution.Verbosity as Verbosity
- ( normal )
+ ( normal
+ )
-import System.FilePath ( takeDirectory, normalise, (</>), (<.>) )
-import System.Directory ( doesDirectoryExist, doesFileExist )
+import System.Directory (doesDirectoryExist, doesFileExist)
+import System.FilePath (normalise, takeDirectory, (<.>), (</>))
haddockProjectAction :: HaddockProjectFlags -> [String] -> GlobalFlags -> IO ()
haddockProjectAction flags _extraArgs globalFlags = do
- -- create destination directory if it does not exist
- let outputDir = normalise $ fromFlag (haddockProjectDir flags)
- createDirectoryIfMissingVerbose verbosity True outputDir
+ -- create destination directory if it does not exist
+ let outputDir = normalise $ fromFlag (haddockProjectDir flags)
+ createDirectoryIfMissingVerbose verbosity True outputDir
- when ((2::Int) <=
- ( flagElim 0 (bool 0 1) (haddockProjectHackage flags)
- + flagElim 0 (bool 0 1) (haddockProjectLocal flags)
- + flagElim 0 (const 1) (haddockProjectHtmlLocation flags)
- )) $
- die' verbosity "Options `--local`, `--hackage` and `--html-location` are mutually exclusive`"
+ when
+ ( (2 :: Int)
+ <= ( flagElim 0 (bool 0 1) (haddockProjectHackage flags)
+ + flagElim 0 (bool 0 1) (haddockProjectLocal flags)
+ + flagElim 0 (const 1) (haddockProjectHtmlLocation flags)
+ )
+ )
+ $ die' verbosity "Options `--local`, `--hackage` and `--html-location` are mutually exclusive`"
- warn verbosity "haddock-project command is experimental, it might break in the future"
+ warn verbosity "haddock-project command is experimental, it might break in the future"
- -- build all packages with appropriate haddock flags
- let haddockFlags = defaultHaddockFlags
- { haddockHtml = Flag True
- -- one can either use `--haddock-base-url` or
- -- `--haddock-html-location`.
- , haddockBaseUrl = if localStyle
- then Flag ".."
- else NoFlag
- , haddockProgramPaths = haddockProjectProgramPaths flags
- , haddockProgramArgs = haddockProjectProgramArgs flags
- , haddockHtmlLocation = if fromFlagOrDefault False (haddockProjectHackage flags)
- then Flag "https://hackage.haskell.org/package/$pkg-$version/docs"
- else haddockProjectHtmlLocation flags
- , haddockHoogle = haddockProjectHoogle flags
- , haddockExecutables = haddockProjectExecutables flags
- , haddockTestSuites = haddockProjectTestSuites flags
- , haddockBenchmarks = haddockProjectBenchmarks flags
- , haddockForeignLibs = haddockProjectForeignLibs flags
- , haddockInternal = haddockProjectInternal flags
- , haddockCss = haddockProjectCss flags
- , haddockLinkedSource = if localOrHackage
- then Flag True
- else haddockProjectLinkedSource flags
- , haddockQuickJump = if localOrHackage
- then Flag True
- else haddockProjectQuickJump flags
- , haddockHscolourCss = haddockProjectHscolourCss flags
- , haddockContents = if localStyle then Flag (toPathTemplate "../index.html")
- else NoFlag
- , haddockIndex = if localStyle then Flag (toPathTemplate "../doc-index.html")
- else NoFlag
- , haddockKeepTempFiles= haddockProjectKeepTempFiles flags
- , haddockVerbosity = haddockProjectVerbosity flags
- , haddockLib = haddockProjectLib flags
- , haddockOutputDir = haddockProjectOutputDir flags
+ -- build all packages with appropriate haddock flags
+ let haddockFlags =
+ defaultHaddockFlags
+ { haddockHtml = Flag True
+ , -- one can either use `--haddock-base-url` or
+ -- `--haddock-html-location`.
+ haddockBaseUrl =
+ if localStyle
+ then Flag ".."
+ else NoFlag
+ , haddockProgramPaths = haddockProjectProgramPaths flags
+ , haddockProgramArgs = haddockProjectProgramArgs flags
+ , haddockHtmlLocation =
+ if fromFlagOrDefault False (haddockProjectHackage flags)
+ then Flag "https://hackage.haskell.org/package/$pkg-$version/docs"
+ else haddockProjectHtmlLocation flags
+ , haddockHoogle = haddockProjectHoogle flags
+ , haddockExecutables = haddockProjectExecutables flags
+ , haddockTestSuites = haddockProjectTestSuites flags
+ , haddockBenchmarks = haddockProjectBenchmarks flags
+ , haddockForeignLibs = haddockProjectForeignLibs flags
+ , haddockInternal = haddockProjectInternal flags
+ , haddockCss = haddockProjectCss flags
+ , haddockLinkedSource =
+ if localOrHackage
+ then Flag True
+ else haddockProjectLinkedSource flags
+ , haddockQuickJump =
+ if localOrHackage
+ then Flag True
+ else haddockProjectQuickJump flags
+ , haddockHscolourCss = haddockProjectHscolourCss flags
+ , haddockContents =
+ if localStyle
+ then Flag (toPathTemplate "../index.html")
+ else NoFlag
+ , haddockIndex =
+ if localStyle
+ then Flag (toPathTemplate "../doc-index.html")
+ else NoFlag
+ , haddockKeepTempFiles = haddockProjectKeepTempFiles flags
+ , haddockVerbosity = haddockProjectVerbosity flags
+ , haddockLib = haddockProjectLib flags
+ , haddockOutputDir = haddockProjectOutputDir flags
+ }
+ nixFlags =
+ (commandDefaultFlags CmdHaddock.haddockCommand)
+ { NixStyleOptions.haddockFlags = haddockFlags
+ , NixStyleOptions.configFlags =
+ (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand))
+ { configVerbosity = haddockProjectVerbosity flags
+ }
}
- nixFlags = (commandDefaultFlags CmdHaddock.haddockCommand)
- { NixStyleOptions.haddockFlags = haddockFlags
- , NixStyleOptions.configFlags =
- (NixStyleOptions.configFlags (commandDefaultFlags CmdBuild.buildCommand))
- { configVerbosity = haddockProjectVerbosity flags }
- }
- --
- -- Construct the build plan and infer the list of packages which haddocks
- -- we need.
- --
+ --
+ -- Construct the build plan and infer the list of packages which haddocks
+ -- we need.
+ --
- withContextAndSelectors RejectNoTargets Nothing nixFlags ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do
- baseCtx <- case targetCtx of
- ProjectContext -> return ctx
- GlobalContext -> return ctx
- ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
- let distLayout = distDirLayout baseCtx
- cabalLayout = cabalDirLayout baseCtx
- buildCtx <-
- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
- -- Interpret the targets on the command line as build targets
- -- (as opposed to say repl or haddock targets).
- targets <- either reportTargetProblems return
- $ resolveTargets
- selectPackageTargets
- selectComponentTargetBasic
- elaboratedPlan
- Nothing
- targetSelectors
+ withContextAndSelectors RejectNoTargets Nothing nixFlags ["all"] globalFlags HaddockCommand $ \targetCtx ctx targetSelectors -> do
+ baseCtx <- case targetCtx of
+ ProjectContext -> return ctx
+ GlobalContext -> return ctx
+ ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
+ let distLayout = distDirLayout baseCtx
+ cabalLayout = cabalDirLayout baseCtx
+ buildCtx <-
+ runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
+ -- Interpret the targets on the command line as build targets
+ -- (as opposed to say repl or haddock targets).
+ targets <-
+ either reportTargetProblems return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTargetBasic
+ elaboratedPlan
+ Nothing
+ targetSelectors
- let elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
- return (elaboratedPlan', targets)
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
+ return (elaboratedPlan', targets)
- printPlan verbosity baseCtx buildCtx
+ printPlan verbosity baseCtx buildCtx
- let elaboratedPlan :: ElaboratedInstallPlan
- elaboratedPlan = elaboratedPlanOriginal buildCtx
+ let elaboratedPlan :: ElaboratedInstallPlan
+ elaboratedPlan = elaboratedPlanOriginal buildCtx
- sharedConfig :: ElaboratedSharedConfig
- sharedConfig = elaboratedShared buildCtx
+ sharedConfig :: ElaboratedSharedConfig
+ sharedConfig = elaboratedShared buildCtx
- pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage ]
- pkgs = matchingPackages elaboratedPlan
+ pkgs :: [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+ pkgs = matchingPackages elaboratedPlan
- progs <- reconfigurePrograms verbosity
- (haddockProjectProgramPaths flags)
- (haddockProjectProgramArgs flags)
- -- we need to insert 'haddockProgram' before we reconfigure it,
- -- otherwise 'set
- . addKnownProgram haddockProgram
- . pkgConfigCompilerProgs
- $ sharedConfig
- let sharedConfig' = sharedConfig { pkgConfigCompilerProgs = progs }
+ progs <-
+ reconfigurePrograms
+ verbosity
+ (haddockProjectProgramPaths flags)
+ (haddockProjectProgramArgs flags)
+ -- we need to insert 'haddockProgram' before we reconfigure it,
+ -- otherwise 'set
+ . addKnownProgram haddockProgram
+ . pkgConfigCompilerProgs
+ $ sharedConfig
+ let sharedConfig' = sharedConfig{pkgConfigCompilerProgs = progs}
- _ <- requireProgramVersion
- verbosity haddockProgram
- (orLaterVersion (mkVersion [2,26,1])) progs
+ _ <-
+ requireProgramVersion
+ verbosity
+ haddockProgram
+ (orLaterVersion (mkVersion [2, 26, 1]))
+ progs
- --
- -- Build haddocks of each components
- --
+ --
+ -- Build haddocks of each components
+ --
- CmdHaddock.haddockAction
- nixFlags
- ["all"]
- globalFlags
+ CmdHaddock.haddockAction
+ nixFlags
+ ["all"]
+ globalFlags
- --
- -- Copy haddocks to the destination folder
- --
+ --
+ -- Copy haddocks to the destination folder
+ --
- packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
- case pkg of
- Left _ | not localStyle ->
- return []
- Left package -> do
- let packageName = unPackageName (pkgName $ sourcePackageId package)
- destDir = outputDir </> packageName
- fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
- let docDir = takeDirectory interfacePath
- a <- doesFileExist interfacePath
+ packageInfos <- fmap (nub . concat) $ for pkgs $ \pkg ->
+ case pkg of
+ Left _
+ | not localStyle ->
+ return []
+ Left package -> do
+ let packageName = unPackageName (pkgName $ sourcePackageId package)
+ destDir = outputDir </> packageName
+ fmap catMaybes $ for (haddockInterfaces package) $ \interfacePath -> do
+ let docDir = takeDirectory interfacePath
+ a <- doesFileExist interfacePath
+ case a of
+ True ->
+ copyDirectoryRecursive verbosity docDir destDir
+ >> return
+ ( Just
+ ( packageName
+ , interfacePath
+ , Hidden
+ )
+ )
+ False -> return Nothing
+ Right package ->
+ case elabLocalToProject package of
+ True -> do
+ let distDirParams = elabDistDirParams sharedConfig' package
+ buildDir = distBuildDirectory distLayout distDirParams
+ packageName = unPackageName (pkgName $ elabPkgSourceId package)
+ let docDir =
+ buildDir
+ </> "doc"
+ </> "html"
+ </> packageName
+ destDir = outputDir </> packageName
+ interfacePath =
+ destDir
+ </> packageName
+ <.> "haddock"
+ a <- doesDirectoryExist docDir
case a of
- True -> copyDirectoryRecursive verbosity docDir destDir
- >> return (Just ( packageName
- , interfacePath
- , Hidden
- ))
- False -> return Nothing
-
- Right package ->
- case elabLocalToProject package of
- True -> do
- let distDirParams = elabDistDirParams sharedConfig' package
- buildDir = distBuildDirectory distLayout distDirParams
- packageName = unPackageName (pkgName $ elabPkgSourceId package)
- let docDir = buildDir
- </> "doc" </> "html"
- </> packageName
- destDir = outputDir </> packageName
- interfacePath = destDir
- </> packageName <.> "haddock"
- a <- doesDirectoryExist docDir
- case a of
- True -> copyDirectoryRecursive verbosity docDir destDir
- >> return [( packageName
- , interfacePath
- , Visible
- )]
- False -> return []
- False | not localStyle ->
- return []
- False -> do
- let packageName = unPackageName (pkgName $ elabPkgSourceId package)
- packageDir = storePackageDirectory (cabalStoreDirLayout cabalLayout)
- (compilerId (pkgConfigCompiler sharedConfig'))
- (elabUnitId package)
- docDir = packageDir </> "share" </> "doc" </> "html"
- destDir = outputDir </> packageName
- interfacePath = destDir
- </> packageName <.> "haddock"
- a <- doesDirectoryExist docDir
- case a of
- True -> copyDirectoryRecursive verbosity docDir destDir
- -- non local packages will be hidden in haddock's
- -- generated contents page
- >> return [( packageName
- , interfacePath
- , Hidden
- )]
- False -> return []
+ True ->
+ copyDirectoryRecursive verbosity docDir destDir
+ >> return
+ [
+ ( packageName
+ , interfacePath
+ , Visible
+ )
+ ]
+ False -> return []
+ False
+ | not localStyle ->
+ return []
+ False -> do
+ let packageName = unPackageName (pkgName $ elabPkgSourceId package)
+ packageDir =
+ storePackageDirectory
+ (cabalStoreDirLayout cabalLayout)
+ (compilerId (pkgConfigCompiler sharedConfig'))
+ (elabUnitId package)
+ docDir = packageDir </> "share" </> "doc" </> "html"
+ destDir = outputDir </> packageName
+ interfacePath =
+ destDir
+ </> packageName
+ <.> "haddock"
+ a <- doesDirectoryExist docDir
+ case a of
+ True ->
+ copyDirectoryRecursive verbosity docDir destDir
+ -- non local packages will be hidden in haddock's
+ -- generated contents page
+ >> return
+ [
+ ( packageName
+ , interfacePath
+ , Hidden
+ )
+ ]
+ False -> return []
- --
- -- generate index, content, etc.
- --
+ --
+ -- generate index, content, etc.
+ --
- let flags' = flags
- { haddockProjectDir = Flag outputDir
- , haddockProjectGenIndex = if localOrHackage
- then Flag True
- else haddockProjectGenIndex flags
- , haddockProjectGenContents = if localOrHackage
- then Flag True
- else haddockProjectGenContents flags
- , haddockProjectQuickJump = if localOrHackage
- then Flag True
- else haddockProjectQuickJump flags
+ let flags' =
+ flags
+ { haddockProjectDir = Flag outputDir
+ , haddockProjectGenIndex =
+ if localOrHackage
+ then Flag True
+ else haddockProjectGenIndex flags
+ , haddockProjectGenContents =
+ if localOrHackage
+ then Flag True
+ else haddockProjectGenContents flags
+ , haddockProjectQuickJump =
+ if localOrHackage
+ then Flag True
+ else haddockProjectQuickJump flags
, haddockProjectLinkedSource = haddockLinkedSource haddockFlags
- , haddockProjectInterfaces = Flag
- [ ( interfacePath
- , Just packageName
- , Just packageName
- , visibility
- )
- | (packageName, interfacePath, visibility) <- packageInfos
- ]
+ , haddockProjectInterfaces =
+ Flag
+ [ ( interfacePath
+ , Just packageName
+ , Just packageName
+ , visibility
+ )
+ | (packageName, interfacePath, visibility) <- packageInfos
+ ]
}
- createHaddockIndex verbosity
- (pkgConfigCompilerProgs sharedConfig')
- (pkgConfigCompiler sharedConfig')
- (pkgConfigPlatform sharedConfig')
- flags'
+ createHaddockIndex
+ verbosity
+ (pkgConfigCompilerProgs sharedConfig')
+ (pkgConfigCompiler sharedConfig')
+ (pkgConfigPlatform sharedConfig')
+ flags'
where
verbosity = fromFlagOrDefault normal (haddockProjectVerbosity flags)
@@ -303,36 +372,41 @@ haddockProjectAction flags _extraArgs globalFlags = do
-- transitive dependencies; or depend on `--haddocks-html-location` to
-- provide location of the documentation of dependencies.
localStyle =
- let local = fromFlagOrDefault False (haddockProjectLocal flags)
- hackage = fromFlagOrDefault False (haddockProjectHackage flags)
+ let local = fromFlagOrDefault False (haddockProjectLocal flags)
+ hackage = fromFlagOrDefault False (haddockProjectHackage flags)
location = fromFlagOrDefault False (const True <$> haddockProjectHtmlLocation flags)
- in local && not hackage && not location
- -- or if none of the flags is given set `localStyle` to `True`
- || not local && not hackage && not location
-
+ in local && not hackage && not location
+ -- or if none of the flags is given set `localStyle` to `True`
+ || not local && not hackage && not location
localOrHackage =
- any id $ flagToList (haddockProjectLocal flags)
- ++ flagToList (haddockProjectHackage flags)
+ any id $
+ flagToList (haddockProjectLocal flags)
+ ++ flagToList (haddockProjectHackage flags)
reportTargetProblems :: Show x => [x] -> IO a
reportTargetProblems =
- die' verbosity . unlines . map show
+ die' verbosity . unlines . map show
-- TODO: this is just a sketch
- selectPackageTargets :: TargetSelector
- -> [AvailableTarget k]
- -> Either (TargetProblem ()) [k]
- selectPackageTargets _ ts = Right $
- mapMaybe
- (\t -> case availableTargetStatus t of
- TargetBuildable k _ | availableTargetLocalToProject t
- -> Just k
- _ -> Nothing)
- ts
+ selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either (TargetProblem ()) [k]
+ selectPackageTargets _ ts =
+ Right $
+ mapMaybe
+ ( \t -> case availableTargetStatus t of
+ TargetBuildable k _
+ | availableTargetLocalToProject t ->
+ Just k
+ _ -> Nothing
+ )
+ ts
- matchingPackages :: ElaboratedInstallPlan
- -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
+ matchingPackages
+ :: ElaboratedInstallPlan
+ -> [Either InstalledPackageInfo ElaboratedConfiguredPackage]
matchingPackages =
- fmap (foldPlanPackage Left Right)
- . InstallPlan.toList
+ fmap (foldPlanPackage Left Right)
+ . InstallPlan.toList
diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs
index 8cf8c57ccf810590fe16fdb42b2c482e395d5f9f..46ce2cd6e5a66535a44cd9fc4c33c8bf0d557840 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall.hs
@@ -1,183 +1,289 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | cabal-install CLI command: build
---
-module Distribution.Client.CmdInstall (
- -- * The @build@ CLI and action
- installCommand,
- installAction,
+module Distribution.Client.CmdInstall
+ ( -- * The @build@ CLI and action
+ installCommand
+ , installAction
-- * Internals exposed for testing
- selectPackageTargets,
- selectComponentTarget,
+ , selectPackageTargets
+ , selectComponentTarget
+
-- * Internals exposed for CmdRepl + CmdRun
- establishDummyDistDirLayout,
- establishDummyProjectBaseContext
+ , establishDummyDistDirLayout
+ , establishDummyProjectBaseContext
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
- ( doesPathExist )
+ ( doesPathExist
+ )
+import Prelude ()
-import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
import Distribution.Client.CmdSdist
+import Distribution.Client.ProjectOrchestration
import Distribution.Client.TargetProblem
- ( TargetProblem', TargetProblem (..) )
+ ( TargetProblem (..)
+ , TargetProblem'
+ )
import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.CmdInstall.ClientInstallTargetSelector
-import Distribution.Client.Setup
- ( GlobalFlags(..), ConfigFlags(..), InstallFlags(..) )
-import Distribution.Client.Types
- ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage
- , SourcePackageDb(..) )
+import Distribution.Client.Config
+ ( SavedConfig (..)
+ , defaultInstallPath
+ , loadConfig
+ )
+import Distribution.Client.DistDirLayout
+ ( CabalDirLayout (..)
+ , DistDirLayout (..)
+ , StoreDirLayout (..)
+ , cabalStoreDirLayout
+ , mkCabalDirLayout
+ )
+import Distribution.Client.IndexUtils
+ ( getInstalledPackages
+ , getSourcePackages
+ )
import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Package
- ( Package(..), PackageName, mkPackageName, unPackageName )
-import Distribution.Types.PackageId
- ( PackageIdentifier(..) )
-import Distribution.Client.ProjectConfig
- ( ProjectPackageLocation(..)
- , fetchAndReadSourcePackages
- , projectConfigWithBuilderRepoContext
- , resolveBuildTimeSettings, withProjectOrGlobalConfig )
+import Distribution.Client.InstallSymlink
+ ( promptRun
+ , symlinkBinary
+ , trySymlink
+ )
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
-import Distribution.Client.ProjectFlags (ProjectFlags (..))
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
+import Distribution.Client.ProjectConfig
+ ( ProjectPackageLocation (..)
+ , fetchAndReadSourcePackages
+ , projectConfigWithBuilderRepoContext
+ , resolveBuildTimeSettings
+ , withProjectOrGlobalConfig
+ )
import Distribution.Client.ProjectConfig.Types
- ( ProjectConfig(..), ProjectConfigShared(..)
- , ProjectConfigBuildOnly(..), PackageConfig(..)
- , MapMappend(..)
- , getMapLast, getMapMappend, projectConfigLogsDir
- , projectConfigStoreDir, projectConfigBuildOnly
- , projectConfigConfigFile )
-import Distribution.Simple.Program.Db
- ( userSpecifyPaths, userSpecifyArgss, defaultProgramDb
- , modifyProgramSearchPath )
-import Distribution.Simple.BuildPaths
- ( exeExtension )
-import Distribution.Simple.Program.Find
- ( ProgramSearchPathEntry(..) )
-import Distribution.Client.Config
- ( defaultInstallPath, loadConfig, SavedConfig(..) )
-import qualified Distribution.Simple.PackageIndex as PI
-import Distribution.Solver.Types.PackageIndex
- ( lookupPackageName, searchByName )
-import Distribution.Types.InstalledPackageInfo
- ( InstalledPackageInfo(..) )
-import Distribution.Types.Version
- ( Version, nullVersion )
-import Distribution.Types.VersionRange
- ( thisVersion )
-import Distribution.Solver.Types.PackageConstraint
- ( PackageProperty(..) )
-import Distribution.Client.IndexUtils
- ( getSourcePackages, getInstalledPackages )
+ ( MapMappend (..)
+ , PackageConfig (..)
+ , ProjectConfig (..)
+ , ProjectConfigBuildOnly (..)
+ , ProjectConfigShared (..)
+ , getMapLast
+ , getMapMappend
+ , projectConfigBuildOnly
+ , projectConfigConfigFile
+ , projectConfigLogsDir
+ , projectConfigStoreDir
+ )
+import Distribution.Client.ProjectFlags (ProjectFlags (..))
import Distribution.Client.ProjectPlanning
- ( storePackageInstallDirs' )
+ ( storePackageInstallDirs'
+ )
import Distribution.Client.ProjectPlanning.Types
- ( ElaboratedInstallPlan )
-import qualified Distribution.Simple.InstallDirs as InstallDirs
-import Distribution.Client.DistDirLayout
- ( DistDirLayout(..), mkCabalDirLayout
- , cabalStoreDirLayout
- , CabalDirLayout(..), StoreDirLayout(..) )
+ ( ElaboratedInstallPlan
+ )
import Distribution.Client.RebuildMonad
- ( runRebuild )
-import Distribution.Client.InstallSymlink
- ( symlinkBinary, trySymlink, promptRun )
+ ( runRebuild
+ )
+import Distribution.Client.Setup
+ ( ConfigFlags (..)
+ , GlobalFlags (..)
+ , InstallFlags (..)
+ )
+import Distribution.Client.Types
+ ( PackageLocation (..)
+ , PackageSpecifier (..)
+ , SourcePackageDb (..)
+ , UnresolvedSourcePackage
+ )
import Distribution.Client.Types.OverwritePolicy
- ( OverwritePolicy (..) )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault, flagToMaybe, flagElim )
-import Distribution.Simple.Setup
- ( Flag(..), installDirsOptions )
-import Distribution.Solver.Types.SourcePackage
- ( SourcePackage(..) )
+ ( OverwritePolicy (..)
+ )
+import Distribution.Package
+ ( Package (..)
+ , PackageName
+ , mkPackageName
+ , unPackageName
+ )
+import Distribution.Simple.BuildPaths
+ ( exeExtension
+ )
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives, optionName )
-import Distribution.Simple.Configure
- ( configCompilerEx )
+ ( CommandUI (..)
+ , optionName
+ , usageAlternatives
+ )
import Distribution.Simple.Compiler
- ( Compiler(..), CompilerId(..), CompilerFlavor(..)
- , PackageDBStack, PackageDB(..) )
+ ( Compiler (..)
+ , CompilerFlavor (..)
+ , CompilerId (..)
+ , PackageDB (..)
+ , PackageDBStack
+ )
+import Distribution.Simple.Configure
+ ( configCompilerEx
+ )
+import Distribution.Simple.Flag
+ ( flagElim
+ , flagToMaybe
+ , fromFlagOrDefault
+ )
import Distribution.Simple.GHC
- ( ghcPlatformAndVersionString, getGhcAppDir
- , GhcImplInfo(..), getImplInfo
- , GhcEnvironmentFileEntry(..)
- , renderGhcEnvironmentFile, readGhcEnvironmentFile, ParseErrorExc )
+ ( GhcEnvironmentFileEntry (..)
+ , GhcImplInfo (..)
+ , ParseErrorExc
+ , getGhcAppDir
+ , getImplInfo
+ , ghcPlatformAndVersionString
+ , readGhcEnvironmentFile
+ , renderGhcEnvironmentFile
+ )
+import qualified Distribution.Simple.InstallDirs as InstallDirs
+import qualified Distribution.Simple.PackageIndex as PI
+import Distribution.Simple.Program.Db
+ ( defaultProgramDb
+ , modifyProgramSearchPath
+ , userSpecifyArgss
+ , userSpecifyPaths
+ )
+import Distribution.Simple.Program.Find
+ ( ProgramSearchPathEntry (..)
+ )
+import Distribution.Simple.Setup
+ ( Flag (..)
+ , installDirsOptions
+ )
+import Distribution.Simple.Utils
+ ( createDirectoryIfMissingVerbose
+ , die'
+ , notice
+ , ordNub
+ , safeHead
+ , warn
+ , withTempDirectory
+ , wrapText
+ )
+import Distribution.Solver.Types.PackageConstraint
+ ( PackageProperty (..)
+ )
+import Distribution.Solver.Types.PackageIndex
+ ( lookupPackageName
+ , searchByName
+ )
+import Distribution.Solver.Types.SourcePackage
+ ( SourcePackage (..)
+ )
import Distribution.System
- ( Platform , buildOS, OS (Windows) )
+ ( OS (Windows)
+ , Platform
+ , buildOS
+ )
+import Distribution.Types.InstalledPackageInfo
+ ( InstalledPackageInfo (..)
+ )
+import Distribution.Types.PackageId
+ ( PackageIdentifier (..)
+ )
import Distribution.Types.UnitId
- ( UnitId )
+ ( UnitId
+ )
import Distribution.Types.UnqualComponentName
- ( UnqualComponentName, unUnqualComponentName )
-import Distribution.Verbosity
- ( normal, lessVerbose )
-import Distribution.Simple.Utils
- ( wrapText, die', notice, warn
- , withTempDirectory, createDirectoryIfMissingVerbose
- , ordNub, safeHead )
+ ( UnqualComponentName
+ , unUnqualComponentName
+ )
+import Distribution.Types.Version
+ ( Version
+ , nullVersion
+ )
+import Distribution.Types.VersionRange
+ ( thisVersion
+ )
import Distribution.Utils.Generic
- ( writeFileAtomic )
+ ( writeFileAtomic
+ )
+import Distribution.Verbosity
+ ( lessVerbose
+ , normal
+ )
import qualified Data.ByteString.Lazy.Char8 as BS
-import Data.Ord
- ( Down(..) )
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
+import Data.Ord
+ ( Down (..)
+ )
import qualified Data.Set as S
-import qualified Data.List.NonEmpty as NE
import Distribution.Utils.NubList
- ( fromNubList )
+ ( fromNubList
+ )
import Network.URI (URI)
import System.Directory
- ( doesFileExist, createDirectoryIfMissing
- , getTemporaryDirectory, makeAbsolute, doesDirectoryExist
- , removeFile, removeDirectory, copyFile )
+ ( copyFile
+ , createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ , getTemporaryDirectory
+ , makeAbsolute
+ , removeDirectory
+ , removeFile
+ )
import System.FilePath
- ( (</>), (<.>), takeDirectory, takeBaseName )
+ ( takeBaseName
+ , takeDirectory
+ , (<.>)
+ , (</>)
+ )
installCommand :: CommandUI (NixStyleFlags ClientInstallFlags)
-installCommand = CommandUI
- { commandName = "v2-install"
- , commandSynopsis = "Install packages."
- , commandUsage = usageAlternatives
- "v2-install" [ "[TARGETS] [FLAGS]" ]
- , commandDescription = Just $ \_ -> wrapText $
- "Installs one or more packages. This is done by installing them "
- ++ "in the store and symlinking/copying the executables in the directory "
- ++ "specified by the --installdir flag (`~/.local/bin/` by default). "
- ++ "If you want the installed executables to be available globally, "
- ++ "make sure that the PATH environment variable contains that directory. "
- ++ "\n\n"
- ++ "If TARGET is a library and --lib (provisional) is used, "
- ++ "it will be added to the global environment. "
- ++ "When doing this, cabal will try to build a plan that includes all "
- ++ "the previously installed libraries. This is currently not implemented."
- , commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " v2-install\n"
- ++ " Install the package in the current directory\n"
- ++ " " ++ pname ++ " v2-install pkgname\n"
- ++ " Install the package named pkgname"
- ++ " (fetching it from hackage if necessary)\n"
- ++ " " ++ pname ++ " v2-install ./pkgfoo\n"
- ++ " Install the package in the ./pkgfoo directory\n"
-
- , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x
- , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags
- }
- where
- -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.
- notInstallDirOpt x = not $ optionName x `elem` installDirOptNames
- installDirOptNames = map optionName installDirsOptions
-
+installCommand =
+ CommandUI
+ { commandName = "v2-install"
+ , commandSynopsis = "Install packages."
+ , commandUsage =
+ usageAlternatives
+ "v2-install"
+ ["[TARGETS] [FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Installs one or more packages. This is done by installing them "
+ ++ "in the store and symlinking/copying the executables in the directory "
+ ++ "specified by the --installdir flag (`~/.local/bin/` by default). "
+ ++ "If you want the installed executables to be available globally, "
+ ++ "make sure that the PATH environment variable contains that directory. "
+ ++ "\n\n"
+ ++ "If TARGET is a library and --lib (provisional) is used, "
+ ++ "it will be added to the global environment. "
+ ++ "When doing this, cabal will try to build a plan that includes all "
+ ++ "the previously installed libraries. This is currently not implemented."
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v2-install\n"
+ ++ " Install the package in the current directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-install pkgname\n"
+ ++ " Install the package named pkgname"
+ ++ " (fetching it from hackage if necessary)\n"
+ ++ " "
+ ++ pname
+ ++ " v2-install ./pkgfoo\n"
+ ++ " Install the package in the ./pkgfoo directory\n"
+ , commandOptions = \x -> filter notInstallDirOpt $ nixStyleOptions clientInstallOptions x
+ , commandDefaultFlags = defaultNixStyleFlags defaultClientInstallFlags
+ }
+ where
+ -- install doesn't take installDirs flags, since it always installs into the store in a fixed way.
+ notInstallDirOpt x = not $ optionName x `elem` installDirOptNames
+ installDirOptNames = map optionName installDirsOptions
-- | The @install@ command actually serves four different needs. It installs:
-- * exes:
@@ -195,9 +301,8 @@ installCommand = CommandUI
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
installAction :: NixStyleFlags ClientInstallFlags -> [String] -> GlobalFlags -> IO ()
-installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targetStrings globalFlags = do
+installAction flags@NixStyleFlags{extraFlags = clientInstallFlags', ..} targetStrings globalFlags = do
-- Ensure there were no invalid configuration options specified.
verifyPreconditionsOrDie verbosity configFlags'
@@ -207,8 +312,8 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
clientInstallFlags <- getClientInstallFlags verbosity globalFlags clientInstallFlags'
let
- installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
- targetFilter = if installLibs then Just LibKind else Just ExeKind
+ installLibs = fromFlagOrDefault False (cinstInstallLibs clientInstallFlags)
+ targetFilter = if installLibs then Just LibKind else Just ExeKind
targetStrings' = if null targetStrings then ["."] else targetStrings
-- Note the logic here is rather goofy. Target selectors of the form "foo:bar" also parse as uris.
@@ -228,24 +333,30 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
localBaseCtx <-
establishProjectBaseContext reducedVerbosity cliConfig InstallCommand
let localDistDirLayout = distDirLayout localBaseCtx
- pkgDb <- projectConfigWithBuilderRepoContext reducedVerbosity
- (buildSettings localBaseCtx) (getSourcePackages verbosity)
+ pkgDb <-
+ projectConfigWithBuilderRepoContext
+ reducedVerbosity
+ (buildSettings localBaseCtx)
+ (getSourcePackages verbosity)
let
(targetStrings'', packageIds) =
- partitionEithers .
- flip fmap targetStrings' $
- \str -> case simpleParsec str of
- Just (pkgId :: PackageId)
- | pkgVersion pkgId /= nullVersion -> Right pkgId
- _ -> Left str
+ partitionEithers
+ . flip fmap targetStrings'
+ $ \str -> case simpleParsec str of
+ Just (pkgId :: PackageId)
+ | pkgVersion pkgId /= nullVersion -> Right pkgId
+ _ -> Left str
packageSpecifiers =
flip fmap packageIds $ \case
- PackageIdentifier{..}
- | pkgVersion == nullVersion -> NamedPackage pkgName []
- | otherwise -> NamedPackage pkgName
- [PackagePropertyVersion
- (thisVersion pkgVersion)]
+ PackageIdentifier{..}
+ | pkgVersion == nullVersion -> NamedPackage pkgName []
+ | otherwise ->
+ NamedPackage
+ pkgName
+ [ PackagePropertyVersion
+ (thisVersion pkgVersion)
+ ]
packageTargets =
flip TargetPackageNamed targetFilter . pkgName <$> packageIds
@@ -254,17 +365,27 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
else do
targetSelectors <-
either (reportTargetSelectorProblems verbosity) return
- =<< readTargetSelectors (localPackages localBaseCtx)
- Nothing targetStrings''
+ =<< readTargetSelectors
+ (localPackages localBaseCtx)
+ Nothing
+ targetStrings''
(specs, selectors) <-
getSpecsAndTargetSelectors
- verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter
-
- return ( specs ++ packageSpecifiers
- , []
- , selectors ++ packageTargets
- , projectConfig localBaseCtx )
+ verbosity
+ reducedVerbosity
+ pkgDb
+ targetSelectors
+ localDistDirLayout
+ localBaseCtx
+ targetFilter
+
+ return
+ ( specs ++ packageSpecifiers
+ , []
+ , selectors ++ packageTargets
+ , projectConfig localBaseCtx
+ )
withoutProject :: ProjectConfig -> IO ([PackageSpecifier UnresolvedSourcePackage], [URI], [TargetSelector], ProjectConfig)
withoutProject _ | null targetStrings = withProject -- if there's no targets, we don't parse specially, but treat it as install in a standard cabal package dir
@@ -273,86 +394,106 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
let
projectConfig = globalConfig <> cliConfig
- ProjectConfigBuildOnly {
- projectConfigLogsDir
- } = projectConfigBuildOnly projectConfig
+ ProjectConfigBuildOnly
+ { projectConfigLogsDir
+ } = projectConfigBuildOnly projectConfig
- ProjectConfigShared {
- projectConfigStoreDir
- } = projectConfigShared projectConfig
+ ProjectConfigShared
+ { projectConfigStoreDir
+ } = projectConfigShared projectConfig
mlogsDir = flagToMaybe projectConfigLogsDir
mstoreDir = flagToMaybe projectConfigStoreDir
cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
let
- buildSettings = resolveBuildTimeSettings
- verbosity cabalDirLayout
- projectConfig
-
- SourcePackageDb { packageIndex } <- projectConfigWithBuilderRepoContext
- verbosity buildSettings
- (getSourcePackages verbosity)
+ buildSettings =
+ resolveBuildTimeSettings
+ verbosity
+ cabalDirLayout
+ projectConfig
+
+ SourcePackageDb{packageIndex} <-
+ projectConfigWithBuilderRepoContext
+ verbosity
+ buildSettings
+ (getSourcePackages verbosity)
for_ (concatMap woPackageNames tss) $ \name -> do
when (null (lookupPackageName packageIndex name)) $ do
let xs = searchByName packageIndex (unPackageName name)
- let emptyIf True _ = []
+ let emptyIf True _ = []
emptyIf False zs = zs
- die' verbosity $ concat $
- [ "Unknown package \"", unPackageName name, "\". "
- ] ++ emptyIf (null xs)
- [ "Did you mean any of the following?\n"
- , unlines (("- " ++) . unPackageName . fst <$> xs)
- ]
+ die' verbosity $
+ concat $
+ [ "Unknown package \""
+ , unPackageName name
+ , "\". "
+ ]
+ ++ emptyIf
+ (null xs)
+ [ "Did you mean any of the following?\n"
+ , unlines (("- " ++) . unPackageName . fst <$> xs)
+ ]
let
(uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
- packageTargets = map woPackageTargets tss
+ packageTargets = map woPackageTargets tss
return (packageSpecifiers, uris, packageTargets, projectConfig)
(specs, uris, targetSelectors, config) <-
- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject
+ withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag withProject withoutProject
let
- ProjectConfig {
- projectConfigBuildOnly = ProjectConfigBuildOnly {
- projectConfigLogsDir
- },
- projectConfigShared = ProjectConfigShared {
- projectConfigHcFlavor,
- projectConfigHcPath,
- projectConfigHcPkg,
- projectConfigStoreDir
- },
- projectConfigLocalPackages = PackageConfig {
- packageConfigProgramPaths,
- packageConfigProgramArgs,
- packageConfigProgramPathExtra
- }
- } = config
+ ProjectConfig
+ { projectConfigBuildOnly =
+ ProjectConfigBuildOnly
+ { projectConfigLogsDir
+ }
+ , projectConfigShared =
+ ProjectConfigShared
+ { projectConfigHcFlavor
+ , projectConfigHcPath
+ , projectConfigHcPkg
+ , projectConfigStoreDir
+ }
+ , projectConfigLocalPackages =
+ PackageConfig
+ { packageConfigProgramPaths
+ , packageConfigProgramArgs
+ , packageConfigProgramPathExtra
+ }
+ } = config
hcFlavor = flagToMaybe projectConfigHcFlavor
- hcPath = flagToMaybe projectConfigHcPath
- hcPkg = flagToMaybe projectConfigHcPkg
+ hcPath = flagToMaybe projectConfigHcPath
+ hcPkg = flagToMaybe projectConfigHcPkg
-- ProgramDb with directly user specified paths
preProgDb =
- userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
- . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
- . modifyProgramSearchPath
- (++ [ ProgramSearchPathDir dir
- | dir <- fromNubList packageConfigProgramPathExtra ])
- $ defaultProgramDb
+ userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
+ . userSpecifyArgss (Map.toList (getMapMappend packageConfigProgramArgs))
+ . modifyProgramSearchPath
+ ( ++
+ [ ProgramSearchPathDir dir
+ | dir <- fromNubList packageConfigProgramPathExtra
+ ]
+ )
+ $ defaultProgramDb
-- progDb is a program database with compiler tools configured properly
- (compiler@Compiler { compilerId =
- compilerId@(CompilerId compilerFlavor compilerVersion) }, platform, progDb) <-
- configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity
+ ( compiler@Compiler
+ { compilerId =
+ compilerId@(CompilerId compilerFlavor compilerVersion)
+ }
+ , platform
+ , progDb
+ ) <-
+ configCompilerEx hcFlavor hcPath hcPkg preProgDb verbosity
let
- GhcImplInfo{ supportsPkgEnvFiles } = getImplInfo compiler
+ GhcImplInfo{supportsPkgEnvFiles} = getImplInfo compiler
envFile <- getEnvFile clientInstallFlags platform compilerVersion
existingEnvEntries <-
@@ -372,12 +513,14 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
withTempDirectory verbosity globalTmp "cabal-install." $ \tmpDir -> do
distDirLayout <- establishDummyDistDirLayout verbosity config tmpDir
- uriSpecs <- runRebuild tmpDir $ fetchAndReadSourcePackages
- verbosity
- distDirLayout
- (projectConfigShared config)
- (projectConfigBuildOnly config)
- [ ProjectPackageRemoteTarball uri | uri <- uris ]
+ uriSpecs <-
+ runRebuild tmpDir $
+ fetchAndReadSourcePackages
+ verbosity
+ distDirLayout
+ (projectConfigShared config)
+ (projectConfigBuildOnly config)
+ [ProjectPackageRemoteTarball uri | uri <- uris]
-- check for targets already in env
let getPackageName :: PackageSpecifier UnresolvedSourcePackage -> PackageName
@@ -389,27 +532,31 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
nameIntersection = S.intersection targetNames envNames
-- we check for intersections in targets with the existing env
- (envSpecs', nonGlobalEnvEntries') <- if null nameIntersection
- then pure (envSpecs, map snd nonGlobalEnvEntries)
- else if forceInstall
- then let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs
- nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries
- in pure (es, nge)
- else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection)
+ (envSpecs', nonGlobalEnvEntries') <-
+ if null nameIntersection
+ then pure (envSpecs, map snd nonGlobalEnvEntries)
+ else
+ if forceInstall
+ then
+ let es = filter (\e -> not $ getPackageName e `S.member` nameIntersection) envSpecs
+ nge = map snd . filter (\e -> not $ fst e `S.member` nameIntersection) $ nonGlobalEnvEntries
+ in pure (es, nge)
+ else die' verbosity $ "Packages requested to install already exist in environment file at " ++ envFile ++ ". Overwriting them may break other packages. Use --force-reinstalls to proceed anyway. Packages: " ++ intercalate ", " (map prettyShow $ S.toList nameIntersection)
-- we construct an installed index of files in the cleaned target environment (absent overwrites) so that we can solve with regards to packages installed locally but not in the upstream repo
let installedPacks = PI.allPackagesByName installedIndex
newEnvNames = S.fromList $ map getPackageName envSpecs'
installedIndex' = PI.fromList . concatMap snd . filter (\p -> fst p `S.member` newEnvNames) $ installedPacks
- baseCtx <- establishDummyProjectBaseContext
- verbosity
- config
- distDirLayout
- (envSpecs' ++ specs ++ uriSpecs)
- InstallCommand
+ baseCtx <-
+ establishDummyProjectBaseContext
+ verbosity
+ config
+ distDirLayout
+ (envSpecs' ++ specs ++ uriSpecs)
+ InstallCommand
- buildCtx <- constructProjectBuildContext verbosity (baseCtx {installedPackages = Just installedIndex'}) targetSelectors
+ buildCtx <- constructProjectBuildContext verbosity (baseCtx{installedPackages = Just installedIndex'}) targetSelectors
printPlan verbosity baseCtx buildCtx
@@ -419,33 +566,50 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
-- Now that we built everything we can do the installation part.
-- First, figure out if / what parts we want to install:
let
- dryRun = buildSettingDryRun (buildSettings baseCtx)
- || buildSettingOnlyDownload (buildSettings baseCtx)
+ dryRun =
+ buildSettingDryRun (buildSettings baseCtx)
+ || buildSettingOnlyDownload (buildSettings baseCtx)
-- Then, install!
unless dryRun $
if installLibs
- then installLibraries verbosity
- buildCtx installedIndex compiler packageDbs envFile nonGlobalEnvEntries'
- else installExes verbosity
- baseCtx buildCtx platform compiler configFlags clientInstallFlags
+ then
+ installLibraries
+ verbosity
+ buildCtx
+ installedIndex
+ compiler
+ packageDbs
+ envFile
+ nonGlobalEnvEntries'
+ else
+ installExes
+ verbosity
+ baseCtx
+ buildCtx
+ platform
+ compiler
+ configFlags
+ clientInstallFlags
where
configFlags' = disableTestsBenchsByDefault configFlags
verbosity = fromFlagOrDefault normal (configVerbosity configFlags')
ignoreProject = flagIgnoreProject projectFlags
- baseCliConfig = commandLineFlagsToProjectConfig
- globalFlags
- flags { configFlags = configFlags' }
- clientInstallFlags'
+ baseCliConfig =
+ commandLineFlagsToProjectConfig
+ globalFlags
+ flags{configFlags = configFlags'}
+ clientInstallFlags'
cliConfig = addLocalConfigToTargets baseCliConfig targetStrings
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
-- | Treat all direct targets of install command as local packages: #8637
addLocalConfigToTargets :: ProjectConfig -> [String] -> ProjectConfig
-addLocalConfigToTargets config targetStrings
- = config {
- projectConfigSpecificPackage = projectConfigSpecificPackage config
- <> MapMappend (Map.fromList targetPackageConfigs)
+addLocalConfigToTargets config targetStrings =
+ config
+ { projectConfigSpecificPackage =
+ projectConfigSpecificPackage config
+ <> MapMappend (Map.fromList targetPackageConfigs)
}
where
localConfig = projectConfigLocalPackages config
@@ -460,11 +624,13 @@ verifyPreconditionsOrDie verbosity configFlags = do
-- So we set them as disabled by default and error if they are explicitly
-- enabled.
when (configTests configFlags == Flag True) $
- die' verbosity $ "--enable-tests was specified, but tests can't "
- ++ "be enabled in a remote package"
+ die' verbosity $
+ "--enable-tests was specified, but tests can't "
+ ++ "be enabled in a remote package"
when (configBenchmarks configFlags == Flag True) $
- die' verbosity $ "--enable-benchmarks was specified, but benchmarks can't "
- ++ "be enabled in a remote package"
+ die' verbosity $
+ "--enable-benchmarks was specified, but benchmarks can't "
+ ++ "be enabled in a remote package"
getClientInstallFlags :: Verbosity -> GlobalFlags -> ClientInstallFlags -> IO ClientInstallFlags
getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do
@@ -472,7 +638,6 @@ getClientInstallFlags verbosity globalFlags existingClientInstallFlags = do
savedConfig <- loadConfig verbosity configFileFlag
pure $ savedClientInstallFlags savedConfig `mappend` existingClientInstallFlags
-
getSpecsAndTargetSelectors
:: Verbosity
-> Verbosity
@@ -484,50 +649,57 @@ getSpecsAndTargetSelectors
-> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter =
withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do
- -- Split into known targets and hackage packages.
- (targets, hackageNames) <-
- partitionToKnownTargetsAndHackagePackages
- verbosity pkgDb elaboratedPlan targetSelectors
-
- let
- planMap = InstallPlan.toMap elaboratedPlan
- targetIds = Map.keys targets
-
- sdistize (SpecificSourcePackage spkg) =
- SpecificSourcePackage spkg'
- where
- sdistPath = distSdistFile localDistDirLayout (packageId spkg)
- spkg' = spkg { srcpkgSource = LocalTarballPackage sdistPath }
- sdistize named = named
-
- local = sdistize <$> localPackages localBaseCtx
-
- gatherTargets :: UnitId -> TargetSelector
- gatherTargets targetId = TargetPackageNamed pkgName targetFilter
- where
- targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
- PackageIdentifier{..} = packageId targetUnit
-
- targets' = fmap gatherTargets targetIds
-
- hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
- hackagePkgs = flip NamedPackage [] <$> hackageNames
-
- hackageTargets :: [TargetSelector]
- hackageTargets =
- flip TargetPackageNamed targetFilter <$> hackageNames
-
- createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)
+ -- Split into known targets and hackage packages.
+ (targets, hackageNames) <-
+ partitionToKnownTargetsAndHackagePackages
+ verbosity
+ pkgDb
+ elaboratedPlan
+ targetSelectors
- unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
- SpecificSourcePackage pkg -> packageToSdist verbosity
- (distProjectRootDirectory localDistDirLayout) TarGzArchive
- (distSdistFile localDistDirLayout (packageId pkg)) pkg
+ let
+ planMap = InstallPlan.toMap elaboratedPlan
+ targetIds = Map.keys targets
+
+ sdistize (SpecificSourcePackage spkg) =
+ SpecificSourcePackage spkg'
+ where
+ sdistPath = distSdistFile localDistDirLayout (packageId spkg)
+ spkg' = spkg{srcpkgSource = LocalTarballPackage sdistPath}
+ sdistize named = named
+
+ local = sdistize <$> localPackages localBaseCtx
+
+ gatherTargets :: UnitId -> TargetSelector
+ gatherTargets targetId = TargetPackageNamed pkgName targetFilter
+ where
+ targetUnit = Map.findWithDefault (error "cannot find target unit") targetId planMap
+ PackageIdentifier{..} = packageId targetUnit
+
+ targets' = fmap gatherTargets targetIds
+
+ hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
+ hackagePkgs = flip NamedPackage [] <$> hackageNames
+
+ hackageTargets :: [TargetSelector]
+ hackageTargets =
+ flip TargetPackageNamed targetFilter <$> hackageNames
+
+ createDirectoryIfMissing True (distSdistDirectory localDistDirLayout)
+
+ unless (Map.null targets) $ for_ (localPackages localBaseCtx) $ \lpkg -> case lpkg of
+ SpecificSourcePackage pkg ->
+ packageToSdist
+ verbosity
+ (distProjectRootDirectory localDistDirLayout)
+ TarGzArchive
+ (distSdistFile localDistDirLayout (packageId pkg))
+ pkg
NamedPackage pkgName _ -> error $ "Got NamedPackage " ++ prettyShow pkgName
- if null targets
- then return (hackagePkgs, hackageTargets)
- else return (local ++ hackagePkgs, targets' ++ hackageTargets)
+ if null targets
+ then return (hackagePkgs, hackageTargets)
+ else return (local ++ hackagePkgs, targets' ++ hackageTargets)
-- | Partitions the target selectors into known local targets and hackage packages.
partitionToKnownTargetsAndHackagePackages
@@ -537,33 +709,37 @@ partitionToKnownTargetsAndHackagePackages
-> [TargetSelector]
-> IO (TargetsMap, [PackageName])
partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
- let mTargets = resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- (Just pkgDb)
- targetSelectors
+ let mTargets =
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ (Just pkgDb)
+ targetSelectors
case mTargets of
Right targets ->
-- Everything is a local dependency.
return (targets, [])
- Left errs -> do
+ Left errs -> do
-- Not everything is local.
let
(errs', hackageNames) = partitionEithers . flip fmap errs $ \case
TargetAvailableInIndex name -> Right name
- err -> Left err
+ err -> Left err
-- report incorrect case for known package.
for_ errs' $ \case
TargetNotInProject hn ->
case searchByName (packageIndex pkgDb) (unPackageName hn) of
[] -> return ()
- xs -> die' verbosity . concat $
- [ "Unknown package \"", unPackageName hn, "\". "
- , "Did you mean any of the following?\n"
- , unlines (("- " ++) . unPackageName . fst <$> xs)
- ]
+ xs ->
+ die' verbosity . concat $
+ [ "Unknown package \""
+ , unPackageName hn
+ , "\". "
+ , "Did you mean any of the following?\n"
+ , unlines (("- " ++) . unPackageName . fst <$> xs)
+ ]
_ -> return ()
when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'
@@ -574,52 +750,52 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
| name `elem` hackageNames -> False
TargetPackageNamed name _
| name `elem` hackageNames -> False
- _ -> True
+ _ -> True
-- This can't fail, because all of the errors are
-- removed (or we've given up).
targets <-
either (reportBuildTargetProblems verbosity) return $
- resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors'
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors'
return (targets, hackageNames)
-
-
constructProjectBuildContext
:: Verbosity
-> ProjectBaseContext
- -- ^ The synthetic base context to use to produce the full build context.
+ -- ^ The synthetic base context to use to produce the full build context.
-> [TargetSelector]
-> IO ProjectBuildContext
constructProjectBuildContext verbosity baseCtx targetSelectors = do
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-- Interpret the targets on the command line as build targets
- targets <- either (reportBuildTargetProblems verbosity) return $
- resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
+ targets <-
+ either (reportBuildTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
let prunedToTargetsElaboratedPlan =
pruneInstallPlanToTargets TargetActionBuild targets elaboratedPlan
prunedElaboratedPlan <-
if buildSettingOnlyDeps (buildSettings baseCtx)
- then either (reportCannotPruneDependencies verbosity) return $
- pruneInstallPlanToDependencies (Map.keysSet targets)
- prunedToTargetsElaboratedPlan
- else return prunedToTargetsElaboratedPlan
+ then
+ either (reportCannotPruneDependencies verbosity) return $
+ pruneInstallPlanToDependencies
+ (Map.keysSet targets)
+ prunedToTargetsElaboratedPlan
+ else return prunedToTargetsElaboratedPlan
return (prunedElaboratedPlan, targets)
-
-- | Install any built exe by symlinking/copying it
-- we don't use BuildOutcomes because we also need the component names
installExes
@@ -631,59 +807,74 @@ installExes
-> ConfigFlags
-> ClientInstallFlags
-> IO ()
-installExes verbosity baseCtx buildCtx platform compiler
- configFlags clientInstallFlags = do
- installPath <- defaultInstallPath
- let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
-
- prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))
- suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))
-
- mkUnitBinDir :: UnitId -> FilePath
- mkUnitBinDir =
- InstallDirs.bindir .
- storePackageInstallDirs' storeDirLayout (compilerId compiler)
-
- mkExeName :: UnqualComponentName -> FilePath
- mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
-
- mkFinalExeName :: UnqualComponentName -> FilePath
- mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform
- installdirUnknown =
- "installdir is not defined. Set it in your cabal config file "
- ++ "or use --installdir=<path>. Using default installdir: " ++ show installPath
-
- installdir <- fromFlagOrDefault
- (warn verbosity installdirUnknown >> pure installPath) $
- pure <$> cinstInstalldir clientInstallFlags
- createDirectoryIfMissingVerbose verbosity True installdir
- warnIfNoExes verbosity buildCtx
-
- installMethod <- flagElim defaultMethod return $
- cinstInstallMethod clientInstallFlags
+installExes
+ verbosity
+ baseCtx
+ buildCtx
+ platform
+ compiler
+ configFlags
+ clientInstallFlags = do
+ installPath <- defaultInstallPath
+ let storeDirLayout = cabalStoreDirLayout $ cabalDirLayout baseCtx
+
+ prefix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgPrefix configFlags))
+ suffix = fromFlagOrDefault "" (fmap InstallDirs.fromPathTemplate (configProgSuffix configFlags))
+
+ mkUnitBinDir :: UnitId -> FilePath
+ mkUnitBinDir =
+ InstallDirs.bindir
+ . storePackageInstallDirs' storeDirLayout (compilerId compiler)
+
+ mkExeName :: UnqualComponentName -> FilePath
+ mkExeName exe = unUnqualComponentName exe <.> exeExtension platform
+
+ mkFinalExeName :: UnqualComponentName -> FilePath
+ mkFinalExeName exe = prefix <> unUnqualComponentName exe <> suffix <.> exeExtension platform
+ installdirUnknown =
+ "installdir is not defined. Set it in your cabal config file "
+ ++ "or use --installdir=<path>. Using default installdir: "
+ ++ show installPath
+
+ installdir <-
+ fromFlagOrDefault
+ (warn verbosity installdirUnknown >> pure installPath)
+ $ pure <$> cinstInstalldir clientInstallFlags
+ createDirectoryIfMissingVerbose verbosity True installdir
+ warnIfNoExes verbosity buildCtx
+
+ installMethod <-
+ flagElim defaultMethod return $
+ cinstInstallMethod clientInstallFlags
- let
- doInstall = installUnitExes
- verbosity
- overwritePolicy
- mkUnitBinDir mkExeName mkFinalExeName
- installdir installMethod
- in traverse_ doInstall $ Map.toList $ targetsMap buildCtx
- where
- overwritePolicy = fromFlagOrDefault NeverOverwrite $
- cinstOverwritePolicy clientInstallFlags
- isWindows = buildOS == Windows
-
- -- This is in IO as we will make environment checks,
- -- to decide which method is best
- defaultMethod :: IO InstallMethod
- defaultMethod
- -- Try symlinking in temporary directory, if it works default to
- -- symlinking even on windows
- | isWindows = do
- symlinks <- trySymlink verbosity
- return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
- | otherwise = return InstallMethodSymlink
+ let
+ doInstall =
+ installUnitExes
+ verbosity
+ overwritePolicy
+ mkUnitBinDir
+ mkExeName
+ mkFinalExeName
+ installdir
+ installMethod
+ in
+ traverse_ doInstall $ Map.toList $ targetsMap buildCtx
+ where
+ overwritePolicy =
+ fromFlagOrDefault NeverOverwrite $
+ cinstOverwritePolicy clientInstallFlags
+ isWindows = buildOS == Windows
+
+ -- This is in IO as we will make environment checks,
+ -- to decide which method is best
+ defaultMethod :: IO InstallMethod
+ defaultMethod
+ -- Try symlinking in temporary directory, if it works default to
+ -- symlinking even on windows
+ | isWindows = do
+ symlinks <- trySymlink verbosity
+ return $ if symlinks then InstallMethodSymlink else InstallMethodCopy
+ | otherwise = return InstallMethodSymlink
-- | Install any built library by adding it to the default ghc environment
installLibraries
@@ -692,70 +883,82 @@ installLibraries
-> PI.PackageIndex InstalledPackageInfo
-> Compiler
-> PackageDBStack
- -> FilePath -- ^ Environment file
+ -> FilePath
+ -- ^ Environment file
-> [GhcEnvironmentFileEntry]
-> IO ()
-installLibraries verbosity buildCtx installedIndex compiler
- packageDbs' envFile envEntries = do
- if supportsPkgEnvFiles $ getImplInfo compiler
- then do
- let validDb (SpecificPackageDB fp) = doesPathExist fp
- validDb _ = pure True
- -- if a user "installs" a global package and no existing cabal db exists, none will be created.
- -- this ensures we don't add the "phantom" path to the file.
- packageDbs <- filterM validDb packageDbs'
- let
- getLatest = (=<<) (maybeToList . safeHead . snd) . take 1 . sortBy (comparing (Down . fst))
- . PI.lookupPackageName installedIndex
- globalLatest = concat (getLatest <$> globalPackages)
- globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest
- baseEntries =
- GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs
- pkgEntries = ordNub $
- globalEntries
- ++ envEntries
- ++ entriesForLibraryComponents (targetsMap buildCtx)
- contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
- createDirectoryIfMissing True (takeDirectory envFile)
- writeFileAtomic envFile (BS.pack contents')
- else
- warn verbosity $
+installLibraries
+ verbosity
+ buildCtx
+ installedIndex
+ compiler
+ packageDbs'
+ envFile
+ envEntries = do
+ if supportsPkgEnvFiles $ getImplInfo compiler
+ then do
+ let validDb (SpecificPackageDB fp) = doesPathExist fp
+ validDb _ = pure True
+ -- if a user "installs" a global package and no existing cabal db exists, none will be created.
+ -- this ensures we don't add the "phantom" path to the file.
+ packageDbs <- filterM validDb packageDbs'
+ let
+ getLatest =
+ (=<<) (maybeToList . safeHead . snd)
+ . take 1
+ . sortBy (comparing (Down . fst))
+ . PI.lookupPackageName installedIndex
+ globalLatest = concat (getLatest <$> globalPackages)
+ globalEntries = GhcEnvFilePackageId . installedUnitId <$> globalLatest
+ baseEntries =
+ GhcEnvFileClearPackageDbStack : fmap GhcEnvFilePackageDb packageDbs
+ pkgEntries =
+ ordNub $
+ globalEntries
+ ++ envEntries
+ ++ entriesForLibraryComponents (targetsMap buildCtx)
+ contents' = renderGhcEnvironmentFile (baseEntries ++ pkgEntries)
+ createDirectoryIfMissing True (takeDirectory envFile)
+ writeFileAtomic envFile (BS.pack contents')
+ else
+ warn verbosity $
"The current compiler doesn't support safely installing libraries, "
- ++ "so only executables will be available. (Library installation is "
- ++ "supported on GHC 8.0+ only)"
+ ++ "so only executables will be available. (Library installation is "
+ ++ "supported on GHC 8.0+ only)"
-- See ticket #8894. This is safe to include any nonreinstallable boot pkg,
-- but the particular package users will always expect to be in scope without specific installation
-- is base, so that they can access prelude, regardles of if they specifically asked for it.
globalPackages :: [PackageName]
-globalPackages = mkPackageName <$> [ "base" ]
+globalPackages = mkPackageName <$> ["base"]
warnIfNoExes :: Verbosity -> ProjectBuildContext -> IO ()
warnIfNoExes verbosity buildCtx =
when noExes $
warn verbosity $
- "\n" <>
- "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>
- "@ WARNING: Installation might not be completed as desired! @\n" <>
- "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n" <>
- "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n" <>
- "* You might have wanted to add them as dependencies to your package." <>
- " In this case add \"" <>
- intercalate ", " (showTargetSelector <$> selectors) <>
- "\" to the build-depends field(s) of your package's .cabal file.\n" <>
- "* You might have wanted to add them to a GHC environment. In this case" <>
- " use \"cabal install --lib " <>
- unwords (showTargetSelector <$> selectors) <> "\". " <>
- " The \"--lib\" flag is provisional: see" <>
- " https://github.com/haskell/cabal/issues/6481 for more information."
+ "\n"
+ <> "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
+ <> "@ WARNING: Installation might not be completed as desired! @\n"
+ <> "@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
+ <> "The command \"cabal install [TARGETS]\" doesn't expose libraries.\n"
+ <> "* You might have wanted to add them as dependencies to your package."
+ <> " In this case add \""
+ <> intercalate ", " (showTargetSelector <$> selectors)
+ <> "\" to the build-depends field(s) of your package's .cabal file.\n"
+ <> "* You might have wanted to add them to a GHC environment. In this case"
+ <> " use \"cabal install --lib "
+ <> unwords (showTargetSelector <$> selectors)
+ <> "\". "
+ <> " The \"--lib\" flag is provisional: see"
+ <> " https://github.com/haskell/cabal/issues/6481 for more information."
where
- targets = concat $ Map.elems $ targetsMap buildCtx
+ targets = concat $ Map.elems $ targetsMap buildCtx
components = fst <$> targets
- selectors = concatMap (NE.toList . snd) targets
- noExes = null $ catMaybes $ exeMaybe <$> components
+ selectors = concatMap (NE.toList . snd) targets
+ noExes = null $ catMaybes $ exeMaybe <$> components
exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
- exeMaybe _ = Nothing
+ exeMaybe _ = Nothing
-- | Return the package specifiers and non-global environment file entries.
getEnvSpecsAndNonGlobalEntries
@@ -765,122 +968,161 @@ getEnvSpecsAndNonGlobalEntries
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
getEnvSpecsAndNonGlobalEntries installedIndex entries installLibs =
if installLibs
- then (envSpecs, envEntries')
- else ([], envEntries')
+ then (envSpecs, envEntries')
+ else ([], envEntries')
where
(envSpecs, envEntries') = environmentFileToSpecifiers installedIndex entries
environmentFileToSpecifiers
- :: PI.InstalledPackageIndex -> [GhcEnvironmentFileEntry]
+ :: PI.InstalledPackageIndex
+ -> [GhcEnvironmentFileEntry]
-> ([PackageSpecifier a], [(PackageName, GhcEnvironmentFileEntry)])
environmentFileToSpecifiers ipi = foldMap $ \case
- (GhcEnvFilePackageId unitId)
- | Just InstalledPackageInfo
- { sourcePackageId = PackageIdentifier{..}, installedUnitId }
- <- PI.lookupUnitId ipi unitId
- , let pkgSpec = NamedPackage pkgName
- [PackagePropertyVersion (thisVersion pkgVersion)]
- -> ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)])
- _ -> ([], [])
-
+ (GhcEnvFilePackageId unitId)
+ | Just
+ InstalledPackageInfo
+ { sourcePackageId = PackageIdentifier{..}
+ , installedUnitId
+ } <-
+ PI.lookupUnitId ipi unitId
+ , let pkgSpec =
+ NamedPackage
+ pkgName
+ [PackagePropertyVersion (thisVersion pkgVersion)] ->
+ ([pkgSpec], [(pkgName, GhcEnvFilePackageId installedUnitId)])
+ _ -> ([], [])
-- | Disables tests and benchmarks if they weren't explicitly enabled.
disableTestsBenchsByDefault :: ConfigFlags -> ConfigFlags
disableTestsBenchsByDefault configFlags =
- configFlags { configTests = Flag False <> configTests configFlags
- , configBenchmarks = Flag False <> configBenchmarks configFlags }
+ configFlags
+ { configTests = Flag False <> configTests configFlags
+ , configBenchmarks = Flag False <> configBenchmarks configFlags
+ }
-- | Symlink/copy every exe from a package from the store to a given location
installUnitExes
:: Verbosity
- -> OverwritePolicy -- ^ Whether to overwrite existing files
- -> (UnitId -> FilePath) -- ^ A function to get an UnitId's
- -- ^ store directory
- -> (UnqualComponentName -> FilePath) -- ^ A function to get an
- -- ^ exe's filename
- -> (UnqualComponentName -> FilePath) -- ^ A function to get an
- -- ^ exe's final possibly
- -- ^ different to the name in the store.
+ -> OverwritePolicy
+ -- ^ Whether to overwrite existing files
+ -> (UnitId -> FilePath)
+ -- ^ A function to get an UnitId's
+ -- ^ store directory
+ -> (UnqualComponentName -> FilePath)
+ -- ^ A function to get an
+ -- ^ exe's filename
+ -> (UnqualComponentName -> FilePath)
+ -- ^ A function to get an
+ -- ^ exe's final possibly
+ -- ^ different to the name in the store.
-> FilePath
-> InstallMethod
-> ( UnitId
- , [(ComponentTarget, NonEmpty TargetSelector)] )
+ , [(ComponentTarget, NonEmpty TargetSelector)]
+ )
-> IO ()
-installUnitExes verbosity overwritePolicy
- mkSourceBinDir mkExeName mkFinalExeName
- installdir installMethod
- (unit, components) =
- traverse_ installAndWarn exes
- where
- exes = catMaybes $ (exeMaybe . fst) <$> components
- exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
- exeMaybe _ = Nothing
- installAndWarn exe = do
- success <- installBuiltExe
- verbosity overwritePolicy
- (mkSourceBinDir unit) (mkExeName exe)
- (mkFinalExeName exe)
- installdir installMethod
- let errorMessage = case overwritePolicy of
- NeverOverwrite ->
- "Path '" <> (installdir </> prettyShow exe) <> "' already exists. "
- <> "Use --overwrite-policy=always to overwrite."
- -- This shouldn't even be possible, but we keep it in case
- -- symlinking/copying logic changes
- _ ->
- case installMethod of
- InstallMethodSymlink -> "Symlinking"
- InstallMethodCopy ->
- "Copying" <> " '" <> prettyShow exe <> "' failed."
- unless success $ die' verbosity errorMessage
+installUnitExes
+ verbosity
+ overwritePolicy
+ mkSourceBinDir
+ mkExeName
+ mkFinalExeName
+ installdir
+ installMethod
+ (unit, components) =
+ traverse_ installAndWarn exes
+ where
+ exes = catMaybes $ (exeMaybe . fst) <$> components
+ exeMaybe (ComponentTarget (CExeName exe) _) = Just exe
+ exeMaybe _ = Nothing
+ installAndWarn exe = do
+ success <-
+ installBuiltExe
+ verbosity
+ overwritePolicy
+ (mkSourceBinDir unit)
+ (mkExeName exe)
+ (mkFinalExeName exe)
+ installdir
+ installMethod
+ let errorMessage = case overwritePolicy of
+ NeverOverwrite ->
+ "Path '"
+ <> (installdir </> prettyShow exe)
+ <> "' already exists. "
+ <> "Use --overwrite-policy=always to overwrite."
+ -- This shouldn't even be possible, but we keep it in case
+ -- symlinking/copying logic changes
+ _ ->
+ case installMethod of
+ InstallMethodSymlink -> "Symlinking"
+ InstallMethodCopy ->
+ "Copying" <> " '" <> prettyShow exe <> "' failed."
+ unless success $ die' verbosity errorMessage
-- | Install a specific exe.
installBuiltExe
- :: Verbosity -> OverwritePolicy
- -> FilePath -- ^ The directory where the built exe is located
- -> FilePath -- ^ The exe's filename
- -> FilePath -- ^ The exe's filename in the public install directory
- -> FilePath -- ^ the directory where it should be installed
+ :: Verbosity
+ -> OverwritePolicy
+ -> FilePath
+ -- ^ The directory where the built exe is located
+ -> FilePath
+ -- ^ The exe's filename
+ -> FilePath
+ -- ^ The exe's filename in the public install directory
+ -> FilePath
+ -- ^ the directory where it should be installed
-> InstallMethod
- -> IO Bool -- ^ Whether the installation was successful
-installBuiltExe verbosity overwritePolicy
- sourceDir exeName finalExeName
- installdir InstallMethodSymlink = do
- notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"
- symlinkBinary
- overwritePolicy
- installdir
- sourceDir
- finalExeName
- exeName
- where
- destination = installdir </> finalExeName
-installBuiltExe verbosity overwritePolicy
- sourceDir exeName finalExeName
- installdir InstallMethodCopy = do
- notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"
- exists <- doesPathExist destination
- case (exists, overwritePolicy) of
- (True , NeverOverwrite ) -> pure False
- (True , AlwaysOverwrite) -> overwrite
- (True , PromptOverwrite) -> maybeOverwrite
- (False, _ ) -> copy
- where
- source = sourceDir </> exeName
- destination = installdir </> finalExeName
- remove = do
- isDir <- doesDirectoryExist destination
- if isDir
- then removeDirectory destination
- else removeFile destination
- copy = copyFile source destination >> pure True
- overwrite :: IO Bool
- overwrite = remove >> copy
- maybeOverwrite :: IO Bool
- maybeOverwrite
- = promptRun
- "Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
- overwrite
+ -> IO Bool
+ -- ^ Whether the installation was successful
+installBuiltExe
+ verbosity
+ overwritePolicy
+ sourceDir
+ exeName
+ finalExeName
+ installdir
+ InstallMethodSymlink = do
+ notice verbosity $ "Symlinking '" <> exeName <> "' to '" <> destination <> "'"
+ symlinkBinary
+ overwritePolicy
+ installdir
+ sourceDir
+ finalExeName
+ exeName
+ where
+ destination = installdir </> finalExeName
+installBuiltExe
+ verbosity
+ overwritePolicy
+ sourceDir
+ exeName
+ finalExeName
+ installdir
+ InstallMethodCopy = do
+ notice verbosity $ "Copying '" <> exeName <> "' to '" <> destination <> "'"
+ exists <- doesPathExist destination
+ case (exists, overwritePolicy) of
+ (True, NeverOverwrite) -> pure False
+ (True, AlwaysOverwrite) -> overwrite
+ (True, PromptOverwrite) -> maybeOverwrite
+ (False, _) -> copy
+ where
+ source = sourceDir </> exeName
+ destination = installdir </> finalExeName
+ remove = do
+ isDir <- doesDirectoryExist destination
+ if isDir
+ then removeDirectory destination
+ else removeFile destination
+ copy = copyFile source destination >> pure True
+ overwrite :: IO Bool
+ overwrite = remove >> copy
+ maybeOverwrite :: IO Bool
+ maybeOverwrite =
+ promptRun
+ "Existing file found while installing executable. Do you want to overwrite that file? (y/n)"
+ overwrite
-- | Create 'GhcEnvironmentFileEntry's for packages with exposed libraries.
entriesForLibraryComponents :: TargetsMap -> [GhcEnvironmentFileEntry]
@@ -888,15 +1130,15 @@ entriesForLibraryComponents = Map.foldrWithKey' (\k v -> mappend (go k v)) []
where
hasLib :: (ComponentTarget, NonEmpty TargetSelector) -> Bool
hasLib (ComponentTarget (CLibName _) _, _) = True
- hasLib _ = False
+ hasLib _ = False
- go :: UnitId
- -> [(ComponentTarget, NonEmpty TargetSelector)]
- -> [GhcEnvironmentFileEntry]
+ go
+ :: UnitId
+ -> [(ComponentTarget, NonEmpty TargetSelector)]
+ -> [GhcEnvironmentFileEntry]
go unitId targets
| any hasLib targets = [GhcEnvFilePackageId unitId]
- | otherwise = []
-
+ | otherwise = []
-- | Gets the file path to the request environment file.
getEnvFile :: ClientInstallFlags -> Platform -> Version -> IO FilePath
@@ -908,16 +1150,16 @@ getEnvFile clientInstallFlags platform compilerVersion = do
-- a named global environment.
| takeBaseName spec == spec ->
return (getGlobalEnv appDir platform compilerVersion spec)
- | otherwise -> do
- spec' <- makeAbsolute spec
- isDir <- doesDirectoryExist spec'
- if isDir
- -- If spec is a directory, then make an ambient environment inside
- -- that directory.
- then return (getLocalEnv spec' platform compilerVersion)
- -- Otherwise, treat it like a literal file path.
- else return spec'
- Nothing ->
+ | otherwise -> do
+ spec' <- makeAbsolute spec
+ isDir <- doesDirectoryExist spec'
+ if isDir
+ then -- If spec is a directory, then make an ambient environment inside
+ -- that directory.
+ return (getLocalEnv spec' platform compilerVersion)
+ else -- Otherwise, treat it like a literal file path.
+ return spec'
+ Nothing ->
return (getGlobalEnv appDir platform compilerVersion "default")
-- | Returns the list of @GhcEnvFilePackageIj@ values already existing in the
@@ -925,32 +1167,41 @@ getEnvFile clientInstallFlags platform compilerVersion = do
getExistingEnvEntries :: Verbosity -> CompilerFlavor -> Bool -> FilePath -> IO [GhcEnvironmentFileEntry]
getExistingEnvEntries verbosity compilerFlavor supportsPkgEnvFiles envFile = do
envFileExists <- doesFileExist envFile
- filterEnvEntries <$> if
- (compilerFlavor == GHC || compilerFlavor == GHCJS)
- && supportsPkgEnvFiles && envFileExists
- then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
- warn verbosity ("The environment file " ++ envFile ++
- " is unparsable. Libraries cannot be installed.") >> return []
- else return []
+ filterEnvEntries
+ <$> if (compilerFlavor == GHC || compilerFlavor == GHCJS)
+ && supportsPkgEnvFiles
+ && envFileExists
+ then catch (readGhcEnvironmentFile envFile) $ \(_ :: ParseErrorExc) ->
+ warn
+ verbosity
+ ( "The environment file "
+ ++ envFile
+ ++ " is unparsable. Libraries cannot be installed."
+ )
+ >> return []
+ else return []
where
-- Why? We know what the first part will be, we only care about the packages.
filterEnvEntries = filter $ \case
GhcEnvFilePackageId _ -> True
- _ -> False
+ _ -> False
-- | Constructs the path to the global GHC environment file.
--
-- TODO(m-renaud): Create PkgEnvName newtype wrapper.
getGlobalEnv :: FilePath -> Platform -> Version -> String -> FilePath
getGlobalEnv appDir platform compilerVersion name =
- appDir </> ghcPlatformAndVersionString platform compilerVersion
- </> "environments" </> name
+ appDir
+ </> ghcPlatformAndVersionString platform compilerVersion
+ </> "environments"
+ </> name
-- | Constructs the path to a local GHC environment file.
getLocalEnv :: FilePath -> Platform -> Version -> FilePath
-getLocalEnv dir platform compilerVersion =
- dir </>
- ".ghc.environment." <> ghcPlatformAndVersionString platform compilerVersion
+getLocalEnv dir platform compilerVersion =
+ dir
+ </> ".ghc.environment."
+ <> ghcPlatformAndVersionString platform compilerVersion
getPackageDbStack
:: CompilerId
@@ -960,7 +1211,7 @@ getPackageDbStack
getPackageDbStack compilerId storeDirFlag logsDirFlag = do
mstoreDir <- traverse makeAbsolute $ flagToMaybe storeDirFlag
let
- mlogsDir = flagToMaybe logsDirFlag
+ mlogsDir = flagToMaybe logsDirFlag
cabalLayout <- mkCabalDirLayout mstoreDir mlogsDir
pure $ storePackageDBStack (cabalStoreDirLayout cabalLayout) compilerId
@@ -971,44 +1222,42 @@ getPackageDbStack compilerId storeDirFlag logsDirFlag = do
-- For the @build@ command select all components except non-buildable
-- and disabled tests\/benchmarks, fail if there are no such
-- components
---
selectPackageTargets
:: TargetSelector
- -> [AvailableTarget k] -> Either TargetProblem' [k]
+ -> [AvailableTarget k]
+ -> Either TargetProblem' [k]
selectPackageTargets targetSelector targets
-
- -- If there are any buildable targets then we select those
- | not (null targetsBuildable)
- = Right targetsBuildable
-
- -- If there are targets but none are buildable then we report those
- | not (null targets)
- = Left (TargetProblemNoneEnabled targetSelector targets')
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ -- If there are any buildable targets then we select those
+ | not (null targetsBuildable) =
+ Right targetsBuildable
+ -- If there are targets but none are buildable then we report those
+ | not (null targets) =
+ Left (TargetProblemNoneEnabled targetSelector targets')
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
- targets' = forgetTargetsDetail targets
- targetsBuildable = selectBuildableTargetsWith
- (buildable targetSelector)
- targets
+ targets' = forgetTargetsDetail targets
+ targetsBuildable =
+ selectBuildableTargetsWith
+ (buildable targetSelector)
+ targets
-- When there's a target filter like "pkg:tests" then we do select tests,
-- but if it's just a target like "pkg" then we don't build tests unless
-- they are requested by default (i.e. by using --enable-tests)
- buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
- buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
+ buildable (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
+ buildable (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
buildable _ _ = True
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @build@ command we just need the basic checks on being buildable etc.
---
selectComponentTarget
:: SubComponentTarget
- -> AvailableTarget k -> Either TargetProblem' k
+ -> AvailableTarget k
+ -> Either TargetProblem' k
selectComponentTarget = selectComponentTargetBasic
reportBuildTargetProblems :: Verbosity -> [TargetProblem'] -> IO a
@@ -1016,4 +1265,4 @@ reportBuildTargetProblems verbosity problems = reportTargetProblems verbosity "b
reportCannotPruneDependencies :: Verbosity -> CannotPruneDependencies -> IO a
reportCannotPruneDependencies verbosity =
- die' verbosity . renderCannotPruneDependencies
+ die' verbosity . renderCannotPruneDependencies
diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs
index 9d85e55cce6c03a34905e1c0b9d1ca604803fd60..d5bbd5309f72ee08c5d979d0ef97d6e8f66a3a36 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallFlags.hs
@@ -1,36 +1,50 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
+
module Distribution.Client.CmdInstall.ClientInstallFlags
-( InstallMethod(..)
-, ClientInstallFlags(..)
-, defaultClientInstallFlags
-, clientInstallOptions
-) where
+ ( InstallMethod (..)
+ , ClientInstallFlags (..)
+ , defaultClientInstallFlags
+ , clientInstallOptions
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.ReadE
- ( succeedReadE, parsecToReadE )
+ ( parsecToReadE
+ , succeedReadE
+ )
import Distribution.Simple.Command
- ( ShowOrParseArgs(..), OptionField(..), option, reqArg )
+ ( OptionField (..)
+ , ShowOrParseArgs (..)
+ , option
+ , reqArg
+ )
import Distribution.Simple.Setup
- ( Flag(..), trueArg, flagToList, toFlag )
+ ( Flag (..)
+ , flagToList
+ , toFlag
+ , trueArg
+ )
import Distribution.Client.Types.InstallMethod
- ( InstallMethod (..) )
+ ( InstallMethod (..)
+ )
import Distribution.Client.Types.OverwritePolicy
- ( OverwritePolicy(..) )
+ ( OverwritePolicy (..)
+ )
import qualified Distribution.Compat.CharParsing as P
data ClientInstallFlags = ClientInstallFlags
- { cinstInstallLibs :: Flag Bool
+ { cinstInstallLibs :: Flag Bool
, cinstEnvironmentPath :: Flag FilePath
, cinstOverwritePolicy :: Flag OverwritePolicy
- , cinstInstallMethod :: Flag InstallMethod
- , cinstInstalldir :: Flag FilePath
- } deriving (Eq, Show, Generic)
+ , cinstInstallMethod :: Flag InstallMethod
+ , cinstInstalldir :: Flag FilePath
+ }
+ deriving (Eq, Show, Generic)
instance Monoid ClientInstallFlags where
mempty = gmempty
@@ -43,48 +57,66 @@ instance Binary ClientInstallFlags
instance Structured ClientInstallFlags
defaultClientInstallFlags :: ClientInstallFlags
-defaultClientInstallFlags = ClientInstallFlags
- { cinstInstallLibs = toFlag False
- , cinstEnvironmentPath = mempty
- , cinstOverwritePolicy = mempty
- , cinstInstallMethod = mempty
- , cinstInstalldir = mempty
- }
+defaultClientInstallFlags =
+ ClientInstallFlags
+ { cinstInstallLibs = toFlag False
+ , cinstEnvironmentPath = mempty
+ , cinstOverwritePolicy = mempty
+ , cinstInstallMethod = mempty
+ , cinstInstalldir = mempty
+ }
clientInstallOptions :: ShowOrParseArgs -> [OptionField ClientInstallFlags]
clientInstallOptions _ =
- [ option [] ["lib"]
- ( "Install libraries rather than executables from the target package " <>
- "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)." )
- cinstInstallLibs (\v flags -> flags { cinstInstallLibs = v })
- trueArg
- , option [] ["package-env", "env"]
- "Set the environment file that may be modified."
- cinstEnvironmentPath (\pf flags -> flags { cinstEnvironmentPath = pf })
- (reqArg "ENV" (succeedReadE Flag) flagToList)
- , option [] ["overwrite-policy"]
- "How to handle already existing symlinks."
- cinstOverwritePolicy (\v flags -> flags { cinstOverwritePolicy = v })
- $ reqArg "always|never|prompt"
+ [ option
+ []
+ ["lib"]
+ ( "Install libraries rather than executables from the target package "
+ <> "(provisional, see https://github.com/haskell/cabal/issues/6481 for more information)."
+ )
+ cinstInstallLibs
+ (\v flags -> flags{cinstInstallLibs = v})
+ trueArg
+ , option
+ []
+ ["package-env", "env"]
+ "Set the environment file that may be modified."
+ cinstEnvironmentPath
+ (\pf flags -> flags{cinstEnvironmentPath = pf})
+ (reqArg "ENV" (succeedReadE Flag) flagToList)
+ , option
+ []
+ ["overwrite-policy"]
+ "How to handle already existing symlinks."
+ cinstOverwritePolicy
+ (\v flags -> flags{cinstOverwritePolicy = v})
+ $ reqArg
+ "always|never|prompt"
(parsecToReadE (\err -> "Error parsing overwrite-policy: " ++ err) (toFlag `fmap` parsec))
(map prettyShow . flagToList)
- , option [] ["install-method"]
- "How to install the executables."
- cinstInstallMethod (\v flags -> flags { cinstInstallMethod = v })
- $ reqArg
+ , option
+ []
+ ["install-method"]
+ "How to install the executables."
+ cinstInstallMethod
+ (\v flags -> flags{cinstInstallMethod = v})
+ $ reqArg
"default|copy|symlink"
(parsecToReadE (\err -> "Error parsing install-method: " ++ err) (toFlag `fmap` parsecInstallMethod))
(map prettyShow . flagToList)
- , option [] ["installdir"]
- "Where to install (by symlinking or copying) the executables in."
- cinstInstalldir (\v flags -> flags { cinstInstalldir = v })
- $ reqArg "DIR" (succeedReadE Flag) flagToList
+ , option
+ []
+ ["installdir"]
+ "Where to install (by symlinking or copying) the executables in."
+ cinstInstalldir
+ (\v flags -> flags{cinstInstalldir = v})
+ $ reqArg "DIR" (succeedReadE Flag) flagToList
]
parsecInstallMethod :: CabalParsing m => m InstallMethod
parsecInstallMethod = do
- name <- P.munch1 isAlpha
- case name of
- "copy" -> pure InstallMethodCopy
- "symlink" -> pure InstallMethodSymlink
- _ -> P.unexpected $ "InstallMethod: " ++ name
+ name <- P.munch1 isAlpha
+ case name of
+ "copy" -> pure InstallMethodCopy
+ "symlink" -> pure InstallMethodSymlink
+ _ -> P.unexpected $ "InstallMethod: " ++ name
diff --git a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs
index 0127aea0f3c6e979885dff153b4a5d25b6d018be..e8e3f4062765ae0e0931577dc76fd2817ecebf42 100644
--- a/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs
+++ b/cabal-install/src/Distribution/Client/CmdInstall/ClientInstallTargetSelector.hs
@@ -1,10 +1,10 @@
-module Distribution.Client.CmdInstall.ClientInstallTargetSelector (
- WithoutProjectTargetSelector (..),
- parseWithoutProjectTargetSelector,
- woPackageNames,
- woPackageTargets,
- woPackageSpecifiers,
- ) where
+module Distribution.Client.CmdInstall.ClientInstallTargetSelector
+ ( WithoutProjectTargetSelector (..)
+ , parseWithoutProjectTargetSelector
+ , woPackageNames
+ , woPackageTargets
+ , woPackageSpecifiers
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
@@ -13,56 +13,58 @@ import Network.URI (URI, parseURI)
import Distribution.Client.TargetSelector
import Distribution.Client.Types
-import Distribution.Compat.CharParsing (char, optional)
+import Distribution.Compat.CharParsing (char, optional)
import Distribution.Package
-import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName))
-import Distribution.Simple.Utils (die')
+import Distribution.Simple.LocalBuildInfo (ComponentName (CExeName))
+import Distribution.Simple.Utils (die')
import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
import Distribution.Version
data WithoutProjectTargetSelector
- = WoPackageId PackageId
- | WoPackageComponent PackageId ComponentName
- | WoURI URI
+ = WoPackageId PackageId
+ | WoPackageComponent PackageId ComponentName
+ | WoURI URI
deriving (Show)
parseWithoutProjectTargetSelector :: Verbosity -> String -> IO WithoutProjectTargetSelector
parseWithoutProjectTargetSelector verbosity input =
- case explicitEitherParsec parser input of
- Right ts -> return ts
- Left err -> case parseURI input of
- Just uri -> return (WoURI uri)
- Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err
+ case explicitEitherParsec parser input of
+ Right ts -> return ts
+ Left err -> case parseURI input of
+ Just uri -> return (WoURI uri)
+ Nothing -> die' verbosity $ "Invalid package ID: " ++ input ++ "\n" ++ err
where
parser :: CabalParsing m => m WithoutProjectTargetSelector
parser = do
- pid <- parsec
- cn <- optional (char ':' *> parsec)
- return $ case cn of
- Nothing -> WoPackageId pid
- Just cn' -> WoPackageComponent pid (CExeName cn')
+ pid <- parsec
+ cn <- optional (char ':' *> parsec)
+ return $ case cn of
+ Nothing -> WoPackageId pid
+ Just cn' -> WoPackageComponent pid (CExeName cn')
-woPackageNames :: WithoutProjectTargetSelector -> [PackageName]
-woPackageNames (WoPackageId pid) = [pkgName pid]
+woPackageNames :: WithoutProjectTargetSelector -> [PackageName]
+woPackageNames (WoPackageId pid) = [pkgName pid]
woPackageNames (WoPackageComponent pid _) = [pkgName pid]
-woPackageNames (WoURI _) = []
+woPackageNames (WoURI _) = []
-woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector
+woPackageTargets :: WithoutProjectTargetSelector -> TargetSelector
woPackageTargets (WoPackageId pid) =
- TargetPackageNamed (pkgName pid) Nothing
+ TargetPackageNamed (pkgName pid) Nothing
woPackageTargets (WoPackageComponent pid cn) =
- TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent
+ TargetComponentUnknown (pkgName pid) (Right cn) WholeComponent
woPackageTargets (WoURI _) =
- TargetAllPackages (Just ExeKind)
+ TargetAllPackages (Just ExeKind)
-woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
-woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid)
+woPackageSpecifiers :: WithoutProjectTargetSelector -> Either URI (PackageSpecifier pkg)
+woPackageSpecifiers (WoPackageId pid) = Right (pidPackageSpecifiers pid)
woPackageSpecifiers (WoPackageComponent pid _) = Right (pidPackageSpecifiers pid)
-woPackageSpecifiers (WoURI uri) = Left uri
+woPackageSpecifiers (WoURI uri) = Left uri
pidPackageSpecifiers :: PackageId -> PackageSpecifier pkg
pidPackageSpecifiers pid
- | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []
- | otherwise = NamedPackage (pkgName pid)
+ | pkgVersion pid == nullVersion = NamedPackage (pkgName pid) []
+ | otherwise =
+ NamedPackage
+ (pkgName pid)
[ PackagePropertyVersion (thisVersion (pkgVersion pid))
]
diff --git a/cabal-install/src/Distribution/Client/CmdLegacy.hs b/cabal-install/src/Distribution/Client/CmdLegacy.hs
index 6d51e844d44629b3b75409ec934dc24977776697..4572c868f3375090d086cf46742b8acab1587ab6 100644
--- a/cabal-install/src/Distribution/Client/CmdLegacy.hs
+++ b/cabal-install/src/Distribution/Client/CmdLegacy.hs
@@ -1,32 +1,41 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
-module Distribution.Client.CmdLegacy ( legacyCmd, legacyWrapperCmd, newCmd ) where
-import Prelude ()
+module Distribution.Client.CmdLegacy (legacyCmd, legacyWrapperCmd, newCmd) where
+
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Distribution.Client.Sandbox
- ( loadConfigOrSandboxConfig, findSavedDistPref )
+ ( findSavedDistPref
+ , loadConfigOrSandboxConfig
+ )
import qualified Distribution.Client.Setup as Client
import Distribution.Client.SetupWrapper
- ( SetupScriptOptions(..), setupWrapper, defaultSetupScriptOptions )
-import qualified Distribution.Simple.Setup as Setup
+ ( SetupScriptOptions (..)
+ , defaultSetupScriptOptions
+ , setupWrapper
+ )
import Distribution.Simple.Command
+import qualified Distribution.Simple.Setup as Setup
import Distribution.Simple.Utils
- ( wrapText )
+ ( wrapText
+ )
import Distribution.Verbosity
- ( normal )
+ ( normal
+ )
import Control.Exception
- ( try )
+ ( try
+ )
import qualified Data.Text as T
-- Tweaked versions of code from Main.
-regularCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action)
+regularCmd :: HasVerbosity flags => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> CommandSpec (globals -> IO action)
regularCmd ui action =
- CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand
+ CommandSpec ui ((flip commandAddAction) (\flags extra globals -> action flags extra globals)) NormalCommand
wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> CommandSpec (Client.GlobalFlags -> IO ())
wrapperCmd ui verbosity' distPref =
@@ -34,89 +43,99 @@ wrapperCmd ui verbosity' distPref =
wrapperAction :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> Command (Client.GlobalFlags -> IO ())
wrapperAction command verbosityFlag distPrefFlag =
- commandAddAction command
- { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do
- let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags)
-
- load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)
- let config = either (\(SomeException _) -> mempty) id load
- distPref <- findSavedDistPref config (distPrefFlag flags)
- let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }
-
- let command' = command { commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command }
-
- setupWrapper verbosity' setupScriptOptions Nothing
- command' (const flags) (const extraArgs)
+ commandAddAction
+ command
+ { commandDefaultFlags = mempty
+ }
+ $ \flags extraArgs globalFlags -> do
+ let verbosity' = Setup.fromFlagOrDefault normal (verbosityFlag flags)
+
+ load <- try (loadConfigOrSandboxConfig verbosity' globalFlags)
+ let config = either (\(SomeException _) -> mempty) id load
+ distPref <- findSavedDistPref config (distPrefFlag flags)
+ let setupScriptOptions = defaultSetupScriptOptions{useDistPref = distPref}
+
+ let command' = command{commandName = T.unpack . T.replace "v1-" "" . T.pack . commandName $ command}
+
+ setupWrapper
+ verbosity'
+ setupScriptOptions
+ Nothing
+ command'
+ (const flags)
+ (const extraArgs)
--
class HasVerbosity a where
- verbosity :: a -> Verbosity
+ verbosity :: a -> Verbosity
instance HasVerbosity (Setup.Flag Verbosity) where
- verbosity = Setup.fromFlagOrDefault normal
+ verbosity = Setup.fromFlagOrDefault normal
-instance (HasVerbosity a) => HasVerbosity (a, b) where
- verbosity (a, _) = verbosity a
+instance HasVerbosity a => HasVerbosity (a, b) where
+ verbosity (a, _) = verbosity a
-instance (HasVerbosity a) => HasVerbosity (a, b, c) where
- verbosity (a , _, _) = verbosity a
+instance HasVerbosity a => HasVerbosity (a, b, c) where
+ verbosity (a, _, _) = verbosity a
-instance (HasVerbosity a) => HasVerbosity (a, b, c, d) where
- verbosity (a, _, _, _) = verbosity a
+instance HasVerbosity a => HasVerbosity (a, b, c, d) where
+ verbosity (a, _, _, _) = verbosity a
-instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e) where
- verbosity (a, _, _, _, _) = verbosity a
+instance HasVerbosity a => HasVerbosity (a, b, c, d, e) where
+ verbosity (a, _, _, _, _) = verbosity a
-instance (HasVerbosity a) => HasVerbosity (a, b, c, d, e, f) where
- verbosity (a, _, _, _, _, _) = verbosity a
+instance HasVerbosity a => HasVerbosity (a, b, c, d, e, f) where
+ verbosity (a, _, _, _, _, _) = verbosity a
instance HasVerbosity Setup.BuildFlags where
- verbosity = verbosity . Setup.buildVerbosity
+ verbosity = verbosity . Setup.buildVerbosity
instance HasVerbosity Setup.ConfigFlags where
- verbosity = verbosity . Setup.configVerbosity
+ verbosity = verbosity . Setup.configVerbosity
instance HasVerbosity Setup.ReplFlags where
- verbosity = verbosity . Setup.replVerbosity
+ verbosity = verbosity . Setup.replVerbosity
instance HasVerbosity Client.FreezeFlags where
- verbosity = verbosity . Client.freezeVerbosity
+ verbosity = verbosity . Client.freezeVerbosity
instance HasVerbosity Setup.HaddockFlags where
- verbosity = verbosity . Setup.haddockVerbosity
+ verbosity = verbosity . Setup.haddockVerbosity
instance HasVerbosity Client.UpdateFlags where
- verbosity = verbosity . Client.updateVerbosity
+ verbosity = verbosity . Client.updateVerbosity
instance HasVerbosity Setup.CleanFlags where
- verbosity = verbosity . Setup.cleanVerbosity
+ verbosity = verbosity . Setup.cleanVerbosity
--
legacyNote :: String -> String
-legacyNote cmd = wrapText $
- "The v1-" ++ cmd ++ " command is a part of the legacy v1 style of cabal usage.\n\n" ++
-
- "It is a legacy feature and will be removed in a future release of cabal-install." ++
- " Please file a bug if you cannot replicate a working v1- use case with the nix-style" ++
- " commands.\n\n" ++
-
- "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"
+legacyNote cmd =
+ wrapText $
+ "The v1-"
+ ++ cmd
+ ++ " command is a part of the legacy v1 style of cabal usage.\n\n"
+ ++ "It is a legacy feature and will be removed in a future release of cabal-install."
+ ++ " Please file a bug if you cannot replicate a working v1- use case with the nix-style"
+ ++ " commands.\n\n"
+ ++ "For more information, see: https://cabal.readthedocs.io/en/latest/nix-local-build-overview.html"
toLegacyCmd :: CommandSpec (globals -> IO action) -> [CommandSpec (globals -> IO action)]
toLegacyCmd mkSpec = [toLegacy mkSpec]
where
toLegacy (CommandSpec origUi@CommandUI{..} action type') = CommandSpec legUi action type'
where
- legUi = origUi
+ legUi =
+ origUi
{ commandName = "v1-" ++ commandName
, commandNotes = Just $ \pname -> case commandNotes of
Just notes -> notes pname ++ "\n" ++ legacyNote commandName
Nothing -> legacyNote commandName
}
-legacyCmd :: (HasVerbosity flags) => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
+legacyCmd :: HasVerbosity flags => CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
legacyCmd ui action = toLegacyCmd (regularCmd ui action)
legacyWrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Setup.Flag Verbosity) -> (flags -> Setup.Flag String) -> [CommandSpec (Client.GlobalFlags -> IO ())]
@@ -124,21 +143,23 @@ legacyWrapperCmd ui verbosity' distPref = toLegacyCmd (wrapperCmd ui verbosity'
newCmd :: CommandUI flags -> (flags -> [String] -> globals -> IO action) -> [CommandSpec (globals -> IO action)]
newCmd origUi@CommandUI{..} action = [cmd defaultUi, cmd newUi, cmd origUi]
- where
- cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand
-
- newMsg = T.unpack . T.replace "v2-" "new-" . T.pack
- newUi = origUi
- { commandName = newMsg commandName
- , commandUsage = newMsg . commandUsage
- , commandDescription = (newMsg .) <$> commandDescription
- , commandNotes = (newMsg .) <$> commandNotes
- }
-
- defaultMsg = T.unpack . T.replace "v2-" "" . T.pack
- defaultUi = origUi
- { commandName = defaultMsg commandName
- , commandUsage = defaultMsg . commandUsage
- , commandDescription = (defaultMsg .) <$> commandDescription
- , commandNotes = (defaultMsg .) <$> commandNotes
- }
+ where
+ cmd ui = CommandSpec ui (flip commandAddAction action) NormalCommand
+
+ newMsg = T.unpack . T.replace "v2-" "new-" . T.pack
+ newUi =
+ origUi
+ { commandName = newMsg commandName
+ , commandUsage = newMsg . commandUsage
+ , commandDescription = (newMsg .) <$> commandDescription
+ , commandNotes = (newMsg .) <$> commandNotes
+ }
+
+ defaultMsg = T.unpack . T.replace "v2-" "" . T.pack
+ defaultUi =
+ origUi
+ { commandName = defaultMsg commandName
+ , commandUsage = defaultMsg . commandUsage
+ , commandDescription = (defaultMsg .) <$> commandDescription
+ , commandNotes = (defaultMsg .) <$> commandNotes
+ }
diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs
index 2767430084986c46e1766c1541ec19a30952e1f1..d83664532247f5233b5827939340af1bfa3c5352 100644
--- a/cabal-install/src/Distribution/Client/CmdListBin.hs
+++ b/cabal-install/src/Distribution/Client/CmdListBin.hs
@@ -1,51 +1,66 @@
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-module Distribution.Client.CmdListBin (
- listbinCommand,
- listbinAction,
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+
+module Distribution.Client.CmdListBin
+ ( listbinCommand
+ , listbinAction
-- * Internals exposed for testing
- selectPackageTargets,
- selectComponentTarget,
- noComponentsProblem,
- matchesMultipleProblem,
- multipleTargetsProblem,
- componentNotRightKindProblem
-) where
+ , selectPackageTargets
+ , selectComponentTarget
+ , noComponentsProblem
+ , matchesMultipleProblem
+ , multipleTargetsProblem
+ , componentNotRightKindProblem
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Client.CmdErrorMessages
- (plural, renderListCommaAnd, renderTargetProblem, renderTargetProblemNoTargets,
- renderTargetSelector, showTargetSelector, targetSelectorFilter, targetSelectorPluralPkgs)
-import Distribution.Client.DistDirLayout (DistDirLayout (..))
+ ( plural
+ , renderListCommaAnd
+ , renderTargetProblem
+ , renderTargetProblemNoTargets
+ , renderTargetSelector
+ , showTargetSelector
+ , targetSelectorFilter
+ , targetSelectorPluralPkgs
+ )
+import Distribution.Client.DistDirLayout (DistDirLayout (..))
import Distribution.Client.NixStyleOptions
- (NixStyleFlags (..), defaultNixStyleFlags, nixStyleOptions)
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.ScriptUtils
- (AcceptNoTargets(..), TargetContext(..), updateContextAndWriteProjectFile, withContextAndSelectors)
-import Distribution.Client.Setup (GlobalFlags (..))
-import Distribution.Client.TargetProblem (TargetProblem (..))
-import Distribution.Simple.BuildPaths (dllExtension, exeExtension)
-import Distribution.Simple.Command (CommandUI (..))
-import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault)
-import Distribution.Simple.Utils (die', withOutputMarker, wrapText)
-import Distribution.System (Platform)
-import Distribution.Types.ComponentName (showComponentName)
-import Distribution.Types.UnitId (UnitId)
-import Distribution.Types.UnqualComponentName (UnqualComponentName)
-import Distribution.Verbosity (silent, verboseStderr)
-import System.FilePath ((<.>), (</>))
-
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import qualified Distribution.Client.InstallPlan as IP
-import qualified Distribution.Simple.InstallDirs as InstallDirs
+ ( AcceptNoTargets (..)
+ , TargetContext (..)
+ , updateContextAndWriteProjectFile
+ , withContextAndSelectors
+ )
+import Distribution.Client.Setup (GlobalFlags (..))
+import Distribution.Client.TargetProblem (TargetProblem (..))
+import Distribution.Simple.BuildPaths (dllExtension, exeExtension)
+import Distribution.Simple.Command (CommandUI (..))
+import Distribution.Simple.Setup (configVerbosity, fromFlagOrDefault)
+import Distribution.Simple.Utils (die', withOutputMarker, wrapText)
+import Distribution.System (Platform)
+import Distribution.Types.ComponentName (showComponentName)
+import Distribution.Types.UnitId (UnitId)
+import Distribution.Types.UnqualComponentName (UnqualComponentName)
+import Distribution.Verbosity (silent, verboseStderr)
+import System.FilePath ((<.>), (</>))
+
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Distribution.Client.InstallPlan as IP
+import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Solver.Types.ComponentDeps as CD
-------------------------------------------------------------------------------
@@ -53,16 +68,18 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD
-------------------------------------------------------------------------------
listbinCommand :: CommandUI (NixStyleFlags ())
-listbinCommand = CommandUI
+listbinCommand =
+ CommandUI
{ commandName = "list-bin"
, commandSynopsis = "List the path to a single executable."
, commandUsage = \pname ->
"Usage: " ++ pname ++ " list-bin [FLAGS] TARGET\n"
- , commandDescription = Just $ \_ -> wrapText
- "List the path to a build product."
+ , commandDescription = Just $ \_ ->
+ wrapText
+ "List the path to a build product."
, commandNotes = Nothing
, commandDefaultFlags = defaultNixStyleFlags ()
- , commandOptions = nixStyleOptions (const [])
+ , commandOptions = nixStyleOptions (const [])
}
-------------------------------------------------------------------------------
@@ -73,111 +90,122 @@ listbinAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
listbinAction flags@NixStyleFlags{..} args globalFlags = do
-- fail early if multiple target selectors specified
target <- case args of
- [] -> die' verbosity "One target is required, none provided"
- [x] -> return x
- _ -> die' verbosity "One target is required, given multiple"
+ [] -> die' verbosity "One target is required, none provided"
+ [x] -> return x
+ _ -> die' verbosity "One target is required, given multiple"
-- configure and elaborate target selectors
withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
baseCtx <- case targetCtx of
- ProjectContext -> return ctx
- GlobalContext -> return ctx
+ ProjectContext -> return ctx
+ GlobalContext -> return ctx
ScriptContext path exemeta -> updateContextAndWriteProjectFile ctx path exemeta
buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
- -- Interpret the targets on the command line as build targets
- -- (as opposed to say repl or haddock targets).
- targets <- either (reportTargetProblems verbosity) return
- $ resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- -- Reject multiple targets, or at least targets in different
- -- components. It is ok to have two module/file targets in the
- -- same component, but not two that live in different components.
- --
- -- Note that we discard the target and return the whole 'TargetsMap',
- -- so this check will be repeated (and must succeed) after
- -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
- _ <- singleComponentOrElse
- (reportTargetProblems
- verbosity
- [multipleTargetsProblem targets])
- targets
-
- let elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
- return (elaboratedPlan', targets)
+ -- Interpret the targets on the command line as build targets
+ -- (as opposed to say repl or haddock targets).
+ targets <-
+ either (reportTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
+
+ -- Reject multiple targets, or at least targets in different
+ -- components. It is ok to have two module/file targets in the
+ -- same component, but not two that live in different components.
+ --
+ -- Note that we discard the target and return the whole 'TargetsMap',
+ -- so this check will be repeated (and must succeed) after
+ -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
+ _ <-
+ singleComponentOrElse
+ ( reportTargetProblems
+ verbosity
+ [multipleTargetsProblem targets]
+ )
+ targets
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
+ return (elaboratedPlan', targets)
(selectedUnitId, selectedComponent) <-
-- Slight duplication with 'runProjectPreBuildPhase'.
singleComponentOrElse
- (die' verbosity $ "No or multiple targets given, but the run "
- ++ "phase has been reached. This is a bug.")
+ ( die' verbosity $
+ "No or multiple targets given, but the run "
+ ++ "phase has been reached. This is a bug."
+ )
$ targetsMap buildCtx
printPlan verbosity baseCtx buildCtx
binfiles <- case Map.lookup selectedUnitId $ IP.toMap (elaboratedPlanOriginal buildCtx) of
- Nothing -> die' verbosity "No or multiple targets given..."
- Just gpp -> return $ IP.foldPlanPackage
+ Nothing -> die' verbosity "No or multiple targets given..."
+ Just gpp ->
+ return $
+ IP.foldPlanPackage
(const []) -- IPI don't have executables
(elaboratedPackage (distDirLayout baseCtx) (elaboratedShared buildCtx) selectedComponent)
gpp
case binfiles of
- [] -> die' verbosity "No target found"
- [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n"
- -- Andreas, 2023-01-13, issue #8400:
- -- Regular output of `list-bin` should go to stdout unconditionally,
- -- but for the sake of the testsuite, we want to mark it so it goes
- -- into the golden value for the test.
- -- Note: 'withOutputMarker' only checks 'isVerboseMarkOutput',
- -- thus, we can reuse @verbosity@ here, even if other components
- -- of @verbosity@ may be wrong (like 'VStderr', verbosity level etc.).
- -- Andreas, 2023-01-20:
- -- Appending the newline character here rather than using 'putStrLn'
- -- because an active 'withOutputMarker' produces text that ends
- -- in newline characters.
- _ -> die' verbosity "Multiple targets found"
+ [] -> die' verbosity "No target found"
+ [exe] -> putStr $ withOutputMarker verbosity $ exe ++ "\n"
+ -- Andreas, 2023-01-13, issue #8400:
+ -- Regular output of `list-bin` should go to stdout unconditionally,
+ -- but for the sake of the testsuite, we want to mark it so it goes
+ -- into the golden value for the test.
+ -- Note: 'withOutputMarker' only checks 'isVerboseMarkOutput',
+ -- thus, we can reuse @verbosity@ here, even if other components
+ -- of @verbosity@ may be wrong (like 'VStderr', verbosity level etc.).
+ -- Andreas, 2023-01-20:
+ -- Appending the newline character here rather than using 'putStrLn'
+ -- because an active 'withOutputMarker' produces text that ends
+ -- in newline characters.
+ _ -> die' verbosity "Multiple targets found"
where
defaultVerbosity = verboseStderr silent
verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)
-- this is copied from
elaboratedPackage
- :: DistDirLayout
- -> ElaboratedSharedConfig
- -> UnqualComponentName
- -> ElaboratedConfiguredPackage
- -> [FilePath]
+ :: DistDirLayout
+ -> ElaboratedSharedConfig
+ -> UnqualComponentName
+ -> ElaboratedConfiguredPackage
+ -> [FilePath]
elaboratedPackage distDirLayout elaboratedSharedConfig selectedComponent elab = case elabPkgOrComp elab of
- ElabPackage pkg ->
- [ bin
- | (c, _) <- CD.toList $ CD.zip (pkgLibDependencies pkg)
- (pkgExeDependencies pkg)
- , bin <- bin_file c
- ]
- ElabComponent comp -> bin_file (compSolverName comp)
+ ElabPackage pkg ->
+ [ bin
+ | (c, _) <-
+ CD.toList $
+ CD.zip
+ (pkgLibDependencies pkg)
+ (pkgExeDependencies pkg)
+ , bin <- bin_file c
+ ]
+ ElabComponent comp -> bin_file (compSolverName comp)
where
dist_dir = distBuildDirectory distDirLayout (elabDistDirParams elaboratedSharedConfig elab)
bin_file c = case c of
- CD.ComponentExe s
- | s == selectedComponent -> [bin_file' s]
- CD.ComponentTest s
- | s == selectedComponent -> [bin_file' s]
- CD.ComponentBench s
- | s == selectedComponent -> [bin_file' s]
- CD.ComponentFLib s
- | s == selectedComponent -> [flib_file' s]
- _ -> []
+ CD.ComponentExe s
+ | s == selectedComponent -> [bin_file' s]
+ CD.ComponentTest s
+ | s == selectedComponent -> [bin_file' s]
+ CD.ComponentBench s
+ | s == selectedComponent -> [bin_file' s]
+ CD.ComponentFLib s
+ | s == selectedComponent -> [flib_file' s]
+ _ -> []
plat :: Platform
plat = pkgConfigPlatform elaboratedSharedConfig
@@ -185,12 +213,12 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
-- here and in PlanOutput,
-- use binDirectoryFor?
bin_file' s =
- if elabBuildStyle elab == BuildInplaceOnly
+ if elabBuildStyle elab == BuildInplaceOnly
then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat
else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat
flib_file' s =
- if elabBuildStyle elab == BuildInplaceOnly
+ if elabBuildStyle elab == BuildInplaceOnly
then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat
else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat
@@ -200,12 +228,12 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
singleComponentOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
singleComponentOrElse action targetsMap =
- case Set.toList . distinctTargetComponents $ targetsMap
- of [(unitId, CExeName component)] -> return (unitId, component)
- [(unitId, CTestName component)] -> return (unitId, component)
- [(unitId, CBenchName component)] -> return (unitId, component)
- [(unitId, CFLibName component)] -> return (unitId, component)
- _ -> action
+ case Set.toList . distinctTargetComponents $ targetsMap of
+ [(unitId, CExeName component)] -> return (unitId, component)
+ [(unitId, CTestName component)] -> return (unitId, component)
+ [(unitId, CBenchName component)] -> return (unitId, component)
+ [(unitId, CFLibName component)] -> return (unitId, component)
+ _ -> action
-- | This defines what a 'TargetSelector' means for the @list-bin@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
@@ -213,49 +241,45 @@ singleComponentOrElse action targetsMap =
--
-- For the @list-bin@ command we select the exe or flib if there is only one
-- and it's buildable. Fail if there are no or multiple buildable exe components.
---
-selectPackageTargets :: TargetSelector
- -> [AvailableTarget k] -> Either ListBinTargetProblem [k]
+selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either ListBinTargetProblem [k]
selectPackageTargets targetSelector targets
-
-- If there is a single executable component, select that. See #7403
- | [target] <- targetsExesBuildable
- = Right [target]
-
+ | [target] <- targetsExesBuildable =
+ Right [target]
-- Otherwise, if there is a single executable-like component left, select that.
- | [target] <- targetsExeLikesBuildable
- = Right [target]
-
- -- but fail if there are multiple buildable executables.
- | not (null targetsExeLikesBuildable)
- = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')
-
- -- If there are executables but none are buildable then we report those
- | not (null targetsExeLikes')
- = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')
-
- -- If there are no executables but some other targets then we report that
- | not (null targets)
- = Left (noComponentsProblem targetSelector)
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ | [target] <- targetsExeLikesBuildable =
+ Right [target]
+ -- but fail if there are multiple buildable executables.
+ | not (null targetsExeLikesBuildable) =
+ Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')
+ -- If there are executables but none are buildable then we report those
+ | not (null targetsExeLikes') =
+ Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')
+ -- If there are no executables but some other targets then we report that
+ | not (null targets) =
+ Left (noComponentsProblem targetSelector)
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
-- Targets that are precisely executables
targetsExes = filterTargetsKind ExeKind targets
targetsExesBuildable = selectBuildableTargets targetsExes
-- Any target that could be executed
- targetsExeLikes = targetsExes
- ++ filterTargetsKind TestKind targets
- ++ filterTargetsKind BenchKind targets
-
- (targetsExeLikesBuildable,
- targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes
+ targetsExeLikes =
+ targetsExes
+ ++ filterTargetsKind TestKind targets
+ ++ filterTargetsKind BenchKind targets
- targetsExeLikes' = forgetTargetsDetail targetsExeLikes
+ ( targetsExeLikesBuildable
+ , targetsExeLikesBuildable'
+ ) = selectBuildableTargets' targetsExeLikes
+ targetsExeLikes' = forgetTargetsDetail targetsExeLikes
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
@@ -263,43 +287,42 @@ selectPackageTargets targetSelector targets
-- For the @run@ command we just need to check it is a executable-like
-- (an executable, a test, or a benchmark), in addition
-- to the basic checks on being buildable etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either ListBinTargetProblem k
-selectComponentTarget subtarget@WholeComponent t
- = case availableTargetComponentName t
- of CExeName _ -> component
- CTestName _ -> component
- CBenchName _ -> component
- CFLibName _ -> component
- _ -> Left (componentNotRightKindProblem pkgid cname)
- where pkgid = availableTargetPackageId t
- cname = availableTargetComponentName t
- component = selectComponentTargetBasic subtarget t
-
-selectComponentTarget subtarget t
- = Left (isSubComponentProblem (availableTargetPackageId t)
- (availableTargetComponentName t)
- subtarget)
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either ListBinTargetProblem k
+selectComponentTarget subtarget@WholeComponent t =
+ case availableTargetComponentName t of
+ CExeName _ -> component
+ CTestName _ -> component
+ CBenchName _ -> component
+ CFLibName _ -> component
+ _ -> Left (componentNotRightKindProblem pkgid cname)
+ where
+ pkgid = availableTargetPackageId t
+ cname = availableTargetComponentName t
+ component = selectComponentTargetBasic subtarget t
+selectComponentTarget subtarget t =
+ Left
+ ( isSubComponentProblem
+ (availableTargetPackageId t)
+ (availableTargetComponentName t)
+ subtarget
+ )
-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.
---
-data ListBinProblem =
- -- | The 'TargetSelector' matches targets but no executables
- TargetProblemNoRightComps TargetSelector
-
- -- | A single 'TargetSelector' matches multiple targets
- | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
-
- -- | Multiple 'TargetSelector's match multiple targets
- | TargetProblemMultipleTargets TargetsMap
-
- -- | The 'TargetSelector' refers to a component that is not an executable
- | TargetProblemComponentNotRightKind PackageId ComponentName
-
- -- | Asking to run an individual file or module is not supported
- | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
+data ListBinProblem
+ = -- | The 'TargetSelector' matches targets but no executables
+ TargetProblemNoRightComps TargetSelector
+ | -- | A single 'TargetSelector' matches multiple targets
+ TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
+ | -- | Multiple 'TargetSelector's match multiple targets
+ TargetProblemMultipleTargets TargetsMap
+ | -- | The 'TargetSelector' refers to a component that is not an executable
+ TargetProblemComponentNotRightKind PackageId ComponentName
+ | -- | Asking to run an individual file or module is not supported
+ TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
deriving (Eq, Show)
type ListBinTargetProblem = TargetProblem ListBinProblem
@@ -308,14 +331,16 @@ noComponentsProblem :: TargetSelector -> ListBinTargetProblem
noComponentsProblem = CustomTargetProblem . TargetProblemNoRightComps
matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> ListBinTargetProblem
-matchesMultipleProblem selector targets = CustomTargetProblem $
+matchesMultipleProblem selector targets =
+ CustomTargetProblem $
TargetProblemMatchesMultiple selector targets
multipleTargetsProblem :: TargetsMap -> TargetProblem ListBinProblem
multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
componentNotRightKindProblem :: PackageId -> ComponentName -> TargetProblem ListBinProblem
-componentNotRightKindProblem pkgid name = CustomTargetProblem $
+componentNotRightKindProblem pkgid name =
+ CustomTargetProblem $
TargetProblemComponentNotRightKind pkgid name
isSubComponentProblem
@@ -323,63 +348,75 @@ isSubComponentProblem
-> ComponentName
-> SubComponentTarget
-> TargetProblem ListBinProblem
-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $
+isSubComponentProblem pkgid name subcomponent =
+ CustomTargetProblem $
TargetProblemIsSubComponent pkgid name subcomponent
reportTargetProblems :: Verbosity -> [ListBinTargetProblem] -> IO a
reportTargetProblems verbosity =
- die' verbosity . unlines . map renderListBinTargetProblem
+ die' verbosity . unlines . map renderListBinTargetProblem
renderListBinTargetProblem :: ListBinTargetProblem -> String
renderListBinTargetProblem (TargetProblemNoTargets targetSelector) =
- case targetSelectorFilter targetSelector of
- Just kind | kind /= ExeKind
- -> "The list-bin command is for finding binaries, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
-
- _ -> renderTargetProblemNoTargets "list-bin" targetSelector
+ case targetSelectorFilter targetSelector of
+ Just kind
+ | kind /= ExeKind ->
+ "The list-bin command is for finding binaries, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
+ _ -> renderTargetProblemNoTargets "list-bin" targetSelector
renderListBinTargetProblem problem =
- renderTargetProblem "list-bin" renderListBinProblem problem
+ renderTargetProblem "list-bin" renderListBinProblem problem
renderListBinProblem :: ListBinProblem -> String
renderListBinProblem (TargetProblemMatchesMultiple targetSelector targets) =
- "The list-bin command is for finding a single binary at once. The target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " which includes "
- ++ renderListCommaAnd ( ("the "++) <$>
- showComponentName <$>
- availableTargetComponentName <$>
- foldMap
- (\kind -> filterTargetsKind kind targets)
- [ExeKind, TestKind, BenchKind] )
- ++ "."
-
+ "The list-bin command is for finding a single binary at once. The target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " which includes "
+ ++ renderListCommaAnd
+ ( ("the " ++)
+ <$> showComponentName
+ <$> availableTargetComponentName
+ <$> foldMap
+ (\kind -> filterTargetsKind kind targets)
+ [ExeKind, TestKind, BenchKind]
+ )
+ ++ "."
renderListBinProblem (TargetProblemMultipleTargets selectorMap) =
- "The list-bin command is for finding a single binary at once. The targets "
- ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"
- | ts <- uniqueTargetSelectors selectorMap ]
- ++ " refer to different executables."
-
+ "The list-bin command is for finding a single binary at once. The targets "
+ ++ renderListCommaAnd
+ [ "'" ++ showTargetSelector ts ++ "'"
+ | ts <- uniqueTargetSelectors selectorMap
+ ]
+ ++ " refer to different executables."
renderListBinProblem (TargetProblemComponentNotRightKind pkgid cname) =
- "The list-bin command is for finding binaries, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " from the package "
- ++ prettyShow pkgid ++ "."
+ "The list-bin command is for finding binaries, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " from the package "
+ ++ prettyShow pkgid
+ ++ "."
where
targetSelector = TargetComponent pkgid cname WholeComponent
-
renderListBinProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
- "The list-bin command can only find a binary as a whole, "
- ++ "not files or modules within them, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
+ "The list-bin command can only find a binary as a whole, "
+ ++ "not files or modules within them, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
where
targetSelector = TargetComponent pkgid cname subtarget
-
renderListBinProblem (TargetProblemNoRightComps targetSelector) =
- "Cannot list-bin the target '" ++ showTargetSelector targetSelector
- ++ "' which refers to " ++ renderTargetSelector targetSelector
- ++ " because "
- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
- ++ " not contain any executables or foreign libraries."
+ "Cannot list-bin the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' which refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " because "
+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
+ ++ " not contain any executables or foreign libraries."
diff --git a/cabal-install/src/Distribution/Client/CmdOutdated.hs b/cabal-install/src/Distribution/Client/CmdOutdated.hs
index 1c98abd937e3e25e2cdb5e51c42551edcd6b0be7..7f143b9ec3bbea330ff955c1fda348f210d6ba50 100644
--- a/cabal-install/src/Distribution/Client/CmdOutdated.hs
+++ b/cabal-install/src/Distribution/Client/CmdOutdated.hs
@@ -1,7 +1,11 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.CmdOutdated
-- Maintainer : cabal-devel@haskell.org
@@ -9,184 +13,271 @@
--
-- Implementation of the 'outdated' command. Checks for outdated
-- dependencies in the package description file or freeze file.
------------------------------------------------------------------------------
-
module Distribution.Client.CmdOutdated
- ( outdatedCommand, outdatedAction
- , ListOutdatedSettings(..), listOutdated )
+ ( outdatedCommand
+ , outdatedAction
+ , ListOutdatedSettings (..)
+ , listOutdated
+ )
where
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Lens
- ( _1, _2 )
+ ( _1
+ , _2
+ )
import Prelude ()
import Distribution.Client.Config
- ( SavedConfig(savedGlobalFlags, savedConfigureFlags
- , savedConfigureExFlags) )
-import Distribution.Client.IndexUtils as IndexUtils
+ ( SavedConfig
+ ( savedConfigureExFlags
+ , savedConfigureFlags
+ , savedGlobalFlags
+ )
+ )
import Distribution.Client.DistDirLayout
- ( defaultDistDirLayout
- , DistDirLayout(distProjectRootDirectory, distProjectFile) )
+ ( DistDirLayout (distProjectFile, distProjectRootDirectory)
+ , defaultDistDirLayout
+ )
+import Distribution.Client.IndexUtils as IndexUtils
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectConfig.Legacy
- ( instantiateProjectConfigSkeletonWithCompiler )
+ ( instantiateProjectConfigSkeletonWithCompiler
+ )
import Distribution.Client.ProjectFlags
- ( projectFlagsOptions, ProjectFlags(..), defaultProjectFlags
- , removeIgnoreProjectOption )
+ ( ProjectFlags (..)
+ , defaultProjectFlags
+ , projectFlagsOptions
+ , removeIgnoreProjectOption
+ )
import Distribution.Client.RebuildMonad
- ( runRebuild )
+ ( runRebuild
+ )
import Distribution.Client.Sandbox
- ( loadConfigOrSandboxConfig )
+ ( loadConfigOrSandboxConfig
+ )
+import Distribution.Client.Sandbox.PackageEnvironment
+ ( loadUserConfig
+ )
import Distribution.Client.Setup
import Distribution.Client.Targets
- ( userToPackageConstraint, UserConstraint )
+ ( UserConstraint
+ , userToPackageConstraint
+ )
import Distribution.Client.Types.SourcePackageDb as SourcePackageDb
import Distribution.Solver.Types.PackageConstraint
- ( packageConstraintToDependency )
-import Distribution.Client.Sandbox.PackageEnvironment
- ( loadUserConfig )
+ ( packageConstraintToDependency
+ )
import Distribution.Utils.Generic
- ( safeLast, wrapText )
+ ( safeLast
+ , wrapText
+ )
+import Distribution.Client.HttpUtils
+import qualified Distribution.Compat.CharParsing as P
import Distribution.Package
- ( PackageName, packageVersion )
+ ( PackageName
+ , packageVersion
+ )
import Distribution.PackageDescription
- ( allBuildDepends )
+ ( allBuildDepends
+ )
import Distribution.PackageDescription.Configuration
- ( finalizePD )
+ ( finalizePD
+ )
+import Distribution.ReadE
+ ( parsecToReadE
+ )
+import Distribution.Simple.Command
+ ( CommandUI (..)
+ , OptionField
+ , ShowOrParseArgs
+ , liftOptionL
+ , optArg
+ , option
+ , reqArg
+ )
import Distribution.Simple.Compiler
- ( Compiler, compilerInfo )
+ ( Compiler
+ , compilerInfo
+ )
+import Distribution.Simple.Flag
+ ( Flag (..)
+ , flagToMaybe
+ , fromFlagOrDefault
+ , toFlag
+ )
+import Distribution.Simple.PackageDescription
+ ( readGenericPackageDescription
+ )
import Distribution.Simple.Setup
- ( optionVerbosity, trueArg )
+ ( optionVerbosity
+ , trueArg
+ )
import Distribution.Simple.Utils
- ( die', notice, debug, tryFindPackageDesc )
+ ( debug
+ , die'
+ , notice
+ , tryFindPackageDesc
+ )
import Distribution.System
- ( Platform (..) )
+ ( Platform (..)
+ )
import Distribution.Types.ComponentRequestedSpec
- ( ComponentRequestedSpec(..) )
+ ( ComponentRequestedSpec (..)
+ )
import Distribution.Types.Dependency
- ( Dependency(..) )
-import Distribution.Verbosity
- ( silent, normal )
-import Distribution.Version
- ( Version, VersionInterval (..), VersionRange, LowerBound(..)
- , UpperBound(..) , asVersionIntervals, majorBoundVersion )
+ ( Dependency (..)
+ )
import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint (..), simplifyPackageVersionConstraint )
-import Distribution.Simple.Flag
- ( Flag(..), flagToMaybe, fromFlagOrDefault, toFlag )
-import Distribution.Simple.Command
- ( ShowOrParseArgs, OptionField, CommandUI(..), optArg, option, reqArg, liftOptionL )
-import Distribution.Simple.PackageDescription
- ( readGenericPackageDescription )
-import qualified Distribution.Compat.CharParsing as P
-import Distribution.ReadE
- ( parsecToReadE )
-import Distribution.Client.HttpUtils
+ ( PackageVersionConstraint (..)
+ , simplifyPackageVersionConstraint
+ )
import Distribution.Utils.NubList
- ( fromNubList )
+ ( fromNubList
+ )
+import Distribution.Verbosity
+ ( normal
+ , silent
+ )
+import Distribution.Version
+ ( LowerBound (..)
+ , UpperBound (..)
+ , Version
+ , VersionInterval (..)
+ , VersionRange
+ , asVersionIntervals
+ , majorBoundVersion
+ )
import qualified Data.Set as S
import System.Directory
- ( getCurrentDirectory, doesFileExist )
+ ( doesFileExist
+ , getCurrentDirectory
+ )
-------------------------------------------------------------------------------
-- Command
-------------------------------------------------------------------------------
outdatedCommand :: CommandUI (ProjectFlags, OutdatedFlags)
-outdatedCommand = CommandUI
- { commandName = "outdated"
- , commandSynopsis = "Check for outdated dependencies."
- , commandDescription = Just $ \_ -> wrapText $
- "Checks for outdated dependencies in the package description file "
- ++ "or freeze file"
- , commandNotes = Nothing
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n"
- , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags)
- , commandOptions = \showOrParseArgs ->
- map (liftOptionL _1)
- (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs)) ++
- map (liftOptionL _2) (outdatedOptions showOrParseArgs)
- }
+outdatedCommand =
+ CommandUI
+ { commandName = "outdated"
+ , commandSynopsis = "Check for outdated dependencies."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Checks for outdated dependencies in the package description file "
+ ++ "or freeze file"
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " outdated [FLAGS] [PACKAGES]\n"
+ , commandDefaultFlags = (defaultProjectFlags, defaultOutdatedFlags)
+ , commandOptions = \showOrParseArgs ->
+ map
+ (liftOptionL _1)
+ (removeIgnoreProjectOption (projectFlagsOptions showOrParseArgs))
+ ++ map (liftOptionL _2) (outdatedOptions showOrParseArgs)
+ }
-------------------------------------------------------------------------------
-- Flags
-------------------------------------------------------------------------------
-data IgnoreMajorVersionBumps = IgnoreMajorVersionBumpsNone
- | IgnoreMajorVersionBumpsAll
- | IgnoreMajorVersionBumpsSome [PackageName]
+data IgnoreMajorVersionBumps
+ = IgnoreMajorVersionBumpsNone
+ | IgnoreMajorVersionBumpsAll
+ | IgnoreMajorVersionBumpsSome [PackageName]
instance Monoid IgnoreMajorVersionBumps where
- mempty = IgnoreMajorVersionBumpsNone
+ mempty = IgnoreMajorVersionBumpsNone
mappend = (<>)
instance Semigroup IgnoreMajorVersionBumps where
- IgnoreMajorVersionBumpsNone <> r = r
- l@IgnoreMajorVersionBumpsAll <> _ = l
- l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l
- (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r
- (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) =
+ IgnoreMajorVersionBumpsNone <> r = r
+ l@IgnoreMajorVersionBumpsAll <> _ = l
+ l@(IgnoreMajorVersionBumpsSome _) <> IgnoreMajorVersionBumpsNone = l
+ (IgnoreMajorVersionBumpsSome _) <> r@IgnoreMajorVersionBumpsAll = r
+ (IgnoreMajorVersionBumpsSome a) <> (IgnoreMajorVersionBumpsSome b) =
IgnoreMajorVersionBumpsSome (a ++ b)
data OutdatedFlags = OutdatedFlags
- { outdatedVerbosity :: Flag Verbosity
- , outdatedFreezeFile :: Flag Bool
+ { outdatedVerbosity :: Flag Verbosity
+ , outdatedFreezeFile :: Flag Bool
, outdatedNewFreezeFile :: Flag Bool
- , outdatedSimpleOutput :: Flag Bool
- , outdatedExitCode :: Flag Bool
- , outdatedQuiet :: Flag Bool
- , outdatedIgnore :: [PackageName]
- , outdatedMinor :: Maybe IgnoreMajorVersionBumps
+ , outdatedSimpleOutput :: Flag Bool
+ , outdatedExitCode :: Flag Bool
+ , outdatedQuiet :: Flag Bool
+ , outdatedIgnore :: [PackageName]
+ , outdatedMinor :: Maybe IgnoreMajorVersionBumps
}
defaultOutdatedFlags :: OutdatedFlags
-defaultOutdatedFlags = OutdatedFlags
- { outdatedVerbosity = toFlag normal
- , outdatedFreezeFile = mempty
- , outdatedNewFreezeFile = mempty
- , outdatedSimpleOutput = mempty
- , outdatedExitCode = mempty
- , outdatedQuiet = mempty
- , outdatedIgnore = mempty
- , outdatedMinor = mempty
- }
+defaultOutdatedFlags =
+ OutdatedFlags
+ { outdatedVerbosity = toFlag normal
+ , outdatedFreezeFile = mempty
+ , outdatedNewFreezeFile = mempty
+ , outdatedSimpleOutput = mempty
+ , outdatedExitCode = mempty
+ , outdatedQuiet = mempty
+ , outdatedIgnore = mempty
+ , outdatedMinor = mempty
+ }
outdatedOptions :: ShowOrParseArgs -> [OptionField OutdatedFlags]
outdatedOptions _showOrParseArgs =
[ optionVerbosity
outdatedVerbosity
- (\v flags -> flags {outdatedVerbosity = v})
- , option [] ["freeze-file", "v1-freeze-file"]
+ (\v flags -> flags{outdatedVerbosity = v})
+ , option
+ []
+ ["freeze-file", "v1-freeze-file"]
"Act on the freeze file"
- outdatedFreezeFile (\v flags -> flags {outdatedFreezeFile = v})
+ outdatedFreezeFile
+ (\v flags -> flags{outdatedFreezeFile = v})
trueArg
- , option [] ["v2-freeze-file", "new-freeze-file"]
+ , option
+ []
+ ["v2-freeze-file", "new-freeze-file"]
"Act on the new-style freeze file (default: cabal.project.freeze)"
- outdatedNewFreezeFile (\v flags -> flags {outdatedNewFreezeFile = v})
+ outdatedNewFreezeFile
+ (\v flags -> flags{outdatedNewFreezeFile = v})
trueArg
- , option [] ["simple-output"]
+ , option
+ []
+ ["simple-output"]
"Only print names of outdated dependencies, one per line"
- outdatedSimpleOutput (\v flags -> flags {outdatedSimpleOutput = v})
+ outdatedSimpleOutput
+ (\v flags -> flags{outdatedSimpleOutput = v})
trueArg
- , option [] ["exit-code"]
+ , option
+ []
+ ["exit-code"]
"Exit with non-zero when there are outdated dependencies"
- outdatedExitCode (\v flags -> flags {outdatedExitCode = v})
+ outdatedExitCode
+ (\v flags -> flags{outdatedExitCode = v})
trueArg
- , option ['q'] ["quiet"]
+ , option
+ ['q']
+ ["quiet"]
"Don't print any output. Implies '--exit-code' and '-v0'"
- outdatedQuiet (\v flags -> flags {outdatedQuiet = v})
+ outdatedQuiet
+ (\v flags -> flags{outdatedQuiet = v})
trueArg
- , option [] ["ignore"]
+ , option
+ []
+ ["ignore"]
"Packages to ignore"
- outdatedIgnore (\v flags -> flags {outdatedIgnore = v})
+ outdatedIgnore
+ (\v flags -> flags{outdatedIgnore = v})
(reqArg "PKGS" pkgNameListParser (map prettyShow))
- , option [] ["minor"]
+ , option
+ []
+ ["minor"]
"Ignore major version bumps for these packages"
- outdatedMinor (\v flags -> flags {outdatedMinor = v})
+ outdatedMinor
+ (\v flags -> flags{outdatedMinor = v})
( optArg
"PKGS"
ignoreMajorVersionBumpsParser
@@ -195,20 +286,22 @@ outdatedOptions _showOrParseArgs =
)
]
where
- ignoreMajorVersionBumpsPrinter :: Maybe IgnoreMajorVersionBumps
- -> [Maybe String]
+ ignoreMajorVersionBumpsPrinter
+ :: Maybe IgnoreMajorVersionBumps
+ -> [Maybe String]
ignoreMajorVersionBumpsPrinter Nothing = []
- ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone)= []
+ ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsNone) = []
ignoreMajorVersionBumpsPrinter (Just IgnoreMajorVersionBumpsAll) = [Nothing]
ignoreMajorVersionBumpsPrinter (Just (IgnoreMajorVersionBumpsSome pkgs)) =
map (Just . prettyShow) pkgs
- ignoreMajorVersionBumpsParser =
+ ignoreMajorVersionBumpsParser =
(Just . IgnoreMajorVersionBumpsSome) `fmap` pkgNameListParser
- pkgNameListParser = parsecToReadE
- ("Couldn't parse the list of package names: " ++)
- (fmap toList (P.sepByNonEmpty parsec (P.char ',')))
+ pkgNameListParser =
+ parsecToReadE
+ ("Couldn't parse the list of package names: " ++)
+ (fmap toList (P.sepByNonEmpty parsec (P.char ',')))
-------------------------------------------------------------------------------
-- Action
@@ -219,7 +312,7 @@ outdatedAction :: (ProjectFlags, OutdatedFlags) -> [String] -> GlobalFlags -> IO
outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}) _targetStrings globalFlags = do
config <- loadConfigOrSandboxConfig verbosity globalFlags
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
- configFlags = savedConfigureFlags config
+ configFlags = savedConfigureFlags config
withRepoContext verbosity globalFlags' $ \repoContext -> do
when (not newFreezeFile && (isJust mprojectDir || isJust mprojectFile)) $
die' verbosity $
@@ -227,58 +320,69 @@ outdatedAction (ProjectFlags{flagProjectDir, flagProjectFile}, OutdatedFlags{..}
sourcePkgDb <- IndexUtils.getSourcePackages verbosity repoContext
(comp, platform, _progdb) <- configCompilerAux' configFlags
- deps <- if freezeFile
- then depsFromFreezeFile verbosity
- else if newFreezeFile
- then do
- httpTransport <- configureTransport verbosity
- (fromNubList . globalProgPathExtra $ globalFlags)
- (flagToMaybe . globalHttpTransport $ globalFlags)
- depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile
- else do
- depsFromPkgDesc verbosity comp platform
- debug verbosity $ "Dependencies loaded: "
- ++ intercalate ", " (map prettyShow deps)
- let outdatedDeps = listOutdated deps sourcePkgDb
- (ListOutdatedSettings ignorePred minorPred)
+ deps <-
+ if freezeFile
+ then depsFromFreezeFile verbosity
+ else
+ if newFreezeFile
+ then do
+ httpTransport <-
+ configureTransport
+ verbosity
+ (fromNubList . globalProgPathExtra $ globalFlags)
+ (flagToMaybe . globalHttpTransport $ globalFlags)
+ depsFromNewFreezeFile verbosity httpTransport comp platform mprojectDir mprojectFile
+ else do
+ depsFromPkgDesc verbosity comp platform
+ debug verbosity $
+ "Dependencies loaded: "
+ ++ intercalate ", " (map prettyShow deps)
+ let outdatedDeps =
+ listOutdated
+ deps
+ sourcePkgDb
+ (ListOutdatedSettings ignorePred minorPred)
when (not quiet) $
showResult verbosity outdatedDeps simpleOutput
if exitCode && (not . null $ outdatedDeps)
then exitFailure
else return ()
where
- verbosity = if quiet
- then silent
- else fromFlagOrDefault normal outdatedVerbosity
- freezeFile = fromFlagOrDefault False outdatedFreezeFile
+ verbosity =
+ if quiet
+ then silent
+ else fromFlagOrDefault normal outdatedVerbosity
+ freezeFile = fromFlagOrDefault False outdatedFreezeFile
newFreezeFile = fromFlagOrDefault False outdatedNewFreezeFile
- mprojectDir = flagToMaybe flagProjectDir
- mprojectFile = flagToMaybe flagProjectFile
- simpleOutput = fromFlagOrDefault False outdatedSimpleOutput
- quiet = fromFlagOrDefault False outdatedQuiet
- exitCode = fromFlagOrDefault quiet outdatedExitCode
- ignorePred = let ignoreSet = S.fromList outdatedIgnore
- in \pkgname -> pkgname `S.member` ignoreSet
- minorPred = case outdatedMinor of
- Nothing -> const False
- Just IgnoreMajorVersionBumpsNone -> const False
- Just IgnoreMajorVersionBumpsAll -> const True
- Just (IgnoreMajorVersionBumpsSome pkgs) ->
- let minorSet = S.fromList pkgs
- in \pkgname -> pkgname `S.member` minorSet
-
+ mprojectDir = flagToMaybe flagProjectDir
+ mprojectFile = flagToMaybe flagProjectFile
+ simpleOutput = fromFlagOrDefault False outdatedSimpleOutput
+ quiet = fromFlagOrDefault False outdatedQuiet
+ exitCode = fromFlagOrDefault quiet outdatedExitCode
+ ignorePred =
+ let ignoreSet = S.fromList outdatedIgnore
+ in \pkgname -> pkgname `S.member` ignoreSet
+ minorPred = case outdatedMinor of
+ Nothing -> const False
+ Just IgnoreMajorVersionBumpsNone -> const False
+ Just IgnoreMajorVersionBumpsAll -> const True
+ Just (IgnoreMajorVersionBumpsSome pkgs) ->
+ let minorSet = S.fromList pkgs
+ in \pkgname -> pkgname `S.member` minorSet
-- | Print either the list of all outdated dependencies, or a message
-- that there are none.
-showResult :: Verbosity -> [(PackageVersionConstraint,Version)] -> Bool -> IO ()
+showResult :: Verbosity -> [(PackageVersionConstraint, Version)] -> Bool -> IO ()
showResult verbosity outdatedDeps simpleOutput =
if not . null $ outdatedDeps
- then
- do when (not simpleOutput) $
- notice verbosity "Outdated dependencies:"
- for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->
- let outdatedDep = if simpleOutput then prettyShow pn
- else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"
+ then do
+ when (not simpleOutput) $
+ notice verbosity "Outdated dependencies:"
+ for_ outdatedDeps $ \(d@(PackageVersionConstraint pn _), v) ->
+ let outdatedDep =
+ if simpleOutput
+ then prettyShow pn
+ else prettyShow d ++ " (latest: " ++ prettyShow v ++ ")"
in notice verbosity outdatedDep
else notice verbosity "All dependencies are up to date."
@@ -290,55 +394,71 @@ userConstraintsToDependencies ucnstrs =
-- | Read the list of dependencies from the freeze file.
depsFromFreezeFile :: Verbosity -> IO [PackageVersionConstraint]
depsFromFreezeFile verbosity = do
- cwd <- getCurrentDirectory
+ cwd <- getCurrentDirectory
userConfig <- loadUserConfig verbosity cwd Nothing
- let ucnstrs = map fst . configExConstraints . savedConfigureExFlags $
- userConfig
- deps = userConstraintsToDependencies ucnstrs
+ let ucnstrs =
+ map fst . configExConstraints . savedConfigureExFlags $
+ userConfig
+ deps = userConstraintsToDependencies ucnstrs
debug verbosity "Reading the list of dependencies from the freeze file"
return deps
-- | Read the list of dependencies from the new-style freeze file.
depsFromNewFreezeFile :: Verbosity -> HttpTransport -> Compiler -> Platform -> Maybe FilePath -> Maybe FilePath -> IO [PackageVersionConstraint]
depsFromNewFreezeFile verbosity httpTransport compiler (Platform arch os) mprojectDir mprojectFile = do
- projectRoot <- either throwIO return =<<
- findProjectRoot verbosity mprojectDir mprojectFile
- let distDirLayout = defaultDistDirLayout projectRoot
- {- TODO: Support dist dir override -} Nothing Nothing
+ projectRoot <-
+ either throwIO return
+ =<< findProjectRoot verbosity mprojectDir mprojectFile
+ let distDirLayout =
+ defaultDistDirLayout
+ projectRoot
+ {- TODO: Support dist dir override -} Nothing
+ Nothing
projectConfig <- runRebuild (distProjectRootDirectory distDirLayout) $ do
- pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
- pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs
- let ucnstrs = map fst . projectConfigConstraints . projectConfigShared
- $ projectConfig
- deps = userConstraintsToDependencies ucnstrs
+ pcs <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
+ pure $ instantiateProjectConfigSkeletonWithCompiler os arch (compilerInfo compiler) mempty pcs
+ let ucnstrs =
+ map fst . projectConfigConstraints . projectConfigShared $
+ projectConfig
+ deps = userConstraintsToDependencies ucnstrs
freezeFile = distProjectFile distDirLayout "freeze"
freezeFileExists <- doesFileExist freezeFile
unless freezeFileExists $
die' verbosity $
- "Couldn't find a freeze file expected at: " ++ freezeFile ++ "\n\n"
- ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. "
- ++ "When one of these flags is given, we try to read the dependencies from a freeze file. "
- ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate "
- ++ "a freeze file via 'cabal freeze'."
+ "Couldn't find a freeze file expected at: "
+ ++ freezeFile
+ ++ "\n\n"
+ ++ "We are looking for this file because you supplied '--project-file' or '--v2-freeze-file'. "
+ ++ "When one of these flags is given, we try to read the dependencies from a freeze file. "
+ ++ "If it is undesired behaviour, you should not use these flags, otherwise please generate "
+ ++ "a freeze file via 'cabal freeze'."
debug verbosity $
"Reading the list of dependencies from the new-style freeze file " ++ freezeFile
return deps
-- | Read the list of dependencies from the package description.
-depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint]
+depsFromPkgDesc :: Verbosity -> Compiler -> Platform -> IO [PackageVersionConstraint]
depsFromPkgDesc verbosity comp platform = do
- cwd <- getCurrentDirectory
+ cwd <- getCurrentDirectory
path <- tryFindPackageDesc verbosity cwd
- gpd <- readGenericPackageDescription verbosity path
+ gpd <- readGenericPackageDescription verbosity path
let cinfo = compilerInfo comp
- epd = finalizePD mempty (ComponentRequestedSpec True True)
- (const True) platform cinfo [] gpd
+ epd =
+ finalizePD
+ mempty
+ (ComponentRequestedSpec True True)
+ (const True)
+ platform
+ cinfo
+ []
+ gpd
case epd of
- Left _ -> die' verbosity "finalizePD failed"
+ Left _ -> die' verbosity "finalizePD failed"
Right (pd, _) -> do
let bd = allBuildDepends pd
- debug verbosity
+ debug
+ verbosity
"Reading the list of dependencies from the package description"
return $ map toPVC bd
where
@@ -346,17 +466,18 @@ depsFromPkgDesc verbosity comp platform = do
-- | Various knobs for customising the behaviour of 'listOutdated'.
data ListOutdatedSettings = ListOutdatedSettings
- { -- | Should this package be ignored?
- listOutdatedIgnorePred :: PackageName -> Bool
- , -- | Should major version bumps be ignored for this package?
- listOutdatedMinorPred :: PackageName -> Bool
+ { listOutdatedIgnorePred :: PackageName -> Bool
+ -- ^ Should this package be ignored?
+ , listOutdatedMinorPred :: PackageName -> Bool
+ -- ^ Should major version bumps be ignored for this package?
}
-- | Find all outdated dependencies.
-listOutdated :: [PackageVersionConstraint]
- -> SourcePackageDb
- -> ListOutdatedSettings
- -> [(PackageVersionConstraint, Version)]
+listOutdated
+ :: [PackageVersionConstraint]
+ -> SourcePackageDb
+ -> ListOutdatedSettings
+ -> [(PackageVersionConstraint, Version)]
listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) =
mapMaybe isOutdated $ map simplifyPackageVersionConstraint deps
where
@@ -364,30 +485,31 @@ listOutdated deps sourceDb (ListOutdatedSettings ignorePred minorPred) =
isOutdated dep@(PackageVersionConstraint pname vr)
| ignorePred pname = Nothing
| otherwise =
- let this = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr
+ let this = map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname vr
latest = lookupLatest dep
- in (\v -> (dep, v)) `fmap` isOutdated' this latest
+ in (\v -> (dep, v)) `fmap` isOutdated' this latest
isOutdated' :: [Version] -> [Version] -> Maybe Version
- isOutdated' [] _ = Nothing
- isOutdated' _ [] = Nothing
+ isOutdated' [] _ = Nothing
+ isOutdated' _ [] = Nothing
isOutdated' this latest =
- let this' = maximum this
+ let this' = maximum this
latest' = maximum latest
- in if this' < latest' then Just latest' else Nothing
+ in if this' < latest' then Just latest' else Nothing
lookupLatest :: PackageVersionConstraint -> [Version]
lookupLatest (PackageVersionConstraint pname vr)
| minorPred pname =
- map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname (relaxMinor vr)
+ map packageVersion $ SourcePackageDb.lookupDependency sourceDb pname (relaxMinor vr)
| otherwise =
- map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname
+ map packageVersion $ SourcePackageDb.lookupPackageName sourceDb pname
relaxMinor :: VersionRange -> VersionRange
relaxMinor vr =
let vis = asVersionIntervals vr
- in maybe vr relax (safeLast vis)
- where relax (VersionInterval (LowerBound v0 _) upper) =
- case upper of
- NoUpperBound -> vr
- UpperBound _v1 _ -> majorBoundVersion v0
+ in maybe vr relax (safeLast vis)
+ where
+ relax (VersionInterval (LowerBound v0 _) upper) =
+ case upper of
+ NoUpperBound -> vr
+ UpperBound _v1 _ -> majorBoundVersion v0
diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs
index dcf659f036a427043c16d35a76bd98a25b5e43d5..01a39f3cc647ebc68aa7c8d524302d800210e644 100644
--- a/cabal-install/src/Distribution/Client/CmdRepl.hs
+++ b/cabal-install/src/Distribution/Client/CmdRepl.hs
@@ -5,102 +5,170 @@
{-# LANGUAGE TupleSections #-}
-- | cabal-install CLI command: repl
---
-module Distribution.Client.CmdRepl (
- -- * The @repl@ CLI and action
- replCommand,
- replAction,
+module Distribution.Client.CmdRepl
+ ( -- * The @repl@ CLI and action
+ replCommand
+ , replAction
-- * Internals exposed for testing
- matchesMultipleProblem,
- selectPackageTargets,
- selectComponentTarget
+ , matchesMultipleProblem
+ , selectPackageTargets
+ , selectComponentTarget
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L
-import Distribution.Client.DistDirLayout
- ( DistDirLayout(..) )
-import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.CmdErrorMessages
- ( renderTargetSelector, showTargetSelector,
- renderTargetProblem,
- targetSelectorRefersToPkgs,
- renderComponentKind, renderListCommaAnd, renderListSemiAnd,
- componentKind, sortGroupOn, Plural(..) )
-import Distribution.Client.TargetProblem
- ( TargetProblem(..) )
+ ( Plural (..)
+ , componentKind
+ , renderComponentKind
+ , renderListCommaAnd
+ , renderListSemiAnd
+ , renderTargetProblem
+ , renderTargetSelector
+ , showTargetSelector
+ , sortGroupOn
+ , targetSelectorRefersToPkgs
+ )
+import Distribution.Client.DistDirLayout
+ ( DistDirLayout (..)
+ )
import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.NixStyleOptions
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
import Distribution.Client.ProjectBuilding
- ( rebuildTargetsDryRun, improveInstallPlanWithUpToDatePackages )
+ ( improveInstallPlanWithUpToDatePackages
+ , rebuildTargetsDryRun
+ )
import Distribution.Client.ProjectOrchestration
import Distribution.Client.ProjectPlanning
- ( ElaboratedSharedConfig(..), ElaboratedInstallPlan )
+ ( ElaboratedInstallPlan
+ , ElaboratedSharedConfig (..)
+ )
import Distribution.Client.ProjectPlanning.Types
- ( elabOrderExeDependencies )
+ ( elabOrderExeDependencies
+ )
import Distribution.Client.ScriptUtils
- ( AcceptNoTargets(..), withContextAndSelectors, TargetContext(..)
- , updateContextAndWriteProjectFile, updateContextAndWriteProjectFile'
- , fakeProjectSourcePackage, lSrcpkgDescription )
+ ( AcceptNoTargets (..)
+ , TargetContext (..)
+ , fakeProjectSourcePackage
+ , lSrcpkgDescription
+ , updateContextAndWriteProjectFile
+ , updateContextAndWriteProjectFile'
+ , withContextAndSelectors
+ )
import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..) )
+ ( ConfigFlags (..)
+ , GlobalFlags
+ )
import qualified Distribution.Client.Setup as Client
+import Distribution.Client.TargetProblem
+ ( TargetProblem (..)
+ )
import Distribution.Client.Types
- ( PackageSpecifier(..), UnresolvedSourcePackage )
-import Distribution.Simple.Setup
- ( fromFlagOrDefault, ReplOptions(..), replOptions
- , Flag(..), toFlag, falseArg )
-import Distribution.Simple.Command
- ( CommandUI(..), liftOptionL, usageAlternatives, option
- , ShowOrParseArgs, OptionField, reqArg )
+ ( PackageSpecifier (..)
+ , UnresolvedSourcePackage
+ )
import Distribution.Compiler
- ( CompilerFlavor(GHC) )
-import Distribution.Simple.Compiler
- ( Compiler, compilerCompatVersion )
+ ( CompilerFlavor (GHC)
+ )
import Distribution.Package
- ( Package(..), packageName, UnitId, installedUnitId )
+ ( Package (..)
+ , UnitId
+ , installedUnitId
+ , packageName
+ )
import Distribution.Parsec
- ( parsecCommaList )
+ ( parsecCommaList
+ )
import Distribution.ReadE
- ( ReadE, parsecToReadE )
+ ( ReadE
+ , parsecToReadE
+ )
+import Distribution.Simple.Command
+ ( CommandUI (..)
+ , OptionField
+ , ShowOrParseArgs
+ , liftOptionL
+ , option
+ , reqArg
+ , usageAlternatives
+ )
+import Distribution.Simple.Compiler
+ ( Compiler
+ , compilerCompatVersion
+ )
+import Distribution.Simple.Setup
+ ( Flag (..)
+ , ReplOptions (..)
+ , falseArg
+ , fromFlagOrDefault
+ , replOptions
+ , toFlag
+ )
+import Distribution.Simple.Utils
+ ( debugNoWrap
+ , die'
+ , wrapText
+ )
import Distribution.Solver.Types.SourcePackage
- ( SourcePackage(..) )
+ ( SourcePackage (..)
+ )
import Distribution.Types.BuildInfo
- ( BuildInfo(..), emptyBuildInfo )
+ ( BuildInfo (..)
+ , emptyBuildInfo
+ )
import Distribution.Types.ComponentName
- ( componentNameString )
+ ( componentNameString
+ )
import Distribution.Types.CondTree
- ( CondTree(..) )
+ ( CondTree (..)
+ )
import Distribution.Types.Dependency
- ( Dependency(..), mainLibSet )
+ ( Dependency (..)
+ , mainLibSet
+ )
import Distribution.Types.Library
- ( Library(..), emptyLibrary )
+ ( Library (..)
+ , emptyLibrary
+ )
import Distribution.Types.Version
- ( Version, mkVersion )
+ ( Version
+ , mkVersion
+ )
import Distribution.Types.VersionRange
- ( anyVersion )
+ ( anyVersion
+ )
import Distribution.Utils.Generic
- ( safeHead )
+ ( safeHead
+ )
import Distribution.Verbosity
- ( normal, lessVerbose )
-import Distribution.Simple.Utils
- ( wrapText, die', debugNoWrap )
+ ( lessVerbose
+ , normal
+ )
import Language.Haskell.Extension
- ( Language(..) )
+ ( Language (..)
+ )
import Data.List
- ( (\\) )
+ ( (\\)
+ )
import qualified Data.Map as Map
import qualified Data.Set as Set
import System.Directory
- ( doesFileExist, getCurrentDirectory )
+ ( doesFileExist
+ , getCurrentDirectory
+ )
import System.FilePath
- ( (</>) )
+ ( (</>)
+ )
data EnvFlags = EnvFlags
{ envPackages :: [Dependency]
@@ -108,21 +176,28 @@ data EnvFlags = EnvFlags
}
defaultEnvFlags :: EnvFlags
-defaultEnvFlags = EnvFlags
- { envPackages = []
- , envIncludeTransitive = toFlag True
- }
+defaultEnvFlags =
+ EnvFlags
+ { envPackages = []
+ , envIncludeTransitive = toFlag True
+ }
envOptions :: ShowOrParseArgs -> [OptionField EnvFlags]
envOptions _ =
- [ option ['b'] ["build-depends"]
- "Include additional packages in the environment presented to GHCi."
- envPackages (\p flags -> flags { envPackages = p ++ envPackages flags })
- (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String]))
- , option [] ["no-transitive-deps"]
- "Don't automatically include transitive dependencies of requested packages."
- envIncludeTransitive (\p flags -> flags { envIncludeTransitive = p })
- falseArg
+ [ option
+ ['b']
+ ["build-depends"]
+ "Include additional packages in the environment presented to GHCi."
+ envPackages
+ (\p flags -> flags{envPackages = p ++ envPackages flags})
+ (reqArg "DEPENDENCIES" dependenciesReadE (fmap prettyShow :: [Dependency] -> [String]))
+ , option
+ []
+ ["no-transitive-deps"]
+ "Don't automatically include transitive dependencies of requested packages."
+ envIncludeTransitive
+ (\p flags -> flags{envIncludeTransitive = p})
+ falseArg
]
where
dependenciesReadE :: ReadE [Dependency]
@@ -132,47 +207,61 @@ envOptions _ =
(parsecCommaList parsec)
replCommand :: CommandUI (NixStyleFlags (ReplOptions, EnvFlags))
-replCommand = Client.installCommand {
- commandName = "v2-repl",
- commandSynopsis = "Open an interactive session for the given component.",
- commandUsage = usageAlternatives "v2-repl" [ "[TARGET] [FLAGS]" ],
- commandDescription = Just $ \_ -> wrapText $
- "Open an interactive session for a component within the project. The "
- ++ "available targets are the same as for the 'v2-build' command: "
- ++ "individual components within packages in the project, including "
- ++ "libraries, executables, test-suites or benchmarks. Packages can "
- ++ "also be specified in which case the library component in the "
- ++ "package will be used, or the (first listed) executable in the "
- ++ "package if there is no library.\n\n"
-
- ++ "Dependencies are built or rebuilt as necessary. Additional "
- ++ "configuration flags can be specified on the command line and these "
- ++ "extend the project configuration from the 'cabal.project', "
- ++ "'cabal.project.local' and other files.",
- commandNotes = Just $ \pname ->
+replCommand =
+ Client.installCommand
+ { commandName = "v2-repl"
+ , commandSynopsis = "Open an interactive session for the given component."
+ , commandUsage = usageAlternatives "v2-repl" ["[TARGET] [FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Open an interactive session for a component within the project. The "
+ ++ "available targets are the same as for the 'v2-build' command: "
+ ++ "individual components within packages in the project, including "
+ ++ "libraries, executables, test-suites or benchmarks. Packages can "
+ ++ "also be specified in which case the library component in the "
+ ++ "package will be used, or the (first listed) executable in the "
+ ++ "package if there is no library.\n\n"
+ ++ "Dependencies are built or rebuilt as necessary. Additional "
+ ++ "configuration flags can be specified on the command line and these "
+ ++ "extend the project configuration from the 'cabal.project', "
+ ++ "'cabal.project.local' and other files."
+ , commandNotes = Just $ \pname ->
"Examples, open an interactive session:\n"
- ++ " " ++ pname ++ " v2-repl\n"
- ++ " for the default component in the package in the current directory\n"
- ++ " " ++ pname ++ " v2-repl pkgname\n"
- ++ " for the default component in the package named 'pkgname'\n"
- ++ " " ++ pname ++ " v2-repl ./pkgfoo\n"
- ++ " for the default component in the package in the ./pkgfoo directory\n"
- ++ " " ++ pname ++ " v2-repl cname\n"
- ++ " for the component named 'cname'\n"
- ++ " " ++ pname ++ " v2-repl pkgname:cname\n"
- ++ " for the component 'cname' in the package 'pkgname'\n\n"
- ++ " " ++ pname ++ " v2-repl --build-depends lens\n"
- ++ " add the latest version of the library 'lens' to the default component "
- ++ "(or no componentif there is no project present)\n"
- ++ " " ++ pname ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
- ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' "
- ++ "to the default component (or no component if there is no project present)\n",
-
- commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags),
- commandOptions = nixStyleOptions $ \showOrParseArgs ->
- map (liftOptionL _1) (replOptions showOrParseArgs) ++
- map (liftOptionL _2) (envOptions showOrParseArgs)
- }
+ ++ " "
+ ++ pname
+ ++ " v2-repl\n"
+ ++ " for the default component in the package in the current directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-repl pkgname\n"
+ ++ " for the default component in the package named 'pkgname'\n"
+ ++ " "
+ ++ pname
+ ++ " v2-repl ./pkgfoo\n"
+ ++ " for the default component in the package in the ./pkgfoo directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-repl cname\n"
+ ++ " for the component named 'cname'\n"
+ ++ " "
+ ++ pname
+ ++ " v2-repl pkgname:cname\n"
+ ++ " for the component 'cname' in the package 'pkgname'\n\n"
+ ++ " "
+ ++ pname
+ ++ " v2-repl --build-depends lens\n"
+ ++ " add the latest version of the library 'lens' to the default component "
+ ++ "(or no componentif there is no project present)\n"
+ ++ " "
+ ++ pname
+ ++ " v2-repl --build-depends \"lens >= 4.15 && < 4.18\"\n"
+ ++ " add a version (constrained between 4.15 and 4.18) of the library 'lens' "
+ ++ "to the default component (or no component if there is no project present)\n"
+ , commandDefaultFlags = defaultNixStyleFlags (mempty, defaultEnvFlags)
+ , commandOptions = nixStyleOptions $ \showOrParseArgs ->
+ map (liftOptionL _1) (replOptions showOrParseArgs)
+ ++ map (liftOptionL _2) (envOptions showOrParseArgs)
+ }
-- | The @repl@ command is very much like @build@. It brings the install plan
-- up to date, selects that part of the plan needed by the given or implicit
@@ -184,12 +273,12 @@ replCommand = Client.installCommand {
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
replAction :: NixStyleFlags (ReplOptions, EnvFlags) -> [String] -> GlobalFlags -> IO ()
-replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags
- = withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do
+replAction flags@NixStyleFlags{extraFlags = (replOpts, envFlags), ..} targetStrings globalFlags =
+ withContextAndSelectors AcceptNoTargets (Just LibKind) flags targetStrings globalFlags ReplCommand $ \targetCtx ctx targetSelectors -> do
when (buildSettingOnlyDeps (buildSettings ctx)) $
- die' verbosity $ "The repl command does not support '--only-dependencies'. "
+ die' verbosity $
+ "The repl command does not support '--only-dependencies'. "
++ "You may wish to use 'build --only-dependencies' and then "
++ "use 'repl'."
@@ -197,35 +286,40 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt
baseCtx <- case targetCtx of
ProjectContext -> return ctx
- GlobalContext -> do
+ GlobalContext -> do
unless (null targetStrings) $
- die' verbosity $ "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings
+ die' verbosity $
+ "'repl' takes no arguments or a script argument outside a project: " ++ unwords targetStrings
let
- sourcePackage = fakeProjectSourcePackage projectRoot
- & lSrcpkgDescription . L.condLibrary
- .~ Just (CondNode library [baseDep] [])
- library = emptyLibrary { libBuildInfo = lBuildInfo }
- lBuildInfo = emptyBuildInfo
- { targetBuildDepends = [baseDep]
- , defaultLanguage = Just Haskell2010
- }
+ sourcePackage =
+ fakeProjectSourcePackage projectRoot
+ & lSrcpkgDescription . L.condLibrary
+ .~ Just (CondNode library [baseDep] [])
+ library = emptyLibrary{libBuildInfo = lBuildInfo}
+ lBuildInfo =
+ emptyBuildInfo
+ { targetBuildDepends = [baseDep]
+ , defaultLanguage = Just Haskell2010
+ }
baseDep = Dependency "base" anyVersion mainLibSet
updateContextAndWriteProjectFile' ctx sourcePackage
ScriptContext scriptPath scriptExecutable -> do
unless (length targetStrings == 1) $
- die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings
+ die' verbosity $
+ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings
existsScriptPath <- doesFileExist scriptPath
unless existsScriptPath $
- die' verbosity $ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings
+ die' verbosity $
+ "'repl' takes a single argument which should be a script: " ++ unwords targetStrings
updateContextAndWriteProjectFile ctx scriptPath scriptExecutable
- (originalComponent, baseCtx') <- if null (envPackages envFlags)
- then return (Nothing, baseCtx)
- else
- -- Unfortunately, the best way to do this is to let the normal solver
+ (originalComponent, baseCtx') <-
+ if null (envPackages envFlags)
+ then return (Nothing, baseCtx)
+ else -- Unfortunately, the best way to do this is to let the normal solver
-- help us resolve the targets, but that isn't ideal for performance,
-- especially in the no-project case.
withInstallPlan (lessVerbose verbosity) baseCtx $ \elaboratedPlan _ -> do
@@ -257,39 +351,46 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt
targets <- validatedTargets elaboratedPlan targetSelectors
let
- elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionRepl
- targets
- elaboratedPlan
+ elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionRepl
+ targets
+ elaboratedPlan
includeTransitive = fromFlagOrDefault True (envIncludeTransitive envFlags)
- pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared'
- elaboratedPlan'
+ pkgsBuildStatus <-
+ rebuildTargetsDryRun
+ distDirLayout
+ elaboratedShared'
+ elaboratedPlan'
- let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages
- pkgsBuildStatus elaboratedPlan'
+ let elaboratedPlan'' =
+ improveInstallPlanWithUpToDatePackages
+ pkgsBuildStatus
+ elaboratedPlan'
debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')
let
- buildCtx = ProjectBuildContext
- { elaboratedPlanOriginal = elaboratedPlan
- , elaboratedPlanToExecute = elaboratedPlan''
- , elaboratedShared = elaboratedShared'
- , pkgsBuildStatus
- , targetsMap = targets
- }
+ buildCtx =
+ ProjectBuildContext
+ { elaboratedPlanOriginal = elaboratedPlan
+ , elaboratedPlanToExecute = elaboratedPlan''
+ , elaboratedShared = elaboratedShared'
+ , pkgsBuildStatus
+ , targetsMap = targets
+ }
- ElaboratedSharedConfig { pkgConfigCompiler = compiler } = elaboratedShared'
+ ElaboratedSharedConfig{pkgConfigCompiler = compiler} = elaboratedShared'
replFlags = case originalComponent of
Just oci -> generateReplFlags includeTransitive elaboratedPlan' oci
- Nothing -> []
+ Nothing -> []
return (buildCtx, compiler, replOpts & lReplOptionsFlags %~ (++ replFlags))
replOpts'' <- case targetCtx of
ProjectContext -> return replOpts'
- _ -> usingGhciScript compiler projectRoot replOpts'
+ _ -> usingGhciScript compiler projectRoot replOpts'
let buildCtx' = buildCtx & lElaboratedShared . lPkgConfigReplOptions .~ replOpts''
printPlan verbosity baseCtx' buildCtx'
@@ -302,19 +403,21 @@ replAction flags@NixStyleFlags { extraFlags = (replOpts, envFlags), ..} targetSt
validatedTargets elaboratedPlan targetSelectors = do
-- Interpret the targets on the command line as repl targets
-- (as opposed to say build or haddock targets).
- targets <- either (reportTargetProblems verbosity) return
- $ resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
+ targets <-
+ either (reportTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
-- Reject multiple targets, or at least targets in different
-- components. It is ok to have two module/file targets in the
-- same component, but not two that live in different components.
when (Set.size (distinctTargetComponents targets) > 1) $
- reportTargetProblems verbosity
+ reportTargetProblems
+ verbosity
[multipleTargetsProblem targets]
return targets
@@ -325,27 +428,32 @@ data OriginalComponentInfo = OriginalComponentInfo
}
deriving (Show)
-addDepsToProjectTarget :: [Dependency]
- -> PackageId
- -> ProjectBaseContext
- -> ProjectBaseContext
+addDepsToProjectTarget
+ :: [Dependency]
+ -> PackageId
+ -> ProjectBaseContext
+ -> ProjectBaseContext
addDepsToProjectTarget deps pkgId ctx =
- (\p -> ctx { localPackages = p }) . fmap addDeps . localPackages $ ctx
+ (\p -> ctx{localPackages = p}) . fmap addDeps . localPackages $ ctx
where
- addDeps :: PackageSpecifier UnresolvedSourcePackage
- -> PackageSpecifier UnresolvedSourcePackage
+ addDeps
+ :: PackageSpecifier UnresolvedSourcePackage
+ -> PackageSpecifier UnresolvedSourcePackage
addDeps (SpecificSourcePackage pkg)
| packageId pkg /= pkgId = SpecificSourcePackage pkg
| SourcePackage{..} <- pkg =
- SpecificSourcePackage $ pkg { srcpkgDescription =
- -- New dependencies are added to the original ones found in the
- -- `targetBuildDepends` field.
- -- `traverseBuildInfos` is used in order to update _all_ the
- -- occurrences of the field `targetBuildDepends`. It ensures that
- -- fields depending on the latter are also consistently updated.
- srcpkgDescription & (L.traverseBuildInfos . L.targetBuildDepends)
- %~ (deps ++)
- }
+ SpecificSourcePackage $
+ pkg
+ { srcpkgDescription =
+ -- New dependencies are added to the original ones found in the
+ -- `targetBuildDepends` field.
+ -- `traverseBuildInfos` is used in order to update _all_ the
+ -- occurrences of the field `targetBuildDepends`. It ensures that
+ -- fields depending on the latter are also consistently updated.
+ srcpkgDescription
+ & (L.traverseBuildInfos . L.targetBuildDepends)
+ %~ (deps ++)
+ }
addDeps spec = spec
generateReplFlags :: Bool -> ElaboratedInstallPlan -> OriginalComponentInfo -> [String]
@@ -359,12 +467,13 @@ generateReplFlags includeTransitive elaboratedPlan OriginalComponentInfo{..} = f
deps, deps', trans, trans' :: [UnitId]
flags :: [String]
- deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
- deps' = deps \\ ociOriginalDeps
- trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
+ deps = installedUnitId <$> InstallPlan.directDeps elaboratedPlan ociUnitId
+ deps' = deps \\ ociOriginalDeps
+ trans = installedUnitId <$> InstallPlan.dependencyClosure elaboratedPlan deps'
trans' = trans \\ ociOriginalDeps
- flags = fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps)
- $ if includeTransitive then trans' else deps'
+ flags =
+ fmap (("-package-id " ++) . prettyShow) . (\\ exeDeps) $
+ if includeTransitive then trans' else deps'
-- | Add repl options to ensure the repl actually starts in the current working directory.
--
@@ -402,84 +511,81 @@ minGhciScriptVersion = mkVersion [7, 6]
--
-- Fail if there are no buildable lib\/exe components, or if there are
-- multiple libs or exes.
---
-selectPackageTargets :: TargetSelector
- -> [AvailableTarget k] -> Either ReplTargetProblem [k]
+selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either ReplTargetProblem [k]
selectPackageTargets targetSelector targets
-
- -- If there is exactly one buildable library then we select that
- | [target] <- targetsLibsBuildable
- = Right [target]
-
- -- but fail if there are multiple buildable libraries.
- | not (null targetsLibsBuildable)
- = Left (matchesMultipleProblem targetSelector targetsLibsBuildable')
-
- -- If there is exactly one buildable executable then we select that
- | [target] <- targetsExesBuildable
- = Right [target]
-
- -- but fail if there are multiple buildable executables.
- | not (null targetsExesBuildable)
- = Left (matchesMultipleProblem targetSelector targetsExesBuildable')
-
- -- If there is exactly one other target then we select that
- | [target] <- targetsBuildable
- = Right [target]
-
- -- but fail if there are multiple such targets
- | not (null targetsBuildable)
- = Left (matchesMultipleProblem targetSelector targetsBuildable')
-
- -- If there are targets but none are buildable then we report those
- | not (null targets)
- = Left (TargetProblemNoneEnabled targetSelector targets')
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ -- If there is exactly one buildable library then we select that
+ | [target] <- targetsLibsBuildable =
+ Right [target]
+ -- but fail if there are multiple buildable libraries.
+ | not (null targetsLibsBuildable) =
+ Left (matchesMultipleProblem targetSelector targetsLibsBuildable')
+ -- If there is exactly one buildable executable then we select that
+ | [target] <- targetsExesBuildable =
+ Right [target]
+ -- but fail if there are multiple buildable executables.
+ | not (null targetsExesBuildable) =
+ Left (matchesMultipleProblem targetSelector targetsExesBuildable')
+ -- If there is exactly one other target then we select that
+ | [target] <- targetsBuildable =
+ Right [target]
+ -- but fail if there are multiple such targets
+ | not (null targetsBuildable) =
+ Left (matchesMultipleProblem targetSelector targetsBuildable')
+ -- If there are targets but none are buildable then we report those
+ | not (null targets) =
+ Left (TargetProblemNoneEnabled targetSelector targets')
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
- targets' = forgetTargetsDetail targets
- (targetsLibsBuildable,
- targetsLibsBuildable') = selectBuildableTargets'
- . filterTargetsKind LibKind
- $ targets
- (targetsExesBuildable,
- targetsExesBuildable') = selectBuildableTargets'
- . filterTargetsKind ExeKind
- $ targets
- (targetsBuildable,
- targetsBuildable') = selectBuildableTargetsWith'
- (isRequested targetSelector) targets
+ targets' = forgetTargetsDetail targets
+ ( targetsLibsBuildable
+ , targetsLibsBuildable'
+ ) =
+ selectBuildableTargets'
+ . filterTargetsKind LibKind
+ $ targets
+ ( targetsExesBuildable
+ , targetsExesBuildable'
+ ) =
+ selectBuildableTargets'
+ . filterTargetsKind ExeKind
+ $ targets
+ ( targetsBuildable
+ , targetsBuildable'
+ ) =
+ selectBuildableTargetsWith'
+ (isRequested targetSelector)
+ targets
-- When there's a target filter like "pkg:tests" then we do select tests,
-- but if it's just a target like "pkg" then we don't build tests unless
-- they are requested by default (i.e. by using --enable-tests)
- isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
- isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
+ isRequested (TargetAllPackages Nothing) TargetNotRequestedByDefault = False
+ isRequested (TargetPackage _ _ Nothing) TargetNotRequestedByDefault = False
isRequested _ _ = True
-
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @repl@ command we just need the basic checks on being buildable etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either ReplTargetProblem k
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either ReplTargetProblem k
selectComponentTarget = selectComponentTargetBasic
-
data ReplProblem
= TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
-
- -- | Multiple 'TargetSelector's match multiple targets
- | TargetProblemMultipleTargets TargetsMap
+ | -- | Multiple 'TargetSelector's match multiple targets
+ TargetProblemMultipleTargets TargetsMap
deriving (Eq, Show)
-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @repl@ command.
---
type ReplTargetProblem = TargetProblem ReplProblem
matchesMultipleProblem
@@ -496,55 +602,62 @@ multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
reportTargetProblems :: Verbosity -> [TargetProblem ReplProblem] -> IO a
reportTargetProblems verbosity =
- die' verbosity . unlines . map renderReplTargetProblem
+ die' verbosity . unlines . map renderReplTargetProblem
renderReplTargetProblem :: TargetProblem ReplProblem -> String
renderReplTargetProblem = renderTargetProblem "open a repl for" renderReplProblem
renderReplProblem :: ReplProblem -> String
renderReplProblem (TargetProblemMatchesMultiple targetSelector targets) =
- "Cannot open a repl for multiple components at once. The target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " which "
- ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ")
- ++ renderListSemiAnd
- [ "the " ++ renderComponentKind Plural ckind ++ " " ++
- renderListCommaAnd
+ "Cannot open a repl for multiple components at once. The target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " which "
+ ++ (if targetSelectorRefersToPkgs targetSelector then "includes " else "are ")
+ ++ renderListSemiAnd
+ [ "the "
+ ++ renderComponentKind Plural ckind
+ ++ " "
+ ++ renderListCommaAnd
[ maybe (prettyShow pkgname) prettyShow (componentNameString cname)
| t <- ts
- , let cname = availableTargetComponentName t
+ , let cname = availableTargetComponentName t
pkgname = packageName (availableTargetPackageId t)
]
| (ckind, ts) <- sortGroupOn availableTargetComponentKind targets
]
- ++ ".\n\n" ++ explanationSingleComponentLimitation
+ ++ ".\n\n"
+ ++ explanationSingleComponentLimitation
where
- availableTargetComponentKind = componentKind
- . availableTargetComponentName
-
+ availableTargetComponentKind =
+ componentKind
+ . availableTargetComponentName
renderReplProblem (TargetProblemMultipleTargets selectorMap) =
- "Cannot open a repl for multiple components at once. The targets "
- ++ renderListCommaAnd
+ "Cannot open a repl for multiple components at once. The targets "
+ ++ renderListCommaAnd
[ "'" ++ showTargetSelector ts ++ "'"
- | ts <- uniqueTargetSelectors selectorMap ]
- ++ " refer to different components."
- ++ ".\n\n" ++ explanationSingleComponentLimitation
+ | ts <- uniqueTargetSelectors selectorMap
+ ]
+ ++ " refer to different components."
+ ++ ".\n\n"
+ ++ explanationSingleComponentLimitation
explanationSingleComponentLimitation :: String
explanationSingleComponentLimitation =
- "The reason for this limitation is that current versions of ghci do not "
- ++ "support loading multiple components as source. Load just one component "
- ++ "and when you make changes to a dependent component then quit and reload."
+ "The reason for this limitation is that current versions of ghci do not "
+ ++ "support loading multiple components as source. Load just one component "
+ ++ "and when you make changes to a dependent component then quit and reload."
-- Lenses
lElaboratedShared :: Lens' ProjectBuildContext ElaboratedSharedConfig
-lElaboratedShared f s = fmap (\x -> s { elaboratedShared = x }) (f (elaboratedShared s))
-{-# inline lElaboratedShared #-}
+lElaboratedShared f s = fmap (\x -> s{elaboratedShared = x}) (f (elaboratedShared s))
+{-# INLINE lElaboratedShared #-}
lPkgConfigReplOptions :: Lens' ElaboratedSharedConfig ReplOptions
-lPkgConfigReplOptions f s = fmap (\x -> s { pkgConfigReplOptions = x }) (f (pkgConfigReplOptions s))
-{-# inline lPkgConfigReplOptions #-}
+lPkgConfigReplOptions f s = fmap (\x -> s{pkgConfigReplOptions = x}) (f (pkgConfigReplOptions s))
+{-# INLINE lPkgConfigReplOptions #-}
lReplOptionsFlags :: Lens' ReplOptions [String]
-lReplOptionsFlags f s = fmap (\x -> s { replOptionsFlags = x }) (f (replOptionsFlags s))
-{-# inline lReplOptionsFlags #-}
+lReplOptionsFlags f s = fmap (\x -> s{replOptionsFlags = x}) (f (replOptionsFlags s))
+{-# INLINE lReplOptionsFlags #-}
diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs
index 664ffb30fca787fac0976bf7732907a62fe1defe..a3134b321208491e0efdf0d26216a8ff632d77ac 100644
--- a/cabal-install/src/Distribution/Client/CmdRun.hs
+++ b/cabal-install/src/Distribution/Client/CmdRun.hs
@@ -5,118 +5,172 @@
{-# LANGUAGE TupleSections #-}
-- | cabal-install CLI command: run
---
-module Distribution.Client.CmdRun (
- -- * The @run@ CLI and action
- runCommand,
- runAction,
- handleShebang, validScript,
+module Distribution.Client.CmdRun
+ ( -- * The @run@ CLI and action
+ runCommand
+ , runAction
+ , handleShebang
+ , validScript
-- * Internals exposed for testing
- matchesMultipleProblem,
- noExesProblem,
- selectPackageTargets,
- selectComponentTarget
+ , matchesMultipleProblem
+ , noExesProblem
+ , selectPackageTargets
+ , selectComponentTarget
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude hiding (toList)
+import Prelude ()
-import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
- ( renderTargetSelector, showTargetSelector,
- renderTargetProblem,
- renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
- targetSelectorFilter, renderListCommaAnd,
- renderListPretty )
+ ( plural
+ , renderListCommaAnd
+ , renderListPretty
+ , renderTargetProblem
+ , renderTargetProblemNoTargets
+ , renderTargetSelector
+ , showTargetSelector
+ , targetSelectorFilter
+ , targetSelectorPluralPkgs
+ )
+import Distribution.Client.ProjectOrchestration
import Distribution.Client.TargetProblem
- ( TargetProblem (..) )
+ ( TargetProblem (..)
+ )
-import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
-import Distribution.Client.Setup
- ( GlobalFlags(..), ConfigFlags(..) )
import Distribution.Client.GlobalFlags
- ( defaultGlobalFlags )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault )
-import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives )
-import Distribution.Types.ComponentName
- ( componentNameRaw )
-import Distribution.Verbosity
- ( normal, silent )
-import Distribution.Simple.Utils
- ( wrapText, die', info, notice, safeHead, warn )
+ ( defaultGlobalFlags
+ )
+import Distribution.Client.InstallPlan
+ ( foldPlanPackage
+ , toList
+ )
+import Distribution.Client.NixStyleOptions
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
import Distribution.Client.ProjectPlanning
- ( ElaboratedConfiguredPackage(..)
- , ElaboratedInstallPlan, binDirectoryFor )
+ ( ElaboratedConfiguredPackage (..)
+ , ElaboratedInstallPlan
+ , binDirectoryFor
+ )
import Distribution.Client.ProjectPlanning.Types
- ( dataDirsEnvironmentForPlan )
-import Distribution.Client.InstallPlan
- ( toList, foldPlanPackage )
-import Distribution.Types.UnqualComponentName
- ( UnqualComponentName, unUnqualComponentName )
-import Distribution.Simple.Program.Run
- ( runProgramInvocation, ProgramInvocation(..),
- emptyProgramInvocation )
-import Distribution.Types.UnitId
- ( UnitId )
+ ( dataDirsEnvironmentForPlan
+ )
import Distribution.Client.ScriptUtils
- ( AcceptNoTargets(..), withContextAndSelectors, updateContextAndWriteProjectFile, TargetContext(..) )
+ ( AcceptNoTargets (..)
+ , TargetContext (..)
+ , updateContextAndWriteProjectFile
+ , withContextAndSelectors
+ )
+import Distribution.Client.Setup
+ ( ConfigFlags (..)
+ , GlobalFlags (..)
+ )
import Distribution.Client.Utils
- ( occursOnlyOrBefore, giveRTSWarning )
+ ( giveRTSWarning
+ , occursOnlyOrBefore
+ )
+import Distribution.Simple.Command
+ ( CommandUI (..)
+ , usageAlternatives
+ )
+import Distribution.Simple.Flag
+ ( fromFlagOrDefault
+ )
+import Distribution.Simple.Program.Run
+ ( ProgramInvocation (..)
+ , emptyProgramInvocation
+ , runProgramInvocation
+ )
+import Distribution.Simple.Utils
+ ( die'
+ , info
+ , notice
+ , safeHead
+ , warn
+ , wrapText
+ )
+import Distribution.Types.ComponentName
+ ( componentNameRaw
+ )
+import Distribution.Types.UnitId
+ ( UnitId
+ )
+import Distribution.Types.UnqualComponentName
+ ( UnqualComponentName
+ , unUnqualComponentName
+ )
+import Distribution.Verbosity
+ ( normal
+ , silent
+ )
-import Data.List ( group )
+import Data.List (group)
import qualified Data.Set as Set
import GHC.Environment
- ( getFullArgs )
+ ( getFullArgs
+ )
import System.Directory
- ( doesFileExist )
+ ( doesFileExist
+ )
import System.FilePath
- ( (</>), isValid, isPathSeparator )
+ ( isPathSeparator
+ , isValid
+ , (</>)
+ )
runCommand :: CommandUI (NixStyleFlags ())
-runCommand = CommandUI
- { commandName = "v2-run"
- , commandSynopsis = "Run an executable."
- , commandUsage = usageAlternatives "v2-run"
- [ "[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]" ]
- , commandDescription = Just $ \pname -> wrapText $
- "Runs the specified executable-like component (an executable, a test, "
- ++ "or a benchmark), first ensuring it is up to date.\n\n"
-
- ++ "Any executable-like component in any package in the project can be "
- ++ "specified. A package can be specified if contains just one "
- ++ "executable-like, preferring a single executable. The default is to "
- ++ "use the package in the current directory if it contains just one "
- ++ "executable-like.\n\n"
-
- ++ "Extra arguments can be passed to the program, but use '--' to "
- ++ "separate arguments for the program from arguments for " ++ pname
- ++ ". The executable is run in an environment where it can find its "
- ++ "data files inplace in the build tree.\n\n"
-
- ++ "Dependencies are built or rebuilt as necessary. Additional "
- ++ "configuration flags can be specified on the command line and these "
- ++ "extend the project configuration from the 'cabal.project', "
- ++ "'cabal.project.local' and other files."
- , commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " v2-run\n"
- ++ " Run the executable-like in the package in the current directory\n"
- ++ " " ++ pname ++ " v2-run foo-tool\n"
- ++ " Run the named executable-like (in any package in the project)\n"
- ++ " " ++ pname ++ " v2-run pkgfoo:foo-tool\n"
- ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"
- ++ " " ++ pname ++ " v2-run foo -O2 -- dothing --fooflag\n"
- ++ " Build with '-O2' and run the program, passing it extra arguments.\n"
-
- , commandDefaultFlags = defaultNixStyleFlags ()
- , commandOptions = nixStyleOptions (const [])
- }
+runCommand =
+ CommandUI
+ { commandName = "v2-run"
+ , commandSynopsis = "Run an executable."
+ , commandUsage =
+ usageAlternatives
+ "v2-run"
+ ["[TARGET] [FLAGS] [-- EXECUTABLE_FLAGS]"]
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "Runs the specified executable-like component (an executable, a test, "
+ ++ "or a benchmark), first ensuring it is up to date.\n\n"
+ ++ "Any executable-like component in any package in the project can be "
+ ++ "specified. A package can be specified if contains just one "
+ ++ "executable-like, preferring a single executable. The default is to "
+ ++ "use the package in the current directory if it contains just one "
+ ++ "executable-like.\n\n"
+ ++ "Extra arguments can be passed to the program, but use '--' to "
+ ++ "separate arguments for the program from arguments for "
+ ++ pname
+ ++ ". The executable is run in an environment where it can find its "
+ ++ "data files inplace in the build tree.\n\n"
+ ++ "Dependencies are built or rebuilt as necessary. Additional "
+ ++ "configuration flags can be specified on the command line and these "
+ ++ "extend the project configuration from the 'cabal.project', "
+ ++ "'cabal.project.local' and other files."
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v2-run\n"
+ ++ " Run the executable-like in the package in the current directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-run foo-tool\n"
+ ++ " Run the named executable-like (in any package in the project)\n"
+ ++ " "
+ ++ pname
+ ++ " v2-run pkgfoo:foo-tool\n"
+ ++ " Run the executable-like 'foo-tool' in the package 'pkgfoo'\n"
+ ++ " "
+ ++ pname
+ ++ " v2-run foo -O2 -- dothing --fooflag\n"
+ ++ " Build with '-O2' and run the program, passing it extra arguments.\n"
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ , commandOptions = nixStyleOptions (const [])
+ }
-- | The @run@ command runs a specified executable-like component, building it
-- first if necessary. The component can be either an executable, a test,
@@ -125,64 +179,69 @@ runCommand = CommandUI
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
runAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-runAction flags@NixStyleFlags {..} targetAndArgs globalFlags
- = withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
+runAction flags@NixStyleFlags{..} targetAndArgs globalFlags =
+ withContextAndSelectors RejectNoTargets (Just ExeKind) flags targetStr globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
(baseCtx, defaultVerbosity) <- case targetCtx of
- ProjectContext -> return (ctx, normal)
- GlobalContext -> return (ctx, normal)
- ScriptContext path exemeta -> (, silent) <$> updateContextAndWriteProjectFile ctx path exemeta
+ ProjectContext -> return (ctx, normal)
+ GlobalContext -> return (ctx, normal)
+ ScriptContext path exemeta -> (,silent) <$> updateContextAndWriteProjectFile ctx path exemeta
let verbosity = fromFlagOrDefault defaultVerbosity (configVerbosity configFlags)
buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-
- when (buildSettingOnlyDeps (buildSettings baseCtx)) $
- die' verbosity $
- "The run command does not support '--only-dependencies'. "
- ++ "You may wish to use 'build --only-dependencies' and then "
- ++ "use 'run'."
-
- fullArgs <- getFullArgs
- when (occursOnlyOrBefore fullArgs "+RTS" "--") $
- warn verbosity $ giveRTSWarning "run"
-
- -- Interpret the targets on the command line as build targets
- -- (as opposed to say repl or haddock targets).
- targets <- either (reportTargetProblems verbosity) return
- $ resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- -- Reject multiple targets, or at least targets in different
- -- components. It is ok to have two module/file targets in the
- -- same component, but not two that live in different components.
- --
- -- Note that we discard the target and return the whole 'TargetsMap',
- -- so this check will be repeated (and must succeed) after
- -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
- _ <- singleExeOrElse
- (reportTargetProblems
- verbosity
- [multipleTargetsProblem targets])
- targets
-
- let elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionBuild
- targets
- elaboratedPlan
- return (elaboratedPlan', targets)
+ when (buildSettingOnlyDeps (buildSettings baseCtx)) $
+ die' verbosity $
+ "The run command does not support '--only-dependencies'. "
+ ++ "You may wish to use 'build --only-dependencies' and then "
+ ++ "use 'run'."
+
+ fullArgs <- getFullArgs
+ when (occursOnlyOrBefore fullArgs "+RTS" "--") $
+ warn verbosity $
+ giveRTSWarning "run"
+
+ -- Interpret the targets on the command line as build targets
+ -- (as opposed to say repl or haddock targets).
+ targets <-
+ either (reportTargetProblems verbosity) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
+
+ -- Reject multiple targets, or at least targets in different
+ -- components. It is ok to have two module/file targets in the
+ -- same component, but not two that live in different components.
+ --
+ -- Note that we discard the target and return the whole 'TargetsMap',
+ -- so this check will be repeated (and must succeed) after
+ -- the 'runProjectPreBuildPhase'. Keep it in mind when modifying this.
+ _ <-
+ singleExeOrElse
+ ( reportTargetProblems
+ verbosity
+ [multipleTargetsProblem targets]
+ )
+ targets
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionBuild
+ targets
+ elaboratedPlan
+ return (elaboratedPlan', targets)
(selectedUnitId, selectedComponent) <-
-- Slight duplication with 'runProjectPreBuildPhase'.
singleExeOrElse
- (die' verbosity $ "No or multiple targets given, but the run "
- ++ "phase has been reached. This is a bug.")
+ ( die' verbosity $
+ "No or multiple targets given, but the run "
+ ++ "phase has been reached. This is a bug."
+ )
$ targetsMap buildCtx
printPlan verbosity baseCtx buildCtx
@@ -190,7 +249,6 @@ runAction flags@NixStyleFlags {..} targetAndArgs globalFlags
buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
-
let elaboratedPlan = elaboratedPlanToExecute buildCtx
matchingElaboratedConfiguredPackages =
matchingPackagesByUnitId
@@ -212,40 +270,49 @@ runAction flags@NixStyleFlags {..} targetAndArgs globalFlags
-- an error in all of these cases, even if some seem like they
-- shouldn't happen.
pkg <- case matchingElaboratedConfiguredPackages of
- [] -> die' verbosity $ "Unknown executable "
- ++ exeName
- ++ " in package "
- ++ prettyShow selectedUnitId
+ [] ->
+ die' verbosity $
+ "Unknown executable "
+ ++ exeName
+ ++ " in package "
+ ++ prettyShow selectedUnitId
[elabPkg] -> do
- info verbosity $ "Selecting "
- ++ prettyShow selectedUnitId
- ++ " to supply " ++ exeName
+ info verbosity $
+ "Selecting "
+ ++ prettyShow selectedUnitId
+ ++ " to supply "
+ ++ exeName
return elabPkg
- elabPkgs -> die' verbosity
- $ "Multiple matching executables found matching "
- ++ exeName
- ++ ":\n"
- ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)
- let exePath = binDirectoryFor (distDirLayout baseCtx)
- (elaboratedShared buildCtx)
- pkg
- exeName
- </> exeName
- let dryRun = buildSettingDryRun (buildSettings baseCtx)
- || buildSettingOnlyDownload (buildSettings baseCtx)
+ elabPkgs ->
+ die' verbosity $
+ "Multiple matching executables found matching "
+ ++ exeName
+ ++ ":\n"
+ ++ unlines (fmap (\p -> " - in package " ++ prettyShow (elabUnitId p)) elabPkgs)
+ let exePath =
+ binDirectoryFor
+ (distDirLayout baseCtx)
+ (elaboratedShared buildCtx)
+ pkg
+ exeName
+ </> exeName
+ let dryRun =
+ buildSettingDryRun (buildSettings baseCtx)
+ || buildSettingOnlyDownload (buildSettings baseCtx)
if dryRun
- then notice verbosity "Running of executable suppressed by flag(s)"
- else
- runProgramInvocation
- verbosity
- emptyProgramInvocation {
- progInvokePath = exePath,
- progInvokeArgs = args,
- progInvokeEnv = dataDirsEnvironmentForPlan
- (distDirLayout baseCtx)
- elaboratedPlan
- }
+ then notice verbosity "Running of executable suppressed by flag(s)"
+ else
+ runProgramInvocation
+ verbosity
+ emptyProgramInvocation
+ { progInvokePath = exePath
+ , progInvokeArgs = args
+ , progInvokeEnv =
+ dataDirsEnvironmentForPlan
+ (distDirLayout baseCtx)
+ elaboratedPlan
+ }
where
(targetStr, args) = splitAt 1 targetAndArgs
@@ -273,30 +340,35 @@ validScript script
-- argument is a list of arguments to be passed to the script.
handleShebang :: FilePath -> [String] -> IO ()
handleShebang script args =
- runAction (commandDefaultFlags runCommand) (script:args) defaultGlobalFlags
+ runAction (commandDefaultFlags runCommand) (script : args) defaultGlobalFlags
singleExeOrElse :: IO (UnitId, UnqualComponentName) -> TargetsMap -> IO (UnitId, UnqualComponentName)
singleExeOrElse action targetsMap =
- case Set.toList . distinctTargetComponents $ targetsMap
- of [(unitId, CExeName component)] -> return (unitId, component)
- [(unitId, CTestName component)] -> return (unitId, component)
- [(unitId, CBenchName component)] -> return (unitId, component)
- _ -> action
+ case Set.toList . distinctTargetComponents $ targetsMap of
+ [(unitId, CExeName component)] -> return (unitId, component)
+ [(unitId, CTestName component)] -> return (unitId, component)
+ [(unitId, CBenchName component)] -> return (unitId, component)
+ _ -> action
-- | Filter the 'ElaboratedInstallPlan' keeping only the
-- 'ElaboratedConfiguredPackage's that match the specified
-- 'UnitId'.
-matchingPackagesByUnitId :: UnitId
- -> ElaboratedInstallPlan
- -> [ElaboratedConfiguredPackage]
+matchingPackagesByUnitId
+ :: UnitId
+ -> ElaboratedInstallPlan
+ -> [ElaboratedConfiguredPackage]
matchingPackagesByUnitId uid =
- catMaybes
- . fmap (foldPlanPackage
- (const Nothing)
- (\x -> if elabUnitId x == uid
- then Just x
- else Nothing))
- . toList
+ catMaybes
+ . fmap
+ ( foldPlanPackage
+ (const Nothing)
+ ( \x ->
+ if elabUnitId x == uid
+ then Just x
+ else Nothing
+ )
+ )
+ . toList
-- | This defines what a 'TargetSelector' means for the @run@ command.
-- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,
@@ -304,49 +376,45 @@ matchingPackagesByUnitId uid =
--
-- For the @run@ command we select the exe if there is only one and it's
-- buildable. Fail if there are no or multiple buildable exe components.
---
-selectPackageTargets :: TargetSelector
- -> [AvailableTarget k] -> Either RunTargetProblem [k]
+selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either RunTargetProblem [k]
selectPackageTargets targetSelector targets
-
-- If there is a single executable component, select that. See #7403
- | [target] <- targetsExesBuildable
- = Right [target]
-
+ | [target] <- targetsExesBuildable =
+ Right [target]
-- Otherwise, if there is a single executable-like component left, select that.
- | [target] <- targetsExeLikesBuildable
- = Right [target]
-
+ | [target] <- targetsExeLikesBuildable =
+ Right [target]
-- but fail if there are multiple buildable executables.
- | not (null targetsExeLikesBuildable)
- = Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')
-
- -- If there are executables but none are buildable then we report those
- | not (null targetsExeLikes')
- = Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')
-
- -- If there are no executables but some other targets then we report that
- | not (null targets)
- = Left (noExesProblem targetSelector)
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ | not (null targetsExeLikesBuildable) =
+ Left (matchesMultipleProblem targetSelector targetsExeLikesBuildable')
+ -- If there are executables but none are buildable then we report those
+ | not (null targetsExeLikes') =
+ Left (TargetProblemNoneEnabled targetSelector targetsExeLikes')
+ -- If there are no executables but some other targets then we report that
+ | not (null targets) =
+ Left (noExesProblem targetSelector)
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
-- Targets that are precisely executables
targetsExes = filterTargetsKind ExeKind targets
targetsExesBuildable = selectBuildableTargets targetsExes
-- Any target that could be executed
- targetsExeLikes = targetsExes
- ++ filterTargetsKind TestKind targets
- ++ filterTargetsKind BenchKind targets
-
- (targetsExeLikesBuildable,
- targetsExeLikesBuildable') = selectBuildableTargets' targetsExeLikes
+ targetsExeLikes =
+ targetsExes
+ ++ filterTargetsKind TestKind targets
+ ++ filterTargetsKind BenchKind targets
- targetsExeLikes' = forgetTargetsDetail targetsExeLikes
+ ( targetsExeLikesBuildable
+ , targetsExeLikesBuildable'
+ ) = selectBuildableTargets' targetsExeLikes
+ targetsExeLikes' = forgetTargetsDetail targetsExeLikes
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
@@ -354,42 +422,41 @@ selectPackageTargets targetSelector targets
-- For the @run@ command we just need to check it is a executable-like
-- (an executable, a test, or a benchmark), in addition
-- to the basic checks on being buildable etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either RunTargetProblem k
-selectComponentTarget subtarget@WholeComponent t
- = case availableTargetComponentName t
- of CExeName _ -> component
- CTestName _ -> component
- CBenchName _ -> component
- _ -> Left (componentNotExeProblem pkgid cname)
- where pkgid = availableTargetPackageId t
- cname = availableTargetComponentName t
- component = selectComponentTargetBasic subtarget t
-
-selectComponentTarget subtarget t
- = Left (isSubComponentProblem (availableTargetPackageId t)
- (availableTargetComponentName t)
- subtarget)
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either RunTargetProblem k
+selectComponentTarget subtarget@WholeComponent t =
+ case availableTargetComponentName t of
+ CExeName _ -> component
+ CTestName _ -> component
+ CBenchName _ -> component
+ _ -> Left (componentNotExeProblem pkgid cname)
+ where
+ pkgid = availableTargetPackageId t
+ cname = availableTargetComponentName t
+ component = selectComponentTargetBasic subtarget t
+selectComponentTarget subtarget t =
+ Left
+ ( isSubComponentProblem
+ (availableTargetPackageId t)
+ (availableTargetComponentName t)
+ subtarget
+ )
-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @run@ command.
---
-data RunProblem =
- -- | The 'TargetSelector' matches targets but no executables
- TargetProblemNoExes TargetSelector
-
- -- | A single 'TargetSelector' matches multiple targets
- | TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
-
- -- | Multiple 'TargetSelector's match multiple targets
- | TargetProblemMultipleTargets TargetsMap
-
- -- | The 'TargetSelector' refers to a component that is not an executable
- | TargetProblemComponentNotExe PackageId ComponentName
-
- -- | Asking to run an individual file or module is not supported
- | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
+data RunProblem
+ = -- | The 'TargetSelector' matches targets but no executables
+ TargetProblemNoExes TargetSelector
+ | -- | A single 'TargetSelector' matches multiple targets
+ TargetProblemMatchesMultiple TargetSelector [AvailableTarget ()]
+ | -- | Multiple 'TargetSelector's match multiple targets
+ TargetProblemMultipleTargets TargetsMap
+ | -- | The 'TargetSelector' refers to a component that is not an executable
+ TargetProblemComponentNotExe PackageId ComponentName
+ | -- | Asking to run an individual file or module is not supported
+ TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
deriving (Eq, Show)
type RunTargetProblem = TargetProblem RunProblem
@@ -398,14 +465,16 @@ noExesProblem :: TargetSelector -> RunTargetProblem
noExesProblem = CustomTargetProblem . TargetProblemNoExes
matchesMultipleProblem :: TargetSelector -> [AvailableTarget ()] -> RunTargetProblem
-matchesMultipleProblem selector targets = CustomTargetProblem $
+matchesMultipleProblem selector targets =
+ CustomTargetProblem $
TargetProblemMatchesMultiple selector targets
multipleTargetsProblem :: TargetsMap -> TargetProblem RunProblem
multipleTargetsProblem = CustomTargetProblem . TargetProblemMultipleTargets
componentNotExeProblem :: PackageId -> ComponentName -> TargetProblem RunProblem
-componentNotExeProblem pkgid name = CustomTargetProblem $
+componentNotExeProblem pkgid name =
+ CustomTargetProblem $
TargetProblemComponentNotExe pkgid name
isSubComponentProblem
@@ -413,62 +482,77 @@ isSubComponentProblem
-> ComponentName
-> SubComponentTarget
-> TargetProblem RunProblem
-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $
+isSubComponentProblem pkgid name subcomponent =
+ CustomTargetProblem $
TargetProblemIsSubComponent pkgid name subcomponent
reportTargetProblems :: Verbosity -> [RunTargetProblem] -> IO a
reportTargetProblems verbosity =
- die' verbosity . unlines . map renderRunTargetProblem
+ die' verbosity . unlines . map renderRunTargetProblem
renderRunTargetProblem :: RunTargetProblem -> String
renderRunTargetProblem (TargetProblemNoTargets targetSelector) =
- case targetSelectorFilter targetSelector of
- Just kind | kind /= ExeKind
- -> "The run command is for running executables, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
-
- _ -> renderTargetProblemNoTargets "run" targetSelector
+ case targetSelectorFilter targetSelector of
+ Just kind
+ | kind /= ExeKind ->
+ "The run command is for running executables, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
+ _ -> renderTargetProblemNoTargets "run" targetSelector
renderRunTargetProblem problem =
- renderTargetProblem "run" renderRunProblem problem
+ renderTargetProblem "run" renderRunProblem problem
renderRunProblem :: RunProblem -> String
renderRunProblem (TargetProblemMatchesMultiple targetSelector targets) =
- "The run command is for running a single executable at once. The target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " which includes \n"
- ++ unlines ((\(label, xs) -> "- " ++ label ++ ": " ++ renderListPretty xs)
- <$> (zip ["executables", "test-suites", "benchmarks"]
- $ filter (not . null) . map removeDuplicates
- $ map (componentNameRaw . availableTargetComponentName)
- <$> (flip filterTargetsKind $ targets) <$> [ExeKind, TestKind, BenchKind] ))
- where removeDuplicates = catMaybes . map safeHead . group . sort
-
+ "The run command is for running a single executable at once. The target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " which includes \n"
+ ++ unlines
+ ( (\(label, xs) -> "- " ++ label ++ ": " ++ renderListPretty xs)
+ <$> ( zip ["executables", "test-suites", "benchmarks"] $
+ filter (not . null) . map removeDuplicates $
+ map (componentNameRaw . availableTargetComponentName)
+ <$> (flip filterTargetsKind $ targets)
+ <$> [ExeKind, TestKind, BenchKind]
+ )
+ )
+ where
+ removeDuplicates = catMaybes . map safeHead . group . sort
renderRunProblem (TargetProblemMultipleTargets selectorMap) =
- "The run command is for running a single executable at once. The targets "
- ++ renderListCommaAnd [ "'" ++ showTargetSelector ts ++ "'"
- | ts <- uniqueTargetSelectors selectorMap ]
- ++ " refer to different executables."
-
+ "The run command is for running a single executable at once. The targets "
+ ++ renderListCommaAnd
+ [ "'" ++ showTargetSelector ts ++ "'"
+ | ts <- uniqueTargetSelectors selectorMap
+ ]
+ ++ " refer to different executables."
renderRunProblem (TargetProblemComponentNotExe pkgid cname) =
- "The run command is for running executables, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " from the package "
- ++ prettyShow pkgid ++ "."
+ "The run command is for running executables, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " from the package "
+ ++ prettyShow pkgid
+ ++ "."
where
targetSelector = TargetComponent pkgid cname WholeComponent
-
renderRunProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
- "The run command can only run an executable as a whole, "
- ++ "not files or modules within them, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
+ "The run command can only run an executable as a whole, "
+ ++ "not files or modules within them, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
where
targetSelector = TargetComponent pkgid cname subtarget
-
renderRunProblem (TargetProblemNoExes targetSelector) =
- "Cannot run the target '" ++ showTargetSelector targetSelector
- ++ "' which refers to " ++ renderTargetSelector targetSelector
- ++ " because "
- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
- ++ " not contain any executables."
+ "Cannot run the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' which refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " because "
+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
+ ++ " not contain any executables."
diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs
index 605403b0a3a3b0e2d1e6b105e5cde50065f9e498..cd5946641ca55268edc76557b9dd4d8dc908556c 100644
--- a/cabal-install/src/Distribution/Client/CmdSdist.hs
+++ b/cabal-install/src/Distribution/Client/CmdSdist.hs
@@ -1,93 +1,161 @@
-{-# LANGUAGE MultiWayIf #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
module Distribution.Client.CmdSdist
- ( sdistCommand, sdistAction, packageToSdist
- , OutputFormat(..)) where
+ ( sdistCommand
+ , sdistAction
+ , packageToSdist
+ , OutputFormat (..)
+ ) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Distribution.Client.CmdErrorMessages
- ( Plural(..), renderComponentKind )
-import Distribution.Client.ProjectOrchestration
- ( ProjectBaseContext(..), CurrentCommand(..), establishProjectBaseContext, establishProjectBaseContextWithRoot)
-import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), defaultNixStyleFlags )
-import Distribution.Client.TargetSelector
- ( TargetSelector(..), ComponentKind
- , readTargetSelectors, reportTargetSelectorProblems )
-import Distribution.Client.Setup
- ( GlobalFlags(..) )
-import Distribution.Solver.Types.SourcePackage
- ( SourcePackage(..) )
-import Distribution.Client.Types
- ( PackageSpecifier(..), PackageLocation(..), UnresolvedSourcePackage )
+ ( Plural (..)
+ , renderComponentKind
+ )
import Distribution.Client.DistDirLayout
- ( DistDirLayout(..), ProjectRoot (..) )
+ ( DistDirLayout (..)
+ , ProjectRoot (..)
+ )
+import Distribution.Client.NixStyleOptions
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ )
import Distribution.Client.ProjectConfig
- ( ProjectConfig, withProjectOrGlobalConfig, commandLineFlagsToProjectConfig, projectConfigConfigFile, projectConfigShared )
+ ( ProjectConfig
+ , commandLineFlagsToProjectConfig
+ , projectConfigConfigFile
+ , projectConfigShared
+ , withProjectOrGlobalConfig
+ )
import Distribution.Client.ProjectFlags
- ( ProjectFlags (..), defaultProjectFlags, projectFlagsOptions )
+ ( ProjectFlags (..)
+ , defaultProjectFlags
+ , projectFlagsOptions
+ )
+import Distribution.Client.ProjectOrchestration
+ ( CurrentCommand (..)
+ , ProjectBaseContext (..)
+ , establishProjectBaseContext
+ , establishProjectBaseContextWithRoot
+ )
+import Distribution.Client.Setup
+ ( GlobalFlags (..)
+ )
+import Distribution.Client.TargetSelector
+ ( ComponentKind
+ , TargetSelector (..)
+ , readTargetSelectors
+ , reportTargetSelectorProblems
+ )
+import Distribution.Client.Types
+ ( PackageLocation (..)
+ , PackageSpecifier (..)
+ , UnresolvedSourcePackage
+ )
+import Distribution.Solver.Types.SourcePackage
+ ( SourcePackage (..)
+ )
+import Distribution.Client.SrcDist
+ ( packageDirToSdist
+ )
import Distribution.Compat.Lens
- ( _1, _2 )
+ ( _1
+ , _2
+ )
import Distribution.Package
- ( Package(packageId) )
+ ( Package (packageId)
+ )
import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription )
+ ( flattenPackageDescription
+ )
import Distribution.ReadE
- ( succeedReadE )
+ ( succeedReadE
+ )
import Distribution.Simple.Command
- ( CommandUI(..), OptionField, option, reqArg, liftOptionL, ShowOrParseArgs )
+ ( CommandUI (..)
+ , OptionField
+ , ShowOrParseArgs
+ , liftOptionL
+ , option
+ , reqArg
+ )
import Distribution.Simple.PreProcess
- ( knownSuffixHandlers )
+ ( knownSuffixHandlers
+ )
import Distribution.Simple.Setup
- ( Flag(..), toFlag, fromFlagOrDefault, flagToList, flagToMaybe
- , optionVerbosity, optionDistPref, trueArg, configVerbosity, configDistPref
- )
+ ( Flag (..)
+ , configDistPref
+ , configVerbosity
+ , flagToList
+ , flagToMaybe
+ , fromFlagOrDefault
+ , optionDistPref
+ , optionVerbosity
+ , toFlag
+ , trueArg
+ )
import Distribution.Simple.SrcDist
- ( listPackageSourcesWithDie )
-import Distribution.Client.SrcDist
- ( packageDirToSdist )
+ ( listPackageSourcesWithDie
+ )
import Distribution.Simple.Utils
- ( die', notice, withOutputMarker, wrapText )
+ ( die'
+ , notice
+ , withOutputMarker
+ , wrapText
+ )
import Distribution.Types.ComponentName
- ( ComponentName, showComponentName )
+ ( ComponentName
+ , showComponentName
+ )
+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
import Distribution.Types.PackageName
- ( PackageName, unPackageName )
+ ( PackageName
+ , unPackageName
+ )
import Distribution.Verbosity
- ( normal )
-import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
+ ( normal
+ )
import qualified Data.ByteString.Lazy.Char8 as BSL
import System.Directory
- ( getCurrentDirectory
- , createDirectoryIfMissing, makeAbsolute
- )
+ ( createDirectoryIfMissing
+ , getCurrentDirectory
+ , makeAbsolute
+ )
import System.FilePath
- ( (</>), (<.>), makeRelative, normalise )
+ ( makeRelative
+ , normalise
+ , (<.>)
+ , (</>)
+ )
-------------------------------------------------------------------------------
-- Command
-------------------------------------------------------------------------------
sdistCommand :: CommandUI (ProjectFlags, SdistFlags)
-sdistCommand = CommandUI
+sdistCommand =
+ CommandUI
{ commandName = "v2-sdist"
, commandSynopsis = "Generate a source distribution file (.tar.gz)."
, commandUsage = \pname ->
"Usage: " ++ pname ++ " v2-sdist [FLAGS] [PACKAGES]\n"
- , commandDescription = Just $ \_ -> wrapText
- "Generates tarballs of project packages suitable for upload to Hackage."
+ , commandDescription = Just $ \_ ->
+ wrapText
+ "Generates tarballs of project packages suitable for upload to Hackage."
, commandNotes = Nothing
, commandDefaultFlags = (defaultProjectFlags, defaultSdistFlags)
, commandOptions = \showOrParseArgs ->
- map (liftOptionL _1) (projectFlagsOptions showOrParseArgs) ++
- map (liftOptionL _2) (sdistOptions showOrParseArgs)
+ map (liftOptionL _1) (projectFlagsOptions showOrParseArgs)
+ ++ map (liftOptionL _2) (sdistOptions showOrParseArgs)
}
-------------------------------------------------------------------------------
@@ -95,42 +163,54 @@ sdistCommand = CommandUI
-------------------------------------------------------------------------------
data SdistFlags = SdistFlags
- { sdistVerbosity :: Flag Verbosity
- , sdistDistDir :: Flag FilePath
- , sdistListSources :: Flag Bool
- , sdistNulSeparated :: Flag Bool
- , sdistOutputPath :: Flag FilePath
- }
+ { sdistVerbosity :: Flag Verbosity
+ , sdistDistDir :: Flag FilePath
+ , sdistListSources :: Flag Bool
+ , sdistNulSeparated :: Flag Bool
+ , sdistOutputPath :: Flag FilePath
+ }
defaultSdistFlags :: SdistFlags
-defaultSdistFlags = SdistFlags
- { sdistVerbosity = toFlag normal
- , sdistDistDir = mempty
- , sdistListSources = toFlag False
- , sdistNulSeparated = toFlag False
- , sdistOutputPath = mempty
+defaultSdistFlags =
+ SdistFlags
+ { sdistVerbosity = toFlag normal
+ , sdistDistDir = mempty
+ , sdistListSources = toFlag False
+ , sdistNulSeparated = toFlag False
+ , sdistOutputPath = mempty
}
sdistOptions :: ShowOrParseArgs -> [OptionField SdistFlags]
sdistOptions showOrParseArgs =
- [ optionVerbosity
- sdistVerbosity (\v flags -> flags { sdistVerbosity = v })
- , optionDistPref
- sdistDistDir (\dd flags -> flags { sdistDistDir = dd })
- showOrParseArgs
- , option ['l'] ["list-only"]
- "Just list the sources, do not make a tarball"
- sdistListSources (\v flags -> flags { sdistListSources = v })
- trueArg
- , option [] ["null-sep"]
- "Separate the source files with NUL bytes rather than newlines."
- sdistNulSeparated (\v flags -> flags { sdistNulSeparated = v })
- trueArg
- , option ['o'] ["output-directory", "outputdir"]
- "Choose the output directory of this command. '-' sends all output to stdout"
- sdistOutputPath (\o flags -> flags { sdistOutputPath = o })
- (reqArg "PATH" (succeedReadE Flag) flagToList)
- ]
+ [ optionVerbosity
+ sdistVerbosity
+ (\v flags -> flags{sdistVerbosity = v})
+ , optionDistPref
+ sdistDistDir
+ (\dd flags -> flags{sdistDistDir = dd})
+ showOrParseArgs
+ , option
+ ['l']
+ ["list-only"]
+ "Just list the sources, do not make a tarball"
+ sdistListSources
+ (\v flags -> flags{sdistListSources = v})
+ trueArg
+ , option
+ []
+ ["null-sep"]
+ "Separate the source files with NUL bytes rather than newlines."
+ sdistNulSeparated
+ (\v flags -> flags{sdistNulSeparated = v})
+ trueArg
+ , option
+ ['o']
+ ["output-directory", "outputdir"]
+ "Choose the output directory of this command. '-' sends all output to stdout"
+ sdistOutputPath
+ (\o flags -> flags{sdistOutputPath = o})
+ (reqArg "PATH" (succeedReadE Flag) flagToList)
+ ]
-------------------------------------------------------------------------------
-- Action
@@ -138,64 +218,69 @@ sdistOptions showOrParseArgs =
sdistAction :: (ProjectFlags, SdistFlags) -> [String] -> GlobalFlags -> IO ()
sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
- (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject
-
- let localPkgs = localPackages baseCtx
-
- targetSelectors <- either (reportTargetSelectorProblems verbosity) return
- =<< readTargetSelectors localPkgs Nothing targetStrings
-
- -- elaborate path, create target directory
- mOutputPath' <- case mOutputPath of
- Just "-" -> return (Just "-")
- Just path -> do
- abspath <- makeAbsolute path
- createDirectoryIfMissing True abspath
- return (Just abspath)
- Nothing -> do
- createDirectoryIfMissing True (distSdistDirectory distDirLayout)
- return Nothing
-
- let format :: OutputFormat
- format =
- if | listSources, nulSeparated -> SourceList '\0'
- | listSources -> SourceList '\n'
- | otherwise -> TarGzArchive
-
- ext = case format of
- SourceList _ -> "list"
- TarGzArchive -> "tar.gz"
-
- outputPath pkg = case mOutputPath' of
- Just path
- | path == "-" -> "-"
- | otherwise -> path </> prettyShow (packageId pkg) <.> ext
- Nothing
- | listSources -> "-"
- | otherwise -> distSdistFile distDirLayout (packageId pkg)
-
-
- case reifyTargetSelectors localPkgs targetSelectors of
- Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs
- Right pkgs
- | length pkgs > 1, not listSources, Just "-" <- mOutputPath' ->
- die' verbosity "Can't write multiple tarballs to standard output!"
- | otherwise ->
- traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs
+ (baseCtx, distDirLayout) <- withProjectOrGlobalConfig verbosity flagIgnoreProject globalConfigFlag withProject withoutProject
+
+ let localPkgs = localPackages baseCtx
+
+ targetSelectors <-
+ either (reportTargetSelectorProblems verbosity) return
+ =<< readTargetSelectors localPkgs Nothing targetStrings
+
+ -- elaborate path, create target directory
+ mOutputPath' <- case mOutputPath of
+ Just "-" -> return (Just "-")
+ Just path -> do
+ abspath <- makeAbsolute path
+ createDirectoryIfMissing True abspath
+ return (Just abspath)
+ Nothing -> do
+ createDirectoryIfMissing True (distSdistDirectory distDirLayout)
+ return Nothing
+
+ let format :: OutputFormat
+ format =
+ if
+ | listSources, nulSeparated -> SourceList '\0'
+ | listSources -> SourceList '\n'
+ | otherwise -> TarGzArchive
+
+ ext = case format of
+ SourceList _ -> "list"
+ TarGzArchive -> "tar.gz"
+
+ outputPath pkg = case mOutputPath' of
+ Just path
+ | path == "-" -> "-"
+ | otherwise -> path </> prettyShow (packageId pkg) <.> ext
+ Nothing
+ | listSources -> "-"
+ | otherwise -> distSdistFile distDirLayout (packageId pkg)
+
+ case reifyTargetSelectors localPkgs targetSelectors of
+ Left errs -> die' verbosity . unlines . fmap renderTargetProblem $ errs
+ Right pkgs
+ | length pkgs > 1
+ , not listSources
+ , Just "-" <- mOutputPath' ->
+ die' verbosity "Can't write multiple tarballs to standard output!"
+ | otherwise ->
+ traverse_ (\pkg -> packageToSdist verbosity (distProjectRootDirectory distDirLayout) format (outputPath pkg) pkg) pkgs
where
- verbosity = fromFlagOrDefault normal sdistVerbosity
- listSources = fromFlagOrDefault False sdistListSources
- nulSeparated = fromFlagOrDefault False sdistNulSeparated
- mOutputPath = flagToMaybe sdistOutputPath
+ verbosity = fromFlagOrDefault normal sdistVerbosity
+ listSources = fromFlagOrDefault False sdistListSources
+ nulSeparated = fromFlagOrDefault False sdistNulSeparated
+ mOutputPath = flagToMaybe sdistOutputPath
prjConfig :: ProjectConfig
- prjConfig = commandLineFlagsToProjectConfig
+ prjConfig =
+ commandLineFlagsToProjectConfig
globalFlags
(defaultNixStyleFlags ())
- { configFlags = (configFlags $ defaultNixStyleFlags ())
- { configVerbosity = sdistVerbosity
- , configDistPref = sdistDistDir
- }
+ { configFlags =
+ (configFlags $ defaultNixStyleFlags ())
+ { configVerbosity = sdistVerbosity
+ , configDistPref = sdistDistDir
+ }
, projectFlags = pf
}
mempty
@@ -204,113 +289,117 @@ sdistAction (pf@ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
withProject :: IO (ProjectBaseContext, DistDirLayout)
withProject = do
- baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand
- return (baseCtx, distDirLayout baseCtx)
+ baseCtx <- establishProjectBaseContext verbosity prjConfig OtherCommand
+ return (baseCtx, distDirLayout baseCtx)
withoutProject :: ProjectConfig -> IO (ProjectBaseContext, DistDirLayout)
withoutProject config = do
- cwd <- getCurrentDirectory
- baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand
- return (baseCtx, distDirLayout baseCtx)
+ cwd <- getCurrentDirectory
+ baseCtx <- establishProjectBaseContextWithRoot verbosity (config <> prjConfig) (ProjectRootImplicit cwd) OtherCommand
+ return (baseCtx, distDirLayout baseCtx)
-data OutputFormat = SourceList Char
- | TarGzArchive
- deriving (Show, Eq)
+data OutputFormat
+ = SourceList Char
+ | TarGzArchive
+ deriving (Show, Eq)
packageToSdist :: Verbosity -> FilePath -> OutputFormat -> FilePath -> UnresolvedSourcePackage -> IO ()
packageToSdist verbosity projectRootDir format outputFile pkg = do
- let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))
- dir0 <- case srcpkgSource pkg of
- LocalUnpackedPackage path -> pure (Right path)
- RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz)
- RemoteSourceRepoPackage {} -> death
- LocalTarballPackage tgz -> pure (Left tgz)
- RemoteTarballPackage _ (Just tgz) -> pure (Left tgz)
- RemoteTarballPackage {} -> death
- RepoTarballPackage {} -> death
-
- let -- Write String to stdout or file, using the default TextEncoding.
- write str
- | outputFile == "-" = putStr (withOutputMarker verbosity str)
- | otherwise = do
- writeFile outputFile str
- notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
- -- Write raw ByteString to stdout or file as it is, without encoding.
- writeLBS lbs
- | outputFile == "-" = BSL.putStr lbs
- | otherwise = do
- BSL.writeFile outputFile lbs
- notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
-
- case dir0 of
- Left tgz -> do
- case format of
- TarGzArchive -> do
- writeLBS =<< BSL.readFile tgz
- _ -> die' verbosity ("cannot convert tarball package to " ++ show format)
-
- Right dir -> case format of
- SourceList nulSep -> do
- let gpd :: GenericPackageDescription
- gpd = srcpkgDescription pkg
-
- let thisDie :: Verbosity -> String -> IO a
- thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
-
- files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers
- let files = nub $ sort $ map normalise files'
- let prefix = makeRelative projectRootDir dir
- write $ concat [prefix </> i ++ [nulSep] | i <- files]
-
+ let death = die' verbosity ("The impossible happened: a local package isn't local" <> (show pkg))
+ dir0 <- case srcpkgSource pkg of
+ LocalUnpackedPackage path -> pure (Right path)
+ RemoteSourceRepoPackage _ (Just tgz) -> pure (Left tgz)
+ RemoteSourceRepoPackage{} -> death
+ LocalTarballPackage tgz -> pure (Left tgz)
+ RemoteTarballPackage _ (Just tgz) -> pure (Left tgz)
+ RemoteTarballPackage{} -> death
+ RepoTarballPackage{} -> death
+
+ let
+ -- Write String to stdout or file, using the default TextEncoding.
+ write str
+ | outputFile == "-" = putStr (withOutputMarker verbosity str)
+ | otherwise = do
+ writeFile outputFile str
+ notice verbosity $ "Wrote source list to " ++ outputFile ++ "\n"
+ -- Write raw ByteString to stdout or file as it is, without encoding.
+ writeLBS lbs
+ | outputFile == "-" = BSL.putStr lbs
+ | otherwise = do
+ BSL.writeFile outputFile lbs
+ notice verbosity $ "Wrote tarball sdist to " ++ outputFile ++ "\n"
+
+ case dir0 of
+ Left tgz -> do
+ case format of
TarGzArchive -> do
- packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS
+ writeLBS =<< BSL.readFile tgz
+ _ -> die' verbosity ("cannot convert tarball package to " ++ show format)
+ Right dir -> case format of
+ SourceList nulSep -> do
+ let gpd :: GenericPackageDescription
+ gpd = srcpkgDescription pkg
+
+ let thisDie :: Verbosity -> String -> IO a
+ thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
+
+ files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers
+ let files = nub $ sort $ map normalise files'
+ let prefix = makeRelative projectRootDir dir
+ write $ concat [prefix </> i ++ [nulSep] | i <- files]
+ TarGzArchive -> do
+ packageDirToSdist verbosity (srcpkgDescription pkg) dir >>= writeLBS
--
reifyTargetSelectors :: [PackageSpecifier UnresolvedSourcePackage] -> [TargetSelector] -> Either [TargetProblem] [UnresolvedSourcePackage]
reifyTargetSelectors pkgs sels =
- case partitionEithers (foldMap go sels) of
- ([], sels') -> Right sels'
- (errs, _) -> Left errs
- where
- -- there can be pkgs which are in extra-packages:
- -- these are not SpecificSourcePackage
- --
- -- Why these packages are in localPkgs, it's confusing.
- -- Anyhow, better to be lenient here.
- --
- flatten (SpecificSourcePackage pkg@SourcePackage{}) = Just pkg
- flatten _ = Nothing
-
- pkgs' = mapMaybe flatten pkgs
-
- getPkg pid = case find ((== pid) . packageId) pkgs' of
- Just pkg -> Right pkg
- Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages."
-
- go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
- go (TargetPackage _ pids Nothing) = fmap getPkg pids
- go (TargetAllPackages Nothing) = Right <$> pkgs'
-
- go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)]
- go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)]
-
- go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)]
- go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)]
-
- go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)]
-
-data TargetProblem = AllComponentsOnly ComponentKind
- | NonlocalPackageNotAllowed PackageName
- | ComponentsNotAllowed ComponentName
+ case partitionEithers (foldMap go sels) of
+ ([], sels') -> Right sels'
+ (errs, _) -> Left errs
+ where
+ -- there can be pkgs which are in extra-packages:
+ -- these are not SpecificSourcePackage
+ --
+ -- Why these packages are in localPkgs, it's confusing.
+ -- Anyhow, better to be lenient here.
+ --
+ flatten (SpecificSourcePackage pkg@SourcePackage{}) = Just pkg
+ flatten _ = Nothing
+
+ pkgs' = mapMaybe flatten pkgs
+
+ getPkg pid = case find ((== pid) . packageId) pkgs' of
+ Just pkg -> Right pkg
+ Nothing -> error "The impossible happened: we have a reference to a local package that isn't in localPackages."
+
+ go :: TargetSelector -> [Either TargetProblem UnresolvedSourcePackage]
+ go (TargetPackage _ pids Nothing) = fmap getPkg pids
+ go (TargetAllPackages Nothing) = Right <$> pkgs'
+ go (TargetPackage _ _ (Just kind)) = [Left (AllComponentsOnly kind)]
+ go (TargetAllPackages (Just kind)) = [Left (AllComponentsOnly kind)]
+ go (TargetPackageNamed pname _) = [Left (NonlocalPackageNotAllowed pname)]
+ go (TargetComponentUnknown pname _ _) = [Left (NonlocalPackageNotAllowed pname)]
+ go (TargetComponent _ cname _) = [Left (ComponentsNotAllowed cname)]
+
+data TargetProblem
+ = AllComponentsOnly ComponentKind
+ | NonlocalPackageNotAllowed PackageName
+ | ComponentsNotAllowed ComponentName
renderTargetProblem :: TargetProblem -> String
renderTargetProblem (AllComponentsOnly kind) =
- "It is not possible to package only the " ++ renderComponentKind Plural kind ++ " from a package "
+ "It is not possible to package only the "
+ ++ renderComponentKind Plural kind
+ ++ " from a package "
++ "for distribution. Only entire packages may be packaged for distribution."
renderTargetProblem (ComponentsNotAllowed cname) =
- "The component " ++ showComponentName cname ++ " cannot be packaged for distribution on its own. "
+ "The component "
+ ++ showComponentName cname
+ ++ " cannot be packaged for distribution on its own. "
++ "Only entire packages may be packaged for distribution."
renderTargetProblem (NonlocalPackageNotAllowed pname) =
- "The package " ++ unPackageName pname ++ " cannot be packaged for distribution, because it is not "
+ "The package "
+ ++ unPackageName pname
+ ++ " cannot be packaged for distribution, because it is not "
++ "local to this project."
diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs
index dd5f0915eca4db43ae19df81cd3b945758ccb2b4..96a8fdc5ceaed093144b9734fbb936fe2f40382f 100644
--- a/cabal-install/src/Distribution/Client/CmdTest.hs
+++ b/cabal-install/src/Distribution/Client/CmdTest.hs
@@ -1,89 +1,115 @@
{-# LANGUAGE RecordWildCards #-}
-- | cabal-install CLI command: test
---
-module Distribution.Client.CmdTest (
- -- * The @test@ CLI and action
- testCommand,
- testAction,
+module Distribution.Client.CmdTest
+ ( -- * The @test@ CLI and action
+ testCommand
+ , testAction
-- * Internals exposed for testing
- isSubComponentProblem,
- notTestProblem,
- noTestsProblem,
- selectPackageTargets,
- selectComponentTarget
+ , isSubComponentProblem
+ , notTestProblem
+ , noTestsProblem
+ , selectPackageTargets
+ , selectComponentTarget
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.ProjectOrchestration
import Distribution.Client.CmdErrorMessages
- ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural,
- renderTargetProblem,
- renderTargetProblemNoTargets, targetSelectorPluralPkgs )
-import Distribution.Client.TargetProblem
- ( TargetProblem (..) )
+ ( plural
+ , renderTargetProblem
+ , renderTargetProblemNoTargets
+ , renderTargetSelector
+ , showTargetSelector
+ , targetSelectorFilter
+ , targetSelectorPluralPkgs
+ )
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
+import Distribution.Client.ProjectOrchestration
import Distribution.Client.Setup
- ( GlobalFlags(..), ConfigFlags(..) )
+ ( ConfigFlags (..)
+ , GlobalFlags (..)
+ )
+import Distribution.Client.TargetProblem
+ ( TargetProblem (..)
+ )
import Distribution.Client.Utils
- ( giveRTSWarning )
-import Distribution.Simple.Setup
- ( TestFlags(..), fromFlagOrDefault )
+ ( giveRTSWarning
+ )
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives )
+ ( CommandUI (..)
+ , usageAlternatives
+ )
import Distribution.Simple.Flag
- ( Flag(..) )
-import Distribution.Verbosity
- ( normal )
+ ( Flag (..)
+ )
+import Distribution.Simple.Setup
+ ( TestFlags (..)
+ , fromFlagOrDefault
+ )
import Distribution.Simple.Utils
- ( notice, wrapText, die', warn )
+ ( die'
+ , notice
+ , warn
+ , wrapText
+ )
+import Distribution.Verbosity
+ ( normal
+ )
import qualified System.Exit (exitSuccess)
import GHC.Environment
- ( getFullArgs )
+ ( getFullArgs
+ )
testCommand :: CommandUI (NixStyleFlags ())
-testCommand = CommandUI
- { commandName = "v2-test"
- , commandSynopsis = "Run test-suites."
- , commandUsage = usageAlternatives "v2-test" [ "[TARGETS] [FLAGS]" ]
- , commandDescription = Just $ \_ -> wrapText $
- "Runs the specified test-suites, first ensuring they are up to "
- ++ "date.\n\n"
-
- ++ "Any test-suite in any package in the project can be specified. "
- ++ "A package can be specified in which case all the test-suites in the "
- ++ "package are run. The default is to run all the test-suites in the "
- ++ "package in the current directory.\n\n"
-
- ++ "Dependencies are built or rebuilt as necessary. Additional "
- ++ "configuration flags can be specified on the command line and these "
- ++ "extend the project configuration from the 'cabal.project', "
- ++ "'cabal.project.local' and other files.\n\n"
-
- ++ "To pass command-line arguments to a test suite, see the "
- ++ "v2-run command."
- , commandNotes = Just $ \pname ->
+testCommand =
+ CommandUI
+ { commandName = "v2-test"
+ , commandSynopsis = "Run test-suites."
+ , commandUsage = usageAlternatives "v2-test" ["[TARGETS] [FLAGS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Runs the specified test-suites, first ensuring they are up to "
+ ++ "date.\n\n"
+ ++ "Any test-suite in any package in the project can be specified. "
+ ++ "A package can be specified in which case all the test-suites in the "
+ ++ "package are run. The default is to run all the test-suites in the "
+ ++ "package in the current directory.\n\n"
+ ++ "Dependencies are built or rebuilt as necessary. Additional "
+ ++ "configuration flags can be specified on the command line and these "
+ ++ "extend the project configuration from the 'cabal.project', "
+ ++ "'cabal.project.local' and other files.\n\n"
+ ++ "To pass command-line arguments to a test suite, see the "
+ ++ "v2-run command."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v2-test\n"
- ++ " Run all the test-suites in the package in the current directory\n"
- ++ " " ++ pname ++ " v2-test pkgname\n"
- ++ " Run all the test-suites in the package named pkgname\n"
- ++ " " ++ pname ++ " v2-test cname\n"
- ++ " Run the test-suite named cname\n"
- ++ " " ++ pname ++ " v2-test cname --enable-coverage\n"
- ++ " Run the test-suite built with code coverage (including local libs used)\n"
-
- , commandDefaultFlags = defaultNixStyleFlags ()
- , commandOptions = nixStyleOptions (const [])
- }
-
-
+ ++ " "
+ ++ pname
+ ++ " v2-test\n"
+ ++ " Run all the test-suites in the package in the current directory\n"
+ ++ " "
+ ++ pname
+ ++ " v2-test pkgname\n"
+ ++ " Run all the test-suites in the package named pkgname\n"
+ ++ " "
+ ++ pname
+ ++ " v2-test cname\n"
+ ++ " Run the test-suite named cname\n"
+ ++ " "
+ ++ pname
+ ++ " v2-test cname --enable-coverage\n"
+ ++ " Run the test-suite built with code coverage (including local libs used)\n"
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ , commandOptions = nixStyleOptions (const [])
+ }
-- | The @test@ command is very much like @build@. It brings the install plan
-- up to date, selects that part of the plan needed by the given or implicit
@@ -94,48 +120,49 @@ testCommand = CommandUI
--
-- For more details on how this works, see the module
-- "Distribution.Client.ProjectOrchestration"
---
testAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-testAction flags@NixStyleFlags {..} targetStrings globalFlags = do
-
- baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
-
- targetSelectors <- either (reportTargetSelectorProblems verbosity) return
- =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings
-
- buildCtx <-
- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
-
- when (buildSettingOnlyDeps (buildSettings baseCtx)) $
- die' verbosity $
- "The test command does not support '--only-dependencies'. "
- ++ "You may wish to use 'build --only-dependencies' and then "
- ++ "use 'test'."
-
- fullArgs <- getFullArgs
- when ("+RTS" `elem` fullArgs) $
- warn verbosity $ giveRTSWarning "test"
-
- -- Interpret the targets on the command line as test targets
- -- (as opposed to say build or haddock targets).
- targets <- either (reportTargetProblems verbosity failWhenNoTestSuites) return
- $ resolveTargets
- selectPackageTargets
- selectComponentTarget
- elaboratedPlan
- Nothing
- targetSelectors
-
- let elaboratedPlan' = pruneInstallPlanToTargets
- TargetActionTest
- targets
- elaboratedPlan
- return (elaboratedPlan', targets)
-
- printPlan verbosity baseCtx buildCtx
-
- buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
- runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
+testAction flags@NixStyleFlags{..} targetStrings globalFlags = do
+ baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
+
+ targetSelectors <-
+ either (reportTargetSelectorProblems verbosity) return
+ =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings
+
+ buildCtx <-
+ runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
+ when (buildSettingOnlyDeps (buildSettings baseCtx)) $
+ die' verbosity $
+ "The test command does not support '--only-dependencies'. "
+ ++ "You may wish to use 'build --only-dependencies' and then "
+ ++ "use 'test'."
+
+ fullArgs <- getFullArgs
+ when ("+RTS" `elem` fullArgs) $
+ warn verbosity $
+ giveRTSWarning "test"
+
+ -- Interpret the targets on the command line as test targets
+ -- (as opposed to say build or haddock targets).
+ targets <-
+ either (reportTargetProblems verbosity failWhenNoTestSuites) return $
+ resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ elaboratedPlan
+ Nothing
+ targetSelectors
+
+ let elaboratedPlan' =
+ pruneInstallPlanToTargets
+ TargetActionTest
+ targets
+ elaboratedPlan
+ return (elaboratedPlan', targets)
+
+ printPlan verbosity baseCtx buildCtx
+
+ buildOutcomes <- runProjectBuildPhase verbosity baseCtx buildCtx
+ runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
where
failWhenNoTestSuites = testFailWhenNoTestSuites testFlags
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
@@ -147,77 +174,74 @@ testAction flags@NixStyleFlags {..} targetStrings globalFlags = do
--
-- For the @test@ command we select all buildable test-suites,
-- or fail if there are no test-suites or no buildable test-suites.
---
-selectPackageTargets :: TargetSelector
- -> [AvailableTarget k] -> Either TestTargetProblem [k]
+selectPackageTargets
+ :: TargetSelector
+ -> [AvailableTarget k]
+ -> Either TestTargetProblem [k]
selectPackageTargets targetSelector targets
-
- -- If there are any buildable test-suite targets then we select those
- | not (null targetsTestsBuildable)
- = Right targetsTestsBuildable
-
- -- If there are test-suites but none are buildable then we report those
- | not (null targetsTests)
- = Left (TargetProblemNoneEnabled targetSelector targetsTests)
-
- -- If there are no test-suite but some other targets then we report that
- | not (null targets)
- = Left (noTestsProblem targetSelector)
-
- -- If there are no targets at all then we report that
- | otherwise
- = Left (TargetProblemNoTargets targetSelector)
+ -- If there are any buildable test-suite targets then we select those
+ | not (null targetsTestsBuildable) =
+ Right targetsTestsBuildable
+ -- If there are test-suites but none are buildable then we report those
+ | not (null targetsTests) =
+ Left (TargetProblemNoneEnabled targetSelector targetsTests)
+ -- If there are no test-suite but some other targets then we report that
+ | not (null targets) =
+ Left (noTestsProblem targetSelector)
+ -- If there are no targets at all then we report that
+ | otherwise =
+ Left (TargetProblemNoTargets targetSelector)
where
- targetsTestsBuildable = selectBuildableTargets
- . filterTargetsKind TestKind
- $ targets
-
- targetsTests = forgetTargetsDetail
- . filterTargetsKind TestKind
- $ targets
+ targetsTestsBuildable =
+ selectBuildableTargets
+ . filterTargetsKind TestKind
+ $ targets
+ targetsTests =
+ forgetTargetsDetail
+ . filterTargetsKind TestKind
+ $ targets
-- | For a 'TargetComponent' 'TargetSelector', check if the component can be
-- selected.
--
-- For the @test@ command we just need to check it is a test-suite, in addition
-- to the basic checks on being buildable etc.
---
-selectComponentTarget :: SubComponentTarget
- -> AvailableTarget k -> Either TestTargetProblem k
+selectComponentTarget
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either TestTargetProblem k
selectComponentTarget subtarget@WholeComponent t
- | CTestName _ <- availableTargetComponentName t
- = either Left return $
- selectComponentTargetBasic subtarget t
- | otherwise
- = Left (notTestProblem
- (availableTargetPackageId t)
- (availableTargetComponentName t))
-
-selectComponentTarget subtarget t
- = Left (isSubComponentProblem
- (availableTargetPackageId t)
- (availableTargetComponentName t)
- subtarget)
+ | CTestName _ <- availableTargetComponentName t =
+ either Left return $
+ selectComponentTargetBasic subtarget t
+ | otherwise =
+ Left
+ ( notTestProblem
+ (availableTargetPackageId t)
+ (availableTargetComponentName t)
+ )
+selectComponentTarget subtarget t =
+ Left
+ ( isSubComponentProblem
+ (availableTargetPackageId t)
+ (availableTargetComponentName t)
+ subtarget
+ )
-- | The various error conditions that can occur when matching a
-- 'TargetSelector' against 'AvailableTarget's for the @test@ command.
---
-data TestProblem =
- -- | The 'TargetSelector' matches targets but no test-suites
- TargetProblemNoTests TargetSelector
-
- -- | The 'TargetSelector' refers to a component that is not a test-suite
- | TargetProblemComponentNotTest PackageId ComponentName
-
- -- | Asking to test an individual file or module is not supported
- | TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
+data TestProblem
+ = -- | The 'TargetSelector' matches targets but no test-suites
+ TargetProblemNoTests TargetSelector
+ | -- | The 'TargetSelector' refers to a component that is not a test-suite
+ TargetProblemComponentNotTest PackageId ComponentName
+ | -- | Asking to test an individual file or module is not supported
+ TargetProblemIsSubComponent PackageId ComponentName SubComponentTarget
deriving (Eq, Show)
-
type TestTargetProblem = TargetProblem TestProblem
-
noTestsProblem :: TargetSelector -> TargetProblem TestProblem
noTestsProblem = CustomTargetProblem . TargetProblemNoTests
@@ -229,8 +253,9 @@ isSubComponentProblem
-> ComponentName
-> SubComponentTarget
-> TargetProblem TestProblem
-isSubComponentProblem pkgid name subcomponent = CustomTargetProblem $
- TargetProblemIsSubComponent pkgid name subcomponent
+isSubComponentProblem pkgid name subcomponent =
+ CustomTargetProblem $
+ TargetProblemIsSubComponent pkgid name subcomponent
reportTargetProblems :: Verbosity -> Flag Bool -> [TestTargetProblem] -> IO a
reportTargetProblems verbosity failWhenNoTestSuites problems =
@@ -241,8 +266,8 @@ reportTargetProblems verbosity failWhenNoTestSuites problems =
notice verbosity (renderAllowedNoTestsProblem selector)
System.Exit.exitSuccess
(_, _) -> die' verbosity problemsMessage
- where
- problemsMessage = unlines . map renderTestTargetProblem $ problems
+ where
+ problemsMessage = unlines . map renderTestTargetProblem $ problems
-- | Unless @--test-fail-when-no-test-suites@ flag is passed, we don't
-- @die@ when the target problem is 'TargetProblemNoTests'.
@@ -250,42 +275,49 @@ reportTargetProblems verbosity failWhenNoTestSuites problems =
-- indicate how this behaviour was enabled.
renderAllowedNoTestsProblem :: TargetSelector -> String
renderAllowedNoTestsProblem selector =
- "No tests to run for " ++ renderTargetSelector selector
+ "No tests to run for " ++ renderTargetSelector selector
renderTestTargetProblem :: TestTargetProblem -> String
renderTestTargetProblem (TargetProblemNoTargets targetSelector) =
- case targetSelectorFilter targetSelector of
- Just kind | kind /= TestKind
- -> "The test command is for running test suites, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
- ++ "\n" ++ show targetSelector
-
- _ -> renderTargetProblemNoTargets "test" targetSelector
+ case targetSelectorFilter targetSelector of
+ Just kind
+ | kind /= TestKind ->
+ "The test command is for running test suites, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
+ ++ "\n"
+ ++ show targetSelector
+ _ -> renderTargetProblemNoTargets "test" targetSelector
renderTestTargetProblem problem =
- renderTargetProblem "test" renderTestProblem problem
-
+ renderTargetProblem "test" renderTestProblem problem
renderTestProblem :: TestProblem -> String
renderTestProblem (TargetProblemNoTests targetSelector) =
- "Cannot run tests for the target '" ++ showTargetSelector targetSelector
- ++ "' which refers to " ++ renderTargetSelector targetSelector
- ++ " because "
- ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
- ++ " not contain any test suites."
-
+ "Cannot run tests for the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' which refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " because "
+ ++ plural (targetSelectorPluralPkgs targetSelector) "it does" "they do"
+ ++ " not contain any test suites."
renderTestProblem (TargetProblemComponentNotTest pkgid cname) =
- "The test command is for running test suites, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ " from the package "
- ++ prettyShow pkgid ++ "."
+ "The test command is for running test suites, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ " from the package "
+ ++ prettyShow pkgid
+ ++ "."
where
targetSelector = TargetComponent pkgid cname WholeComponent
-
renderTestProblem (TargetProblemIsSubComponent pkgid cname subtarget) =
- "The test command can only run test suites as a whole, "
- ++ "not files or modules within them, but the target '"
- ++ showTargetSelector targetSelector ++ "' refers to "
- ++ renderTargetSelector targetSelector ++ "."
+ "The test command can only run test suites as a whole, "
+ ++ "not files or modules within them, but the target '"
+ ++ showTargetSelector targetSelector
+ ++ "' refers to "
+ ++ renderTargetSelector targetSelector
+ ++ "."
where
targetSelector = TargetComponent pkgid cname subtarget
diff --git a/cabal-install/src/Distribution/Client/CmdUpdate.hs b/cabal-install/src/Distribution/Client/CmdUpdate.hs
index f066788ec6377242a5936b94c0949c6cd23fa659..4ccd53ff286693f35171b7b7efb45090065a7e96 100644
--- a/cabal-install/src/Distribution/Client/CmdUpdate.hs
+++ b/cabal-install/src/Distribution/Client/CmdUpdate.hs
@@ -1,196 +1,262 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
-- | cabal-install CLI command: update
---
-module Distribution.Client.CmdUpdate (
- updateCommand,
- updateAction,
+module Distribution.Client.CmdUpdate
+ ( updateCommand
+ , updateAction
) where
-import Prelude ()
import Control.Exception
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
import Distribution.Client.Compat.Directory
- ( setModificationTime )
-import Distribution.Client.ProjectOrchestration
-import Distribution.Client.ProjectConfig
- ( ProjectConfig(..)
- , ProjectConfigShared(projectConfigConfigFile)
- , projectConfigWithSolverRepoContext
- , withProjectOrGlobalConfig )
-import Distribution.Client.ProjectFlags
- ( ProjectFlags (..) )
-import Distribution.Client.Types
- ( Repo(..), RepoName (..), unRepoName, RemoteRepo(..), repoName )
-import Distribution.Client.HttpUtils
- ( DownloadResult(..) )
+ ( setModificationTime
+ )
import Distribution.Client.FetchUtils
- ( downloadIndex )
+ ( downloadIndex
+ )
+import Distribution.Client.HttpUtils
+ ( DownloadResult (..)
+ )
+import Distribution.Client.IndexUtils
+ ( Index (..)
+ , currentIndexTimestamp
+ , indexBaseName
+ , updatePackageIndexCacheFile
+ , updateRepoIndexCache
+ , writeIndexTimestamp
+ )
+import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.JobControl
- ( newParallelJobControl, spawnJob, collectJob )
+ ( collectJob
+ , newParallelJobControl
+ , spawnJob
+ )
+import Distribution.Client.NixStyleOptions
+ ( NixStyleFlags (..)
+ , defaultNixStyleFlags
+ , nixStyleOptions
+ )
+import Distribution.Client.ProjectConfig
+ ( ProjectConfig (..)
+ , ProjectConfigShared (projectConfigConfigFile)
+ , projectConfigWithSolverRepoContext
+ , withProjectOrGlobalConfig
+ )
+import Distribution.Client.ProjectFlags
+ ( ProjectFlags (..)
+ )
+import Distribution.Client.ProjectOrchestration
import Distribution.Client.Setup
- ( GlobalFlags, ConfigFlags(..)
- , UpdateFlags, defaultUpdateFlags
- , RepoContext(..) )
+ ( ConfigFlags (..)
+ , GlobalFlags
+ , RepoContext (..)
+ , UpdateFlags
+ , defaultUpdateFlags
+ )
+import Distribution.Client.Types
+ ( RemoteRepo (..)
+ , Repo (..)
+ , RepoName (..)
+ , repoName
+ , unRepoName
+ )
import Distribution.Simple.Flag
- ( fromFlagOrDefault )
+ ( fromFlagOrDefault
+ )
import Distribution.Simple.Utils
- ( die', notice, wrapText, writeFileAtomic, noticeNoWrap, warn )
+ ( die'
+ , notice
+ , noticeNoWrap
+ , warn
+ , wrapText
+ , writeFileAtomic
+ )
import Distribution.Verbosity
- ( normal, lessVerbose )
-import Distribution.Client.IndexUtils.IndexState
-import Distribution.Client.IndexUtils
- ( updateRepoIndexCache, Index(..), writeIndexTimestamp
- , currentIndexTimestamp, indexBaseName, updatePackageIndexCacheFile )
+ ( lessVerbose
+ , normal
+ )
import qualified Data.Maybe as Unsafe (fromJust)
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-import qualified Data.ByteString.Lazy as BS
-import Distribution.Client.GZipUtils (maybeDecompress)
-import System.FilePath ((<.>), dropExtension)
+import qualified Data.ByteString.Lazy as BS
import Data.Time (getCurrentTime)
+import Distribution.Client.GZipUtils (maybeDecompress)
import Distribution.Simple.Command
- ( CommandUI(..), usageAlternatives )
+ ( CommandUI (..)
+ , usageAlternatives
+ )
+import System.FilePath (dropExtension, (<.>))
-import qualified Hackage.Security.Client as Sec
import Distribution.Client.IndexUtils.Timestamp (nullTimestamp)
+import qualified Hackage.Security.Client as Sec
updateCommand :: CommandUI (NixStyleFlags ())
-updateCommand = CommandUI
- { commandName = "v2-update"
- , commandSynopsis = "Updates list of known packages."
- , commandUsage = usageAlternatives "v2-update" [ "[FLAGS] [REPOS]" ]
- , commandDescription = Just $ \_ -> wrapText $
+updateCommand =
+ CommandUI
+ { commandName = "v2-update"
+ , commandSynopsis = "Updates list of known packages."
+ , commandUsage = usageAlternatives "v2-update" ["[FLAGS] [REPOS]"]
+ , commandDescription = Just $ \_ ->
+ wrapText $
"For all known remote repositories, download the package list."
-
- , commandNotes = Just $ \pname ->
+ , commandNotes = Just $ \pname ->
"REPO has the format <repo-id>[,<index-state>] where index-state follows\n"
- ++ "the same format and syntax that is supported by the --index-state flag.\n\n"
- ++ "Examples:\n"
- ++ " " ++ pname ++ " v2-update\n"
- ++ " Download the package list for all known remote repositories.\n\n"
- ++ " " ++ pname ++ " v2-update hackage.haskell.org,@1474732068\n"
- ++ " " ++ pname ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"
- ++ " " ++ pname ++ " v2-update hackage.haskell.org,HEAD\n"
- ++ " " ++ pname ++ " v2-update hackage.haskell.org\n"
- ++ " Download hackage.haskell.org at a specific index state.\n\n"
- ++ " " ++ pname ++ " v2-update hackage.haskell.org head.hackage\n"
- ++ " Download hackage.haskell.org and head.hackage\n"
- ++ " head.hackage must be a known repo-id. E.g. from\n"
- ++ " your cabal.project(.local) file.\n"
-
- , commandOptions = nixStyleOptions $ const []
- , commandDefaultFlags = defaultNixStyleFlags ()
- }
+ ++ "the same format and syntax that is supported by the --index-state flag.\n\n"
+ ++ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v2-update\n"
+ ++ " Download the package list for all known remote repositories.\n\n"
+ ++ " "
+ ++ pname
+ ++ " v2-update hackage.haskell.org,@1474732068\n"
+ ++ " "
+ ++ pname
+ ++ " v2-update hackage.haskell.org,2016-09-24T17:47:48Z\n"
+ ++ " "
+ ++ pname
+ ++ " v2-update hackage.haskell.org,HEAD\n"
+ ++ " "
+ ++ pname
+ ++ " v2-update hackage.haskell.org\n"
+ ++ " Download hackage.haskell.org at a specific index state.\n\n"
+ ++ " "
+ ++ pname
+ ++ " v2-update hackage.haskell.org head.hackage\n"
+ ++ " Download hackage.haskell.org and head.hackage\n"
+ ++ " head.hackage must be a known repo-id. E.g. from\n"
+ ++ " your cabal.project(.local) file.\n"
+ , commandOptions = nixStyleOptions $ const []
+ , commandDefaultFlags = defaultNixStyleFlags ()
+ }
data UpdateRequest = UpdateRequest
- { _updateRequestRepoName :: RepoName
+ { _updateRequestRepoName :: RepoName
, _updateRequestRepoState :: RepoIndexState
- } deriving (Show)
+ }
+ deriving (Show)
instance Pretty UpdateRequest where
- pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
+ pretty (UpdateRequest n s) = pretty n <<>> Disp.comma <<>> pretty s
instance Parsec UpdateRequest where
parsec = do
- name <- parsec
- state <- P.char ',' *> parsec <|> pure IndexStateHead
- return (UpdateRequest name state)
+ name <- parsec
+ state <- P.char ',' *> parsec <|> pure IndexStateHead
+ return (UpdateRequest name state)
updateAction :: NixStyleFlags () -> [String] -> GlobalFlags -> IO ()
-updateAction flags@NixStyleFlags {..} extraArgs globalFlags = do
+updateAction flags@NixStyleFlags{..} extraArgs globalFlags = do
let ignoreProject = flagIgnoreProject projectFlags
- projectConfig <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag
- (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
- (\globalConfig -> return $ globalConfig <> cliConfig)
+ projectConfig <-
+ withProjectOrGlobalConfig
+ verbosity
+ ignoreProject
+ globalConfigFlag
+ (projectConfig <$> establishProjectBaseContext verbosity cliConfig OtherCommand)
+ (\globalConfig -> return $ globalConfig <> cliConfig)
- projectConfigWithSolverRepoContext verbosity
- (projectConfigShared projectConfig) (projectConfigBuildOnly projectConfig)
+ projectConfigWithSolverRepoContext
+ verbosity
+ (projectConfigShared projectConfig)
+ (projectConfigBuildOnly projectConfig)
$ \repoCtxt -> do
+ let repos :: [Repo]
+ repos = repoContextRepos repoCtxt
- let repos :: [Repo]
- repos = repoContextRepos repoCtxt
-
- parseArg :: String -> IO UpdateRequest
- parseArg s = case simpleParsec s of
- Just r -> return r
- Nothing -> die' verbosity $
- "'v2-update' unable to parse repo: \"" ++ s ++ "\""
-
- updateRepoRequests <- traverse parseArg extraArgs
-
- unless (null updateRepoRequests) $ do
- let remoteRepoNames = map repoName repos
- unknownRepos = [r | (UpdateRequest r _) <- updateRepoRequests
- , not (r `elem` remoteRepoNames)]
- unless (null unknownRepos) $
- die' verbosity $ "'v2-update' repo(s): \""
- ++ intercalate "\", \"" (map unRepoName unknownRepos)
- ++ "\" can not be found in known remote repo(s): "
- ++ intercalate ", " (map unRepoName remoteRepoNames)
-
- let reposToUpdate :: [(Repo, RepoIndexState)]
- reposToUpdate = case updateRepoRequests of
- -- If we are not given any specific repository, update all
- -- repositories to HEAD.
- [] -> map (,IndexStateHead) repos
- updateRequests -> let repoMap = [(repoName r, r) | r <- repos]
- lookup' k = Unsafe.fromJust (lookup k repoMap)
- in [ (lookup' name, state)
- | (UpdateRequest name state) <- updateRequests ]
-
- case reposToUpdate of
- [] ->
- notice verbosity "No remote repositories configured"
- [(remoteRepo, _)] ->
- notice verbosity $ "Downloading the latest package list from "
- ++ unRepoName (repoName remoteRepo)
- _ -> notice verbosity . unlines
- $ "Downloading the latest package lists from: "
- : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
+ parseArg :: String -> IO UpdateRequest
+ parseArg s = case simpleParsec s of
+ Just r -> return r
+ Nothing ->
+ die' verbosity $
+ "'v2-update' unable to parse repo: \"" ++ s ++ "\""
+
+ updateRepoRequests <- traverse parseArg extraArgs
+
+ unless (null updateRepoRequests) $ do
+ let remoteRepoNames = map repoName repos
+ unknownRepos =
+ [ r | (UpdateRequest r _) <- updateRepoRequests, not (r `elem` remoteRepoNames)
+ ]
+ unless (null unknownRepos) $
+ die' verbosity $
+ "'v2-update' repo(s): \""
+ ++ intercalate "\", \"" (map unRepoName unknownRepos)
+ ++ "\" can not be found in known remote repo(s): "
+ ++ intercalate ", " (map unRepoName remoteRepoNames)
- unless (null reposToUpdate) $ do
- jobCtrl <- newParallelJobControl (length reposToUpdate)
- traverse_ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
- reposToUpdate
- traverse_ (\_ -> collectJob jobCtrl) reposToUpdate
+ let reposToUpdate :: [(Repo, RepoIndexState)]
+ reposToUpdate = case updateRepoRequests of
+ -- If we are not given any specific repository, update all
+ -- repositories to HEAD.
+ [] -> map (,IndexStateHead) repos
+ updateRequests ->
+ let repoMap = [(repoName r, r) | r <- repos]
+ lookup' k = Unsafe.fromJust (lookup k repoMap)
+ in [ (lookup' name, state)
+ | (UpdateRequest name state) <- updateRequests
+ ]
+ case reposToUpdate of
+ [] ->
+ notice verbosity "No remote repositories configured"
+ [(remoteRepo, _)] ->
+ notice verbosity $
+ "Downloading the latest package list from "
+ ++ unRepoName (repoName remoteRepo)
+ _ ->
+ notice verbosity . unlines $
+ "Downloading the latest package lists from: "
+ : map (("- " ++) . unRepoName . repoName . fst) reposToUpdate
+
+ unless (null reposToUpdate) $ do
+ jobCtrl <- newParallelJobControl (length reposToUpdate)
+ traverse_
+ (spawnJob jobCtrl . updateRepo verbosity defaultUpdateFlags repoCtxt)
+ reposToUpdate
+ traverse_ (\_ -> collectJob jobCtrl) reposToUpdate
where
verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here
globalConfigFlag = projectConfigConfigFile (projectConfigShared cliConfig)
-updateRepo :: Verbosity -> UpdateFlags -> RepoContext -> (Repo, RepoIndexState)
- -> IO ()
+updateRepo
+ :: Verbosity
+ -> UpdateFlags
+ -> RepoContext
+ -> (Repo, RepoIndexState)
+ -> IO ()
updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
transport <- repoContextGetTransport repoCtxt
case repo of
RepoLocalNoIndex{} -> do
let index = RepoIndex repoCtxt repo
updatePackageIndexCacheFile verbosity index
-
RepoRemote{..} -> do
- downloadResult <- downloadIndex transport verbosity
- repoRemote repoLocalDir
+ downloadResult <-
+ downloadIndex
+ transport
+ verbosity
+ repoRemote
+ repoLocalDir
case downloadResult of
FileAlreadyInCache ->
setModificationTime (indexBaseName repo <.> "tar")
- =<< getCurrentTime
+ =<< getCurrentTime
FileDownloaded indexPath -> do
writeFileAtomic (dropExtension indexPath) . maybeDecompress
- =<< BS.readFile indexPath
+ =<< BS.readFile indexPath
updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \repoSecure -> do
let index = RepoIndex repoCtxt repo
@@ -199,9 +265,10 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
-- NB: always update the timestamp, even if we didn't actually
-- download anything
writeIndexTimestamp index indexState
- ce <- if repoContextIgnoreExpiry repoCtxt
- then Just `fmap` getCurrentTime
- else return Nothing
+ ce <-
+ if repoContextIgnoreExpiry repoCtxt
+ then Just `fmap` getCurrentTime
+ else return Nothing
updated <- Sec.uncheckClientErrors $ Sec.checkForUpdates repoSecure ce
-- this resolves indexState (which could be HEAD) into a timestamp
new_ts <- currentIndexTimestamp (lessVerbose verbosity) repoCtxt repo
@@ -210,13 +277,12 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
-- Update cabal's internal index as well so that it's not out of sync
-- (If all access to the cache goes through hackage-security this can go)
case updated of
- Sec.NoUpdates -> do
+ Sec.NoUpdates -> do
now <- getCurrentTime
- setModificationTime (indexBaseName repo <.> "tar") now `catchIO`
- (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e)
+ setModificationTime (indexBaseName repo <.> "tar") now
+ `catchIO` (\e -> warn verbosity $ "Could not set modification time of index tarball -- " ++ displayException e)
noticeNoWrap verbosity $
"Package list of " ++ prettyShow rname ++ " is up to date."
-
Sec.HasUpdates -> do
updateRepoIndexCache verbosity index
noticeNoWrap verbosity $
@@ -233,5 +299,7 @@ updateRepo verbosity _updateFlags repoCtxt (repo, indexState) = do
-- the user know how to go back to current_ts
when (current_ts /= nullTimestamp && new_ts /= current_ts) $
noticeNoWrap verbosity $
- "To revert to previous state run:\n" ++
- " cabal v2-update '" ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts)) ++ "'\n"
+ "To revert to previous state run:\n"
+ ++ " cabal v2-update '"
+ ++ prettyShow (UpdateRequest rname (IndexStateTime current_ts))
+ ++ "'\n"
diff --git a/cabal-install/src/Distribution/Client/Compat/Directory.hs b/cabal-install/src/Distribution/Client/Compat/Directory.hs
index 3c0997377b8d0ba5ce473410af6032fce811d647..7b44596186daff0612e50fa54a7dba691d1709f4 100644
--- a/cabal-install/src/Distribution/Client/Compat/Directory.hs
+++ b/cabal-install/src/Distribution/Client/Compat/Directory.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE CPP #-}
-module Distribution.Client.Compat.Directory (
- setModificationTime,
- createFileLink,
- pathIsSymbolicLink,
- getSymbolicLinkTarget,
- ) where
+
+module Distribution.Client.Compat.Directory
+ ( setModificationTime
+ , createFileLink
+ , pathIsSymbolicLink
+ , getSymbolicLinkTarget
+ ) where
#if MIN_VERSION_directory(1,2,3)
import System.Directory (setModificationTime)
diff --git a/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs b/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs
index 8a799b6de7d79b46ca033e2fed9afcd9587f41af..e805c110d60a0299608a6c449446115c1a53751e 100644
--- a/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs
+++ b/cabal-install/src/Distribution/Client/Compat/ExecutablePath.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
-- Copied verbatim from base-4.6.0.0. We can't simply import
-- System.Environment.getExecutablePath because we need compatibility with older
-- GHCs.
-module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where
+module Distribution.Client.Compat.ExecutablePath (getExecutablePath) where
import Prelude
@@ -118,6 +118,7 @@ getExecutablePath = readSymbolicLink $ "/proc/self/exe"
--------------------------------------------------------------------------------
-- Windows
+{- FOURMOLU_DISABLE -}
#elif defined(mingw32_HOST_OS)
# if defined(i386_HOST_ARCH)
@@ -164,3 +165,4 @@ getExecutablePath =
--------------------------------------------------------------------------------
#endif
+{- FOURMOLU_ENABLE -}
diff --git a/cabal-install/src/Distribution/Client/Compat/Orphans.hs b/cabal-install/src/Distribution/Client/Compat/Orphans.hs
index aef25787f45f9ec6173b91c7ae1d16e36ce7eec7..4a2e28a10fbc1a4d4df958d882dfb04780091f2a 100644
--- a/cabal-install/src/Distribution/Client/Compat/Orphans.hs
+++ b/cabal-install/src/Distribution/Client/Compat/Orphans.hs
@@ -1,13 +1,14 @@
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module Distribution.Client.Compat.Orphans () where
-import Control.Exception (SomeException)
-import Distribution.Compat.Binary (Binary (..))
-import Distribution.Compat.Typeable (typeRep)
+import Control.Exception (SomeException)
+import Distribution.Compat.Binary (Binary (..))
+import Distribution.Compat.Typeable (typeRep)
import Distribution.Utils.Structured (Structure (Nominal), Structured (..))
-import Network.URI (URI (..), URIAuth (..))
-import Prelude (error, return)
+import Network.URI (URI (..), URIAuth (..))
+import Prelude (error, return)
-------------------------------------------------------------------------------
-- network-uri
@@ -17,25 +18,30 @@ import Prelude (error, return)
-- versions do not, so we use manual Binary instances here
instance Binary URI where
put (URI a b c d e) = do put a; put b; put c; put d; put e
- get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get
- return (URI a b c d e)
+ get = do
+ !a <- get
+ !b <- get
+ !c <- get
+ !d <- get
+ !e <- get
+ return (URI a b c d e)
instance Structured URI where
- structure p = Nominal (typeRep p) 0 "URI" []
+ structure p = Nominal (typeRep p) 0 "URI" []
instance Binary URIAuth where
- put (URIAuth a b c) = do put a; put b; put c
- get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)
+ put (URIAuth a b c) = do put a; put b; put c
+ get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)
-------------------------------------------------------------------------------
-- base
-------------------------------------------------------------------------------
---FIXME: Duncan Coutts: this is a total cheat
---Added in 46aa019ec85e313e257d122a3549cce01996c566
+-- FIXME: Duncan Coutts: this is a total cheat
+-- Added in 46aa019ec85e313e257d122a3549cce01996c566
instance Binary SomeException where
- put _ = return ()
- get = error "cannot serialise exceptions"
+ put _ = return ()
+ get = error "cannot serialise exceptions"
instance Structured SomeException where
- structure p = Nominal (typeRep p) 0 "SomeException" []
+ structure p = Nominal (typeRep p) 0 "SomeException" []
diff --git a/cabal-install/src/Distribution/Client/Compat/Prelude.hs b/cabal-install/src/Distribution/Client/Compat/Prelude.hs
index 38978ef8d3f6a316b866d61e951960fc25456d27..42d048c9b61ad14ce69a0793b7a79e2ac4faf78f 100644
--- a/cabal-install/src/Distribution/Client/Compat/Prelude.hs
+++ b/cabal-install/src/Distribution/Client/Compat/Prelude.hs
@@ -9,7 +9,6 @@
--
-- This module is a superset of "Distribution.Compat.Prelude" (which
-- this module re-exports)
---
module Distribution.Client.Compat.Prelude
( module Distribution.Compat.Prelude.Internal
, module X
@@ -19,6 +18,6 @@ import Distribution.Client.Compat.Orphans ()
import Distribution.Compat.Prelude.Internal
import Prelude ()
-import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec)
-import Distribution.Pretty as X (Pretty (..), prettyShow)
+import Distribution.Parsec as X (CabalParsing, Parsec (..), eitherParsec, explicitEitherParsec, simpleParsec)
+import Distribution.Pretty as X (Pretty (..), prettyShow)
import Distribution.Verbosity as X (Verbosity)
diff --git a/cabal-install/src/Distribution/Client/Compat/Semaphore.hs b/cabal-install/src/Distribution/Client/Compat/Semaphore.hs
index e25442b019c4309b41a4e4b38e30bde9507c05ba..42c398b5c33c8a92c691417de5f1dc50564d3026 100644
--- a/cabal-install/src/Distribution/Client/Compat/Semaphore.hs
+++ b/cabal-install/src/Distribution/Client/Compat/Semaphore.hs
@@ -1,26 +1,32 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
+
module Distribution.Client.Compat.Semaphore
- ( QSem
- , newQSem
- , waitQSem
- , signalQSem
- ) where
+ ( QSem
+ , newQSem
+ , waitQSem
+ , signalQSem
+ ) where
-import Prelude (IO, return, Eq (..), Int, Bool (..), ($), ($!), Num (..), flip)
+import Prelude (Bool (..), Eq (..), IO, Int, Num (..), flip, return, ($), ($!))
-import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,
- writeTVar)
+import Control.Concurrent.STM
+ ( TVar
+ , atomically
+ , newTVar
+ , readTVar
+ , retry
+ , writeTVar
+ )
import Control.Exception (mask_, onException)
import Control.Monad (join, unless)
-import Data.Typeable (Typeable)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
+import Data.Typeable (Typeable)
-- | 'QSem' is a quantity semaphore in which the resource is acquired
-- and released in units of one. It provides guaranteed FIFO ordering
-- for satisfying blocked `waitQSem` calls.
---
data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])
deriving (Eq, Typeable)
@@ -34,18 +40,20 @@ newQSem i = atomically $ do
waitQSem :: QSem -> IO ()
waitQSem s@(QSem q _b1 b2) =
mask_ $ join $ atomically $ do
- -- join, because if we need to block, we have to add a TVar to
- -- the block queue.
- -- mask_, because we need a chance to set up an exception handler
- -- after the join returns.
- v <- readTVar q
- if v == 0
- then do b <- newTVar False
- ys <- readTVar b2
- writeTVar b2 (b:ys)
- return (wait b)
- else do writeTVar q $! v - 1
- return (return ())
+ -- join, because if we need to block, we have to add a TVar to
+ -- the block queue.
+ -- mask_, because we need a chance to set up an exception handler
+ -- after the join returns.
+ v <- readTVar q
+ if v == 0
+ then do
+ b <- newTVar False
+ ys <- readTVar b2
+ writeTVar b2 (b : ys)
+ return (wait b)
+ else do
+ writeTVar q $! v - 1
+ return (return ())
where
--
-- very careful here: if we receive an exception, then we need to
@@ -59,17 +67,18 @@ waitQSem s@(QSem q _b1 b2) =
--
wait t =
flip onException (wake s t) $
- atomically $ do
- b <- readTVar t
- unless b retry
-
+ atomically $ do
+ b <- readTVar t
+ unless b retry
wake :: QSem -> TVar Bool -> IO ()
wake s x = join $ atomically $ do
- b <- readTVar x
- if b then return (signalQSem s)
- else do writeTVar x True
- return (return ())
+ b <- readTVar x
+ if b
+ then return (signalQSem s)
+ else do
+ writeTVar x True
+ return (return ())
{-
property we want:
@@ -82,27 +91,29 @@ wake s x = join $ atomically $ do
signalQSem :: QSem -> IO ()
signalQSem s@(QSem q b1 b2) =
mask_ $ join $ atomically $ do
- -- join, so we don't force the reverse inside the txn
- -- mask_ is needed so we don't lose a wakeup
+ -- join, so we don't force the reverse inside the txn
+ -- mask_ is needed so we don't lose a wakeup
v <- readTVar q
if v /= 0
- then do writeTVar q $! v + 1
- return (return ())
- else do xs <- readTVar b1
- checkwake1 xs
+ then do
+ writeTVar q $! v + 1
+ return (return ())
+ else do
+ xs <- readTVar b1
+ checkwake1 xs
where
checkwake1 [] = do
ys <- readTVar b2
checkwake2 ys
- checkwake1 (x:xs) = do
+ checkwake1 (x : xs) = do
writeTVar b1 xs
return (wake s x)
checkwake2 [] = do
writeTVar q 1
return (return ())
- checkwake2 (y:ys) = do
- let (z:|zs) = NE.reverse (y:|ys)
+ checkwake2 (y : ys) = do
+ let (z :| zs) = NE.reverse (y :| ys)
writeTVar b1 zs
writeTVar b2 []
return (wake s z)
diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs
index df9a5046a30c920507862cb74dfad9b6b588fbb6..51de660808db0c3c0b69e29f68780b4c9276e838 100644
--- a/cabal-install/src/Distribution/Client/Config.hs
+++ b/cabal-install/src/Distribution/Client/Config.hs
@@ -1,6 +1,9 @@
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Config
-- Copyright : (c) David Himmelstrup 2005
@@ -12,185 +15,277 @@
--
-- Utilities for handling saved state such as known packages, known servers and
-- downloaded packages.
------------------------------------------------------------------------------
-module Distribution.Client.Config (
- SavedConfig(..),
- loadConfig,
- getConfigFilePath,
-
- showConfig,
- showConfigWithComments,
- parseConfig,
-
- defaultConfigFile,
- defaultCacheDir,
- defaultScriptBuildsDir,
- defaultStoreDir,
- defaultCompiler,
- defaultInstallPath,
- defaultLogsDir,
- defaultReportsDir,
- defaultUserInstall,
-
- baseSavedConfig,
- commentSavedConfig,
- initialSavedConfig,
- configFieldDescriptions,
- haddockFlagsFields,
- installDirsFields,
- withProgramsFields,
- withProgramOptionsFields,
- userConfigDiff,
- userConfigUpdate,
- createDefaultConfigFile,
-
- remoteRepoFields,
- postProcessRepo,
+module Distribution.Client.Config
+ ( SavedConfig (..)
+ , loadConfig
+ , getConfigFilePath
+ , showConfig
+ , showConfigWithComments
+ , parseConfig
+ , defaultConfigFile
+ , defaultCacheDir
+ , defaultScriptBuildsDir
+ , defaultStoreDir
+ , defaultCompiler
+ , defaultInstallPath
+ , defaultLogsDir
+ , defaultReportsDir
+ , defaultUserInstall
+ , baseSavedConfig
+ , commentSavedConfig
+ , initialSavedConfig
+ , configFieldDescriptions
+ , haddockFlagsFields
+ , installDirsFields
+ , withProgramsFields
+ , withProgramOptionsFields
+ , userConfigDiff
+ , userConfigUpdate
+ , createDefaultConfigFile
+ , remoteRepoFields
+ , postProcessRepo
) where
-import Distribution.Compat.Environment (lookupEnv)
import Distribution.Client.Compat.Prelude
+import Distribution.Compat.Environment (lookupEnv)
import Prelude ()
-import Language.Haskell.Extension ( Language(Haskell2010) )
+import Language.Haskell.Extension (Language (Haskell2010))
import Distribution.Deprecated.ViewAsFieldDescr
- ( viewAsFieldDescr )
+ ( viewAsFieldDescr
+ )
-import Distribution.Client.Types
- ( RemoteRepo(..), LocalRepo (..), emptyRemoteRepo
- , AllowOlder(..), AllowNewer(..), RelaxDeps(..), isRelaxDeps
- , RepoName (..), unRepoName
- )
-import Distribution.Client.Types.Credentials (Username (..), Password (..))
import Distribution.Client.BuildReports.Types
- ( ReportLevel(..) )
-import qualified Distribution.Client.Init.Types as IT
- ( InitFlags(..) )
+ ( ReportLevel (..)
+ )
+import Distribution.Client.CmdInstall.ClientInstallFlags
+ ( ClientInstallFlags (..)
+ , clientInstallOptions
+ , defaultClientInstallFlags
+ )
import qualified Distribution.Client.Init.Defaults as IT
+import qualified Distribution.Client.Init.Types as IT
+ ( InitFlags (..)
+ )
import Distribution.Client.Setup
- ( GlobalFlags(..), globalCommand, defaultGlobalFlags
- , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
- , initOptions
- , InstallFlags(..), installOptions, defaultInstallFlags
- , UploadFlags(..), uploadCommand
- , ReportFlags(..), reportCommand )
-import Distribution.Client.CmdInstall.ClientInstallFlags
- ( ClientInstallFlags(..), defaultClientInstallFlags
- , clientInstallOptions )
+ ( ConfigExFlags (..)
+ , GlobalFlags (..)
+ , InstallFlags (..)
+ , ReportFlags (..)
+ , UploadFlags (..)
+ , configureExOptions
+ , defaultConfigExFlags
+ , defaultGlobalFlags
+ , defaultInstallFlags
+ , globalCommand
+ , initOptions
+ , installOptions
+ , reportCommand
+ , uploadCommand
+ )
+import Distribution.Client.Types
+ ( AllowNewer (..)
+ , AllowOlder (..)
+ , LocalRepo (..)
+ , RelaxDeps (..)
+ , RemoteRepo (..)
+ , RepoName (..)
+ , emptyRemoteRepo
+ , isRelaxDeps
+ , unRepoName
+ )
+import Distribution.Client.Types.Credentials (Password (..), Username (..))
import Distribution.Utils.NubList
- ( NubList, fromNubList, toNubList, overNubList )
+ ( NubList
+ , fromNubList
+ , overNubList
+ , toNubList
+ )
-import Distribution.Simple.Compiler
- ( DebugInfoLevel(..), OptimisationLevel(..) )
-import Distribution.Simple.Setup
- ( ConfigFlags(..), configureOptions, defaultConfigFlags
- , HaddockFlags(..), haddockOptions, defaultHaddockFlags
- , TestFlags(..), defaultTestFlags
- , BenchmarkFlags(..), defaultBenchmarkFlags
- , installDirsOptions, optionDistPref
- , programDbPaths', programDbOptions
- , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault )
-import Distribution.Simple.InstallDirs
- ( InstallDirs(..), defaultInstallDirs
- , PathTemplate, toPathTemplate)
-import Distribution.Deprecated.ParseUtils
- ( FieldDescr(..), liftField, runP
- , ParseResult(..), PError(..), PWarning(..)
- , locatedErrorMsg, showPWarning
- , readFields, warning, lineNo
- , simpleField, listField, spaceListField
- , parseOptCommaList, parseTokenQ, syntaxError
- , simpleFieldParsec, listFieldParsec
- )
-import Distribution.Client.ParseUtils
- ( parseFields, ppFields, ppSection )
import Distribution.Client.HttpUtils
- ( isOldHackageURI )
+ ( isOldHackageURI
+ )
+import Distribution.Client.ParseUtils
+ ( parseFields
+ , ppFields
+ , ppSection
+ )
+import Distribution.Client.ProjectFlags (ProjectFlags (..))
+import Distribution.Client.Version
+ ( cabalInstallVersion
+ )
+import qualified Distribution.Compat.CharParsing as P
+import Distribution.Compiler
+ ( CompilerFlavor (..)
+ , defaultCompilerFlavor
+ )
+import Distribution.Deprecated.ParseUtils
+ ( FieldDescr (..)
+ , PError (..)
+ , PWarning (..)
+ , ParseResult (..)
+ , liftField
+ , lineNo
+ , listField
+ , listFieldParsec
+ , locatedErrorMsg
+ , parseOptCommaList
+ , parseTokenQ
+ , readFields
+ , runP
+ , showPWarning
+ , simpleField
+ , simpleFieldParsec
+ , spaceListField
+ , syntaxError
+ , warning
+ )
import qualified Distribution.Deprecated.ParseUtils as ParseUtils
- ( Field(..) )
+ ( Field (..)
+ )
import Distribution.Simple.Command
- ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) )
+ ( CommandUI (commandOptions)
+ , ShowOrParseArgs (..)
+ , commandDefaultFlags
+ )
+import Distribution.Simple.Compiler
+ ( DebugInfoLevel (..)
+ , OptimisationLevel (..)
+ )
+import Distribution.Simple.InstallDirs
+ ( InstallDirs (..)
+ , PathTemplate
+ , defaultInstallDirs
+ , toPathTemplate
+ )
import Distribution.Simple.Program
- ( defaultProgramDb )
+ ( defaultProgramDb
+ )
+import Distribution.Simple.Setup
+ ( BenchmarkFlags (..)
+ , ConfigFlags (..)
+ , Flag (..)
+ , HaddockFlags (..)
+ , TestFlags (..)
+ , configureOptions
+ , defaultBenchmarkFlags
+ , defaultConfigFlags
+ , defaultHaddockFlags
+ , defaultTestFlags
+ , flagToMaybe
+ , fromFlagOrDefault
+ , haddockOptions
+ , installDirsOptions
+ , optionDistPref
+ , programDbOptions
+ , programDbPaths'
+ , toFlag
+ )
import Distribution.Simple.Utils
- ( die', notice, warn, lowercase, cabalVersion, toUTF8BS )
-import Distribution.Client.Version
- ( cabalInstallVersion )
-import Distribution.Compiler
- ( CompilerFlavor(..), defaultCompilerFlavor )
-import Distribution.Verbosity
- ( normal )
-import qualified Distribution.Compat.CharParsing as P
-import Distribution.Client.ProjectFlags (ProjectFlags (..))
+ ( cabalVersion
+ , die'
+ , lowercase
+ , notice
+ , toUTF8BS
+ , warn
+ )
import Distribution.Solver.Types.ConstraintSource
+import Distribution.Verbosity
+ ( normal
+ )
-import qualified Text.PrettyPrint as Disp
- ( render, text, empty )
-import Distribution.Parsec (parsecOptCommaList, ParsecParser, parsecToken, parsecFilePath)
-import Text.PrettyPrint
- ( ($+$) )
-import Text.PrettyPrint.HughesPJ
- ( text, Doc )
-import System.Directory
- ( createDirectoryIfMissing, getHomeDirectory, getXdgDirectory, XdgDirectory(XdgCache, XdgConfig, XdgState), renameFile, getAppUserDataDirectory, doesDirectoryExist )
+import qualified Data.ByteString as BS
+import qualified Data.Map as M
+import Distribution.Compat.Environment
+ ( getEnvironment
+ )
+import Distribution.Parsec (ParsecParser, parsecFilePath, parsecOptCommaList, parsecToken)
import Network.URI
- ( URI(..), URIAuth(..), parseURI )
+ ( URI (..)
+ , URIAuth (..)
+ , parseURI
+ )
+import System.Directory
+ ( XdgDirectory (XdgCache, XdgConfig, XdgState)
+ , createDirectoryIfMissing
+ , doesDirectoryExist
+ , getAppUserDataDirectory
+ , getHomeDirectory
+ , getXdgDirectory
+ , renameFile
+ )
import System.FilePath
- ( (<.>), (</>), takeDirectory )
+ ( takeDirectory
+ , (<.>)
+ , (</>)
+ )
import System.IO.Error
- ( isDoesNotExistError )
-import Distribution.Compat.Environment
- ( getEnvironment )
-import qualified Data.Map as M
-import qualified Data.ByteString as BS
+ ( isDoesNotExistError
+ )
+import Text.PrettyPrint
+ ( ($+$)
+ )
+import qualified Text.PrettyPrint as Disp
+ ( empty
+ , render
+ , text
+ )
+import Text.PrettyPrint.HughesPJ
+ ( Doc
+ , text
+ )
--
+
-- * Configuration saved in the config file
+
--
data SavedConfig = SavedConfig
- { savedGlobalFlags :: GlobalFlags
- , savedInitFlags :: IT.InitFlags
- , savedInstallFlags :: InstallFlags
- , savedClientInstallFlags :: ClientInstallFlags
- , savedConfigureFlags :: ConfigFlags
- , savedConfigureExFlags :: ConfigExFlags
- , savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
- , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
- , savedUploadFlags :: UploadFlags
- , savedReportFlags :: ReportFlags
- , savedHaddockFlags :: HaddockFlags
- , savedTestFlags :: TestFlags
- , savedBenchmarkFlags :: BenchmarkFlags
- , savedProjectFlags :: ProjectFlags
- } deriving Generic
+ { savedGlobalFlags :: GlobalFlags
+ , savedInitFlags :: IT.InitFlags
+ , savedInstallFlags :: InstallFlags
+ , savedClientInstallFlags :: ClientInstallFlags
+ , savedConfigureFlags :: ConfigFlags
+ , savedConfigureExFlags :: ConfigExFlags
+ , savedUserInstallDirs :: InstallDirs (Flag PathTemplate)
+ , savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate)
+ , savedUploadFlags :: UploadFlags
+ , savedReportFlags :: ReportFlags
+ , savedHaddockFlags :: HaddockFlags
+ , savedTestFlags :: TestFlags
+ , savedBenchmarkFlags :: BenchmarkFlags
+ , savedProjectFlags :: ProjectFlags
+ }
+ deriving (Generic)
instance Monoid SavedConfig where
mempty = gmempty
mappend = (<>)
instance Semigroup SavedConfig where
- a <> b = SavedConfig {
- savedGlobalFlags = combinedSavedGlobalFlags,
- savedInitFlags = combinedSavedInitFlags,
- savedInstallFlags = combinedSavedInstallFlags,
- savedClientInstallFlags = combinedSavedClientInstallFlags,
- savedConfigureFlags = combinedSavedConfigureFlags,
- savedConfigureExFlags = combinedSavedConfigureExFlags,
- savedUserInstallDirs = combinedSavedUserInstallDirs,
- savedGlobalInstallDirs = combinedSavedGlobalInstallDirs,
- savedUploadFlags = combinedSavedUploadFlags,
- savedReportFlags = combinedSavedReportFlags,
- savedHaddockFlags = combinedSavedHaddockFlags,
- savedTestFlags = combinedSavedTestFlags,
- savedBenchmarkFlags = combinedSavedBenchmarkFlags,
- savedProjectFlags = combinedSavedProjectFlags
- }
+ a <> b =
+ SavedConfig
+ { savedGlobalFlags = combinedSavedGlobalFlags
+ , savedInitFlags = combinedSavedInitFlags
+ , savedInstallFlags = combinedSavedInstallFlags
+ , savedClientInstallFlags = combinedSavedClientInstallFlags
+ , savedConfigureFlags = combinedSavedConfigureFlags
+ , savedConfigureExFlags = combinedSavedConfigureExFlags
+ , savedUserInstallDirs = combinedSavedUserInstallDirs
+ , savedGlobalInstallDirs = combinedSavedGlobalInstallDirs
+ , savedUploadFlags = combinedSavedUploadFlags
+ , savedReportFlags = combinedSavedReportFlags
+ , savedHaddockFlags = combinedSavedHaddockFlags
+ , savedTestFlags = combinedSavedTestFlags
+ , savedBenchmarkFlags = combinedSavedBenchmarkFlags
+ , savedProjectFlags = combinedSavedProjectFlags
+ }
where
-- This is ugly, but necessary. If we're mappending two config files, we
-- want the values of the *non-empty* list fields from the second one to
- -- *override* the corresponding values from the first one. Default
+ -- \*override* the corresponding values from the first one. Default
-- behaviour (concatenation) is confusing and makes some use cases (see
-- #1884) impossible.
--
@@ -206,391 +301,421 @@ instance Semigroup SavedConfig where
-- NB: the signature prevents us from using 'combine' on lists.
combine' :: (SavedConfig -> flags) -> (flags -> Flag a) -> Flag a
- combine' field subfield =
+ combine' field subfield =
(subfield . field $ a) `mappend` (subfield . field $ b)
- combineMonoid :: Monoid mon => (SavedConfig -> flags) -> (flags -> mon)
- -> mon
+ combineMonoid
+ :: Monoid mon
+ => (SavedConfig -> flags)
+ -> (flags -> mon)
+ -> mon
combineMonoid field subfield =
(subfield . field $ a) `mappend` (subfield . field $ b)
lastNonEmpty' :: (SavedConfig -> flags) -> (flags -> [a]) -> [a]
- lastNonEmpty' field subfield =
+ lastNonEmpty' field subfield =
let a' = subfield . field $ a
b' = subfield . field $ b
- in case b' of [] -> a'
- _ -> b'
+ in case b' of
+ [] -> a'
+ _ -> b'
lastNonMempty'
:: (Eq a, Monoid a) => (SavedConfig -> flags) -> (flags -> a) -> a
- lastNonMempty' field subfield =
+ lastNonMempty' field subfield =
let a' = subfield . field $ a
b' = subfield . field $ b
- in if b' == mempty then a' else b'
+ in if b' == mempty then a' else b'
- lastNonEmptyNL' :: (SavedConfig -> flags) -> (flags -> NubList a)
- -> NubList a
+ lastNonEmptyNL'
+ :: (SavedConfig -> flags)
+ -> (flags -> NubList a)
+ -> NubList a
lastNonEmptyNL' field subfield =
let a' = subfield . field $ a
b' = subfield . field $ b
- in case fromNubList b' of [] -> a'
- _ -> b'
-
- combinedSavedGlobalFlags = GlobalFlags {
- globalVersion = combine globalVersion,
- globalNumericVersion = combine globalNumericVersion,
- globalConfigFile = combine globalConfigFile,
- globalConstraintsFile = combine globalConstraintsFile,
- globalRemoteRepos = lastNonEmptyNL globalRemoteRepos,
- globalCacheDir = combine globalCacheDir,
- globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos,
- globalActiveRepos = combine globalActiveRepos,
- globalLogsDir = combine globalLogsDir,
- globalIgnoreExpiry = combine globalIgnoreExpiry,
- globalHttpTransport = combine globalHttpTransport,
- globalNix = combine globalNix,
- globalStoreDir = combine globalStoreDir,
- globalProgPathExtra = lastNonEmptyNL globalProgPathExtra
- }
+ in case fromNubList b' of
+ [] -> a'
+ _ -> b'
+
+ combinedSavedGlobalFlags =
+ GlobalFlags
+ { globalVersion = combine globalVersion
+ , globalNumericVersion = combine globalNumericVersion
+ , globalConfigFile = combine globalConfigFile
+ , globalConstraintsFile = combine globalConstraintsFile
+ , globalRemoteRepos = lastNonEmptyNL globalRemoteRepos
+ , globalCacheDir = combine globalCacheDir
+ , globalLocalNoIndexRepos = lastNonEmptyNL globalLocalNoIndexRepos
+ , globalActiveRepos = combine globalActiveRepos
+ , globalLogsDir = combine globalLogsDir
+ , globalIgnoreExpiry = combine globalIgnoreExpiry
+ , globalHttpTransport = combine globalHttpTransport
+ , globalNix = combine globalNix
+ , globalStoreDir = combine globalStoreDir
+ , globalProgPathExtra = lastNonEmptyNL globalProgPathExtra
+ }
where
- combine = combine' savedGlobalFlags
+ combine = combine' savedGlobalFlags
lastNonEmptyNL = lastNonEmptyNL' savedGlobalFlags
- combinedSavedInitFlags = IT.InitFlags {
- IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs,
- IT.author = combine IT.author,
- IT.buildTools = combineMonoid savedInitFlags IT.buildTools,
- IT.cabalVersion = combine IT.cabalVersion,
- IT.category = combine IT.category,
- IT.dependencies = combineMonoid savedInitFlags IT.dependencies,
- IT.email = combine IT.email,
- IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules,
- IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc,
- IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc,
- IT.homepage = combine IT.homepage,
- IT.initHcPath = combine IT.initHcPath,
- IT.initVerbosity = combine IT.initVerbosity,
- IT.initializeTestSuite = combine IT.initializeTestSuite,
- IT.interactive = combine IT.interactive,
- IT.language = combine IT.language,
- IT.license = combine IT.license,
- IT.mainIs = combine IT.mainIs,
- IT.minimal = combine IT.minimal,
- IT.noComments = combine IT.noComments,
- IT.otherExts = combineMonoid savedInitFlags IT.otherExts,
- IT.otherModules = combineMonoid savedInitFlags IT.otherModules,
- IT.overwrite = combine IT.overwrite,
- IT.packageDir = combine IT.packageDir,
- IT.packageName = combine IT.packageName,
- IT.packageType = combine IT.packageType,
- IT.quiet = combine IT.quiet,
- IT.simpleProject = combine IT.simpleProject,
- IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs,
- IT.synopsis = combine IT.synopsis,
- IT.testDirs = combineMonoid savedInitFlags IT.testDirs,
- IT.version = combine IT.version
- }
+ combinedSavedInitFlags =
+ IT.InitFlags
+ { IT.applicationDirs = combineMonoid savedInitFlags IT.applicationDirs
+ , IT.author = combine IT.author
+ , IT.buildTools = combineMonoid savedInitFlags IT.buildTools
+ , IT.cabalVersion = combine IT.cabalVersion
+ , IT.category = combine IT.category
+ , IT.dependencies = combineMonoid savedInitFlags IT.dependencies
+ , IT.email = combine IT.email
+ , IT.exposedModules = combineMonoid savedInitFlags IT.exposedModules
+ , IT.extraSrc = combineMonoid savedInitFlags IT.extraSrc
+ , IT.extraDoc = combineMonoid savedInitFlags IT.extraDoc
+ , IT.homepage = combine IT.homepage
+ , IT.initHcPath = combine IT.initHcPath
+ , IT.initVerbosity = combine IT.initVerbosity
+ , IT.initializeTestSuite = combine IT.initializeTestSuite
+ , IT.interactive = combine IT.interactive
+ , IT.language = combine IT.language
+ , IT.license = combine IT.license
+ , IT.mainIs = combine IT.mainIs
+ , IT.minimal = combine IT.minimal
+ , IT.noComments = combine IT.noComments
+ , IT.otherExts = combineMonoid savedInitFlags IT.otherExts
+ , IT.otherModules = combineMonoid savedInitFlags IT.otherModules
+ , IT.overwrite = combine IT.overwrite
+ , IT.packageDir = combine IT.packageDir
+ , IT.packageName = combine IT.packageName
+ , IT.packageType = combine IT.packageType
+ , IT.quiet = combine IT.quiet
+ , IT.simpleProject = combine IT.simpleProject
+ , IT.sourceDirs = combineMonoid savedInitFlags IT.sourceDirs
+ , IT.synopsis = combine IT.synopsis
+ , IT.testDirs = combineMonoid savedInitFlags IT.testDirs
+ , IT.version = combine IT.version
+ }
where
combine = combine' savedInitFlags
- combinedSavedInstallFlags = InstallFlags {
- installDocumentation = combine installDocumentation,
- installHaddockIndex = combine installHaddockIndex,
- installDryRun = combine installDryRun,
- installOnlyDownload = combine installOnlyDownload,
- installDest = combine installDest,
- installMaxBackjumps = combine installMaxBackjumps,
- installReorderGoals = combine installReorderGoals,
- installCountConflicts = combine installCountConflicts,
- installFineGrainedConflicts = combine installFineGrainedConflicts,
- installMinimizeConflictSet = combine installMinimizeConflictSet,
- installIndependentGoals = combine installIndependentGoals,
- installPreferOldest = combine installPreferOldest,
- installShadowPkgs = combine installShadowPkgs,
- installStrongFlags = combine installStrongFlags,
- installAllowBootLibInstalls = combine installAllowBootLibInstalls,
- installOnlyConstrained = combine installOnlyConstrained,
- installReinstall = combine installReinstall,
- installAvoidReinstalls = combine installAvoidReinstalls,
- installOverrideReinstall = combine installOverrideReinstall,
- installUpgradeDeps = combine installUpgradeDeps,
- installOnly = combine installOnly,
- installOnlyDeps = combine installOnlyDeps,
- installIndexState = combine installIndexState,
- installRootCmd = combine installRootCmd,
- installSummaryFile = lastNonEmptyNL installSummaryFile,
- installLogFile = combine installLogFile,
- installBuildReports = combine installBuildReports,
- installReportPlanningFailure = combine installReportPlanningFailure,
- installSymlinkBinDir = combine installSymlinkBinDir,
- installPerComponent = combine installPerComponent,
- installNumJobs = combine installNumJobs,
- installKeepGoing = combine installKeepGoing,
- installRunTests = combine installRunTests,
- installOfflineMode = combine installOfflineMode
- }
+ combinedSavedInstallFlags =
+ InstallFlags
+ { installDocumentation = combine installDocumentation
+ , installHaddockIndex = combine installHaddockIndex
+ , installDryRun = combine installDryRun
+ , installOnlyDownload = combine installOnlyDownload
+ , installDest = combine installDest
+ , installMaxBackjumps = combine installMaxBackjumps
+ , installReorderGoals = combine installReorderGoals
+ , installCountConflicts = combine installCountConflicts
+ , installFineGrainedConflicts = combine installFineGrainedConflicts
+ , installMinimizeConflictSet = combine installMinimizeConflictSet
+ , installIndependentGoals = combine installIndependentGoals
+ , installPreferOldest = combine installPreferOldest
+ , installShadowPkgs = combine installShadowPkgs
+ , installStrongFlags = combine installStrongFlags
+ , installAllowBootLibInstalls = combine installAllowBootLibInstalls
+ , installOnlyConstrained = combine installOnlyConstrained
+ , installReinstall = combine installReinstall
+ , installAvoidReinstalls = combine installAvoidReinstalls
+ , installOverrideReinstall = combine installOverrideReinstall
+ , installUpgradeDeps = combine installUpgradeDeps
+ , installOnly = combine installOnly
+ , installOnlyDeps = combine installOnlyDeps
+ , installIndexState = combine installIndexState
+ , installRootCmd = combine installRootCmd
+ , installSummaryFile = lastNonEmptyNL installSummaryFile
+ , installLogFile = combine installLogFile
+ , installBuildReports = combine installBuildReports
+ , installReportPlanningFailure = combine installReportPlanningFailure
+ , installSymlinkBinDir = combine installSymlinkBinDir
+ , installPerComponent = combine installPerComponent
+ , installNumJobs = combine installNumJobs
+ , installKeepGoing = combine installKeepGoing
+ , installRunTests = combine installRunTests
+ , installOfflineMode = combine installOfflineMode
+ }
where
- combine = combine' savedInstallFlags
+ combine = combine' savedInstallFlags
lastNonEmptyNL = lastNonEmptyNL' savedInstallFlags
- combinedSavedClientInstallFlags = ClientInstallFlags
- { cinstInstallLibs = combine cinstInstallLibs
- , cinstEnvironmentPath = combine cinstEnvironmentPath
- , cinstOverwritePolicy = combine cinstOverwritePolicy
- , cinstInstallMethod = combine cinstInstallMethod
- , cinstInstalldir = combine cinstInstalldir
- }
+ combinedSavedClientInstallFlags =
+ ClientInstallFlags
+ { cinstInstallLibs = combine cinstInstallLibs
+ , cinstEnvironmentPath = combine cinstEnvironmentPath
+ , cinstOverwritePolicy = combine cinstOverwritePolicy
+ , cinstInstallMethod = combine cinstInstallMethod
+ , cinstInstalldir = combine cinstInstalldir
+ }
where
- combine = combine' savedClientInstallFlags
-
- combinedSavedConfigureFlags = ConfigFlags {
- configArgs = lastNonEmpty configArgs,
- configPrograms_ = configPrograms_ . savedConfigureFlags $ b,
- -- TODO: NubListify
- configProgramPaths = lastNonEmpty configProgramPaths,
- -- TODO: NubListify
- configProgramArgs = lastNonEmpty configProgramArgs,
- configProgramPathExtra = lastNonEmptyNL configProgramPathExtra,
- configInstantiateWith = lastNonEmpty configInstantiateWith,
- configHcFlavor = combine configHcFlavor,
- configHcPath = combine configHcPath,
- configHcPkg = combine configHcPkg,
- configVanillaLib = combine configVanillaLib,
- configProfLib = combine configProfLib,
- configProf = combine configProf,
- configSharedLib = combine configSharedLib,
- configStaticLib = combine configStaticLib,
- configDynExe = combine configDynExe,
- configFullyStaticExe = combine configFullyStaticExe,
- configProfExe = combine configProfExe,
- configProfDetail = combine configProfDetail,
- configProfLibDetail = combine configProfLibDetail,
- -- TODO: NubListify
- configConfigureArgs = lastNonEmpty configConfigureArgs,
- configOptimization = combine configOptimization,
- configDebugInfo = combine configDebugInfo,
- configProgPrefix = combine configProgPrefix,
- configProgSuffix = combine configProgSuffix,
- -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
- configInstallDirs =
- (configInstallDirs . savedConfigureFlags $ a)
- `mappend` (configInstallDirs . savedConfigureFlags $ b),
- configScratchDir = combine configScratchDir,
- -- TODO: NubListify
- configExtraLibDirs = lastNonEmpty configExtraLibDirs,
- configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic,
- -- TODO: NubListify
- configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs,
- -- TODO: NubListify
- configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs,
- configDeterministic = combine configDeterministic,
- configIPID = combine configIPID,
- configCID = combine configCID,
- configDistPref = combine configDistPref,
- configCabalFilePath = combine configCabalFilePath,
- configVerbosity = combine configVerbosity,
- configUserInstall = combine configUserInstall,
- -- TODO: NubListify
- configPackageDBs = lastNonEmpty configPackageDBs,
- configGHCiLib = combine configGHCiLib,
- configSplitSections = combine configSplitSections,
- configSplitObjs = combine configSplitObjs,
- configStripExes = combine configStripExes,
- configStripLibs = combine configStripLibs,
- -- TODO: NubListify
- configConstraints = lastNonEmpty configConstraints,
- -- TODO: NubListify
- configDependencies = lastNonEmpty configDependencies,
- -- TODO: NubListify
- configConfigurationsFlags = lastNonMempty configConfigurationsFlags,
- configTests = combine configTests,
- configBenchmarks = combine configBenchmarks,
- configCoverage = combine configCoverage,
- configLibCoverage = combine configLibCoverage,
- configExactConfiguration = combine configExactConfiguration,
- configFlagError = combine configFlagError,
- configRelocatable = combine configRelocatable,
- configUseResponseFiles = combine configUseResponseFiles,
- configDumpBuildInfo = combine configDumpBuildInfo,
- configAllowDependingOnPrivateLibs =
- combine configAllowDependingOnPrivateLibs
- }
+ combine = combine' savedClientInstallFlags
+
+ combinedSavedConfigureFlags =
+ ConfigFlags
+ { configArgs = lastNonEmpty configArgs
+ , configPrograms_ = configPrograms_ . savedConfigureFlags $ b
+ , -- TODO: NubListify
+ configProgramPaths = lastNonEmpty configProgramPaths
+ , -- TODO: NubListify
+ configProgramArgs = lastNonEmpty configProgramArgs
+ , configProgramPathExtra = lastNonEmptyNL configProgramPathExtra
+ , configInstantiateWith = lastNonEmpty configInstantiateWith
+ , configHcFlavor = combine configHcFlavor
+ , configHcPath = combine configHcPath
+ , configHcPkg = combine configHcPkg
+ , configVanillaLib = combine configVanillaLib
+ , configProfLib = combine configProfLib
+ , configProf = combine configProf
+ , configSharedLib = combine configSharedLib
+ , configStaticLib = combine configStaticLib
+ , configDynExe = combine configDynExe
+ , configFullyStaticExe = combine configFullyStaticExe
+ , configProfExe = combine configProfExe
+ , configProfDetail = combine configProfDetail
+ , configProfLibDetail = combine configProfLibDetail
+ , -- TODO: NubListify
+ configConfigureArgs = lastNonEmpty configConfigureArgs
+ , configOptimization = combine configOptimization
+ , configDebugInfo = combine configDebugInfo
+ , configProgPrefix = combine configProgPrefix
+ , configProgSuffix = combine configProgSuffix
+ , -- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
+ configInstallDirs =
+ (configInstallDirs . savedConfigureFlags $ a)
+ `mappend` (configInstallDirs . savedConfigureFlags $ b)
+ , configScratchDir = combine configScratchDir
+ , -- TODO: NubListify
+ configExtraLibDirs = lastNonEmpty configExtraLibDirs
+ , configExtraLibDirsStatic = lastNonEmpty configExtraLibDirsStatic
+ , -- TODO: NubListify
+ configExtraFrameworkDirs = lastNonEmpty configExtraFrameworkDirs
+ , -- TODO: NubListify
+ configExtraIncludeDirs = lastNonEmpty configExtraIncludeDirs
+ , configDeterministic = combine configDeterministic
+ , configIPID = combine configIPID
+ , configCID = combine configCID
+ , configDistPref = combine configDistPref
+ , configCabalFilePath = combine configCabalFilePath
+ , configVerbosity = combine configVerbosity
+ , configUserInstall = combine configUserInstall
+ , -- TODO: NubListify
+ configPackageDBs = lastNonEmpty configPackageDBs
+ , configGHCiLib = combine configGHCiLib
+ , configSplitSections = combine configSplitSections
+ , configSplitObjs = combine configSplitObjs
+ , configStripExes = combine configStripExes
+ , configStripLibs = combine configStripLibs
+ , -- TODO: NubListify
+ configConstraints = lastNonEmpty configConstraints
+ , -- TODO: NubListify
+ configDependencies = lastNonEmpty configDependencies
+ , -- TODO: NubListify
+ configConfigurationsFlags = lastNonMempty configConfigurationsFlags
+ , configTests = combine configTests
+ , configBenchmarks = combine configBenchmarks
+ , configCoverage = combine configCoverage
+ , configLibCoverage = combine configLibCoverage
+ , configExactConfiguration = combine configExactConfiguration
+ , configFlagError = combine configFlagError
+ , configRelocatable = combine configRelocatable
+ , configUseResponseFiles = combine configUseResponseFiles
+ , configDumpBuildInfo = combine configDumpBuildInfo
+ , configAllowDependingOnPrivateLibs =
+ combine configAllowDependingOnPrivateLibs
+ }
where
- combine = combine' savedConfigureFlags
- lastNonEmpty = lastNonEmpty' savedConfigureFlags
+ combine = combine' savedConfigureFlags
+ lastNonEmpty = lastNonEmpty' savedConfigureFlags
lastNonEmptyNL = lastNonEmptyNL' savedConfigureFlags
- lastNonMempty = lastNonMempty' savedConfigureFlags
-
- combinedSavedConfigureExFlags = ConfigExFlags {
- configCabalVersion = combine configCabalVersion,
- configAppend = combine configAppend,
- configBackup = combine configBackup,
- -- TODO: NubListify
- configExConstraints = lastNonEmpty configExConstraints,
- -- TODO: NubListify
- configPreferences = lastNonEmpty configPreferences,
- configSolver = combine configSolver,
- configAllowNewer =
- combineMonoid savedConfigureExFlags configAllowNewer,
- configAllowOlder =
- combineMonoid savedConfigureExFlags configAllowOlder,
- configWriteGhcEnvironmentFilesPolicy
- = combine configWriteGhcEnvironmentFilesPolicy
- }
+ lastNonMempty = lastNonMempty' savedConfigureFlags
+
+ combinedSavedConfigureExFlags =
+ ConfigExFlags
+ { configCabalVersion = combine configCabalVersion
+ , configAppend = combine configAppend
+ , configBackup = combine configBackup
+ , -- TODO: NubListify
+ configExConstraints = lastNonEmpty configExConstraints
+ , -- TODO: NubListify
+ configPreferences = lastNonEmpty configPreferences
+ , configSolver = combine configSolver
+ , configAllowNewer =
+ combineMonoid savedConfigureExFlags configAllowNewer
+ , configAllowOlder =
+ combineMonoid savedConfigureExFlags configAllowOlder
+ , configWriteGhcEnvironmentFilesPolicy =
+ combine configWriteGhcEnvironmentFilesPolicy
+ }
where
- combine = combine' savedConfigureExFlags
+ combine = combine' savedConfigureExFlags
lastNonEmpty = lastNonEmpty' savedConfigureExFlags
-- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
- combinedSavedUserInstallDirs = savedUserInstallDirs a
- `mappend` savedUserInstallDirs b
+ combinedSavedUserInstallDirs =
+ savedUserInstallDirs a
+ `mappend` savedUserInstallDirs b
-- Parametrised by (Flag PathTemplate), so safe to use 'mappend'.
- combinedSavedGlobalInstallDirs = savedGlobalInstallDirs a
- `mappend` savedGlobalInstallDirs b
-
- combinedSavedUploadFlags = UploadFlags {
- uploadCandidate = combine uploadCandidate,
- uploadDoc = combine uploadDoc,
- uploadUsername = combine uploadUsername,
- uploadPassword = combine uploadPassword,
- uploadPasswordCmd = combine uploadPasswordCmd,
- uploadVerbosity = combine uploadVerbosity
- }
+ combinedSavedGlobalInstallDirs =
+ savedGlobalInstallDirs a
+ `mappend` savedGlobalInstallDirs b
+
+ combinedSavedUploadFlags =
+ UploadFlags
+ { uploadCandidate = combine uploadCandidate
+ , uploadDoc = combine uploadDoc
+ , uploadUsername = combine uploadUsername
+ , uploadPassword = combine uploadPassword
+ , uploadPasswordCmd = combine uploadPasswordCmd
+ , uploadVerbosity = combine uploadVerbosity
+ }
where
combine = combine' savedUploadFlags
- combinedSavedReportFlags = ReportFlags {
- reportUsername = combine reportUsername,
- reportPassword = combine reportPassword,
- reportVerbosity = combine reportVerbosity
- }
+ combinedSavedReportFlags =
+ ReportFlags
+ { reportUsername = combine reportUsername
+ , reportPassword = combine reportPassword
+ , reportVerbosity = combine reportVerbosity
+ }
where
combine = combine' savedReportFlags
- combinedSavedHaddockFlags = HaddockFlags {
- -- TODO: NubListify
- haddockProgramPaths = lastNonEmpty haddockProgramPaths,
- -- TODO: NubListify
- haddockProgramArgs = lastNonEmpty haddockProgramArgs,
- haddockHoogle = combine haddockHoogle,
- haddockHtml = combine haddockHtml,
- haddockHtmlLocation = combine haddockHtmlLocation,
- haddockForHackage = combine haddockForHackage,
- haddockExecutables = combine haddockExecutables,
- haddockTestSuites = combine haddockTestSuites,
- haddockBenchmarks = combine haddockBenchmarks,
- haddockForeignLibs = combine haddockForeignLibs,
- haddockInternal = combine haddockInternal,
- haddockCss = combine haddockCss,
- haddockLinkedSource = combine haddockLinkedSource,
- haddockQuickJump = combine haddockQuickJump,
- haddockHscolourCss = combine haddockHscolourCss,
- haddockContents = combine haddockContents,
- haddockDistPref = combine haddockDistPref,
- haddockKeepTempFiles = combine haddockKeepTempFiles,
- haddockVerbosity = combine haddockVerbosity,
- haddockCabalFilePath = combine haddockCabalFilePath,
- haddockIndex = combine haddockIndex,
- haddockBaseUrl = combine haddockBaseUrl,
- haddockLib = combine haddockLib,
- haddockOutputDir = combine haddockOutputDir,
- haddockArgs = lastNonEmpty haddockArgs
- }
+ combinedSavedHaddockFlags =
+ HaddockFlags
+ { -- TODO: NubListify
+ haddockProgramPaths = lastNonEmpty haddockProgramPaths
+ , -- TODO: NubListify
+ haddockProgramArgs = lastNonEmpty haddockProgramArgs
+ , haddockHoogle = combine haddockHoogle
+ , haddockHtml = combine haddockHtml
+ , haddockHtmlLocation = combine haddockHtmlLocation
+ , haddockForHackage = combine haddockForHackage
+ , haddockExecutables = combine haddockExecutables
+ , haddockTestSuites = combine haddockTestSuites
+ , haddockBenchmarks = combine haddockBenchmarks
+ , haddockForeignLibs = combine haddockForeignLibs
+ , haddockInternal = combine haddockInternal
+ , haddockCss = combine haddockCss
+ , haddockLinkedSource = combine haddockLinkedSource
+ , haddockQuickJump = combine haddockQuickJump
+ , haddockHscolourCss = combine haddockHscolourCss
+ , haddockContents = combine haddockContents
+ , haddockDistPref = combine haddockDistPref
+ , haddockKeepTempFiles = combine haddockKeepTempFiles
+ , haddockVerbosity = combine haddockVerbosity
+ , haddockCabalFilePath = combine haddockCabalFilePath
+ , haddockIndex = combine haddockIndex
+ , haddockBaseUrl = combine haddockBaseUrl
+ , haddockLib = combine haddockLib
+ , haddockOutputDir = combine haddockOutputDir
+ , haddockArgs = lastNonEmpty haddockArgs
+ }
where
- combine = combine' savedHaddockFlags
- lastNonEmpty = lastNonEmpty' savedHaddockFlags
-
- combinedSavedTestFlags = TestFlags {
- testDistPref = combine testDistPref,
- testVerbosity = combine testVerbosity,
- testHumanLog = combine testHumanLog,
- testMachineLog = combine testMachineLog,
- testShowDetails = combine testShowDetails,
- testKeepTix = combine testKeepTix,
- testWrapper = combine testWrapper,
- testFailWhenNoTestSuites = combine testFailWhenNoTestSuites,
- testOptions = lastNonEmpty testOptions
- }
+ combine = combine' savedHaddockFlags
+ lastNonEmpty = lastNonEmpty' savedHaddockFlags
+
+ combinedSavedTestFlags =
+ TestFlags
+ { testDistPref = combine testDistPref
+ , testVerbosity = combine testVerbosity
+ , testHumanLog = combine testHumanLog
+ , testMachineLog = combine testMachineLog
+ , testShowDetails = combine testShowDetails
+ , testKeepTix = combine testKeepTix
+ , testWrapper = combine testWrapper
+ , testFailWhenNoTestSuites = combine testFailWhenNoTestSuites
+ , testOptions = lastNonEmpty testOptions
+ }
where
- combine = combine' savedTestFlags
- lastNonEmpty = lastNonEmpty' savedTestFlags
-
- combinedSavedBenchmarkFlags = BenchmarkFlags {
- benchmarkDistPref = combine benchmarkDistPref,
- benchmarkVerbosity = combine benchmarkVerbosity,
- benchmarkOptions = lastNonEmpty benchmarkOptions
- }
+ combine = combine' savedTestFlags
+ lastNonEmpty = lastNonEmpty' savedTestFlags
+
+ combinedSavedBenchmarkFlags =
+ BenchmarkFlags
+ { benchmarkDistPref = combine benchmarkDistPref
+ , benchmarkVerbosity = combine benchmarkVerbosity
+ , benchmarkOptions = lastNonEmpty benchmarkOptions
+ }
where
- combine = combine' savedBenchmarkFlags
- lastNonEmpty = lastNonEmpty' savedBenchmarkFlags
-
- combinedSavedProjectFlags = ProjectFlags
- { flagProjectDir = combine flagProjectDir
- , flagProjectFile = combine flagProjectFile
- , flagIgnoreProject = combine flagIgnoreProject
- }
+ combine = combine' savedBenchmarkFlags
+ lastNonEmpty = lastNonEmpty' savedBenchmarkFlags
+
+ combinedSavedProjectFlags =
+ ProjectFlags
+ { flagProjectDir = combine flagProjectDir
+ , flagProjectFile = combine flagProjectFile
+ , flagIgnoreProject = combine flagIgnoreProject
+ }
where
- combine = combine' savedProjectFlags
+ combine = combine' savedProjectFlags
--
+
-- * Default config
+
--
-- | These are the absolute basic defaults. The fields that must be
-- initialised. When we load the config from the file we layer the loaded
-- values over these ones, so any missing fields in the file take their values
-- from here.
---
baseSavedConfig :: IO SavedConfig
baseSavedConfig = do
userPrefix <- defaultInstallPrefix
- cacheDir <- defaultCacheDir
- logsDir <- defaultLogsDir
- return mempty {
- savedConfigureFlags = mempty {
- configHcFlavor = toFlag defaultCompiler,
- configUserInstall = toFlag defaultUserInstall,
- configVerbosity = toFlag normal
- },
- savedUserInstallDirs = mempty {
- prefix = toFlag (toPathTemplate userPrefix)
- },
- savedGlobalFlags = mempty {
- globalCacheDir = toFlag cacheDir,
- globalLogsDir = toFlag logsDir
- }
- }
+ cacheDir <- defaultCacheDir
+ logsDir <- defaultLogsDir
+ return
+ mempty
+ { savedConfigureFlags =
+ mempty
+ { configHcFlavor = toFlag defaultCompiler
+ , configUserInstall = toFlag defaultUserInstall
+ , configVerbosity = toFlag normal
+ }
+ , savedUserInstallDirs =
+ mempty
+ { prefix = toFlag (toPathTemplate userPrefix)
+ }
+ , savedGlobalFlags =
+ mempty
+ { globalCacheDir = toFlag cacheDir
+ , globalLogsDir = toFlag logsDir
+ }
+ }
-- | This is the initial configuration that we write out to the config file
-- if the file does not exist (or the config we use if the file cannot be read
-- for some other reason). When the config gets loaded it gets layered on top
-- of 'baseSavedConfig' so we do not need to include it into the initial
-- values we save into the config file.
---
initialSavedConfig :: IO SavedConfig
initialSavedConfig = do
- cacheDir <- defaultCacheDir
- logsDir <- defaultLogsDir
- extraPath <- defaultExtraPath
+ cacheDir <- defaultCacheDir
+ logsDir <- defaultLogsDir
+ extraPath <- defaultExtraPath
installPath <- defaultInstallPath
- return mempty {
- savedGlobalFlags = mempty {
- globalCacheDir = toFlag cacheDir,
- globalRemoteRepos = toNubList [defaultRemoteRepo]
- },
- savedConfigureFlags = mempty {
- configProgramPathExtra = toNubList extraPath
- },
- savedInstallFlags = mempty {
- installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")],
- installBuildReports= toFlag NoReports,
- installNumJobs = toFlag Nothing
- },
- savedClientInstallFlags = mempty {
- cinstInstalldir = toFlag installPath
- }
- }
+ return
+ mempty
+ { savedGlobalFlags =
+ mempty
+ { globalCacheDir = toFlag cacheDir
+ , globalRemoteRepos = toNubList [defaultRemoteRepo]
+ }
+ , savedConfigureFlags =
+ mempty
+ { configProgramPathExtra = toNubList extraPath
+ }
+ , savedInstallFlags =
+ mempty
+ { installSummaryFile = toNubList [toPathTemplate (logsDir </> "build.log")]
+ , installBuildReports = toFlag NoReports
+ , installNumJobs = toFlag Nothing
+ }
+ , savedClientInstallFlags =
+ mempty
+ { cinstInstalldir = toFlag installPath
+ }
+ }
-- | If @CABAL\_DIR@ is set or @~/.cabal@ exists, return that
-- directory. Otherwise returns Nothing. If this function returns
@@ -606,9 +731,10 @@ maybeGetCabalDir = do
Nothing -> do
defaultDir <- getAppUserDataDirectory "cabal"
dotCabalExists <- doesDirectoryExist defaultDir
- return $ if dotCabalExists
- then Just defaultDir
- else Nothing
+ return $
+ if dotCabalExists
+ then Just defaultDir
+ else Nothing
-- | The default behaviour of cabal-install is to use the XDG
-- directory standard. However, if @CABAL_DIR@ is set, we instead use
@@ -683,19 +809,21 @@ defaultCompiler = fromMaybe GHC defaultCompilerFlavor
defaultUserInstall :: Bool
defaultUserInstall = True
+
-- We do per-user installs by default on all platforms. We used to default to
-- global installs on Windows but that no longer works on Windows Vista or 7.
defaultRemoteRepo :: RemoteRepo
defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
where
- str = "hackage.haskell.org"
+ str = "hackage.haskell.org"
name = RepoName str
- uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
- -- Note that lots of old config files will have the old url
- -- http://hackage.haskell.org/packages/archive
- -- but new config files can use the new url (without the /packages/archive)
- -- and avoid having to do a http redirect
+ uri = URI "http:" (Just (URIAuth "" str "")) "/" "" ""
+
+-- Note that lots of old config files will have the old url
+-- http://hackage.haskell.org/packages/archive
+-- but new config files can use the new url (without the /packages/archive)
+-- and avoid having to do a http redirect
-- For the default repo we know extra information, fill this in.
--
@@ -706,32 +834,35 @@ defaultRemoteRepo = RemoteRepo name uri Nothing [] 0 False
--
addInfoForKnownRepos :: RemoteRepo -> RemoteRepo
addInfoForKnownRepos repo
- | remoteRepoName repo == remoteRepoName defaultRemoteRepo
- = useSecure . tryHttps . fixOldURI $ repo
+ | remoteRepoName repo == remoteRepoName defaultRemoteRepo =
+ useSecure . tryHttps . fixOldURI $ repo
where
fixOldURI r
- | isOldHackageURI (remoteRepoURI r)
- = r { remoteRepoURI = remoteRepoURI defaultRemoteRepo }
+ | isOldHackageURI (remoteRepoURI r) =
+ r{remoteRepoURI = remoteRepoURI defaultRemoteRepo}
| otherwise = r
- tryHttps r = r { remoteRepoShouldTryHttps = True }
+ tryHttps r = r{remoteRepoShouldTryHttps = True}
- useSecure r@RemoteRepo{
- remoteRepoSecure = secure,
- remoteRepoRootKeys = [],
- remoteRepoKeyThreshold = 0
- } | secure /= Just False
- = r {
- -- Use hackage-security by default unless you opt-out with
+ useSecure
+ r@RemoteRepo
+ { remoteRepoSecure = secure
+ , remoteRepoRootKeys = []
+ , remoteRepoKeyThreshold = 0
+ }
+ | secure /= Just False =
+ r
+ { -- Use hackage-security by default unless you opt-out with
-- secure: False
- remoteRepoSecure = Just True,
- remoteRepoRootKeys = defaultHackageRemoteRepoKeys,
- remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold
+ remoteRepoSecure = Just True
+ , remoteRepoRootKeys = defaultHackageRemoteRepoKeys
+ , remoteRepoKeyThreshold = defaultHackageRemoteRepoKeyThreshold
}
useSecure r = r
addInfoForKnownRepos other = other
-- | The current hackage.haskell.org repo root keys that we ship with cabal.
+
---
-- This lets us bootstrap trust in this repo without user intervention.
-- These keys need to be periodically updated when new root keys are added.
@@ -739,39 +870,39 @@ addInfoForKnownRepos other = other
--
defaultHackageRemoteRepoKeys :: [String]
defaultHackageRemoteRepoKeys =
- -- Key owners and public keys are provided as a convenience to readers.
- -- The canonical source for this mapping data is the hackage-root-keys
- -- repository and Hackage's root.json file.
- --
- -- Links:
- -- * https://github.com/haskell-infra/hackage-root-keys
- -- * https://hackage.haskell.org/root.json
- -- Please consult root.json on Hackage to map key IDs to public keys,
- -- and the hackage-root-keys repository to map public keys to their
- -- owners.
- [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)
- "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0",
- -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
- "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42",
- -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
- "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d",
- -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
- "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
- ]
+ -- Key owners and public keys are provided as a convenience to readers.
+ -- The canonical source for this mapping data is the hackage-root-keys
+ -- repository and Hackage's root.json file.
+ --
+ -- Links:
+ -- * https://github.com/haskell-infra/hackage-root-keys
+ -- * https://hackage.haskell.org/root.json
+ -- Please consult root.json on Hackage to map key IDs to public keys,
+ -- and the hackage-root-keys repository to map public keys to their
+ -- owners.
+ [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)
+ "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
+ , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
+ "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
+ , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
+ "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
+ , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
+ "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
+ ]
-- | The required threshold of root key signatures for hackage.haskell.org
---
defaultHackageRemoteRepoKeyThreshold :: Int
defaultHackageRemoteRepoKeyThreshold = 3
--
+
-- * Config file reading
+
--
-- | Loads the main configuration, and applies additional defaults to give the
-- effective configuration. To loads just what is actually in the config file,
-- use 'loadRawConfig'.
---
loadConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
loadConfig verbosity configFileFlag = do
config <- loadRawConfig verbosity configFileFlag
@@ -780,22 +911,24 @@ loadConfig verbosity configFileFlag = do
extendToEffectiveConfig :: SavedConfig -> IO SavedConfig
extendToEffectiveConfig config = do
base <- baseSavedConfig
- let effective0 = base `mappend` config
+ let effective0 = base `mappend` config
globalFlags0 = savedGlobalFlags effective0
- effective = effective0 {
- savedGlobalFlags = globalFlags0 {
- globalRemoteRepos =
- overNubList (map addInfoForKnownRepos)
- (globalRemoteRepos globalFlags0)
- }
- }
+ effective =
+ effective0
+ { savedGlobalFlags =
+ globalFlags0
+ { globalRemoteRepos =
+ overNubList
+ (map addInfoForKnownRepos)
+ (globalRemoteRepos globalFlags0)
+ }
+ }
return effective
-- | Like 'loadConfig' but does not apply any additional defaults, it just
-- loads what is actually in the config file. This is thus suitable for
-- comparing or editing a config file, but not suitable for using as the
-- effective configuration.
---
loadRawConfig :: Verbosity -> Flag FilePath -> IO SavedConfig
loadRawConfig verbosity configFileFlag = do
(source, configFile) <- getConfigFilePathAndSource configFileFlag
@@ -811,34 +944,39 @@ loadRawConfig verbosity configFileFlag = do
Default -> do
notice verbosity msgNotFound
createDefaultConfigFile verbosity [] configFile
- CommandlineOption -> failNoConfigFile
+ CommandlineOption -> failNoConfigFile
EnvironmentVariable -> failNoConfigFile
where
- msgNotFound = unwords [ "Config file not found:", configFile ]
- failNoConfigFile = die' verbosity $ unlines
- [ msgNotFound
- , "(Config files can be created via the cabal-command 'user-config init'.)"
- ]
+ msgNotFound = unwords ["Config file not found:", configFile]
+ failNoConfigFile =
+ die' verbosity $
+ unlines
+ [ msgNotFound
+ , "(Config files can be created via the cabal-command 'user-config init'.)"
+ ]
Just (ParseOk ws conf) -> do
- unless (null ws) $ warn verbosity $
- unlines (map (showPWarning configFile) ws)
+ unless (null ws) $
+ warn verbosity $
+ unlines (map (showPWarning configFile) ws)
return conf
Just (ParseFailed err) -> do
let (line, msg) = locatedErrorMsg err
die' verbosity $
- "Error parsing config file " ++ configFile
- ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg
-
+ "Error parsing config file "
+ ++ configFile
+ ++ maybe "" (\n -> ':' : show n) line
+ ++ ":\n"
+ ++ msg
where
- sourceMsg CommandlineOption = "commandline option"
+ sourceMsg CommandlineOption = "commandline option"
sourceMsg EnvironmentVariable = "environment variable CABAL_CONFIG"
- sourceMsg Default = "default config file"
+ sourceMsg Default = "default config file"
-- | Provenance of the config file.
-
-data ConfigFileSource = CommandlineOption
- | EnvironmentVariable
- | Default
+data ConfigFileSource
+ = CommandlineOption
+ | EnvironmentVariable
+ | Default
-- | Returns the config file path, without checking that the file exists.
-- The order of precedence is: input flag, CABAL_CONFIG, default location.
@@ -847,23 +985,25 @@ getConfigFilePath = fmap snd . getConfigFilePathAndSource
getConfigFilePathAndSource :: Flag FilePath -> IO (ConfigFileSource, FilePath)
getConfigFilePathAndSource configFileFlag =
- getSource sources
+ getSource sources
where
sources =
- [ (CommandlineOption, return . flagToMaybe $ configFileFlag)
+ [ (CommandlineOption, return . flagToMaybe $ configFileFlag)
, (EnvironmentVariable, lookup "CABAL_CONFIG" `liftM` getEnvironment)
- , (Default, Just `liftM` defaultConfigFile) ]
+ , (Default, Just `liftM` defaultConfigFile)
+ ]
getSource [] = error "no config file path candidate found."
- getSource ((source,action): xs) =
- action >>= maybe (getSource xs) (return . (,) source)
+ getSource ((source, action) : xs) =
+ action >>= maybe (getSource xs) (return . (,) source)
readConfigFile
:: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
-readConfigFile initial file = handleNotExists $
- fmap (Just . parseConfig (ConstraintSourceMainConfig file) initial)
- (BS.readFile file)
-
+readConfigFile initial file =
+ handleNotExists $
+ fmap
+ (Just . parseConfig (ConstraintSourceMainConfig file) initial)
+ (BS.readFile file)
where
handleNotExists action = catchIO action $ \ioe ->
if isDoesNotExistError ioe
@@ -871,10 +1011,10 @@ readConfigFile initial file = handleNotExists $
else ioError ioe
createDefaultConfigFile :: Verbosity -> [String] -> FilePath -> IO SavedConfig
-createDefaultConfigFile verbosity extraLines filePath = do
+createDefaultConfigFile verbosity extraLines filePath = do
commentConf <- commentSavedConfig
initialConf <- initialSavedConfig
- extraConf <- parseExtraLines verbosity extraLines
+ extraConf <- parseExtraLines verbosity extraLines
notice verbosity $ "Writing default configuration to " ++ filePath
writeConfigFile filePath commentConf (initialConf `mappend` extraConf)
return initialConf
@@ -887,523 +1027,656 @@ writeConfigFile file comments vals = do
explanation ++ showConfigWithComments comments vals ++ "\n"
renameFile tmpFile file
where
- explanation = unlines
- ["-- This is the configuration file for the 'cabal' command line tool."
- ,"--"
- ,"-- The available configuration options are listed below."
- ,"-- Some of them have default values listed."
- ,"--"
- ,"-- Lines (like this one) beginning with '--' are comments."
- ,"-- Be careful with spaces and indentation because they are"
- ,"-- used to indicate layout for nested sections."
- ,"--"
- ,"-- This config file was generated using the following versions"
- ,"-- of Cabal and cabal-install:"
- ,"-- Cabal library version: " ++ prettyShow cabalVersion
- ,"-- cabal-install version: " ++ prettyShow cabalInstallVersion
- ,"",""
- ]
+ explanation =
+ unlines
+ [ "-- This is the configuration file for the 'cabal' command line tool."
+ , "--"
+ , "-- The available configuration options are listed below."
+ , "-- Some of them have default values listed."
+ , "--"
+ , "-- Lines (like this one) beginning with '--' are comments."
+ , "-- Be careful with spaces and indentation because they are"
+ , "-- used to indicate layout for nested sections."
+ , "--"
+ , "-- This config file was generated using the following versions"
+ , "-- of Cabal and cabal-install:"
+ , "-- Cabal library version: " ++ prettyShow cabalVersion
+ , "-- cabal-install version: " ++ prettyShow cabalInstallVersion
+ , ""
+ , ""
+ ]
-- | These are the default values that get used in Cabal if a no value is
-- given. We use these here to include in comments when we write out the
-- initial config file so that the user can see what default value they are
-- overriding.
---
commentSavedConfig :: IO SavedConfig
commentSavedConfig = do
- userInstallDirs <- defaultInstallDirs defaultCompiler True True
+ userInstallDirs <- defaultInstallDirs defaultCompiler True True
globalInstallDirs <- defaultInstallDirs defaultCompiler False True
- let conf0 = mempty {
- savedGlobalFlags = defaultGlobalFlags {
- globalRemoteRepos = toNubList [defaultRemoteRepo],
- globalNix = mempty
- },
- savedInitFlags = mempty {
- IT.interactive = toFlag False,
- IT.cabalVersion = toFlag IT.defaultCabalVersion,
- IT.language = toFlag Haskell2010,
- IT.license = NoFlag,
- IT.sourceDirs = Flag [IT.defaultSourceDir],
- IT.applicationDirs = Flag [IT.defaultApplicationDir],
- IT.quiet = Flag False,
- IT.noComments = Flag False,
- IT.minimal = Flag False,
- IT.simpleProject = Flag False
- },
- savedInstallFlags = defaultInstallFlags,
- savedClientInstallFlags= defaultClientInstallFlags,
- savedConfigureExFlags = defaultConfigExFlags {
- configAllowNewer = Just (AllowNewer mempty),
- configAllowOlder = Just (AllowOlder mempty)
- },
- savedConfigureFlags = (defaultConfigFlags defaultProgramDb) {
- configUserInstall = toFlag defaultUserInstall
- },
- savedUserInstallDirs = fmap toFlag userInstallDirs,
- savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
- savedUploadFlags = commandDefaultFlags uploadCommand,
- savedReportFlags = commandDefaultFlags reportCommand,
- savedHaddockFlags = defaultHaddockFlags,
- savedTestFlags = defaultTestFlags,
- savedBenchmarkFlags = defaultBenchmarkFlags
- }
+ let conf0 =
+ mempty
+ { savedGlobalFlags =
+ defaultGlobalFlags
+ { globalRemoteRepos = toNubList [defaultRemoteRepo]
+ , globalNix = mempty
+ }
+ , savedInitFlags =
+ mempty
+ { IT.interactive = toFlag False
+ , IT.cabalVersion = toFlag IT.defaultCabalVersion
+ , IT.language = toFlag Haskell2010
+ , IT.license = NoFlag
+ , IT.sourceDirs = Flag [IT.defaultSourceDir]
+ , IT.applicationDirs = Flag [IT.defaultApplicationDir]
+ , IT.quiet = Flag False
+ , IT.noComments = Flag False
+ , IT.minimal = Flag False
+ , IT.simpleProject = Flag False
+ }
+ , savedInstallFlags = defaultInstallFlags
+ , savedClientInstallFlags = defaultClientInstallFlags
+ , savedConfigureExFlags =
+ defaultConfigExFlags
+ { configAllowNewer = Just (AllowNewer mempty)
+ , configAllowOlder = Just (AllowOlder mempty)
+ }
+ , savedConfigureFlags =
+ (defaultConfigFlags defaultProgramDb)
+ { configUserInstall = toFlag defaultUserInstall
+ }
+ , savedUserInstallDirs = fmap toFlag userInstallDirs
+ , savedGlobalInstallDirs = fmap toFlag globalInstallDirs
+ , savedUploadFlags = commandDefaultFlags uploadCommand
+ , savedReportFlags = commandDefaultFlags reportCommand
+ , savedHaddockFlags = defaultHaddockFlags
+ , savedTestFlags = defaultTestFlags
+ , savedBenchmarkFlags = defaultBenchmarkFlags
+ }
conf1 <- extendToEffectiveConfig conf0
let globalFlagsConf1 = savedGlobalFlags conf1
- conf2 = conf1 {
- savedGlobalFlags = globalFlagsConf1 {
- globalRemoteRepos = overNubList (map removeRootKeys)
- (globalRemoteRepos globalFlagsConf1)
- }
- }
+ conf2 =
+ conf1
+ { savedGlobalFlags =
+ globalFlagsConf1
+ { globalRemoteRepos =
+ overNubList
+ (map removeRootKeys)
+ (globalRemoteRepos globalFlagsConf1)
+ }
+ }
return conf2
- where
- -- Most people don't want to see default root keys, so don't print them.
- removeRootKeys :: RemoteRepo -> RemoteRepo
- removeRootKeys r = r { remoteRepoRootKeys = [] }
+ where
+ -- Most people don't want to see default root keys, so don't print them.
+ removeRootKeys :: RemoteRepo -> RemoteRepo
+ removeRootKeys r = r{remoteRepoRootKeys = []}
-- | All config file fields.
---
configFieldDescriptions :: ConstraintSource -> [FieldDescr SavedConfig]
configFieldDescriptions src =
-
- toSavedConfig liftGlobalFlag
- (commandOptions (globalCommand []) ParseArgs)
- ["version", "numeric-version", "config-file"] []
-
- ++ toSavedConfig liftConfigFlag
- (configureOptions ParseArgs)
- (["builddir", "constraint", "dependency", "ipid"]
- ++ map fieldName installDirsFields)
-
- -- This is only here because viewAsFieldDescr gives us a parser
- -- that only recognises 'ghc' etc, the case-sensitive flag names, not
- -- what the normal case-insensitive parser gives us.
- [simpleFieldParsec "compiler"
- (fromFlagOrDefault Disp.empty . fmap pretty) (Flag <$> parsec <|> pure NoFlag)
- configHcFlavor (\v flags -> flags { configHcFlavor = v })
-
- -- TODO: The following is a temporary fix. The "optimization"
+ toSavedConfig
+ liftGlobalFlag
+ (commandOptions (globalCommand []) ParseArgs)
+ ["version", "numeric-version", "config-file"]
+ []
+ ++ toSavedConfig
+ liftConfigFlag
+ (configureOptions ParseArgs)
+ ( ["builddir", "constraint", "dependency", "ipid"]
+ ++ map fieldName installDirsFields
+ )
+ -- This is only here because viewAsFieldDescr gives us a parser
+ -- that only recognises 'ghc' etc, the case-sensitive flag names, not
+ -- what the normal case-insensitive parser gives us.
+ [ simpleFieldParsec
+ "compiler"
+ (fromFlagOrDefault Disp.empty . fmap pretty)
+ (Flag <$> parsec <|> pure NoFlag)
+ configHcFlavor
+ (\v flags -> flags{configHcFlavor = v})
+ , -- TODO: The following is a temporary fix. The "optimization"
-- and "debug-info" fields are OptArg, and viewAsFieldDescr
-- fails on that. Instead of a hand-written hackaged parser
-- and printer, we should handle this case properly in the
-- library.
- ,liftField configOptimization (\v flags ->
- flags { configOptimization = v }) $
- let name = "optimization" in
- FieldDescr name
- (\f -> case f of
- Flag NoOptimisation -> Disp.text "False"
- Flag NormalOptimisation -> Disp.text "True"
- Flag MaximumOptimisation -> Disp.text "2"
- _ -> Disp.empty)
- (\line str _ -> case () of
- _ | str == "False" -> ParseOk [] (Flag NoOptimisation)
- | str == "True" -> ParseOk [] (Flag NormalOptimisation)
- | str == "0" -> ParseOk [] (Flag NoOptimisation)
- | str == "1" -> ParseOk [] (Flag NormalOptimisation)
- | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
- | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
- | lstr == "true" -> ParseOk [caseWarning]
- (Flag NormalOptimisation)
- | otherwise -> ParseFailed (NoParse name line)
- where
- lstr = lowercase str
- caseWarning = PWarning $
- "The '" ++ name
- ++ "' field is case sensitive, use 'True' or 'False'.")
- ,liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $
- let name = "debug-info" in
- FieldDescr name
- (\f -> case f of
- Flag NoDebugInfo -> Disp.text "False"
- Flag MinimalDebugInfo -> Disp.text "1"
- Flag NormalDebugInfo -> Disp.text "True"
- Flag MaximalDebugInfo -> Disp.text "3"
- _ -> Disp.empty)
- (\line str _ -> case () of
- _ | str == "False" -> ParseOk [] (Flag NoDebugInfo)
- | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
- | str == "0" -> ParseOk [] (Flag NoDebugInfo)
- | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
- | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
- | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
- | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
- | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
- | otherwise -> ParseFailed (NoParse name line)
- where
- lstr = lowercase str
- caseWarning = PWarning $
- "The '" ++ name
- ++ "' field is case sensitive, use 'True' or 'False'.")
- ]
-
- ++ toSavedConfig liftConfigExFlag
- (configureExOptions ParseArgs src)
- []
- [let pkgs = (Just . AllowOlder . RelaxDepsSome)
- `fmap` parsecOptCommaList parsec
- parseAllowOlder = ((Just . AllowOlder . toRelaxDeps)
- `fmap` parsec) <|> pkgs
- in simpleFieldParsec "allow-older"
- (showRelaxDeps . fmap unAllowOlder) parseAllowOlder
- configAllowOlder (\v flags -> flags { configAllowOlder = v })
- ,let pkgs = (Just . AllowNewer . RelaxDepsSome)
- `fmap` parsecOptCommaList parsec
- parseAllowNewer = ((Just . AllowNewer . toRelaxDeps)
- `fmap` parsec) <|> pkgs
- in simpleFieldParsec "allow-newer"
- (showRelaxDeps . fmap unAllowNewer) parseAllowNewer
- configAllowNewer (\v flags -> flags { configAllowNewer = v })
+ liftField
+ configOptimization
+ ( \v flags ->
+ flags{configOptimization = v}
+ )
+ $ let name = "optimization"
+ in FieldDescr
+ name
+ ( \f -> case f of
+ Flag NoOptimisation -> Disp.text "False"
+ Flag NormalOptimisation -> Disp.text "True"
+ Flag MaximumOptimisation -> Disp.text "2"
+ _ -> Disp.empty
+ )
+ ( \line str _ -> case () of
+ _
+ | str == "False" -> ParseOk [] (Flag NoOptimisation)
+ | str == "True" -> ParseOk [] (Flag NormalOptimisation)
+ | str == "0" -> ParseOk [] (Flag NoOptimisation)
+ | str == "1" -> ParseOk [] (Flag NormalOptimisation)
+ | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
+ | lstr == "false" -> ParseOk [caseWarning] (Flag NoOptimisation)
+ | lstr == "true" ->
+ ParseOk
+ [caseWarning]
+ (Flag NormalOptimisation)
+ | otherwise -> ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ caseWarning =
+ PWarning $
+ "The '"
+ ++ name
+ ++ "' field is case sensitive, use 'True' or 'False'."
+ )
+ , liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $
+ let name = "debug-info"
+ in FieldDescr
+ name
+ ( \f -> case f of
+ Flag NoDebugInfo -> Disp.text "False"
+ Flag MinimalDebugInfo -> Disp.text "1"
+ Flag NormalDebugInfo -> Disp.text "True"
+ Flag MaximalDebugInfo -> Disp.text "3"
+ _ -> Disp.empty
+ )
+ ( \line str _ -> case () of
+ _
+ | str == "False" -> ParseOk [] (Flag NoDebugInfo)
+ | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
+ | str == "0" -> ParseOk [] (Flag NoDebugInfo)
+ | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
+ | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
+ | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
+ | lstr == "false" -> ParseOk [caseWarning] (Flag NoDebugInfo)
+ | lstr == "true" -> ParseOk [caseWarning] (Flag NormalDebugInfo)
+ | otherwise -> ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ caseWarning =
+ PWarning $
+ "The '"
+ ++ name
+ ++ "' field is case sensitive, use 'True' or 'False'."
+ )
+ ]
+ ++ toSavedConfig
+ liftConfigExFlag
+ (configureExOptions ParseArgs src)
+ []
+ [ let pkgs =
+ (Just . AllowOlder . RelaxDepsSome)
+ `fmap` parsecOptCommaList parsec
+ parseAllowOlder =
+ ( (Just . AllowOlder . toRelaxDeps)
+ `fmap` parsec
+ )
+ <|> pkgs
+ in simpleFieldParsec
+ "allow-older"
+ (showRelaxDeps . fmap unAllowOlder)
+ parseAllowOlder
+ configAllowOlder
+ (\v flags -> flags{configAllowOlder = v})
+ , let pkgs =
+ (Just . AllowNewer . RelaxDepsSome)
+ `fmap` parsecOptCommaList parsec
+ parseAllowNewer =
+ ( (Just . AllowNewer . toRelaxDeps)
+ `fmap` parsec
+ )
+ <|> pkgs
+ in simpleFieldParsec
+ "allow-newer"
+ (showRelaxDeps . fmap unAllowNewer)
+ parseAllowNewer
+ configAllowNewer
+ (\v flags -> flags{configAllowNewer = v})
+ ]
+ ++ toSavedConfig
+ liftInstallFlag
+ (installOptions ParseArgs)
+ ["dry-run", "only", "only-dependencies", "dependencies-only"]
+ []
+ ++ toSavedConfig
+ liftClientInstallFlag
+ (clientInstallOptions ParseArgs)
+ []
+ []
+ ++ toSavedConfig
+ liftUploadFlag
+ (commandOptions uploadCommand ParseArgs)
+ ["verbose", "check", "documentation", "publish"]
+ []
+ ++ toSavedConfig
+ liftReportFlag
+ (commandOptions reportCommand ParseArgs)
+ ["verbose", "username", "password"]
+ []
+ -- FIXME: this is a hack, hiding the user name and password.
+ -- But otherwise it masks the upload ones. Either need to
+ -- share the options or make then distinct. In any case
+ -- they should probably be per-server.
+
+ ++ [ viewAsFieldDescr $
+ optionDistPref
+ (configDistPref . savedConfigureFlags)
+ ( \distPref config ->
+ config
+ { savedConfigureFlags =
+ (savedConfigureFlags config)
+ { configDistPref = distPref
+ }
+ , savedHaddockFlags =
+ (savedHaddockFlags config)
+ { haddockDistPref = distPref
+ }
+ }
+ )
+ ParseArgs
]
-
- ++ toSavedConfig liftInstallFlag
- (installOptions ParseArgs)
- ["dry-run", "only", "only-dependencies", "dependencies-only"] []
-
- ++ toSavedConfig liftClientInstallFlag
- (clientInstallOptions ParseArgs)
- [] []
-
- ++ toSavedConfig liftUploadFlag
- (commandOptions uploadCommand ParseArgs)
- ["verbose", "check", "documentation", "publish"] []
-
- ++ toSavedConfig liftReportFlag
- (commandOptions reportCommand ParseArgs)
- ["verbose", "username", "password"] []
- --FIXME: this is a hack, hiding the user name and password.
- -- But otherwise it masks the upload ones. Either need to
- -- share the options or make then distinct. In any case
- -- they should probably be per-server.
-
- ++ [ viewAsFieldDescr
- $ optionDistPref
- (configDistPref . savedConfigureFlags)
- (\distPref config ->
- config
- { savedConfigureFlags = (savedConfigureFlags config) {
- configDistPref = distPref }
- , savedHaddockFlags = (savedHaddockFlags config) {
- haddockDistPref = distPref }
- }
- )
- ParseArgs
- ]
-
where
toSavedConfig lift options exclusions replacements =
[ lift (fromMaybe field replacement)
| opt <- options
- , let field = viewAsFieldDescr opt
- name = fieldName field
+ , let field = viewAsFieldDescr opt
+ name = fieldName field
replacement = find ((== name) . fieldName) replacements
- , name `notElem` exclusions ]
+ , name `notElem` exclusions
+ ]
- showRelaxDeps Nothing = mempty
- showRelaxDeps (Just rd) | isRelaxDeps rd = Disp.text "True"
- | otherwise = Disp.text "False"
+ showRelaxDeps Nothing = mempty
+ showRelaxDeps (Just rd)
+ | isRelaxDeps rd = Disp.text "True"
+ | otherwise = Disp.text "False"
- toRelaxDeps True = RelaxDepsAll
+ toRelaxDeps True = RelaxDepsAll
toRelaxDeps False = mempty
-
-- TODO: next step, make the deprecated fields elicit a warning.
--
deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
deprecatedFieldDescriptions =
[ liftGlobalFlag $
- listFieldParsec "repos"
- pretty parsec
- (fromNubList . globalRemoteRepos)
- (\rs cfg -> cfg { globalRemoteRepos = toNubList rs })
+ listFieldParsec
+ "repos"
+ pretty
+ parsec
+ (fromNubList . globalRemoteRepos)
+ (\rs cfg -> cfg{globalRemoteRepos = toNubList rs})
, liftGlobalFlag $
- simpleFieldParsec "cachedir"
- (Disp.text . fromFlagOrDefault "") (optionalFlag parsecFilePath)
- globalCacheDir (\d cfg -> cfg { globalCacheDir = d })
+ simpleFieldParsec
+ "cachedir"
+ (Disp.text . fromFlagOrDefault "")
+ (optionalFlag parsecFilePath)
+ globalCacheDir
+ (\d cfg -> cfg{globalCacheDir = d})
, liftUploadFlag $
- simpleFieldParsec "hackage-username"
- (Disp.text . fromFlagOrDefault "" . fmap unUsername)
- (optionalFlag (fmap Username parsecToken))
- uploadUsername (\d cfg -> cfg { uploadUsername = d })
+ simpleFieldParsec
+ "hackage-username"
+ (Disp.text . fromFlagOrDefault "" . fmap unUsername)
+ (optionalFlag (fmap Username parsecToken))
+ uploadUsername
+ (\d cfg -> cfg{uploadUsername = d})
, liftUploadFlag $
- simpleFieldParsec "hackage-password"
- (Disp.text . fromFlagOrDefault "" . fmap unPassword)
- (optionalFlag (fmap Password parsecToken))
- uploadPassword (\d cfg -> cfg { uploadPassword = d })
+ simpleFieldParsec
+ "hackage-password"
+ (Disp.text . fromFlagOrDefault "" . fmap unPassword)
+ (optionalFlag (fmap Password parsecToken))
+ uploadPassword
+ (\d cfg -> cfg{uploadPassword = d})
, liftUploadFlag $
- spaceListField "hackage-password-command"
- Disp.text parseTokenQ
- (fromFlagOrDefault [] . uploadPasswordCmd)
- (\d cfg -> cfg { uploadPasswordCmd = Flag d })
+ spaceListField
+ "hackage-password-command"
+ Disp.text
+ parseTokenQ
+ (fromFlagOrDefault [] . uploadPasswordCmd)
+ (\d cfg -> cfg{uploadPasswordCmd = Flag d})
]
- ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs)
- installDirsFields
- ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs)
- installDirsFields
+ ++ map
+ (modifyFieldName ("user-" ++) . liftUserInstallDirs)
+ installDirsFields
+ ++ map
+ (modifyFieldName ("global-" ++) . liftGlobalInstallDirs)
+ installDirsFields
where
optionalFlag :: ParsecParser a -> ParsecParser (Flag a)
optionalFlag p = toFlag <$> p <|> pure mempty
modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
- modifyFieldName f d = d { fieldName = f (fieldName d) }
-
-liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))
- -> FieldDescr SavedConfig
-liftUserInstallDirs = liftField
- savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })
-
-liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))
- -> FieldDescr SavedConfig
+ modifyFieldName f d = d{fieldName = f (fieldName d)}
+
+liftUserInstallDirs
+ :: FieldDescr (InstallDirs (Flag PathTemplate))
+ -> FieldDescr SavedConfig
+liftUserInstallDirs =
+ liftField
+ savedUserInstallDirs
+ (\flags conf -> conf{savedUserInstallDirs = flags})
+
+liftGlobalInstallDirs
+ :: FieldDescr (InstallDirs (Flag PathTemplate))
+ -> FieldDescr SavedConfig
liftGlobalInstallDirs =
- liftField savedGlobalInstallDirs
- (\flags conf -> conf { savedGlobalInstallDirs = flags })
+ liftField
+ savedGlobalInstallDirs
+ (\flags conf -> conf{savedGlobalInstallDirs = flags})
liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig
-liftGlobalFlag = liftField
- savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })
+liftGlobalFlag =
+ liftField
+ savedGlobalFlags
+ (\flags conf -> conf{savedGlobalFlags = flags})
liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
-liftConfigFlag = liftField
- savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })
+liftConfigFlag =
+ liftField
+ savedConfigureFlags
+ (\flags conf -> conf{savedConfigureFlags = flags})
liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
-liftConfigExFlag = liftField
- savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })
+liftConfigExFlag =
+ liftField
+ savedConfigureExFlags
+ (\flags conf -> conf{savedConfigureExFlags = flags})
liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
-liftInstallFlag = liftField
- savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })
+liftInstallFlag =
+ liftField
+ savedInstallFlags
+ (\flags conf -> conf{savedInstallFlags = flags})
liftClientInstallFlag :: FieldDescr ClientInstallFlags -> FieldDescr SavedConfig
liftClientInstallFlag =
- liftField savedClientInstallFlags
- (\flags conf -> conf { savedClientInstallFlags = flags })
+ liftField
+ savedClientInstallFlags
+ (\flags conf -> conf{savedClientInstallFlags = flags})
liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
-liftUploadFlag = liftField
- savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })
+liftUploadFlag =
+ liftField
+ savedUploadFlags
+ (\flags conf -> conf{savedUploadFlags = flags})
liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
-liftReportFlag = liftField
- savedReportFlags (\flags conf -> conf { savedReportFlags = flags })
-
-parseConfig :: ConstraintSource
- -> SavedConfig
- -> BS.ByteString
- -> ParseResult SavedConfig
+liftReportFlag =
+ liftField
+ savedReportFlags
+ (\flags conf -> conf{savedReportFlags = flags})
+
+parseConfig
+ :: ConstraintSource
+ -> SavedConfig
+ -> BS.ByteString
+ -> ParseResult SavedConfig
parseConfig src initial = \str -> do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
config <- parse others
- let init0 = savedInitFlags config
- user0 = savedUserInstallDirs config
+ let init0 = savedInitFlags config
+ user0 = savedUserInstallDirs config
global0 = savedGlobalInstallDirs config
(remoteRepoSections0, localRepoSections0, haddockFlags, initFlags, user, global, paths, args) <-
- foldM parseSections
- ([], [], savedHaddockFlags config, init0, user0, global0, [], [])
- knownSections
+ foldM
+ parseSections
+ ([], [], savedHaddockFlags config, init0, user0, global0, [], [])
+ knownSections
let remoteRepoSections =
- reverse
- . nubBy ((==) `on` remoteRepoName)
- $ remoteRepoSections0
+ reverse
+ . nubBy ((==) `on` remoteRepoName)
+ $ remoteRepoSections0
let localRepoSections =
- reverse
- . nubBy ((==) `on` localRepoName)
- $ localRepoSections0
-
- return . fixConfigMultilines $ config {
- savedGlobalFlags = (savedGlobalFlags config) {
- globalRemoteRepos = toNubList remoteRepoSections,
- globalLocalNoIndexRepos = toNubList localRepoSections,
- -- the global extra prog path comes from the configure flag prog path
- globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)
- },
- savedConfigureFlags = (savedConfigureFlags config) {
- configProgramPaths = paths,
- configProgramArgs = args
- },
- savedHaddockFlags = haddockFlags,
- savedInitFlags = initFlags,
- savedUserInstallDirs = user,
- savedGlobalInstallDirs = global
- }
-
+ reverse
+ . nubBy ((==) `on` localRepoName)
+ $ localRepoSections0
+
+ return . fixConfigMultilines $
+ config
+ { savedGlobalFlags =
+ (savedGlobalFlags config)
+ { globalRemoteRepos = toNubList remoteRepoSections
+ , globalLocalNoIndexRepos = toNubList localRepoSections
+ , -- the global extra prog path comes from the configure flag prog path
+ globalProgPathExtra = configProgramPathExtra (savedConfigureFlags config)
+ }
+ , savedConfigureFlags =
+ (savedConfigureFlags config)
+ { configProgramPaths = paths
+ , configProgramArgs = args
+ }
+ , savedHaddockFlags = haddockFlags
+ , savedInitFlags = initFlags
+ , savedUserInstallDirs = user
+ , savedGlobalInstallDirs = global
+ }
where
- isKnownSection (ParseUtils.Section _ "repository" _ _) = True
- isKnownSection (ParseUtils.F _ "remote-repo" _) = True
- isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
- isKnownSection (ParseUtils.Section _ "init" _ _) = True
- isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
- isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
+ isKnownSection (ParseUtils.Section _ "repository" _ _) = True
+ isKnownSection (ParseUtils.F _ "remote-repo" _) = True
+ isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
+ isKnownSection (ParseUtils.Section _ "init" _ _) = True
+ isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
+ isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
- isKnownSection _ = False
+ isKnownSection _ = False
-- Attempt to split fields that can represent lists of paths into
-- actual lists on failure, leave the field untouched.
splitMultiPath :: [String] -> [String]
splitMultiPath [s] = case runP 0 "" (parseOptCommaList parseTokenQ) s of
- ParseOk _ res -> res
- _ -> [s]
+ ParseOk _ res -> res
+ _ -> [s]
splitMultiPath xs = xs
-- This is a fixup, pending a full config parser rewrite, to
-- ensure that config fields which can be comma-separated lists
-- actually parse as comma-separated lists.
- fixConfigMultilines conf = conf {
- savedConfigureFlags =
- let scf = savedConfigureFlags conf
- in scf {
- configProgramPathExtra =
- toNubList $ splitMultiPath
- (fromNubList $ configProgramPathExtra scf)
- , configExtraLibDirs = splitMultiPath
- (configExtraLibDirs scf)
- , configExtraLibDirsStatic = splitMultiPath
- (configExtraLibDirsStatic scf)
- , configExtraFrameworkDirs = splitMultiPath
- (configExtraFrameworkDirs scf)
- , configExtraIncludeDirs = splitMultiPath
- (configExtraIncludeDirs scf)
- , configConfigureArgs = splitMultiPath
- (configConfigureArgs scf)
- }
- }
+ fixConfigMultilines conf =
+ conf
+ { savedConfigureFlags =
+ let scf = savedConfigureFlags conf
+ in scf
+ { configProgramPathExtra =
+ toNubList $
+ splitMultiPath
+ (fromNubList $ configProgramPathExtra scf)
+ , configExtraLibDirs =
+ splitMultiPath
+ (configExtraLibDirs scf)
+ , configExtraLibDirsStatic =
+ splitMultiPath
+ (configExtraLibDirsStatic scf)
+ , configExtraFrameworkDirs =
+ splitMultiPath
+ (configExtraFrameworkDirs scf)
+ , configExtraIncludeDirs =
+ splitMultiPath
+ (configExtraIncludeDirs scf)
+ , configConfigureArgs =
+ splitMultiPath
+ (configConfigureArgs scf)
+ }
+ }
- parse = parseFields (configFieldDescriptions src
- ++ deprecatedFieldDescriptions) initial
-
- parseSections (rs, ls, h, i, u, g, p, a)
- (ParseUtils.Section lineno "repository" name fs) = do
- name' <- maybe (ParseFailed $ NoParse "repository name" lineno) return $
- simpleParsec name
- r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
- r'' <- postProcessRepo lineno name r'
- case r'' of
- Left local -> return (rs, local:ls, h, i, u, g, p, a)
- Right remote -> return (remote:rs, ls, h, i, u, g, p, a)
-
- parseSections (rs, ls, h, i, u, g, p, a)
- (ParseUtils.F lno "remote-repo" raw) = do
- let mr' = simpleParsec raw
- r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
- return (r':rs, ls, h, i, u, g, p, a)
-
- parseSections accum@(rs, ls, h, i, u, g, p, a)
- (ParseUtils.Section _ "haddock" name fs)
- | name == "" = do h' <- parseFields haddockFlagsFields h fs
- return (rs, ls, h', i, u, g, p, a)
- | otherwise = do
- warning "The 'haddock' section should be unnamed"
- return accum
-
- parseSections accum@(rs, ls, h, i, u, g, p, a)
- (ParseUtils.Section _ "init" name fs)
- | name == "" = do i' <- parseFields initFlagsFields i fs
- return (rs, ls, h, i', u, g, p, a)
- | otherwise = do
- warning "The 'init' section should be unnamed"
- return accum
-
- parseSections accum@(rs, ls, h, i, u, g, p, a)
- (ParseUtils.Section _ "install-dirs" name fs)
- | name' == "user" = do u' <- parseFields installDirsFields u fs
- return (rs, ls, h, i, u', g, p, a)
- | name' == "global" = do g' <- parseFields installDirsFields g fs
- return (rs, ls, h, i, u, g', p, a)
- | otherwise = do
- warning "The 'install-paths' section should be for 'user' or 'global'"
- return accum
- where name' = lowercase name
- parseSections accum@(rs, ls, h, i, u, g, p, a)
- (ParseUtils.Section _ "program-locations" name fs)
- | name == "" = do p' <- parseFields withProgramsFields p fs
- return (rs, ls, h, i, u, g, p', a)
- | otherwise = do
- warning "The 'program-locations' section should be unnamed"
- return accum
- parseSections accum@(rs, ls, h, i, u, g, p, a)
- (ParseUtils.Section _ "program-default-options" name fs)
- | name == "" = do a' <- parseFields withProgramOptionsFields a fs
- return (rs, ls, h, i, u, g, p, a')
- | otherwise = do
- warning "The 'program-default-options' section should be unnamed"
- return accum
+ parse =
+ parseFields
+ ( configFieldDescriptions src
+ ++ deprecatedFieldDescriptions
+ )
+ initial
+
+ parseSections
+ (rs, ls, h, i, u, g, p, a)
+ (ParseUtils.Section lineno "repository" name fs) = do
+ name' <-
+ maybe (ParseFailed $ NoParse "repository name" lineno) return $
+ simpleParsec name
+ r' <- parseFields remoteRepoFields (emptyRemoteRepo name') fs
+ r'' <- postProcessRepo lineno name r'
+ case r'' of
+ Left local -> return (rs, local : ls, h, i, u, g, p, a)
+ Right remote -> return (remote : rs, ls, h, i, u, g, p, a)
+ parseSections
+ (rs, ls, h, i, u, g, p, a)
+ (ParseUtils.F lno "remote-repo" raw) = do
+ let mr' = simpleParsec raw
+ r' <- maybe (ParseFailed $ NoParse "remote-repo" lno) return mr'
+ return (r' : rs, ls, h, i, u, g, p, a)
+ parseSections
+ accum@(rs, ls, h, i, u, g, p, a)
+ (ParseUtils.Section _ "haddock" name fs)
+ | name == "" = do
+ h' <- parseFields haddockFlagsFields h fs
+ return (rs, ls, h', i, u, g, p, a)
+ | otherwise = do
+ warning "The 'haddock' section should be unnamed"
+ return accum
+ parseSections
+ accum@(rs, ls, h, i, u, g, p, a)
+ (ParseUtils.Section _ "init" name fs)
+ | name == "" = do
+ i' <- parseFields initFlagsFields i fs
+ return (rs, ls, h, i', u, g, p, a)
+ | otherwise = do
+ warning "The 'init' section should be unnamed"
+ return accum
+ parseSections
+ accum@(rs, ls, h, i, u, g, p, a)
+ (ParseUtils.Section _ "install-dirs" name fs)
+ | name' == "user" = do
+ u' <- parseFields installDirsFields u fs
+ return (rs, ls, h, i, u', g, p, a)
+ | name' == "global" = do
+ g' <- parseFields installDirsFields g fs
+ return (rs, ls, h, i, u, g', p, a)
+ | otherwise = do
+ warning "The 'install-paths' section should be for 'user' or 'global'"
+ return accum
+ where
+ name' = lowercase name
+ parseSections
+ accum@(rs, ls, h, i, u, g, p, a)
+ (ParseUtils.Section _ "program-locations" name fs)
+ | name == "" = do
+ p' <- parseFields withProgramsFields p fs
+ return (rs, ls, h, i, u, g, p', a)
+ | otherwise = do
+ warning "The 'program-locations' section should be unnamed"
+ return accum
+ parseSections
+ accum@(rs, ls, h, i, u, g, p, a)
+ (ParseUtils.Section _ "program-default-options" name fs)
+ | name == "" = do
+ a' <- parseFields withProgramOptionsFields a fs
+ return (rs, ls, h, i, u, g, p, a')
+ | otherwise = do
+ warning "The 'program-default-options' section should be unnamed"
+ return accum
parseSections accum f = do
warning $ "Unrecognized stanza on line " ++ show (lineNo f)
return accum
postProcessRepo :: Int -> String -> RemoteRepo -> ParseResult (Either LocalRepo RemoteRepo)
postProcessRepo lineno reponameStr repo0 = do
- when (null reponameStr) $
- syntaxError lineno $ "a 'repository' section requires the "
- ++ "repository name as an argument"
-
- reponame <- maybe (fail $ "Invalid repository name " ++ reponameStr) return $
- simpleParsec reponameStr
-
- case uriScheme (remoteRepoURI repo0) of
- -- TODO: check that there are no authority, query or fragment
- -- Note: the trailing colon is important
- "file+noindex:" -> do
- let uri = remoteRepoURI repo0
- return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")
-
- _ -> do
- let repo = repo0 { remoteRepoName = reponame }
-
- when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $
- warning $ "'key-threshold' for repository "
- ++ show (remoteRepoName repo)
- ++ " higher than number of keys"
-
- when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $
- warning $ "'root-keys' for repository "
- ++ show (remoteRepoName repo)
- ++ " non-empty, but 'secure' not set to True."
-
- return $ Right repo
+ when (null reponameStr) $
+ syntaxError lineno $
+ "a 'repository' section requires the "
+ ++ "repository name as an argument"
+
+ reponame <-
+ maybe (fail $ "Invalid repository name " ++ reponameStr) return $
+ simpleParsec reponameStr
+
+ case uriScheme (remoteRepoURI repo0) of
+ -- TODO: check that there are no authority, query or fragment
+ -- Note: the trailing colon is important
+ "file+noindex:" -> do
+ let uri = remoteRepoURI repo0
+ return $ Left $ LocalRepo reponame (uriPath uri) (uriFragment uri == "#shared-cache")
+ _ -> do
+ let repo = repo0{remoteRepoName = reponame}
+
+ when (remoteRepoKeyThreshold repo > length (remoteRepoRootKeys repo)) $
+ warning $
+ "'key-threshold' for repository "
+ ++ show (remoteRepoName repo)
+ ++ " higher than number of keys"
+
+ when (not (null (remoteRepoRootKeys repo)) && remoteRepoSecure repo /= Just True) $
+ warning $
+ "'root-keys' for repository "
+ ++ show (remoteRepoName repo)
+ ++ " non-empty, but 'secure' not set to True."
+
+ return $ Right repo
showConfig :: SavedConfig -> String
showConfig = showConfigWithComments mempty
showConfigWithComments :: SavedConfig -> SavedConfig -> String
-showConfigWithComments comment vals = Disp.render $
- case fmap (uncurry ppRemoteRepoSection)
- (zip (getRemoteRepos comment) (getRemoteRepos vals)) of
- [] -> Disp.text ""
- (x:xs) -> foldl' (\ r r' -> r $+$ Disp.text "" $+$ r') x xs
- $+$ Disp.text ""
- $+$ ppFields
- (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))
- mcomment vals
- $+$ Disp.text ""
- $+$ ppSection "haddock" "" haddockFlagsFields
- (fmap savedHaddockFlags mcomment) (savedHaddockFlags vals)
- $+$ Disp.text ""
- $+$ ppSection "init" "" initFlagsFields
- (fmap savedInitFlags mcomment) (savedInitFlags vals)
- $+$ Disp.text ""
- $+$ installDirsSection "user" savedUserInstallDirs
- $+$ Disp.text ""
- $+$ installDirsSection "global" savedGlobalInstallDirs
- $+$ Disp.text ""
- $+$ configFlagsSection "program-locations" withProgramsFields
- configProgramPaths
- $+$ Disp.text ""
- $+$ configFlagsSection "program-default-options" withProgramOptionsFields
- configProgramArgs
+showConfigWithComments comment vals =
+ Disp.render $
+ case fmap
+ (uncurry ppRemoteRepoSection)
+ (zip (getRemoteRepos comment) (getRemoteRepos vals)) of
+ [] -> Disp.text ""
+ (x : xs) -> foldl' (\r r' -> r $+$ Disp.text "" $+$ r') x xs
+ $+$ Disp.text ""
+ $+$ ppFields
+ (skipSomeFields (configFieldDescriptions ConstraintSourceUnknown))
+ mcomment
+ vals
+ $+$ Disp.text ""
+ $+$ ppSection
+ "haddock"
+ ""
+ haddockFlagsFields
+ (fmap savedHaddockFlags mcomment)
+ (savedHaddockFlags vals)
+ $+$ Disp.text ""
+ $+$ ppSection
+ "init"
+ ""
+ initFlagsFields
+ (fmap savedInitFlags mcomment)
+ (savedInitFlags vals)
+ $+$ Disp.text ""
+ $+$ installDirsSection "user" savedUserInstallDirs
+ $+$ Disp.text ""
+ $+$ installDirsSection "global" savedGlobalInstallDirs
+ $+$ Disp.text ""
+ $+$ configFlagsSection
+ "program-locations"
+ withProgramsFields
+ configProgramPaths
+ $+$ Disp.text ""
+ $+$ configFlagsSection
+ "program-default-options"
+ withProgramOptionsFields
+ configProgramArgs
where
getRemoteRepos = fromNubList . globalRemoteRepos . savedGlobalFlags
mcomment = Just comment
installDirsSection name field =
- ppSection "install-dirs" name installDirsFields
- (fmap field mcomment) (field vals)
+ ppSection
+ "install-dirs"
+ name
+ installDirsFields
+ (fmap field mcomment)
+ (field vals)
configFlagsSection name fields field =
- ppSection name "" fields
- (fmap (field . savedConfigureFlags) mcomment)
- ((field . savedConfigureFlags) vals)
+ ppSection
+ name
+ ""
+ fields
+ (fmap (field . savedConfigureFlags) mcomment)
+ ((field . savedConfigureFlags) vals)
-- skip fields based on field name. currently only skips "remote-repo",
-- because that is rendered as a section. (see 'ppRemoteRepoSection'.)
@@ -1414,33 +1687,50 @@ installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
installDirsFields = map viewAsFieldDescr installDirsOptions
ppRemoteRepoSection :: RemoteRepo -> RemoteRepo -> Doc
-ppRemoteRepoSection def vals = ppSection "repository" (unRepoName (remoteRepoName vals))
- remoteRepoFields (Just def) vals
+ppRemoteRepoSection def vals =
+ ppSection
+ "repository"
+ (unRepoName (remoteRepoName vals))
+ remoteRepoFields
+ (Just def)
+ vals
remoteRepoFields :: [FieldDescr RemoteRepo]
remoteRepoFields =
- [ simpleField "url"
- (text . show) (parseTokenQ >>= parseURI')
- remoteRepoURI (\x repo -> repo { remoteRepoURI = x })
- , simpleFieldParsec "secure"
- showSecure (Just `fmap` parsec)
- remoteRepoSecure (\x repo -> repo { remoteRepoSecure = x })
- , listField "root-keys"
- text parseTokenQ
- remoteRepoRootKeys (\x repo -> repo { remoteRepoRootKeys = x })
- , simpleFieldParsec "key-threshold"
- showThreshold P.integral
- remoteRepoKeyThreshold (\x repo -> repo { remoteRepoKeyThreshold = x })
+ [ simpleField
+ "url"
+ (text . show)
+ (parseTokenQ >>= parseURI')
+ remoteRepoURI
+ (\x repo -> repo{remoteRepoURI = x})
+ , simpleFieldParsec
+ "secure"
+ showSecure
+ (Just `fmap` parsec)
+ remoteRepoSecure
+ (\x repo -> repo{remoteRepoSecure = x})
+ , listField
+ "root-keys"
+ text
+ parseTokenQ
+ remoteRepoRootKeys
+ (\x repo -> repo{remoteRepoRootKeys = x})
+ , simpleFieldParsec
+ "key-threshold"
+ showThreshold
+ P.integral
+ remoteRepoKeyThreshold
+ (\x repo -> repo{remoteRepoKeyThreshold = x})
]
where
parseURI' uriString =
case parseURI uriString of
- Nothing -> fail $ "remote-repo: no parse on " ++ show uriString
+ Nothing -> fail $ "remote-repo: no parse on " ++ show uriString
Just uri -> return uri
- showSecure Nothing = mempty -- default 'secure' setting
- showSecure (Just True) = text "True" -- user explicitly enabled it
- showSecure (Just False) = text "False" -- user explicitly disabled it
+ showSecure Nothing = mempty -- default 'secure' setting
+ showSecure (Just True) = text "True" -- user explicitly enabled it
+ showSecure (Just False) = text "False" -- user explicitly disabled it
-- If the key-threshold is set to 0, we omit it as this is the default
-- and it looks odd to have a value for key-threshold but not for 'secure'
@@ -1451,28 +1741,48 @@ remoteRepoFields =
-- | Fields for the 'haddock' section.
haddockFlagsFields :: [FieldDescr HaddockFlags]
-haddockFlagsFields = [ field
- | opt <- haddockOptions ParseArgs
- , let field = viewAsFieldDescr opt
- name = fieldName field
- , name `notElem` exclusions ]
+haddockFlagsFields =
+ [ field
+ | opt <- haddockOptions ParseArgs
+ , let field = viewAsFieldDescr opt
+ name = fieldName field
+ , name `notElem` exclusions
+ ]
where
exclusions = ["verbose", "builddir", "for-hackage"]
-- | Fields for the 'init' section.
initFlagsFields :: [FieldDescr IT.InitFlags]
-initFlagsFields = [ field
- | opt <- initOptions ParseArgs
- , let field = viewAsFieldDescr opt
- name = fieldName field
- , name `notElem` exclusions ]
+initFlagsFields =
+ [ field
+ | opt <- initOptions ParseArgs
+ , let field = viewAsFieldDescr opt
+ name = fieldName field
+ , name `notElem` exclusions
+ ]
where
exclusions =
- [ "author", "email", "overwrite"
- , "package-dir", "packagedir", "package-name", "version", "homepage"
- , "synopsis", "category", "extra-source-file", "lib", "exe", "libandexe"
- , "main-is", "expose-module", "exposed-modules", "extension"
- , "dependency", "build-tool", "with-compiler"
+ [ "author"
+ , "email"
+ , "overwrite"
+ , "package-dir"
+ , "packagedir"
+ , "package-name"
+ , "version"
+ , "homepage"
+ , "synopsis"
+ , "category"
+ , "extra-source-file"
+ , "lib"
+ , "exe"
+ , "libandexe"
+ , "main-is"
+ , "expose-module"
+ , "exposed-modules"
+ , "extension"
+ , "dependency"
+ , "build-tool"
+ , "with-compiler"
, "verbose"
]
@@ -1480,28 +1790,36 @@ initFlagsFields = [ field
withProgramsFields :: [FieldDescr [(String, FilePath)]]
withProgramsFields =
map viewAsFieldDescr $
- programDbPaths' (++ "-location") defaultProgramDb
- ParseArgs id (++)
+ programDbPaths'
+ (++ "-location")
+ defaultProgramDb
+ ParseArgs
+ id
+ (++)
-- | Fields for the 'program-default-options' section.
withProgramOptionsFields :: [FieldDescr [(String, [String])]]
withProgramOptionsFields =
map viewAsFieldDescr $
- programDbOptions defaultProgramDb ParseArgs id (++)
+ programDbOptions defaultProgramDb ParseArgs id (++)
parseExtraLines :: Verbosity -> [String] -> IO SavedConfig
parseExtraLines verbosity extraLines =
- case parseConfig (ConstraintSourceMainConfig "additional lines")
- mempty (toUTF8BS (unlines extraLines)) of
+ case parseConfig
+ (ConstraintSourceMainConfig "additional lines")
+ mempty
+ (toUTF8BS (unlines extraLines)) of
ParseFailed err ->
let (line, msg) = locatedErrorMsg err
- in die' verbosity $
- "Error parsing additional config lines\n"
- ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg
+ in die' verbosity $
+ "Error parsing additional config lines\n"
+ ++ maybe "" (\n -> ':' : show n) line
+ ++ ":\n"
+ ++ msg
ParseOk [] r -> return r
ParseOk ws _ ->
die' verbosity $
- unlines (map (showPWarning "Error parsing additional config lines") ws)
+ unlines (map (showPWarning "Error parsing additional config lines") ws)
-- | Get the differences (as a pseudo code diff) between the user's
-- config file and the one that cabal would generate if it didn't exist.
@@ -1511,57 +1829,66 @@ userConfigDiff verbosity globalFlags extraLines = do
extraConfig <- parseExtraLines verbosity extraLines
testConfig <- initialSavedConfig
return $
- reverse . foldl' createDiff [] . M.toList
- $ M.unionWith combine
- (M.fromList . map justFst $ filterShow testConfig)
- (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))
+ reverse . foldl' createDiff [] . M.toList $
+ M.unionWith
+ combine
+ (M.fromList . map justFst $ filterShow testConfig)
+ (M.fromList . map justSnd $ filterShow (userConfig `mappend` extraConfig))
where
justFst (a, b) = (a, (Just b, Nothing))
justSnd (a, b) = (a, (Nothing, Just b))
combine (Nothing, Just b) (Just a, Nothing) = (Just a, Just b)
combine (Just a, Nothing) (Nothing, Just b) = (Just a, Just b)
- combine x y = error $ "Can't happen : userConfigDiff "
- ++ show x ++ " " ++ show y
+ combine x y =
+ error $
+ "Can't happen : userConfigDiff "
+ ++ show x
+ ++ " "
+ ++ show y
createDiff :: [String] -> (String, (Maybe String, Maybe String)) -> [String]
createDiff acc (key, (Just a, Just b))
- | a == b = acc
- | otherwise = ("+ " ++ key ++ ": " ++ b)
- : ("- " ++ key ++ ": " ++ a) : acc
+ | a == b = acc
+ | otherwise =
+ ("+ " ++ key ++ ": " ++ b)
+ : ("- " ++ key ++ ": " ++ a)
+ : acc
createDiff acc (key, (Nothing, Just b)) = ("+ " ++ key ++ ": " ++ b) : acc
createDiff acc (key, (Just a, Nothing)) = ("- " ++ key ++ ": " ++ a) : acc
createDiff acc (_, (Nothing, Nothing)) = acc
filterShow :: SavedConfig -> [(String, String)]
- filterShow cfg = map keyValueSplit
+ filterShow cfg =
+ map keyValueSplit
. filter (\s -> not (null s) && ':' `elem` s)
. map nonComment
. lines
$ showConfig cfg
nonComment [] = []
- nonComment ('-':'-':_) = []
- nonComment (x:xs) = x : nonComment xs
+ nonComment ('-' : '-' : _) = []
+ nonComment (x : xs) = x : nonComment xs
topAndTail = reverse . dropWhile isSpace . reverse . dropWhile isSpace
keyValueSplit s =
- let (left, right) = break (== ':') s
- in (topAndTail left, topAndTail (drop 1 right))
-
+ let (left, right) = break (== ':') s
+ in (topAndTail left, topAndTail (drop 1 right))
-- | Update the user's config file keeping the user's customizations.
userConfigUpdate :: Verbosity -> GlobalFlags -> [String] -> IO ()
userConfigUpdate verbosity globalFlags extraLines = do
- userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
+ userConfig <- loadRawConfig normal (globalConfigFile globalFlags)
extraConfig <- parseExtraLines verbosity extraLines
- newConfig <- initialSavedConfig
+ newConfig <- initialSavedConfig
commentConf <- commentSavedConfig
cabalFile <- getConfigFilePath $ globalConfigFile globalFlags
let backup = cabalFile ++ ".backup"
notice verbosity $ "Renaming " ++ cabalFile ++ " to " ++ backup ++ "."
renameFile cabalFile backup
notice verbosity $ "Writing merged config to " ++ cabalFile ++ "."
- writeConfigFile cabalFile commentConf
+ writeConfigFile
+ cabalFile
+ commentConf
(newConfig `mappend` userConfig `mappend` extraConfig)
diff --git a/cabal-install/src/Distribution/Client/Configure.hs b/cabal-install/src/Distribution/Client/Configure.hs
index 2cbe16096a456e7d1c89be2fae4fea793356f05b..d0abdac34304a7c12473706eff6db45e78a5a66e 100644
--- a/cabal-install/src/Distribution/Client/Configure.hs
+++ b/cabal-install/src/Distribution/Client/Configure.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Configure
-- Copyright : (c) David Himmelstrup 2005,
@@ -10,78 +14,122 @@
-- Portability : portable
--
-- High level interface to configuring a package.
------------------------------------------------------------------------------
-module Distribution.Client.Configure (
- configure,
- configureSetupScript,
- chooseCabalVersion,
- checkConfigExFlags,
+module Distribution.Client.Configure
+ ( configure
+ , configureSetupScript
+ , chooseCabalVersion
+ , checkConfigExFlags
+
-- * Saved configure flags
- readConfigFlagsFrom, readConfigFlags,
- cabalConfigFlagsFile,
- writeConfigFlagsTo, writeConfigFlags,
+ , readConfigFlagsFrom
+ , readConfigFlags
+ , cabalConfigFlagsFile
+ , writeConfigFlagsTo
+ , writeConfigFlags
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Utils.Generic (safeHead)
+import Prelude ()
import Distribution.Client.Dependency
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import Distribution.Client.IndexUtils as IndexUtils
- ( getSourcePackages, getInstalledPackages )
+ ( getInstalledPackages
+ , getSourcePackages
+ )
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.JobControl (Lock)
import Distribution.Client.Setup
- ( ConfigExFlags(..), RepoContext(..)
- , configureCommand, configureExCommand, filterConfigureFlags )
-import Distribution.Client.Types as Source
+ ( ConfigExFlags (..)
+ , RepoContext (..)
+ , configureCommand
+ , configureExCommand
+ , filterConfigureFlags
+ )
import Distribution.Client.SetupWrapper
- ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
+ ( SetupScriptOptions (..)
+ , defaultSetupScriptOptions
+ , setupWrapper
+ )
+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import Distribution.Client.Targets
- ( userToPackageConstraint, userConstraintPackageName )
-import Distribution.Client.JobControl (Lock)
+ ( userConstraintPackageName
+ , userToPackageConstraint
+ )
+import Distribution.Client.Types as Source
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.ConstraintSource
-import Distribution.Solver.Types.LabeledPackageConstraint
-import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PackageIndex
- ( PackageIndex, elemByPackageName )
-import Distribution.Solver.Types.PkgConfigDb
- (PkgConfigDb, readPkgConfigDb)
-import Distribution.Solver.Types.SourcePackage
-
+import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackageIndex
+ ( PackageIndex
+ , elemByPackageName
+ )
+import Distribution.Solver.Types.PkgConfigDb
+ ( PkgConfigDb
+ , readPkgConfigDb
+ )
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SourcePackage
+
+import Distribution.Client.SavedFlags (readCommandFlags, writeCommandFlags)
+import Distribution.Package
+ ( Package (..)
+ , PackageId
+ , packageName
+ )
+import qualified Distribution.PackageDescription as PkgDesc
+import Distribution.PackageDescription.Configuration
+ ( finalizePD
+ )
import Distribution.Simple.Compiler
- ( Compiler, CompilerInfo, compilerInfo, PackageDB(..), PackageDBStack )
-import Distribution.Simple.Program (ProgramDb)
-import Distribution.Client.SavedFlags ( readCommandFlags, writeCommandFlags )
-import Distribution.Simple.Setup
- ( ConfigFlags(..)
- , fromFlag, toFlag, flagToMaybe, fromFlagOrDefault )
+ ( Compiler
+ , CompilerInfo
+ , PackageDB (..)
+ , PackageDBStack
+ , compilerInfo
+ )
import Distribution.Simple.PackageDescription
- ( readGenericPackageDescription )
+ ( readGenericPackageDescription
+ )
import Distribution.Simple.PackageIndex as PackageIndex
- ( InstalledPackageIndex, lookupPackageName )
-import Distribution.Package
- ( Package(..), packageName, PackageId )
+ ( InstalledPackageIndex
+ , lookupPackageName
+ )
+import Distribution.Simple.Program (ProgramDb)
+import Distribution.Simple.Setup
+ ( ConfigFlags (..)
+ , flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ , toFlag
+ )
+import Distribution.Simple.Utils as Utils
+ ( debug
+ , defaultPackageDesc
+ , die'
+ , notice
+ , warn
+ )
+import Distribution.System
+ ( Platform
+ )
import Distribution.Types.GivenComponent
- ( GivenComponent(..) )
+ ( GivenComponent (..)
+ )
import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint(..), thisPackageVersionConstraint )
-import qualified Distribution.PackageDescription as PkgDesc
-import Distribution.PackageDescription.Configuration
- ( finalizePD )
+ ( PackageVersionConstraint (..)
+ , thisPackageVersionConstraint
+ )
import Distribution.Version
- ( Version, anyVersion, thisVersion
- , VersionRange )
-import Distribution.Simple.Utils as Utils
- ( warn, notice, debug, die'
- , defaultPackageDesc )
-import Distribution.System
- ( Platform )
+ ( Version
+ , VersionRange
+ , anyVersion
+ , thisVersion
+ )
-import System.FilePath ( (</>) )
+import System.FilePath ((</>))
-- | Choose the Cabal version such that the setup scripts compiled against this
-- version will support the given command-line flags. Currently, it implements no
@@ -92,215 +140,286 @@ chooseCabalVersion _configExFlags maybeVersion =
maybe anyVersion thisVersion maybeVersion
-- | Configure the package found in the local directory
-configure :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> Platform
- -> ProgramDb
- -> ConfigFlags
- -> ConfigExFlags
- -> [String]
- -> IO ()
-configure verbosity packageDBs repoCtxt comp platform progdb
- configFlags configExFlags extraArgs = do
-
- installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
- sourcePkgDb <- getSourcePackages verbosity repoCtxt
- pkgConfigDb <- readPkgConfigDb verbosity progdb
-
- checkConfigExFlags verbosity installedPkgIndex
- (packageIndex sourcePkgDb) configExFlags
-
- progress <- planLocalPackage verbosity comp platform configFlags configExFlags
- installedPkgIndex sourcePkgDb pkgConfigDb
-
- notice verbosity "Resolving dependencies..."
- maybePlan <- foldProgress logMsg (return . Left) (return . Right)
- progress
- case maybePlan of
- Left message -> do
- warn verbosity $
- "solver failed to find a solution:\n"
- ++ message
- ++ "\nTrying configure anyway."
- setupWrapper verbosity (setupScriptOptions installedPkgIndex Nothing)
- Nothing configureCommand (const configFlags) (const extraArgs)
-
- Right installPlan0 ->
- let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
- in case fst (InstallPlan.ready installPlan) of
- [pkg@(ReadyPackage
- (ConfiguredPackage _ (SourcePackage _ _ (LocalUnpackedPackage _) _)
- _ _ _))] -> do
- configurePackage verbosity
- platform (compilerInfo comp)
- (setupScriptOptions installedPkgIndex (Just pkg))
- configFlags pkg extraArgs
-
- _ -> die' verbosity $ "internal error: configure install plan should have exactly "
- ++ "one local ready package."
-
- where
- setupScriptOptions :: InstalledPackageIndex
- -> Maybe ReadyPackage
- -> SetupScriptOptions
- setupScriptOptions =
- configureSetupScript
- packageDBs
+configure
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> ConfigFlags
+ -> ConfigExFlags
+ -> [String]
+ -> IO ()
+configure
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ platform
+ progdb
+ configFlags
+ configExFlags
+ extraArgs = do
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
+ sourcePkgDb <- getSourcePackages verbosity repoCtxt
+ pkgConfigDb <- readPkgConfigDb verbosity progdb
+
+ checkConfigExFlags
+ verbosity
+ installedPkgIndex
+ (packageIndex sourcePkgDb)
+ configExFlags
+
+ progress <-
+ planLocalPackage
+ verbosity
comp
platform
- progdb
- (fromFlagOrDefault
- (useDistPref defaultSetupScriptOptions)
- (configDistPref configFlags))
- (chooseCabalVersion
- configExFlags
- (flagToMaybe (configCabalVersion configExFlags)))
- Nothing
- False
-
- logMsg message rest = debug verbosity message >> rest
-
-configureSetupScript :: PackageDBStack
- -> Compiler
- -> Platform
- -> ProgramDb
- -> FilePath
- -> VersionRange
- -> Maybe Lock
- -> Bool
- -> InstalledPackageIndex
- -> Maybe ReadyPackage
- -> SetupScriptOptions
-configureSetupScript packageDBs
- comp
- platform
- progdb
- distPref
- cabalVersion
- lock
- forceExternal
- index
- mpkg
- = SetupScriptOptions {
- useCabalVersion = cabalVersion
- , useCabalSpecVersion = Nothing
- , useCompiler = Just comp
- , usePlatform = Just platform
- , usePackageDB = packageDBs'
- , usePackageIndex = index'
- , useProgramDb = progdb
- , useDistPref = distPref
- , useLoggingHandle = Nothing
- , useWorkingDir = Nothing
- , useExtraPathEnv = []
- , useExtraEnvOverrides = []
- , setupCacheLock = lock
- , useWin32CleanHack = False
- , forceExternalSetupMethod = forceExternal
- -- If we have explicit setup dependencies, list them; otherwise, we give
- -- the empty list of dependencies; ideally, we would fix the version of
- -- Cabal here, so that we no longer need the special case for that in
- -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet
- -- know the version of Cabal at this point, but only find this there.
- -- Therefore, for now, we just leave this blank.
- , useDependencies = fromMaybe [] explicitSetupDeps
- , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps
- , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps
- , isInteractive = False
- }
- where
- -- When we are compiling a legacy setup script without an explicit
- -- setup stanza, we typically want to allow the UserPackageDB for
- -- finding the Cabal lib when compiling any Setup.hs even if we're doing
- -- a global install. However we also allow looking in a specific package
- -- db.
- packageDBs' :: PackageDBStack
- index' :: Maybe InstalledPackageIndex
- (packageDBs', index') =
- case packageDBs of
- (GlobalPackageDB:dbs) | UserPackageDB `notElem` dbs
- , Nothing <- explicitSetupDeps
- -> (GlobalPackageDB:UserPackageDB:dbs, Nothing)
- -- but if the user is using an odd db stack, don't touch it
- _otherwise -> (packageDBs, Just index)
-
- maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo
- maybeSetupBuildInfo = do
- ReadyPackage cpkg <- mpkg
- let gpkg = srcpkgDescription (confPkgSource cpkg)
- PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
-
- -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If
- -- so, 'setup-depends' must not be exclusive. See #3199.
- defaultSetupDeps :: Bool
- defaultSetupDeps = maybe False PkgDesc.defaultSetupDepends
- maybeSetupBuildInfo
-
- explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]
- explicitSetupDeps = do
- -- Check if there is an explicit setup stanza.
- _buildInfo <- maybeSetupBuildInfo
- -- Return the setup dependencies computed by the solver
- ReadyPackage cpkg <- mpkg
- return [ ( cid, srcid )
- | ConfiguredId srcid
- (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) cid
- <- CD.setupDeps (confPkgDeps cpkg)
- ]
+ configFlags
+ configExFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+
+ notice verbosity "Resolving dependencies..."
+ maybePlan <-
+ foldProgress
+ logMsg
+ (return . Left)
+ (return . Right)
+ progress
+ case maybePlan of
+ Left message -> do
+ warn verbosity $
+ "solver failed to find a solution:\n"
+ ++ message
+ ++ "\nTrying configure anyway."
+ setupWrapper
+ verbosity
+ (setupScriptOptions installedPkgIndex Nothing)
+ Nothing
+ configureCommand
+ (const configFlags)
+ (const extraArgs)
+ Right installPlan0 ->
+ let installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
+ in case fst (InstallPlan.ready installPlan) of
+ [ pkg@( ReadyPackage
+ ( ConfiguredPackage
+ _
+ (SourcePackage _ _ (LocalUnpackedPackage _) _)
+ _
+ _
+ _
+ )
+ )
+ ] -> do
+ configurePackage
+ verbosity
+ platform
+ (compilerInfo comp)
+ (setupScriptOptions installedPkgIndex (Just pkg))
+ configFlags
+ pkg
+ extraArgs
+ _ ->
+ die' verbosity $
+ "internal error: configure install plan should have exactly "
+ ++ "one local ready package."
+ where
+ setupScriptOptions
+ :: InstalledPackageIndex
+ -> Maybe ReadyPackage
+ -> SetupScriptOptions
+ setupScriptOptions =
+ configureSetupScript
+ packageDBs
+ comp
+ platform
+ progdb
+ ( fromFlagOrDefault
+ (useDistPref defaultSetupScriptOptions)
+ (configDistPref configFlags)
+ )
+ ( chooseCabalVersion
+ configExFlags
+ (flagToMaybe (configCabalVersion configExFlags))
+ )
+ Nothing
+ False
+
+ logMsg message rest = debug verbosity message >> rest
+
+configureSetupScript
+ :: PackageDBStack
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> FilePath
+ -> VersionRange
+ -> Maybe Lock
+ -> Bool
+ -> InstalledPackageIndex
+ -> Maybe ReadyPackage
+ -> SetupScriptOptions
+configureSetupScript
+ packageDBs
+ comp
+ platform
+ progdb
+ distPref
+ cabalVersion
+ lock
+ forceExternal
+ index
+ mpkg =
+ SetupScriptOptions
+ { useCabalVersion = cabalVersion
+ , useCabalSpecVersion = Nothing
+ , useCompiler = Just comp
+ , usePlatform = Just platform
+ , usePackageDB = packageDBs'
+ , usePackageIndex = index'
+ , useProgramDb = progdb
+ , useDistPref = distPref
+ , useLoggingHandle = Nothing
+ , useWorkingDir = Nothing
+ , useExtraPathEnv = []
+ , useExtraEnvOverrides = []
+ , setupCacheLock = lock
+ , useWin32CleanHack = False
+ , forceExternalSetupMethod = forceExternal
+ , -- If we have explicit setup dependencies, list them; otherwise, we give
+ -- the empty list of dependencies; ideally, we would fix the version of
+ -- Cabal here, so that we no longer need the special case for that in
+ -- `compileSetupExecutable` in `externalSetupMethod`, but we don't yet
+ -- know the version of Cabal at this point, but only find this there.
+ -- Therefore, for now, we just leave this blank.
+ useDependencies = fromMaybe [] explicitSetupDeps
+ , useDependenciesExclusive = not defaultSetupDeps && isJust explicitSetupDeps
+ , useVersionMacros = not defaultSetupDeps && isJust explicitSetupDeps
+ , isInteractive = False
+ }
+ where
+ -- When we are compiling a legacy setup script without an explicit
+ -- setup stanza, we typically want to allow the UserPackageDB for
+ -- finding the Cabal lib when compiling any Setup.hs even if we're doing
+ -- a global install. However we also allow looking in a specific package
+ -- db.
+ packageDBs' :: PackageDBStack
+ index' :: Maybe InstalledPackageIndex
+ (packageDBs', index') =
+ case packageDBs of
+ (GlobalPackageDB : dbs)
+ | UserPackageDB `notElem` dbs
+ , Nothing <- explicitSetupDeps ->
+ (GlobalPackageDB : UserPackageDB : dbs, Nothing)
+ -- but if the user is using an odd db stack, don't touch it
+ _otherwise -> (packageDBs, Just index)
+
+ maybeSetupBuildInfo :: Maybe PkgDesc.SetupBuildInfo
+ maybeSetupBuildInfo = do
+ ReadyPackage cpkg <- mpkg
+ let gpkg = srcpkgDescription (confPkgSource cpkg)
+ PkgDesc.setupBuildInfo (PkgDesc.packageDescription gpkg)
+
+ -- Was a default 'custom-setup' stanza added by 'cabal-install' itself? If
+ -- so, 'setup-depends' must not be exclusive. See #3199.
+ defaultSetupDeps :: Bool
+ defaultSetupDeps =
+ maybe
+ False
+ PkgDesc.defaultSetupDepends
+ maybeSetupBuildInfo
+
+ explicitSetupDeps :: Maybe [(InstalledPackageId, PackageId)]
+ explicitSetupDeps = do
+ -- Check if there is an explicit setup stanza.
+ _buildInfo <- maybeSetupBuildInfo
+ -- Return the setup dependencies computed by the solver
+ ReadyPackage cpkg <- mpkg
+ return
+ [ (cid, srcid)
+ | ConfiguredId
+ srcid
+ (Just (PkgDesc.CLibName PkgDesc.LMainLibName))
+ cid <-
+ CD.setupDeps (confPkgDeps cpkg)
+ ]
-- | Warn if any constraints or preferences name packages that are not in the
-- source package index or installed package index.
-checkConfigExFlags :: Package pkg
- => Verbosity
- -> InstalledPackageIndex
- -> PackageIndex pkg
- -> ConfigExFlags
- -> IO ()
+checkConfigExFlags
+ :: Package pkg
+ => Verbosity
+ -> InstalledPackageIndex
+ -> PackageIndex pkg
+ -> ConfigExFlags
+ -> IO ()
checkConfigExFlags verbosity installedPkgIndex sourcePkgIndex flags = do
for_ (safeHead unknownConstraints) $ \h ->
- warn verbosity $ "Constraint refers to an unknown package: "
- ++ showConstraint h
+ warn verbosity $
+ "Constraint refers to an unknown package: "
+ ++ showConstraint h
for_ (safeHead unknownPreferences) $ \h ->
- warn verbosity $ "Preference refers to an unknown package: "
- ++ prettyShow h
+ warn verbosity $
+ "Preference refers to an unknown package: "
+ ++ prettyShow h
where
- unknownConstraints = filter (unknown . userConstraintPackageName . fst) $
- configExConstraints flags
- unknownPreferences = filter (unknown . \(PackageVersionConstraint name _) -> name) $
- configPreferences flags
- unknown pkg = null (PackageIndex.lookupPackageName installedPkgIndex pkg)
- && not (elemByPackageName sourcePkgIndex pkg)
+ unknownConstraints =
+ filter (unknown . userConstraintPackageName . fst) $
+ configExConstraints flags
+ unknownPreferences =
+ filter (unknown . \(PackageVersionConstraint name _) -> name) $
+ configPreferences flags
+ unknown pkg =
+ null (PackageIndex.lookupPackageName installedPkgIndex pkg)
+ && not (elemByPackageName sourcePkgIndex pkg)
showConstraint (uc, src) =
- prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"
+ prettyShow uc ++ " (" ++ showConstraintSource src ++ ")"
-- | Make an 'InstallPlan' for the unpacked package in the current directory,
-- and all its dependencies.
---
-planLocalPackage :: Verbosity -> Compiler
- -> Platform
- -> ConfigFlags -> ConfigExFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> PkgConfigDb
- -> IO (Progress String String SolverInstallPlan)
-planLocalPackage verbosity comp platform configFlags configExFlags
- installedPkgIndex (SourcePackageDb _ packagePrefs) pkgConfigDb = do
- pkg <- readGenericPackageDescription verbosity =<<
- case flagToMaybe (configCabalFilePath configFlags) of
- Nothing -> defaultPackageDesc verbosity
- Just fp -> return fp
- solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags)
- (compilerInfo comp)
-
- let -- We create a local package and ask to resolve a dependency on it
- localPkg = SourcePackage {
- srcpkgPackageId = packageId pkg,
- srcpkgDescription = pkg,
- srcpkgSource = LocalUnpackedPackage ".",
- srcpkgDescrOverride = Nothing
- }
+planLocalPackage
+ :: Verbosity
+ -> Compiler
+ -> Platform
+ -> ConfigFlags
+ -> ConfigExFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> PkgConfigDb
+ -> IO (Progress String String SolverInstallPlan)
+planLocalPackage
+ verbosity
+ comp
+ platform
+ configFlags
+ configExFlags
+ installedPkgIndex
+ (SourcePackageDb _ packagePrefs)
+ pkgConfigDb = do
+ pkg <-
+ readGenericPackageDescription verbosity
+ =<< case flagToMaybe (configCabalFilePath configFlags) of
+ Nothing -> defaultPackageDesc verbosity
+ Just fp -> return fp
+ solver <-
+ chooseSolver
+ verbosity
+ (fromFlag $ configSolver configExFlags)
+ (compilerInfo comp)
+
+ let
+ -- We create a local package and ask to resolve a dependency on it
+ localPkg =
+ SourcePackage
+ { srcpkgPackageId = packageId pkg
+ , srcpkgDescription = pkg
+ , srcpkgSource = LocalUnpackedPackage "."
+ , srcpkgDescrOverride = Nothing
+ }
testsEnabled :: Bool
testsEnabled = fromFlagOrDefault False $ configTests configFlags
@@ -310,49 +429,46 @@ planLocalPackage verbosity comp platform configFlags configExFlags
resolverParams :: DepResolverParams
resolverParams =
- removeLowerBounds
+ removeLowerBounds
(fromMaybe (AllowOlder mempty) $ configAllowOlder configExFlags)
- . removeUpperBounds
- (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)
-
- . addPreferences
+ . removeUpperBounds
+ (fromMaybe (AllowNewer mempty) $ configAllowNewer configExFlags)
+ . addPreferences
-- preferences from the config file or command line
[ PackageVersionPreference name ver
- | PackageVersionConstraint name ver <- configPreferences configExFlags ]
-
- . addConstraints
+ | PackageVersionConstraint name ver <- configPreferences configExFlags
+ ]
+ . addConstraints
-- version constraints from the config file or command line
-- TODO: should warn or error on constraints that are not on direct
-- deps or flag constraints not on the package in question.
[ LabeledPackageConstraint (userToPackageConstraint uc) src
- | (uc, src) <- configExConstraints configExFlags ]
-
- . addConstraints
+ | (uc, src) <- configExConstraints configExFlags
+ ]
+ . addConstraints
-- package flags from the config file or command line
- [ let pc = PackageConstraint
- (scopeToplevel $ packageName pkg)
- (PackagePropertyFlags $ configConfigurationsFlags configFlags)
- in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
+ [ let pc =
+ PackageConstraint
+ (scopeToplevel $ packageName pkg)
+ (PackagePropertyFlags $ configConfigurationsFlags configFlags)
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
]
-
- . addConstraints
+ . addConstraints
-- '--enable-tests' and '--enable-benchmarks' constraints from
-- the config file or command line
- [ let pc = PackageConstraint (scopeToplevel $ packageName pkg) .
- PackagePropertyStanzas $
- [ TestStanzas | testsEnabled ] ++
- [ BenchStanzas | benchmarksEnabled ]
- in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
+ [ let pc =
+ PackageConstraint (scopeToplevel $ packageName pkg)
+ . PackagePropertyStanzas
+ $ [TestStanzas | testsEnabled]
+ ++ [BenchStanzas | benchmarksEnabled]
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
]
-
- -- Don't solve for executables, since we use an empty source
- -- package database and executables never show up in the
- -- installed package index
- . setSolveExecutables (SolveExecutables False)
-
- . setSolverVerbosity verbosity
-
- $ standardInstallPolicy
+ -- Don't solve for executables, since we use an empty source
+ -- package database and executables never show up in the
+ -- installed package index
+ . setSolveExecutables (SolveExecutables False)
+ . setSolverVerbosity verbosity
+ $ standardInstallPolicy
installedPkgIndex
-- NB: We pass in an *empty* source package database,
-- because cabal configure assumes that all dependencies
@@ -360,8 +476,7 @@ planLocalPackage verbosity comp platform configFlags configExFlags
(SourcePackageDb mempty packagePrefs)
[SpecificSourcePackage localPkg]
- return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)
-
+ return (resolveDependencies platform (compilerInfo comp) pkgConfigDb solver resolverParams)
-- | Call an installer for an 'SourcePackage' but override the configure
-- flags with the ones given by the 'ReadyPackage'. In particular the
@@ -371,66 +486,94 @@ planLocalPackage verbosity comp platform configFlags configExFlags
--
-- NB: when updating this function, don't forget to also update
-- 'installReadyPackage' in D.C.Install.
-configurePackage :: Verbosity
- -> Platform -> CompilerInfo
- -> SetupScriptOptions
- -> ConfigFlags
- -> ReadyPackage
- -> [String]
- -> IO ()
-configurePackage verbosity platform comp scriptOptions configFlags
- (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))
- extraArgs =
-
- setupWrapper verbosity
- scriptOptions (Just pkg) configureCommand configureFlags (const extraArgs)
-
- where
- gpkg :: PkgDesc.GenericPackageDescription
- gpkg = srcpkgDescription spkg
- configureFlags :: Version -> ConfigFlags
- configureFlags = filterConfigureFlags configFlags {
- configIPID = if isJust (flagToMaybe (configIPID configFlags))
- -- Make sure cabal configure --ipid works.
- then configIPID configFlags
- else toFlag (prettyShow ipid),
- configConfigurationsFlags = flags,
- -- We generate the legacy constraints as well as the new style precise
- -- deps. In the end only one set gets passed to Setup.hs configure,
- -- depending on the Cabal version we are talking to.
- configConstraints = [ thisPackageVersionConstraint srcid
- | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid
- <- CD.nonSetupDeps deps ],
- configDependencies = [ GivenComponent (packageName srcid) cname uid
- | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid
- <- CD.nonSetupDeps deps ],
- -- Use '--exact-configuration' if supported.
- configExactConfiguration = toFlag True,
- configVerbosity = toFlag verbosity,
- -- NB: if the user explicitly specified
- -- --enable-tests/--enable-benchmarks, always respect it.
- -- (But if they didn't, let solver decide.)
- configBenchmarks = toFlag (BenchStanzas `optStanzaSetMember` stanzas)
- `mappend` configBenchmarks configFlags,
- configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
- `mappend` configTests configFlags
- }
-
- pkg :: PkgDesc.PackageDescription
- pkg = case finalizePD flags (enableStanzas stanzas)
- (const True)
- platform comp [] gpkg of
- Left _ -> error "finalizePD ReadyPackage failed"
- Right (desc, _) -> desc
+configurePackage
+ :: Verbosity
+ -> Platform
+ -> CompilerInfo
+ -> SetupScriptOptions
+ -> ConfigFlags
+ -> ReadyPackage
+ -> [String]
+ -> IO ()
+configurePackage
+ verbosity
+ platform
+ comp
+ scriptOptions
+ configFlags
+ (ReadyPackage (ConfiguredPackage ipid spkg flags stanzas deps))
+ extraArgs =
+ setupWrapper
+ verbosity
+ scriptOptions
+ (Just pkg)
+ configureCommand
+ configureFlags
+ (const extraArgs)
+ where
+ gpkg :: PkgDesc.GenericPackageDescription
+ gpkg = srcpkgDescription spkg
+ configureFlags :: Version -> ConfigFlags
+ configureFlags =
+ filterConfigureFlags
+ configFlags
+ { configIPID =
+ if isJust (flagToMaybe (configIPID configFlags))
+ then -- Make sure cabal configure --ipid works.
+ configIPID configFlags
+ else toFlag (prettyShow ipid)
+ , configConfigurationsFlags = flags
+ , -- We generate the legacy constraints as well as the new style precise
+ -- deps. In the end only one set gets passed to Setup.hs configure,
+ -- depending on the Cabal version we are talking to.
+ configConstraints =
+ [ thisPackageVersionConstraint srcid
+ | ConfiguredId srcid (Just (PkgDesc.CLibName PkgDesc.LMainLibName)) _uid <-
+ CD.nonSetupDeps deps
+ ]
+ , configDependencies =
+ [ GivenComponent (packageName srcid) cname uid
+ | ConfiguredId srcid (Just (PkgDesc.CLibName cname)) uid <-
+ CD.nonSetupDeps deps
+ ]
+ , -- Use '--exact-configuration' if supported.
+ configExactConfiguration = toFlag True
+ , configVerbosity = toFlag verbosity
+ , -- NB: if the user explicitly specified
+ -- --enable-tests/--enable-benchmarks, always respect it.
+ -- (But if they didn't, let solver decide.)
+ configBenchmarks =
+ toFlag (BenchStanzas `optStanzaSetMember` stanzas)
+ `mappend` configBenchmarks configFlags
+ , configTests =
+ toFlag (TestStanzas `optStanzaSetMember` stanzas)
+ `mappend` configTests configFlags
+ }
+
+ pkg :: PkgDesc.PackageDescription
+ pkg = case finalizePD
+ flags
+ (enableStanzas stanzas)
+ (const True)
+ platform
+ comp
+ []
+ gpkg of
+ Left _ -> error "finalizePD ReadyPackage failed"
+ Right (desc, _) -> desc
-- -----------------------------------------------------------------------------
+
-- * Saved configure environments and flags
+
-- -----------------------------------------------------------------------------
-- | Read saved configure flags and restore the saved environment from the
-- specified files.
-readConfigFlagsFrom :: FilePath -- ^ path to saved flags file
- -> IO (ConfigFlags, ConfigExFlags)
+readConfigFlagsFrom
+ :: FilePath
+ -- ^ path to saved flags file
+ -> IO (ConfigFlags, ConfigExFlags)
readConfigFlagsFrom flags = do
readCommandFlags flags configureExCommand
@@ -441,21 +584,29 @@ cabalConfigFlagsFile dist = dist </> "cabal-config-flags"
-- | Read saved configure flags and restore the saved environment from the
-- usual location.
-readConfigFlags :: FilePath -- ^ @--build-dir@
- -> IO (ConfigFlags, ConfigExFlags)
+readConfigFlags
+ :: FilePath
+ -- ^ @--build-dir@
+ -> IO (ConfigFlags, ConfigExFlags)
readConfigFlags dist =
readConfigFlagsFrom (cabalConfigFlagsFile dist)
-- | Save the configure flags and environment to the specified files.
-writeConfigFlagsTo :: FilePath -- ^ path to saved flags file
- -> Verbosity -> (ConfigFlags, ConfigExFlags)
- -> IO ()
+writeConfigFlagsTo
+ :: FilePath
+ -- ^ path to saved flags file
+ -> Verbosity
+ -> (ConfigFlags, ConfigExFlags)
+ -> IO ()
writeConfigFlagsTo file verb flags = do
writeCommandFlags verb file configureExCommand flags
-- | Save the build flags to the usual location.
-writeConfigFlags :: Verbosity
- -> FilePath -- ^ @--build-dir@
- -> (ConfigFlags, ConfigExFlags) -> IO ()
+writeConfigFlags
+ :: Verbosity
+ -> FilePath
+ -- ^ @--build-dir@
+ -> (ConfigFlags, ConfigExFlags)
+ -> IO ()
writeConfigFlags verb dist =
writeConfigFlagsTo (cabalConfigFlagsFile dist) verb
diff --git a/cabal-install/src/Distribution/Client/Dependency.hs b/cabal-install/src/Distribution/Client/Dependency.hs
index 3c3e8614241287b74232040a0251784790f0ab0c..5bc5ec51b86d14ad3b4023335135f4e87902e102 100644
--- a/cabal-install/src/Distribution/Client/Dependency.hs
+++ b/cabal-install/src/Distribution/Client/Dependency.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Dependency
-- Copyright : (c) David Himmelstrup 2005,
@@ -11,384 +14,432 @@
-- Portability : portable
--
-- Top level interface to dependency resolution.
------------------------------------------------------------------------------
-module Distribution.Client.Dependency (
- -- * The main package dependency resolver
- DepResolverParams,
- chooseSolver,
- resolveDependencies,
- Progress(..),
- foldProgress,
+module Distribution.Client.Dependency
+ ( -- * The main package dependency resolver
+ DepResolverParams
+ , chooseSolver
+ , resolveDependencies
+ , Progress (..)
+ , foldProgress
-- * Alternate, simple resolver that does not do dependencies recursively
- resolveWithoutDependencies,
+ , resolveWithoutDependencies
-- * Constructing resolver policies
- PackageProperty(..),
- PackageConstraint(..),
- scopeToplevel,
- PackagesPreferenceDefault(..),
- PackagePreference(..),
+ , PackageProperty (..)
+ , PackageConstraint (..)
+ , scopeToplevel
+ , PackagesPreferenceDefault (..)
+ , PackagePreference (..)
-- ** Standard policy
- basicInstallPolicy,
- standardInstallPolicy,
- PackageSpecifier(..),
+ , basicInstallPolicy
+ , standardInstallPolicy
+ , PackageSpecifier (..)
-- ** Extra policy options
- upgradeDependencies,
- reinstallTargets,
+ , upgradeDependencies
+ , reinstallTargets
-- ** Policy utils
- addConstraints,
- addPreferences,
- setPreferenceDefault,
- setReorderGoals,
- setCountConflicts,
- setFineGrainedConflicts,
- setMinimizeConflictSet,
- setIndependentGoals,
- setAvoidReinstalls,
- setShadowPkgs,
- setStrongFlags,
- setAllowBootLibInstalls,
- setOnlyConstrained,
- setMaxBackjumps,
- setEnableBackjumping,
- setSolveExecutables,
- setGoalOrder,
- setSolverVerbosity,
- removeLowerBounds,
- removeUpperBounds,
- addDefaultSetupDependencies,
- addSetupCabalMinVersionConstraint,
- addSetupCabalMaxVersionConstraint,
+ , addConstraints
+ , addPreferences
+ , setPreferenceDefault
+ , setReorderGoals
+ , setCountConflicts
+ , setFineGrainedConflicts
+ , setMinimizeConflictSet
+ , setIndependentGoals
+ , setAvoidReinstalls
+ , setShadowPkgs
+ , setStrongFlags
+ , setAllowBootLibInstalls
+ , setOnlyConstrained
+ , setMaxBackjumps
+ , setEnableBackjumping
+ , setSolveExecutables
+ , setGoalOrder
+ , setSolverVerbosity
+ , removeLowerBounds
+ , removeUpperBounds
+ , addDefaultSetupDependencies
+ , addSetupCabalMinVersionConstraint
+ , addSetupCabalMaxVersionConstraint
) where
import Distribution.Client.Compat.Prelude
import qualified Prelude as Unsafe (head)
-import Distribution.Solver.Modular
- ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) )
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
+import Distribution.Client.Dependency.Types
+ ( PackagesPreferenceDefault (..)
+ , PreSolver (..)
+ , Solver (..)
+ )
import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Types
- ( SourcePackageDb(SourcePackageDb)
- , PackageSpecifier(..), pkgSpecifierTarget, pkgSpecifierConstraints
- , UnresolvedPkgLoc, UnresolvedSourcePackage
- , AllowNewer(..), AllowOlder(..), RelaxDeps(..), RelaxedDep(..)
- , RelaxDepScope(..), RelaxDepMod(..), RelaxDepSubject(..), isRelaxDeps
- )
-import Distribution.Client.Dependency.Types
- ( PreSolver(..), Solver(..)
- , PackagesPreferenceDefault(..) )
+ ( AllowNewer (..)
+ , AllowOlder (..)
+ , PackageSpecifier (..)
+ , RelaxDepMod (..)
+ , RelaxDepScope (..)
+ , RelaxDepSubject (..)
+ , RelaxDeps (..)
+ , RelaxedDep (..)
+ , SourcePackageDb (SourcePackageDb)
+ , UnresolvedPkgLoc
+ , UnresolvedSourcePackage
+ , isRelaxDeps
+ , pkgSpecifierConstraints
+ , pkgSpecifierTarget
+ )
+import Distribution.Client.Utils
+ ( MergeResult (..)
+ , duplicatesBy
+ , mergeBy
+ )
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compiler
+ ( CompilerInfo (..)
+ )
import Distribution.Package
- ( PackageName, mkPackageName, PackageIdentifier(PackageIdentifier), PackageId
- , Package(..), packageName, packageVersion )
-import Distribution.Types.Dependency
+ ( Package (..)
+ , PackageId
+ , PackageIdentifier (PackageIdentifier)
+ , PackageName
+ , mkPackageName
+ , packageName
+ , packageVersion
+ )
import qualified Distribution.PackageDescription as PD
-import qualified Distribution.PackageDescription.Configuration as PD
import Distribution.PackageDescription.Configuration
- ( finalizePD )
-import Distribution.Compiler
- ( CompilerInfo(..) )
-import Distribution.System
- ( Platform )
-import Distribution.Client.Utils
- ( duplicatesBy, mergeBy, MergeResult(..) )
+ ( finalizePD
+ )
+import qualified Distribution.PackageDescription.Configuration as PD
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Simple.Setup
- ( asBool )
+ ( asBool
+ )
+import Distribution.Solver.Modular
+ ( PruneAfterFirstSuccess (..)
+ , SolverConfig (..)
+ , modularResolver
+ )
+import Distribution.System
+ ( Platform
+ )
+import Distribution.Types.Dependency
import Distribution.Verbosity
- ( normal )
+ ( normal
+ )
import Distribution.Version
-import qualified Distribution.Compat.Graph as Graph
-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
+import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ConstraintSource
-import Distribution.Solver.Types.DependencyResolver
-import Distribution.Solver.Types.InstalledPreference as Preference
-import Distribution.Solver.Types.LabeledPackageConstraint
-import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PackageConstraint
-import Distribution.Solver.Types.PackagePath
-import Distribution.Solver.Types.PackagePreferences
+import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.DependencyResolver
+import Distribution.Solver.Types.InstalledPreference as Preference
+import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
-import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
-import Distribution.Solver.Types.Progress
-import Distribution.Solver.Types.ResolverPackage
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.SolverId
-import Distribution.Solver.Types.SolverPackage
-import Distribution.Solver.Types.SourcePackage
-import Distribution.Solver.Types.Variable
+import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.PackagePreferences
+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
+import Distribution.Solver.Types.Progress
+import Distribution.Solver.Types.ResolverPackage
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SolverId
+import Distribution.Solver.Types.SolverPackage
+import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Variable
+import Control.Exception
+ ( assert
+ )
import Data.List
- ( maximumBy )
+ ( maximumBy
+ )
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Control.Exception
- ( assert )
-
-- ------------------------------------------------------------
+
-- * High level planner policy
+
-- ------------------------------------------------------------
-- | The set of parameters to the dependency resolver. These parameters are
-- relatively low level but many kinds of high level policies can be
-- implemented in terms of adjustments to the parameters.
---
-data DepResolverParams = DepResolverParams {
- depResolverTargets :: Set PackageName,
- depResolverConstraints :: [LabeledPackageConstraint],
- depResolverPreferences :: [PackagePreference],
- depResolverPreferenceDefault :: PackagesPreferenceDefault,
- depResolverInstalledPkgIndex :: InstalledPackageIndex,
- depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage,
- depResolverReorderGoals :: ReorderGoals,
- depResolverCountConflicts :: CountConflicts,
- depResolverFineGrainedConflicts :: FineGrainedConflicts,
- depResolverMinimizeConflictSet :: MinimizeConflictSet,
- depResolverIndependentGoals :: IndependentGoals,
- depResolverAvoidReinstalls :: AvoidReinstalls,
- depResolverShadowPkgs :: ShadowPkgs,
- depResolverStrongFlags :: StrongFlags,
-
- -- | Whether to allow base and its dependencies to be installed.
- depResolverAllowBootLibInstalls :: AllowBootLibInstalls,
-
- -- | Whether to only allow explicitly constrained packages plus
- -- goals or to allow any package.
- depResolverOnlyConstrained :: OnlyConstrained,
-
- depResolverMaxBackjumps :: Maybe Int,
- depResolverEnableBackjumping :: EnableBackjumping,
- -- | Whether or not to solve for dependencies on executables.
- -- This should be true, except in the legacy code path where
- -- we can't tell if an executable has been installed or not,
- -- so we shouldn't solve for them. See #3875.
- depResolverSolveExecutables :: SolveExecutables,
-
- -- | Function to override the solver's goal-ordering heuristics.
- depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering),
- depResolverVerbosity :: Verbosity
- }
+data DepResolverParams = DepResolverParams
+ { depResolverTargets :: Set PackageName
+ , depResolverConstraints :: [LabeledPackageConstraint]
+ , depResolverPreferences :: [PackagePreference]
+ , depResolverPreferenceDefault :: PackagesPreferenceDefault
+ , depResolverInstalledPkgIndex :: InstalledPackageIndex
+ , depResolverSourcePkgIndex :: PackageIndex.PackageIndex UnresolvedSourcePackage
+ , depResolverReorderGoals :: ReorderGoals
+ , depResolverCountConflicts :: CountConflicts
+ , depResolverFineGrainedConflicts :: FineGrainedConflicts
+ , depResolverMinimizeConflictSet :: MinimizeConflictSet
+ , depResolverIndependentGoals :: IndependentGoals
+ , depResolverAvoidReinstalls :: AvoidReinstalls
+ , depResolverShadowPkgs :: ShadowPkgs
+ , depResolverStrongFlags :: StrongFlags
+ , depResolverAllowBootLibInstalls :: AllowBootLibInstalls
+ -- ^ Whether to allow base and its dependencies to be installed.
+ , depResolverOnlyConstrained :: OnlyConstrained
+ -- ^ Whether to only allow explicitly constrained packages plus
+ -- goals or to allow any package.
+ , depResolverMaxBackjumps :: Maybe Int
+ , depResolverEnableBackjumping :: EnableBackjumping
+ , depResolverSolveExecutables :: SolveExecutables
+ -- ^ Whether or not to solve for dependencies on executables.
+ -- This should be true, except in the legacy code path where
+ -- we can't tell if an executable has been installed or not,
+ -- so we shouldn't solve for them. See #3875.
+ , depResolverGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
+ -- ^ Function to override the solver's goal-ordering heuristics.
+ , depResolverVerbosity :: Verbosity
+ }
showDepResolverParams :: DepResolverParams -> String
showDepResolverParams p =
- "targets: " ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))
- ++ "\nconstraints: "
- ++ concatMap (("\n " ++) . showLabeledConstraint)
- (depResolverConstraints p)
- ++ "\npreferences: "
- ++ concatMap (("\n " ++) . showPackagePreference)
- (depResolverPreferences p)
- ++ "\nstrategy: " ++ show (depResolverPreferenceDefault p)
- ++ "\nreorder goals: " ++ show (asBool (depResolverReorderGoals p))
- ++ "\ncount conflicts: " ++ show (asBool (depResolverCountConflicts p))
- ++ "\nfine grained conflicts: " ++ show (asBool (depResolverFineGrainedConflicts p))
- ++ "\nminimize conflict set: " ++ show (asBool (depResolverMinimizeConflictSet p))
- ++ "\nindependent goals: " ++ show (asBool (depResolverIndependentGoals p))
- ++ "\navoid reinstalls: " ++ show (asBool (depResolverAvoidReinstalls p))
- ++ "\nshadow packages: " ++ show (asBool (depResolverShadowPkgs p))
- ++ "\nstrong flags: " ++ show (asBool (depResolverStrongFlags p))
- ++ "\nallow boot library installs: " ++ show (asBool (depResolverAllowBootLibInstalls p))
- ++ "\nonly constrained packages: " ++ show (depResolverOnlyConstrained p)
- ++ "\nmax backjumps: " ++ maybe "infinite" show
- (depResolverMaxBackjumps p)
+ "targets: "
+ ++ intercalate ", " (map prettyShow $ Set.toList (depResolverTargets p))
+ ++ "\nconstraints: "
+ ++ concatMap
+ (("\n " ++) . showLabeledConstraint)
+ (depResolverConstraints p)
+ ++ "\npreferences: "
+ ++ concatMap
+ (("\n " ++) . showPackagePreference)
+ (depResolverPreferences p)
+ ++ "\nstrategy: "
+ ++ show (depResolverPreferenceDefault p)
+ ++ "\nreorder goals: "
+ ++ show (asBool (depResolverReorderGoals p))
+ ++ "\ncount conflicts: "
+ ++ show (asBool (depResolverCountConflicts p))
+ ++ "\nfine grained conflicts: "
+ ++ show (asBool (depResolverFineGrainedConflicts p))
+ ++ "\nminimize conflict set: "
+ ++ show (asBool (depResolverMinimizeConflictSet p))
+ ++ "\nindependent goals: "
+ ++ show (asBool (depResolverIndependentGoals p))
+ ++ "\navoid reinstalls: "
+ ++ show (asBool (depResolverAvoidReinstalls p))
+ ++ "\nshadow packages: "
+ ++ show (asBool (depResolverShadowPkgs p))
+ ++ "\nstrong flags: "
+ ++ show (asBool (depResolverStrongFlags p))
+ ++ "\nallow boot library installs: "
+ ++ show (asBool (depResolverAllowBootLibInstalls p))
+ ++ "\nonly constrained packages: "
+ ++ show (depResolverOnlyConstrained p)
+ ++ "\nmax backjumps: "
+ ++ maybe
+ "infinite"
+ show
+ (depResolverMaxBackjumps p)
where
showLabeledConstraint :: LabeledPackageConstraint -> String
showLabeledConstraint (LabeledPackageConstraint pc src) =
- showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
+ showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
-- | A package selection preference for a particular package.
--
-- Preferences are soft constraints that the dependency resolver should try to
-- respect where possible. It is not specified if preferences on some packages
-- are more important than others.
---
-data PackagePreference =
-
- -- | A suggested constraint on the version number.
- PackageVersionPreference PackageName VersionRange
-
- -- | If we prefer versions of packages that are already installed.
- | PackageInstalledPreference PackageName InstalledPreference
-
- -- | If we would prefer to enable these optional stanzas
- -- (i.e. test suites and/or benchmarks)
- | PackageStanzasPreference PackageName [OptionalStanza]
-
+data PackagePreference
+ = -- | A suggested constraint on the version number.
+ PackageVersionPreference PackageName VersionRange
+ | -- | If we prefer versions of packages that are already installed.
+ PackageInstalledPreference PackageName InstalledPreference
+ | -- | If we would prefer to enable these optional stanzas
+ -- (i.e. test suites and/or benchmarks)
+ PackageStanzasPreference PackageName [OptionalStanza]
-- | Provide a textual representation of a package preference
-- for debugging purposes.
---
showPackagePreference :: PackagePreference -> String
-showPackagePreference (PackageVersionPreference pn vr) =
+showPackagePreference (PackageVersionPreference pn vr) =
prettyShow pn ++ " " ++ prettyShow (simplifyVersionRange vr)
showPackagePreference (PackageInstalledPreference pn ip) =
prettyShow pn ++ " " ++ show ip
showPackagePreference (PackageStanzasPreference pn st) =
prettyShow pn ++ " " ++ show st
-basicDepResolverParams :: InstalledPackageIndex
- -> PackageIndex.PackageIndex UnresolvedSourcePackage
- -> DepResolverParams
+basicDepResolverParams
+ :: InstalledPackageIndex
+ -> PackageIndex.PackageIndex UnresolvedSourcePackage
+ -> DepResolverParams
basicDepResolverParams installedPkgIndex sourcePkgIndex =
- DepResolverParams {
- depResolverTargets = Set.empty,
- depResolverConstraints = [],
- depResolverPreferences = [],
- depResolverPreferenceDefault = PreferLatestForSelected,
- depResolverInstalledPkgIndex = installedPkgIndex,
- depResolverSourcePkgIndex = sourcePkgIndex,
- depResolverReorderGoals = ReorderGoals False,
- depResolverCountConflicts = CountConflicts True,
- depResolverFineGrainedConflicts = FineGrainedConflicts True,
- depResolverMinimizeConflictSet = MinimizeConflictSet False,
- depResolverIndependentGoals = IndependentGoals False,
- depResolverAvoidReinstalls = AvoidReinstalls False,
- depResolverShadowPkgs = ShadowPkgs False,
- depResolverStrongFlags = StrongFlags False,
- depResolverAllowBootLibInstalls = AllowBootLibInstalls False,
- depResolverOnlyConstrained = OnlyConstrainedNone,
- depResolverMaxBackjumps = Nothing,
- depResolverEnableBackjumping = EnableBackjumping True,
- depResolverSolveExecutables = SolveExecutables True,
- depResolverGoalOrder = Nothing,
- depResolverVerbosity = normal
- }
-
-addTargets :: [PackageName]
- -> DepResolverParams -> DepResolverParams
+ DepResolverParams
+ { depResolverTargets = Set.empty
+ , depResolverConstraints = []
+ , depResolverPreferences = []
+ , depResolverPreferenceDefault = PreferLatestForSelected
+ , depResolverInstalledPkgIndex = installedPkgIndex
+ , depResolverSourcePkgIndex = sourcePkgIndex
+ , depResolverReorderGoals = ReorderGoals False
+ , depResolverCountConflicts = CountConflicts True
+ , depResolverFineGrainedConflicts = FineGrainedConflicts True
+ , depResolverMinimizeConflictSet = MinimizeConflictSet False
+ , depResolverIndependentGoals = IndependentGoals False
+ , depResolverAvoidReinstalls = AvoidReinstalls False
+ , depResolverShadowPkgs = ShadowPkgs False
+ , depResolverStrongFlags = StrongFlags False
+ , depResolverAllowBootLibInstalls = AllowBootLibInstalls False
+ , depResolverOnlyConstrained = OnlyConstrainedNone
+ , depResolverMaxBackjumps = Nothing
+ , depResolverEnableBackjumping = EnableBackjumping True
+ , depResolverSolveExecutables = SolveExecutables True
+ , depResolverGoalOrder = Nothing
+ , depResolverVerbosity = normal
+ }
+
+addTargets
+ :: [PackageName]
+ -> DepResolverParams
+ -> DepResolverParams
addTargets extraTargets params =
- params {
- depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params
+ params
+ { depResolverTargets = Set.fromList extraTargets `Set.union` depResolverTargets params
}
-addConstraints :: [LabeledPackageConstraint]
- -> DepResolverParams -> DepResolverParams
+addConstraints
+ :: [LabeledPackageConstraint]
+ -> DepResolverParams
+ -> DepResolverParams
addConstraints extraConstraints params =
- params {
- depResolverConstraints = extraConstraints
- ++ depResolverConstraints params
+ params
+ { depResolverConstraints =
+ extraConstraints
+ ++ depResolverConstraints params
}
-addPreferences :: [PackagePreference]
- -> DepResolverParams -> DepResolverParams
+addPreferences
+ :: [PackagePreference]
+ -> DepResolverParams
+ -> DepResolverParams
addPreferences extraPreferences params =
- params {
- depResolverPreferences = extraPreferences
- ++ depResolverPreferences params
+ params
+ { depResolverPreferences =
+ extraPreferences
+ ++ depResolverPreferences params
}
-setPreferenceDefault :: PackagesPreferenceDefault
- -> DepResolverParams -> DepResolverParams
+setPreferenceDefault
+ :: PackagesPreferenceDefault
+ -> DepResolverParams
+ -> DepResolverParams
setPreferenceDefault preferenceDefault params =
- params {
- depResolverPreferenceDefault = preferenceDefault
+ params
+ { depResolverPreferenceDefault = preferenceDefault
}
setReorderGoals :: ReorderGoals -> DepResolverParams -> DepResolverParams
setReorderGoals reorder params =
- params {
- depResolverReorderGoals = reorder
+ params
+ { depResolverReorderGoals = reorder
}
setCountConflicts :: CountConflicts -> DepResolverParams -> DepResolverParams
setCountConflicts count params =
- params {
- depResolverCountConflicts = count
+ params
+ { depResolverCountConflicts = count
}
setFineGrainedConflicts :: FineGrainedConflicts -> DepResolverParams -> DepResolverParams
setFineGrainedConflicts fineGrained params =
- params {
- depResolverFineGrainedConflicts = fineGrained
+ params
+ { depResolverFineGrainedConflicts = fineGrained
}
setMinimizeConflictSet :: MinimizeConflictSet -> DepResolverParams -> DepResolverParams
setMinimizeConflictSet minimize params =
- params {
- depResolverMinimizeConflictSet = minimize
+ params
+ { depResolverMinimizeConflictSet = minimize
}
setIndependentGoals :: IndependentGoals -> DepResolverParams -> DepResolverParams
setIndependentGoals indep params =
- params {
- depResolverIndependentGoals = indep
+ params
+ { depResolverIndependentGoals = indep
}
setAvoidReinstalls :: AvoidReinstalls -> DepResolverParams -> DepResolverParams
setAvoidReinstalls avoid params =
- params {
- depResolverAvoidReinstalls = avoid
+ params
+ { depResolverAvoidReinstalls = avoid
}
setShadowPkgs :: ShadowPkgs -> DepResolverParams -> DepResolverParams
setShadowPkgs shadow params =
- params {
- depResolverShadowPkgs = shadow
+ params
+ { depResolverShadowPkgs = shadow
}
setStrongFlags :: StrongFlags -> DepResolverParams -> DepResolverParams
setStrongFlags sf params =
- params {
- depResolverStrongFlags = sf
+ params
+ { depResolverStrongFlags = sf
}
setAllowBootLibInstalls :: AllowBootLibInstalls -> DepResolverParams -> DepResolverParams
setAllowBootLibInstalls i params =
- params {
- depResolverAllowBootLibInstalls = i
+ params
+ { depResolverAllowBootLibInstalls = i
}
setOnlyConstrained :: OnlyConstrained -> DepResolverParams -> DepResolverParams
setOnlyConstrained i params =
- params {
- depResolverOnlyConstrained = i
- }
+ params
+ { depResolverOnlyConstrained = i
+ }
setMaxBackjumps :: Maybe Int -> DepResolverParams -> DepResolverParams
setMaxBackjumps n params =
- params {
- depResolverMaxBackjumps = n
+ params
+ { depResolverMaxBackjumps = n
}
setEnableBackjumping :: EnableBackjumping -> DepResolverParams -> DepResolverParams
setEnableBackjumping b params =
- params {
- depResolverEnableBackjumping = b
+ params
+ { depResolverEnableBackjumping = b
}
setSolveExecutables :: SolveExecutables -> DepResolverParams -> DepResolverParams
setSolveExecutables b params =
- params {
- depResolverSolveExecutables = b
+ params
+ { depResolverSolveExecutables = b
}
-setGoalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
- -> DepResolverParams
- -> DepResolverParams
+setGoalOrder
+ :: Maybe (Variable QPN -> Variable QPN -> Ordering)
+ -> DepResolverParams
+ -> DepResolverParams
setGoalOrder order params =
- params {
- depResolverGoalOrder = order
+ params
+ { depResolverGoalOrder = order
}
setSolverVerbosity :: Verbosity -> DepResolverParams -> DepResolverParams
setSolverVerbosity verbosity params =
- params {
- depResolverVerbosity = verbosity
+ params
+ { depResolverVerbosity = verbosity
}
-- | Some packages are specific to a given compiler version and should never be
-- upgraded.
dontUpgradeNonUpgradeablePackages :: DepResolverParams -> DepResolverParams
dontUpgradeNonUpgradeablePackages params =
- addConstraints extraConstraints params
+ addConstraints extraConstraints params
where
extraConstraints =
[ LabeledPackageConstraint
@@ -396,11 +447,14 @@ dontUpgradeNonUpgradeablePackages params =
ConstraintSourceNonUpgradeablePackage
| Set.notMember (mkPackageName "base") (depResolverTargets params)
, pkgname <- nonUpgradeablePackages
- , isInstalled pkgname ]
+ , isInstalled pkgname
+ ]
- isInstalled = not . null
- . InstalledPackageIndex.lookupPackageName
- (depResolverInstalledPkgIndex params)
+ isInstalled =
+ not
+ . null
+ . InstalledPackageIndex.lookupPackageName
+ (depResolverInstalledPkgIndex params)
-- NOTE: the lists of non-upgradable and non-installable packages used to be
-- respectively in this module and in `Distribution.Solver.Modular.Solver`.
@@ -420,44 +474,53 @@ nonUpgradeablePackages =
, mkPackageName "template-haskell"
]
-addSourcePackages :: [UnresolvedSourcePackage]
- -> DepResolverParams -> DepResolverParams
+addSourcePackages
+ :: [UnresolvedSourcePackage]
+ -> DepResolverParams
+ -> DepResolverParams
addSourcePackages pkgs params =
- params {
- depResolverSourcePkgIndex =
- foldl (flip PackageIndex.insert)
- (depResolverSourcePkgIndex params) pkgs
+ params
+ { depResolverSourcePkgIndex =
+ foldl
+ (flip PackageIndex.insert)
+ (depResolverSourcePkgIndex params)
+ pkgs
}
-hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]
- -> DepResolverParams
- -> DepResolverParams
+hideInstalledPackagesSpecificBySourcePackageId
+ :: [PackageId]
+ -> DepResolverParams
+ -> DepResolverParams
hideInstalledPackagesSpecificBySourcePackageId pkgids params =
- --TODO: this should work using exclude constraints instead
- params {
- depResolverInstalledPkgIndex =
- foldl' (flip InstalledPackageIndex.deleteSourcePackageId)
- (depResolverInstalledPkgIndex params) pkgids
+ -- TODO: this should work using exclude constraints instead
+ params
+ { depResolverInstalledPkgIndex =
+ foldl'
+ (flip InstalledPackageIndex.deleteSourcePackageId)
+ (depResolverInstalledPkgIndex params)
+ pkgids
}
-hideInstalledPackagesAllVersions :: [PackageName]
- -> DepResolverParams -> DepResolverParams
+hideInstalledPackagesAllVersions
+ :: [PackageName]
+ -> DepResolverParams
+ -> DepResolverParams
hideInstalledPackagesAllVersions pkgnames params =
- --TODO: this should work using exclude constraints instead
- params {
- depResolverInstalledPkgIndex =
- foldl' (flip InstalledPackageIndex.deletePackageName)
- (depResolverInstalledPkgIndex params) pkgnames
+ -- TODO: this should work using exclude constraints instead
+ params
+ { depResolverInstalledPkgIndex =
+ foldl'
+ (flip InstalledPackageIndex.deletePackageName)
+ (depResolverInstalledPkgIndex params)
+ pkgnames
}
-
-- | Remove upper bounds in dependencies using the policy specified by the
-- 'AllowNewer' argument (all/some/none).
--
-- Note: It's important to apply 'removeUpperBounds' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
---
removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams
removeUpperBounds (AllowNewer relDeps) = removeBounds RelaxUpper relDeps
@@ -470,63 +533,65 @@ data RelaxKind = RelaxLower | RelaxUpper
-- | Common internal implementation of 'removeLowerBounds'/'removeUpperBounds'
removeBounds :: RelaxKind -> RelaxDeps -> DepResolverParams -> DepResolverParams
removeBounds _ rd params | not (isRelaxDeps rd) = params -- no-op optimisation
-removeBounds relKind relDeps params =
- params {
- depResolverSourcePkgIndex = sourcePkgIndex'
+removeBounds relKind relDeps params =
+ params
+ { depResolverSourcePkgIndex = sourcePkgIndex'
}
where
sourcePkgIndex' :: PackageIndex.PackageIndex UnresolvedSourcePackage
sourcePkgIndex' = relaxDeps <$> depResolverSourcePkgIndex params
relaxDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
- relaxDeps srcPkg = srcPkg
- { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg)
- }
+ relaxDeps srcPkg =
+ srcPkg
+ { srcpkgDescription = relaxPackageDeps relKind relDeps (srcpkgDescription srcPkg)
+ }
-- | Relax the dependencies of this package if needed.
--
-- Helper function used by 'removeBounds'
-relaxPackageDeps :: RelaxKind
- -> RelaxDeps
- -> PD.GenericPackageDescription -> PD.GenericPackageDescription
+relaxPackageDeps
+ :: RelaxKind
+ -> RelaxDeps
+ -> PD.GenericPackageDescription
+ -> PD.GenericPackageDescription
relaxPackageDeps _ rd gpd | not (isRelaxDeps rd) = gpd -- subsumed by no-op case in 'removeBounds'
-relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd
+relaxPackageDeps relKind RelaxDepsAll gpd = PD.transformAllBuildDepends relaxAll gpd
where
relaxAll :: Dependency -> Dependency
relaxAll (Dependency pkgName verRange cs) =
- Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs
-
+ Dependency pkgName (removeBound relKind RelaxDepModNone verRange) cs
relaxPackageDeps relKind (RelaxDepsSome depsToRelax0) gpd =
PD.transformAllBuildDepends relaxSome gpd
where
- thisPkgName = packageName gpd
- thisPkgId = packageId gpd
- depsToRelax = Map.fromList $ mapMaybe f depsToRelax0
+ thisPkgName = packageName gpd
+ thisPkgId = packageId gpd
+ depsToRelax = Map.fromList $ mapMaybe f depsToRelax0
- f :: RelaxedDep -> Maybe (RelaxDepSubject,RelaxDepMod)
+ f :: RelaxedDep -> Maybe (RelaxDepSubject, RelaxDepMod)
f (RelaxedDep scope rdm p) = case scope of
- RelaxDepScopeAll -> Just (p,rdm)
+ RelaxDepScopeAll -> Just (p, rdm)
RelaxDepScopePackage p0
- | p0 == thisPkgName -> Just (p,rdm)
- | otherwise -> Nothing
+ | p0 == thisPkgName -> Just (p, rdm)
+ | otherwise -> Nothing
RelaxDepScopePackageId p0
- | p0 == thisPkgId -> Just (p,rdm)
- | otherwise -> Nothing
+ | p0 == thisPkgId -> Just (p, rdm)
+ | otherwise -> Nothing
relaxSome :: Dependency -> Dependency
relaxSome d@(Dependency depName verRange cs)
- | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =
- -- a '*'-subject acts absorbing, for consistency with
- -- the 'Semigroup RelaxDeps' instance
- Dependency depName (removeBound relKind relMod verRange) cs
- | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =
- Dependency depName (removeBound relKind relMod verRange) cs
- | otherwise = d -- no-op
+ | Just relMod <- Map.lookup RelaxDepSubjectAll depsToRelax =
+ -- a '*'-subject acts absorbing, for consistency with
+ -- the 'Semigroup RelaxDeps' instance
+ Dependency depName (removeBound relKind relMod verRange) cs
+ | Just relMod <- Map.lookup (RelaxDepSubjectPkg depName) depsToRelax =
+ Dependency depName (removeBound relKind relMod verRange) cs
+ | otherwise = d -- no-op
-- | Internal helper for 'relaxPackageDeps'
removeBound :: RelaxKind -> RelaxDepMod -> VersionRange -> VersionRange
-removeBound RelaxLower RelaxDepModNone = removeLowerBound
-removeBound RelaxUpper RelaxDepModNone = removeUpperBound
+removeBound RelaxLower RelaxDepModNone = removeLowerBound
+removeBound RelaxUpper RelaxDepModNone = removeUpperBound
removeBound RelaxLower RelaxDepModCaret = transformCaretLower
removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper
@@ -535,158 +600,167 @@ removeBound RelaxUpper RelaxDepModCaret = transformCaretUpper
-- Note: It's important to apply 'addDefaultSetupDepends' after
-- 'addSourcePackages'. Otherwise, the packages inserted by
-- 'addSourcePackages' won't have upper bounds in dependencies relaxed.
---
-addDefaultSetupDependencies :: (UnresolvedSourcePackage -> Maybe [Dependency])
- -> DepResolverParams -> DepResolverParams
+addDefaultSetupDependencies
+ :: (UnresolvedSourcePackage -> Maybe [Dependency])
+ -> DepResolverParams
+ -> DepResolverParams
addDefaultSetupDependencies defaultSetupDeps params =
- params {
- depResolverSourcePkgIndex =
+ params
+ { depResolverSourcePkgIndex =
fmap applyDefaultSetupDeps (depResolverSourcePkgIndex params)
}
where
applyDefaultSetupDeps :: UnresolvedSourcePackage -> UnresolvedSourcePackage
applyDefaultSetupDeps srcpkg =
- srcpkg {
- srcpkgDescription = gpkgdesc {
- PD.packageDescription = pkgdesc {
- PD.setupBuildInfo =
- case PD.setupBuildInfo pkgdesc of
- Just sbi -> Just sbi
- Nothing -> case defaultSetupDeps srcpkg of
- Nothing -> Nothing
- Just deps | isCustom -> Just PD.SetupBuildInfo {
- PD.defaultSetupDepends = True,
- PD.setupDepends = deps
- }
+ srcpkg
+ { srcpkgDescription =
+ gpkgdesc
+ { PD.packageDescription =
+ pkgdesc
+ { PD.setupBuildInfo =
+ case PD.setupBuildInfo pkgdesc of
+ Just sbi -> Just sbi
+ Nothing -> case defaultSetupDeps srcpkg of
+ Nothing -> Nothing
+ Just deps
+ | isCustom ->
+ Just
+ PD.SetupBuildInfo
+ { PD.defaultSetupDepends = True
+ , PD.setupDepends = deps
+ }
| otherwise -> Nothing
- }
- }
+ }
+ }
}
where
isCustom = PD.buildType pkgdesc == PD.Custom
gpkgdesc = srcpkgDescription srcpkg
- pkgdesc = PD.packageDescription gpkgdesc
+ pkgdesc = PD.packageDescription gpkgdesc
-- | If a package has a custom setup then we need to add a setup-depends
-- on Cabal.
---
-addSetupCabalMinVersionConstraint :: Version
- -> DepResolverParams -> DepResolverParams
+addSetupCabalMinVersionConstraint
+ :: Version
+ -> DepResolverParams
+ -> DepResolverParams
addSetupCabalMinVersionConstraint minVersion =
- addConstraints
- [ LabeledPackageConstraint
- (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)
- (PackagePropertyVersion $ orLaterVersion minVersion))
- ConstraintSetupCabalMinVersion
- ]
+ addConstraints
+ [ LabeledPackageConstraint
+ ( PackageConstraint
+ (ScopeAnySetupQualifier cabalPkgname)
+ (PackagePropertyVersion $ orLaterVersion minVersion)
+ )
+ ConstraintSetupCabalMinVersion
+ ]
where
cabalPkgname = mkPackageName "Cabal"
-- | Variant of 'addSetupCabalMinVersionConstraint' which sets an
-- upper bound on @setup.Cabal@ labeled with 'ConstraintSetupCabalMaxVersion'.
---
-addSetupCabalMaxVersionConstraint :: Version
- -> DepResolverParams -> DepResolverParams
+addSetupCabalMaxVersionConstraint
+ :: Version
+ -> DepResolverParams
+ -> DepResolverParams
addSetupCabalMaxVersionConstraint maxVersion =
- addConstraints
- [ LabeledPackageConstraint
- (PackageConstraint (ScopeAnySetupQualifier cabalPkgname)
- (PackagePropertyVersion $ earlierVersion maxVersion))
- ConstraintSetupCabalMaxVersion
- ]
+ addConstraints
+ [ LabeledPackageConstraint
+ ( PackageConstraint
+ (ScopeAnySetupQualifier cabalPkgname)
+ (PackagePropertyVersion $ earlierVersion maxVersion)
+ )
+ ConstraintSetupCabalMaxVersion
+ ]
where
cabalPkgname = mkPackageName "Cabal"
-
upgradeDependencies :: DepResolverParams -> DepResolverParams
upgradeDependencies = setPreferenceDefault PreferAllLatest
-
reinstallTargets :: DepResolverParams -> DepResolverParams
reinstallTargets params =
- hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params
-
+ hideInstalledPackagesAllVersions (Set.toList $ depResolverTargets params) params
-- | A basic solver policy on which all others are built.
---
-basicInstallPolicy :: InstalledPackageIndex
- -> SourcePackageDb
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> DepResolverParams
basicInstallPolicy
- installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
- pkgSpecifiers
-
- = addPreferences
+ :: InstalledPackageIndex
+ -> SourcePackageDb
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> DepResolverParams
+basicInstallPolicy
+ installedPkgIndex
+ (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
+ pkgSpecifiers =
+ addPreferences
[ PackageVersionPreference name ver
- | (name, ver) <- Map.toList sourcePkgPrefs ]
-
- . addConstraints
- (concatMap pkgSpecifierConstraints pkgSpecifiers)
-
- . addTargets
- (map pkgSpecifierTarget pkgSpecifiers)
-
- . hideInstalledPackagesSpecificBySourcePackageId
- [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
-
- . addSourcePackages
- [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
-
- $ basicDepResolverParams
- installedPkgIndex sourcePkgIndex
-
+ | (name, ver) <- Map.toList sourcePkgPrefs
+ ]
+ . addConstraints
+ (concatMap pkgSpecifierConstraints pkgSpecifiers)
+ . addTargets
+ (map pkgSpecifierTarget pkgSpecifiers)
+ . hideInstalledPackagesSpecificBySourcePackageId
+ [packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
+ . addSourcePackages
+ [pkg | SpecificSourcePackage pkg <- pkgSpecifiers]
+ $ basicDepResolverParams
+ installedPkgIndex
+ sourcePkgIndex
-- | The policy used by all the standard commands, install, fetch, freeze etc
-- (but not the v2-build and related commands).
--
-- It extends the 'basicInstallPolicy' with a policy on setup deps.
---
-standardInstallPolicy :: InstalledPackageIndex
- -> SourcePackageDb
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> DepResolverParams
-standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
-
- = addDefaultSetupDependencies mkDefaultSetupDeps
-
- $ basicInstallPolicy
- installedPkgIndex sourcePkgDb pkgSpecifiers
-
- where
- -- Force Cabal >= 1.24 dep when the package is affected by #3199.
- mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
- mkDefaultSetupDeps srcpkg | affected =
- Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1,24]) mainLibSet]
- | otherwise = Nothing
- where
- gpkgdesc = srcpkgDescription srcpkg
- pkgdesc = PD.packageDescription gpkgdesc
- bt = PD.buildType pkgdesc
- affected = bt == PD.Custom && hasBuildableFalse gpkgdesc
-
- -- Does this package contain any components with non-empty 'build-depends'
- -- and a 'buildable' field that could potentially be set to 'False'? False
- -- positives are possible.
- hasBuildableFalse :: PD.GenericPackageDescription -> Bool
- hasBuildableFalse gpkg =
- not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))
- where
- buildableConditions = PD.extractConditions PD.buildable gpkg
- noDepConditions = PD.extractConditions
- (null . PD.targetBuildDepends) gpkg
- alwaysTrue (PD.Lit True) = True
- alwaysTrue _ = False
+standardInstallPolicy
+ :: InstalledPackageIndex
+ -> SourcePackageDb
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> DepResolverParams
+standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers =
+ addDefaultSetupDependencies mkDefaultSetupDeps $
+ basicInstallPolicy
+ installedPkgIndex
+ sourcePkgDb
+ pkgSpecifiers
+ where
+ -- Force Cabal >= 1.24 dep when the package is affected by #3199.
+ mkDefaultSetupDeps :: UnresolvedSourcePackage -> Maybe [Dependency]
+ mkDefaultSetupDeps srcpkg
+ | affected =
+ Just [Dependency (mkPackageName "Cabal") (orLaterVersion $ mkVersion [1, 24]) mainLibSet]
+ | otherwise = Nothing
+ where
+ gpkgdesc = srcpkgDescription srcpkg
+ pkgdesc = PD.packageDescription gpkgdesc
+ bt = PD.buildType pkgdesc
+ affected = bt == PD.Custom && hasBuildableFalse gpkgdesc
+
+ -- Does this package contain any components with non-empty 'build-depends'
+ -- and a 'buildable' field that could potentially be set to 'False'? False
+ -- positives are possible.
+ hasBuildableFalse :: PD.GenericPackageDescription -> Bool
+ hasBuildableFalse gpkg =
+ not (all alwaysTrue (zipWith PD.cOr buildableConditions noDepConditions))
+ where
+ buildableConditions = PD.extractConditions PD.buildable gpkg
+ noDepConditions =
+ PD.extractConditions
+ (null . PD.targetBuildDepends)
+ gpkg
+ alwaysTrue (PD.Lit True) = True
+ alwaysTrue _ = False
-- ------------------------------------------------------------
+
-- * Interface to the standard resolver
+
-- ------------------------------------------------------------
chooseSolver :: Verbosity -> PreSolver -> CompilerInfo -> IO Solver
chooseSolver _verbosity preSolver _cinfo =
- case preSolver of
- AlwaysModular -> do
- return Modular
+ case preSolver of
+ AlwaysModular -> do
+ return Modular
runSolver :: Solver -> SolverConfig -> DependencyResolver UnresolvedPkgLoc
runSolver Modular = modularResolver
@@ -696,279 +770,335 @@ runSolver Modular = modularResolver
-- Since this is potentially an expensive operation, the result is wrapped in a
-- a 'Progress' structure that can be unfolded to provide progress information,
-- logging messages and the final result or an error.
---
-resolveDependencies :: Platform
- -> CompilerInfo
- -> PkgConfigDb
- -> Solver
- -> DepResolverParams
- -> Progress String String SolverInstallPlan
-
- --TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
+resolveDependencies
+ :: Platform
+ -> CompilerInfo
+ -> PkgConfigDb
+ -> Solver
+ -> DepResolverParams
+ -> Progress String String SolverInstallPlan
+-- TODO: is this needed here? see dontUpgradeNonUpgradeablePackages
resolveDependencies platform comp _pkgConfigDB _solver params
- | Set.null (depResolverTargets params)
- = return (validateSolverResult platform comp indGoals [])
+ | Set.null (depResolverTargets params) =
+ return (validateSolverResult platform comp indGoals [])
where
indGoals = depResolverIndependentGoals params
-
resolveDependencies platform comp pkgConfigDB solver params =
-
- Step (showDepResolverParams finalparams)
- $ fmap (validateSolverResult platform comp indGoals)
- $ runSolver solver (SolverConfig reordGoals cntConflicts fineGrained minimize
- indGoals noReinstalls
- shadowing strFlags allowBootLibs
- -- See comment of nonUpgradeablePackages about
- -- non-installable and non-upgradable packages.
- nonUpgradeablePackages
- onlyConstrained_ maxBkjumps enableBj
- solveExes order verbosity (PruneAfterFirstSuccess False))
- platform comp installedPkgIndex sourcePkgIndex
- pkgConfigDB preferences constraints targets
+ Step (showDepResolverParams finalparams) $
+ fmap (validateSolverResult platform comp indGoals) $
+ runSolver
+ solver
+ ( SolverConfig
+ reordGoals
+ cntConflicts
+ fineGrained
+ minimize
+ indGoals
+ noReinstalls
+ shadowing
+ strFlags
+ allowBootLibs
+ -- See comment of nonUpgradeablePackages about
+ -- non-installable and non-upgradable packages.
+ nonUpgradeablePackages
+ onlyConstrained_
+ maxBkjumps
+ enableBj
+ solveExes
+ order
+ verbosity
+ (PruneAfterFirstSuccess False)
+ )
+ platform
+ comp
+ installedPkgIndex
+ sourcePkgIndex
+ pkgConfigDB
+ preferences
+ constraints
+ targets
where
-
- finalparams@(DepResolverParams
- targets constraints
- prefs defpref
- installedPkgIndex
- sourcePkgIndex
- reordGoals
- cntConflicts
- fineGrained
- minimize
- indGoals
- noReinstalls
- shadowing
- strFlags
- allowBootLibs
- onlyConstrained_
- maxBkjumps
- enableBj
- solveExes
- order
- verbosity) =
+ finalparams@( DepResolverParams
+ targets
+ constraints
+ prefs
+ defpref
+ installedPkgIndex
+ sourcePkgIndex
+ reordGoals
+ cntConflicts
+ fineGrained
+ minimize
+ indGoals
+ noReinstalls
+ shadowing
+ strFlags
+ allowBootLibs
+ onlyConstrained_
+ maxBkjumps
+ enableBj
+ solveExes
+ order
+ verbosity
+ ) =
if asBool (depResolverAllowBootLibInstalls params)
- then params
- else dontUpgradeNonUpgradeablePackages params
+ then params
+ else dontUpgradeNonUpgradeablePackages params
preferences :: PackageName -> PackagePreferences
preferences = interpretPackagesPreference targets defpref prefs
-
-- | Give an interpretation to the global 'PackagesPreference' as
-- specific per-package 'PackageVersionPreference'.
---
-interpretPackagesPreference :: Set PackageName
- -> PackagesPreferenceDefault
- -> [PackagePreference]
- -> (PackageName -> PackagePreferences)
+interpretPackagesPreference
+ :: Set PackageName
+ -> PackagesPreferenceDefault
+ -> [PackagePreference]
+ -> (PackageName -> PackagePreferences)
interpretPackagesPreference selected defaultPref prefs =
- \pkgname -> PackagePreferences (versionPref pkgname)
- (installPref pkgname)
- (stanzasPref pkgname)
+ \pkgname ->
+ PackagePreferences
+ (versionPref pkgname)
+ (installPref pkgname)
+ (stanzasPref pkgname)
where
versionPref :: PackageName -> [VersionRange]
versionPref pkgname =
fromMaybe [anyVersion] (Map.lookup pkgname versionPrefs)
- versionPrefs = Map.fromListWith (++)
- [(pkgname, [pref])
- | PackageVersionPreference pkgname pref <- prefs]
+ versionPrefs =
+ Map.fromListWith
+ (++)
+ [ (pkgname, [pref])
+ | PackageVersionPreference pkgname pref <- prefs
+ ]
installPref :: PackageName -> InstalledPreference
installPref pkgname =
fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
- installPrefs = Map.fromList
- [ (pkgname, pref)
- | PackageInstalledPreference pkgname pref <- prefs ]
+ installPrefs =
+ Map.fromList
+ [ (pkgname, pref)
+ | PackageInstalledPreference pkgname pref <- prefs
+ ]
installPrefDefault = case defaultPref of
- PreferAllLatest -> const Preference.PreferLatest
- PreferAllOldest -> const Preference.PreferOldest
- PreferAllInstalled -> const Preference.PreferInstalled
+ PreferAllLatest -> const Preference.PreferLatest
+ PreferAllOldest -> const Preference.PreferOldest
+ PreferAllInstalled -> const Preference.PreferInstalled
PreferLatestForSelected -> \pkgname ->
-- When you say cabal install foo, what you really mean is, prefer the
-- latest version of foo, but the installed version of everything else
- if pkgname `Set.member` selected then Preference.PreferLatest
- else Preference.PreferInstalled
+ if pkgname `Set.member` selected
+ then Preference.PreferLatest
+ else Preference.PreferInstalled
stanzasPref :: PackageName -> [OptionalStanza]
stanzasPref pkgname =
fromMaybe [] (Map.lookup pkgname stanzasPrefs)
- stanzasPrefs = Map.fromListWith (\a b -> nub (a ++ b))
- [ (pkgname, pref)
- | PackageStanzasPreference pkgname pref <- prefs ]
-
+ stanzasPrefs =
+ Map.fromListWith
+ (\a b -> nub (a ++ b))
+ [ (pkgname, pref)
+ | PackageStanzasPreference pkgname pref <- prefs
+ ]
-- ------------------------------------------------------------
+
-- * Checking the result of the solver
+
-- ------------------------------------------------------------
-- | Make an install plan from the output of the dep resolver.
-- It checks that the plan is valid, or it's an error in the dep resolver.
---
-validateSolverResult :: Platform
- -> CompilerInfo
- -> IndependentGoals
- -> [ResolverPackage UnresolvedPkgLoc]
- -> SolverInstallPlan
+validateSolverResult
+ :: Platform
+ -> CompilerInfo
+ -> IndependentGoals
+ -> [ResolverPackage UnresolvedPkgLoc]
+ -> SolverInstallPlan
validateSolverResult platform comp indepGoals pkgs =
- case planPackagesProblems platform comp pkgs of
- [] -> case SolverInstallPlan.new indepGoals graph of
- Right plan -> plan
- Left problems -> error (formatPlanProblems problems)
- problems -> error (formatPkgProblems problems)
-
+ case planPackagesProblems platform comp pkgs of
+ [] -> case SolverInstallPlan.new indepGoals graph of
+ Right plan -> plan
+ Left problems -> error (formatPlanProblems problems)
+ problems -> error (formatPkgProblems problems)
where
graph :: Graph.Graph (ResolverPackage UnresolvedPkgLoc)
graph = Graph.fromDistinctList pkgs
formatPkgProblems :: [PlanPackageProblem] -> String
- formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
+ formatPkgProblems = formatProblemMessage . map showPlanPackageProblem
formatPlanProblems :: [SolverInstallPlan.SolverPlanProblem] -> String
formatPlanProblems = formatProblemMessage . map SolverInstallPlan.showPlanProblem
formatProblemMessage problems =
unlines $
"internal error: could not construct a valid install plan."
- : "The proposed (invalid) plan contained the following problems:"
- : problems
- ++ "Proposed plan:"
- : [SolverInstallPlan.showPlanIndex pkgs]
-
+ : "The proposed (invalid) plan contained the following problems:"
+ : problems
+ ++ "Proposed plan:"
+ : [SolverInstallPlan.showPlanIndex pkgs]
-data PlanPackageProblem =
- InvalidConfiguredPackage (SolverPackage UnresolvedPkgLoc)
- [PackageProblem]
- | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]
+data PlanPackageProblem
+ = InvalidConfiguredPackage
+ (SolverPackage UnresolvedPkgLoc)
+ [PackageProblem]
+ | DuplicatePackageSolverId SolverId [ResolverPackage UnresolvedPkgLoc]
showPlanPackageProblem :: PlanPackageProblem -> String
showPlanPackageProblem (InvalidConfiguredPackage pkg packageProblems) =
- "Package " ++ prettyShow (packageId pkg)
- ++ " has an invalid configuration, in particular:\n"
- ++ unlines [ " " ++ showPackageProblem problem
- | problem <- packageProblems ]
+ "Package "
+ ++ prettyShow (packageId pkg)
+ ++ " has an invalid configuration, in particular:\n"
+ ++ unlines
+ [ " " ++ showPackageProblem problem
+ | problem <- packageProblems
+ ]
showPlanPackageProblem (DuplicatePackageSolverId pid dups) =
- "Package " ++ prettyShow (packageId pid) ++ " has "
- ++ show (length dups) ++ " duplicate instances."
-
-planPackagesProblems :: Platform -> CompilerInfo
- -> [ResolverPackage UnresolvedPkgLoc]
- -> [PlanPackageProblem]
+ "Package "
+ ++ prettyShow (packageId pid)
+ ++ " has "
+ ++ show (length dups)
+ ++ " duplicate instances."
+
+planPackagesProblems
+ :: Platform
+ -> CompilerInfo
+ -> [ResolverPackage UnresolvedPkgLoc]
+ -> [PlanPackageProblem]
planPackagesProblems platform cinfo pkgs =
- [ InvalidConfiguredPackage pkg packageProblems
- | Configured pkg <- pkgs
- , let packageProblems = configuredPackageProblems platform cinfo pkg
- , not (null packageProblems) ]
- ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups
- | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs ]
-
-data PackageProblem = DuplicateFlag PD.FlagName
- | MissingFlag PD.FlagName
- | ExtraFlag PD.FlagName
- | DuplicateDeps [PackageId]
- | MissingDep Dependency
- | ExtraDep PackageId
- | InvalidDep Dependency PackageId
+ [ InvalidConfiguredPackage pkg packageProblems
+ | Configured pkg <- pkgs
+ , let packageProblems = configuredPackageProblems platform cinfo pkg
+ , not (null packageProblems)
+ ]
+ ++ [ DuplicatePackageSolverId (Graph.nodeKey (Unsafe.head dups)) dups
+ | dups <- duplicatesBy (comparing Graph.nodeKey) pkgs
+ ]
+
+data PackageProblem
+ = DuplicateFlag PD.FlagName
+ | MissingFlag PD.FlagName
+ | ExtraFlag PD.FlagName
+ | DuplicateDeps [PackageId]
+ | MissingDep Dependency
+ | ExtraDep PackageId
+ | InvalidDep Dependency PackageId
showPackageProblem :: PackageProblem -> String
showPackageProblem (DuplicateFlag flag) =
"duplicate flag in the flag assignment: " ++ PD.unFlagName flag
-
showPackageProblem (MissingFlag flag) =
"missing an assignment for the flag: " ++ PD.unFlagName flag
-
showPackageProblem (ExtraFlag flag) =
"extra flag given that is not used by the package: " ++ PD.unFlagName flag
-
showPackageProblem (DuplicateDeps pkgids) =
- "duplicate packages specified as selected dependencies: "
- ++ intercalate ", " (map prettyShow pkgids)
-
+ "duplicate packages specified as selected dependencies: "
+ ++ intercalate ", " (map prettyShow pkgids)
showPackageProblem (MissingDep dep) =
- "the package has a dependency " ++ prettyShow dep
- ++ " but no package has been selected to satisfy it."
-
+ "the package has a dependency "
+ ++ prettyShow dep
+ ++ " but no package has been selected to satisfy it."
showPackageProblem (ExtraDep pkgid) =
- "the package configuration specifies " ++ prettyShow pkgid
- ++ " but (with the given flag assignment) the package does not actually"
- ++ " depend on any version of that package."
-
+ "the package configuration specifies "
+ ++ prettyShow pkgid
+ ++ " but (with the given flag assignment) the package does not actually"
+ ++ " depend on any version of that package."
showPackageProblem (InvalidDep dep pkgid) =
- "the package depends on " ++ prettyShow dep
- ++ " but the configuration specifies " ++ prettyShow pkgid
- ++ " which does not satisfy the dependency."
+ "the package depends on "
+ ++ prettyShow dep
+ ++ " but the configuration specifies "
+ ++ prettyShow pkgid
+ ++ " which does not satisfy the dependency."
-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if
-- in the configuration given by the flag assignment, all the package
-- dependencies are satisfied by the specified packages.
---
-configuredPackageProblems :: Platform -> CompilerInfo
- -> SolverPackage UnresolvedPkgLoc -> [PackageProblem]
-configuredPackageProblems platform cinfo
- (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
- [ DuplicateFlag flag
- | flag <- PD.findDuplicateFlagAssignments specifiedFlags ]
- ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ]
- ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ]
- ++ [ DuplicateDeps pkgs
- | pkgs <- CD.nonSetupDeps (fmap (duplicatesBy (comparing packageName))
- specifiedDeps1) ]
- ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ]
- ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ]
- ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps
- , not (packageSatisfiesDependency pkgid dep) ]
- -- TODO: sanity tests on executable deps
- where
- thisPkgName :: PackageName
- thisPkgName = packageName (srcpkgDescription pkg)
-
- specifiedDeps1 :: ComponentDeps [PackageId]
- specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0
-
- specifiedDeps :: [PackageId]
- specifiedDeps = CD.flatDeps specifiedDeps1
-
- mergedFlags :: [MergeResult PD.FlagName PD.FlagName]
- mergedFlags = mergeBy compare
- (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))
- (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
-
- packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool
- packageSatisfiesDependency
- (PackageIdentifier name version)
- (Dependency name' versionRange _) = assert (name == name') $
- version `withinRange` versionRange
-
- dependencyName (Dependency name _ _) = name
-
- mergedDeps :: [MergeResult Dependency PackageId]
- mergedDeps = mergeDeps requiredDeps specifiedDeps
-
- mergeDeps :: [Dependency] -> [PackageId]
- -> [MergeResult Dependency PackageId]
- mergeDeps required specified =
- let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f) in
- mergeBy
- (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
- (sortNubOn dependencyName required)
- (sortNubOn packageName specified)
-
- compSpec = enableStanzas stanzas
- -- TODO: It would be nicer to use ComponentDeps here so we can be more
- -- precise in our checks. In fact, this no longer relies on buildDepends and
- -- thus should be easier to fix. As long as we _do_ use a flat list here, we
- -- have to allow for duplicates when we fold specifiedDeps; once we have
- -- proper ComponentDeps here we should get rid of the `nubOn` in
- -- `mergeDeps`.
- requiredDeps :: [Dependency]
- requiredDeps =
- --TODO: use something lower level than finalizePD
- case finalizePD specifiedFlags
- compSpec
- (const True)
- platform cinfo
- []
- (srcpkgDescription pkg) of
- Right (resolvedPkg, _) ->
+configuredPackageProblems
+ :: Platform
+ -> CompilerInfo
+ -> SolverPackage UnresolvedPkgLoc
+ -> [PackageProblem]
+configuredPackageProblems
+ platform
+ cinfo
+ (SolverPackage pkg specifiedFlags stanzas specifiedDeps0 _specifiedExeDeps') =
+ [ DuplicateFlag flag
+ | flag <- PD.findDuplicateFlagAssignments specifiedFlags
+ ]
+ ++ [MissingFlag flag | OnlyInLeft flag <- mergedFlags]
+ ++ [ExtraFlag flag | OnlyInRight flag <- mergedFlags]
+ ++ [ DuplicateDeps pkgs
+ | pkgs <-
+ CD.nonSetupDeps
+ ( fmap
+ (duplicatesBy (comparing packageName))
+ specifiedDeps1
+ )
+ ]
+ ++ [MissingDep dep | OnlyInLeft dep <- mergedDeps]
+ ++ [ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps]
+ ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps, not (packageSatisfiesDependency pkgid dep)
+ ]
+ where
+ -- TODO: sanity tests on executable deps
+
+ thisPkgName :: PackageName
+ thisPkgName = packageName (srcpkgDescription pkg)
+
+ specifiedDeps1 :: ComponentDeps [PackageId]
+ specifiedDeps1 = fmap (map solverSrcId) specifiedDeps0
+
+ specifiedDeps :: [PackageId]
+ specifiedDeps = CD.flatDeps specifiedDeps1
+
+ mergedFlags :: [MergeResult PD.FlagName PD.FlagName]
+ mergedFlags =
+ mergeBy
+ compare
+ (sort $ map PD.flagName (PD.genPackageFlags (srcpkgDescription pkg)))
+ (sort $ map fst (PD.unFlagAssignment specifiedFlags)) -- TODO
+ packageSatisfiesDependency :: PackageIdentifier -> Dependency -> Bool
+ packageSatisfiesDependency
+ (PackageIdentifier name version)
+ (Dependency name' versionRange _) =
+ assert (name == name') $
+ version `withinRange` versionRange
+
+ dependencyName (Dependency name _ _) = name
+
+ mergedDeps :: [MergeResult Dependency PackageId]
+ mergedDeps = mergeDeps requiredDeps specifiedDeps
+
+ mergeDeps
+ :: [Dependency]
+ -> [PackageId]
+ -> [MergeResult Dependency PackageId]
+ mergeDeps required specified =
+ let sortNubOn f = nubBy ((==) `on` f) . sortBy (compare `on` f)
+ in mergeBy
+ (\dep pkgid -> dependencyName dep `compare` packageName pkgid)
+ (sortNubOn dependencyName required)
+ (sortNubOn packageName specified)
+
+ compSpec = enableStanzas stanzas
+ -- TODO: It would be nicer to use ComponentDeps here so we can be more
+ -- precise in our checks. In fact, this no longer relies on buildDepends and
+ -- thus should be easier to fix. As long as we _do_ use a flat list here, we
+ -- have to allow for duplicates when we fold specifiedDeps; once we have
+ -- proper ComponentDeps here we should get rid of the `nubOn` in
+ -- `mergeDeps`.
+ requiredDeps :: [Dependency]
+ requiredDeps =
+ -- TODO: use something lower level than finalizePD
+ case finalizePD
+ specifiedFlags
+ compSpec
+ (const True)
+ platform
+ cinfo
+ []
+ (srcpkgDescription pkg) of
+ Right (resolvedPkg, _) ->
-- we filter self/internal dependencies. They are still there.
-- This is INCORRECT.
--
@@ -976,15 +1106,17 @@ configuredPackageProblems platform cinfo
-- but no finalizePDs picks components we are not building, eg. exes.
-- See #3775
--
- filter ((/= thisPkgName) . dependencyName)
- (PD.enabledBuildDepends resolvedPkg compSpec)
- ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
- Left _ ->
- error "configuredPackageInvalidDeps internal error"
-
+ filter
+ ((/= thisPkgName) . dependencyName)
+ (PD.enabledBuildDepends resolvedPkg compSpec)
+ ++ maybe [] PD.setupDepends (PD.setupBuildInfo resolvedPkg)
+ Left _ ->
+ error "configuredPackageInvalidDeps internal error"
-- ------------------------------------------------------------
+
-- * Simple resolver that ignores dependencies
+
-- ------------------------------------------------------------
-- | A simplistic method of resolving a list of target package names to
@@ -1000,80 +1132,105 @@ configuredPackageProblems platform cinfo
--
-- Note: if no installed package index is available, it is OK to pass 'mempty'.
-- It simply means preferences for installed packages will be ignored.
---
-resolveWithoutDependencies :: DepResolverParams
- -> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
-resolveWithoutDependencies (DepResolverParams targets constraints
- prefs defpref installedPkgIndex sourcePkgIndex
- _reorderGoals _countConflicts _fineGrained
- _minimizeConflictSet _indGoals _avoidReinstalls
- _shadowing _strFlags _maxBjumps _enableBj _solveExes
- _allowBootLibInstalls _onlyConstrained _order _verbosity) =
+resolveWithoutDependencies
+ :: DepResolverParams
+ -> Either [ResolveNoDepsError] [UnresolvedSourcePackage]
+resolveWithoutDependencies
+ ( DepResolverParams
+ targets
+ constraints
+ prefs
+ defpref
+ installedPkgIndex
+ sourcePkgIndex
+ _reorderGoals
+ _countConflicts
+ _fineGrained
+ _minimizeConflictSet
+ _indGoals
+ _avoidReinstalls
+ _shadowing
+ _strFlags
+ _maxBjumps
+ _enableBj
+ _solveExes
+ _allowBootLibInstalls
+ _onlyConstrained
+ _order
+ _verbosity
+ ) =
collectEithers $ map selectPackage (Set.toList targets)
- where
- selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
- selectPackage pkgname
- | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions
- | otherwise = Right $! maximumBy bestByPrefs choices
-
- where
- -- Constraints
- requiredVersions :: VersionRange
- requiredVersions = packageConstraints pkgname
- choices :: [UnresolvedSourcePackage]
- choices = PackageIndex.lookupDependency sourcePkgIndex
- pkgname
- requiredVersions
-
- -- Preferences
- PackagePreferences preferredVersions preferInstalled _
- = packagePreferences pkgname
-
- bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
- bestByPrefs = comparing $ \pkg ->
- (installPref pkg, versionPref pkg, packageVersion pkg)
- installPref :: UnresolvedSourcePackage -> Bool
- installPref = case preferInstalled of
- Preference.PreferLatest -> const False
- Preference.PreferOldest -> const False
- Preference.PreferInstalled -> not . null
- . InstalledPackageIndex.lookupSourcePackageId
- installedPkgIndex
- . packageId
- versionPref :: Package a => a -> Int
- versionPref pkg = length . filter (packageVersion pkg `withinRange`) $
- preferredVersions
-
- packageConstraints :: PackageName -> VersionRange
- packageConstraints pkgname =
- Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
- packageVersionConstraintMap :: Map PackageName VersionRange
- packageVersionConstraintMap =
- let pcs = map unlabelPackageConstraint constraints
- in Map.fromList [ (scopeToPackageName scope, range)
- | PackageConstraint
- scope (PackagePropertyVersion range) <- pcs ]
-
- packagePreferences :: PackageName -> PackagePreferences
- packagePreferences = interpretPackagesPreference targets defpref prefs
-
+ where
+ selectPackage :: PackageName -> Either ResolveNoDepsError UnresolvedSourcePackage
+ selectPackage pkgname
+ | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions
+ | otherwise = Right $! maximumBy bestByPrefs choices
+ where
+ -- Constraints
+ requiredVersions :: VersionRange
+ requiredVersions = packageConstraints pkgname
+ choices :: [UnresolvedSourcePackage]
+ choices =
+ PackageIndex.lookupDependency
+ sourcePkgIndex
+ pkgname
+ requiredVersions
+
+ -- Preferences
+ PackagePreferences preferredVersions preferInstalled _ =
+ packagePreferences pkgname
+
+ bestByPrefs :: UnresolvedSourcePackage -> UnresolvedSourcePackage -> Ordering
+ bestByPrefs = comparing $ \pkg ->
+ (installPref pkg, versionPref pkg, packageVersion pkg)
+ installPref :: UnresolvedSourcePackage -> Bool
+ installPref = case preferInstalled of
+ Preference.PreferLatest -> const False
+ Preference.PreferOldest -> const False
+ Preference.PreferInstalled ->
+ not
+ . null
+ . InstalledPackageIndex.lookupSourcePackageId
+ installedPkgIndex
+ . packageId
+ versionPref :: Package a => a -> Int
+ versionPref pkg =
+ length . filter (packageVersion pkg `withinRange`) $
+ preferredVersions
+
+ packageConstraints :: PackageName -> VersionRange
+ packageConstraints pkgname =
+ Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
+ packageVersionConstraintMap :: Map PackageName VersionRange
+ packageVersionConstraintMap =
+ let pcs = map unlabelPackageConstraint constraints
+ in Map.fromList
+ [ (scopeToPackageName scope, range)
+ | PackageConstraint
+ scope
+ (PackagePropertyVersion range) <-
+ pcs
+ ]
+
+ packagePreferences :: PackageName -> PackagePreferences
+ packagePreferences = interpretPackagesPreference targets defpref prefs
collectEithers :: [Either a b] -> Either [a] [b]
collectEithers = collect . partitionEithers
where
collect ([], xs) = Right xs
- collect (errs,_) = Left errs
+ collect (errs, _) = Left errs
-- | Errors for 'resolveWithoutDependencies'.
---
-data ResolveNoDepsError =
-
- -- | A package name which cannot be resolved to a specific package.
- -- Also gives the constraint on the version and whether there was
- -- a constraint on the package being installed.
- ResolveUnsatisfiable PackageName VersionRange
+data ResolveNoDepsError
+ = -- | A package name which cannot be resolved to a specific package.
+ -- Also gives the constraint on the version and whether there was
+ -- a constraint on the package being installed.
+ ResolveUnsatisfiable PackageName VersionRange
instance Show ResolveNoDepsError where
show (ResolveUnsatisfiable name ver) =
- "There is no available version of " ++ prettyShow name
- ++ " that satisfies " ++ prettyShow (simplifyVersionRange ver)
+ "There is no available version of "
+ ++ prettyShow name
+ ++ " that satisfies "
+ ++ prettyShow (simplifyVersionRange ver)
diff --git a/cabal-install/src/Distribution/Client/Dependency/Types.hs b/cabal-install/src/Distribution/Client/Dependency/Types.hs
index 8ba96643d8ec1d09fefc088a2bbe23c00b92fd1d..78f976620088ad52ecb26e1daae70adc43c8c4d3 100644
--- a/cabal-install/src/Distribution/Client/Dependency/Types.hs
+++ b/cabal-install/src/Distribution/Client/Dependency/Types.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Dependency.Types (
- PreSolver(..),
- Solver(..),
- PackagesPreferenceDefault(..),
+
+module Distribution.Client.Dependency.Types
+ ( PreSolver (..)
+ , Solver (..)
+ , PackagesPreferenceDefault (..)
) where
import Distribution.Client.Compat.Prelude
@@ -12,7 +13,6 @@ import Text.PrettyPrint (text)
import qualified Distribution.Compat.CharParsing as P
-
-- | All the solvers that can be selected.
data PreSolver = AlwaysModular
deriving (Eq, Ord, Show, Bounded, Enum, Generic)
@@ -28,43 +28,35 @@ instance Structured PreSolver
instance Structured Solver
instance Pretty PreSolver where
- pretty AlwaysModular = text "modular"
+ pretty AlwaysModular = text "modular"
instance Parsec PreSolver where
- parsec = do
- name <- P.munch1 isAlpha
- case map toLower name of
- "modular" -> return AlwaysModular
- _ -> P.unexpected $ "PreSolver: " ++ name
+ parsec = do
+ name <- P.munch1 isAlpha
+ case map toLower name of
+ "modular" -> return AlwaysModular
+ _ -> P.unexpected $ "PreSolver: " ++ name
-- | Global policy for all packages to say if we prefer package versions that
-- are already installed locally or if we just prefer the latest available.
---
-data PackagesPreferenceDefault =
-
- -- | Always prefer the latest version irrespective of any existing
- -- installed version.
- --
- -- * This is the standard policy for upgrade.
- --
- PreferAllLatest
-
- -- | Always prefer the oldest version irrespective of any existing
- -- installed version or packages explicitly requested.
- --
- -- * This is enabled by --prefer-oldest.
- --
- | PreferAllOldest
-
- -- | Always prefer the installed versions over ones that would need to be
- -- installed. Secondarily, prefer latest versions (eg the latest installed
- -- version or if there are none then the latest source version).
- | PreferAllInstalled
-
- -- | Prefer the latest version for packages that are explicitly requested
- -- but prefers the installed version for any other packages.
- --
- -- * This is the standard policy for install.
- --
- | PreferLatestForSelected
- deriving Show
+data PackagesPreferenceDefault
+ = -- | Always prefer the latest version irrespective of any existing
+ -- installed version.
+ --
+ -- * This is the standard policy for upgrade.
+ PreferAllLatest
+ | -- | Always prefer the oldest version irrespective of any existing
+ -- installed version or packages explicitly requested.
+ --
+ -- * This is enabled by --prefer-oldest.
+ PreferAllOldest
+ | -- | Always prefer the installed versions over ones that would need to be
+ -- installed. Secondarily, prefer latest versions (eg the latest installed
+ -- version or if there are none then the latest source version).
+ PreferAllInstalled
+ | -- | Prefer the latest version for packages that are explicitly requested
+ -- but prefers the installed version for any other packages.
+ --
+ -- * This is the standard policy for install.
+ PreferLatestForSelected
+ deriving (Show)
diff --git a/cabal-install/src/Distribution/Client/DistDirLayout.hs b/cabal-install/src/Distribution/Client/DistDirLayout.hs
index af59bdaa0954422922c704695c1c5d61e66a71c2..2b4bc54fb3ecd517bb0db30ee93cc50fd772c022 100644
--- a/cabal-install/src/Distribution/Client/DistDirLayout.hs
+++ b/cabal-install/src/Distribution/Client/DistDirLayout.hs
@@ -4,26 +4,25 @@
--
-- The layout of the .\/dist\/ directory where cabal keeps all of its state
-- and build artifacts.
---
-module Distribution.Client.DistDirLayout (
- -- * 'DistDirLayout'
- DistDirLayout(..),
- DistDirParams(..),
- defaultDistDirLayout,
+module Distribution.Client.DistDirLayout
+ ( -- * 'DistDirLayout'
+ DistDirLayout (..)
+ , DistDirParams (..)
+ , defaultDistDirLayout
-- * 'ProjectRoot'
- ProjectRoot(..),
- defaultProjectFile,
+ , ProjectRoot (..)
+ , defaultProjectFile
-- * 'StoreDirLayout'
- StoreDirLayout(..),
- defaultStoreDirLayout,
+ , StoreDirLayout (..)
+ , defaultStoreDirLayout
-- * 'CabalDirLayout'
- CabalDirLayout(..),
- mkCabalDirLayout,
- defaultCabalDirLayout
-) where
+ , CabalDirLayout (..)
+ , mkCabalDirLayout
+ , defaultCabalDirLayout
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
@@ -31,119 +30,102 @@ import Prelude ()
import System.FilePath
import Distribution.Client.Config
- ( defaultStoreDir, defaultLogsDir)
-import Distribution.Package
- ( PackageId, PackageIdentifier, ComponentId, UnitId )
+ ( defaultLogsDir
+ , defaultStoreDir
+ )
import Distribution.Compiler
+import Distribution.Package
+ ( ComponentId
+ , PackageId
+ , PackageIdentifier
+ , UnitId
+ )
import Distribution.Simple.Compiler
- ( PackageDB(..), PackageDBStack, OptimisationLevel(..) )
+ ( OptimisationLevel (..)
+ , PackageDB (..)
+ , PackageDBStack
+ )
+import Distribution.System
import Distribution.Types.ComponentName
import Distribution.Types.LibraryName
-import Distribution.System
-
-- | Information which can be used to construct the path to
-- the build directory of a build. This is LESS fine-grained
-- than what goes into the hashed 'InstalledPackageId',
-- and for good reason: we don't want this path to change if
-- the user, say, adds a dependency to their project.
-data DistDirParams = DistDirParams {
- distParamUnitId :: UnitId,
- distParamPackageId :: PackageId,
- distParamComponentId :: ComponentId,
- distParamComponentName :: Maybe ComponentName,
- distParamCompilerId :: CompilerId,
- distParamPlatform :: Platform,
- distParamOptimization :: OptimisationLevel
- -- TODO (see #3343):
- -- Flag assignments
- -- Optimization
- }
-
+data DistDirParams = DistDirParams
+ { distParamUnitId :: UnitId
+ , distParamPackageId :: PackageId
+ , distParamComponentId :: ComponentId
+ , distParamComponentName :: Maybe ComponentName
+ , distParamCompilerId :: CompilerId
+ , distParamPlatform :: Platform
+ , distParamOptimization :: OptimisationLevel
+ -- TODO (see #3343):
+ -- Flag assignments
+ -- Optimization
+ }
-- | The layout of the project state directory. Traditionally this has been
-- called the @dist@ directory.
---
-data DistDirLayout = DistDirLayout {
-
- -- | The root directory of the project. Many other files are relative to
- -- this location (e.g. the @cabal.project@ file).
- --
- distProjectRootDirectory :: FilePath,
-
- -- | The @cabal.project@ file and related like @cabal.project.freeze@.
- -- The parameter is for the extension, like \"freeze\", or \"\" for the
- -- main file.
- --
- distProjectFile :: String -> FilePath,
-
- -- | The \"dist\" directory, which is the root of where cabal keeps all
- -- its state including the build artifacts from each package we build.
- --
- distDirectory :: FilePath,
-
- -- | The directory under dist where we keep the build artifacts for a
- -- package we're building from a local directory.
- --
- -- This uses a 'UnitId' not just a 'PackageName' because technically
- -- we can have multiple instances of the same package in a solution
- -- (e.g. setup deps).
- --
- distBuildDirectory :: DistDirParams -> FilePath,
- distBuildRootDirectory :: FilePath,
-
- -- | The directory under dist where we download tarballs and source
- -- control repos to.
- --
- distDownloadSrcDirectory :: FilePath,
-
- -- | The directory under dist where we put the unpacked sources of
- -- packages, in those cases where it makes sense to keep the build
- -- artifacts to reduce rebuild times.
- --
- distUnpackedSrcDirectory :: PackageId -> FilePath,
- distUnpackedSrcRootDirectory :: FilePath,
-
- -- | The location for project-wide cache files (e.g. state used in
- -- incremental rebuilds).
- --
- distProjectCacheFile :: String -> FilePath,
- distProjectCacheDirectory :: FilePath,
-
- -- | The location for package-specific cache files (e.g. state used in
- -- incremental rebuilds).
- --
- distPackageCacheFile :: DistDirParams -> String -> FilePath,
- distPackageCacheDirectory :: DistDirParams -> FilePath,
-
- -- | The location that sdists are placed by default.
- distSdistFile :: PackageId -> FilePath,
- distSdistDirectory :: FilePath,
-
- distTempDirectory :: FilePath,
- distBinDirectory :: FilePath,
-
- distPackageDB :: CompilerId -> PackageDB,
-
- -- | Is needed when `--haddock-output-dir` flag is used.
- distHaddockOutputDir :: Maybe FilePath
- }
-
+data DistDirLayout = DistDirLayout
+ { distProjectRootDirectory :: FilePath
+ -- ^ The root directory of the project. Many other files are relative to
+ -- this location (e.g. the @cabal.project@ file).
+ , distProjectFile :: String -> FilePath
+ -- ^ The @cabal.project@ file and related like @cabal.project.freeze@.
+ -- The parameter is for the extension, like \"freeze\", or \"\" for the
+ -- main file.
+ , distDirectory :: FilePath
+ -- ^ The \"dist\" directory, which is the root of where cabal keeps all
+ -- its state including the build artifacts from each package we build.
+ , distBuildDirectory :: DistDirParams -> FilePath
+ -- ^ The directory under dist where we keep the build artifacts for a
+ -- package we're building from a local directory.
+ --
+ -- This uses a 'UnitId' not just a 'PackageName' because technically
+ -- we can have multiple instances of the same package in a solution
+ -- (e.g. setup deps).
+ , distBuildRootDirectory :: FilePath
+ , distDownloadSrcDirectory :: FilePath
+ -- ^ The directory under dist where we download tarballs and source
+ -- control repos to.
+ , distUnpackedSrcDirectory :: PackageId -> FilePath
+ -- ^ The directory under dist where we put the unpacked sources of
+ -- packages, in those cases where it makes sense to keep the build
+ -- artifacts to reduce rebuild times.
+ , distUnpackedSrcRootDirectory :: FilePath
+ , distProjectCacheFile :: String -> FilePath
+ -- ^ The location for project-wide cache files (e.g. state used in
+ -- incremental rebuilds).
+ , distProjectCacheDirectory :: FilePath
+ , distPackageCacheFile :: DistDirParams -> String -> FilePath
+ -- ^ The location for package-specific cache files (e.g. state used in
+ -- incremental rebuilds).
+ , distPackageCacheDirectory :: DistDirParams -> FilePath
+ , distSdistFile :: PackageId -> FilePath
+ -- ^ The location that sdists are placed by default.
+ , distSdistDirectory :: FilePath
+ , distTempDirectory :: FilePath
+ , distBinDirectory :: FilePath
+ , distPackageDB :: CompilerId -> PackageDB
+ , distHaddockOutputDir :: Maybe FilePath
+ -- ^ Is needed when `--haddock-output-dir` flag is used.
+ }
-- | The layout of a cabal nix-style store.
---
-data StoreDirLayout = StoreDirLayout {
- storeDirectory :: CompilerId -> FilePath,
- storePackageDirectory :: CompilerId -> UnitId -> FilePath,
- storePackageDBPath :: CompilerId -> FilePath,
- storePackageDB :: CompilerId -> PackageDB,
- storePackageDBStack :: CompilerId -> PackageDBStack,
- storeIncomingDirectory :: CompilerId -> FilePath,
- storeIncomingLock :: CompilerId -> UnitId -> FilePath
- }
-
-
---TODO: move to another module, e.g. CabalDirLayout?
+data StoreDirLayout = StoreDirLayout
+ { storeDirectory :: CompilerId -> FilePath
+ , storePackageDirectory :: CompilerId -> UnitId -> FilePath
+ , storePackageDBPath :: CompilerId -> FilePath
+ , storePackageDB :: CompilerId -> PackageDB
+ , storePackageDBStack :: CompilerId -> PackageDBStack
+ , storeIncomingDirectory :: CompilerId -> FilePath
+ , storeIncomingLock :: CompilerId -> UnitId -> FilePath
+ }
+
+-- TODO: move to another module, e.g. CabalDirLayout?
-- or perhaps rename this module to DirLayouts.
-- | The layout of the user-wide cabal directory, that is the @~/.cabal@ dir
@@ -151,32 +133,26 @@ data StoreDirLayout = StoreDirLayout {
--
-- At the moment this is just a partial specification, but the idea is
-- eventually to cover it all.
---
-data CabalDirLayout = CabalDirLayout {
- cabalStoreDirLayout :: StoreDirLayout,
-
- cabalLogsDirectory :: FilePath
- }
-
+data CabalDirLayout = CabalDirLayout
+ { cabalStoreDirLayout :: StoreDirLayout
+ , cabalLogsDirectory :: FilePath
+ }
-- | Information about the root directory of the project.
--
-- It can either be an implicit project root in the current dir if no
-- @cabal.project@ file is found, or an explicit root if either
-- the file is found or the project root directory was specicied.
---
-data ProjectRoot =
- -- | An implicit project root. It contains the absolute project
- -- root dir.
- ProjectRootImplicit FilePath
-
- -- | An explicit project root. It contains the absolute project
- -- root dir and the relative @cabal.project@ file (or explicit override)
- | ProjectRootExplicit FilePath FilePath
-
- -- | An explicit, absolute project root dir and an explicit, absolute
- -- @cabal.project@ file.
- | ProjectRootExplicitAbsolute FilePath FilePath
+data ProjectRoot
+ = -- | An implicit project root. It contains the absolute project
+ -- root dir.
+ ProjectRootImplicit FilePath
+ | -- | An explicit project root. It contains the absolute project
+ -- root dir and the relative @cabal.project@ file (or explicit override)
+ ProjectRootExplicit FilePath FilePath
+ | -- | An explicit, absolute project root dir and an explicit, absolute
+ -- @cabal.project@ file.
+ ProjectRootExplicitAbsolute FilePath FilePath
deriving (Eq, Show)
defaultProjectFile :: FilePath
@@ -185,66 +161,74 @@ defaultProjectFile = "cabal.project"
-- | Make the default 'DistDirLayout' based on the project root dir and
-- optional overrides for the location of the @dist@ directory, the
-- @cabal.project@ file and the documentation directory.
---
-defaultDistDirLayout :: ProjectRoot -- ^ the project root
- -> Maybe FilePath -- ^ the @dist@ directory or default
- -- (absolute or relative to the root)
- -> Maybe FilePath -- ^ the documentation directory
- -> DistDirLayout
+defaultDistDirLayout
+ :: ProjectRoot
+ -- ^ the project root
+ -> Maybe FilePath
+ -- ^ the @dist@ directory or default
+ -- (absolute or relative to the root)
+ -> Maybe FilePath
+ -- ^ the documentation directory
+ -> DistDirLayout
defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir =
- DistDirLayout {..}
+ DistDirLayout{..}
where
(projectRootDir, projectFile) = case projectRoot of
- ProjectRootImplicit dir -> (dir, dir </> defaultProjectFile)
- ProjectRootExplicit dir file -> (dir, dir </> file)
+ ProjectRootImplicit dir -> (dir, dir </> defaultProjectFile)
+ ProjectRootExplicit dir file -> (dir, dir </> file)
ProjectRootExplicitAbsolute dir file -> (dir, file)
distProjectRootDirectory :: FilePath
distProjectRootDirectory = projectRootDir
distProjectFile :: String -> FilePath
- distProjectFile ext = projectFile <.> ext
+ distProjectFile ext = projectFile <.> ext
distDirectory :: FilePath
- distDirectory = distProjectRootDirectory
- </> fromMaybe "dist-newstyle" mdistDirectory
- --TODO: switch to just dist at some point, or some other new name
+ distDirectory =
+ distProjectRootDirectory
+ </> fromMaybe "dist-newstyle" mdistDirectory
+ -- TODO: switch to just dist at some point, or some other new name
distBuildRootDirectory :: FilePath
- distBuildRootDirectory = distDirectory </> "build"
+ distBuildRootDirectory = distDirectory </> "build"
distBuildDirectory :: DistDirParams -> FilePath
distBuildDirectory params =
- distBuildRootDirectory </>
- prettyShow (distParamPlatform params) </>
- prettyShow (distParamCompilerId params) </>
- prettyShow (distParamPackageId params) </>
- (case distParamComponentName params of
- Nothing -> ""
- Just (CLibName LMainLibName) -> ""
- Just (CLibName (LSubLibName name)) -> "l" </> prettyShow name
- Just (CFLibName name) -> "f" </> prettyShow name
- Just (CExeName name) -> "x" </> prettyShow name
- Just (CTestName name) -> "t" </> prettyShow name
- Just (CBenchName name) -> "b" </> prettyShow name) </>
- (case distParamOptimization params of
- NoOptimisation -> "noopt"
- NormalOptimisation -> ""
- MaximumOptimisation -> "opt") </>
- (let uid_str = prettyShow (distParamUnitId params)
- in if uid_str == prettyShow (distParamComponentId params)
- then ""
- else uid_str)
+ distBuildRootDirectory
+ </> prettyShow (distParamPlatform params)
+ </> prettyShow (distParamCompilerId params)
+ </> prettyShow (distParamPackageId params)
+ </> ( case distParamComponentName params of
+ Nothing -> ""
+ Just (CLibName LMainLibName) -> ""
+ Just (CLibName (LSubLibName name)) -> "l" </> prettyShow name
+ Just (CFLibName name) -> "f" </> prettyShow name
+ Just (CExeName name) -> "x" </> prettyShow name
+ Just (CTestName name) -> "t" </> prettyShow name
+ Just (CBenchName name) -> "b" </> prettyShow name
+ )
+ </> ( case distParamOptimization params of
+ NoOptimisation -> "noopt"
+ NormalOptimisation -> ""
+ MaximumOptimisation -> "opt"
+ )
+ </> ( let uid_str = prettyShow (distParamUnitId params)
+ in if uid_str == prettyShow (distParamComponentId params)
+ then ""
+ else uid_str
+ )
distUnpackedSrcRootDirectory :: FilePath
- distUnpackedSrcRootDirectory = distDirectory </> "src"
+ distUnpackedSrcRootDirectory = distDirectory </> "src"
distUnpackedSrcDirectory :: PackageId -> FilePath
- distUnpackedSrcDirectory pkgid = distUnpackedSrcRootDirectory
- </> prettyShow pkgid
+ distUnpackedSrcDirectory pkgid =
+ distUnpackedSrcRootDirectory
+ </> prettyShow pkgid
-- we shouldn't get name clashes so this should be fine:
distDownloadSrcDirectory :: FilePath
- distDownloadSrcDirectory = distUnpackedSrcRootDirectory
+ distDownloadSrcDirectory = distUnpackedSrcRootDirectory
distProjectCacheDirectory :: FilePath
distProjectCacheDirectory = distDirectory </> "cache"
@@ -281,7 +265,7 @@ defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir =
defaultStoreDirLayout :: FilePath -> StoreDirLayout
defaultStoreDirLayout storeRoot =
- StoreDirLayout {..}
+ StoreDirLayout{..}
where
storeDirectory :: CompilerId -> FilePath
storeDirectory compid =
@@ -311,17 +295,19 @@ defaultStoreDirLayout storeRoot =
storeIncomingLock compid unitid =
storeIncomingDirectory compid </> prettyShow unitid <.> "lock"
-
defaultCabalDirLayout :: IO CabalDirLayout
defaultCabalDirLayout =
- mkCabalDirLayout Nothing Nothing
-
-mkCabalDirLayout :: Maybe FilePath -- ^ Store directory. Must be absolute
- -> Maybe FilePath -- ^ Log directory
- -> IO CabalDirLayout
+ mkCabalDirLayout Nothing Nothing
+
+mkCabalDirLayout
+ :: Maybe FilePath
+ -- ^ Store directory. Must be absolute
+ -> Maybe FilePath
+ -- ^ Log directory
+ -> IO CabalDirLayout
mkCabalDirLayout mstoreDir mlogDir = do
- cabalStoreDirLayout <-
- defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir
- cabalLogsDirectory <-
- maybe defaultLogsDir pure mlogDir
- pure $ CabalDirLayout {..}
+ cabalStoreDirLayout <-
+ defaultStoreDirLayout <$> maybe defaultStoreDir pure mstoreDir
+ cabalLogsDirectory <-
+ maybe defaultLogsDir pure mlogDir
+ pure $ CabalDirLayout{..}
diff --git a/cabal-install/src/Distribution/Client/Fetch.hs b/cabal-install/src/Distribution/Client/Fetch.hs
index 9dcdfb902a9d3643719a4d0a7f01e432a97d71cb..724c583b661c5e5ec3e7d6a5c6cce4c5f8d93e39 100644
--- a/cabal-install/src/Distribution/Client/Fetch.hs
+++ b/cabal-install/src/Distribution/Client/Fetch.hs
@@ -10,223 +10,267 @@
--
-- The cabal fetch command
-----------------------------------------------------------------------------
-module Distribution.Client.Fetch (
- fetch,
+module Distribution.Client.Fetch
+ ( fetch
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.Types
-import Distribution.Client.Targets
-import Distribution.Client.FetchUtils hiding (fetchPackage)
import Distribution.Client.Dependency
+import Distribution.Client.FetchUtils hiding (fetchPackage)
import Distribution.Client.IndexUtils as IndexUtils
- ( getSourcePackages, getInstalledPackages )
-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
+ ( getInstalledPackages
+ , getSourcePackages
+ )
import Distribution.Client.Setup
- ( GlobalFlags(..), FetchFlags(..), RepoContext(..) )
+ ( FetchFlags (..)
+ , GlobalFlags (..)
+ , RepoContext (..)
+ )
+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
+import Distribution.Client.Targets
+import Distribution.Client.Types
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb, readPkgConfigDb )
+import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, readPkgConfigDb)
import Distribution.Solver.Types.SolverPackage
import Distribution.Solver.Types.SourcePackage
import Distribution.Package
- ( packageId )
+ ( packageId
+ )
import Distribution.Simple.Compiler
- ( Compiler, compilerInfo, PackageDBStack )
+ ( Compiler
+ , PackageDBStack
+ , compilerInfo
+ )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
- ( ProgramDb )
+ ( ProgramDb
+ )
import Distribution.Simple.Setup
- ( fromFlag, fromFlagOrDefault )
+ ( fromFlag
+ , fromFlagOrDefault
+ )
import Distribution.Simple.Utils
- ( die', notice, debug )
+ ( debug
+ , die'
+ , notice
+ )
import Distribution.System
- ( Platform )
+ ( Platform
+ )
-- ------------------------------------------------------------
+
-- * The fetch command
+
-- ------------------------------------------------------------
---TODO:
+-- TODO:
+
-- * add fetch -o support
+
-- * support tarball URLs via ad-hoc download cache (or in -o mode?)
+
-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied
+
-- * Port various flags from install:
+
-- * --upgrade-dependencies
-- * --constraint and --preference
-- * --only-dependencies, but note it conflicts with --no-deps
-
-- | Fetch a list of packages and their dependencies.
---
-fetch :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> Platform
- -> ProgramDb
- -> GlobalFlags
- -> FetchFlags
- -> [UserTarget]
- -> IO ()
+fetch
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> GlobalFlags
+ -> FetchFlags
+ -> [UserTarget]
+ -> IO ()
fetch verbosity _ _ _ _ _ _ _ [] =
- notice verbosity "No packages requested. Nothing to do."
-
-fetch verbosity packageDBs repoCtxt comp platform progdb
- _ fetchFlags userTargets = do
-
+ notice verbosity "No packages requested. Nothing to do."
+fetch
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ platform
+ progdb
+ _
+ fetchFlags
+ userTargets = do
traverse_ (checkTarget verbosity) userTargets
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
- sourcePkgDb <- getSourcePackages verbosity repoCtxt
- pkgConfigDb <- readPkgConfigDb verbosity progdb
-
- pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
- (packageIndex sourcePkgDb)
- userTargets
-
- pkgs <- planPackages
- verbosity comp platform fetchFlags
- installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
+ sourcePkgDb <- getSourcePackages verbosity repoCtxt
+ pkgConfigDb <- readPkgConfigDb verbosity progdb
+
+ pkgSpecifiers <-
+ resolveUserTargets
+ verbosity
+ repoCtxt
+ (packageIndex sourcePkgDb)
+ userTargets
+
+ pkgs <-
+ planPackages
+ verbosity
+ comp
+ platform
+ fetchFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+ pkgSpecifiers
pkgs' <- filterM (fmap not . isFetched . srcpkgSource) pkgs
if null pkgs'
- --TODO: when we add support for remote tarballs then this message
+ then -- TODO: when we add support for remote tarballs then this message
-- will need to be changed because for remote tarballs we fetch them
-- at the earlier phase.
- then notice verbosity $ "No packages need to be fetched. "
- ++ "All the requested packages are already local "
- ++ "or cached locally."
- else if dryRun
- then notice verbosity $ unlines $
- "The following packages would be fetched:"
- : map (prettyShow . packageId) pkgs'
-
- else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs'
-
- where
- dryRun = fromFlag (fetchDryRun fetchFlags)
-
-planPackages :: Verbosity
- -> Compiler
- -> Platform
- -> FetchFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> PkgConfigDb
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> IO [UnresolvedSourcePackage]
-planPackages verbosity comp platform fetchFlags
- installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
-
- | includeDependencies = do
- solver <- chooseSolver verbosity
- (fromFlag (fetchSolver fetchFlags)) (compilerInfo comp)
- notice verbosity "Resolving dependencies..."
- installPlan <- foldProgress logMsg (die' verbosity) return $
- resolveDependencies
- platform (compilerInfo comp) pkgConfigDb
- solver
- resolverParams
-
- -- The packages we want to fetch are those packages the 'InstallPlan'
- -- that are in the 'InstallPlan.Configured' state.
- return
- [ solverPkgSource cpkg
- | (SolverInstallPlan.Configured cpkg)
- <- SolverInstallPlan.toList installPlan ]
-
- | otherwise =
- either (die' verbosity . unlines . map show) return $
- resolveWithoutDependencies resolverParams
-
- where
- resolverParams :: DepResolverParams
- resolverParams =
-
- setMaxBackjumps (if maxBackjumps < 0 then Nothing
- else Just maxBackjumps)
-
- . setIndependentGoals independentGoals
-
- . setReorderGoals reorderGoals
-
- . setCountConflicts countConflicts
-
- . setFineGrainedConflicts fineGrainedConflicts
-
- . setMinimizeConflictSet minimizeConflictSet
-
- . setShadowPkgs shadowPkgs
-
- . setStrongFlags strongFlags
-
- . setAllowBootLibInstalls allowBootLibInstalls
-
- . setOnlyConstrained onlyConstrained
-
- . setSolverVerbosity verbosity
-
- . addConstraints
- [ let pc = PackageConstraint
- (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
- (PackagePropertyStanzas stanzas)
- in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
- | pkgSpecifier <- pkgSpecifiers ]
-
- -- Reinstall the targets given on the command line so that the dep
- -- resolver will decide that they need fetching, even if they're
- -- already installed. Since we want to get the source packages of
- -- things we might have installed (but not have the sources for).
- . reinstallTargets
-
- $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
-
- includeDependencies = fromFlag (fetchDeps fetchFlags)
- logMsg message rest = debug verbosity message >> rest
-
- stanzas = [ TestStanzas | testsEnabled ]
- ++ [ BenchStanzas | benchmarksEnabled ]
- testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags
- benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags
-
- reorderGoals = fromFlag (fetchReorderGoals fetchFlags)
- countConflicts = fromFlag (fetchCountConflicts fetchFlags)
- fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags)
- minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags)
- independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
- shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
- strongFlags = fromFlag (fetchStrongFlags fetchFlags)
- maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags)
- allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags)
- onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags)
+ notice verbosity $
+ "No packages need to be fetched. "
+ ++ "All the requested packages are already local "
+ ++ "or cached locally."
+ else
+ if dryRun
+ then
+ notice verbosity $
+ unlines $
+ "The following packages would be fetched:"
+ : map (prettyShow . packageId) pkgs'
+ else traverse_ (fetchPackage verbosity repoCtxt . srcpkgSource) pkgs'
+ where
+ dryRun = fromFlag (fetchDryRun fetchFlags)
+
+planPackages
+ :: Verbosity
+ -> Compiler
+ -> Platform
+ -> FetchFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> PkgConfigDb
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> IO [UnresolvedSourcePackage]
+planPackages
+ verbosity
+ comp
+ platform
+ fetchFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+ pkgSpecifiers
+ | includeDependencies = do
+ solver <-
+ chooseSolver
+ verbosity
+ (fromFlag (fetchSolver fetchFlags))
+ (compilerInfo comp)
+ notice verbosity "Resolving dependencies..."
+ installPlan <-
+ foldProgress logMsg (die' verbosity) return $
+ resolveDependencies
+ platform
+ (compilerInfo comp)
+ pkgConfigDb
+ solver
+ resolverParams
+
+ -- The packages we want to fetch are those packages the 'InstallPlan'
+ -- that are in the 'InstallPlan.Configured' state.
+ return
+ [ solverPkgSource cpkg
+ | (SolverInstallPlan.Configured cpkg) <-
+ SolverInstallPlan.toList installPlan
+ ]
+ | otherwise =
+ either (die' verbosity . unlines . map show) return $
+ resolveWithoutDependencies resolverParams
+ where
+ resolverParams :: DepResolverParams
+ resolverParams =
+ setMaxBackjumps
+ ( if maxBackjumps < 0
+ then Nothing
+ else Just maxBackjumps
+ )
+ . setIndependentGoals independentGoals
+ . setReorderGoals reorderGoals
+ . setCountConflicts countConflicts
+ . setFineGrainedConflicts fineGrainedConflicts
+ . setMinimizeConflictSet minimizeConflictSet
+ . setShadowPkgs shadowPkgs
+ . setStrongFlags strongFlags
+ . setAllowBootLibInstalls allowBootLibInstalls
+ . setOnlyConstrained onlyConstrained
+ . setSolverVerbosity verbosity
+ . addConstraints
+ [ let pc =
+ PackageConstraint
+ (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
+ (PackagePropertyStanzas stanzas)
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
+ | pkgSpecifier <- pkgSpecifiers
+ ]
+ -- Reinstall the targets given on the command line so that the dep
+ -- resolver will decide that they need fetching, even if they're
+ -- already installed. Since we want to get the source packages of
+ -- things we might have installed (but not have the sources for).
+ . reinstallTargets
+ $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+
+ includeDependencies = fromFlag (fetchDeps fetchFlags)
+ logMsg message rest = debug verbosity message >> rest
+
+ stanzas =
+ [TestStanzas | testsEnabled]
+ ++ [BenchStanzas | benchmarksEnabled]
+ testsEnabled = fromFlagOrDefault False $ fetchTests fetchFlags
+ benchmarksEnabled = fromFlagOrDefault False $ fetchBenchmarks fetchFlags
+
+ reorderGoals = fromFlag (fetchReorderGoals fetchFlags)
+ countConflicts = fromFlag (fetchCountConflicts fetchFlags)
+ fineGrainedConflicts = fromFlag (fetchFineGrainedConflicts fetchFlags)
+ minimizeConflictSet = fromFlag (fetchMinimizeConflictSet fetchFlags)
+ independentGoals = fromFlag (fetchIndependentGoals fetchFlags)
+ shadowPkgs = fromFlag (fetchShadowPkgs fetchFlags)
+ strongFlags = fromFlag (fetchStrongFlags fetchFlags)
+ maxBackjumps = fromFlag (fetchMaxBackjumps fetchFlags)
+ allowBootLibInstalls = fromFlag (fetchAllowBootLibInstalls fetchFlags)
+ onlyConstrained = fromFlag (fetchOnlyConstrained fetchFlags)
checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget verbosity target = case target of
- UserTargetRemoteTarball _uri
- -> die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "
- ++ "In the meantime you can use the 'unpack' commands."
- _ -> return ()
+ UserTargetRemoteTarball _uri ->
+ die' verbosity $
+ "The 'fetch' command does not yet support remote tarballs. "
+ ++ "In the meantime you can use the 'unpack' commands."
+ _ -> return ()
fetchPackage :: Verbosity -> RepoContext -> PackageLocation a -> IO ()
fetchPackage verbosity repoCtxt pkgsrc = case pkgsrc of
- LocalUnpackedPackage _dir -> return ()
- LocalTarballPackage _file -> return ()
-
- RemoteTarballPackage _uri _ ->
- die' verbosity $ "The 'fetch' command does not yet support remote tarballs. "
- ++ "In the meantime you can use the 'unpack' commands."
-
- RemoteSourceRepoPackage _repo _ ->
- die' verbosity $ "The 'fetch' command does not yet support remote "
- ++ "source repositories."
-
- RepoTarballPackage repo pkgid _ -> do
- _ <- fetchRepoTarball verbosity repoCtxt repo pkgid
- return ()
+ LocalUnpackedPackage _dir -> return ()
+ LocalTarballPackage _file -> return ()
+ RemoteTarballPackage _uri _ ->
+ die' verbosity $
+ "The 'fetch' command does not yet support remote tarballs. "
+ ++ "In the meantime you can use the 'unpack' commands."
+ RemoteSourceRepoPackage _repo _ ->
+ die' verbosity $
+ "The 'fetch' command does not yet support remote "
+ ++ "source repositories."
+ RepoTarballPackage repo pkgid _ -> do
+ _ <- fetchRepoTarball verbosity repoCtxt repo pkgid
+ return ()
diff --git a/cabal-install/src/Distribution/Client/FetchUtils.hs b/cabal-install/src/Distribution/Client/FetchUtils.hs
index 0a493d493f70015eb12695125db5dc437f199c67..2ad9ea2c235cce9bf08b6c126635458c2458911f 100644
--- a/cabal-install/src/Distribution/Client/FetchUtils.hs
+++ b/cabal-install/src/Distribution/Client/FetchUtils.hs
@@ -1,4 +1,10 @@
-----------------------------------------------------------------------------
+-----------------------------------------------------------------------------
+{-# LANGUAGE RecordWildCards #-}
+-----------------------------------------------------------------------------
+-----------------------------------------------------------------------------
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- |
-- Module : Distribution.Client.FetchUtils
-- Copyright : (c) David Himmelstrup 2005
@@ -10,177 +16,201 @@
-- Portability : portable
--
-- Functions for fetching packages
------------------------------------------------------------------------------
-{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}
-module Distribution.Client.FetchUtils (
-
- -- * fetching packages
- fetchPackage,
- isFetched,
- checkFetched,
+module Distribution.Client.FetchUtils
+ ( -- * fetching packages
+ fetchPackage
+ , isFetched
+ , checkFetched
-- ** specifically for repo packages
- checkRepoTarballFetched,
- fetchRepoTarball,
- verifyFetchedTarball,
+ , checkRepoTarballFetched
+ , fetchRepoTarball
+ , verifyFetchedTarball
-- ** fetching packages asynchronously
- asyncFetchPackages,
- waitAsyncFetchPackage,
- AsyncFetchMap,
+ , asyncFetchPackages
+ , waitAsyncFetchPackage
+ , AsyncFetchMap
-- * fetching other things
- downloadIndex,
+ , downloadIndex
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.Types
import Distribution.Client.HttpUtils
- ( downloadURI, isOldHackageURI, DownloadResult(..)
- , HttpTransport(..), transportCheckHttps, remoteRepoCheckHttps )
+ ( DownloadResult (..)
+ , HttpTransport (..)
+ , downloadURI
+ , isOldHackageURI
+ , remoteRepoCheckHttps
+ , transportCheckHttps
+ )
+import Distribution.Client.Types
+import Distribution.Client.GlobalFlags
+ ( RepoContext (..)
+ )
+import Distribution.Client.Utils
+ ( ProgressPhase (..)
+ , progressMessage
+ )
import Distribution.Package
- ( PackageId, packageName, packageVersion )
+ ( PackageId
+ , packageName
+ , packageVersion
+ )
import Distribution.Simple.Utils
- ( notice, info, debug, warn, die' )
+ ( debug
+ , die'
+ , info
+ , notice
+ , warn
+ )
import Distribution.Verbosity
- ( verboseUnmarkOutput )
-import Distribution.Client.GlobalFlags
- ( RepoContext(..) )
-import Distribution.Client.Utils
- ( ProgressPhase(..), progressMessage )
+ ( verboseUnmarkOutput
+ )
-import qualified Data.Map as Map
-import qualified Control.Exception.Safe as Safe
import Control.Concurrent.Async
import Control.Concurrent.MVar
+import qualified Control.Exception.Safe as Safe
+import qualified Data.Map as Map
+import Network.URI
+ ( URI (uriPath)
+ )
import System.Directory
- ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory
- , getFileSize )
-import System.IO
- ( openTempFile, hClose )
+ ( createDirectoryIfMissing
+ , doesFileExist
+ , getFileSize
+ , getTemporaryDirectory
+ )
import System.FilePath
- ( (</>), (<.>) )
+ ( (<.>)
+ , (</>)
+ )
import qualified System.FilePath.Posix as FilePath.Posix
- ( combine, joinPath )
-import Network.URI
- ( URI(uriPath) )
+ ( combine
+ , joinPath
+ )
+import System.IO
+ ( hClose
+ , openTempFile
+ )
import qualified Hackage.Security.Client as Sec
-import qualified Hackage.Security.Util.Path as Sec
import qualified Hackage.Security.Util.Checked as Sec
+import qualified Hackage.Security.Util.Path as Sec
-- ------------------------------------------------------------
+
-- * Actually fetch things
+
-- ------------------------------------------------------------
-- | Returns @True@ if the package has already been fetched
-- or does not need fetching.
---
isFetched :: UnresolvedPkgLoc -> IO Bool
isFetched loc = case loc of
- LocalUnpackedPackage _dir -> return True
- LocalTarballPackage _file -> return True
- RemoteTarballPackage _uri local -> return (isJust local)
- RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
- RemoteSourceRepoPackage _ local -> return (isJust local)
-
+ LocalUnpackedPackage _dir -> return True
+ LocalTarballPackage _file -> return True
+ RemoteTarballPackage _uri local -> return (isJust local)
+ RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)
+ RemoteSourceRepoPackage _ local -> return (isJust local)
-- | Checks if the package has already been fetched (or does not need
-- fetching) and if so returns evidence in the form of a 'PackageLocation'
-- with a resolved local file location.
---
-checkFetched :: UnresolvedPkgLoc
- -> IO (Maybe ResolvedPkgLoc)
+checkFetched
+ :: UnresolvedPkgLoc
+ -> IO (Maybe ResolvedPkgLoc)
checkFetched loc = case loc of
- LocalUnpackedPackage dir ->
- return (Just $ LocalUnpackedPackage dir)
- LocalTarballPackage file ->
- return (Just $ LocalTarballPackage file)
- RemoteTarballPackage uri (Just file) ->
- return (Just $ RemoteTarballPackage uri file)
- RepoTarballPackage repo pkgid (Just file) ->
- return (Just $ RepoTarballPackage repo pkgid file)
- RemoteSourceRepoPackage repo (Just file) ->
- return (Just $ RemoteSourceRepoPackage repo file)
-
- RemoteTarballPackage _uri Nothing -> return Nothing
- RemoteSourceRepoPackage _repo Nothing -> return Nothing
- RepoTarballPackage repo pkgid Nothing ->
- fmap (fmap (RepoTarballPackage repo pkgid))
- (checkRepoTarballFetched repo pkgid)
+ LocalUnpackedPackage dir ->
+ return (Just $ LocalUnpackedPackage dir)
+ LocalTarballPackage file ->
+ return (Just $ LocalTarballPackage file)
+ RemoteTarballPackage uri (Just file) ->
+ return (Just $ RemoteTarballPackage uri file)
+ RepoTarballPackage repo pkgid (Just file) ->
+ return (Just $ RepoTarballPackage repo pkgid file)
+ RemoteSourceRepoPackage repo (Just file) ->
+ return (Just $ RemoteSourceRepoPackage repo file)
+ RemoteTarballPackage _uri Nothing -> return Nothing
+ RemoteSourceRepoPackage _repo Nothing -> return Nothing
+ RepoTarballPackage repo pkgid Nothing ->
+ fmap
+ (fmap (RepoTarballPackage repo pkgid))
+ (checkRepoTarballFetched repo pkgid)
-- | Like 'checkFetched' but for the specific case of a 'RepoTarballPackage'.
---
checkRepoTarballFetched :: Repo -> PackageId -> IO (Maybe FilePath)
checkRepoTarballFetched repo pkgid = do
- let file = packageFile repo pkgid
- exists <- doesFileExist file
- if exists
- then return (Just file)
- else return Nothing
+ let file = packageFile repo pkgid
+ exists <- doesFileExist file
+ if exists
+ then return (Just file)
+ else return Nothing
verifyFetchedTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO Bool
verifyFetchedTarball verbosity repoCtxt repo pkgid =
- let file = packageFile repo pkgid
- handleError :: IO Bool -> IO Bool
- handleError act = do
- res <- Safe.try act
- case res of
- Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False
- Right b -> pure b
+ let file = packageFile repo pkgid
+ handleError :: IO Bool -> IO Bool
+ handleError act = do
+ res <- Safe.try act
+ case res of
+ Left e -> warn verbosity ("Error verifying fetched tarball " ++ file ++ ", will redownload: " ++ show (e :: SomeException)) >> pure False
+ Right b -> pure b
in handleError $ do
exists <- doesFileExist file
if not exists
then return True -- if the file does not exist, it vacuously passes validation, since it will be downloaded as necessary with what we will then check is a valid hash.
else case repo of
-- a secure repo has hashes we can compare against to confirm this is the correct file.
- RepoSecure{} ->
- repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
- Sec.withIndex repoSecure $ \callbacks ->
- let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False
- -- the do block in parens is due to dealing with the checked exceptions mechanism.
- in (do fileInfo <- Sec.indexLookupFileInfo callbacks pkgid
- sz <- Sec.FileLength . fromInteger <$> getFileSize file
- if sz /= Sec.fileInfoLength (Sec.trusted fileInfo)
- then warnAndFail "file length mismatch"
- else do
- res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute)
- if res
- then pure True
- else warnAndFail "file hash mismatch")
- `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e))
- `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e))
- _ -> pure True
+ RepoSecure{} ->
+ repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
+ Sec.withIndex repoSecure $ \callbacks ->
+ let warnAndFail s = warn verbosity ("Fetched tarball " ++ file ++ " does not match server, will redownload: " ++ s) >> return False
+ in -- the do block in parens is due to dealing with the checked exceptions mechanism.
+ ( do
+ fileInfo <- Sec.indexLookupFileInfo callbacks pkgid
+ sz <- Sec.FileLength . fromInteger <$> getFileSize file
+ if sz /= Sec.fileInfoLength (Sec.trusted fileInfo)
+ then warnAndFail "file length mismatch"
+ else do
+ res <- Sec.compareTrustedFileInfo (Sec.trusted fileInfo) <$> Sec.computeFileInfo (Sec.Path file :: Sec.Path Sec.Absolute)
+ if res
+ then pure True
+ else warnAndFail "file hash mismatch"
+ )
+ `Sec.catchChecked` (\(e :: Sec.InvalidPackageException) -> warnAndFail (show e))
+ `Sec.catchChecked` (\(e :: Sec.VerificationError) -> warnAndFail (show e))
+ _ -> pure True
-- | Fetch a package if we don't have it already.
---
-fetchPackage :: Verbosity
- -> RepoContext
- -> UnresolvedPkgLoc
- -> IO ResolvedPkgLoc
+fetchPackage
+ :: Verbosity
+ -> RepoContext
+ -> UnresolvedPkgLoc
+ -> IO ResolvedPkgLoc
fetchPackage verbosity repoCtxt loc = case loc of
- LocalUnpackedPackage dir ->
- return (LocalUnpackedPackage dir)
- LocalTarballPackage file ->
- return (LocalTarballPackage file)
- RemoteTarballPackage uri (Just file) ->
- return (RemoteTarballPackage uri file)
- RepoTarballPackage repo pkgid (Just file) ->
- return (RepoTarballPackage repo pkgid file)
- RemoteSourceRepoPackage repo (Just dir) ->
- return (RemoteSourceRepoPackage repo dir)
-
- RemoteTarballPackage uri Nothing -> do
- path <- downloadTarballPackage uri
- return (RemoteTarballPackage uri path)
- RepoTarballPackage repo pkgid Nothing -> do
- local <- fetchRepoTarball verbosity repoCtxt repo pkgid
- return (RepoTarballPackage repo pkgid local)
- RemoteSourceRepoPackage _repo Nothing ->
- die' verbosity "fetchPackage: source repos not supported"
+ LocalUnpackedPackage dir ->
+ return (LocalUnpackedPackage dir)
+ LocalTarballPackage file ->
+ return (LocalTarballPackage file)
+ RemoteTarballPackage uri (Just file) ->
+ return (RemoteTarballPackage uri file)
+ RepoTarballPackage repo pkgid (Just file) ->
+ return (RepoTarballPackage repo pkgid file)
+ RemoteSourceRepoPackage repo (Just dir) ->
+ return (RemoteSourceRepoPackage repo dir)
+ RemoteTarballPackage uri Nothing -> do
+ path <- downloadTarballPackage uri
+ return (RemoteTarballPackage uri path)
+ RepoTarballPackage repo pkgid Nothing -> do
+ local <- fetchRepoTarball verbosity repoCtxt repo pkgid
+ return (RepoTarballPackage repo pkgid local)
+ RemoteSourceRepoPackage _repo Nothing ->
+ die' verbosity "fetchPackage: source repos not supported"
where
downloadTarballPackage :: URI -> IO FilePath
downloadTarballPackage uri = do
@@ -193,19 +223,19 @@ fetchPackage verbosity repoCtxt loc = case loc of
_ <- downloadURI transport verbosity uri path
return path
-
-- | Fetch a repo package if we don't have it already.
---
fetchRepoTarball :: Verbosity -> RepoContext -> Repo -> PackageId -> IO FilePath
fetchRepoTarball verbosity' repoCtxt repo pkgid = do
fetched <- doesFileExist (packageFile repo pkgid)
if fetched
- then do info verbosity $ prettyShow pkgid ++ " has already been downloaded."
- return (packageFile repo pkgid)
- else do progressMessage verbosity ProgressDownloading (prettyShow pkgid)
- res <- downloadRepoPackage
- progressMessage verbosity ProgressDownloaded (prettyShow pkgid)
- return res
+ then do
+ info verbosity $ prettyShow pkgid ++ " has already been downloaded."
+ return (packageFile repo pkgid)
+ else do
+ progressMessage verbosity ProgressDownloading (prettyShow pkgid)
+ res <- downloadRepoPackage
+ progressMessage verbosity ProgressDownloaded (prettyShow pkgid)
+ return res
where
-- whether we download or not is non-deterministic
verbosity = verboseUnmarkOutput verbosity'
@@ -213,19 +243,17 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do
downloadRepoPackage :: IO FilePath
downloadRepoPackage = case repo of
RepoLocalNoIndex{} -> return (packageFile repo pkgid)
-
RepoRemote{..} -> do
transport <- repoContextGetTransport repoCtxt
remoteRepoCheckHttps verbosity transport repoRemote
- let uri = packageURI repoRemote pkgid
- dir = packageDir repo pkgid
- path = packageFile repo pkgid
+ let uri = packageURI repoRemote pkgid
+ dir = packageDir repo pkgid
+ path = packageFile repo pkgid
createDirectoryIfMissing True dir
_ <- downloadURI transport verbosity uri path
return path
-
RepoSecure{} -> repoContextWithSecureRepo repoCtxt repo $ \rep -> do
- let dir = packageDir repo pkgid
+ let dir = packageDir repo pkgid
path = packageFile repo pkgid
createDirectoryIfMissing True dir
Sec.uncheckClientErrors $ do
@@ -236,25 +264,29 @@ fetchRepoTarball verbosity' repoCtxt repo pkgid = do
-- | Downloads an index file to [config-dir/packages/serv-id] without
-- hackage-security. You probably don't want to call this directly;
-- use 'updateRepo' instead.
---
downloadIndex :: HttpTransport -> Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult
downloadIndex transport verbosity remoteRepo cacheDir = do
remoteRepoCheckHttps verbosity transport remoteRepo
- let uri = (remoteRepoURI remoteRepo) {
- uriPath = uriPath (remoteRepoURI remoteRepo)
- `FilePath.Posix.combine` "00-index.tar.gz"
- }
+ let uri =
+ (remoteRepoURI remoteRepo)
+ { uriPath =
+ uriPath (remoteRepoURI remoteRepo)
+ `FilePath.Posix.combine` "00-index.tar.gz"
+ }
path = cacheDir </> "00-index" <.> "tar.gz"
createDirectoryIfMissing True cacheDir
downloadURI transport verbosity uri path
-
-- ------------------------------------------------------------
+
-- * Async fetch wrapper utilities
+
-- ------------------------------------------------------------
-type AsyncFetchMap = Map UnresolvedPkgLoc
- (MVar (Either SomeException ResolvedPkgLoc))
+type AsyncFetchMap =
+ Map
+ UnresolvedPkgLoc
+ (MVar (Either SomeException ResolvedPkgLoc))
-- | Fork off an async action to download the given packages (by location).
--
@@ -267,37 +299,40 @@ type AsyncFetchMap = Map UnresolvedPkgLoc
--
-- Synchronous exceptions raised by the download actions are delivered
-- via 'waitAsyncFetchPackage'.
---
-asyncFetchPackages :: Verbosity
- -> RepoContext
- -> [UnresolvedPkgLoc]
- -> (AsyncFetchMap -> IO a)
- -> IO a
+asyncFetchPackages
+ :: Verbosity
+ -> RepoContext
+ -> [UnresolvedPkgLoc]
+ -> (AsyncFetchMap -> IO a)
+ -> IO a
asyncFetchPackages verbosity repoCtxt pkglocs body = do
- --TODO: [nice to have] use parallel downloads?
-
- asyncDownloadVars <- sequenceA
- [ do v <- newEmptyMVar
- return (pkgloc, v)
- | pkgloc <- pkglocs
- ]
-
- let fetchPackages :: IO ()
- fetchPackages =
- for_ asyncDownloadVars $ \(pkgloc, var) -> do
- -- Suppress marking here, because 'withAsync' means
- -- that we get nondeterministic interleaving.
- -- It is essential that we don't catch async exceptions here,
- -- specifically 'AsyncCancelled' thrown at us from 'concurrently'.
- result <- Safe.try $
+ -- TODO: [nice to have] use parallel downloads?
+
+ asyncDownloadVars <-
+ sequenceA
+ [ do
+ v <- newEmptyMVar
+ return (pkgloc, v)
+ | pkgloc <- pkglocs
+ ]
+
+ let fetchPackages :: IO ()
+ fetchPackages =
+ for_ asyncDownloadVars $ \(pkgloc, var) -> do
+ -- Suppress marking here, because 'withAsync' means
+ -- that we get nondeterministic interleaving.
+ -- It is essential that we don't catch async exceptions here,
+ -- specifically 'AsyncCancelled' thrown at us from 'concurrently'.
+ result <-
+ Safe.try $
fetchPackage (verboseUnmarkOutput verbosity) repoCtxt pkgloc
- putMVar var result
-
- (_, res) <- concurrently
- fetchPackages
- (body $ Map.fromList asyncDownloadVars)
- pure res
+ putMVar var result
+ (_, res) <-
+ concurrently
+ fetchPackages
+ (body $ Map.fromList asyncDownloadVars)
+ pure res
-- | Expect to find a download in progress in the given 'AsyncFetchMap'
-- and wait on it to finish.
@@ -309,54 +344,60 @@ asyncFetchPackages verbosity repoCtxt pkglocs body = do
-- components and/or qualified goals, and these all go through the
-- download phase so we end up using 'waitAsyncFetchPackage' twice on
-- the same package. C.f. #4461.
-waitAsyncFetchPackage :: Verbosity
- -> AsyncFetchMap
- -> UnresolvedPkgLoc
- -> IO ResolvedPkgLoc
+waitAsyncFetchPackage
+ :: Verbosity
+ -> AsyncFetchMap
+ -> UnresolvedPkgLoc
+ -> IO ResolvedPkgLoc
waitAsyncFetchPackage verbosity downloadMap srcloc =
- case Map.lookup srcloc downloadMap of
- Just hnd -> do
- debug verbosity $ "Waiting for download of " ++ show srcloc
- either throwIO return =<< readMVar hnd
- Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"
-
+ case Map.lookup srcloc downloadMap of
+ Just hnd -> do
+ debug verbosity $ "Waiting for download of " ++ show srcloc
+ either throwIO return =<< readMVar hnd
+ Nothing -> fail "waitAsyncFetchPackage: package not being downloaded"
-- ------------------------------------------------------------
+
-- * Path utilities
+
-- ------------------------------------------------------------
-- | Generate the full path to the locally cached copy of
-- the tarball for a given @PackageIdentifier@.
---
packageFile :: Repo -> PackageId -> FilePath
-packageFile repo pkgid = packageDir repo pkgid
- </> prettyShow pkgid
- <.> "tar.gz"
+packageFile repo pkgid =
+ packageDir repo pkgid
+ </> prettyShow pkgid
+ <.> "tar.gz"
-- | Generate the full path to the directory where the local cached copy of
-- the tarball for a given @PackageIdentifier@ is stored.
---
packageDir :: Repo -> PackageId -> FilePath
packageDir (RepoLocalNoIndex (LocalRepo _ dir _) _) _pkgid = dir
-packageDir repo pkgid = repoLocalDir repo
- </> prettyShow (packageName pkgid)
- </> prettyShow (packageVersion pkgid)
+packageDir repo pkgid =
+ repoLocalDir repo
+ </> prettyShow (packageName pkgid)
+ </> prettyShow (packageVersion pkgid)
-- | Generate the URI of the tarball for a given package.
---
packageURI :: RemoteRepo -> PackageId -> URI
-packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =
- (remoteRepoURI repo) {
- uriPath = FilePath.Posix.joinPath
- [uriPath (remoteRepoURI repo)
- ,prettyShow (packageName pkgid)
- ,prettyShow (packageVersion pkgid)
- ,prettyShow pkgid <.> "tar.gz"]
- }
+packageURI repo pkgid
+ | isOldHackageURI (remoteRepoURI repo) =
+ (remoteRepoURI repo)
+ { uriPath =
+ FilePath.Posix.joinPath
+ [ uriPath (remoteRepoURI repo)
+ , prettyShow (packageName pkgid)
+ , prettyShow (packageVersion pkgid)
+ , prettyShow pkgid <.> "tar.gz"
+ ]
+ }
packageURI repo pkgid =
- (remoteRepoURI repo) {
- uriPath = FilePath.Posix.joinPath
- [uriPath (remoteRepoURI repo)
- ,"package"
- ,prettyShow pkgid <.> "tar.gz"]
- }
+ (remoteRepoURI repo)
+ { uriPath =
+ FilePath.Posix.joinPath
+ [ uriPath (remoteRepoURI repo)
+ , "package"
+ , prettyShow pkgid <.> "tar.gz"
+ ]
+ }
diff --git a/cabal-install/src/Distribution/Client/FileMonitor.hs b/cabal-install/src/Distribution/Client/FileMonitor.hs
index ab991ea8da5e9b597fd8afada0fbc40821724ebf..5edd159496b0fa70265d4a4f0a93e12c4f0980eb 100644
--- a/cabal-install/src/Distribution/Client/FileMonitor.hs
+++ b/cabal-install/src/Distribution/Client/FileMonitor.hs
@@ -1,106 +1,111 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveGeneric, DeriveFunctor, GeneralizedNewtypeDeriving,
- NamedFieldPuns, BangPatterns, ScopedTypeVariables #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | An abstraction to help with re-running actions when files or other
-- input values they depend on have changed.
---
-module Distribution.Client.FileMonitor (
-
- -- * Declaring files to monitor
- MonitorFilePath(..),
- MonitorKindFile(..),
- MonitorKindDir(..),
- FilePathGlob(..),
- monitorFile,
- monitorFileHashed,
- monitorNonExistentFile,
- monitorFileExistence,
- monitorDirectory,
- monitorNonExistentDirectory,
- monitorDirectoryExistence,
- monitorFileOrDirectory,
- monitorFileGlob,
- monitorFileGlobExistence,
- monitorFileSearchPath,
- monitorFileHashedSearchPath,
-
- -- * Creating and checking sets of monitored files
- FileMonitor(..),
- newFileMonitor,
- MonitorChanged(..),
- MonitorChangedReason(..),
- checkFileMonitorChanged,
- updateFileMonitor,
- MonitorTimestamp,
- beginUpdateFileMonitor,
-
- -- * Internal
- MonitorStateFileSet,
- MonitorStateFile,
- MonitorStateGlob,
+module Distribution.Client.FileMonitor
+ ( -- * Declaring files to monitor
+ MonitorFilePath (..)
+ , MonitorKindFile (..)
+ , MonitorKindDir (..)
+ , FilePathGlob (..)
+ , monitorFile
+ , monitorFileHashed
+ , monitorNonExistentFile
+ , monitorFileExistence
+ , monitorDirectory
+ , monitorNonExistentDirectory
+ , monitorDirectoryExistence
+ , monitorFileOrDirectory
+ , monitorFileGlob
+ , monitorFileGlobExistence
+ , monitorFileSearchPath
+ , monitorFileHashedSearchPath
+
+ -- * Creating and checking sets of monitored files
+ , FileMonitor (..)
+ , newFileMonitor
+ , MonitorChanged (..)
+ , MonitorChangedReason (..)
+ , checkFileMonitorChanged
+ , updateFileMonitor
+ , MonitorTimestamp
+ , beginUpdateFileMonitor
+
+ -- * Internal
+ , MonitorStateFileSet
+ , MonitorStateFile
+ , MonitorStateGlob
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
import qualified Distribution.Compat.Binary as Binary
+import Prelude ()
-import qualified Data.Map.Strict as Map
import Data.Binary.Get (runGetOrFail)
import qualified Data.ByteString.Lazy as BS
import qualified Data.Hashable as Hashable
+import qualified Data.Map.Strict as Map
-import Control.Monad
-import Control.Monad.Trans (MonadIO, liftIO)
-import Control.Monad.State (StateT, mapStateT)
+import Control.Exception
+import Control.Monad
+import Control.Monad.Except
+ ( ExceptT
+ , runExceptT
+ , throwError
+ , withExceptT
+ )
+import Control.Monad.State (StateT, mapStateT)
import qualified Control.Monad.State as State
-import Control.Monad.Except (ExceptT, runExceptT, withExceptT,
- throwError)
-import Control.Exception
-
-import Distribution.Compat.Time
-import Distribution.Client.Glob
-import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)
-import Distribution.Client.Utils (mergeBy, MergeResult(..))
-import Distribution.Utils.Structured (structuredEncode, Tag (..))
-import System.FilePath
-import System.Directory
-import System.IO
+import Control.Monad.Trans (MonadIO, liftIO)
+
+import Distribution.Client.Glob
+import Distribution.Client.Utils (MergeResult (..), mergeBy)
+import Distribution.Compat.Time
+import Distribution.Simple.Utils (handleDoesNotExist, writeFileAtomic)
+import Distribution.Utils.Structured (Tag (..), structuredEncode)
+import System.Directory
+import System.FilePath
+import System.IO
------------------------------------------------------------------------------
-- Types for specifying files to monitor
--
-
-- | A description of a file (or set of files) to monitor for changes.
--
-- Where file paths are relative they are relative to a common directory
-- (e.g. project root), not necessarily the process current directory.
---
-data MonitorFilePath =
- MonitorFile {
- monitorKindFile :: !MonitorKindFile,
- monitorKindDir :: !MonitorKindDir,
- monitorPath :: !FilePath
- }
- | MonitorFileGlob {
- monitorKindFile :: !MonitorKindFile,
- monitorKindDir :: !MonitorKindDir,
- monitorPathGlob :: !FilePathGlob
- }
+data MonitorFilePath
+ = MonitorFile
+ { monitorKindFile :: !MonitorKindFile
+ , monitorKindDir :: !MonitorKindDir
+ , monitorPath :: !FilePath
+ }
+ | MonitorFileGlob
+ { monitorKindFile :: !MonitorKindFile
+ , monitorKindDir :: !MonitorKindDir
+ , monitorPathGlob :: !FilePathGlob
+ }
deriving (Eq, Show, Generic)
-data MonitorKindFile = FileExists
- | FileModTime
- | FileHashed
- | FileNotExists
+data MonitorKindFile
+ = FileExists
+ | FileModTime
+ | FileHashed
+ | FileNotExists
deriving (Eq, Show, Generic)
-data MonitorKindDir = DirExists
- | DirModTime
- | DirNotExists
+data MonitorKindDir
+ = DirExists
+ | DirModTime
+ | DirNotExists
deriving (Eq, Show, Generic)
instance Binary MonitorFilePath
@@ -114,7 +119,6 @@ instance Structured MonitorKindDir
-- | Monitor a single file for changes, based on its modification time.
-- The monitored file is considered to have changed if it no longer
-- exists or if its modification time has changed.
---
monitorFile :: FilePath -> MonitorFilePath
monitorFile = MonitorFile FileModTime DirNotExists
@@ -122,32 +126,27 @@ monitorFile = MonitorFile FileModTime DirNotExists
-- and content hash. The monitored file is considered to have changed if
-- it no longer exists or if its modification time and content hash have
-- changed.
---
monitorFileHashed :: FilePath -> MonitorFilePath
monitorFileHashed = MonitorFile FileHashed DirNotExists
-- | Monitor a single non-existent file for changes. The monitored file
-- is considered to have changed if it exists.
---
monitorNonExistentFile :: FilePath -> MonitorFilePath
monitorNonExistentFile = MonitorFile FileNotExists DirNotExists
-- | Monitor a single file for existence only. The monitored file is
-- considered to have changed if it no longer exists.
---
monitorFileExistence :: FilePath -> MonitorFilePath
monitorFileExistence = MonitorFile FileExists DirNotExists
-- | Monitor a single directory for changes, based on its modification
-- time. The monitored directory is considered to have changed if it no
-- longer exists or if its modification time has changed.
---
monitorDirectory :: FilePath -> MonitorFilePath
monitorDirectory = MonitorFile FileNotExists DirModTime
-- | Monitor a single non-existent directory for changes. The monitored
-- directory is considered to have changed if it exists.
---
monitorNonExistentDirectory :: FilePath -> MonitorFilePath
-- Just an alias for monitorNonExistentFile, since you can't
-- tell the difference between a non-existent directory and
@@ -156,14 +155,12 @@ monitorNonExistentDirectory = monitorNonExistentFile
-- | Monitor a single directory for existence. The monitored directory is
-- considered to have changed only if it no longer exists.
---
monitorDirectoryExistence :: FilePath -> MonitorFilePath
monitorDirectoryExistence = MonitorFile FileNotExists DirExists
-- | Monitor a single file or directory for changes, based on its modification
-- time. The monitored file is considered to have changed if it no longer
-- exists or if its modification time has changed.
---
monitorFileOrDirectory :: FilePath -> MonitorFilePath
monitorFileOrDirectory = MonitorFile FileModTime DirModTime
@@ -171,14 +168,12 @@ monitorFileOrDirectory = MonitorFile FileModTime DirModTime
-- The monitored glob is considered to have changed if the set of files
-- matching the glob changes (i.e. creations or deletions), or for files if the
-- modification time and content hash of any matching file has changed.
---
monitorFileGlob :: FilePathGlob -> MonitorFilePath
monitorFileGlob = MonitorFileGlob FileHashed DirExists
-- | Monitor a set of files (or directories) identified by a file glob for
-- existence only. The monitored glob is considered to have changed if the set
-- of files matching the glob changes (i.e. creations or deletions).
---
monitorFileGlobExistence :: FilePathGlob -> MonitorFilePath
monitorFileGlobExistence = MonitorFileGlob FileExists DirExists
@@ -187,16 +182,15 @@ monitorFileGlobExistence = MonitorFileGlob FileExists DirExists
-- @foundAtPath@.
monitorFileSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]
monitorFileSearchPath notFoundAtPaths foundAtPath =
- monitorFile foundAtPath
- : map monitorNonExistentFile notFoundAtPaths
+ monitorFile foundAtPath
+ : map monitorNonExistentFile notFoundAtPaths
-- | Similar to 'monitorFileSearchPath', but also instructs us to
-- monitor the hash of the found file.
monitorFileHashedSearchPath :: [FilePath] -> FilePath -> [MonitorFilePath]
monitorFileHashedSearchPath notFoundAtPaths foundAtPath =
- monitorFileHashed foundAtPath
- : map monitorNonExistentFile notFoundAtPaths
-
+ monitorFileHashed foundAtPath
+ : map monitorNonExistentFile notFoundAtPaths
------------------------------------------------------------------------------
-- Implementation types, files status
@@ -207,13 +201,14 @@ monitorFileHashedSearchPath notFoundAtPaths foundAtPath =
-- files to be monitored (index by their path), and a list of
-- globs, which monitor may files at once.
data MonitorStateFileSet
- = MonitorStateFileSet ![MonitorStateFile]
- ![MonitorStateGlob]
- -- Morally this is not actually a set but a bag (represented by lists).
- -- There is no principled reason to use a bag here rather than a set, but
- -- there is also no particular gain either. That said, we do preserve the
- -- order of the lists just to reduce confusion (and have predictable I/O
- -- patterns).
+ = MonitorStateFileSet
+ ![MonitorStateFile]
+ ![MonitorStateGlob]
+ -- Morally this is not actually a set but a bag (represented by lists).
+ -- There is no principled reason to use a bag here rather than a set, but
+ -- there is also no particular gain either. That said, we do preserve the
+ -- order of the lists just to reduce confusion (and have predictable I/O
+ -- patterns).
deriving (Show, Generic)
instance Binary MonitorStateFileSet
@@ -230,19 +225,25 @@ type Hash = Int
-- file to have changed, either because it had already changed by the time we
-- did the snapshot (i.e. too new, changed since start of update process) or it
-- no longer exists at all.
---
-data MonitorStateFile = MonitorStateFile !MonitorKindFile !MonitorKindDir
- !FilePath !MonitorStateFileStatus
+data MonitorStateFile
+ = MonitorStateFile
+ !MonitorKindFile
+ !MonitorKindDir
+ !FilePath
+ !MonitorStateFileStatus
deriving (Show, Generic)
data MonitorStateFileStatus
- = MonitorStateFileExists
- | MonitorStateFileModTime !ModTime -- ^ cached file mtime
- | MonitorStateFileHashed !ModTime !Hash -- ^ cached mtime and content hash
- | MonitorStateDirExists
- | MonitorStateDirModTime !ModTime -- ^ cached dir mtime
- | MonitorStateNonExistent
- | MonitorStateAlreadyChanged
+ = MonitorStateFileExists
+ | -- | cached file mtime
+ MonitorStateFileModTime !ModTime
+ | -- | cached mtime and content hash
+ MonitorStateFileHashed !ModTime !Hash
+ | MonitorStateDirExists
+ | -- | cached dir mtime
+ MonitorStateDirModTime !ModTime
+ | MonitorStateNonExistent
+ | MonitorStateAlreadyChanged
deriving (Show, Generic)
instance Binary MonitorStateFile
@@ -252,23 +253,25 @@ instance Structured MonitorStateFileStatus
-- | The state necessary to determine whether the files matched by a globbing
-- match have changed.
---
-data MonitorStateGlob = MonitorStateGlob !MonitorKindFile !MonitorKindDir
- !FilePathRoot !MonitorStateGlobRel
+data MonitorStateGlob
+ = MonitorStateGlob
+ !MonitorKindFile
+ !MonitorKindDir
+ !FilePathRoot
+ !MonitorStateGlobRel
deriving (Show, Generic)
data MonitorStateGlobRel
- = MonitorStateGlobDirs
- !Glob !FilePathGlobRel
- !ModTime
- ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted
-
- | MonitorStateGlobFiles
- !Glob
- !ModTime
- ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted
-
- | MonitorStateGlobDirTrailing
+ = MonitorStateGlobDirs
+ !Glob
+ !FilePathGlobRel
+ !ModTime
+ ![(FilePath, MonitorStateGlobRel)] -- invariant: sorted
+ | MonitorStateGlobFiles
+ !Glob
+ !ModTime
+ ![(FilePath, MonitorStateFileStatus)] -- invariant: sorted
+ | MonitorStateGlobDirTrailing
deriving (Show, Generic)
instance Binary MonitorStateGlob
@@ -280,7 +283,6 @@ instance Structured MonitorStateGlobRel
-- | We can build a 'MonitorStateFileSet' from a set of 'MonitorFilePath' by
-- inspecting the state of the file system, and we can go in the reverse
-- direction by just forgetting the extra info.
---
reconstructMonitorFilePaths :: MonitorStateFileSet -> [MonitorFilePath]
reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
map getSinglePath singlePaths ++ map getGlobPath globPaths
@@ -291,11 +293,12 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
getGlobPath :: MonitorStateGlob -> MonitorFilePath
getGlobPath (MonitorStateGlob kindfile kinddir root gstate) =
- MonitorFileGlob kindfile kinddir $ FilePathGlob root $
- case gstate of
- MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
- MonitorStateGlobFiles glob _ _ -> GlobFile glob
- MonitorStateGlobDirTrailing -> GlobDirTrailing
+ MonitorFileGlob kindfile kinddir $
+ FilePathGlob root $
+ case gstate of
+ MonitorStateGlobDirs glob globs _ _ -> GlobDir glob globs
+ MonitorStateGlobFiles glob _ _ -> GlobFile glob
+ MonitorStateGlobDirTrailing -> GlobDirTrailing
------------------------------------------------------------------------------
-- Checking the status of monitored files
@@ -327,31 +330,23 @@ reconstructMonitorFilePaths (MonitorStateFileSet singlePaths globPaths) =
-- The typical occurrence of this pattern is captured by 'rerunIfChanged'
-- and the 'Rebuild' monad. More complicated cases may need to use
-- 'checkFileMonitorChanged' and 'updateFileMonitor' directly.
---
-data FileMonitor a b
- = FileMonitor {
-
- -- | The file where this 'FileMonitor' should store its state.
- --
- fileMonitorCacheFile :: FilePath,
-
- -- | Compares a new cache key with old one to determine if a
- -- corresponding cached value is still valid.
- --
- -- Typically this is just an equality test, but in some
- -- circumstances it can make sense to do things like subset
- -- comparisons.
- --
- -- The first arg is the new value, the second is the old cached value.
- --
- fileMonitorKeyValid :: a -> a -> Bool,
-
- -- | When this mode is enabled, if 'checkFileMonitorChanged' returns
- -- 'MonitoredValueChanged' then we have the guarantee that no files
- -- changed, that the value change was the only change. In the default
- -- mode no such guarantee is provided which is slightly faster.
- --
- fileMonitorCheckIfOnlyValueChanged :: Bool
+data FileMonitor a b = FileMonitor
+ { fileMonitorCacheFile :: FilePath
+ -- ^ The file where this 'FileMonitor' should store its state.
+ , fileMonitorKeyValid :: a -> a -> Bool
+ -- ^ Compares a new cache key with old one to determine if a
+ -- corresponding cached value is still valid.
+ --
+ -- Typically this is just an equality test, but in some
+ -- circumstances it can make sense to do things like subset
+ -- comparisons.
+ --
+ -- The first arg is the new value, the second is the old cached value.
+ , fileMonitorCheckIfOnlyValueChanged :: Bool
+ -- ^ When this mode is enabled, if 'checkFileMonitorChanged' returns
+ -- 'MonitoredValueChanged' then we have the guarantee that no files
+ -- changed, that the value change was the only change. In the default
+ -- mode no such guarantee is provided which is slightly faster.
}
-- | Define a new file monitor.
@@ -362,145 +357,141 @@ data FileMonitor a b
--
-- The path of the file monitor itself must be unique because it keeps state
-- on disk and these would clash.
---
-newFileMonitor :: Eq a => FilePath -- ^ The file to cache the state of the
- -- file monitor. Must be unique.
- -> FileMonitor a b
+newFileMonitor
+ :: Eq a
+ => FilePath
+ -- ^ The file to cache the state of the
+ -- file monitor. Must be unique.
+ -> FileMonitor a b
newFileMonitor path = FileMonitor path (==) False
-- | The result of 'checkFileMonitorChanged': either the monitored files or
-- value changed (and it tells us which it was) or nothing changed and we get
-- the cached result.
---
-data MonitorChanged a b =
- -- | The monitored files and value did not change. The cached result is
- -- @b@.
- --
- -- The set of monitored files is also returned. This is useful
- -- for composing or nesting 'FileMonitor's.
- MonitorUnchanged b [MonitorFilePath]
-
- -- | The monitor found that something changed. The reason is given.
- --
- | MonitorChanged (MonitorChangedReason a)
- deriving Show
+data MonitorChanged a b
+ = -- | The monitored files and value did not change. The cached result is
+ -- @b@.
+ --
+ -- The set of monitored files is also returned. This is useful
+ -- for composing or nesting 'FileMonitor's.
+ MonitorUnchanged b [MonitorFilePath]
+ | -- | The monitor found that something changed. The reason is given.
+ MonitorChanged (MonitorChangedReason a)
+ deriving (Show)
-- | What kind of change 'checkFileMonitorChanged' detected.
---
-data MonitorChangedReason a =
-
- -- | One of the files changed (existence, file type, mtime or file
- -- content, depending on the 'MonitorFilePath' in question)
- MonitoredFileChanged FilePath
-
- -- | The pure input value changed.
- --
- -- The previous cached key value is also returned. This is sometimes
- -- useful when using a 'fileMonitorKeyValid' function that is not simply
- -- '(==)', when invalidation can be partial. In such cases it can make
- -- sense to 'updateFileMonitor' with a key value that's a combination of
- -- the new and old (e.g. set union).
- | MonitoredValueChanged a
-
- -- | There was no saved monitor state, cached value etc. Ie the file
- -- for the 'FileMonitor' does not exist.
- | MonitorFirstRun
-
- -- | There was existing state, but we could not read it. This typically
- -- happens when the code has changed compared to an existing 'FileMonitor'
- -- cache file and type of the input value or cached value has changed such
- -- that we cannot decode the values. This is completely benign as we can
- -- treat is just as if there were no cache file and re-run.
- | MonitorCorruptCache
+data MonitorChangedReason a
+ = -- | One of the files changed (existence, file type, mtime or file
+ -- content, depending on the 'MonitorFilePath' in question)
+ MonitoredFileChanged FilePath
+ | -- | The pure input value changed.
+ --
+ -- The previous cached key value is also returned. This is sometimes
+ -- useful when using a 'fileMonitorKeyValid' function that is not simply
+ -- '(==)', when invalidation can be partial. In such cases it can make
+ -- sense to 'updateFileMonitor' with a key value that's a combination of
+ -- the new and old (e.g. set union).
+ MonitoredValueChanged a
+ | -- | There was no saved monitor state, cached value etc. Ie the file
+ -- for the 'FileMonitor' does not exist.
+ MonitorFirstRun
+ | -- | There was existing state, but we could not read it. This typically
+ -- happens when the code has changed compared to an existing 'FileMonitor'
+ -- cache file and type of the input value or cached value has changed such
+ -- that we cannot decode the values. This is completely benign as we can
+ -- treat is just as if there were no cache file and re-run.
+ MonitorCorruptCache
deriving (Eq, Show, Functor)
-- | Test if the input value or files monitored by the 'FileMonitor' have
-- changed. If not, return the cached value.
--
-- See 'FileMonitor' for a full explanation.
---
checkFileMonitorChanged
- :: forall a b. (Binary a, Structured a, Binary b, Structured b)
- => FileMonitor a b -- ^ cache file path
- -> FilePath -- ^ root directory
- -> a -- ^ guard or key value
- -> IO (MonitorChanged a b) -- ^ did the key or any paths change?
+ :: forall a b
+ . (Binary a, Structured a, Binary b, Structured b)
+ => FileMonitor a b
+ -- ^ cache file path
+ -> FilePath
+ -- ^ root directory
+ -> a
+ -- ^ guard or key value
+ -> IO (MonitorChanged a b)
+ -- ^ did the key or any paths change?
checkFileMonitorChanged
- monitor@FileMonitor { fileMonitorKeyValid,
- fileMonitorCheckIfOnlyValueChanged }
- root currentKey =
-
+ monitor@FileMonitor
+ { fileMonitorKeyValid
+ , fileMonitorCheckIfOnlyValueChanged
+ }
+ root
+ currentKey =
-- Consider it a change if the cache file does not exist,
-- or we cannot decode it. Sadly ErrorCall can still happen, despite
-- using decodeFileOrFail, e.g. Data.Char.chr errors
handleDoesNotExist (MonitorChanged MonitorFirstRun) $
- handleErrorCall (MonitorChanged MonitorCorruptCache) $
- withCacheFile monitor $
- either (\_ -> return (MonitorChanged MonitorCorruptCache))
- checkStatusCache
-
- where
- checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b)
- checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do
+ handleErrorCall (MonitorChanged MonitorCorruptCache) $
+ withCacheFile monitor $
+ either
+ (\_ -> return (MonitorChanged MonitorCorruptCache))
+ checkStatusCache
+ where
+ checkStatusCache :: (MonitorStateFileSet, a, Either String b) -> IO (MonitorChanged a b)
+ checkStatusCache (cachedFileStatus, cachedKey, cachedResult) = do
change <- checkForChanges
case change of
Just reason -> return (MonitorChanged reason)
- Nothing -> case cachedResult of
- Left _ -> pure (MonitorChanged MonitorCorruptCache)
- Right cr -> return (MonitorUnchanged cr monitorFiles)
- where monitorFiles = reconstructMonitorFilePaths cachedFileStatus
- where
- -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that
- -- if we return MonitoredValueChanged that only the value changed.
- -- We do that by checking for file changes first. Otherwise it makes
- -- more sense to do the cheaper test first.
- checkForChanges :: IO (Maybe (MonitorChangedReason a))
- checkForChanges
- | fileMonitorCheckIfOnlyValueChanged
- = checkFileChange cachedFileStatus cachedKey cachedResult
- `mplusMaybeT`
- checkValueChange cachedKey
-
- | otherwise
- = checkValueChange cachedKey
- `mplusMaybeT`
- checkFileChange cachedFileStatus cachedKey cachedResult
-
- mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1)
- mplusMaybeT ma mb = do
- mx <- ma
- case mx of
- Nothing -> mb
- Just x -> return (Just x)
-
- -- Check if the guard value has changed
- checkValueChange :: a -> IO (Maybe (MonitorChangedReason a))
- checkValueChange cachedKey
- | not (fileMonitorKeyValid currentKey cachedKey)
- = return (Just (MonitoredValueChanged cachedKey))
- | otherwise
- = return Nothing
-
- -- Check if any file has changed
- checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a))
- checkFileChange cachedFileStatus cachedKey cachedResult = do
- res <- probeFileSystem root cachedFileStatus
- case res of
- -- Some monitored file has changed
- Left changedPath ->
- return (Just (MonitoredFileChanged (normalise changedPath)))
-
- -- No monitored file has changed
- Right (cachedFileStatus', cacheStatus) -> do
-
- -- But we might still want to update the cache
- whenCacheChanged cacheStatus $
- case cachedResult of
- Left _ -> pure ()
- Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr
-
- return Nothing
+ Nothing -> case cachedResult of
+ Left _ -> pure (MonitorChanged MonitorCorruptCache)
+ Right cr -> return (MonitorUnchanged cr monitorFiles)
+ where
+ monitorFiles = reconstructMonitorFilePaths cachedFileStatus
+ where
+ -- In fileMonitorCheckIfOnlyValueChanged mode we want to guarantee that
+ -- if we return MonitoredValueChanged that only the value changed.
+ -- We do that by checking for file changes first. Otherwise it makes
+ -- more sense to do the cheaper test first.
+ checkForChanges :: IO (Maybe (MonitorChangedReason a))
+ checkForChanges
+ | fileMonitorCheckIfOnlyValueChanged =
+ checkFileChange cachedFileStatus cachedKey cachedResult
+ `mplusMaybeT` checkValueChange cachedKey
+ | otherwise =
+ checkValueChange cachedKey
+ `mplusMaybeT` checkFileChange cachedFileStatus cachedKey cachedResult
+
+ mplusMaybeT :: Monad m => m (Maybe a1) -> m (Maybe a1) -> m (Maybe a1)
+ mplusMaybeT ma mb = do
+ mx <- ma
+ case mx of
+ Nothing -> mb
+ Just x -> return (Just x)
+
+ -- Check if the guard value has changed
+ checkValueChange :: a -> IO (Maybe (MonitorChangedReason a))
+ checkValueChange cachedKey
+ | not (fileMonitorKeyValid currentKey cachedKey) =
+ return (Just (MonitoredValueChanged cachedKey))
+ | otherwise =
+ return Nothing
+
+ -- Check if any file has changed
+ checkFileChange :: MonitorStateFileSet -> a -> Either String b -> IO (Maybe (MonitorChangedReason a))
+ checkFileChange cachedFileStatus cachedKey cachedResult = do
+ res <- probeFileSystem root cachedFileStatus
+ case res of
+ -- Some monitored file has changed
+ Left changedPath ->
+ return (Just (MonitoredFileChanged (normalise changedPath)))
+ -- No monitored file has changed
+ Right (cachedFileStatus', cacheStatus) -> do
+ -- But we might still want to update the cache
+ whenCacheChanged cacheStatus $
+ case cachedResult of
+ Left _ -> pure ()
+ Right cr -> rewriteCacheFile monitor cachedFileStatus' cachedKey cr
+
+ return Nothing
-- | Lazily decode a triple, parsing the first two fields strictly and
-- returning a lazy value containing either the last one or an error.
@@ -512,45 +503,49 @@ checkFileMonitorChanged
-- Distribution.Utils.Structured because it depends on a newer version of
-- binary than supported in the Cabal library proper.
structuredDecodeTriple
- :: forall a b c. (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c)
- => BS.ByteString -> Either String (a, b, Either String c)
+ :: forall a b c
+ . (Structured a, Structured b, Structured c, Binary.Binary a, Binary.Binary b, Binary.Binary c)
+ => BS.ByteString
+ -> Either String (a, b, Either String c)
structuredDecodeTriple lbs =
let partialDecode =
- (`runGetOrFail` lbs) $ do
- (_ :: Tag (a,b,c)) <- Binary.get
- (a :: a) <- Binary.get
- (b :: b) <- Binary.get
- pure (a, b)
+ (`runGetOrFail` lbs) $ do
+ (_ :: Tag (a, b, c)) <- Binary.get
+ (a :: a) <- Binary.get
+ (b :: b) <- Binary.get
+ pure (a, b)
cleanEither (Left (_, pos, msg)) = Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)
- cleanEither (Right (_,_,v)) = Right v
-
- in case partialDecode of
- Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)
- Right (lbs', _, (x,y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs')
+ cleanEither (Right (_, _, v)) = Right v
+ in case partialDecode of
+ Left (_, pos, msg) -> Left ("Data.Binary.Get.runGet at position " ++ show pos ++ ": " ++ msg)
+ Right (lbs', _, (x, y)) -> Right (x, y, cleanEither $ runGetOrFail (Binary.get :: Binary.Get c) lbs')
-- | Helper for reading the cache file.
--
-- This determines the type and format of the binary cache file.
---
-withCacheFile :: (Binary a, Structured a, Binary b, Structured b)
- => FileMonitor a b
- -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r)
- -> IO r
-withCacheFile (FileMonitor {fileMonitorCacheFile}) k =
- withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do
- contents <- structuredDecodeTriple <$> BS.hGetContents hnd
- k contents
+withCacheFile
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => FileMonitor a b
+ -> (Either String (MonitorStateFileSet, a, Either String b) -> IO r)
+ -> IO r
+withCacheFile (FileMonitor{fileMonitorCacheFile}) k =
+ withBinaryFile fileMonitorCacheFile ReadMode $ \hnd -> do
+ contents <- structuredDecodeTriple <$> BS.hGetContents hnd
+ k contents
-- | Helper for writing the cache file.
--
-- This determines the type and format of the binary cache file.
---
-rewriteCacheFile :: (Binary a, Structured a, Binary b, Structured b)
- => FileMonitor a b
- -> MonitorStateFileSet -> a -> b -> IO ()
-rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =
- writeFileAtomic fileMonitorCacheFile $
- structuredEncode (fileset, key, result)
+rewriteCacheFile
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => FileMonitor a b
+ -> MonitorStateFileSet
+ -> a
+ -> b
+ -> IO ()
+rewriteCacheFile FileMonitor{fileMonitorCacheFile} fileset key result =
+ writeFileAtomic fileMonitorCacheFile $
+ structuredEncode (fileset, key, result)
-- | Probe the file system to see if any of the monitored files have changed.
--
@@ -566,22 +561,24 @@ rewriteCacheFile FileMonitor {fileMonitorCacheFile} fileset key result =
-- we want to update the cache despite no changes in our relevant file set.
-- Specifically, we should add an mtime for this directory so we can avoid
-- re-traversing the directory in future runs.
---
-probeFileSystem :: FilePath -> MonitorStateFileSet
- -> IO (Either FilePath (MonitorStateFileSet, CacheChanged))
+probeFileSystem
+ :: FilePath
+ -> MonitorStateFileSet
+ -> IO (Either FilePath (MonitorStateFileSet, CacheChanged))
probeFileSystem root (MonitorStateFileSet singlePaths globPaths) =
runChangedM $ do
sequence_
[ probeMonitorStateFileStatus root file status
- | MonitorStateFile _ _ file status <- singlePaths ]
+ | MonitorStateFile _ _ file status <- singlePaths
+ ]
-- The glob monitors can require state changes
globPaths' <-
sequence
[ probeMonitorStateGlob root globPath
- | globPath <- globPaths ]
+ | globPath <- globPaths
+ ]
return (MonitorStateFileSet singlePaths globPaths')
-
-----------------------------------------------
-- Monad for checking for file system changes
--
@@ -606,181 +603,216 @@ cacheChanged = ChangedM $ State.put CacheChanged
mapChangedFile :: (FilePath -> FilePath) -> ChangedM a -> ChangedM a
mapChangedFile adjust (ChangedM a) =
- ChangedM (mapStateT (withExceptT adjust) a)
+ ChangedM (mapStateT (withExceptT adjust) a)
data CacheChanged = CacheChanged | CacheUnchanged
whenCacheChanged :: Monad m => CacheChanged -> m () -> m ()
whenCacheChanged CacheChanged action = action
-whenCacheChanged CacheUnchanged _ = return ()
+whenCacheChanged CacheUnchanged _ = return ()
----------------------
-- | Probe the file system to see if a single monitored file has changed.
---
-probeMonitorStateFileStatus :: FilePath -> FilePath
- -> MonitorStateFileStatus
- -> ChangedM ()
+probeMonitorStateFileStatus
+ :: FilePath
+ -> FilePath
+ -> MonitorStateFileStatus
+ -> ChangedM ()
probeMonitorStateFileStatus root file status =
- case status of
- MonitorStateFileExists ->
- probeFileExistence root file
-
- MonitorStateFileModTime mtime ->
- probeFileModificationTime root file mtime
-
- MonitorStateFileHashed mtime hash ->
- probeFileModificationTimeAndHash root file mtime hash
-
- MonitorStateDirExists ->
- probeDirExistence root file
-
- MonitorStateDirModTime mtime ->
- probeFileModificationTime root file mtime
-
- MonitorStateNonExistent ->
- probeFileNonExistence root file
-
- MonitorStateAlreadyChanged ->
- somethingChanged file
-
+ case status of
+ MonitorStateFileExists ->
+ probeFileExistence root file
+ MonitorStateFileModTime mtime ->
+ probeFileModificationTime root file mtime
+ MonitorStateFileHashed mtime hash ->
+ probeFileModificationTimeAndHash root file mtime hash
+ MonitorStateDirExists ->
+ probeDirExistence root file
+ MonitorStateDirModTime mtime ->
+ probeFileModificationTime root file mtime
+ MonitorStateNonExistent ->
+ probeFileNonExistence root file
+ MonitorStateAlreadyChanged ->
+ somethingChanged file
-- | Probe the file system to see if a monitored file glob has changed.
---
-probeMonitorStateGlob :: FilePath -- ^ root path
- -> MonitorStateGlob
- -> ChangedM MonitorStateGlob
-probeMonitorStateGlob relroot
- (MonitorStateGlob kindfile kinddir globroot glob) = do
+probeMonitorStateGlob
+ :: FilePath
+ -- ^ root path
+ -> MonitorStateGlob
+ -> ChangedM MonitorStateGlob
+probeMonitorStateGlob
+ relroot
+ (MonitorStateGlob kindfile kinddir globroot glob) = do
root <- liftIO $ getFilePathRootDirectory globroot relroot
case globroot of
FilePathRelative ->
- MonitorStateGlob kindfile kinddir globroot <$>
- probeMonitorStateGlobRel kindfile kinddir root "." glob
-
+ MonitorStateGlob kindfile kinddir globroot
+ <$> probeMonitorStateGlobRel kindfile kinddir root "." glob
-- for absolute cases, make the changed file we report absolute too
_ ->
mapChangedFile (root </>) $
- MonitorStateGlob kindfile kinddir globroot <$>
- probeMonitorStateGlobRel kindfile kinddir root "" glob
-
-probeMonitorStateGlobRel :: MonitorKindFile -> MonitorKindDir
- -> FilePath -- ^ root path
- -> FilePath -- ^ path of the directory we are
- -- looking in relative to @root@
- -> MonitorStateGlobRel
- -> ChangedM MonitorStateGlobRel
-probeMonitorStateGlobRel kindfile kinddir root dirName
- (MonitorStateGlobDirs glob globPath mtime children) = do
+ MonitorStateGlob kindfile kinddir globroot
+ <$> probeMonitorStateGlobRel kindfile kinddir root "" glob
+
+probeMonitorStateGlobRel
+ :: MonitorKindFile
+ -> MonitorKindDir
+ -> FilePath
+ -- ^ root path
+ -> FilePath
+ -- ^ path of the directory we are
+ -- looking in relative to @root@
+ -> MonitorStateGlobRel
+ -> ChangedM MonitorStateGlobRel
+probeMonitorStateGlobRel
+ kindfile
+ kinddir
+ root
+ dirName
+ (MonitorStateGlobDirs glob globPath mtime children) = do
change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime
case change of
Nothing -> do
- children' <- sequence
- [ do fstate' <- probeMonitorStateGlobRel
- kindfile kinddir root
- (dirName </> fname) fstate
- return (fname, fstate')
- | (fname, fstate) <- children ]
+ children' <-
+ sequence
+ [ do
+ fstate' <-
+ probeMonitorStateGlobRel
+ kindfile
+ kinddir
+ root
+ (dirName </> fname)
+ fstate
+ return (fname, fstate')
+ | (fname, fstate) <- children
+ ]
return $! MonitorStateGlobDirs glob globPath mtime children'
-
Just mtime' -> do
-- directory modification time changed:
-- a matching subdir may have been added or deleted
- matches <- filterM (\entry -> let subdir = root </> dirName </> entry
- in liftIO $ doesDirectoryExist subdir)
- . filter (matchGlob glob)
- =<< liftIO (getDirectoryContents (root </> dirName))
-
- children' <- traverse probeMergeResult $
- mergeBy (\(path1,_) path2 -> compare path1 path2)
- children
- (sort matches)
+ matches <-
+ filterM
+ ( \entry ->
+ let subdir = root </> dirName </> entry
+ in liftIO $ doesDirectoryExist subdir
+ )
+ . filter (matchGlob glob)
+ =<< liftIO (getDirectoryContents (root </> dirName))
+
+ children' <-
+ traverse probeMergeResult $
+ mergeBy
+ (\(path1, _) path2 -> compare path1 path2)
+ children
+ (sort matches)
return $! MonitorStateGlobDirs glob globPath mtime' children'
- -- Note that just because the directory has changed, we don't force
- -- a cache rewrite with 'cacheChanged' since that has some cost, and
- -- all we're saving is scanning the directory. But we do rebuild the
- -- cache with the new mtime', so that if the cache is rewritten for
- -- some other reason, we'll take advantage of that.
-
- where
- probeMergeResult :: MergeResult (FilePath, MonitorStateGlobRel) FilePath
- -> ChangedM (FilePath, MonitorStateGlobRel)
-
- -- Only in cached (directory deleted)
- probeMergeResult (OnlyInLeft (path, fstate)) = do
- case allMatchingFiles (dirName </> path) fstate of
- [] -> return (path, fstate)
- -- Strictly speaking we should be returning 'CacheChanged' above
- -- as we should prune the now-missing 'MonitorStateGlobRel'. However
- -- we currently just leave these now-redundant entries in the
- -- cache as they cost no IO and keeping them allows us to avoid
- -- rewriting the cache.
- (file:_) -> somethingChanged file
-
- -- Only in current filesystem state (directory added)
- probeMergeResult (OnlyInRight path) = do
- fstate <- liftIO $ buildMonitorStateGlobRel Nothing Map.empty
- kindfile kinddir root (dirName </> path) globPath
- case allMatchingFiles (dirName </> path) fstate of
- (file:_) -> somethingChanged file
- -- This is the only case where we use 'cacheChanged' because we can
- -- have a whole new dir subtree (of unbounded size and cost), so we
- -- need to save the state of that new subtree in the cache.
- [] -> cacheChanged >> return (path, fstate)
-
- -- Found in path
- probeMergeResult (InBoth (path, fstate) _) = do
- fstate' <- probeMonitorStateGlobRel kindfile kinddir
- root (dirName </> path) fstate
- return (path, fstate')
-
- -- | Does a 'MonitorStateGlob' have any relevant files within it?
- allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]
- allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =
- [ dir </> fname | (fname, _) <- entries ]
- allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =
- [ res
- | (subdir, fstate) <- entries
- , res <- allMatchingFiles (dir </> subdir) fstate ]
- allMatchingFiles dir MonitorStateGlobDirTrailing =
- [dir]
-
-probeMonitorStateGlobRel _ _ root dirName
- (MonitorStateGlobFiles glob mtime children) = do
+ where
+ -- Note that just because the directory has changed, we don't force
+ -- a cache rewrite with 'cacheChanged' since that has some cost, and
+ -- all we're saving is scanning the directory. But we do rebuild the
+ -- cache with the new mtime', so that if the cache is rewritten for
+ -- some other reason, we'll take advantage of that.
+
+ probeMergeResult
+ :: MergeResult (FilePath, MonitorStateGlobRel) FilePath
+ -> ChangedM (FilePath, MonitorStateGlobRel)
+
+ -- Only in cached (directory deleted)
+ probeMergeResult (OnlyInLeft (path, fstate)) = do
+ case allMatchingFiles (dirName </> path) fstate of
+ [] -> return (path, fstate)
+ -- Strictly speaking we should be returning 'CacheChanged' above
+ -- as we should prune the now-missing 'MonitorStateGlobRel'. However
+ -- we currently just leave these now-redundant entries in the
+ -- cache as they cost no IO and keeping them allows us to avoid
+ -- rewriting the cache.
+ (file : _) -> somethingChanged file
+
+ -- Only in current filesystem state (directory added)
+ probeMergeResult (OnlyInRight path) = do
+ fstate <-
+ liftIO $
+ buildMonitorStateGlobRel
+ Nothing
+ Map.empty
+ kindfile
+ kinddir
+ root
+ (dirName </> path)
+ globPath
+ case allMatchingFiles (dirName </> path) fstate of
+ (file : _) -> somethingChanged file
+ -- This is the only case where we use 'cacheChanged' because we can
+ -- have a whole new dir subtree (of unbounded size and cost), so we
+ -- need to save the state of that new subtree in the cache.
+ [] -> cacheChanged >> return (path, fstate)
+
+ -- Found in path
+ probeMergeResult (InBoth (path, fstate) _) = do
+ fstate' <-
+ probeMonitorStateGlobRel
+ kindfile
+ kinddir
+ root
+ (dirName </> path)
+ fstate
+ return (path, fstate')
+
+ -- \| Does a 'MonitorStateGlob' have any relevant files within it?
+ allMatchingFiles :: FilePath -> MonitorStateGlobRel -> [FilePath]
+ allMatchingFiles dir (MonitorStateGlobFiles _ _ entries) =
+ [dir </> fname | (fname, _) <- entries]
+ allMatchingFiles dir (MonitorStateGlobDirs _ _ _ entries) =
+ [ res
+ | (subdir, fstate) <- entries
+ , res <- allMatchingFiles (dir </> subdir) fstate
+ ]
+ allMatchingFiles dir MonitorStateGlobDirTrailing =
+ [dir]
+probeMonitorStateGlobRel
+ _
+ _
+ root
+ dirName
+ (MonitorStateGlobFiles glob mtime children) = do
change <- liftIO $ checkDirectoryModificationTime (root </> dirName) mtime
mtime' <- case change of
- Nothing -> return mtime
+ Nothing -> return mtime
Just mtime' -> do
-- directory modification time changed:
-- a matching file may have been added or deleted
- matches <- return . filter (matchGlob glob)
- =<< liftIO (getDirectoryContents (root </> dirName))
+ matches <-
+ return . filter (matchGlob glob)
+ =<< liftIO (getDirectoryContents (root </> dirName))
traverse_ probeMergeResult $
- mergeBy (\(path1,_) path2 -> compare path1 path2)
- children
- (sort matches)
+ mergeBy
+ (\(path1, _) path2 -> compare path1 path2)
+ children
+ (sort matches)
return mtime'
-- Check that none of the children have changed
for_ children $ \(file, status) ->
probeMonitorStateFileStatus root (dirName </> file) status
-
return (MonitorStateGlobFiles glob mtime' children)
- -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use
- -- the new mtime' if any.
- where
- probeMergeResult :: MergeResult (FilePath, MonitorStateFileStatus) FilePath
- -> ChangedM ()
- probeMergeResult mr = case mr of
- InBoth _ _ -> return ()
- -- this is just to be able to accurately report which file changed:
- OnlyInLeft (path, _) -> somethingChanged (dirName </> path)
- OnlyInRight path -> somethingChanged (dirName </> path)
-
+ where
+ -- Again, we don't force a cache rewrite with 'cacheChanged', but we do use
+ -- the new mtime' if any.
+
+ probeMergeResult
+ :: MergeResult (FilePath, MonitorStateFileStatus) FilePath
+ -> ChangedM ()
+ probeMergeResult mr = case mr of
+ InBoth _ _ -> return ()
+ -- this is just to be able to accurately report which file changed:
+ OnlyInLeft (path, _) -> somethingChanged (dirName </> path)
+ OnlyInRight path -> somethingChanged (dirName </> path)
probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =
- return MonitorStateGlobDirTrailing
+ return MonitorStateGlobDirTrailing
------------------------------------------------------------------------------
@@ -809,31 +841,39 @@ probeMonitorStateGlobRel _ _ _ _ MonitorStateGlobDirTrailing =
-- 'beginUpdateFileMonitor' to get a timestamp and pass that. Alternatively,
-- if you take the snapshot in advance of the action, or you're not monitoring
-- any files then you can use @Nothing@ for the timestamp parameter.
---
updateFileMonitor
:: (Binary a, Structured a, Binary b, Structured b)
- => FileMonitor a b -- ^ cache file path
- -> FilePath -- ^ root directory
- -> Maybe MonitorTimestamp -- ^ timestamp when the update action started
- -> [MonitorFilePath] -- ^ files of interest relative to root
- -> a -- ^ the current key value
- -> b -- ^ the current result value
+ => FileMonitor a b
+ -- ^ cache file path
+ -> FilePath
+ -- ^ root directory
+ -> Maybe MonitorTimestamp
+ -- ^ timestamp when the update action started
+ -> [MonitorFilePath]
+ -- ^ files of interest relative to root
+ -> a
+ -- ^ the current key value
+ -> b
+ -- ^ the current result value
-> IO ()
-updateFileMonitor monitor root startTime monitorFiles
- cachedKey cachedResult = do
+updateFileMonitor
+ monitor
+ root
+ startTime
+ monitorFiles
+ cachedKey
+ cachedResult = do
hashcache <- readCacheFileHashes monitor
msfs <- buildMonitorStateFileSet startTime hashcache root monitorFiles
rewriteCacheFile monitor msfs cachedKey cachedResult
-- | A timestamp to help with the problem of file changes during actions.
-- See 'updateFileMonitor' for details.
---
newtype MonitorTimestamp = MonitorTimestamp ModTime
-- | Record a timestamp at the beginning of an action, and when the action
-- completes call 'updateFileMonitor' passing it the timestamp.
-- See 'updateFileMonitor' for details.
---
beginUpdateFileMonitor :: IO MonitorTimestamp
beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime
@@ -841,92 +881,110 @@ beginUpdateFileMonitor = MonitorTimestamp <$> getCurTime
-- specification of the set of files we need to monitor, inspect the state
-- of the file system now and collect the information we'll need later to
-- determine if anything has changed.
---
-buildMonitorStateFileSet :: Maybe MonitorTimestamp -- ^ optional: timestamp
- -- of the start of the action
- -> FileHashCache -- ^ existing file hashes
- -> FilePath -- ^ root directory
- -> [MonitorFilePath] -- ^ patterns of interest
- -- relative to root
- -> IO MonitorStateFileSet
+buildMonitorStateFileSet
+ :: Maybe MonitorTimestamp
+ -- ^ optional: timestamp
+ -- of the start of the action
+ -> FileHashCache
+ -- ^ existing file hashes
+ -> FilePath
+ -- ^ root directory
+ -> [MonitorFilePath]
+ -- ^ patterns of interest
+ -- relative to root
+ -> IO MonitorStateFileSet
buildMonitorStateFileSet mstartTime hashcache root =
- go [] []
+ go [] []
where
- go :: [MonitorStateFile] -> [MonitorStateGlob]
- -> [MonitorFilePath] -> IO MonitorStateFileSet
+ go
+ :: [MonitorStateFile]
+ -> [MonitorStateGlob]
+ -> [MonitorFilePath]
+ -> IO MonitorStateFileSet
go !singlePaths !globPaths [] =
return (MonitorStateFileSet (reverse singlePaths) (reverse globPaths))
-
- go !singlePaths !globPaths
- (MonitorFile kindfile kinddir path : monitors) = do
- monitorState <- MonitorStateFile kindfile kinddir path
- <$> buildMonitorStateFile mstartTime hashcache
- kindfile kinddir root path
- go (monitorState : singlePaths) globPaths monitors
-
- go !singlePaths !globPaths
- (MonitorFileGlob kindfile kinddir globPath : monitors) = do
- monitorState <- buildMonitorStateGlob mstartTime hashcache
- kindfile kinddir root globPath
- go singlePaths (monitorState : globPaths) monitors
-
-
-buildMonitorStateFile :: Maybe MonitorTimestamp -- ^ start time of update
- -> FileHashCache -- ^ existing file hashes
- -> MonitorKindFile -> MonitorKindDir
- -> FilePath -- ^ the root directory
- -> FilePath
- -> IO MonitorStateFileStatus
+ go
+ !singlePaths
+ !globPaths
+ (MonitorFile kindfile kinddir path : monitors) = do
+ monitorState <-
+ MonitorStateFile kindfile kinddir path
+ <$> buildMonitorStateFile
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ path
+ go (monitorState : singlePaths) globPaths monitors
+ go
+ !singlePaths
+ !globPaths
+ (MonitorFileGlob kindfile kinddir globPath : monitors) = do
+ monitorState <-
+ buildMonitorStateGlob
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ globPath
+ go singlePaths (monitorState : globPaths) monitors
+
+buildMonitorStateFile
+ :: Maybe MonitorTimestamp
+ -- ^ start time of update
+ -> FileHashCache
+ -- ^ existing file hashes
+ -> MonitorKindFile
+ -> MonitorKindDir
+ -> FilePath
+ -- ^ the root directory
+ -> FilePath
+ -> IO MonitorStateFileStatus
buildMonitorStateFile mstartTime hashcache kindfile kinddir root path = do
- let abspath = root </> path
- isFile <- doesFileExist abspath
- isDir <- doesDirectoryExist abspath
- case (isFile, kindfile, isDir, kinddir) of
- (_, FileNotExists, _, DirNotExists) ->
- -- we don't need to care if it exists now, since we check at probe time
- return MonitorStateNonExistent
-
- (False, _, False, _) ->
- return MonitorStateAlreadyChanged
-
- (True, FileExists, _, _) ->
- return MonitorStateFileExists
-
- (True, FileModTime, _, _) ->
- handleIOException MonitorStateAlreadyChanged $ do
- mtime <- getModTime abspath
- if changedDuringUpdate mstartTime mtime
- then return MonitorStateAlreadyChanged
- else return (MonitorStateFileModTime mtime)
-
- (True, FileHashed, _, _) ->
- handleIOException MonitorStateAlreadyChanged $ do
- mtime <- getModTime abspath
- if changedDuringUpdate mstartTime mtime
- then return MonitorStateAlreadyChanged
- else do hash <- getFileHash hashcache abspath abspath mtime
- return (MonitorStateFileHashed mtime hash)
-
- (_, _, True, DirExists) ->
- return MonitorStateDirExists
-
- (_, _, True, DirModTime) ->
- handleIOException MonitorStateAlreadyChanged $ do
- mtime <- getModTime abspath
- if changedDuringUpdate mstartTime mtime
- then return MonitorStateAlreadyChanged
- else return (MonitorStateDirModTime mtime)
-
- (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged
- (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged
+ let abspath = root </> path
+ isFile <- doesFileExist abspath
+ isDir <- doesDirectoryExist abspath
+ case (isFile, kindfile, isDir, kinddir) of
+ (_, FileNotExists, _, DirNotExists) ->
+ -- we don't need to care if it exists now, since we check at probe time
+ return MonitorStateNonExistent
+ (False, _, False, _) ->
+ return MonitorStateAlreadyChanged
+ (True, FileExists, _, _) ->
+ return MonitorStateFileExists
+ (True, FileModTime, _, _) ->
+ handleIOException MonitorStateAlreadyChanged $ do
+ mtime <- getModTime abspath
+ if changedDuringUpdate mstartTime mtime
+ then return MonitorStateAlreadyChanged
+ else return (MonitorStateFileModTime mtime)
+ (True, FileHashed, _, _) ->
+ handleIOException MonitorStateAlreadyChanged $ do
+ mtime <- getModTime abspath
+ if changedDuringUpdate mstartTime mtime
+ then return MonitorStateAlreadyChanged
+ else do
+ hash <- getFileHash hashcache abspath abspath mtime
+ return (MonitorStateFileHashed mtime hash)
+ (_, _, True, DirExists) ->
+ return MonitorStateDirExists
+ (_, _, True, DirModTime) ->
+ handleIOException MonitorStateAlreadyChanged $ do
+ mtime <- getModTime abspath
+ if changedDuringUpdate mstartTime mtime
+ then return MonitorStateAlreadyChanged
+ else return (MonitorStateDirModTime mtime)
+ (False, _, True, DirNotExists) -> return MonitorStateAlreadyChanged
+ (True, FileNotExists, False, _) -> return MonitorStateAlreadyChanged
-- | If we have a timestamp for the beginning of the update, then any file
-- mtime later than this means that it changed during the update and we ought
-- to consider the file as already changed.
---
changedDuringUpdate :: Maybe MonitorTimestamp -> ModTime -> Bool
-changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime
- = mtime > startTime
+changedDuringUpdate (Just (MonitorTimestamp startTime)) mtime =
+ mtime > startTime
changedDuringUpdate _ _ = False
-- | Much like 'buildMonitorStateFileSet' but for the somewhat complicated case
@@ -935,59 +993,97 @@ changedDuringUpdate _ _ = False
-- This gets used both by 'buildMonitorStateFileSet' when we're taking the
-- file system snapshot, but also by 'probeGlobStatus' as part of checking
-- the monitored (globed) files for changes when we find a whole new subtree.
---
-buildMonitorStateGlob :: Maybe MonitorTimestamp -- ^ start time of update
- -> FileHashCache -- ^ existing file hashes
- -> MonitorKindFile -> MonitorKindDir
- -> FilePath -- ^ the root directory
- -> FilePathGlob -- ^ the matching glob
- -> IO MonitorStateGlob
-buildMonitorStateGlob mstartTime hashcache kindfile kinddir relroot
- (FilePathGlob globroot globPath) = do
+buildMonitorStateGlob
+ :: Maybe MonitorTimestamp
+ -- ^ start time of update
+ -> FileHashCache
+ -- ^ existing file hashes
+ -> MonitorKindFile
+ -> MonitorKindDir
+ -> FilePath
+ -- ^ the root directory
+ -> FilePathGlob
+ -- ^ the matching glob
+ -> IO MonitorStateGlob
+buildMonitorStateGlob
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ relroot
+ (FilePathGlob globroot globPath) = do
root <- liftIO $ getFilePathRootDirectory globroot relroot
- MonitorStateGlob kindfile kinddir globroot <$>
- buildMonitorStateGlobRel
- mstartTime hashcache kindfile kinddir root "." globPath
-
-buildMonitorStateGlobRel :: Maybe MonitorTimestamp -- ^ start time of update
- -> FileHashCache -- ^ existing file hashes
- -> MonitorKindFile -> MonitorKindDir
- -> FilePath -- ^ the root directory
- -> FilePath -- ^ directory we are examining
- -- relative to the root
- -> FilePathGlobRel -- ^ the matching glob
- -> IO MonitorStateGlobRel
-buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root
- dir globPath = do
+ MonitorStateGlob kindfile kinddir globroot
+ <$> buildMonitorStateGlobRel
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ "."
+ globPath
+
+buildMonitorStateGlobRel
+ :: Maybe MonitorTimestamp
+ -- ^ start time of update
+ -> FileHashCache
+ -- ^ existing file hashes
+ -> MonitorKindFile
+ -> MonitorKindDir
+ -> FilePath
+ -- ^ the root directory
+ -> FilePath
+ -- ^ directory we are examining
+ -- relative to the root
+ -> FilePathGlobRel
+ -- ^ the matching glob
+ -> IO MonitorStateGlobRel
+buildMonitorStateGlobRel
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ dir
+ globPath = do
let absdir = root </> dir
dirEntries <- getDirectoryContents absdir
- dirMTime <- getModTime absdir
+ dirMTime <- getModTime absdir
case globPath of
GlobDir glob globPath' -> do
- subdirs <- filterM (\subdir -> doesDirectoryExist (absdir </> subdir))
- $ filter (matchGlob glob) dirEntries
+ subdirs <-
+ filterM (\subdir -> doesDirectoryExist (absdir </> subdir)) $
+ filter (matchGlob glob) dirEntries
subdirStates <-
for (sort subdirs) $ \subdir -> do
- fstate <- buildMonitorStateGlobRel
- mstartTime hashcache kindfile kinddir root
- (dir </> subdir) globPath'
+ fstate <-
+ buildMonitorStateGlobRel
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ (dir </> subdir)
+ globPath'
return (subdir, fstate)
return $! MonitorStateGlobDirs glob globPath' dirMTime subdirStates
-
GlobFile glob -> do
let files = filter (matchGlob glob) dirEntries
filesStates <-
for (sort files) $ \file -> do
- fstate <- buildMonitorStateFile
- mstartTime hashcache kindfile kinddir root
- (dir </> file)
+ fstate <-
+ buildMonitorStateFile
+ mstartTime
+ hashcache
+ kindfile
+ kinddir
+ root
+ (dir </> file)
return (file, fstate)
return $! MonitorStateGlobFiles glob dirMTime filesStates
-
GlobDirTrailing ->
return MonitorStateGlobDirTrailing
-
-- | We really want to avoid re-hashing files all the time. We already make
-- the assumption that if a file mtime has not changed then we don't need to
-- bother checking if the content hash has changed. We can apply the same
@@ -995,70 +1091,76 @@ buildMonitorStateGlobRel mstartTime hashcache kindfile kinddir root
-- updating a file monitor the set of files is the same or largely the same so
-- we can grab the previously known content hashes with their corresponding
-- mtimes.
---
type FileHashCache = Map FilePath (ModTime, Hash)
-- | We declare it a cache hit if the mtime of a file is the same as before.
---
lookupFileHashCache :: FileHashCache -> FilePath -> ModTime -> Maybe Hash
lookupFileHashCache hashcache file mtime = do
- (mtime', hash) <- Map.lookup file hashcache
- guard (mtime' == mtime)
- return hash
+ (mtime', hash) <- Map.lookup file hashcache
+ guard (mtime' == mtime)
+ return hash
-- | Either get it from the cache or go read the file
getFileHash :: FileHashCache -> FilePath -> FilePath -> ModTime -> IO Hash
getFileHash hashcache relfile absfile mtime =
- case lookupFileHashCache hashcache relfile mtime of
- Just hash -> return hash
- Nothing -> readFileHash absfile
+ case lookupFileHashCache hashcache relfile mtime of
+ Just hash -> return hash
+ Nothing -> readFileHash absfile
-- | Build a 'FileHashCache' from the previous 'MonitorStateFileSet'. While
-- in principle we could preserve the structure of the previous state, given
-- that the set of files to monitor can change then it's simpler just to throw
-- away the structure and use a finite map.
---
-readCacheFileHashes :: (Binary a, Structured a, Binary b, Structured b)
- => FileMonitor a b -> IO FileHashCache
+readCacheFileHashes
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => FileMonitor a b
+ -> IO FileHashCache
readCacheFileHashes monitor =
- handleDoesNotExist Map.empty $
- handleErrorCall Map.empty $
- withCacheFile monitor $ \res ->
- case res of
- Left _ -> return Map.empty
- Right (msfs, _, _) -> return (mkFileHashCache msfs)
+ handleDoesNotExist Map.empty $
+ handleErrorCall Map.empty $
+ withCacheFile monitor $ \res ->
+ case res of
+ Left _ -> return Map.empty
+ Right (msfs, _, _) -> return (mkFileHashCache msfs)
where
mkFileHashCache :: MonitorStateFileSet -> FileHashCache
mkFileHashCache (MonitorStateFileSet singlePaths globPaths) =
- collectAllFileHashes singlePaths
+ collectAllFileHashes singlePaths
`Map.union` collectAllGlobHashes globPaths
collectAllFileHashes :: [MonitorStateFile] -> Map FilePath (ModTime, Hash)
collectAllFileHashes singlePaths =
- Map.fromList [ (fpath, (mtime, hash))
- | MonitorStateFile _ _ fpath
- (MonitorStateFileHashed mtime hash) <- singlePaths ]
+ Map.fromList
+ [ (fpath, (mtime, hash))
+ | MonitorStateFile
+ _
+ _
+ fpath
+ (MonitorStateFileHashed mtime hash) <-
+ singlePaths
+ ]
collectAllGlobHashes :: [MonitorStateGlob] -> Map FilePath (ModTime, Hash)
collectAllGlobHashes globPaths =
- Map.fromList [ (fpath, (mtime, hash))
- | MonitorStateGlob _ _ _ gstate <- globPaths
- , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate ]
+ Map.fromList
+ [ (fpath, (mtime, hash))
+ | MonitorStateGlob _ _ _ gstate <- globPaths
+ , (fpath, (mtime, hash)) <- collectGlobHashes "" gstate
+ ]
collectGlobHashes :: FilePath -> MonitorStateGlobRel -> [(FilePath, (ModTime, Hash))]
collectGlobHashes dir (MonitorStateGlobDirs _ _ _ entries) =
[ res
| (subdir, fstate) <- entries
- , res <- collectGlobHashes (dir </> subdir) fstate ]
-
- collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =
+ , res <- collectGlobHashes (dir </> subdir) fstate
+ ]
+ collectGlobHashes dir (MonitorStateGlobFiles _ _ entries) =
[ (dir </> fname, (mtime, hash))
- | (fname, MonitorStateFileHashed mtime hash) <- entries ]
-
+ | (fname, MonitorStateFileHashed mtime hash) <- entries
+ ]
collectGlobHashes _dir MonitorStateGlobDirTrailing =
[]
-
------------------------------------------------------------------------------
-- Utils
--
@@ -1067,45 +1169,53 @@ readCacheFileHashes monitor =
-- the same as @mtime@, short-circuiting if it is different.
probeFileModificationTime :: FilePath -> FilePath -> ModTime -> ChangedM ()
probeFileModificationTime root file mtime = do
- unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime
- unless unchanged (somethingChanged file)
+ unchanged <- liftIO $ checkModificationTimeUnchanged root file mtime
+ unless unchanged (somethingChanged file)
-- | Within the @root@ directory, check if @file@ has its 'ModTime' and
-- 'Hash' is the same as @mtime@ and @hash@, short-circuiting if it is
-- different.
-probeFileModificationTimeAndHash :: FilePath -> FilePath -> ModTime -> Hash
- -> ChangedM ()
+probeFileModificationTimeAndHash
+ :: FilePath
+ -> FilePath
+ -> ModTime
+ -> Hash
+ -> ChangedM ()
probeFileModificationTimeAndHash root file mtime hash = do
- unchanged <- liftIO $
+ unchanged <-
+ liftIO $
checkFileModificationTimeAndHashUnchanged root file mtime hash
- unless unchanged (somethingChanged file)
+ unless unchanged (somethingChanged file)
-- | Within the @root@ directory, check if @file@ still exists as a file.
-- If it *does not* exist, short-circuit.
probeFileExistence :: FilePath -> FilePath -> ChangedM ()
probeFileExistence root file = do
- existsFile <- liftIO $ doesFileExist (root </> file)
- unless existsFile (somethingChanged file)
+ existsFile <- liftIO $ doesFileExist (root </> file)
+ unless existsFile (somethingChanged file)
-- | Within the @root@ directory, check if @dir@ still exists.
-- If it *does not* exist, short-circuit.
probeDirExistence :: FilePath -> FilePath -> ChangedM ()
probeDirExistence root dir = do
- existsDir <- liftIO $ doesDirectoryExist (root </> dir)
- unless existsDir (somethingChanged dir)
+ existsDir <- liftIO $ doesDirectoryExist (root </> dir)
+ unless existsDir (somethingChanged dir)
-- | Within the @root@ directory, check if @file@ still does not exist.
-- If it *does* exist, short-circuit.
probeFileNonExistence :: FilePath -> FilePath -> ChangedM ()
probeFileNonExistence root file = do
- existsFile <- liftIO $ doesFileExist (root </> file)
- existsDir <- liftIO $ doesDirectoryExist (root </> file)
- when (existsFile || existsDir) (somethingChanged file)
+ existsFile <- liftIO $ doesFileExist (root </> file)
+ existsDir <- liftIO $ doesDirectoryExist (root </> file)
+ when (existsFile || existsDir) (somethingChanged file)
-- | Returns @True@ if, inside the @root@ directory, @file@ has the same
-- 'ModTime' as @mtime@.
-checkModificationTimeUnchanged :: FilePath -> FilePath
- -> ModTime -> IO Bool
+checkModificationTimeUnchanged
+ :: FilePath
+ -> FilePath
+ -> ModTime
+ -> IO Bool
checkModificationTimeUnchanged root file mtime =
handleIOException False $ do
mtime' <- getModTime (root </> file)
@@ -1113,8 +1223,12 @@ checkModificationTimeUnchanged root file mtime =
-- | Returns @True@ if, inside the @root@ directory, @file@ has the
-- same 'ModTime' and 'Hash' as @mtime and @chash@.
-checkFileModificationTimeAndHashUnchanged :: FilePath -> FilePath
- -> ModTime -> Hash -> IO Bool
+checkFileModificationTimeAndHashUnchanged
+ :: FilePath
+ -> FilePath
+ -> ModTime
+ -> Hash
+ -> IO Bool
checkFileModificationTimeAndHashUnchanged root file mtime chash =
handleIOException False $ do
mtime' <- getModTime (root </> file)
@@ -1127,8 +1241,8 @@ checkFileModificationTimeAndHashUnchanged root file mtime chash =
-- | Read a non-cryptographic hash of a @file@.
readFileHash :: FilePath -> IO Hash
readFileHash file =
- withBinaryFile file ReadMode $ \hnd ->
- evaluate . Hashable.hash =<< BS.hGetContents hnd
+ withBinaryFile file ReadMode $ \hnd ->
+ evaluate . Hashable.hash =<< BS.hGetContents hnd
-- | Given a directory @dir@, return @Nothing@ if its 'ModTime'
-- is the same as @mtime@, and the new 'ModTime' if it is not.
@@ -1150,22 +1264,19 @@ handleErrorCall e = handle handler where
handler (ErrorCall _) = return e
#endif
-
-- | Run an IO computation, returning @e@ if there is any 'IOException'.
--
-- This policy is OK in the file monitor code because it just causes the
-- monitor to report that something changed, and then code reacting to that
-- will normally encounter the same IO exception when it re-runs the action
-- that uses the file.
---
handleIOException :: a -> IO a -> IO a
handleIOException e =
- handle (anyIOException e)
+ handle (anyIOException e)
where
anyIOException :: a -> IOException -> IO a
anyIOException x _ = return x
-
------------------------------------------------------------------------------
-- Instances
--
diff --git a/cabal-install/src/Distribution/Client/Freeze.hs b/cabal-install/src/Distribution/Client/Freeze.hs
index ff9f6fde91a571c9efee62c3cf0a3e497a5d4e7d..faee9a2cf5a7386a86595b8e49e3a31f814810f5 100644
--- a/cabal-install/src/Distribution/Client/Freeze.hs
+++ b/cabal-install/src/Distribution/Client/Freeze.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Freeze
-- Copyright : (c) David Himmelstrup 2005
@@ -10,29 +13,39 @@
-- Portability : portable
--
-- The cabal freeze command
------------------------------------------------------------------------------
-module Distribution.Client.Freeze (
- freeze, getFreezePkgs
+module Distribution.Client.Freeze
+ ( freeze
+ , getFreezePkgs
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.Config ( SavedConfig(..) )
-import Distribution.Client.Types
-import Distribution.Client.Targets
+import Distribution.Client.Config (SavedConfig (..))
import Distribution.Client.Dependency
import Distribution.Client.IndexUtils as IndexUtils
- ( getSourcePackages, getInstalledPackages )
+ ( getInstalledPackages
+ , getSourcePackages
+ )
+import Distribution.Client.Sandbox.PackageEnvironment
+ ( loadUserConfig
+ , pkgEnvSavedConfig
+ , showPackageEnvironment
+ , userPackageEnvironmentFile
+ )
+import Distribution.Client.Setup
+ ( ConfigExFlags (..)
+ , FreezeFlags (..)
+ , GlobalFlags (..)
+ , RepoContext (..)
+ )
import Distribution.Client.SolverInstallPlan
- ( SolverInstallPlan, SolverPlanPackage )
+ ( SolverInstallPlan
+ , SolverPlanPackage
+ )
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
-import Distribution.Client.Setup
- ( GlobalFlags(..), FreezeFlags(..), ConfigExFlags(..)
- , RepoContext(..) )
-import Distribution.Client.Sandbox.PackageEnvironment
- ( loadUserConfig, pkgEnvSavedConfig, showPackageEnvironment,
- userPackageEnvironmentFile )
+import Distribution.Client.Targets
+import Distribution.Client.Types
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
@@ -41,172 +54,231 @@ import Distribution.Solver.Types.PkgConfigDb
import Distribution.Solver.Types.SolverId
import Distribution.Package
- ( Package, packageId, packageName, packageVersion )
+ ( Package
+ , packageId
+ , packageName
+ , packageVersion
+ )
import Distribution.Simple.Compiler
- ( Compiler, compilerInfo, PackageDBStack )
+ ( Compiler
+ , PackageDBStack
+ , compilerInfo
+ )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import Distribution.Simple.Program
- ( ProgramDb )
+ ( ProgramDb
+ )
import Distribution.Simple.Setup
- ( fromFlag, fromFlagOrDefault, flagToMaybe )
+ ( flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ )
import Distribution.Simple.Utils
- ( die', notice, debug, writeFileAtomic, toUTF8LBS)
+ ( debug
+ , die'
+ , notice
+ , toUTF8LBS
+ , writeFileAtomic
+ )
import Distribution.System
- ( Platform )
+ ( Platform
+ )
import Distribution.Version
- ( thisVersion )
+ ( thisVersion
+ )
-- ------------------------------------------------------------
+
-- * The freeze command
+
-- ------------------------------------------------------------
-- | Freeze all of the dependencies by writing a constraints section
-- constraining each dependency to an exact version.
---
-freeze :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> Platform
- -> ProgramDb
- -> GlobalFlags
- -> FreezeFlags
- -> IO ()
-freeze verbosity packageDBs repoCtxt comp platform progdb
- globalFlags freezeFlags = do
-
- pkgs <- getFreezePkgs
- verbosity packageDBs repoCtxt comp platform progdb
- globalFlags freezeFlags
+freeze
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> GlobalFlags
+ -> FreezeFlags
+ -> IO ()
+freeze
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ platform
+ progdb
+ globalFlags
+ freezeFlags = do
+ pkgs <-
+ getFreezePkgs
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ platform
+ progdb
+ globalFlags
+ freezeFlags
if null pkgs
- then notice verbosity $ "No packages to be frozen. "
- ++ "As this package has no dependencies."
- else if dryRun
- then notice verbosity $ unlines $
- "The following packages would be frozen:"
- : formatPkgs pkgs
-
- else freezePackages verbosity globalFlags pkgs
-
- where
- dryRun = fromFlag (freezeDryRun freezeFlags)
+ then
+ notice verbosity $
+ "No packages to be frozen. "
+ ++ "As this package has no dependencies."
+ else
+ if dryRun
+ then
+ notice verbosity $
+ unlines $
+ "The following packages would be frozen:"
+ : formatPkgs pkgs
+ else freezePackages verbosity globalFlags pkgs
+ where
+ dryRun = fromFlag (freezeDryRun freezeFlags)
-- | Get the list of packages whose versions would be frozen by the @freeze@
-- command.
-getFreezePkgs :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> Platform
- -> ProgramDb
- -> GlobalFlags
- -> FreezeFlags
- -> IO [SolverPlanPackage]
-getFreezePkgs verbosity packageDBs repoCtxt comp platform progdb
- _ freezeFlags = do
-
+getFreezePkgs
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> GlobalFlags
+ -> FreezeFlags
+ -> IO [SolverPlanPackage]
+getFreezePkgs
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ platform
+ progdb
+ _
+ freezeFlags = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
- sourcePkgDb <- getSourcePackages verbosity repoCtxt
- pkgConfigDb <- readPkgConfigDb verbosity progdb
+ sourcePkgDb <- getSourcePackages verbosity repoCtxt
+ pkgConfigDb <- readPkgConfigDb verbosity progdb
- pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
- (packageIndex sourcePkgDb)
- [UserTargetLocalDir "."]
+ pkgSpecifiers <-
+ resolveUserTargets
+ verbosity
+ repoCtxt
+ (packageIndex sourcePkgDb)
+ [UserTargetLocalDir "."]
sanityCheck pkgSpecifiers
planPackages
- verbosity comp platform freezeFlags
- installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
- where
- sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
- sanityCheck pkgSpecifiers = do
- when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
- die' verbosity $ "internal error: 'resolveUserTargets' returned "
- ++ "unexpected named package specifiers!"
- when (length pkgSpecifiers /= 1) $
- die' verbosity $ "internal error: 'resolveUserTargets' returned "
- ++ "unexpected source package specifiers!"
-
-planPackages :: Verbosity
- -> Compiler
- -> Platform
- -> FreezeFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> PkgConfigDb
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> IO [SolverPlanPackage]
-planPackages verbosity comp platform freezeFlags
- installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers = do
-
- solver <- chooseSolver verbosity
- (fromFlag (freezeSolver freezeFlags)) (compilerInfo comp)
- notice verbosity "Resolving dependencies..."
-
- installPlan <- foldProgress logMsg (die' verbosity) return $
- resolveDependencies
- platform (compilerInfo comp) pkgConfigDb
- solver
- resolverParams
-
- return $ pruneInstallPlan installPlan pkgSpecifiers
-
- where
- resolverParams :: DepResolverParams
- resolverParams =
-
- setMaxBackjumps (if maxBackjumps < 0 then Nothing
- else Just maxBackjumps)
-
- . setIndependentGoals independentGoals
-
- . setReorderGoals reorderGoals
-
- . setCountConflicts countConflicts
-
- . setFineGrainedConflicts fineGrainedConflicts
-
- . setMinimizeConflictSet minimizeConflictSet
-
- . setShadowPkgs shadowPkgs
-
- . setStrongFlags strongFlags
-
- . setAllowBootLibInstalls allowBootLibInstalls
-
- . setOnlyConstrained onlyConstrained
-
- . setSolverVerbosity verbosity
-
- . addConstraints
- [ let pkg = pkgSpecifierTarget pkgSpecifier
- pc = PackageConstraint (scopeToplevel pkg)
- (PackagePropertyStanzas stanzas)
- in LabeledPackageConstraint pc ConstraintSourceFreeze
- | pkgSpecifier <- pkgSpecifiers ]
-
- $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
-
- logMsg message rest = debug verbosity message >> rest
-
- stanzas = [ TestStanzas | testsEnabled ]
- ++ [ BenchStanzas | benchmarksEnabled ]
- testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags
- benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
-
- reorderGoals = fromFlag (freezeReorderGoals freezeFlags)
- countConflicts = fromFlag (freezeCountConflicts freezeFlags)
- fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags)
- minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags)
- independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
- shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
- strongFlags = fromFlag (freezeStrongFlags freezeFlags)
- maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags)
- allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)
- onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags)
-
+ verbosity
+ comp
+ platform
+ freezeFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+ pkgSpecifiers
+ where
+ sanityCheck :: [PackageSpecifier UnresolvedSourcePackage] -> IO ()
+ sanityCheck pkgSpecifiers = do
+ when (not . null $ [n | n@(NamedPackage _ _) <- pkgSpecifiers]) $
+ die' verbosity $
+ "internal error: 'resolveUserTargets' returned "
+ ++ "unexpected named package specifiers!"
+ when (length pkgSpecifiers /= 1) $
+ die' verbosity $
+ "internal error: 'resolveUserTargets' returned "
+ ++ "unexpected source package specifiers!"
+
+planPackages
+ :: Verbosity
+ -> Compiler
+ -> Platform
+ -> FreezeFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> PkgConfigDb
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> IO [SolverPlanPackage]
+planPackages
+ verbosity
+ comp
+ platform
+ freezeFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+ pkgSpecifiers = do
+ solver <-
+ chooseSolver
+ verbosity
+ (fromFlag (freezeSolver freezeFlags))
+ (compilerInfo comp)
+ notice verbosity "Resolving dependencies..."
+
+ installPlan <-
+ foldProgress logMsg (die' verbosity) return $
+ resolveDependencies
+ platform
+ (compilerInfo comp)
+ pkgConfigDb
+ solver
+ resolverParams
+
+ return $ pruneInstallPlan installPlan pkgSpecifiers
+ where
+ resolverParams :: DepResolverParams
+ resolverParams =
+ setMaxBackjumps
+ ( if maxBackjumps < 0
+ then Nothing
+ else Just maxBackjumps
+ )
+ . setIndependentGoals independentGoals
+ . setReorderGoals reorderGoals
+ . setCountConflicts countConflicts
+ . setFineGrainedConflicts fineGrainedConflicts
+ . setMinimizeConflictSet minimizeConflictSet
+ . setShadowPkgs shadowPkgs
+ . setStrongFlags strongFlags
+ . setAllowBootLibInstalls allowBootLibInstalls
+ . setOnlyConstrained onlyConstrained
+ . setSolverVerbosity verbosity
+ . addConstraints
+ [ let pkg = pkgSpecifierTarget pkgSpecifier
+ pc =
+ PackageConstraint
+ (scopeToplevel pkg)
+ (PackagePropertyStanzas stanzas)
+ in LabeledPackageConstraint pc ConstraintSourceFreeze
+ | pkgSpecifier <- pkgSpecifiers
+ ]
+ $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers
+
+ logMsg message rest = debug verbosity message >> rest
+
+ stanzas =
+ [TestStanzas | testsEnabled]
+ ++ [BenchStanzas | benchmarksEnabled]
+ testsEnabled = fromFlagOrDefault False $ freezeTests freezeFlags
+ benchmarksEnabled = fromFlagOrDefault False $ freezeBenchmarks freezeFlags
+
+ reorderGoals = fromFlag (freezeReorderGoals freezeFlags)
+ countConflicts = fromFlag (freezeCountConflicts freezeFlags)
+ fineGrainedConflicts = fromFlag (freezeFineGrainedConflicts freezeFlags)
+ minimizeConflictSet = fromFlag (freezeMinimizeConflictSet freezeFlags)
+ independentGoals = fromFlag (freezeIndependentGoals freezeFlags)
+ shadowPkgs = fromFlag (freezeShadowPkgs freezeFlags)
+ strongFlags = fromFlag (freezeStrongFlags freezeFlags)
+ maxBackjumps = fromFlag (freezeMaxBackjumps freezeFlags)
+ allowBootLibInstalls = fromFlag (freezeAllowBootLibInstalls freezeFlags)
+ onlyConstrained = fromFlag (freezeOnlyConstrained freezeFlags)
-- | Remove all unneeded packages from an install plan.
--
@@ -220,45 +292,53 @@ planPackages verbosity comp platform freezeFlags
--
-- Invariant: @pkgSpecifiers@ must refer to packages which are not
-- 'PreExisting' in the 'SolverInstallPlan'.
-pruneInstallPlan :: SolverInstallPlan
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> [SolverPlanPackage]
+pruneInstallPlan
+ :: SolverInstallPlan
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> [SolverPlanPackage]
pruneInstallPlan installPlan pkgSpecifiers =
- removeSelf pkgIds $
+ removeSelf pkgIds $
SolverInstallPlan.dependencyClosure installPlan pkgIds
where
- pkgIds = [ PlannedId (packageId pkg)
- | SpecificSourcePackage pkg <- pkgSpecifiers ]
+ pkgIds =
+ [ PlannedId (packageId pkg)
+ | SpecificSourcePackage pkg <- pkgSpecifiers
+ ]
removeSelf [thisPkg] = filter (\pp -> packageId pp /= packageId thisPkg)
- removeSelf _ = error $ "internal error: 'pruneInstallPlan' given "
- ++ "unexpected package specifiers!"
-
+ removeSelf _ =
+ error $
+ "internal error: 'pruneInstallPlan' given "
+ ++ "unexpected package specifiers!"
freezePackages :: Package pkg => Verbosity -> GlobalFlags -> [pkg] -> IO ()
freezePackages verbosity globalFlags pkgs = do
-
- pkgEnv <- fmap (createPkgEnv . addFrozenConstraints) $
- loadUserConfig verbosity ""
- (flagToMaybe . globalConstraintsFile $ globalFlags)
- writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
+ pkgEnv <-
+ fmap (createPkgEnv . addFrozenConstraints) $
+ loadUserConfig
+ verbosity
+ ""
+ (flagToMaybe . globalConstraintsFile $ globalFlags)
+ writeFileAtomic userPackageEnvironmentFile $ showPkgEnv pkgEnv
where
addFrozenConstraints config =
- config {
- savedConfigureExFlags = (savedConfigureExFlags config) {
- configExConstraints = map constraint pkgs
- }
+ config
+ { savedConfigureExFlags =
+ (savedConfigureExFlags config)
+ { configExConstraints = map constraint pkgs
+ }
}
constraint pkg =
- (pkgIdToConstraint $ packageId pkg
- ,ConstraintSourceUserConfig userPackageEnvironmentFile)
+ ( pkgIdToConstraint $ packageId pkg
+ , ConstraintSourceUserConfig userPackageEnvironmentFile
+ )
where
pkgIdToConstraint pkgId =
- UserConstraint (UserQualified UserQualToplevel (packageName pkgId))
- (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
- createPkgEnv config = mempty { pkgEnvSavedConfig = config }
+ UserConstraint
+ (UserQualified UserQualToplevel (packageName pkgId))
+ (PackagePropertyVersion $ thisVersion (packageVersion pkgId))
+ createPkgEnv config = mempty{pkgEnvSavedConfig = config}
showPkgEnv = toUTF8LBS . showPackageEnvironment
-
formatPkgs :: Package pkg => [pkg] -> [String]
formatPkgs = map $ showPkg . packageId
where
diff --git a/cabal-install/src/Distribution/Client/GZipUtils.hs b/cabal-install/src/Distribution/Client/GZipUtils.hs
index 003ba0e99c78db556fe541ddc0d5246648a52323..acbea16d2e9ec2f536419eb02592d2b3402ed265 100644
--- a/cabal-install/src/Distribution/Client/GZipUtils.hs
+++ b/cabal-install/src/Distribution/Client/GZipUtils.hs
@@ -1,7 +1,10 @@
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.GZipUtils
-- Copyright : (c) Dmitry Astapov 2010
@@ -13,16 +16,15 @@
--
-- Provides a convenience functions for working with files that may or may not
-- be zipped.
------------------------------------------------------------------------------
-module Distribution.Client.GZipUtils (
- maybeDecompress,
+module Distribution.Client.GZipUtils
+ ( maybeDecompress
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Codec.Compression.Zlib.Internal
-import Data.ByteString.Lazy.Internal as BS (ByteString(Empty, Chunk))
+import Data.ByteString.Lazy.Internal as BS (ByteString (Chunk, Empty))
#ifndef MIN_VERSION_zlib
#define MIN_VERSION_zlib(x,y,z) 1
@@ -42,7 +44,6 @@ import qualified Data.ByteString as Strict
-- This is to deal with http proxies that lie to us and transparently
-- decompress without removing the content-encoding header. See:
-- <https://github.com/haskell/cabal/issues/678>
---
maybeDecompress :: ByteString -> ByteString
#if MIN_VERSION_zlib(0,6,0)
maybeDecompress bytes = runST (go bytes decompressor)
diff --git a/cabal-install/src/Distribution/Client/GenBounds.hs b/cabal-install/src/Distribution/Client/GenBounds.hs
index d82387cc015cf5f0ee300c5e1e883ccd66f0fde7..e3584ab8cd405bc0ea20e429e7c0d75a4c3a1981 100644
--- a/cabal-install/src/Distribution/Client/GenBounds.hs
+++ b/cabal-install/src/Distribution/Client/GenBounds.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.GenBounds
-- Copyright : (c) Doug Beardsley 2015
@@ -10,45 +14,75 @@
-- Portability : portable
--
-- The cabal gen-bounds command for generating PVP-compliant version bounds.
------------------------------------------------------------------------------
-module Distribution.Client.GenBounds (
- genBounds
+module Distribution.Client.GenBounds
+ ( genBounds
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.Utils
- ( hasElem, incVersion )
import Distribution.Client.Freeze
- ( getFreezePkgs )
+ ( getFreezePkgs
+ )
import Distribution.Client.Setup
- ( GlobalFlags(..), FreezeFlags(..), RepoContext )
+ ( FreezeFlags (..)
+ , GlobalFlags (..)
+ , RepoContext
+ )
+import Distribution.Client.Utils
+ ( hasElem
+ , incVersion
+ )
import Distribution.Package
- ( Package(..), unPackageName, packageName, packageVersion )
+ ( Package (..)
+ , packageName
+ , packageVersion
+ , unPackageName
+ )
import Distribution.PackageDescription
- ( enabledBuildDepends )
+ ( enabledBuildDepends
+ )
import Distribution.PackageDescription.Configuration
- ( finalizePD )
-import Distribution.Types.ComponentRequestedSpec
- ( defaultComponentRequestedSpec )
-import Distribution.Types.Dependency
+ ( finalizePD
+ )
import Distribution.Simple.Compiler
- ( Compiler, PackageDBStack, compilerInfo )
+ ( Compiler
+ , PackageDBStack
+ , compilerInfo
+ )
import Distribution.Simple.PackageDescription
- ( readGenericPackageDescription )
+ ( readGenericPackageDescription
+ )
import Distribution.Simple.Program
- ( ProgramDb )
+ ( ProgramDb
+ )
import Distribution.Simple.Utils
- ( notice, tryFindPackageDesc )
+ ( notice
+ , tryFindPackageDesc
+ )
import Distribution.System
- ( Platform )
+ ( Platform
+ )
+import Distribution.Types.ComponentRequestedSpec
+ ( defaultComponentRequestedSpec
+ )
+import Distribution.Types.Dependency
import Distribution.Version
- ( Version, alterVersion, VersionInterval (..)
- , LowerBound(..), UpperBound(..), VersionRange, asVersionIntervals
- , orLaterVersion, earlierVersion, intersectVersionRanges, hasUpperBound)
+ ( LowerBound (..)
+ , UpperBound (..)
+ , Version
+ , VersionInterval (..)
+ , VersionRange
+ , alterVersion
+ , asVersionIntervals
+ , earlierVersion
+ , hasUpperBound
+ , intersectVersionRanges
+ , orLaterVersion
+ )
import System.Directory
- ( getCurrentDirectory )
+ ( getCurrentDirectory
+ )
-- | Given a version, return an API-compatible (according to PVP) version range.
--
@@ -59,19 +93,21 @@ import System.Directory
-- the user could be using a new function introduced in a.b.c which would make
-- ">= a.b" incorrect.
pvpize :: Version -> VersionRange
-pvpize v = orLaterVersion (vn 3)
- `intersectVersionRanges`
- earlierVersion (incVersion 1 (vn 2))
+pvpize v =
+ orLaterVersion (vn 3)
+ `intersectVersionRanges` earlierVersion (incVersion 1 (vn 2))
where
vn n = alterVersion (take n) v
-- | Show the PVP-mandated version range for this package. The @padTo@ parameter
-- specifies the width of the package name column.
showBounds :: Package pkg => Int -> pkg -> String
-showBounds padTo p = unwords $
- (padAfter padTo $ unPackageName $ packageName p) :
- -- TODO: use normaliseVersionRange
- map showInterval (asVersionIntervals $ pvpize $ packageVersion p)
+showBounds padTo p =
+ unwords $
+ (padAfter padTo $ unPackageName $ packageName p)
+ :
+ -- TODO: use normaliseVersionRange
+ map showInterval (asVersionIntervals $ pvpize $ packageVersion p)
where
padAfter :: Int -> String -> String
padAfter n str = str ++ replicate (n - length str) ' '
@@ -84,45 +120,64 @@ showBounds padTo p = unwords $
-- | Entry point for the @gen-bounds@ command.
genBounds
- :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> Platform
- -> ProgramDb
- -> GlobalFlags
- -> FreezeFlags
- -> IO ()
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> GlobalFlags
+ -> FreezeFlags
+ -> IO ()
genBounds verbosity packageDBs repoCtxt comp platform progdb globalFlags freezeFlags = do
- let cinfo = compilerInfo comp
-
- cwd <- getCurrentDirectory
- path <- tryFindPackageDesc verbosity cwd
- gpd <- readGenericPackageDescription verbosity path
- -- NB: We don't enable tests or benchmarks, since often they
- -- don't really have useful bounds.
- let epd = finalizePD mempty defaultComponentRequestedSpec
- (const True) platform cinfo [] gpd
- case epd of
- Left _ -> putStrLn "finalizePD failed"
- Right (pd,_) -> do
- let needBounds = map depName $ filter (not . hasUpperBound . depVersion) $
- enabledBuildDepends pd defaultComponentRequestedSpec
-
- pkgs <- getFreezePkgs
- verbosity packageDBs repoCtxt comp platform progdb
- globalFlags freezeFlags
-
- let isNeeded = hasElem needBounds . unPackageName . packageName
- let thePkgs = filter isNeeded pkgs
-
- let padTo = maximum $ map (length . unPackageName . packageName) pkgs
-
- if null thePkgs then notice verbosity
- "Congratulations, all your dependencies have upper bounds!"
+ let cinfo = compilerInfo comp
+
+ cwd <- getCurrentDirectory
+ path <- tryFindPackageDesc verbosity cwd
+ gpd <- readGenericPackageDescription verbosity path
+ -- NB: We don't enable tests or benchmarks, since often they
+ -- don't really have useful bounds.
+ let epd =
+ finalizePD
+ mempty
+ defaultComponentRequestedSpec
+ (const True)
+ platform
+ cinfo
+ []
+ gpd
+ case epd of
+ Left _ -> putStrLn "finalizePD failed"
+ Right (pd, _) -> do
+ let needBounds =
+ map depName $
+ filter (not . hasUpperBound . depVersion) $
+ enabledBuildDepends pd defaultComponentRequestedSpec
+
+ pkgs <-
+ getFreezePkgs
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ platform
+ progdb
+ globalFlags
+ freezeFlags
+
+ let isNeeded = hasElem needBounds . unPackageName . packageName
+ let thePkgs = filter isNeeded pkgs
+
+ let padTo = maximum $ map (length . unPackageName . packageName) pkgs
+
+ if null thePkgs
+ then
+ notice
+ verbosity
+ "Congratulations, all your dependencies have upper bounds!"
else do
- notice verbosity boundsNeededMsg
- traverse_ (notice verbosity . (++",") . showBounds padTo) thePkgs
+ notice verbosity boundsNeededMsg
+ traverse_ (notice verbosity . (++ ",") . showBounds padTo) thePkgs
depName :: Dependency -> String
depName (Dependency pn _ _) = unPackageName pn
@@ -133,18 +188,19 @@ depVersion (Dependency _ vr _) = vr
-- | The message printed when some dependencies are found to be lacking proper
-- PVP-mandated bounds.
boundsNeededMsg :: String
-boundsNeededMsg = unlines
- [ ""
- , "The following packages need bounds and here is a suggested starting point."
- , "You can copy and paste this into the build-depends section in your .cabal"
- , "file and it should work (with the appropriate removal of commas)."
- , ""
- , "Note that version bounds are a statement that you've successfully built and"
- , "tested your package and expect it to work with any of the specified package"
- , "versions (PROVIDED that those packages continue to conform with the PVP)."
- , "Therefore, the version bounds generated here are the most conservative"
- , "based on the versions that you are currently building with. If you know"
- , "your package will work with versions outside the ranges generated here,"
- , "feel free to widen them."
- , ""
- ]
+boundsNeededMsg =
+ unlines
+ [ ""
+ , "The following packages need bounds and here is a suggested starting point."
+ , "You can copy and paste this into the build-depends section in your .cabal"
+ , "file and it should work (with the appropriate removal of commas)."
+ , ""
+ , "Note that version bounds are a statement that you've successfully built and"
+ , "tested your package and expect it to work with any of the specified package"
+ , "versions (PROVIDED that those packages continue to conform with the PVP)."
+ , "Therefore, the version bounds generated here are the most conservative"
+ , "based on the versions that you are currently building with. If you know"
+ , "your package will work with versions outside the ranges generated here,"
+ , "feel free to widen them."
+ , ""
+ ]
diff --git a/cabal-install/src/Distribution/Client/Get.hs b/cabal-install/src/Distribution/Client/Get.hs
index d56700969916054df802e853b730ae57af0d1a81..fa97ddad6cd7f5110bbdf10ea2da41bc32132d2c 100644
--- a/cabal-install/src/Distribution/Client/Get.hs
+++ b/cabal-install/src/Distribution/Client/Get.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Get
-- Copyright : (c) Andrea Vezzosi 2008
@@ -11,69 +14,94 @@
-- Portability : portable
--
-- The 'cabal get' command.
------------------------------------------------------------------------------
-
-module Distribution.Client.Get (
- get,
+module Distribution.Client.Get
+ ( get
-- * Cloning 'SourceRepo's
+
-- | Mainly exported for testing purposes
- clonePackagesFromSourceRepo,
- ClonePackageException(..),
+ , clonePackagesFromSourceRepo
+ , ClonePackageException (..)
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude hiding (get)
+import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..), srpToProxy)
import Distribution.Compat.Directory
- ( listDirectory )
+ ( listDirectory
+ )
import Distribution.Package
- ( PackageId, packageId, packageName )
-import Distribution.Simple.Setup
- ( Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )
-import Distribution.Simple.Utils
- ( notice, die', info, warn, writeFileAtomic )
+ ( PackageId
+ , packageId
+ , packageName
+ )
import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Program
- ( programName )
+ ( programName
+ )
+import Distribution.Simple.Setup
+ ( Flag (..)
+ , flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ )
+import Distribution.Simple.Utils
+ ( die'
+ , info
+ , notice
+ , warn
+ , writeFileAtomic
+ )
import Distribution.Types.SourceRepo (RepoKind (..))
-import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy, srpToProxy)
+import Prelude ()
-import Distribution.Client.Setup
- ( GlobalFlags(..), GetFlags(..), RepoContext(..) )
-import Distribution.Client.Types
-import Distribution.Client.Targets
import Distribution.Client.Dependency
-import Distribution.Client.VCS
import Distribution.Client.FetchUtils
-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
import Distribution.Client.IndexUtils
- ( getSourcePackagesAtIndexState, TotalIndexState, ActiveRepos )
-import Distribution.Solver.Types.SourcePackage
+ ( ActiveRepos
+ , TotalIndexState
+ , getSourcePackagesAtIndexState
+ )
+import Distribution.Client.Setup
+ ( GetFlags (..)
+ , GlobalFlags (..)
+ , RepoContext (..)
+ )
+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)
+import Distribution.Client.Targets
+import Distribution.Client.Types
+import Distribution.Client.VCS
import Distribution.PackageDescription.PrettyPrint
- ( writeGenericPackageDescription )
+ ( writeGenericPackageDescription
+ )
+import Distribution.Solver.Types.SourcePackage
+import Control.Monad (mapM_)
import qualified Data.Map as Map
-import Control.Monad ( mapM_ )
import System.Directory
- ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )
+ ( createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ )
import System.FilePath
- ( (</>), (<.>), addTrailingPathSeparator )
-
+ ( addTrailingPathSeparator
+ , (<.>)
+ , (</>)
+ )
-- | Entry point for the 'cabal get' command.
-get :: Verbosity
- -> RepoContext
- -> GlobalFlags
- -> GetFlags
- -> [UserTarget]
- -> IO ()
+get
+ :: Verbosity
+ -> RepoContext
+ -> GlobalFlags
+ -> GetFlags
+ -> [UserTarget]
+ -> IO ()
get verbosity _ _ _ [] =
- notice verbosity "No packages requested. Nothing to do."
-
+ notice verbosity "No packages requested. Nothing to do."
get verbosity repoCtxt _ getFlags userTargets = do
let useSourceRepo = case getSourceRepository getFlags of
- NoFlag -> False
- _ -> True
+ NoFlag -> False
+ _ -> True
unless useSourceRepo $
traverse_ (checkTarget verbosity) userTargets
@@ -86,13 +114,17 @@ get verbosity repoCtxt _ getFlags userTargets = do
(sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState activeRepos
- pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
- (packageIndex sourcePkgDb)
- userTargets
+ pkgSpecifiers <-
+ resolveUserTargets
+ verbosity
+ repoCtxt
+ (packageIndex sourcePkgDb)
+ userTargets
- pkgs <- either (die' verbosity . unlines . map show) return $
- resolveWithoutDependencies
- (resolverParams sourcePkgDb pkgSpecifiers)
+ pkgs <-
+ either (die' verbosity . unlines . map show) return $
+ resolveWithoutDependencies
+ (resolverParams sourcePkgDb pkgSpecifiers)
unless (null prefix) $
createDirectoryIfMissing True prefix
@@ -108,12 +140,11 @@ get verbosity repoCtxt _ getFlags userTargets = do
if useSourceRepo
then clone pkgs
else unpack pkgs
-
where
resolverParams :: SourcePackageDb -> [PackageSpecifier UnresolvedSourcePackage] -> DepResolverParams
resolverParams sourcePkgDb pkgSpecifiers =
- --TODO: add command-line constraint and preference args for unpack
- standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
+ -- TODO: add command-line constraint and preference args for unpack
+ standardInstallPolicy mempty sourcePkgDb pkgSpecifiers
onlyPkgDescr = fromFlagOrDefault False (getOnlyPkgDescr getFlags)
@@ -121,37 +152,37 @@ get verbosity repoCtxt _ getFlags userTargets = do
prefix = fromFlagOrDefault "" (getDestDir getFlags)
clone :: [UnresolvedSourcePackage] -> IO ()
- clone = clonePackagesFromSourceRepo verbosity prefix kind
- . map (\pkg -> (packageId pkg, packageSourceRepos pkg))
+ clone =
+ clonePackagesFromSourceRepo verbosity prefix kind
+ . map (\pkg -> (packageId pkg, packageSourceRepos pkg))
where
kind :: Maybe RepoKind
kind = fromFlag . getSourceRepository $ getFlags
packageSourceRepos :: SourcePackage loc -> [PD.SourceRepo]
- packageSourceRepos = PD.sourceRepos
- . PD.packageDescription
- . srcpkgDescription
+ packageSourceRepos =
+ PD.sourceRepos
+ . PD.packageDescription
+ . srcpkgDescription
unpack :: [UnresolvedSourcePackage] -> IO ()
unpack pkgs = do
for_ pkgs $ \pkg -> do
location <- fetchPackage verbosity repoCtxt (srcpkgSource pkg)
let pkgid = packageId pkg
- descOverride | usePristine = Nothing
- | otherwise = srcpkgDescrOverride pkg
+ descOverride
+ | usePristine = Nothing
+ | otherwise = srcpkgDescrOverride pkg
case location of
LocalTarballPackage tarballPath ->
unpackPackage verbosity prefix pkgid descOverride tarballPath
-
RemoteTarballPackage _tarballURL tarballPath ->
unpackPackage verbosity prefix pkgid descOverride tarballPath
-
RepoTarballPackage _repo _pkgid tarballPath ->
unpackPackage verbosity prefix pkgid descOverride tarballPath
-
RemoteSourceRepoPackage _repo _ ->
- die' verbosity $ "The 'get' command does no yet support targets "
- ++ "that are remote source repositories."
-
+ die' verbosity $
+ "The 'get' command does no yet support targets "
+ ++ "that are remote source repositories."
LocalUnpackedPackage _ ->
error "Distribution.Client.Get.unpack: the impossible happened."
where
@@ -160,178 +191,218 @@ get verbosity repoCtxt _ getFlags userTargets = do
checkTarget :: Verbosity -> UserTarget -> IO ()
checkTarget verbosity target = case target of
- UserTargetLocalDir dir -> die' verbosity (notTarball dir)
- UserTargetLocalCabalFile file -> die' verbosity (notTarball file)
- _ -> return ()
+ UserTargetLocalDir dir -> die' verbosity (notTarball dir)
+ UserTargetLocalCabalFile file -> die' verbosity (notTarball file)
+ _ -> return ()
where
notTarball t =
- "The 'get' command is for tarball packages. "
- ++ "The target '" ++ t ++ "' is not a tarball."
+ "The 'get' command is for tarball packages. "
+ ++ "The target '"
+ ++ t
+ ++ "' is not a tarball."
-- ------------------------------------------------------------
+
-- * Unpacking the source tarball
+
-- ------------------------------------------------------------
-unpackPackage :: Verbosity -> FilePath -> PackageId
- -> PackageDescriptionOverride
- -> FilePath -> IO ()
+unpackPackage
+ :: Verbosity
+ -> FilePath
+ -> PackageId
+ -> PackageDescriptionOverride
+ -> FilePath
+ -> IO ()
unpackPackage verbosity prefix pkgid descOverride pkgPath = do
- let pkgdirname = prettyShow pkgid
- pkgdir = prefix </> pkgdirname
- pkgdir' = addTrailingPathSeparator pkgdir
- emptyDirectory directory = null <$> listDirectory directory
- existsDir <- doesDirectoryExist pkgdir
- when existsDir $ do
- isEmpty <- emptyDirectory pkgdir
- unless isEmpty $
- die' verbosity $
+ let pkgdirname = prettyShow pkgid
+ pkgdir = prefix </> pkgdirname
+ pkgdir' = addTrailingPathSeparator pkgdir
+ emptyDirectory directory = null <$> listDirectory directory
+ existsDir <- doesDirectoryExist pkgdir
+ when existsDir $ do
+ isEmpty <- emptyDirectory pkgdir
+ unless isEmpty $
+ die' verbosity $
"The directory \"" ++ pkgdir' ++ "\" already exists and is not empty, not unpacking."
- existsFile <- doesFileExist pkgdir
- when existsFile $ die' verbosity $
- "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."
- notice verbosity $ "Unpacking to " ++ pkgdir'
- Tar.extractTarGzFile prefix pkgdirname pkgPath
-
- case descOverride of
- Nothing -> return ()
- Just pkgtxt -> do
- let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"
- info verbosity $
- "Updating " ++ descFilePath
- ++ " with the latest revision from the index."
- writeFileAtomic descFilePath pkgtxt
-
+ existsFile <- doesFileExist pkgdir
+ when existsFile $
+ die' verbosity $
+ "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."
+ notice verbosity $ "Unpacking to " ++ pkgdir'
+ Tar.extractTarGzFile prefix pkgdirname pkgPath
+
+ case descOverride of
+ Nothing -> return ()
+ Just pkgtxt -> do
+ let descFilePath = pkgdir </> prettyShow (packageName pkgid) <.> "cabal"
+ info verbosity $
+ "Updating "
+ ++ descFilePath
+ ++ " with the latest revision from the index."
+ writeFileAtomic descFilePath pkgtxt
-- | Write a @pkgId.cabal@ file with the package description to the destination
-- directory, unless one already exists.
unpackOnlyPkgDescr :: Verbosity -> FilePath -> UnresolvedSourcePackage -> IO ()
unpackOnlyPkgDescr verbosity dstDir pkg = do
- let pkgFile = dstDir </> prettyShow (packageId pkg) <.> "cabal"
- existsFile <- doesFileExist pkgFile
- when existsFile $ die' verbosity $
+ let pkgFile = dstDir </> prettyShow (packageId pkg) <.> "cabal"
+ existsFile <- doesFileExist pkgFile
+ when existsFile $
+ die' verbosity $
"The file \"" ++ pkgFile ++ "\" already exists, not overwriting."
- existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile)
- when existsDir $ die' verbosity $
+ existsDir <- doesDirectoryExist (addTrailingPathSeparator pkgFile)
+ when existsDir $
+ die' verbosity $
"A directory \"" ++ pkgFile ++ "\" is in the way, not unpacking."
- notice verbosity $ "Writing package description to " ++ pkgFile
- case srcpkgDescrOverride pkg of
- Just pkgTxt -> writeFileAtomic pkgFile pkgTxt
- Nothing ->
- writeGenericPackageDescription pkgFile (srcpkgDescription pkg)
+ notice verbosity $ "Writing package description to " ++ pkgFile
+ case srcpkgDescrOverride pkg of
+ Just pkgTxt -> writeFileAtomic pkgFile pkgTxt
+ Nothing ->
+ writeGenericPackageDescription pkgFile (srcpkgDescription pkg)
-- ------------------------------------------------------------
+
-- * Cloning packages from their declared source repositories
--- ------------------------------------------------------------
+-- ------------------------------------------------------------
-data ClonePackageException =
- ClonePackageNoSourceRepos PackageId
- | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
- | ClonePackageNoRepoType PackageId PD.SourceRepo
- | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
- | ClonePackageNoRepoLocation PackageId PD.SourceRepo
- | ClonePackageDestinationExists PackageId FilePath Bool
- | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode
+data ClonePackageException
+ = ClonePackageNoSourceRepos PackageId
+ | ClonePackageNoSourceReposOfKind PackageId (Maybe RepoKind)
+ | ClonePackageNoRepoType PackageId PD.SourceRepo
+ | ClonePackageUnsupportedRepoType PackageId SourceRepoProxy RepoType
+ | ClonePackageNoRepoLocation PackageId PD.SourceRepo
+ | ClonePackageDestinationExists PackageId FilePath Bool
+ | ClonePackageFailedWithExitCode PackageId SourceRepoProxy String ExitCode
deriving (Show, Eq)
instance Exception ClonePackageException where
displayException (ClonePackageNoSourceRepos pkgid) =
- "Cannot fetch a source repository for package " ++ prettyShow pkgid
- ++ ". The package does not specify any source repositories."
-
+ "Cannot fetch a source repository for package "
+ ++ prettyShow pkgid
+ ++ ". The package does not specify any source repositories."
displayException (ClonePackageNoSourceReposOfKind pkgid repoKind) =
- "Cannot fetch a source repository for package " ++ prettyShow pkgid
- ++ ". The package does not specify a source repository of the requested "
- ++ "kind" ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind
-
+ "Cannot fetch a source repository for package "
+ ++ prettyShow pkgid
+ ++ ". The package does not specify a source repository of the requested "
+ ++ "kind"
+ ++ maybe "." (\k -> " (kind " ++ prettyShow k ++ ").") repoKind
displayException (ClonePackageNoRepoType pkgid _repo) =
- "Cannot fetch the source repository for package " ++ prettyShow pkgid
- ++ ". The package's description specifies a source repository but does "
- ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
-
+ "Cannot fetch the source repository for package "
+ ++ prettyShow pkgid
+ ++ ". The package's description specifies a source repository but does "
+ ++ "not specify the repository 'type' field (e.g. git, darcs or hg)."
displayException (ClonePackageUnsupportedRepoType pkgid _ repoType) =
- "Cannot fetch the source repository for package " ++ prettyShow pkgid
- ++ ". The repository type '" ++ prettyShow repoType
- ++ "' is not yet supported."
-
+ "Cannot fetch the source repository for package "
+ ++ prettyShow pkgid
+ ++ ". The repository type '"
+ ++ prettyShow repoType
+ ++ "' is not yet supported."
displayException (ClonePackageNoRepoLocation pkgid _repo) =
- "Cannot fetch the source repository for package " ++ prettyShow pkgid
- ++ ". The package's description specifies a source repository but does "
- ++ "not specify the repository 'location' field (i.e. the URL)."
-
+ "Cannot fetch the source repository for package "
+ ++ prettyShow pkgid
+ ++ ". The package's description specifies a source repository but does "
+ ++ "not specify the repository 'location' field (i.e. the URL)."
displayException (ClonePackageDestinationExists pkgid dest isdir) =
- "Not fetching the source repository for package " ++ prettyShow pkgid ++ ". "
- ++ if isdir then "The destination directory " ++ dest ++ " already exists."
- else "A file " ++ dest ++ " is in the way."
-
- displayException (ClonePackageFailedWithExitCode
- pkgid repo vcsprogname exitcode) =
- "Failed to fetch the source repository for package " ++ prettyShow pkgid
- ++ ", repository location " ++ srpLocation repo ++ " ("
- ++ vcsprogname ++ " failed with " ++ show exitcode ++ ")."
-
+ "Not fetching the source repository for package "
+ ++ prettyShow pkgid
+ ++ ". "
+ ++ if isdir
+ then "The destination directory " ++ dest ++ " already exists."
+ else "A file " ++ dest ++ " is in the way."
+ displayException
+ ( ClonePackageFailedWithExitCode
+ pkgid
+ repo
+ vcsprogname
+ exitcode
+ ) =
+ "Failed to fetch the source repository for package "
+ ++ prettyShow pkgid
+ ++ ", repository location "
+ ++ srpLocation repo
+ ++ " ("
+ ++ vcsprogname
+ ++ " failed with "
+ ++ show exitcode
+ ++ ")."
-- | Given a bunch of package ids and their corresponding available
-- 'SourceRepo's, pick a single 'SourceRepo' for each one and clone into
-- new subdirs of the given directory.
---
-clonePackagesFromSourceRepo :: Verbosity
- -> FilePath -- ^ destination dir prefix
- -> Maybe RepoKind -- ^ preferred 'RepoKind'
- -> [(PackageId, [PD.SourceRepo])]
- -- ^ the packages and their
- -- available 'SourceRepo's
- -> IO ()
-clonePackagesFromSourceRepo verbosity destDirPrefix
- preferredRepoKind pkgrepos = do
-
+clonePackagesFromSourceRepo
+ :: Verbosity
+ -> FilePath
+ -- ^ destination dir prefix
+ -> Maybe RepoKind
+ -- ^ preferred 'RepoKind'
+ -> [(PackageId, [PD.SourceRepo])]
+ -- ^ the packages and their
+ -- available 'SourceRepo's
+ -> IO ()
+clonePackagesFromSourceRepo
+ verbosity
+ destDirPrefix
+ preferredRepoKind
+ pkgrepos = do
-- Do a bunch of checks and collect the required info
pkgrepos' <- traverse preCloneChecks pkgrepos
-- Configure the VCS drivers for all the repository types we may need
- vcss <- configureVCSs verbosity $
- Map.fromList [ (vcsRepoType vcs, vcs)
- | (_, _, vcs, _) <- pkgrepos' ]
+ vcss <-
+ configureVCSs verbosity $
+ Map.fromList
+ [ (vcsRepoType vcs, vcs)
+ | (_, _, vcs, _) <- pkgrepos'
+ ]
-- Now execute all the required commands for each repo
sequence_
[ cloneSourceRepo verbosity vcs' repo destDir
- `catch` \exitcode ->
- throwIO (ClonePackageFailedWithExitCode
- pkgid (srpToProxy repo) (programName (vcsProgram vcs)) exitcode)
+ `catch` \exitcode ->
+ throwIO
+ ( ClonePackageFailedWithExitCode
+ pkgid
+ (srpToProxy repo)
+ (programName (vcsProgram vcs))
+ exitcode
+ )
| (pkgid, repo, vcs, destDir) <- pkgrepos'
, let vcs' = Map.findWithDefault (error $ "Cannot configure " ++ prettyShow (vcsRepoType vcs)) (vcsRepoType vcs) vcss
]
-
- where
- preCloneChecks :: (PackageId, [PD.SourceRepo])
- -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
- preCloneChecks (pkgid, repos) = do
- repo <- case selectPackageSourceRepo preferredRepoKind repos of
- Just repo -> return repo
- Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)
- Nothing -> throwIO (ClonePackageNoSourceReposOfKind
- pkgid preferredRepoKind)
-
- (repo', vcs) <- case validatePDSourceRepo repo of
- Right (repo', _, _, vcs) -> return (repo', vcs)
- Left SourceRepoRepoTypeUnspecified ->
- throwIO (ClonePackageNoRepoType pkgid repo)
-
- Left (SourceRepoRepoTypeUnsupported repo' repoType) ->
- throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)
-
- Left SourceRepoLocationUnspecified ->
- throwIO (ClonePackageNoRepoLocation pkgid repo)
-
- let destDir :: FilePath
- destDir = destDirPrefix </> prettyShow (packageName pkgid)
- destDirExists <- doesDirectoryExist destDir
- destFileExists <- doesFileExist destDir
- when (destDirExists || destFileExists) $
- throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
-
- return (pkgid, repo', vcs, destDir)
+ where
+ preCloneChecks
+ :: (PackageId, [PD.SourceRepo])
+ -> IO (PackageId, SourceRepositoryPackage Maybe, VCS Program, FilePath)
+ preCloneChecks (pkgid, repos) = do
+ repo <- case selectPackageSourceRepo preferredRepoKind repos of
+ Just repo -> return repo
+ Nothing | null repos -> throwIO (ClonePackageNoSourceRepos pkgid)
+ Nothing ->
+ throwIO
+ ( ClonePackageNoSourceReposOfKind
+ pkgid
+ preferredRepoKind
+ )
+
+ (repo', vcs) <- case validatePDSourceRepo repo of
+ Right (repo', _, _, vcs) -> return (repo', vcs)
+ Left SourceRepoRepoTypeUnspecified ->
+ throwIO (ClonePackageNoRepoType pkgid repo)
+ Left (SourceRepoRepoTypeUnsupported repo' repoType) ->
+ throwIO (ClonePackageUnsupportedRepoType pkgid repo' repoType)
+ Left SourceRepoLocationUnspecified ->
+ throwIO (ClonePackageNoRepoLocation pkgid repo)
+
+ let destDir :: FilePath
+ destDir = destDirPrefix </> prettyShow (packageName pkgid)
+ destDirExists <- doesDirectoryExist destDir
+ destFileExists <- doesFileExist destDir
+ when (destDirExists || destFileExists) $
+ throwIO (ClonePackageDestinationExists pkgid destDir destDirExists)
+
+ return (pkgid, repo', vcs, destDir)
-------------------------------------------------------------------------------
-- Selecting
@@ -342,26 +413,26 @@ clonePackagesFromSourceRepo verbosity destDirPrefix
-- Note that this does /not/ depend on what 'VCS' drivers we are able to
-- successfully configure. It is based only on the 'SourceRepo's declared
-- in the package, and optionally on a preferred 'RepoKind'.
---
-selectPackageSourceRepo :: Maybe RepoKind
- -> [PD.SourceRepo]
- -> Maybe PD.SourceRepo
+selectPackageSourceRepo
+ :: Maybe RepoKind
+ -> [PD.SourceRepo]
+ -> Maybe PD.SourceRepo
selectPackageSourceRepo preferredRepoKind =
- listToMaybe
+ listToMaybe
-- Sort repositories by kind, from This to Head to Unknown. Repositories
-- with equivalent kinds are selected based on the order they appear in
-- the Cabal description file.
- . sortBy (comparing thisFirst)
+ . sortBy (comparing thisFirst)
-- If the user has specified the repo kind, filter out the repositories
-- they're not interested in.
- . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)
+ . filter (\repo -> maybe True (PD.repoKind repo ==) preferredRepoKind)
where
thisFirst :: PD.SourceRepo -> Int
thisFirst r = case PD.repoKind r of
- RepoThis -> 0
- RepoHead -> case PD.repoTag r of
- -- If the type is 'head' but the author specified a tag, they
- -- probably meant to create a 'this' repository but screwed up.
- Just _ -> 0
- Nothing -> 1
- RepoKindUnknown _ -> 2
+ RepoThis -> 0
+ RepoHead -> case PD.repoTag r of
+ -- If the type is 'head' but the author specified a tag, they
+ -- probably meant to create a 'this' repository but screwed up.
+ Just _ -> 0
+ Nothing -> 1
+ RepoKindUnknown _ -> 2
diff --git a/cabal-install/src/Distribution/Client/Glob.hs b/cabal-install/src/Distribution/Client/Glob.hs
index 5d3d501fbdbe1d3bf8e5e88208309c1b259c48d7..66baadf7a5d23c8d7487f362ccd4f0d2a1824700 100644
--- a/cabal-install/src/Distribution/Client/Glob.hs
+++ b/cabal-install/src/Distribution/Client/Glob.hs
@@ -1,55 +1,56 @@
{-# LANGUAGE DeriveGeneric #-}
---TODO: [code cleanup] plausibly much of this module should be merged with
+-- TODO: [code cleanup] plausibly much of this module should be merged with
-- similar functionality in Cabal.
module Distribution.Client.Glob
- ( FilePathGlob(..)
- , FilePathRoot(..)
- , FilePathGlobRel(..)
- , Glob
- , GlobPiece(..)
- , matchFileGlob
- , matchFileGlobRel
- , matchGlob
- , isTrivialFilePathGlob
- , getFilePathRootDirectory
- ) where
+ ( FilePathGlob (..)
+ , FilePathRoot (..)
+ , FilePathGlobRel (..)
+ , Glob
+ , GlobPiece (..)
+ , matchFileGlob
+ , matchFileGlobRel
+ , matchGlob
+ , isTrivialFilePathGlob
+ , getFilePathRootDirectory
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Data.List (stripPrefix)
+import Data.List (stripPrefix)
import System.Directory
import System.FilePath
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
-
+import qualified Text.PrettyPrint as Disp
-- | A file path specified by globbing
---
data FilePathGlob = FilePathGlob FilePathRoot FilePathGlobRel
deriving (Eq, Show, Generic)
data FilePathGlobRel
- = GlobDir !Glob !FilePathGlobRel
- | GlobFile !Glob
- | GlobDirTrailing -- ^ trailing dir, a glob ending in @/@
+ = GlobDir !Glob !FilePathGlobRel
+ | GlobFile !Glob
+ | -- | trailing dir, a glob ending in @/@
+ GlobDirTrailing
deriving (Eq, Show, Generic)
-- | A single directory or file component of a globbed path
type Glob = [GlobPiece]
-- | A piece of a globbing pattern
-data GlobPiece = WildCard
- | Literal String
- | Union [Glob]
+data GlobPiece
+ = WildCard
+ | Literal String
+ | Union [Glob]
deriving (Eq, Show, Generic)
data FilePathRoot
- = FilePathRelative
- | FilePathRoot FilePath -- ^ e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
- | FilePathHomeDir
+ = FilePathRelative
+ | -- | e.g. @"/"@, @"c:\"@ or result of 'takeDrive'
+ FilePathRoot FilePath
+ | FilePathHomeDir
deriving (Eq, Show, Generic)
instance Binary FilePathGlob
@@ -68,32 +69,34 @@ instance Structured GlobPiece
-- If it is trivial in this sense then the result is the equivalent constant
-- 'FilePath'. On the other hand if it is not trivial (so could in principle
-- match more than one file) then the result is @Nothing@.
---
isTrivialFilePathGlob :: FilePathGlob -> Maybe FilePath
isTrivialFilePathGlob (FilePathGlob root pathglob) =
- case root of
- FilePathRelative -> go [] pathglob
- FilePathRoot root' -> go [root'] pathglob
- FilePathHomeDir -> Nothing
+ case root of
+ FilePathRelative -> go [] pathglob
+ FilePathRoot root' -> go [root'] pathglob
+ FilePathHomeDir -> Nothing
where
- go paths (GlobDir [Literal path] globs) = go (path:paths) globs
- go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path:paths)))
- go paths GlobDirTrailing = Just (addTrailingPathSeparator
- (joinPath (reverse paths)))
+ go paths (GlobDir [Literal path] globs) = go (path : paths) globs
+ go paths (GlobFile [Literal path]) = Just (joinPath (reverse (path : paths)))
+ go paths GlobDirTrailing =
+ Just
+ ( addTrailingPathSeparator
+ (joinPath (reverse paths))
+ )
go _ _ = Nothing
-- | Get the 'FilePath' corresponding to a 'FilePathRoot'.
--
-- The 'FilePath' argument is required to supply the path for the
-- 'FilePathRelative' case.
---
-getFilePathRootDirectory :: FilePathRoot
- -> FilePath -- ^ root for relative paths
- -> IO FilePath
-getFilePathRootDirectory FilePathRelative root = return root
-getFilePathRootDirectory (FilePathRoot root) _ = return root
-getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
-
+getFilePathRootDirectory
+ :: FilePathRoot
+ -> FilePath
+ -- ^ root for relative paths
+ -> IO FilePath
+getFilePathRootDirectory FilePathRelative root = return root
+getFilePathRootDirectory (FilePathRoot root) _ = return root
+getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
------------------------------------------------------------------------------
-- Matching
@@ -102,18 +105,16 @@ getFilePathRootDirectory FilePathHomeDir _ = getHomeDirectory
-- | Match a 'FilePathGlob' against the file system, starting from a given
-- root directory for relative paths. The results of relative globs are
-- relative to the given root. Matches for absolute globs are absolute.
---
matchFileGlob :: FilePath -> FilePathGlob -> IO [FilePath]
matchFileGlob relroot (FilePathGlob globroot glob) = do
- root <- getFilePathRootDirectory globroot relroot
- matches <- matchFileGlobRel root glob
- case globroot of
- FilePathRelative -> return matches
- _ -> return (map (root </>) matches)
+ root <- getFilePathRootDirectory globroot relroot
+ matches <- matchFileGlobRel root glob
+ case globroot of
+ FilePathRelative -> return matches
+ _ -> return (map (root </>) matches)
-- | Match a 'FilePathGlobRel' against the file system, starting from a
-- given root directory. The results are all relative to the given root.
---
matchFileGlobRel :: FilePath -> FilePathGlobRel -> IO [FilePath]
matchFileGlobRel root glob0 = go glob0 ""
where
@@ -121,19 +122,19 @@ matchFileGlobRel root glob0 = go glob0 ""
entries <- getDirectoryContents (root </> dir)
let files = filter (matchGlob glob) entries
return (map (dir </>) files)
-
go (GlobDir glob globPath) dir = do
entries <- getDirectoryContents (root </> dir)
- subdirs <- filterM (\subdir -> doesDirectoryExist
- (root </> dir </> subdir))
- $ filter (matchGlob glob) entries
+ subdirs <-
+ filterM
+ ( \subdir ->
+ doesDirectoryExist
+ (root </> dir </> subdir)
+ )
+ $ filter (matchGlob glob) entries
concat <$> traverse (\subdir -> go globPath (dir </> subdir)) subdirs
-
go GlobDirTrailing dir = return [dir]
-
-- | Match a globbing pattern against a file path component
---
matchGlob :: Glob -> String -> Bool
matchGlob = goStart
where
@@ -143,22 +144,23 @@ matchGlob = goStart
go, goStart :: [GlobPiece] -> String -> Bool
- goStart (WildCard:_) ('.':_) = False
- goStart (Union globs:rest) cs = any (\glob -> goStart (glob ++ rest) cs)
- globs
- goStart rest cs = go rest cs
-
- go [] "" = True
- go (Literal lit:rest) cs
- | Just cs' <- stripPrefix lit cs
- = go rest cs'
- | otherwise = False
- go [WildCard] "" = True
- go (WildCard:rest) (c:cs) = go rest (c:cs) || go (WildCard:rest) cs
- go (Union globs:rest) cs = any (\glob -> go (glob ++ rest) cs) globs
- go [] (_:_) = False
- go (_:_) "" = False
-
+ goStart (WildCard : _) ('.' : _) = False
+ goStart (Union globs : rest) cs =
+ any
+ (\glob -> goStart (glob ++ rest) cs)
+ globs
+ goStart rest cs = go rest cs
+
+ go [] "" = True
+ go (Literal lit : rest) cs
+ | Just cs' <- stripPrefix lit cs =
+ go rest cs'
+ | otherwise = False
+ go [WildCard] "" = True
+ go (WildCard : rest) (c : cs) = go rest (c : cs) || go (WildCard : rest) cs
+ go (Union globs : rest) cs = any (\glob -> go (glob ++ rest) cs) globs
+ go [] (_ : _) = False
+ go (_ : _) "" = False
------------------------------------------------------------------------------
-- Parsing & printing
@@ -168,77 +170,89 @@ instance Pretty FilePathGlob where
pretty (FilePathGlob root pathglob) = pretty root Disp.<> pretty pathglob
instance Parsec FilePathGlob where
- parsec = do
- root <- parsec
- case root of
- FilePathRelative -> FilePathGlob root <$> parsec
- _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)
+ parsec = do
+ root <- parsec
+ case root of
+ FilePathRelative -> FilePathGlob root <$> parsec
+ _ -> FilePathGlob root <$> parsec <|> pure (FilePathGlob root GlobDirTrailing)
instance Pretty FilePathRoot where
- pretty FilePathRelative = Disp.empty
- pretty (FilePathRoot root) = Disp.text root
- pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'
+ pretty FilePathRelative = Disp.empty
+ pretty (FilePathRoot root) = Disp.text root
+ pretty FilePathHomeDir = Disp.char '~' Disp.<> Disp.char '/'
instance Parsec FilePathRoot where
- parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative where
- root = FilePathRoot "/" <$ P.char '/'
- home = FilePathHomeDir <$ P.string "~/"
- drive = do
- dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
- _ <- P.char ':'
- _ <- P.char '/' <|> P.char '\\'
- return (FilePathRoot (toUpper dr : ":\\"))
+ parsec = root <|> P.try home <|> P.try drive <|> pure FilePathRelative
+ where
+ root = FilePathRoot "/" <$ P.char '/'
+ home = FilePathHomeDir <$ P.string "~/"
+ drive = do
+ dr <- P.satisfy $ \c -> (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')
+ _ <- P.char ':'
+ _ <- P.char '/' <|> P.char '\\'
+ return (FilePathRoot (toUpper dr : ":\\"))
instance Pretty FilePathGlobRel where
- pretty (GlobDir glob pathglob) = dispGlob glob
- Disp.<> Disp.char '/'
- Disp.<> pretty pathglob
- pretty (GlobFile glob) = dispGlob glob
- pretty GlobDirTrailing = Disp.empty
+ pretty (GlobDir glob pathglob) =
+ dispGlob glob
+ Disp.<> Disp.char '/'
+ Disp.<> pretty pathglob
+ pretty (GlobFile glob) = dispGlob glob
+ pretty GlobDirTrailing = Disp.empty
instance Parsec FilePathGlobRel where
- parsec = parsecPath where
- parsecPath :: CabalParsing m => m FilePathGlobRel
- parsecPath = do
- glob <- parsecGlob
- dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
-
- dirSep :: CabalParsing m => m ()
- dirSep = () <$ P.char '/' <|> P.try (do
- _ <- P.char '\\'
- -- check this isn't an escape code
- P.notFollowedBy (P.satisfy isGlobEscapedChar))
+ parsec = parsecPath
+ where
+ parsecPath :: CabalParsing m => m FilePathGlobRel
+ parsecPath = do
+ glob <- parsecGlob
+ dirSep *> (GlobDir glob <$> parsecPath <|> pure (GlobDir glob GlobDirTrailing)) <|> pure (GlobFile glob)
+
+ dirSep :: CabalParsing m => m ()
+ dirSep =
+ () <$ P.char '/'
+ <|> P.try
+ ( do
+ _ <- P.char '\\'
+ -- check this isn't an escape code
+ P.notFollowedBy (P.satisfy isGlobEscapedChar)
+ )
dispGlob :: Glob -> Disp.Doc
dispGlob = Disp.hcat . map dispPiece
where
- dispPiece WildCard = Disp.char '*'
+ dispPiece WildCard = Disp.char '*'
dispPiece (Literal str) = Disp.text (escape str)
- dispPiece (Union globs) = Disp.braces
- (Disp.hcat (Disp.punctuate
- (Disp.char ',')
- (map dispGlob globs)))
- escape [] = []
- escape (c:cs)
+ dispPiece (Union globs) =
+ Disp.braces
+ ( Disp.hcat
+ ( Disp.punctuate
+ (Disp.char ',')
+ (map dispGlob globs)
+ )
+ )
+ escape [] = []
+ escape (c : cs)
| isGlobEscapedChar c = '\\' : c : escape cs
- | otherwise = c : escape cs
+ | otherwise = c : escape cs
parsecGlob :: CabalParsing m => m Glob
-parsecGlob = some parsecPiece where
- parsecPiece = P.choice [ literal, wildcard, union ]
+parsecGlob = some parsecPiece
+ where
+ parsecPiece = P.choice [literal, wildcard, union]
wildcard = WildCard <$ P.char '*'
- union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
- literal = Literal <$> some litchar
+ union = Union . toList <$> P.between (P.char '{') (P.char '}') (P.sepByNonEmpty parsecGlob (P.char ','))
+ literal = Literal <$> some litchar
litchar = normal <|> escape
- normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
- escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
+ normal = P.satisfy (\c -> not (isGlobEscapedChar c) && c /= '/' && c /= '\\')
+ escape = P.try $ P.char '\\' >> P.satisfy isGlobEscapedChar
isGlobEscapedChar :: Char -> Bool
-isGlobEscapedChar '*' = True
-isGlobEscapedChar '{' = True
-isGlobEscapedChar '}' = True
-isGlobEscapedChar ',' = True
-isGlobEscapedChar _ = False
+isGlobEscapedChar '*' = True
+isGlobEscapedChar '{' = True
+isGlobEscapedChar '}' = True
+isGlobEscapedChar ',' = True
+isGlobEscapedChar _ = False
diff --git a/cabal-install/src/Distribution/Client/GlobalFlags.hs b/cabal-install/src/Distribution/Client/GlobalFlags.hs
index d21b071479a39ca2ea5a0fef9014c4e2d6a29290..6b41a79b5ef272a8e2c8c33f272f5d566ef360f4 100644
--- a/cabal-install/src/Distribution/Client/GlobalFlags.hs
+++ b/cabal-install/src/Distribution/Client/GlobalFlags.hs
@@ -2,132 +2,161 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Client.GlobalFlags (
- GlobalFlags(..)
+module Distribution.Client.GlobalFlags
+ ( GlobalFlags (..)
, defaultGlobalFlags
- , RepoContext(..)
+ , RepoContext (..)
, withRepoContext
, withRepoContext'
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
+import Distribution.Client.HttpUtils
+ ( HttpTransport
+ , configureTransport
+ )
import Distribution.Client.Types
- ( Repo(..), unRepoName, RemoteRepo(..), LocalRepo (..), localRepoCacheKey )
+ ( LocalRepo (..)
+ , RemoteRepo (..)
+ , Repo (..)
+ , localRepoCacheKey
+ , unRepoName
+ )
import Distribution.Simple.Setup
- ( Flag(..), fromFlag, flagToMaybe )
-import Distribution.Utils.NubList
- ( NubList, fromNubList )
-import Distribution.Client.HttpUtils
- ( HttpTransport, configureTransport )
+ ( Flag (..)
+ , flagToMaybe
+ , fromFlag
+ )
import Distribution.Simple.Utils
- ( info, warn )
+ ( info
+ , warn
+ )
+import Distribution.Utils.NubList
+ ( NubList
+ , fromNubList
+ )
import Distribution.Client.IndexUtils.ActiveRepos
- ( ActiveRepos )
+ ( ActiveRepos
+ )
import Control.Concurrent
- ( MVar, newMVar, modifyMVar )
-import System.FilePath
- ( (</>) )
-import Network.URI
- ( URI, uriScheme, uriPath )
+ ( MVar
+ , modifyMVar
+ , newMVar
+ )
import qualified Data.Map as Map
-
-import qualified Hackage.Security.Client as Sec
-import qualified Hackage.Security.Util.Path as Sec
-import qualified Hackage.Security.Util.Pretty as Sec
-import qualified Hackage.Security.Client.Repository.Cache as Sec
-import qualified Hackage.Security.Client.Repository.Local as Sec.Local
-import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote
-import qualified Distribution.Client.Security.HTTP as Sec.HTTP
-import qualified Distribution.Client.Security.DNS as Sec.DNS
+import Network.URI
+ ( URI
+ , uriPath
+ , uriScheme
+ )
+import System.FilePath
+ ( (</>)
+ )
+
+import qualified Distribution.Client.Security.DNS as Sec.DNS
+import qualified Distribution.Client.Security.HTTP as Sec.HTTP
+import qualified Hackage.Security.Client as Sec
+import qualified Hackage.Security.Client.Repository.Cache as Sec
+import qualified Hackage.Security.Client.Repository.Local as Sec.Local
+import qualified Hackage.Security.Client.Repository.Remote as Sec.Remote
+import qualified Hackage.Security.Util.Path as Sec
+import qualified Hackage.Security.Util.Pretty as Sec
import qualified System.FilePath.Posix as FilePath.Posix
-- ------------------------------------------------------------
+
-- * Global flags
+
-- ------------------------------------------------------------
-- | Flags that apply at the top level, not to any sub-command.
-
data GlobalFlags = GlobalFlags
- { globalVersion :: Flag Bool
- , globalNumericVersion :: Flag Bool
- , globalConfigFile :: Flag FilePath
- , globalConstraintsFile :: Flag FilePath
- , globalRemoteRepos :: NubList RemoteRepo -- ^ Available Hackage servers.
- , globalCacheDir :: Flag FilePath
- , globalLocalNoIndexRepos :: NubList LocalRepo
- , globalActiveRepos :: Flag ActiveRepos
- , globalLogsDir :: Flag FilePath
- , globalIgnoreExpiry :: Flag Bool -- ^ Ignore security expiry dates
- , globalHttpTransport :: Flag String
- , globalNix :: Flag Bool -- ^ Integrate with Nix
- , globalStoreDir :: Flag FilePath
- , globalProgPathExtra :: NubList FilePath -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
- } deriving (Show, Generic)
+ { globalVersion :: Flag Bool
+ , globalNumericVersion :: Flag Bool
+ , globalConfigFile :: Flag FilePath
+ , globalConstraintsFile :: Flag FilePath
+ , globalRemoteRepos :: NubList RemoteRepo
+ -- ^ Available Hackage servers.
+ , globalCacheDir :: Flag FilePath
+ , globalLocalNoIndexRepos :: NubList LocalRepo
+ , globalActiveRepos :: Flag ActiveRepos
+ , globalLogsDir :: Flag FilePath
+ , globalIgnoreExpiry :: Flag Bool
+ -- ^ Ignore security expiry dates
+ , globalHttpTransport :: Flag String
+ , globalNix :: Flag Bool
+ -- ^ Integrate with Nix
+ , globalStoreDir :: Flag FilePath
+ , globalProgPathExtra :: NubList FilePath
+ -- ^ Extra program path used for packagedb lookups in a global context (i.e. for http transports)
+ }
+ deriving (Show, Generic)
defaultGlobalFlags :: GlobalFlags
-defaultGlobalFlags = GlobalFlags
- { globalVersion = Flag False
- , globalNumericVersion = Flag False
- , globalConfigFile = mempty
- , globalConstraintsFile = mempty
- , globalRemoteRepos = mempty
- , globalCacheDir = mempty
+defaultGlobalFlags =
+ GlobalFlags
+ { globalVersion = Flag False
+ , globalNumericVersion = Flag False
+ , globalConfigFile = mempty
+ , globalConstraintsFile = mempty
+ , globalRemoteRepos = mempty
+ , globalCacheDir = mempty
, globalLocalNoIndexRepos = mempty
- , globalActiveRepos = mempty
- , globalLogsDir = mempty
- , globalIgnoreExpiry = Flag False
- , globalHttpTransport = mempty
- , globalNix = Flag False
- , globalStoreDir = mempty
- , globalProgPathExtra = mempty
+ , globalActiveRepos = mempty
+ , globalLogsDir = mempty
+ , globalIgnoreExpiry = Flag False
+ , globalHttpTransport = mempty
+ , globalNix = Flag False
+ , globalStoreDir = mempty
+ , globalProgPathExtra = mempty
}
instance Monoid GlobalFlags where
- mempty = gmempty
- mappend = (<>)
+ mempty = gmempty
+ mappend = (<>)
instance Semigroup GlobalFlags where
- (<>) = gmappend
+ (<>) = gmappend
-- ------------------------------------------------------------
+
-- * Repo context
+
-- ------------------------------------------------------------
-- | Access to repositories
-data RepoContext = RepoContext {
- -- | All user-specified repositories
- repoContextRepos :: [Repo]
-
- -- | Get the HTTP transport
- --
- -- The transport will be initialized on the first call to this function.
- --
- -- NOTE: It is important that we don't eagerly initialize the transport.
- -- Initializing the transport is not free, and especially in contexts where
- -- we don't know a priori whether or not we need the transport (for instance
- -- when using cabal in "nix mode") incurring the overhead of transport
- -- initialization on _every_ invocation (eg @cabal build@) is undesirable.
+data RepoContext = RepoContext
+ { repoContextRepos :: [Repo]
+ -- ^ All user-specified repositories
, repoContextGetTransport :: IO HttpTransport
-
- -- | Get the (initialized) secure repo
- --
- -- (the 'Repo' type itself is stateless and must remain so, because it
- -- must be serializable)
- , repoContextWithSecureRepo :: forall a.
- Repo
- -> (forall down. Sec.Repository down -> IO a)
- -> IO a
-
- -- | Should we ignore expiry times (when checking security)?
+ -- ^ Get the HTTP transport
+ --
+ -- The transport will be initialized on the first call to this function.
+ --
+ -- NOTE: It is important that we don't eagerly initialize the transport.
+ -- Initializing the transport is not free, and especially in contexts where
+ -- we don't know a priori whether or not we need the transport (for instance
+ -- when using cabal in "nix mode") incurring the overhead of transport
+ -- initialization on _every_ invocation (eg @cabal build@) is undesirable.
+ , repoContextWithSecureRepo
+ :: forall a
+ . Repo
+ -> (forall down. Sec.Repository down -> IO a)
+ -> IO a
+ -- ^ Get the (initialized) secure repo
+ --
+ -- (the 'Repo' type itself is stateless and must remain so, because it
+ -- must be serializable)
, repoContextIgnoreExpiry :: Bool
+ -- ^ Should we ignore expiry times (when checking security)?
}
-- | Wrapper around 'Repository', hiding the type argument
@@ -135,88 +164,107 @@ data SecureRepo = forall down. SecureRepo (Sec.Repository down)
withRepoContext :: Verbosity -> GlobalFlags -> (RepoContext -> IO a) -> IO a
withRepoContext verbosity globalFlags =
- withRepoContext'
- verbosity
- (fromNubList (globalRemoteRepos globalFlags))
- (fromNubList (globalLocalNoIndexRepos globalFlags))
- (fromFlag (globalCacheDir globalFlags))
- (flagToMaybe (globalHttpTransport globalFlags))
- (flagToMaybe (globalIgnoreExpiry globalFlags))
- (fromNubList (globalProgPathExtra globalFlags))
-
-withRepoContext' :: Verbosity -> [RemoteRepo] -> [LocalRepo]
- -> FilePath -> Maybe String -> Maybe Bool
- -> [FilePath]
- -> (RepoContext -> IO a)
- -> IO a
-withRepoContext' verbosity remoteRepos localNoIndexRepos
- sharedCacheDir httpTransport ignoreExpiry extraPaths = \callback -> do
+ withRepoContext'
+ verbosity
+ (fromNubList (globalRemoteRepos globalFlags))
+ (fromNubList (globalLocalNoIndexRepos globalFlags))
+ (fromFlag (globalCacheDir globalFlags))
+ (flagToMaybe (globalHttpTransport globalFlags))
+ (flagToMaybe (globalIgnoreExpiry globalFlags))
+ (fromNubList (globalProgPathExtra globalFlags))
+
+withRepoContext'
+ :: Verbosity
+ -> [RemoteRepo]
+ -> [LocalRepo]
+ -> FilePath
+ -> Maybe String
+ -> Maybe Bool
+ -> [FilePath]
+ -> (RepoContext -> IO a)
+ -> IO a
+withRepoContext'
+ verbosity
+ remoteRepos
+ localNoIndexRepos
+ sharedCacheDir
+ httpTransport
+ ignoreExpiry
+ extraPaths = \callback -> do
for_ localNoIndexRepos $ \local ->
- unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
- warn verbosity $ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"
+ unless (FilePath.Posix.isAbsolute (localRepoPath local)) $
+ warn verbosity $
+ "file+noindex " ++ unRepoName (localRepoName local) ++ " repository path is not absolute; this is fragile, and not recommended"
transportRef <- newMVar Nothing
- let httpLib = Sec.HTTP.transportAdapter
- verbosity
- (getTransport transportRef)
+ let httpLib =
+ Sec.HTTP.transportAdapter
+ verbosity
+ (getTransport transportRef)
initSecureRepos verbosity httpLib secureRemoteRepos $ \secureRepos' ->
- callback RepoContext {
- repoContextRepos = allRemoteRepos
- ++ allLocalNoIndexRepos
- , repoContextGetTransport = getTransport transportRef
- , repoContextWithSecureRepo = withSecureRepo secureRepos'
- , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry
- }
- where
- secureRemoteRepos =
- [ (remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos ]
-
- allRemoteRepos :: [Repo]
- allRemoteRepos =
- [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir
- | remote <- remoteRepos
- , let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)
- isSecure = remoteRepoSecure remote == Just True
- ]
-
- allLocalNoIndexRepos :: [Repo]
- allLocalNoIndexRepos =
- [ RepoLocalNoIndex local cacheDir
- | local <- localNoIndexRepos
- , let cacheDir | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local
- | otherwise = localRepoPath local
- ]
-
- getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
- getTransport transportRef =
- modifyMVar transportRef $ \mTransport -> do
- transport <- case mTransport of
- Just tr -> return tr
- Nothing -> configureTransport verbosity extraPaths httpTransport
- return (Just transport, transport)
-
- withSecureRepo :: Map Repo SecureRepo
- -> Repo
- -> (forall down. Sec.Repository down -> IO a)
- -> IO a
- withSecureRepo secureRepos repo callback =
- case Map.lookup repo secureRepos of
- Just (SecureRepo secureRepo) -> callback secureRepo
- Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"
+ callback
+ RepoContext
+ { repoContextRepos =
+ allRemoteRepos
+ ++ allLocalNoIndexRepos
+ , repoContextGetTransport = getTransport transportRef
+ , repoContextWithSecureRepo = withSecureRepo secureRepos'
+ , repoContextIgnoreExpiry = fromMaybe False ignoreExpiry
+ }
+ where
+ secureRemoteRepos =
+ [(remote, cacheDir) | RepoSecure remote cacheDir <- allRemoteRepos]
+
+ allRemoteRepos :: [Repo]
+ allRemoteRepos =
+ [ (if isSecure then RepoSecure else RepoRemote) remote cacheDir
+ | remote <- remoteRepos
+ , let cacheDir = sharedCacheDir </> unRepoName (remoteRepoName remote)
+ isSecure = remoteRepoSecure remote == Just True
+ ]
+
+ allLocalNoIndexRepos :: [Repo]
+ allLocalNoIndexRepos =
+ [ RepoLocalNoIndex local cacheDir
+ | local <- localNoIndexRepos
+ , let cacheDir
+ | localRepoSharedCache local = sharedCacheDir </> localRepoCacheKey local
+ | otherwise = localRepoPath local
+ ]
+
+ getTransport :: MVar (Maybe HttpTransport) -> IO HttpTransport
+ getTransport transportRef =
+ modifyMVar transportRef $ \mTransport -> do
+ transport <- case mTransport of
+ Just tr -> return tr
+ Nothing -> configureTransport verbosity extraPaths httpTransport
+ return (Just transport, transport)
+
+ withSecureRepo
+ :: Map Repo SecureRepo
+ -> Repo
+ -> (forall down. Sec.Repository down -> IO a)
+ -> IO a
+ withSecureRepo secureRepos repo callback =
+ case Map.lookup repo secureRepos of
+ Just (SecureRepo secureRepo) -> callback secureRepo
+ Nothing -> throwIO $ userError "repoContextWithSecureRepo: unknown repo"
-- | Initialize the provided secure repositories
--
-- Assumed invariant: `remoteRepoSecure` should be set for all these repos.
-initSecureRepos :: forall a. Verbosity
- -> Sec.HTTP.HttpLib
- -> [(RemoteRepo, FilePath)]
- -> (Map Repo SecureRepo -> IO a)
- -> IO a
+initSecureRepos
+ :: forall a
+ . Verbosity
+ -> Sec.HTTP.HttpLib
+ -> [(RemoteRepo, FilePath)]
+ -> (Map Repo SecureRepo -> IO a)
+ -> IO a
initSecureRepos verbosity httpLib repos callback = go Map.empty repos
where
go :: Map Repo SecureRepo -> [(RemoteRepo, FilePath)] -> IO a
go !acc [] = callback acc
- go !acc ((r,cacheDir):rs) = do
+ go !acc ((r, cacheDir) : rs) = do
cachePath <- Sec.makeAbsolute $ Sec.fromFilePath cacheDir
initSecureRepo verbosity httpLib r cachePath $ \r' ->
go (Map.insert (RepoSecure r cacheDir) r' acc) rs
@@ -227,61 +275,74 @@ initSecureRepos verbosity httpLib repos callback = go Map.empty repos
-- from @cabal-install@'s; these are secure repositories, but live in the local
-- file system. We use the convention that these repositories are identified by
-- URLs of the form @file:/path/to/local/repo@.
-initSecureRepo :: Verbosity
- -> Sec.HTTP.HttpLib
- -> RemoteRepo -- ^ Secure repo ('remoteRepoSecure' assumed)
- -> Sec.Path Sec.Absolute -- ^ Cache dir
- -> (SecureRepo -> IO a) -- ^ Callback
- -> IO a
+initSecureRepo
+ :: Verbosity
+ -> Sec.HTTP.HttpLib
+ -> RemoteRepo
+ -- ^ Secure repo ('remoteRepoSecure' assumed)
+ -> Sec.Path Sec.Absolute
+ -- ^ Cache dir
+ -> (SecureRepo -> IO a)
+ -- ^ Callback
+ -> IO a
initSecureRepo verbosity httpLib RemoteRepo{..} cachePath = \callback -> do
- requiresBootstrap <- withRepo [] Sec.requiresBootstrap
-
- mirrors <- if requiresBootstrap
- then do
- info verbosity $ "Trying to locate mirrors via DNS for " ++
- "initial bootstrap of secure " ++
- "repository '" ++ show remoteRepoURI ++
- "' ..."
-
- Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI
- else pure []
-
- withRepo mirrors $ \r -> do
- when requiresBootstrap $ Sec.uncheckClientErrors $
- Sec.bootstrap r
- (map Sec.KeyId remoteRepoRootKeys)
+ requiresBootstrap <- withRepo [] Sec.requiresBootstrap
+
+ mirrors <-
+ if requiresBootstrap
+ then do
+ info verbosity $
+ "Trying to locate mirrors via DNS for "
+ ++ "initial bootstrap of secure "
+ ++ "repository '"
+ ++ show remoteRepoURI
+ ++ "' ..."
+
+ Sec.DNS.queryBootstrapMirrors verbosity remoteRepoURI
+ else pure []
+
+ withRepo mirrors $ \r -> do
+ when requiresBootstrap $
+ Sec.uncheckClientErrors $
+ Sec.bootstrap
+ r
+ (map Sec.KeyId remoteRepoRootKeys)
(Sec.KeyThreshold (fromIntegral remoteRepoKeyThreshold))
- callback $ SecureRepo r
+ callback $ SecureRepo r
where
-- Initialize local or remote repo depending on the URI
withRepo :: [URI] -> (forall down. Sec.Repository down -> IO a) -> IO a
withRepo _ callback | uriScheme remoteRepoURI == "file:" = do
dir <- Sec.makeAbsolute $ Sec.fromFilePath (uriPath remoteRepoURI)
- Sec.Local.withRepository dir
- cache
- Sec.hackageRepoLayout
- Sec.hackageIndexLayout
- logTUF
- callback
+ Sec.Local.withRepository
+ dir
+ cache
+ Sec.hackageRepoLayout
+ Sec.hackageIndexLayout
+ logTUF
+ callback
withRepo mirrors callback =
- Sec.Remote.withRepository httpLib
- (remoteRepoURI:mirrors)
- Sec.Remote.defaultRepoOpts
- cache
- Sec.hackageRepoLayout
- Sec.hackageIndexLayout
- logTUF
- callback
+ Sec.Remote.withRepository
+ httpLib
+ (remoteRepoURI : mirrors)
+ Sec.Remote.defaultRepoOpts
+ cache
+ Sec.hackageRepoLayout
+ Sec.hackageIndexLayout
+ logTUF
+ callback
cache :: Sec.Cache
- cache = Sec.Cache {
- cacheRoot = cachePath
- , cacheLayout = Sec.cabalCacheLayout {
- Sec.cacheLayoutIndexTar = cacheFn "01-index.tar"
- , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx"
- , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz"
- }
- }
+ cache =
+ Sec.Cache
+ { cacheRoot = cachePath
+ , cacheLayout =
+ Sec.cabalCacheLayout
+ { Sec.cacheLayoutIndexTar = cacheFn "01-index.tar"
+ , Sec.cacheLayoutIndexIdx = cacheFn "01-index.tar.idx"
+ , Sec.cacheLayoutIndexTarGz = cacheFn "01-index.tar.gz"
+ }
+ }
cacheFn :: FilePath -> Sec.CachePath
cacheFn = Sec.rootPath . Sec.fragment
diff --git a/cabal-install/src/Distribution/Client/Haddock.hs b/cabal-install/src/Distribution/Client/Haddock.hs
index 862a1e6f85a2537b53e754fb0e905ab2514a3935..058b24f65379eb9c692c82515932f3523307861a 100644
--- a/cabal-install/src/Distribution/Client/Haddock.hs
+++ b/cabal-install/src/Distribution/Client/Haddock.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Haddock
-- Copyright : (c) Andrea Vezzosi 2009
@@ -8,64 +11,80 @@
-- Portability : portable
--
-- Interfacing with Haddock
---
------------------------------------------------------------------------------
module Distribution.Client.Haddock
- (
- regenerateHaddockIndex
- )
- where
+ ( regenerateHaddockIndex
+ )
+where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Data.List (maximumBy)
-import System.Directory (createDirectoryIfMissing, renameFile)
-import System.FilePath ((</>), splitFileName)
+import Distribution.InstalledPackageInfo as InstalledPackageInfo
+ ( InstalledPackageInfo (exposed)
+ )
import Distribution.Package
- ( packageVersion )
+ ( packageVersion
+ )
import Distribution.Simple.Haddock (haddockPackagePaths)
-import Distribution.Simple.Program (haddockProgram, ProgramDb
- , runProgram, requireProgramVersion)
-import Distribution.Version (mkVersion, orLaterVersion)
import Distribution.Simple.PackageIndex
- ( InstalledPackageIndex, allPackagesByName )
+ ( InstalledPackageIndex
+ , allPackagesByName
+ )
+import Distribution.Simple.Program
+ ( ProgramDb
+ , haddockProgram
+ , requireProgramVersion
+ , runProgram
+ )
import Distribution.Simple.Utils
- ( debug, installDirectoryContents, withTempDirectory )
-import Distribution.InstalledPackageInfo as InstalledPackageInfo
- ( InstalledPackageInfo(exposed) )
+ ( debug
+ , installDirectoryContents
+ , withTempDirectory
+ )
+import Distribution.Version (mkVersion, orLaterVersion)
+import System.Directory (createDirectoryIfMissing, renameFile)
+import System.FilePath (splitFileName, (</>))
-regenerateHaddockIndex :: Verbosity
- -> InstalledPackageIndex -> ProgramDb
- -> FilePath
- -> IO ()
+regenerateHaddockIndex
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> ProgramDb
+ -> FilePath
+ -> IO ()
regenerateHaddockIndex verbosity pkgs progdb index = do
- (paths, warns) <- haddockPackagePaths pkgs' Nothing
- let paths' = [ (interface, html) | (interface, Just html, _, _) <- paths]
- for_ warns (debug verbosity)
-
- (confHaddock, _, _) <-
- requireProgramVersion verbosity haddockProgram
- (orLaterVersion (mkVersion [0,6])) progdb
-
- createDirectoryIfMissing True destDir
+ (paths, warns) <- haddockPackagePaths pkgs' Nothing
+ let paths' = [(interface, html) | (interface, Just html, _, _) <- paths]
+ for_ warns (debug verbosity)
- withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do
+ (confHaddock, _, _) <-
+ requireProgramVersion
+ verbosity
+ haddockProgram
+ (orLaterVersion (mkVersion [0, 6]))
+ progdb
- let flags = [ "--gen-contents"
- , "--gen-index"
- , "--odir=" ++ tempDir
- , "--title=Haskell modules on this system" ]
- ++ [ "--read-interface=" ++ html ++ "," ++ interface
- | (interface, html) <- paths' ]
- runProgram verbosity confHaddock flags
- renameFile (tempDir </> "index.html") (tempDir </> destFile)
- installDirectoryContents verbosity tempDir destDir
+ createDirectoryIfMissing True destDir
+ withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do
+ let flags =
+ [ "--gen-contents"
+ , "--gen-index"
+ , "--odir=" ++ tempDir
+ , "--title=Haskell modules on this system"
+ ]
+ ++ [ "--read-interface=" ++ html ++ "," ++ interface
+ | (interface, html) <- paths'
+ ]
+ runProgram verbosity confHaddock flags
+ renameFile (tempDir </> "index.html") (tempDir </> destFile)
+ installDirectoryContents verbosity tempDir destDir
where
- (destDir,destFile) = splitFileName index
+ (destDir, destFile) = splitFileName index
pkgs' :: [InstalledPackageInfo]
- pkgs' = [ maximumBy (comparing packageVersion) pkgvers'
- | (_pname, pkgvers) <- allPackagesByName pkgs
- , let pkgvers' = filter exposed pkgvers
- , not (null pkgvers') ]
+ pkgs' =
+ [ maximumBy (comparing packageVersion) pkgvers'
+ | (_pname, pkgvers) <- allPackagesByName pkgs
+ , let pkgvers' = filter exposed pkgvers
+ , not (null pkgvers')
+ ]
diff --git a/cabal-install/src/Distribution/Client/HashValue.hs b/cabal-install/src/Distribution/Client/HashValue.hs
index 67117b231cce50f026b23e94d0bc293c6206f464..e19956b7ed395e2322f3509f88bb41170a17a9b3 100644
--- a/cabal-install/src/Distribution/Client/HashValue.hs
+++ b/cabal-install/src/Distribution/Client/HashValue.hs
@@ -1,26 +1,27 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.HashValue (
- HashValue,
- hashValue,
- truncateHash,
- showHashValue,
- readFileHashValue,
- hashFromTUF,
- ) where
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Client.HashValue
+ ( HashValue
+ , hashValue
+ , truncateHash
+ , showHashValue
+ , readFileHashValue
+ , hashFromTUF
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Hackage.Security.Client as Sec
-import qualified Crypto.Hash.SHA256 as SHA256
-import qualified Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Char8 as BS
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
-import System.IO (IOMode (..), withBinaryFile)
+import System.IO (IOMode (..), withBinaryFile)
-----------------------------------------------
-- The specific choice of hash implementation
@@ -48,7 +49,6 @@ instance Binary HashValue
instance Structured HashValue
-- | Hash some data. Currently uses SHA256.
---
hashValue :: LBS.ByteString -> HashValue
hashValue = HashValue . SHA256.hashlazy
@@ -56,22 +56,21 @@ showHashValue :: HashValue -> String
showHashValue (HashValue digest) = BS.unpack (Base16.encode digest)
-- | Hash the content of a file. Uses SHA256.
---
readFileHashValue :: FilePath -> IO HashValue
readFileHashValue tarball =
- withBinaryFile tarball ReadMode $ \hnd ->
- evaluate . hashValue =<< LBS.hGetContents hnd
+ withBinaryFile tarball ReadMode $ \hnd ->
+ evaluate . hashValue =<< LBS.hGetContents hnd
-- | Convert a hash from TUF metadata into a 'PackageSourceHash'.
--
-- Note that TUF hashes don't necessarily have to be SHA256, since it can
-- support new algorithms in future.
---
+{- FOURMOLU_DISABLE -}
hashFromTUF :: Sec.Hash -> HashValue
hashFromTUF (Sec.Hash hashstr) =
- --TODO: [code cleanup] either we should get TUF to use raw bytestrings or
- -- perhaps we should also just use a base16 string as the internal rep.
- case Base16.decode (BS.pack hashstr) of
+ -- TODO: [code cleanup] either we should get TUF to use raw bytestrings or
+ -- perhaps we should also just use a base16 string as the internal rep.
+ case Base16.decode (BS.pack hashstr) of
#if MIN_VERSION_base16_bytestring(1,0,0)
Right hash -> HashValue hash
Left _ -> error "hashFromTUF: cannot decode base16"
@@ -80,11 +79,11 @@ hashFromTUF (Sec.Hash hashstr) =
-> HashValue hash
_ -> error "hashFromTUF: cannot decode base16 hash"
#endif
+{- FOURMOLU_ENABLE -}
-- | Truncate a 32 byte SHA256 hash to
--
-- For example 20 bytes render as 40 hex chars, which we use for unit-ids.
-- Or even 4 bytes for 'hashedInstalledPackageIdShort'
---
truncateHash :: Int -> HashValue -> HashValue
truncateHash n (HashValue h) = HashValue (BS.take n h)
diff --git a/cabal-install/src/Distribution/Client/HttpUtils.hs b/cabal-install/src/Distribution/Client/HttpUtils.hs
index 54c88d97ea5080f239a20bac15e4e6e2f9fe0e93..3d27882097b25da772356cbd9578f8a957abee5b 100644
--- a/cabal-install/src/Distribution/Client/HttpUtils.hs
+++ b/cabal-install/src/Distribution/Client/HttpUtils.hs
@@ -1,150 +1,206 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
+
-----------------------------------------------------------------------------
--- | Separate module for HTTP actions, using a proxy server if one exists.
+
-----------------------------------------------------------------------------
-module Distribution.Client.HttpUtils (
- DownloadResult(..),
- configureTransport,
- HttpTransport(..),
- HttpCode,
- downloadURI,
- transportCheckHttps,
- remoteRepoCheckHttps,
- remoteRepoTryUpgradeToHttps,
- isOldHackageURI
+
+-- | Separate module for HTTP actions, using a proxy server if one exists.
+module Distribution.Client.HttpUtils
+ ( DownloadResult (..)
+ , configureTransport
+ , HttpTransport (..)
+ , HttpCode
+ , downloadURI
+ , transportCheckHttps
+ , remoteRepoCheckHttps
+ , remoteRepoTryUpgradeToHttps
+ , isOldHackageURI
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude hiding (Proxy (..))
import Distribution.Utils.Generic
+import Prelude ()
-import Network.HTTP
- ( Request (..), Response (..), RequestMethod (..)
- , Header(..), HeaderName(..), lookupHeader )
-import Network.HTTP.Proxy ( Proxy(..), fetchProxy)
-import Network.URI
- ( URI (..), URIAuth (..), uriToString )
-import Network.Browser
- ( browse, setOutHandler, setErrHandler, setProxy
- , setAuthorityGen, request, setAllowBasicAuth, setUserAgent )
import qualified Control.Exception as Exception
-import Distribution.Simple.Utils
- ( die', info, warn, debug, notice
- , copyFileVerbose, withTempFile, IOData (..) )
-import Distribution.Utils.String (trim)
+import Distribution.Client.Types
+ ( RemoteRepo (..)
+ , unRepoName
+ )
import Distribution.Client.Utils
- ( withTempFileName )
+ ( withTempFileName
+ )
import Distribution.Client.Version
- ( cabalInstallVersion )
-import Distribution.Client.Types
- ( unRepoName, RemoteRepo(..) )
-import Distribution.System
- ( buildOS, buildArch )
-import qualified System.FilePath.Posix as FilePath.Posix
- ( splitDirectories )
-import System.FilePath
- ( (<.>), takeFileName, takeDirectory )
-import System.Directory
- ( doesFileExist, renameFile, canonicalizePath )
-import System.IO
- ( withFile, IOMode(ReadMode), hGetContents, hClose )
-import System.IO.Error
- ( isDoesNotExistError )
+ ( cabalInstallVersion
+ )
import Distribution.Simple.Program
- ( Program, simpleProgram, ConfiguredProgram, programPath
- , ProgramInvocation(..), programInvocation
- , ProgramSearchPathEntry(..)
- , getProgramInvocationOutput )
+ ( ConfiguredProgram
+ , Program
+ , ProgramInvocation (..)
+ , ProgramSearchPathEntry (..)
+ , getProgramInvocationOutput
+ , programInvocation
+ , programPath
+ , simpleProgram
+ )
import Distribution.Simple.Program.Db
- ( ProgramDb, emptyProgramDb, addKnownPrograms
- , configureAllKnownPrograms
- , requireProgram, lookupProgram
- , modifyProgramSearchPath )
+ ( ProgramDb
+ , addKnownPrograms
+ , configureAllKnownPrograms
+ , emptyProgramDb
+ , lookupProgram
+ , modifyProgramSearchPath
+ , requireProgram
+ )
import Distribution.Simple.Program.Run
- ( getProgramInvocationOutputAndErrors )
+ ( getProgramInvocationOutputAndErrors
+ )
+import Distribution.Simple.Utils
+ ( IOData (..)
+ , copyFileVerbose
+ , debug
+ , die'
+ , info
+ , notice
+ , warn
+ , withTempFile
+ )
+import Distribution.System
+ ( buildArch
+ , buildOS
+ )
+import Distribution.Utils.String (trim)
+import Network.Browser
+ ( browse
+ , request
+ , setAllowBasicAuth
+ , setAuthorityGen
+ , setErrHandler
+ , setOutHandler
+ , setProxy
+ , setUserAgent
+ )
+import Network.HTTP
+ ( Header (..)
+ , HeaderName (..)
+ , Request (..)
+ , RequestMethod (..)
+ , Response (..)
+ , lookupHeader
+ )
+import Network.HTTP.Proxy (Proxy (..), fetchProxy)
+import Network.URI
+ ( URI (..)
+ , URIAuth (..)
+ , uriToString
+ )
import Numeric (showHex)
+import System.Directory
+ ( canonicalizePath
+ , doesFileExist
+ , renameFile
+ )
+import System.FilePath
+ ( takeDirectory
+ , takeFileName
+ , (<.>)
+ )
+import qualified System.FilePath.Posix as FilePath.Posix
+ ( splitDirectories
+ )
+import System.IO
+ ( IOMode (ReadMode)
+ , hClose
+ , hGetContents
+ , withFile
+ )
+import System.IO.Error
+ ( isDoesNotExistError
+ )
import System.Random (randomRIO)
-import qualified Crypto.Hash.SHA256 as SHA256
-import qualified Data.ByteString.Base16 as Base16
-import qualified Distribution.Compat.CharParsing as P
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Char8 as BS8
-import qualified Data.ByteString.Lazy as LBS
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Distribution.Compat.CharParsing as P
------------------------------------------------------------------------------
-- Downloading a URI, given an HttpTransport
--
-data DownloadResult = FileAlreadyInCache
- | FileDownloaded FilePath
+data DownloadResult
+ = FileAlreadyInCache
+ | FileDownloaded FilePath
deriving (Eq)
data DownloadCheck
- = Downloaded -- ^ already downloaded and sha256 matches
- | CheckETag String -- ^ already downloaded and we have etag
- | NeedsDownload (Maybe BS.ByteString) -- ^ needs download with optional hash check
- deriving Eq
-
-downloadURI :: HttpTransport
- -> Verbosity
- -> URI -- ^ What to download
- -> FilePath -- ^ Where to put it
- -> IO DownloadResult
+ = -- | already downloaded and sha256 matches
+ Downloaded
+ | -- | already downloaded and we have etag
+ CheckETag String
+ | -- | needs download with optional hash check
+ NeedsDownload (Maybe BS.ByteString)
+ deriving (Eq)
+
+downloadURI
+ :: HttpTransport
+ -> Verbosity
+ -> URI
+ -- ^ What to download
+ -> FilePath
+ -- ^ Where to put it
+ -> IO DownloadResult
downloadURI _transport verbosity uri path | uriScheme uri == "file:" = do
copyFileVerbose verbosity (uriPath uri) path
return (FileDownloaded path)
- -- Can we store the hash of the file so we can safely return path when the
- -- hash matches to avoid unnecessary computation?
+-- Can we store the hash of the file so we can safely return path when the
+-- hash matches to avoid unnecessary computation?
downloadURI transport verbosity uri path = do
+ targetExists <- doesFileExist path
- targetExists <- doesFileExist path
-
- downloadCheck <-
- -- if we have uriFrag, then we expect there to be #sha256=...
- if not (null uriFrag)
+ downloadCheck <-
+ -- if we have uriFrag, then we expect there to be #sha256=...
+ if not (null uriFrag)
then case sha256parsed of
-- we know the hash, and target exists
Right expected | targetExists -> do
contents <- LBS.readFile path
let actual = SHA256.hashlazy contents
if expected == actual
- then return Downloaded
- else return (NeedsDownload (Just expected))
+ then return Downloaded
+ else return (NeedsDownload (Just expected))
-- we known the hash, target doesn't exist
Right expected -> return (NeedsDownload (Just expected))
-
-- we failed to parse uriFragment
- Left err -> die' verbosity $
- "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err
-
- -- if there are no uri fragment, use ETag
- else do
+ Left err ->
+ die' verbosity $
+ "Cannot parse URI fragment " ++ uriFrag ++ " " ++ err
+ else -- if there are no uri fragment, use ETag
+ do
etagPathExists <- doesFileExist etagPath
-- In rare cases the target file doesn't exist, but the etag does.
if targetExists && etagPathExists
- then return (CheckETag etagPath)
- else return (NeedsDownload Nothing)
-
- -- Only use the external http transports if we actually have to
- -- (or have been told to do so)
- let transport'
- | uriScheme uri == "http:"
- , not (transportManuallySelected transport)
- = plainHttpTransport
-
- | otherwise
- = transport
-
- case downloadCheck of
- Downloaded -> return FileAlreadyInCache
- CheckETag etag -> makeDownload transport' Nothing (Just etag)
- NeedsDownload hash -> makeDownload transport' hash Nothing
-
+ then return (CheckETag etagPath)
+ else return (NeedsDownload Nothing)
+
+ -- Only use the external http transports if we actually have to
+ -- (or have been told to do so)
+ let transport'
+ | uriScheme uri == "http:"
+ , not (transportManuallySelected transport) =
+ plainHttpTransport
+ | otherwise =
+ transport
+
+ case downloadCheck of
+ Downloaded -> return FileAlreadyInCache
+ CheckETag etag -> makeDownload transport' Nothing (Just etag)
+ NeedsDownload hash -> makeDownload transport' hash Nothing
where
makeDownload :: HttpTransport -> Maybe BS8.ByteString -> Maybe String -> IO DownloadResult
makeDownload transport' sha256 etag = withTempFileName (takeDirectory path) (takeFileName path) $ \tmpFile -> do
@@ -158,25 +214,32 @@ downloadURI transport verbosity uri path = do
contents <- LBS.readFile tmpFile
let actual = SHA256.hashlazy contents
unless (actual == expected) $
- die' verbosity $ unwords
- [ "Failed to download", show uri
- , ": SHA256 don't match; expected:", BS8.unpack (Base16.encode expected)
- , "actual:", BS8.unpack (Base16.encode actual)
- ]
-
+ die' verbosity $
+ unwords
+ [ "Failed to download"
+ , show uri
+ , ": SHA256 don't match; expected:"
+ , BS8.unpack (Base16.encode expected)
+ , "actual:"
+ , BS8.unpack (Base16.encode actual)
+ ]
(200, Just newEtag) -> writeFile etagPath newEtag
_ -> return ()
case fst result of
200 -> do
- info verbosity ("Downloaded to " ++ path)
- renameFile tmpFile path
- return (FileDownloaded path)
+ info verbosity ("Downloaded to " ++ path)
+ renameFile tmpFile path
+ return (FileDownloaded path)
304 -> do
- notice verbosity "Skipping download: local and remote files match."
- return FileAlreadyInCache
- errCode -> die' verbosity $ "failed to download " ++ show uri
- ++ " : HTTP code " ++ show errCode
+ notice verbosity "Skipping download: local and remote files match."
+ return FileAlreadyInCache
+ errCode ->
+ die' verbosity $
+ "failed to download "
+ ++ show uri
+ ++ " : HTTP code "
+ ++ show errCode
etagPath = path <.> "etag"
uriFrag = uriFragment uri
@@ -185,13 +248,13 @@ downloadURI transport verbosity uri path = do
sha256parsed = explicitEitherParsec fragmentParser uriFrag
fragmentParser = do
- _ <- P.string "#sha256="
- str <- some P.hexDigit
- let bs = Base16.decode (BS8.pack str)
+ _ <- P.string "#sha256="
+ str <- some P.hexDigit
+ let bs = Base16.decode (BS8.pack str)
#if MIN_VERSION_base16_bytestring(1,0,0)
- either fail return bs
+ either fail return bs
#else
- return (fst bs)
+ return (fst bs)
#endif
------------------------------------------------------------------------------
@@ -201,177 +264,218 @@ downloadURI transport verbosity uri path = do
remoteRepoCheckHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO ()
remoteRepoCheckHttps verbosity transport repo
| uriScheme (remoteRepoURI repo) == "https:"
- , not (transportSupportsHttps transport)
- = die' verbosity $ "The remote repository '" ++ unRepoName (remoteRepoName repo)
- ++ "' specifies a URL that " ++ requiresHttpsErrorMessage
+ , not (transportSupportsHttps transport) =
+ die' verbosity $
+ "The remote repository '"
+ ++ unRepoName (remoteRepoName repo)
+ ++ "' specifies a URL that "
+ ++ requiresHttpsErrorMessage
| otherwise = return ()
transportCheckHttps :: Verbosity -> HttpTransport -> URI -> IO ()
transportCheckHttps verbosity transport uri
| uriScheme uri == "https:"
- , not (transportSupportsHttps transport)
- = die' verbosity $ "The URL " ++ show uri
- ++ " " ++ requiresHttpsErrorMessage
+ , not (transportSupportsHttps transport) =
+ die' verbosity $
+ "The URL "
+ ++ show uri
+ ++ " "
+ ++ requiresHttpsErrorMessage
| otherwise = return ()
requiresHttpsErrorMessage :: String
requiresHttpsErrorMessage =
- "requires HTTPS however the built-in HTTP implementation "
- ++ "does not support HTTPS. The transport implementations with HTTPS "
- ++ "support are " ++ intercalate ", "
- [ name | (name, _, True, _ ) <- supportedTransports ]
- ++ ". One of these will be selected automatically if the corresponding "
- ++ "external program is available, or one can be selected specifically "
- ++ "with the global flag --http-transport="
+ "requires HTTPS however the built-in HTTP implementation "
+ ++ "does not support HTTPS. The transport implementations with HTTPS "
+ ++ "support are "
+ ++ intercalate
+ ", "
+ [name | (name, _, True, _) <- supportedTransports]
+ ++ ". One of these will be selected automatically if the corresponding "
+ ++ "external program is available, or one can be selected specifically "
+ ++ "with the global flag --http-transport="
remoteRepoTryUpgradeToHttps :: Verbosity -> HttpTransport -> RemoteRepo -> IO RemoteRepo
remoteRepoTryUpgradeToHttps verbosity transport repo
| remoteRepoShouldTryHttps repo
, uriScheme (remoteRepoURI repo) == "http:"
, not (transportSupportsHttps transport)
- , not (transportManuallySelected transport)
- = die' verbosity $ "The builtin HTTP implementation does not support HTTPS, but using "
- ++ "HTTPS for authenticated uploads is recommended. "
- ++ "The transport implementations with HTTPS support are "
- ++ intercalate ", " [ name | (name, _, True, _ ) <- supportedTransports ]
- ++ "but they require the corresponding external program to be "
- ++ "available. You can either make one available or use plain HTTP by "
- ++ "using the global flag --http-transport=plain-http (or putting the "
- ++ "equivalent in the config file). With plain HTTP, your password "
- ++ "is sent using HTTP digest authentication so it cannot be easily "
- ++ "intercepted, but it is not as secure as using HTTPS."
-
+ , not (transportManuallySelected transport) =
+ die' verbosity $
+ "The builtin HTTP implementation does not support HTTPS, but using "
+ ++ "HTTPS for authenticated uploads is recommended. "
+ ++ "The transport implementations with HTTPS support are "
+ ++ intercalate ", " [name | (name, _, True, _) <- supportedTransports]
+ ++ "but they require the corresponding external program to be "
+ ++ "available. You can either make one available or use plain HTTP by "
+ ++ "using the global flag --http-transport=plain-http (or putting the "
+ ++ "equivalent in the config file). With plain HTTP, your password "
+ ++ "is sent using HTTP digest authentication so it cannot be easily "
+ ++ "intercepted, but it is not as secure as using HTTPS."
| remoteRepoShouldTryHttps repo
, uriScheme (remoteRepoURI repo) == "http:"
- , transportSupportsHttps transport
- = return repo {
- remoteRepoURI = (remoteRepoURI repo) { uriScheme = "https:" }
- }
-
- | otherwise
- = return repo
+ , transportSupportsHttps transport =
+ return
+ repo
+ { remoteRepoURI = (remoteRepoURI repo){uriScheme = "https:"}
+ }
+ | otherwise =
+ return repo
-- | Utility function for legacy support.
isOldHackageURI :: URI -> Bool
-isOldHackageURI uri
- = case uriAuthority uri of
- Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->
- FilePath.Posix.splitDirectories (uriPath uri)
- == ["/","packages","archive"]
- _ -> False
-
+isOldHackageURI uri =
+ case uriAuthority uri of
+ Just (URIAuth{uriRegName = "hackage.haskell.org"}) ->
+ FilePath.Posix.splitDirectories (uriPath uri)
+ == ["/", "packages", "archive"]
+ _ -> False
------------------------------------------------------------------------------
-- Setting up a HttpTransport
--
-data HttpTransport = HttpTransport {
- -- | GET a URI, with an optional ETag (to do a conditional fetch),
- -- write the resource to the given file and return the HTTP status code,
- -- and optional ETag.
- getHttp :: Verbosity -> URI -> Maybe ETag -> FilePath -> [Header]
- -> IO (HttpCode, Maybe ETag),
-
- -- | POST a resource to a URI, with optional auth (username, password)
- -- and return the HTTP status code and any redirect URL.
- postHttp :: Verbosity -> URI -> String -> Maybe Auth
- -> IO (HttpCode, String),
-
- -- | POST a file resource to a URI using multipart\/form-data encoding,
- -- with optional auth (username, password) and return the HTTP status
- -- code and any error string.
- postHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth
- -> IO (HttpCode, String),
-
- -- | PUT a file resource to a URI, with optional auth
- -- (username, password), extra headers and return the HTTP status code
- -- and any error string.
- putHttpFile :: Verbosity -> URI -> FilePath -> Maybe Auth -> [Header]
- -> IO (HttpCode, String),
-
- -- | Whether this transport supports https or just http.
- transportSupportsHttps :: Bool,
-
- -- | Whether this transport implementation was specifically chosen by
- -- the user via configuration, or whether it was automatically selected.
- -- Strictly speaking this is not a property of the transport itself but
- -- about how it was chosen. Nevertheless it's convenient to keep here.
- transportManuallySelected :: Bool
- }
- --TODO: why does postHttp return a redirect, but postHttpFile return errors?
+data HttpTransport = HttpTransport
+ { getHttp
+ :: Verbosity
+ -> URI
+ -> Maybe ETag
+ -> FilePath
+ -> [Header]
+ -> IO (HttpCode, Maybe ETag)
+ -- ^ GET a URI, with an optional ETag (to do a conditional fetch),
+ -- write the resource to the given file and return the HTTP status code,
+ -- and optional ETag.
+ , postHttp
+ :: Verbosity
+ -> URI
+ -> String
+ -> Maybe Auth
+ -> IO (HttpCode, String)
+ -- ^ POST a resource to a URI, with optional auth (username, password)
+ -- and return the HTTP status code and any redirect URL.
+ , postHttpFile
+ :: Verbosity
+ -> URI
+ -> FilePath
+ -> Maybe Auth
+ -> IO (HttpCode, String)
+ -- ^ POST a file resource to a URI using multipart\/form-data encoding,
+ -- with optional auth (username, password) and return the HTTP status
+ -- code and any error string.
+ , putHttpFile
+ :: Verbosity
+ -> URI
+ -> FilePath
+ -> Maybe Auth
+ -> [Header]
+ -> IO (HttpCode, String)
+ -- ^ PUT a file resource to a URI, with optional auth
+ -- (username, password), extra headers and return the HTTP status code
+ -- and any error string.
+ , transportSupportsHttps :: Bool
+ -- ^ Whether this transport supports https or just http.
+ , transportManuallySelected :: Bool
+ -- ^ Whether this transport implementation was specifically chosen by
+ -- the user via configuration, or whether it was automatically selected.
+ -- Strictly speaking this is not a property of the transport itself but
+ -- about how it was chosen. Nevertheless it's convenient to keep here.
+ }
+
+-- TODO: why does postHttp return a redirect, but postHttpFile return errors?
type HttpCode = Int
-type ETag = String
-type Auth = (String, String)
-
-noPostYet :: Verbosity -> URI -> String -> Maybe (String, String)
- -> IO (Int, String)
+type ETag = String
+type Auth = (String, String)
+
+noPostYet
+ :: Verbosity
+ -> URI
+ -> String
+ -> Maybe (String, String)
+ -> IO (Int, String)
noPostYet verbosity _ _ _ = die' verbosity "Posting (for report upload) is not implemented yet"
-supportedTransports :: [(String, Maybe Program, Bool,
- ProgramDb -> Maybe HttpTransport)]
+supportedTransports
+ :: [ ( String
+ , Maybe Program
+ , Bool
+ , ProgramDb -> Maybe HttpTransport
+ )
+ ]
supportedTransports =
- [ let prog = simpleProgram "curl" in
- ( "curl", Just prog, True
- , \db -> curlTransport <$> lookupProgram prog db )
-
- , let prog = simpleProgram "wget" in
- ( "wget", Just prog, True
- , \db -> wgetTransport <$> lookupProgram prog db )
-
- , let prog = simpleProgram "powershell" in
- ( "powershell", Just prog, True
- , \db -> powershellTransport <$> lookupProgram prog db )
-
- , ( "plain-http", Nothing, False
- , \_ -> Just plainHttpTransport )
- ]
+ [ let prog = simpleProgram "curl"
+ in ( "curl"
+ , Just prog
+ , True
+ , \db -> curlTransport <$> lookupProgram prog db
+ )
+ , let prog = simpleProgram "wget"
+ in ( "wget"
+ , Just prog
+ , True
+ , \db -> wgetTransport <$> lookupProgram prog db
+ )
+ , let prog = simpleProgram "powershell"
+ in ( "powershell"
+ , Just prog
+ , True
+ , \db -> powershellTransport <$> lookupProgram prog db
+ )
+ ,
+ ( "plain-http"
+ , Nothing
+ , False
+ , \_ -> Just plainHttpTransport
+ )
+ ]
configureTransport :: Verbosity -> [FilePath] -> Maybe String -> IO HttpTransport
-
configureTransport verbosity extraPath (Just name) =
- -- the user specifically selected a transport by name so we'll try and
- -- configure that one
-
- case find (\(name',_,_,_) -> name' == name) supportedTransports of
- Just (_, mprog, _tls, mkTrans) -> do
-
- let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
- progdb <- case mprog of
- Nothing -> return emptyProgramDb
- Just prog -> snd <$> requireProgram verbosity prog baseProgDb
- -- ^^ if it fails, it'll fail here
-
- let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb
- return transport { transportManuallySelected = True }
-
- Nothing -> die' verbosity $ "Unknown HTTP transport specified: " ++ name
- ++ ". The supported transports are "
- ++ intercalate ", "
- [ name' | (name', _, _, _ ) <- supportedTransports ]
-
+ -- the user specifically selected a transport by name so we'll try and
+ -- configure that one
+
+ case find (\(name', _, _, _) -> name' == name) supportedTransports of
+ Just (_, mprog, _tls, mkTrans) -> do
+ let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
+ progdb <- case mprog of
+ Nothing -> return emptyProgramDb
+ Just prog -> snd <$> requireProgram verbosity prog baseProgDb
+ -- ^^ if it fails, it'll fail here
+
+ let transport = fromMaybe (error "configureTransport: failed to make transport") $ mkTrans progdb
+ return transport{transportManuallySelected = True}
+ Nothing ->
+ die' verbosity $
+ "Unknown HTTP transport specified: "
+ ++ name
+ ++ ". The supported transports are "
+ ++ intercalate
+ ", "
+ [name' | (name', _, _, _) <- supportedTransports]
configureTransport verbosity extraPath Nothing = do
- -- the user hasn't selected a transport, so we'll pick the first one we
- -- can configure successfully, provided that it supports tls
-
- -- for all the transports except plain-http we need to try and find
- -- their external executable
- let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
- progdb <- configureAllKnownPrograms verbosity $
- addKnownPrograms
- [ prog | (_, Just prog, _, _) <- supportedTransports ]
- baseProgDb
-
- let availableTransports =
- [ (name, transport)
- | (name, _, _, mkTrans) <- supportedTransports
- , transport <- maybeToList (mkTrans progdb) ]
- let (name, transport) =
- fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)
- debug verbosity $ "Selected http transport implementation: " ++ name
-
- return transport { transportManuallySelected = False }
-
+ -- the user hasn't selected a transport, so we'll pick the first one we
+ -- can configure successfully, provided that it supports tls
+
+ -- for all the transports except plain-http we need to try and find
+ -- their external executable
+ let baseProgDb = modifyProgramSearchPath (\p -> map ProgramSearchPathDir extraPath ++ p) emptyProgramDb
+ progdb <-
+ configureAllKnownPrograms verbosity $
+ addKnownPrograms
+ [prog | (_, Just prog, _, _) <- supportedTransports]
+ baseProgDb
+
+ let availableTransports =
+ [ (name, transport)
+ | (name, _, _, mkTrans) <- supportedTransports
+ , transport <- maybeToList (mkTrans progdb)
+ ]
+ let (name, transport) =
+ fromMaybe ("plain-http", plainHttpTransport) (safeHead availableTransports)
+ debug verbosity $ "Selected http transport implementation: " ++ name
+
+ return transport{transportManuallySelected = False}
------------------------------------------------------------------------------
-- The HttpTransports based on external programs
@@ -379,28 +483,43 @@ configureTransport verbosity extraPath Nothing = do
curlTransport :: ConfiguredProgram -> HttpTransport
curlTransport prog =
- HttpTransport gethttp posthttp posthttpfile puthttpfile True False
+ HttpTransport gethttp posthttp posthttpfile puthttpfile True False
where
gethttp verbosity uri etag destPath reqHeaders = do
- withTempFile (takeDirectory destPath)
- "curl-headers.txt" $ \tmpFile tmpHandle -> do
+ withTempFile
+ (takeDirectory destPath)
+ "curl-headers.txt"
+ $ \tmpFile tmpHandle -> do
hClose tmpHandle
- let args = [ show uri
- , "--output", destPath
- , "--location"
- , "--write-out", "%{http_code}"
- , "--user-agent", userAgent
- , "--silent", "--show-error"
- , "--dump-header", tmpFile ]
- ++ concat
- [ ["--header", "If-None-Match: " ++ t]
- | t <- maybeToList etag ]
- ++ concat
- [ ["--header", show name ++ ": " ++ value]
- | Header name value <- reqHeaders ]
-
- resp <- getProgramInvocationOutput verbosity $ addAuthConfig Nothing uri
- (programInvocation prog args)
+ let args =
+ [ show uri
+ , "--output"
+ , destPath
+ , "--location"
+ , "--write-out"
+ , "%{http_code}"
+ , "--user-agent"
+ , userAgent
+ , "--silent"
+ , "--show-error"
+ , "--dump-header"
+ , tmpFile
+ ]
+ ++ concat
+ [ ["--header", "If-None-Match: " ++ t]
+ | t <- maybeToList etag
+ ]
+ ++ concat
+ [ ["--header", show name ++ ": " ++ value]
+ | Header name value <- reqHeaders
+ ]
+
+ resp <-
+ getProgramInvocationOutput verbosity $
+ addAuthConfig
+ Nothing
+ uri
+ (programInvocation prog args)
withFile tmpFile ReadMode $ \hnd -> do
headers <- hGetContents hnd
@@ -413,53 +532,78 @@ curlTransport prog =
-- attempt to derive a u/p pair from the uri authority if one exists
-- all `uriUserInfo` values have '@' as a suffix. drop it.
let uriDerivedAuth = case uriAuthority uri of
- (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u
- _ -> Nothing
+ (Just (URIAuth u _ _)) | not (null u) -> Just $ filter (/= '@') u
+ _ -> Nothing
-- prefer passed in auth to auth derived from uri. If neither exist, then no auth
let mbAuthString = case (explicitAuth, uriDerivedAuth) of
- (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd)
- (Nothing, Just a) -> Just a
- (Nothing, Nothing) -> Nothing
+ (Just (uname, passwd), _) -> Just (uname ++ ":" ++ passwd)
+ (Nothing, Just a) -> Just a
+ (Nothing, Nothing) -> Nothing
case mbAuthString of
- Just up -> progInvocation
- { progInvokeInput = Just . IODataText . unlines $
- [ "--digest"
- , "--user " ++ up
- ]
- , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
- }
+ Just up ->
+ progInvocation
+ { progInvokeInput =
+ Just . IODataText . unlines $
+ [ "--digest"
+ , "--user " ++ up
+ ]
+ , progInvokeArgs = ["--config", "-"] ++ progInvokeArgs progInvocation
+ }
Nothing -> progInvocation
posthttpfile verbosity uri path auth = do
- let args = [ show uri
- , "--form", "package=@"++path
- , "--write-out", "\n%{http_code}"
- , "--user-agent", userAgent
- , "--silent", "--show-error"
- , "--header", "Accept: text/plain"
- , "--location"
- ]
- resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri
- (programInvocation prog args)
- (code, err, _etag) <- parseResponse verbosity uri resp ""
- return (code, err)
+ let args =
+ [ show uri
+ , "--form"
+ , "package=@" ++ path
+ , "--write-out"
+ , "\n%{http_code}"
+ , "--user-agent"
+ , userAgent
+ , "--silent"
+ , "--show-error"
+ , "--header"
+ , "Accept: text/plain"
+ , "--location"
+ ]
+ resp <-
+ getProgramInvocationOutput verbosity $
+ addAuthConfig
+ auth
+ uri
+ (programInvocation prog args)
+ (code, err, _etag) <- parseResponse verbosity uri resp ""
+ return (code, err)
puthttpfile verbosity uri path auth headers = do
- let args = [ show uri
- , "--request", "PUT", "--data-binary", "@"++path
- , "--write-out", "\n%{http_code}"
- , "--user-agent", userAgent
- , "--silent", "--show-error"
- , "--location"
- , "--header", "Accept: text/plain"
- ]
- ++ concat
- [ ["--header", show name ++ ": " ++ value]
- | Header name value <- headers ]
- resp <- getProgramInvocationOutput verbosity $ addAuthConfig auth uri
- (programInvocation prog args)
- (code, err, _etag) <- parseResponse verbosity uri resp ""
- return (code, err)
+ let args =
+ [ show uri
+ , "--request"
+ , "PUT"
+ , "--data-binary"
+ , "@" ++ path
+ , "--write-out"
+ , "\n%{http_code}"
+ , "--user-agent"
+ , userAgent
+ , "--silent"
+ , "--show-error"
+ , "--location"
+ , "--header"
+ , "Accept: text/plain"
+ ]
+ ++ concat
+ [ ["--header", show name ++ ": " ++ value]
+ | Header name value <- headers
+ ]
+ resp <-
+ getProgramInvocationOutput verbosity $
+ addAuthConfig
+ auth
+ uri
+ (programInvocation prog args)
+ (code, err, _etag) <- parseResponse verbosity uri resp ""
+ return (code, err)
-- on success these curl invocations produces an output like "200"
-- and on failure it has the server error response first
@@ -467,58 +611,65 @@ curlTransport prog =
parseResponse verbosity uri resp headers =
let codeerr =
case reverse (lines resp) of
- (codeLine:rerrLines) ->
+ (codeLine : rerrLines) ->
case readMaybe (trim codeLine) of
- Just i -> let errstr = mkErrstr rerrLines
- in Just (i, errstr)
+ Just i ->
+ let errstr = mkErrstr rerrLines
+ in Just (i, errstr)
Nothing -> Nothing
- [] -> Nothing
+ [] -> Nothing
mkErrstr = unlines . reverse . dropWhile (all isSpace)
mb_etag :: Maybe ETag
- mb_etag = listToMaybe $ reverse
- [ etag
- | ["ETag:", etag] <- map words (lines headers) ]
-
+ mb_etag =
+ listToMaybe $
+ reverse
+ [ etag
+ | ["ETag:", etag] <- map words (lines headers)
+ ]
in case codeerr of
Just (i, err) -> return (i, err, mb_etag)
- _ -> statusParseFail verbosity uri resp
-
+ _ -> statusParseFail verbosity uri resp
wgetTransport :: ConfiguredProgram -> HttpTransport
wgetTransport prog =
HttpTransport gethttp posthttp posthttpfile puthttpfile True False
where
- gethttp verbosity uri etag destPath reqHeaders = do
- resp <- runWGet verbosity uri args
-
- -- wget doesn't support range requests.
- -- so, we not only ignore range request headers,
- -- but we also display a warning message when we see them.
- let hasRangeHeader = any isRangeHeader reqHeaders
- warningMsg = "the 'wget' transport currently doesn't support"
- ++ " range requests, which wastes network bandwidth."
- ++ " To fix this, set 'http-transport' to 'curl' or"
- ++ " 'plain-http' in '~/.config/cabal/config'."
- ++ " Note that the 'plain-http' transport doesn't"
- ++ " support HTTPS.\n"
-
- when (hasRangeHeader) $ warn verbosity warningMsg
- (code, etag') <- parseOutput verbosity uri resp
- return (code, etag')
+ gethttp verbosity uri etag destPath reqHeaders = do
+ resp <- runWGet verbosity uri args
+
+ -- wget doesn't support range requests.
+ -- so, we not only ignore range request headers,
+ -- but we also display a warning message when we see them.
+ let hasRangeHeader = any isRangeHeader reqHeaders
+ warningMsg =
+ "the 'wget' transport currently doesn't support"
+ ++ " range requests, which wastes network bandwidth."
+ ++ " To fix this, set 'http-transport' to 'curl' or"
+ ++ " 'plain-http' in '~/.config/cabal/config'."
+ ++ " Note that the 'plain-http' transport doesn't"
+ ++ " support HTTPS.\n"
+
+ when (hasRangeHeader) $ warn verbosity warningMsg
+ (code, etag') <- parseOutput verbosity uri resp
+ return (code, etag')
where
- args = [ "--output-document=" ++ destPath
- , "--user-agent=" ++ userAgent
- , "--tries=5"
- , "--timeout=15"
- , "--server-response" ]
+ args =
+ [ "--output-document=" ++ destPath
+ , "--user-agent=" ++ userAgent
+ , "--tries=5"
+ , "--timeout=15"
+ , "--server-response"
+ ]
++ concat
- [ ["--header", "If-None-Match: " ++ t]
- | t <- maybeToList etag ]
+ [ ["--header", "If-None-Match: " ++ t]
+ | t <- maybeToList etag
+ ]
++ [ "--header=" ++ show name ++ ": " ++ value
| hdr@(Header name value) <- reqHeaders
- , (not (isRangeHeader hdr)) ]
+ , (not (isRangeHeader hdr))
+ ]
-- wget doesn't support range requests.
-- so, we ignore range request headers, lest we get errors.
@@ -528,171 +679,207 @@ wgetTransport prog =
posthttp = noPostYet
- posthttpfile verbosity uri path auth =
- withTempFile (takeDirectory path)
- (takeFileName path) $ \tmpFile tmpHandle ->
- withTempFile (takeDirectory path) "response" $
+ posthttpfile verbosity uri path auth =
+ withTempFile
+ (takeDirectory path)
+ (takeFileName path)
+ $ \tmpFile tmpHandle ->
+ withTempFile (takeDirectory path) "response" $
+ \responseFile responseHandle -> do
+ hClose responseHandle
+ (body, boundary) <- generateMultipartBody path
+ LBS.hPut tmpHandle body
+ hClose tmpHandle
+ let args =
+ [ "--post-file=" ++ tmpFile
+ , "--user-agent=" ++ userAgent
+ , "--server-response"
+ , "--output-document=" ++ responseFile
+ , "--header=Accept: text/plain"
+ , "--header=Content-type: multipart/form-data; "
+ ++ "boundary="
+ ++ boundary
+ ]
+ out <- runWGet verbosity (addUriAuth auth uri) args
+ (code, _etag) <- parseOutput verbosity uri out
+ withFile responseFile ReadMode $ \hnd -> do
+ resp <- hGetContents hnd
+ evaluate $ force (code, resp)
+
+ puthttpfile verbosity uri path auth headers =
+ withTempFile (takeDirectory path) "response" $
\responseFile responseHandle -> do
hClose responseHandle
- (body, boundary) <- generateMultipartBody path
- LBS.hPut tmpHandle body
- hClose tmpHandle
- let args = [ "--post-file=" ++ tmpFile
- , "--user-agent=" ++ userAgent
- , "--server-response"
- , "--output-document=" ++ responseFile
- , "--header=Accept: text/plain"
- , "--header=Content-type: multipart/form-data; " ++
- "boundary=" ++ boundary ]
+ let args =
+ [ "--method=PUT"
+ , "--body-file=" ++ path
+ , "--user-agent=" ++ userAgent
+ , "--server-response"
+ , "--output-document=" ++ responseFile
+ , "--header=Accept: text/plain"
+ ]
+ ++ [ "--header=" ++ show name ++ ": " ++ value
+ | Header name value <- headers
+ ]
+
out <- runWGet verbosity (addUriAuth auth uri) args
(code, _etag) <- parseOutput verbosity uri out
withFile responseFile ReadMode $ \hnd -> do
resp <- hGetContents hnd
evaluate $ force (code, resp)
- puthttpfile verbosity uri path auth headers =
- withTempFile (takeDirectory path) "response" $
- \responseFile responseHandle -> do
- hClose responseHandle
- let args = [ "--method=PUT", "--body-file="++path
- , "--user-agent=" ++ userAgent
- , "--server-response"
- , "--output-document=" ++ responseFile
- , "--header=Accept: text/plain" ]
- ++ [ "--header=" ++ show name ++ ": " ++ value
- | Header name value <- headers ]
-
- out <- runWGet verbosity (addUriAuth auth uri) args
- (code, _etag) <- parseOutput verbosity uri out
- withFile responseFile ReadMode $ \hnd -> do
- resp <- hGetContents hnd
- evaluate $ force (code, resp)
-
addUriAuth Nothing uri = uri
- addUriAuth (Just (user, pass)) uri = uri
- { uriAuthority = Just a { uriUserInfo = user ++ ":" ++ pass ++ "@" }
- }
- where
- a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)
+ addUriAuth (Just (user, pass)) uri =
+ uri
+ { uriAuthority = Just a{uriUserInfo = user ++ ":" ++ pass ++ "@"}
+ }
+ where
+ a = fromMaybe (URIAuth "" "" "") (uriAuthority uri)
runWGet verbosity uri args = do
- -- We pass the URI via STDIN because it contains the users' credentials
- -- and sensitive data should not be passed via command line arguments.
- let
- invocation = (programInvocation prog ("--input-file=-" : args))
+ -- We pass the URI via STDIN because it contains the users' credentials
+ -- and sensitive data should not be passed via command line arguments.
+ let
+ invocation =
+ (programInvocation prog ("--input-file=-" : args))
{ progInvokeInput = Just $ IODataText $ uriToString id uri ""
}
- -- wget returns its output on stderr rather than stdout
- (_, resp, exitCode) <- getProgramInvocationOutputAndErrors verbosity
- invocation
- -- wget returns exit code 8 for server "errors" like "304 not modified"
- if exitCode == ExitSuccess || exitCode == ExitFailure 8
- then return resp
- else die' verbosity $ "'" ++ programPath prog
- ++ "' exited with an error:\n" ++ resp
+ -- wget returns its output on stderr rather than stdout
+ (_, resp, exitCode) <-
+ getProgramInvocationOutputAndErrors
+ verbosity
+ invocation
+ -- wget returns exit code 8 for server "errors" like "304 not modified"
+ if exitCode == ExitSuccess || exitCode == ExitFailure 8
+ then return resp
+ else
+ die' verbosity $
+ "'"
+ ++ programPath prog
+ ++ "' exited with an error:\n"
+ ++ resp
-- With the --server-response flag, wget produces output with the full
-- http server response with all headers, we want to find a line like
-- "HTTP/1.1 200 OK", but only the last one, since we can have multiple
-- requests due to redirects.
parseOutput verbosity uri resp =
- let parsedCode = listToMaybe
- [ code
- | (protocol:codestr:_err) <- map words (reverse (lines resp))
- , "HTTP/" `isPrefixOf` protocol
- , code <- maybeToList (readMaybe codestr) ]
+ let parsedCode =
+ listToMaybe
+ [ code
+ | (protocol : codestr : _err) <- map words (reverse (lines resp))
+ , "HTTP/" `isPrefixOf` protocol
+ , code <- maybeToList (readMaybe codestr)
+ ]
mb_etag :: Maybe ETag
- mb_etag = listToMaybe
- [ etag
- | ["ETag:", etag] <- map words (reverse (lines resp)) ]
+ mb_etag =
+ listToMaybe
+ [ etag
+ | ["ETag:", etag] <- map words (reverse (lines resp))
+ ]
in case parsedCode of
Just i -> return (i, mb_etag)
- _ -> statusParseFail verbosity uri resp
-
+ _ -> statusParseFail verbosity uri resp
powershellTransport :: ConfiguredProgram -> HttpTransport
powershellTransport prog =
- HttpTransport gethttp posthttp posthttpfile puthttpfile True False
+ HttpTransport gethttp posthttp posthttpfile puthttpfile True False
where
gethttp verbosity uri etag destPath reqHeaders = do
- resp <- runPowershellScript verbosity $
- webclientScript
- (escape (show uri))
- (("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")
- :(setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders)))
- [ "$response = $request.GetResponse()"
- , "$responseStream = $response.GetResponseStream()"
- , "$buffer = new-object byte[] 10KB"
- , "$count = $responseStream.Read($buffer, 0, $buffer.length)"
- , "while ($count -gt 0)"
- , "{"
- , " $targetStream.Write($buffer, 0, $count)"
- , " $count = $responseStream.Read($buffer, 0, $buffer.length)"
- , "}"
- , "Write-Host ($response.StatusCode -as [int]);"
- , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
- ]
- [ "$targetStream.Flush()"
- , "$targetStream.Close()"
- , "$targetStream.Dispose()"
- , "$responseStream.Dispose()"
- ]
+ resp <-
+ runPowershellScript verbosity $
+ webclientScript
+ (escape (show uri))
+ ( ("$targetStream = New-Object -TypeName System.IO.FileStream -ArgumentList " ++ (escape destPath) ++ ", Create")
+ : (setupHeaders ((useragentHeader : etagHeader) ++ reqHeaders))
+ )
+ [ "$response = $request.GetResponse()"
+ , "$responseStream = $response.GetResponseStream()"
+ , "$buffer = new-object byte[] 10KB"
+ , "$count = $responseStream.Read($buffer, 0, $buffer.length)"
+ , "while ($count -gt 0)"
+ , "{"
+ , " $targetStream.Write($buffer, 0, $count)"
+ , " $count = $responseStream.Read($buffer, 0, $buffer.length)"
+ , "}"
+ , "Write-Host ($response.StatusCode -as [int]);"
+ , "Write-Host $response.GetResponseHeader(\"ETag\").Trim('\"')"
+ ]
+ [ "$targetStream.Flush()"
+ , "$targetStream.Close()"
+ , "$targetStream.Dispose()"
+ , "$responseStream.Dispose()"
+ ]
parseResponse resp
where
parseResponse :: String -> IO (HttpCode, Maybe ETag)
parseResponse x =
case lines $ trim x of
- (code:etagv:_) -> fmap (\c -> (c, Just etagv)) $ parseCode code x
- (code: _) -> fmap (\c -> (c, Nothing )) $ parseCode code x
- _ -> statusParseFail verbosity uri x
+ (code : etagv : _) -> fmap (\c -> (c, Just etagv)) $ parseCode code x
+ (code : _) -> fmap (\c -> (c, Nothing)) $ parseCode code x
+ _ -> statusParseFail verbosity uri x
parseCode :: String -> String -> IO HttpCode
parseCode code x = case readMaybe code of
- Just i -> return i
+ Just i -> return i
Nothing -> statusParseFail verbosity uri x
- etagHeader = [ Header HdrIfNoneMatch t | t <- maybeToList etag ]
+ etagHeader = [Header HdrIfNoneMatch t | t <- maybeToList etag]
posthttp = noPostYet
posthttpfile verbosity uri path auth =
- withTempFile (takeDirectory path)
- (takeFileName path) $ \tmpFile tmpHandle -> do
- (body, boundary) <- generateMultipartBody path
- LBS.hPut tmpHandle body
- hClose tmpHandle
- fullPath <- canonicalizePath tmpFile
-
- let contentHeader = Header HdrContentType
- ("multipart/form-data; boundary=" ++ boundary)
- resp <- runPowershellScript verbosity $ webclientScript
- (escape (show uri))
- (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
- (uploadFileAction "POST" uri fullPath)
- uploadFileCleanup
- parseUploadResponse verbosity uri resp
+ withTempFile
+ (takeDirectory path)
+ (takeFileName path)
+ $ \tmpFile tmpHandle -> do
+ (body, boundary) <- generateMultipartBody path
+ LBS.hPut tmpHandle body
+ hClose tmpHandle
+ fullPath <- canonicalizePath tmpFile
+
+ let contentHeader =
+ Header
+ HdrContentType
+ ("multipart/form-data; boundary=" ++ boundary)
+ resp <-
+ runPowershellScript verbosity $
+ webclientScript
+ (escape (show uri))
+ (setupHeaders (contentHeader : extraHeaders) ++ setupAuth auth)
+ (uploadFileAction "POST" uri fullPath)
+ uploadFileCleanup
+ parseUploadResponse verbosity uri resp
puthttpfile verbosity uri path auth headers = do
fullPath <- canonicalizePath path
- resp <- runPowershellScript verbosity $ webclientScript
- (escape (show uri))
- (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
- (uploadFileAction "PUT" uri fullPath)
- uploadFileCleanup
+ resp <-
+ runPowershellScript verbosity $
+ webclientScript
+ (escape (show uri))
+ (setupHeaders (extraHeaders ++ headers) ++ setupAuth auth)
+ (uploadFileAction "PUT" uri fullPath)
+ uploadFileCleanup
parseUploadResponse verbosity uri resp
runPowershellScript verbosity script = do
let args =
- [ "-InputFormat", "None"
- -- the default execution policy doesn't allow running
- -- unsigned scripts, so we need to tell powershell to bypass it
- , "-ExecutionPolicy", "bypass"
- , "-NoProfile", "-NonInteractive"
- , "-Command", "-"
+ [ "-InputFormat"
+ , "None"
+ , -- the default execution policy doesn't allow running
+ -- unsigned scripts, so we need to tell powershell to bypass it
+ "-ExecutionPolicy"
+ , "bypass"
+ , "-NoProfile"
+ , "-NonInteractive"
+ , "-Command"
+ , "-"
]
debug verbosity script
- getProgramInvocationOutput verbosity (programInvocation prog args)
- { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"
- }
+ getProgramInvocationOutput
+ verbosity
+ (programInvocation prog args)
+ { progInvokeInput = Just $ IODataText $ script ++ "\nExit(0);"
+ }
escape = show
@@ -704,33 +891,37 @@ powershellTransport prog =
| Header name value <- headers
]
where
- addHeader header value
- = case header of
- HdrAccept -> "Accept = " ++ escape value
- HdrUserAgent -> "UserAgent = " ++ escape value
- HdrConnection -> "Connection = " ++ escape value
- HdrContentLength -> "ContentLength = " ++ escape value
- HdrContentType -> "ContentType = " ++ escape value
- HdrDate -> "Date = " ++ escape value
- HdrExpect -> "Expect = " ++ escape value
- HdrHost -> "Host = " ++ escape value
- HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value
- HdrReferer -> "Referer = " ++ escape value
- HdrTransferEncoding -> "TransferEncoding = " ++ escape value
- HdrRange -> let (start, end) =
- if "bytes=" `isPrefixOf` value
- then case break (== '-') value' of
- (start', '-':end') -> (start', end')
- _ -> error $ "Could not decode range: " ++ value
- else error $ "Could not decode range: " ++ value
- value' = drop 6 value
- in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
- name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
+ addHeader header value =
+ case header of
+ HdrAccept -> "Accept = " ++ escape value
+ HdrUserAgent -> "UserAgent = " ++ escape value
+ HdrConnection -> "Connection = " ++ escape value
+ HdrContentLength -> "ContentLength = " ++ escape value
+ HdrContentType -> "ContentType = " ++ escape value
+ HdrDate -> "Date = " ++ escape value
+ HdrExpect -> "Expect = " ++ escape value
+ HdrHost -> "Host = " ++ escape value
+ HdrIfModifiedSince -> "IfModifiedSince = " ++ escape value
+ HdrReferer -> "Referer = " ++ escape value
+ HdrTransferEncoding -> "TransferEncoding = " ++ escape value
+ HdrRange ->
+ let (start, end) =
+ if "bytes=" `isPrefixOf` value
+ then case break (== '-') value' of
+ (start', '-' : end') -> (start', end')
+ _ -> error $ "Could not decode range: " ++ value
+ else error $ "Could not decode range: " ++ value
+ value' = drop 6 value
+ in "AddRange(\"bytes\", " ++ escape start ++ ", " ++ escape end ++ ");"
+ name -> "Headers.Add(" ++ escape (show name) ++ "," ++ escape value ++ ");"
setupAuth auth =
[ "$request.Credentials = new-object System.Net.NetworkCredential("
- ++ escape uname ++ "," ++ escape passwd ++ ",\"\");"
- | (uname,passwd) <- maybeToList auth
+ ++ escape uname
+ ++ ","
+ ++ escape passwd
+ ++ ",\"\");"
+ | (uname, passwd) <- maybeToList auth
]
uploadFileAction method _uri fullPath =
@@ -766,32 +957,32 @@ powershellTransport prog =
| Just code <- readMaybe codeStr -> return (code, unlines message)
_ -> statusParseFail verbosity uri resp
- webclientScript uri setup action cleanup = unlines
- [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
- , "$uri = New-Object \"System.Uri\" " ++ uri
- , "$request = [System.Net.HttpWebRequest]::Create($uri)"
- , unlines setup
- , "Try {"
- , unlines (map (" " ++) action)
- , "} Catch [System.Net.WebException] {"
- , " $exception = $_.Exception;"
- , " If ($exception.Status -eq "
- ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"
- , " $response = $exception.Response -as [System.Net.HttpWebResponse];"
- , " $reader = new-object "
- ++ "System.IO.StreamReader($response.GetResponseStream());"
- , " Write-Host ($response.StatusCode -as [int]);"
- , " Write-Host $reader.ReadToEnd();"
- , " } Else {"
- , " Write-Host $exception.Message;"
- , " }"
- , "} Catch {"
- , " Write-Host $_.Exception.Message;"
- , "} finally {"
- , unlines (map (" " ++) cleanup)
- , "}"
- ]
-
+ webclientScript uri setup action cleanup =
+ unlines
+ [ "[Net.ServicePointManager]::SecurityProtocol = \"tls12, tls11, tls\""
+ , "$uri = New-Object \"System.Uri\" " ++ uri
+ , "$request = [System.Net.HttpWebRequest]::Create($uri)"
+ , unlines setup
+ , "Try {"
+ , unlines (map (" " ++) action)
+ , "} Catch [System.Net.WebException] {"
+ , " $exception = $_.Exception;"
+ , " If ($exception.Status -eq "
+ ++ "[System.Net.WebExceptionStatus]::ProtocolError) {"
+ , " $response = $exception.Response -as [System.Net.HttpWebResponse];"
+ , " $reader = new-object "
+ ++ "System.IO.StreamReader($response.GetResponseStream());"
+ , " Write-Host ($response.StatusCode -as [int]);"
+ , " Write-Host $reader.ReadToEnd();"
+ , " } Else {"
+ , " Write-Host $exception.Message;"
+ , " }"
+ , "} Catch {"
+ , " Write-Host $_.Exception.Message;"
+ , "} finally {"
+ , unlines (map (" " ++) cleanup)
+ , "}"
+ ]
------------------------------------------------------------------------------
-- The builtin plain HttpTransport
@@ -799,76 +990,88 @@ powershellTransport prog =
plainHttpTransport :: HttpTransport
plainHttpTransport =
- HttpTransport gethttp posthttp posthttpfile puthttpfile False False
+ HttpTransport gethttp posthttp posthttpfile puthttpfile False False
where
gethttp verbosity uri etag destPath reqHeaders = do
- let req = Request{
- rqURI = uri,
- rqMethod = GET,
- rqHeaders = [ Header HdrIfNoneMatch t
- | t <- maybeToList etag ]
- ++ reqHeaders,
- rqBody = LBS.empty
- }
+ let req =
+ Request
+ { rqURI = uri
+ , rqMethod = GET
+ , rqHeaders =
+ [ Header HdrIfNoneMatch t
+ | t <- maybeToList etag
+ ]
+ ++ reqHeaders
+ , rqBody = LBS.empty
+ }
(_, resp) <- cabalBrowse verbosity Nothing (request req)
- let code = convertRspCode (rspCode resp)
+ let code = convertRspCode (rspCode resp)
etag' = lookupHeader HdrETag (rspHeaders resp)
-- 206 Partial Content is a normal response to a range request; see #3385.
- when (code==200 || code==206) $
- writeFileAtomic destPath $ rspBody resp
+ when (code == 200 || code == 206) $
+ writeFileAtomic destPath $
+ rspBody resp
return (code, etag')
posthttp = noPostYet
posthttpfile verbosity uri path auth = do
(body, boundary) <- generateMultipartBody path
- let headers = [ Header HdrContentType
- ("multipart/form-data; boundary="++boundary)
- , Header HdrContentLength (show (LBS8.length body))
- , Header HdrAccept ("text/plain")
- ]
- req = Request {
- rqURI = uri,
- rqMethod = POST,
- rqHeaders = headers,
- rqBody = body
- }
+ let headers =
+ [ Header
+ HdrContentType
+ ("multipart/form-data; boundary=" ++ boundary)
+ , Header HdrContentLength (show (LBS8.length body))
+ , Header HdrAccept ("text/plain")
+ ]
+ req =
+ Request
+ { rqURI = uri
+ , rqMethod = POST
+ , rqHeaders = headers
+ , rqBody = body
+ }
(_, resp) <- cabalBrowse verbosity auth (request req)
return (convertRspCode (rspCode resp), rspErrorString resp)
puthttpfile verbosity uri path auth headers = do
body <- LBS8.readFile path
- let req = Request {
- rqURI = uri,
- rqMethod = PUT,
- rqHeaders = Header HdrContentLength (show (LBS8.length body))
- : Header HdrAccept "text/plain"
- : headers,
- rqBody = body
- }
+ let req =
+ Request
+ { rqURI = uri
+ , rqMethod = PUT
+ , rqHeaders =
+ Header HdrContentLength (show (LBS8.length body))
+ : Header HdrAccept "text/plain"
+ : headers
+ , rqBody = body
+ }
(_, resp) <- cabalBrowse verbosity auth (request req)
return (convertRspCode (rspCode resp), rspErrorString resp)
- convertRspCode (a,b,c) = a*100 + b*10 + c
+ convertRspCode (a, b, c) = a * 100 + b * 10 + c
rspErrorString resp =
case lookupHeader HdrContentType (rspHeaders resp) of
Just contenttype
- | takeWhile (/= ';') contenttype == "text/plain"
- -> LBS8.unpack (rspBody resp)
+ | takeWhile (/= ';') contenttype == "text/plain" ->
+ LBS8.unpack (rspBody resp)
_ -> rspReason resp
cabalBrowse verbosity auth act = do
p <- fixupEmptyProxy <$> fetchProxy True
Exception.handleJust
(guard . isDoesNotExistError)
- (const . die' verbosity $ "Couldn't establish HTTP connection. "
- ++ "Possible cause: HTTP proxy server is down.") $
- browse $ do
+ ( const . die' verbosity $
+ "Couldn't establish HTTP connection. "
+ ++ "Possible cause: HTTP proxy server is down."
+ )
+ $ browse
+ $ do
setProxy p
- setErrHandler (warn verbosity . ("http error: "++))
+ setErrHandler (warn verbosity . ("http error: " ++))
setOutHandler (debug verbosity)
- setUserAgent userAgent
+ setUserAgent userAgent
setAllowBasicAuth False
setAuthorityGen (\_ _ -> return auth)
act
@@ -876,20 +1079,30 @@ plainHttpTransport =
fixupEmptyProxy (Proxy uri _) | null uri = NoProxy
fixupEmptyProxy p = p
-
------------------------------------------------------------------------------
-- Common stuff used by multiple transport impls
--
userAgent :: String
-userAgent = concat [ "cabal-install/", prettyShow cabalInstallVersion
- , " (", prettyShow buildOS, "; ", prettyShow buildArch, ")"
- ]
+userAgent =
+ concat
+ [ "cabal-install/"
+ , prettyShow cabalInstallVersion
+ , " ("
+ , prettyShow buildOS
+ , "; "
+ , prettyShow buildArch
+ , ")"
+ ]
statusParseFail :: Verbosity -> URI -> String -> IO a
statusParseFail verbosity uri r =
- die' verbosity $ "Failed to download " ++ show uri ++ " : "
- ++ "No Status Code could be parsed from response: " ++ r
+ die' verbosity $
+ "Failed to download "
+ ++ show uri
+ ++ " : "
+ ++ "No Status Code could be parsed from response: "
+ ++ r
------------------------------------------------------------------------------
-- Multipart stuff partially taken from cgi package.
@@ -897,30 +1110,39 @@ statusParseFail verbosity uri r =
generateMultipartBody :: FilePath -> IO (LBS.ByteString, String)
generateMultipartBody path = do
- content <- LBS.readFile path
- boundary <- genBoundary
- let !body = formatBody content (LBS8.pack boundary)
- return (body, boundary)
+ content <- LBS.readFile path
+ boundary <- genBoundary
+ let !body = formatBody content (LBS8.pack boundary)
+ return (body, boundary)
where
formatBody content boundary =
- LBS8.concat $
- [ crlf, dd, boundary, crlf ]
- ++ [ LBS8.pack (show header) | header <- headers ]
- ++ [ crlf
- , content
- , crlf, dd, boundary, dd, crlf ]
+ LBS8.concat $
+ [crlf, dd, boundary, crlf]
+ ++ [LBS8.pack (show header) | header <- headers]
+ ++ [ crlf
+ , content
+ , crlf
+ , dd
+ , boundary
+ , dd
+ , crlf
+ ]
headers =
- [ Header (HdrCustom "Content-disposition")
- ("form-data; name=package; " ++
- "filename=\"" ++ takeFileName path ++ "\"")
+ [ Header
+ (HdrCustom "Content-disposition")
+ ( "form-data; name=package; "
+ ++ "filename=\""
+ ++ takeFileName path
+ ++ "\""
+ )
, Header HdrContentType "application/x-gzip"
]
crlf = LBS8.pack "\r\n"
- dd = LBS8.pack "--"
+ dd = LBS8.pack "--"
genBoundary :: IO String
genBoundary = do
- i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer
- return $ showHex i ""
+ i <- randomRIO (0x10000000000000, 0xFFFFFFFFFFFFFF) :: IO Integer
+ return $ showHex i ""
diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs
index 40d82380321af9c6d48a4517b369f049bb5177ad..367a5e6fc5cda377e0d449f3ce6227af28839b57 100644
--- a/cabal-install/src/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/src/Distribution/Client/IndexUtils.hs
@@ -1,13 +1,16 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE GADTs #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.IndexUtils
-- Copyright : (c) Duncan Coutts 2008
@@ -18,118 +21,156 @@
-- Portability : portable
--
-- Extra utils related to the package indexes.
------------------------------------------------------------------------------
-module Distribution.Client.IndexUtils (
- getIndexFileAge,
- getInstalledPackages,
- indexBaseName,
- Configure.getInstalledPackagesMonitorFiles,
- getSourcePackages,
- getSourcePackagesMonitorFiles,
-
- TotalIndexState,
- getSourcePackagesAtIndexState,
- ActiveRepos,
- filterSkippedActiveRepos,
-
- Index(..),
- RepoIndexState (..),
- PackageEntry(..),
- parsePackageIndex,
- updateRepoIndexCache,
- updatePackageIndexCacheFile,
- writeIndexTimestamp,
- currentIndexTimestamp,
-
- BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType,
- -- * preferred-versions utilities
- preferredVersions, isPreferredVersions, parsePreferredVersionsWarnings,
- PreferredVersionsParseError(..)
+module Distribution.Client.IndexUtils
+ ( getIndexFileAge
+ , getInstalledPackages
+ , indexBaseName
+ , Configure.getInstalledPackagesMonitorFiles
+ , getSourcePackages
+ , getSourcePackagesMonitorFiles
+ , TotalIndexState
+ , getSourcePackagesAtIndexState
+ , ActiveRepos
+ , filterSkippedActiveRepos
+ , Index (..)
+ , RepoIndexState (..)
+ , PackageEntry (..)
+ , parsePackageIndex
+ , updateRepoIndexCache
+ , updatePackageIndexCacheFile
+ , writeIndexTimestamp
+ , currentIndexTimestamp
+ , BuildTreeRefType (..)
+ , refTypeFromTypeCode
+ , typeCodeFromRefType
+
+ -- * preferred-versions utilities
+ , preferredVersions
+ , isPreferredVersions
+ , parsePreferredVersionsWarnings
+ , PreferredVersionsParseError (..)
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
import qualified Codec.Archive.Tar.Index as Tar
-import qualified Distribution.Client.Tar as Tar
import Distribution.Client.IndexUtils.ActiveRepos
import Distribution.Client.IndexUtils.IndexState
import Distribution.Client.IndexUtils.Timestamp
+import qualified Distribution.Client.Tar as Tar
import Distribution.Client.Types
-import Distribution.Verbosity
import Distribution.Parsec (simpleParsecBS)
+import Distribution.Verbosity
+import Distribution.Client.Setup
+ ( RepoContext (..)
+ )
import Distribution.Package
- ( PackageId, PackageIdentifier(..), mkPackageName
- , Package(..), packageVersion, packageName )
-import Distribution.Types.Dependency
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+ ( Package (..)
+ , PackageId
+ , PackageIdentifier (..)
+ , mkPackageName
+ , packageName
+ , packageVersion
+ )
import Distribution.PackageDescription
- ( GenericPackageDescription(..)
- , PackageDescription(..), emptyPackageDescription )
+ ( GenericPackageDescription (..)
+ , PackageDescription (..)
+ , emptyPackageDescription
+ )
import Distribution.Simple.Compiler
- ( Compiler, PackageDBStack )
-import Distribution.Simple.Program
- ( ProgramDb )
+ ( Compiler
+ , PackageDBStack
+ )
import qualified Distribution.Simple.Configure as Configure
- ( getInstalledPackages, getInstalledPackagesMonitorFiles )
+ ( getInstalledPackages
+ , getInstalledPackagesMonitorFiles
+ )
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import Distribution.Simple.Program
+ ( ProgramDb
+ )
+import Distribution.Simple.Utils
+ ( createDirectoryIfMissingVerbose
+ , die'
+ , fromUTF8LBS
+ , info
+ , warn
+ )
+import Distribution.Types.Dependency
import Distribution.Types.PackageName (PackageName)
import Distribution.Version
- ( Version, VersionRange, mkVersion, intersectVersionRanges )
-import Distribution.Simple.Utils
- ( die', warn, info, createDirectoryIfMissingVerbose, fromUTF8LBS )
-import Distribution.Client.Setup
- ( RepoContext(..) )
+ ( Version
+ , VersionRange
+ , intersectVersionRanges
+ , mkVersion
+ )
import Distribution.PackageDescription.Parsec
- ( parseGenericPackageDescription, parseGenericPackageDescriptionMaybe )
+ ( parseGenericPackageDescription
+ , parseGenericPackageDescriptionMaybe
+ )
import qualified Distribution.PackageDescription.Parsec as PackageDesc.Parse
import qualified Distribution.Simple.PackageDescription as PackageDesc.Parse
-import Distribution.Solver.Types.PackageIndex (PackageIndex)
+import Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
-import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.SourcePackage
-import Data.Either
- ( rights )
-import qualified Data.Map as Map
-import qualified Data.Set as Set
import Control.Exception
-import Data.List (stripPrefix)
-import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Char8 as BSS
import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as BS
+import Data.Either
+ ( rights
+ )
+import Data.List (stripPrefix)
+import qualified Data.Map as Map
+import qualified Data.Set as Set
import Distribution.Client.GZipUtils (maybeDecompress)
-import Distribution.Client.Utils ( byteStringToFilePath
- , tryFindAddSourcePackageDesc )
-import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredEncodeFile, structuredDecodeFileOrFail)
+import Distribution.Client.Utils
+ ( byteStringToFilePath
+ , tryFindAddSourcePackageDesc
+ )
+import Distribution.Compat.Directory (listDirectory)
import Distribution.Compat.Time (getFileAge, getModTime)
-import System.Directory (doesFileExist, doesDirectoryExist)
+import Distribution.Utils.Generic (fstOf3)
+import Distribution.Utils.Structured (Structured (..), nominalStructure, structuredDecodeFileOrFail, structuredEncodeFile)
+import System.Directory (doesDirectoryExist, doesFileExist)
import System.FilePath
- ( (</>), (<.>), takeFileName, takeExtension, replaceExtension, splitDirectories, normalise, takeDirectory )
+ ( normalise
+ , replaceExtension
+ , splitDirectories
+ , takeDirectory
+ , takeExtension
+ , takeFileName
+ , (<.>)
+ , (</>)
+ )
import qualified System.FilePath.Posix as FilePath.Posix
import System.IO
-import System.IO.Unsafe (unsafeInterleaveIO)
import System.IO.Error (isDoesNotExistError)
-import Distribution.Compat.Directory (listDirectory)
-import Distribution.Utils.Generic (fstOf3)
+import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Codec.Compression.GZip as GZip
-import qualified Hackage.Security.Client as Sec
+import qualified Hackage.Security.Client as Sec
import qualified Hackage.Security.Util.Some as Sec
-- | Reduced-verbosity version of 'Configure.getInstalledPackages'
-getInstalledPackages :: Verbosity -> Compiler
- -> PackageDBStack -> ProgramDb
- -> IO InstalledPackageIndex
+getInstalledPackages
+ :: Verbosity
+ -> Compiler
+ -> PackageDBStack
+ -> ProgramDb
+ -> IO InstalledPackageIndex
getInstalledPackages verbosity comp packageDbs progdb =
- Configure.getInstalledPackages verbosity' comp packageDbs progdb
+ Configure.getInstalledPackages verbosity' comp packageDbs progdb
where
- verbosity' = lessVerbose verbosity
-
+ verbosity' = lessVerbose verbosity
-- | Get filename base (i.e. without file extension) for index-related files
--
@@ -143,9 +184,9 @@ indexBaseName :: Repo -> FilePath
indexBaseName repo = repoLocalDir repo </> fn
where
fn = case repo of
- RepoSecure {} -> "01-index"
- RepoRemote {} -> "00-index"
- RepoLocalNoIndex {} -> "noindex"
+ RepoSecure{} -> "01-index"
+ RepoRemote{} -> "00-index"
+ RepoLocalNoIndex{} -> "noindex"
------------------------------------------------------------------------
-- Reading the source package index
@@ -158,20 +199,18 @@ indexBaseName repo = repoLocalDir repo </> fn
-- filtered 'Cache' 'after applying 'filterCache' according to a
-- requested 'IndexState'.
data IndexStateInfo = IndexStateInfo
- { isiMaxTime :: !Timestamp
- -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current
- -- filtered view of the cache.
- --
- -- The following property holds
- --
- -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)
- --
-
- , isiHeadTime :: !Timestamp
- -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest
- -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to
- -- 'isiMaxTime'.
- }
+ { isiMaxTime :: !Timestamp
+ -- ^ 'Timestamp' of maximum/latest 'Timestamp' in the current
+ -- filtered view of the cache.
+ --
+ -- The following property holds
+ --
+ -- > filterCache (IndexState (isiMaxTime isi)) cache == (cache, isi)
+ , isiHeadTime :: !Timestamp
+ -- ^ 'Timestamp' equivalent to 'IndexStateHead', i.e. the latest
+ -- known 'Timestamp'; 'isiHeadTime' is always greater or equal to
+ -- 'isiMaxTime'.
+ }
emptyStateInfo :: IndexStateInfo
emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp
@@ -184,13 +223,13 @@ emptyStateInfo = IndexStateInfo nullTimestamp nullTimestamp
filterCache :: RepoIndexState -> Cache -> (Cache, IndexStateInfo)
filterCache IndexStateHead cache = (cache, IndexStateInfo{..})
where
- isiMaxTime = cacheHeadTs cache
+ isiMaxTime = cacheHeadTs cache
isiHeadTime = cacheHeadTs cache
filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
where
- cache = Cache { cacheEntries = ents, cacheHeadTs = isiMaxTime }
+ cache = Cache{cacheEntries = ents, cacheHeadTs = isiMaxTime}
isiHeadTime = cacheHeadTs cache0
- isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents)
+ isiMaxTime = maximumTimestamp (map cacheEntryTimestamp ents)
ents = filter ((<= ts0) . cacheEntryTimestamp) (cacheEntries cache0)
-- | Read a repository index from disk, from the local files specified by
@@ -202,7 +241,7 @@ filterCache (IndexStateTime ts0) cache0 = (cache, IndexStateInfo{..})
-- This is a higher level wrapper used internally in cabal-install.
getSourcePackages :: Verbosity -> RepoContext -> IO SourcePackageDb
getSourcePackages verbosity repoCtxt =
- fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
+ fstOf3 <$> getSourcePackagesAtIndexState verbosity repoCtxt Nothing Nothing
-- | Variant of 'getSourcePackages' which allows getting the source
-- packages at a particular 'IndexState'.
@@ -212,118 +251,146 @@ getSourcePackages verbosity repoCtxt =
--
-- Returns also the total index where repositories'
-- RepoIndexState's are not HEAD. This is used in v2-freeze.
---
getSourcePackagesAtIndexState
- :: Verbosity
- -> RepoContext
- -> Maybe TotalIndexState
- -> Maybe ActiveRepos
- -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
+ :: Verbosity
+ -> RepoContext
+ -> Maybe TotalIndexState
+ -> Maybe ActiveRepos
+ -> IO (SourcePackageDb, TotalIndexState, ActiveRepos)
getSourcePackagesAtIndexState verbosity repoCtxt _ _
| null (repoContextRepos repoCtxt) = do
-- In the test suite, we routinely don't have any remote package
-- servers, so don't bleat about it
warn (verboseUnmarkOutput verbosity) $
- "No remote package servers have been specified. Usually " ++
- "you would have one specified in the config file."
- return (SourcePackageDb {
- packageIndex = mempty,
- packagePreferences = mempty
- }, headTotalIndexState, ActiveRepos [])
+ "No remote package servers have been specified. Usually "
+ ++ "you would have one specified in the config file."
+ return
+ ( SourcePackageDb
+ { packageIndex = mempty
+ , packagePreferences = mempty
+ }
+ , headTotalIndexState
+ , ActiveRepos []
+ )
getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
- let describeState IndexStateHead = "most recent state"
+ let describeState IndexStateHead = "most recent state"
describeState (IndexStateTime time) = "historical state as of " ++ prettyShow time
pkgss <- for (repoContextRepos repoCtxt) $ \r -> do
- let rname :: RepoName
- rname = repoName r
-
- info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
-
- idxState <- case mb_idxState of
- Just totalIdxState -> do
- let idxState = lookupIndexState rname totalIdxState
- info verbosity $ "Using " ++ describeState idxState ++
- " as explicitly requested (via command line / project configuration)"
- return idxState
- Nothing -> do
- mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
- case mb_idxState' of
- Nothing -> do
- info verbosity "Using most recent state (could not read timestamp file)"
- return IndexStateHead
- Just idxState -> do
- info verbosity $ "Using " ++ describeState idxState ++
- " specified from most recent cabal update"
- return idxState
-
- unless (idxState == IndexStateHead) $
- case r of
- RepoLocalNoIndex {} -> warn verbosity "index-state ignored for file+noindex repositories"
- RepoRemote {} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")
- RepoSecure {} -> pure ()
-
- let idxState' = case r of
- RepoSecure {} -> idxState
- _ -> IndexStateHead
-
- (pis,deps,isi) <- readRepoIndex verbosity repoCtxt r idxState'
-
- case idxState' of
- IndexStateHead -> do
- info verbosity ("index-state("++ unRepoName rname ++") = " ++ prettyShow (isiHeadTime isi))
- return ()
- IndexStateTime ts0 -> do
- when (isiMaxTime isi /= ts0) $
- if ts0 > isiMaxTime isi
- then warn verbosity $
- "Requested index-state " ++ prettyShow ts0
- ++ " is newer than '" ++ unRepoName rname ++ "'!"
- ++ " Falling back to older state ("
- ++ prettyShow (isiMaxTime isi) ++ ")."
- else info verbosity $
- "Requested index-state " ++ prettyShow ts0
- ++ " does not exist in '"++ unRepoName rname ++"'!"
- ++ " Falling back to older state ("
- ++ prettyShow (isiMaxTime isi) ++ ")."
- info verbosity ("index-state("++ unRepoName rname ++") = " ++
- prettyShow (isiMaxTime isi) ++ " (HEAD = " ++
- prettyShow (isiHeadTime isi) ++ ")")
-
- pure RepoData
- { rdRepoName = rname
- , rdTimeStamp = isiMaxTime isi
- , rdIndex = pis
- , rdPreferences = deps
- }
+ let rname :: RepoName
+ rname = repoName r
+
+ info verbosity ("Reading available packages of " ++ unRepoName rname ++ "...")
+
+ idxState <- case mb_idxState of
+ Just totalIdxState -> do
+ let idxState = lookupIndexState rname totalIdxState
+ info verbosity $
+ "Using "
+ ++ describeState idxState
+ ++ " as explicitly requested (via command line / project configuration)"
+ return idxState
+ Nothing -> do
+ mb_idxState' <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
+ case mb_idxState' of
+ Nothing -> do
+ info verbosity "Using most recent state (could not read timestamp file)"
+ return IndexStateHead
+ Just idxState -> do
+ info verbosity $
+ "Using "
+ ++ describeState idxState
+ ++ " specified from most recent cabal update"
+ return idxState
+
+ unless (idxState == IndexStateHead) $
+ case r of
+ RepoLocalNoIndex{} -> warn verbosity "index-state ignored for file+noindex repositories"
+ RepoRemote{} -> warn verbosity ("index-state ignored for old-format (remote repository '" ++ unRepoName rname ++ "')")
+ RepoSecure{} -> pure ()
+
+ let idxState' = case r of
+ RepoSecure{} -> idxState
+ _ -> IndexStateHead
+
+ (pis, deps, isi) <- readRepoIndex verbosity repoCtxt r idxState'
+
+ case idxState' of
+ IndexStateHead -> do
+ info verbosity ("index-state(" ++ unRepoName rname ++ ") = " ++ prettyShow (isiHeadTime isi))
+ return ()
+ IndexStateTime ts0 -> do
+ when (isiMaxTime isi /= ts0) $
+ if ts0 > isiMaxTime isi
+ then
+ warn verbosity $
+ "Requested index-state "
+ ++ prettyShow ts0
+ ++ " is newer than '"
+ ++ unRepoName rname
+ ++ "'!"
+ ++ " Falling back to older state ("
+ ++ prettyShow (isiMaxTime isi)
+ ++ ")."
+ else
+ info verbosity $
+ "Requested index-state "
+ ++ prettyShow ts0
+ ++ " does not exist in '"
+ ++ unRepoName rname
+ ++ "'!"
+ ++ " Falling back to older state ("
+ ++ prettyShow (isiMaxTime isi)
+ ++ ")."
+ info
+ verbosity
+ ( "index-state("
+ ++ unRepoName rname
+ ++ ") = "
+ ++ prettyShow (isiMaxTime isi)
+ ++ " (HEAD = "
+ ++ prettyShow (isiHeadTime isi)
+ ++ ")"
+ )
+
+ pure
+ RepoData
+ { rdRepoName = rname
+ , rdTimeStamp = isiMaxTime isi
+ , rdIndex = pis
+ , rdPreferences = deps
+ }
let activeRepos :: ActiveRepos
activeRepos = fromMaybe defaultActiveRepos mb_activeRepos
pkgss' <- case organizeByRepos activeRepos rdRepoName pkgss of
- Right x -> return x
+ Right x -> return x
Left err -> warn verbosity err >> return (map (\x -> (x, CombineStrategyMerge)) pkgss)
let activeRepos' :: ActiveRepos
- activeRepos' = ActiveRepos
+ activeRepos' =
+ ActiveRepos
[ ActiveRepo (rdRepoName rd) strategy
| (rd, strategy) <- pkgss'
]
let totalIndexState :: TotalIndexState
- totalIndexState = makeTotalIndexState IndexStateHead $ Map.fromList
- [ (n, IndexStateTime ts)
- | (RepoData n ts _idx _prefs, _strategy) <- pkgss'
- -- e.g. file+noindex have nullTimestamp as their timestamp
- , ts /= nullTimestamp
- ]
+ totalIndexState =
+ makeTotalIndexState IndexStateHead $
+ Map.fromList
+ [ (n, IndexStateTime ts)
+ | (RepoData n ts _idx _prefs, _strategy) <- pkgss'
+ , -- e.g. file+noindex have nullTimestamp as their timestamp
+ ts /= nullTimestamp
+ ]
let addIndex
- :: PackageIndex UnresolvedSourcePackage
- -> (RepoData, CombineStrategy)
- -> PackageIndex UnresolvedSourcePackage
- addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc
- addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx
+ :: PackageIndex UnresolvedSourcePackage
+ -> (RepoData, CombineStrategy)
+ -> PackageIndex UnresolvedSourcePackage
+ addIndex acc (RepoData _ _ _ _, CombineStrategySkip) = acc
+ addIndex acc (RepoData _ _ idx _, CombineStrategyMerge) = PackageIndex.merge acc idx
addIndex acc (RepoData _ _ idx _, CombineStrategyOverride) = PackageIndex.override acc idx
let pkgs :: PackageIndex UnresolvedSourcePackage
@@ -331,7 +398,9 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
-- Note: preferences combined without using CombineStrategy
let prefs :: Map PackageName VersionRange
- prefs = Map.fromListWith intersectVersionRanges
+ prefs =
+ Map.fromListWith
+ intersectVersionRanges
[ (name, range)
| (RepoData _n _ts _idx prefs', _strategy) <- pkgss'
, Dependency name range _ <- prefs'
@@ -340,18 +409,22 @@ getSourcePackagesAtIndexState verbosity repoCtxt mb_idxState mb_activeRepos = do
_ <- evaluate pkgs
_ <- evaluate prefs
_ <- evaluate totalIndexState
- return (SourcePackageDb {
- packageIndex = pkgs,
- packagePreferences = prefs
- }, totalIndexState, activeRepos')
+ return
+ ( SourcePackageDb
+ { packageIndex = pkgs
+ , packagePreferences = prefs
+ }
+ , totalIndexState
+ , activeRepos'
+ )
-- auxiliary data used in getSourcePackagesAtIndexState
data RepoData = RepoData
- { rdRepoName :: RepoName
- , rdTimeStamp :: Timestamp
- , rdIndex :: PackageIndex UnresolvedSourcePackage
- , rdPreferences :: [Dependency]
- }
+ { rdRepoName :: RepoName
+ , rdTimeStamp :: Timestamp
+ , rdIndex :: PackageIndex UnresolvedSourcePackage
+ , rdPreferences :: [Dependency]
+ }
-- | Read a repository index from disk, from the local file specified by
-- the 'Repo'.
@@ -359,60 +432,71 @@ data RepoData = RepoData
-- All the 'SourcePackage's are marked as having come from the given 'Repo'.
--
-- This is a higher level wrapper used internally in cabal-install.
---
-readRepoIndex :: Verbosity -> RepoContext -> Repo -> RepoIndexState
- -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
+readRepoIndex
+ :: Verbosity
+ -> RepoContext
+ -> Repo
+ -> RepoIndexState
+ -> IO (PackageIndex UnresolvedSourcePackage, [Dependency], IndexStateInfo)
readRepoIndex verbosity repoCtxt repo idxState =
handleNotFound $ do
when (isRepoRemote repo) $ warnIfIndexIsOld =<< getIndexFileAge repo
-- note that if this step fails due to a bad repo cache, the the procedure can still succeed by reading from the existing cache, which is updated regardless.
- updateRepoIndexCache verbosity (RepoIndex repoCtxt repo) `catchIO`
- (\e -> warn verbosity $ "unable to update the repo index cache -- " ++ displayException e)
- readPackageIndexCacheFile verbosity mkAvailablePackage
- (RepoIndex repoCtxt repo)
- idxState
-
+ updateRepoIndexCache verbosity (RepoIndex repoCtxt repo)
+ `catchIO` (\e -> warn verbosity $ "unable to update the repo index cache -- " ++ displayException e)
+ readPackageIndexCacheFile
+ verbosity
+ mkAvailablePackage
+ (RepoIndex repoCtxt repo)
+ idxState
where
- mkAvailablePackage pkgEntry = SourcePackage
- { srcpkgPackageId = pkgid
- , srcpkgDescription = pkgdesc
- , srcpkgSource = case pkgEntry of
- NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing
- BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path
- , srcpkgDescrOverride = case pkgEntry of
- NormalPackage _ _ pkgtxt _ -> Just pkgtxt
- _ -> Nothing
- }
+ mkAvailablePackage pkgEntry =
+ SourcePackage
+ { srcpkgPackageId = pkgid
+ , srcpkgDescription = pkgdesc
+ , srcpkgSource = case pkgEntry of
+ NormalPackage _ _ _ _ -> RepoTarballPackage repo pkgid Nothing
+ BuildTreeRef _ _ _ path _ -> LocalUnpackedPackage path
+ , srcpkgDescrOverride = case pkgEntry of
+ NormalPackage _ _ pkgtxt _ -> Just pkgtxt
+ _ -> Nothing
+ }
where
pkgdesc = packageDesc pkgEntry
pkgid = packageId pkgEntry
- handleNotFound action = catchIO action $ \e -> if isDoesNotExistError e
- then do
- case repo of
- RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
- RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
- RepoLocalNoIndex local _ -> warn verbosity $
- "Error during construction of local+noindex "
- ++ unRepoName (localRepoName local) ++ " repository index: "
- ++ show e
- return (mempty,mempty,emptyStateInfo)
- else ioError e
-
- isOldThreshold = 15 --days
+ handleNotFound action = catchIO action $ \e ->
+ if isDoesNotExistError e
+ then do
+ case repo of
+ RepoRemote{..} -> warn verbosity $ errMissingPackageList repoRemote
+ RepoSecure{..} -> warn verbosity $ errMissingPackageList repoRemote
+ RepoLocalNoIndex local _ ->
+ warn verbosity $
+ "Error during construction of local+noindex "
+ ++ unRepoName (localRepoName local)
+ ++ " repository index: "
+ ++ show e
+ return (mempty, mempty, emptyStateInfo)
+ else ioError e
+
+ isOldThreshold = 15 -- days
warnIfIndexIsOld dt = do
when (dt >= isOldThreshold) $ case repo of
RepoRemote{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
RepoSecure{..} -> warn verbosity $ errOutdatedPackageList repoRemote dt
- RepoLocalNoIndex {} -> return ()
+ RepoLocalNoIndex{} -> return ()
errMissingPackageList repoRemote =
- "The package list for '" ++ unRepoName (remoteRepoName repoRemote)
- ++ "' does not exist. Run 'cabal update' to download it."
+ "The package list for '"
+ ++ unRepoName (remoteRepoName repoRemote)
+ ++ "' does not exist. Run 'cabal update' to download it."
errOutdatedPackageList repoRemote dt =
- "The package list for '" ++ unRepoName (remoteRepoName repoRemote)
- ++ "' is " ++ shows (floor dt :: Int) " days old.\nRun "
- ++ "'cabal update' to get the latest list of available packages."
+ "The package list for '"
+ ++ unRepoName (remoteRepoName repoRemote)
+ ++ "' is "
+ ++ shows (floor dt :: Int) " days old.\nRun "
+ ++ "'cabal update' to get the latest list of available packages."
-- | Return the age of the index file in days (as a Double).
getIndexFileAge :: Repo -> IO Double
@@ -420,34 +504,36 @@ getIndexFileAge repo = getFileAge $ indexBaseName repo <.> "tar"
-- | A set of files (or directories) that can be monitored to detect when
-- there might have been a change in the source packages.
---
getSourcePackagesMonitorFiles :: [Repo] -> [FilePath]
getSourcePackagesMonitorFiles repos =
- concat [ [ indexBaseName repo <.> "cache"
- , indexBaseName repo <.> "timestamp" ]
- | repo <- repos ]
+ concat
+ [ [ indexBaseName repo <.> "cache"
+ , indexBaseName repo <.> "timestamp"
+ ]
+ | repo <- repos
+ ]
-- | It is not necessary to call this, as the cache will be updated when the
-- index is read normally. However you can do the work earlier if you like.
---
updateRepoIndexCache :: Verbosity -> Index -> IO ()
updateRepoIndexCache verbosity index =
- whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index
+ whenCacheOutOfDate index $ updatePackageIndexCacheFile verbosity index
whenCacheOutOfDate :: Index -> IO () -> IO ()
whenCacheOutOfDate index action = do
exists <- doesFileExist $ cacheFile index
if not exists
- then action
- else if localNoIndex index
- then return () -- TODO: don't update cache for local+noindex repositories
- else do
+ then action
+ else
+ if localNoIndex index
+ then return () -- TODO: don't update cache for local+noindex repositories
+ else do
indexTime <- getModTime $ indexFile index
cacheTime <- getModTime $ cacheFile index
when (indexTime > cacheTime) action
localNoIndex :: Index -> Bool
-localNoIndex (RepoIndex _ (RepoLocalNoIndex {})) = True
+localNoIndex (RepoIndex _ (RepoLocalNoIndex{})) = True
localNoIndex _ = False
------------------------------------------------------------------------
@@ -456,40 +542,42 @@ localNoIndex _ = False
-- | An index entry is either a normal package, or a local build tree reference.
data PackageEntry
- = NormalPackage PackageId GenericPackageDescription ByteString BlockNo
- | BuildTreeRef BuildTreeRefType
- PackageId GenericPackageDescription FilePath BlockNo
+ = NormalPackage PackageId GenericPackageDescription ByteString BlockNo
+ | BuildTreeRef
+ BuildTreeRefType
+ PackageId
+ GenericPackageDescription
+ FilePath
+ BlockNo
-- | A build tree reference is either a link or a snapshot.
data BuildTreeRefType = SnapshotRef | LinkRef
- deriving (Eq,Show,Generic)
+ deriving (Eq, Show, Generic)
instance Binary BuildTreeRefType
instance Structured BuildTreeRefType
refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType
refTypeFromTypeCode t
- | t == Tar.buildTreeRefTypeCode = LinkRef
+ | t == Tar.buildTreeRefTypeCode = LinkRef
| t == Tar.buildTreeSnapshotTypeCode = SnapshotRef
- | otherwise =
- error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"
+ | otherwise =
+ error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"
typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode
-typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode
+typeCodeFromRefType LinkRef = Tar.buildTreeRefTypeCode
typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode
instance Package PackageEntry where
- packageId (NormalPackage pkgid _ _ _) = pkgid
+ packageId (NormalPackage pkgid _ _ _) = pkgid
packageId (BuildTreeRef _ pkgid _ _ _) = pkgid
packageDesc :: PackageEntry -> GenericPackageDescription
-packageDesc (NormalPackage _ descr _ _) = descr
+packageDesc (NormalPackage _ descr _ _) = descr
packageDesc (BuildTreeRef _ _ descr _ _) = descr
-- | Parse an uncompressed \"00-index.tar\" repository index file represented
-- as a 'ByteString'.
---
-
data PackageOrDep = Pkg PackageEntry | Dep Dependency
-- | Read @00-index.tar.gz@ and extract @.cabal@ and @preferred-versions@ files
@@ -522,53 +610,59 @@ parsePackageIndex verbosity = concatMap (uncurry extract) . tarEntriesList . Tar
tarEntriesList :: Show e => Tar.Entries e -> [(BlockNo, Tar.Entry)]
tarEntriesList = go 0
where
- go !_ Tar.Done = []
- go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e)
+ go !_ Tar.Done = []
+ go !_ (Tar.Fail e) = error ("tarEntriesList: " ++ show e)
go !n (Tar.Next e es') = (n, e) : go (Tar.nextEntryOffset e n) es'
extractPkg :: Verbosity -> Tar.Entry -> BlockNo -> Maybe (IO (Maybe PackageEntry))
extractPkg verbosity entry blockNo = case Tar.entryContent entry of
Tar.NormalFile content _
- | takeExtension fileName == ".cabal"
- -> case splitDirectories (normalise fileName) of
- [pkgname,vers,_] -> case simpleParsec vers of
- Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
- where
- pkgid = PackageIdentifier (mkPackageName pkgname) ver
- parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)
- descr = case parsed of
- Just d -> d
- Nothing -> error $ "Couldn't read cabal file "
- ++ show fileName
+ | takeExtension fileName == ".cabal" ->
+ case splitDirectories (normalise fileName) of
+ [pkgname, vers, _] -> case simpleParsec vers of
+ Just ver -> Just . return $ Just (NormalPackage pkgid descr content blockNo)
+ where
+ pkgid = PackageIdentifier (mkPackageName pkgname) ver
+ parsed = parseGenericPackageDescriptionMaybe (BS.toStrict content)
+ descr = case parsed of
+ Just d -> d
+ Nothing ->
+ error $
+ "Couldn't read cabal file "
+ ++ show fileName
+ _ -> Nothing
_ -> Nothing
- _ -> Nothing
-
Tar.OtherEntryType typeCode content _
| Tar.isBuildTreeRefTypeCode typeCode ->
- Just $ do
- let path = byteStringToFilePath content
- dirExists <- doesDirectoryExist path
- result <- if not dirExists then return Nothing
- else do
- cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index."
- descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile
- return . Just $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)
- descr path blockNo
- return result
-
+ Just $ do
+ let path = byteStringToFilePath content
+ dirExists <- doesDirectoryExist path
+ result <-
+ if not dirExists
+ then return Nothing
+ else do
+ cabalFile <- tryFindAddSourcePackageDesc verbosity path "Error reading package index."
+ descr <- PackageDesc.Parse.readGenericPackageDescription normal cabalFile
+ return . Just $
+ BuildTreeRef
+ (refTypeFromTypeCode typeCode)
+ (packageId descr)
+ descr
+ path
+ blockNo
+ return result
_ -> Nothing
-
where
fileName = Tar.entryPath entry
extractPrefs :: Tar.Entry -> Maybe [Dependency]
extractPrefs entry = case Tar.entryContent entry of
Tar.NormalFile content _
- | isPreferredVersions entrypath
- -> Just prefs
+ | isPreferredVersions entrypath ->
+ Just prefs
where
entrypath = Tar.entryPath entry
- prefs = parsePreferredVersions content
+ prefs = parsePreferredVersions content
_ -> Nothing
------------------------------------------------------------------------
@@ -601,30 +695,33 @@ parsePreferredVersions = rights . parsePreferredVersionsWarnings
-- | Parser error of the `preferred-versions` file.
data PreferredVersionsParseError = PreferredVersionsParseError
- { preferredVersionsParsecError :: String
- -- ^ Parser error to show to a user.
- , preferredVersionsOriginalDependency :: String
- -- ^ Original input that produced the parser error.
- }
+ { preferredVersionsParsecError :: String
+ -- ^ Parser error to show to a user.
+ , preferredVersionsOriginalDependency :: String
+ -- ^ Original input that produced the parser error.
+ }
deriving (Generic, Read, Show, Eq, Ord, Typeable)
-- | Parse `preferred-versions` file, collecting parse errors that can be shown
-- in error messages.
-parsePreferredVersionsWarnings :: ByteString
- -> [Either PreferredVersionsParseError Dependency]
+parsePreferredVersionsWarnings
+ :: ByteString
+ -> [Either PreferredVersionsParseError Dependency]
parsePreferredVersionsWarnings =
map parsePreference
- . filter (not . isPrefixOf "--")
- . lines
- . fromUTF8LBS
- where
- parsePreference :: String -> Either PreferredVersionsParseError Dependency
- parsePreference s = case eitherParsec s of
- Left err -> Left $ PreferredVersionsParseError
- { preferredVersionsParsecError = err
- , preferredVersionsOriginalDependency = s
- }
- Right dep -> Right dep
+ . filter (not . isPrefixOf "--")
+ . lines
+ . fromUTF8LBS
+ where
+ parsePreference :: String -> Either PreferredVersionsParseError Dependency
+ parsePreference s = case eitherParsec s of
+ Left err ->
+ Left $
+ PreferredVersionsParseError
+ { preferredVersionsParsecError = err
+ , preferredVersionsOriginalDependency = s
+ }
+ Right dep -> Right dep
------------------------------------------------------------------------
-- Reading and updating the index cache
@@ -638,71 +735,75 @@ parsePreferredVersionsWarnings =
lazySequence :: [IO a] -> IO [a]
lazySequence = unsafeInterleaveIO . go
where
- go [] = return []
- go (x:xs) = do x' <- x
- xs' <- lazySequence xs
- return (x' : xs')
+ go [] = return []
+ go (x : xs) = do
+ x' <- x
+ xs' <- lazySequence xs
+ return (x' : xs')
-- | A lazy unfolder for lookup operations which return the current
-- value and (possibly) the next key
-lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k,v)]
+lazyUnfold :: (k -> IO (v, Maybe k)) -> k -> IO [(k, v)]
lazyUnfold step = goLazy . Just
where
goLazy s = unsafeInterleaveIO (go s)
- go Nothing = return []
+ go Nothing = return []
go (Just k) = do
- (v, mk') <- step k
- vs' <- goLazy mk'
- return ((k,v):vs')
+ (v, mk') <- step k
+ vs' <- goLazy mk'
+ return ((k, v) : vs')
-- | Which index do we mean?
-data Index =
- -- | The main index for the specified repository
+data Index
+ = -- | The main index for the specified repository
RepoIndex RepoContext Repo
-
- -- | A sandbox-local repository
+ | -- | A sandbox-local repository
-- Argument is the location of the index file
- | SandboxIndex FilePath
+ SandboxIndex FilePath
indexFile :: Index -> FilePath
indexFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "tar"
-indexFile (SandboxIndex index) = index
+indexFile (SandboxIndex index) = index
cacheFile :: Index -> FilePath
cacheFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "cache"
-cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
+cacheFile (SandboxIndex index) = index `replaceExtension` "cache"
timestampFile :: Index -> FilePath
timestampFile (RepoIndex _ctxt repo) = indexBaseName repo <.> "timestamp"
-timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp"
+timestampFile (SandboxIndex index) = index `replaceExtension` "timestamp"
-- | Return 'True' if 'Index' uses 01-index format (aka secure repo)
is01Index :: Index -> Bool
is01Index (RepoIndex _ repo) = case repo of
- RepoSecure {} -> True
- RepoRemote {} -> False
- RepoLocalNoIndex {} -> True
-is01Index (SandboxIndex _) = False
-
+ RepoSecure{} -> True
+ RepoRemote{} -> False
+ RepoLocalNoIndex{} -> True
+is01Index (SandboxIndex _) = False
updatePackageIndexCacheFile :: Verbosity -> Index -> IO ()
updatePackageIndexCacheFile verbosity index = do
- info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")
- withIndexEntries verbosity index callback callbackNoIndex
+ info verbosity ("Updating index cache file " ++ cacheFile index ++ " ...")
+ withIndexEntries verbosity index callback callbackNoIndex
where
callback entries = do
- let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)
- cache = Cache { cacheHeadTs = maxTs
- , cacheEntries = entries
- }
- writeIndexCache index cache
- info verbosity ("Index cache updated to index-state "
- ++ prettyShow (cacheHeadTs cache))
+ let !maxTs = maximumTimestamp (map cacheEntryTimestamp entries)
+ cache =
+ Cache
+ { cacheHeadTs = maxTs
+ , cacheEntries = entries
+ }
+ writeIndexCache index cache
+ info
+ verbosity
+ ( "Index cache updated to index-state "
+ ++ prettyShow (cacheHeadTs cache)
+ )
callbackNoIndex entries = do
- writeNoIndexCache verbosity index $ NoIndexCache entries
- info verbosity "Index cache updated"
+ writeNoIndexCache verbosity index $ NoIndexCache entries
+ info verbosity "Index cache updated"
-- | Read the index (for the purpose of building a cache)
--
@@ -725,176 +826,188 @@ updatePackageIndexCacheFile verbosity index = do
-- cache, rather than reconstruct it from zero on each update. However, this
-- would require a change in the cache format.
withIndexEntries
- :: Verbosity -> Index
- -> ([IndexCacheEntry] -> IO a)
- -> ([NoIndexCacheEntry] -> IO a)
- -> IO a
+ :: Verbosity
+ -> Index
+ -> ([IndexCacheEntry] -> IO a)
+ -> ([NoIndexCacheEntry] -> IO a)
+ -> IO a
withIndexEntries _ (RepoIndex repoCtxt repo@RepoSecure{}) callback _ =
- repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
- Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
- -- Incrementally (lazily) read all the entries in the tar file in order,
- -- including all revisions, not just the last revision of each file
- indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)
- callback [ cacheEntry
- | (dirEntry, indexEntry) <- indexEntries
- , cacheEntry <- toCacheEntries dirEntry indexEntry ]
+ repoContextWithSecureRepo repoCtxt repo $ \repoSecure ->
+ Sec.withIndex repoSecure $ \Sec.IndexCallbacks{..} -> do
+ -- Incrementally (lazily) read all the entries in the tar file in order,
+ -- including all revisions, not just the last revision of each file
+ indexEntries <- lazyUnfold indexLookupEntry (Sec.directoryFirst indexDirectory)
+ callback
+ [ cacheEntry
+ | (dirEntry, indexEntry) <- indexEntries
+ , cacheEntry <- toCacheEntries dirEntry indexEntry
+ ]
where
- toCacheEntries :: Sec.DirectoryEntry -> Sec.Some Sec.IndexEntry
- -> [IndexCacheEntry]
+ toCacheEntries
+ :: Sec.DirectoryEntry
+ -> Sec.Some Sec.IndexEntry
+ -> [IndexCacheEntry]
toCacheEntries dirEntry (Sec.Some sie) =
- case Sec.indexEntryPathParsed sie of
- Nothing -> [] -- skip unrecognized file
- Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata
- Just (Sec.IndexPkgCabal pkgId) -> force
- [CachePackageId pkgId blockNo timestamp]
- Just (Sec.IndexPkgPrefs _pkgName) -> force
- [ CachePreference dep blockNo timestamp
- | dep <- parsePreferredVersions (Sec.indexEntryContent sie)
- ]
+ case Sec.indexEntryPathParsed sie of
+ Nothing -> [] -- skip unrecognized file
+ Just (Sec.IndexPkgMetadata _pkgId) -> [] -- skip metadata
+ Just (Sec.IndexPkgCabal pkgId) ->
+ force
+ [CachePackageId pkgId blockNo timestamp]
+ Just (Sec.IndexPkgPrefs _pkgName) ->
+ force
+ [ CachePreference dep blockNo timestamp
+ | dep <- parsePreferredVersions (Sec.indexEntryContent sie)
+ ]
where
blockNo = Sec.directoryEntryBlockNo dirEntry
- timestamp = fromMaybe (error "withIndexEntries: invalid timestamp") $
- epochTimeToTimestamp $ Sec.indexEntryTime sie
-
+ timestamp =
+ fromMaybe (error "withIndexEntries: invalid timestamp") $
+ epochTimeToTimestamp $
+ Sec.indexEntryTime sie
withIndexEntries verbosity (RepoIndex _repoCtxt (RepoLocalNoIndex (LocalRepo name localDir _) _cacheDir)) _ callback = do
- dirContents <- listDirectory localDir
- let contentSet = Set.fromList dirContents
-
- entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do
- case isTarGz file of
- Nothing
- | isPreferredVersions file -> do
- contents <- BS.readFile (localDir </> file)
- let versionPreferencesParsed = parsePreferredVersionsWarnings contents
- let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed
- unless (null warnings) $ do
- warn verbosity $
- "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: "
- ++ (localDir </> file)
- for_ warnings $ \err -> do
- warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err
- warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err
- return $ Just $ NoIndexCachePreference versionPreferences
- | otherwise -> do
- unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $
- info verbosity $ "Skipping " ++ file
- return Nothing
- Just pkgid | cabalPath `Set.member` contentSet -> do
- contents <- BSS.readFile (localDir </> cabalPath)
- for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->
- return (CacheGPD gpd contents)
- where
- cabalPath = prettyShow pkgid ++ ".cabal"
- Just pkgId -> do
- -- check for the right named .cabal file in the compressed tarball
- tarGz <- BS.readFile (localDir </> file)
- let tar = GZip.decompress tarGz
- entries = Tar.read tar
-
- case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of
- Just ce -> return (Just ce)
- Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file
-
- let (prefs, gpds) = partitionEithers $ map
- (\case
+ dirContents <- listDirectory localDir
+ let contentSet = Set.fromList dirContents
+
+ entries <- handle handler $ fmap catMaybes $ for dirContents $ \file -> do
+ case isTarGz file of
+ Nothing
+ | isPreferredVersions file -> do
+ contents <- BS.readFile (localDir </> file)
+ let versionPreferencesParsed = parsePreferredVersionsWarnings contents
+ let (warnings, versionPreferences) = partitionEithers versionPreferencesParsed
+ unless (null warnings) $ do
+ warn verbosity $
+ "withIndexEntries: failed to parse some entries of \"preferred-versions\" found at: "
+ ++ (localDir </> file)
+ for_ warnings $ \err -> do
+ warn verbosity $ "* \"" ++ preferredVersionsOriginalDependency err
+ warn verbosity $ "Parser Error: " ++ preferredVersionsParsecError err
+ return $ Just $ NoIndexCachePreference versionPreferences
+ | otherwise -> do
+ unless (takeFileName file == "noindex.cache" || ".cabal" `isSuffixOf` file) $
+ info verbosity $
+ "Skipping " ++ file
+ return Nothing
+ Just pkgid | cabalPath `Set.member` contentSet -> do
+ contents <- BSS.readFile (localDir </> cabalPath)
+ for (parseGenericPackageDescriptionMaybe contents) $ \gpd ->
+ return (CacheGPD gpd contents)
+ where
+ cabalPath = prettyShow pkgid ++ ".cabal"
+ Just pkgId -> do
+ -- check for the right named .cabal file in the compressed tarball
+ tarGz <- BS.readFile (localDir </> file)
+ let tar = GZip.decompress tarGz
+ entries = Tar.read tar
+
+ case Tar.foldEntries (readCabalEntry pkgId) Nothing (const Nothing) entries of
+ Just ce -> return (Just ce)
+ Nothing -> die' verbosity $ "Cannot read .cabal file inside " ++ file
+
+ let (prefs, gpds) =
+ partitionEithers $
+ map
+ ( \case
NoIndexCachePreference deps -> Left deps
CacheGPD gpd _ -> Right gpd
)
entries
- info verbosity $ "Entries in file+noindex repository " ++ unRepoName name
- for_ gpds $ \gpd ->
- info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)
- unless (null prefs) $ do
- info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name
- for_ (concat prefs) $ \pref ->
- info verbosity ("* " ++ prettyShow pref)
+ info verbosity $ "Entries in file+noindex repository " ++ unRepoName name
+ for_ gpds $ \gpd ->
+ info verbosity $ "- " ++ prettyShow (package $ Distribution.PackageDescription.packageDescription gpd)
+ unless (null prefs) $ do
+ info verbosity $ "Preferred versions in file+noindex repository " ++ unRepoName name
+ for_ (concat prefs) $ \pref ->
+ info verbosity ("* " ++ prettyShow pref)
- callback entries
+ callback entries
where
handler :: IOException -> IO a
handler e = die' verbosity $ "Error while updating index for " ++ unRepoName name ++ " repository " ++ show e
isTarGz :: FilePath -> Maybe PackageIdentifier
isTarGz fp = do
- pfx <- stripSuffix ".tar.gz" fp
- simpleParsec pfx
+ pfx <- stripSuffix ".tar.gz" fp
+ simpleParsec pfx
stripSuffix sfx str = fmap reverse (stripPrefix (reverse sfx) (reverse str))
-- look for <pkgid>/<pkgname>.cabal inside the tarball
readCabalEntry :: PackageIdentifier -> Tar.Entry -> Maybe NoIndexCacheEntry -> Maybe NoIndexCacheEntry
readCabalEntry pkgId entry Nothing
- | filename == Tar.entryPath entry
- , Tar.NormalFile contents _ <- Tar.entryContent entry
- = let bs = BS.toStrict contents
- in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs
+ | filename == Tar.entryPath entry
+ , Tar.NormalFile contents _ <- Tar.entryContent entry =
+ let bs = BS.toStrict contents
+ in fmap (\gpd -> CacheGPD gpd bs) $ parseGenericPackageDescriptionMaybe bs
where
- filename = prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"
+ filename = prettyShow pkgId FilePath.Posix.</> prettyShow (packageName pkgId) ++ ".cabal"
readCabalEntry _ _ x = x
-
-withIndexEntries verbosity index callback _ = do -- non-secure repositories
- withFile (indexFile index) ReadMode $ \h -> do
- bs <- maybeDecompress `fmap` BS.hGetContents h
- pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs
- callback $ map toCache (catMaybes pkgsOrPrefs)
+withIndexEntries verbosity index callback _ = do
+ -- non-secure repositories
+ withFile (indexFile index) ReadMode $ \h -> do
+ bs <- maybeDecompress `fmap` BS.hGetContents h
+ pkgsOrPrefs <- lazySequence $ parsePackageIndex verbosity bs
+ callback $ map toCache (catMaybes pkgsOrPrefs)
where
toCache :: PackageOrDep -> IndexCacheEntry
toCache (Pkg (NormalPackage pkgid _ _ blockNo)) = CachePackageId pkgid blockNo nullTimestamp
toCache (Pkg (BuildTreeRef refType _ _ _ blockNo)) = CacheBuildTreeRef refType blockNo
toCache (Dep d) = CachePreference d 0 nullTimestamp
-readPackageIndexCacheFile :: Package pkg
- => Verbosity
- -> (PackageEntry -> pkg)
- -> Index
- -> RepoIndexState
- -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
+readPackageIndexCacheFile
+ :: Package pkg
+ => Verbosity
+ -> (PackageEntry -> pkg)
+ -> Index
+ -> RepoIndexState
+ -> IO (PackageIndex pkg, [Dependency], IndexStateInfo)
readPackageIndexCacheFile verbosity mkPkg index idxState
- | localNoIndex index = do
- cache0 <- readNoIndexCache verbosity index
- (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0
- pure (pkgs, prefs, emptyStateInfo)
-
- | otherwise = do
- cache0 <- readIndexCache verbosity index
- indexHnd <- openFile (indexFile index) ReadMode
- let (cache,isi) = filterCache idxState cache0
- (pkgs,deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache
- pure (pkgs,deps,isi)
-
-packageIndexFromCache :: Package pkg
- => Verbosity
- -> (PackageEntry -> pkg)
- -> Handle
- -> Cache
- -> IO (PackageIndex pkg, [Dependency])
+ | localNoIndex index = do
+ cache0 <- readNoIndexCache verbosity index
+ (pkgs, prefs) <- packageNoIndexFromCache verbosity mkPkg cache0
+ pure (pkgs, prefs, emptyStateInfo)
+ | otherwise = do
+ cache0 <- readIndexCache verbosity index
+ indexHnd <- openFile (indexFile index) ReadMode
+ let (cache, isi) = filterCache idxState cache0
+ (pkgs, deps) <- packageIndexFromCache verbosity mkPkg indexHnd cache
+ pure (pkgs, deps, isi)
+
+packageIndexFromCache
+ :: Package pkg
+ => Verbosity
+ -> (PackageEntry -> pkg)
+ -> Handle
+ -> Cache
+ -> IO (PackageIndex pkg, [Dependency])
packageIndexFromCache verbosity mkPkg hnd cache = do
- (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache
- pkgIndex <- evaluate $ PackageIndex.fromList pkgs
- return (pkgIndex, prefs)
+ (pkgs, prefs) <- packageListFromCache verbosity mkPkg hnd cache
+ pkgIndex <- evaluate $ PackageIndex.fromList pkgs
+ return (pkgIndex, prefs)
packageNoIndexFromCache
- :: forall pkg. Package pkg
- => Verbosity
- -> (PackageEntry -> pkg)
- -> NoIndexCache
- -> IO (PackageIndex pkg, [Dependency])
+ :: forall pkg
+ . Package pkg
+ => Verbosity
+ -> (PackageEntry -> pkg)
+ -> NoIndexCache
+ -> IO (PackageIndex pkg, [Dependency])
packageNoIndexFromCache _verbosity mkPkg cache = do
- let (pkgs, prefs) = packageListFromNoIndexCache
- pkgIndex <- evaluate $ PackageIndex.fromList pkgs
- pure (pkgIndex, prefs)
+ let (pkgs, prefs) = packageListFromNoIndexCache
+ pkgIndex <- evaluate $ PackageIndex.fromList pkgs
+ pure (pkgIndex, prefs)
where
packageListFromNoIndexCache :: ([pkg], [Dependency])
packageListFromNoIndexCache = foldr go mempty (noIndexCacheEntries cache)
go :: NoIndexCacheEntry -> ([pkg], [Dependency]) -> ([pkg], [Dependency])
go (CacheGPD gpd bs) (pkgs, prefs) =
- let pkgId = package $ Distribution.PackageDescription.packageDescription gpd
- in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs)
+ let pkgId = package $ Distribution.PackageDescription.packageDescription gpd
+ in (mkPkg (NormalPackage pkgId gpd (BS.fromStrict bs) 0) : pkgs, prefs)
go (NoIndexCachePreference deps) (pkgs, prefs) =
- (pkgs, deps ++ prefs)
-
+ (pkgs, deps ++ prefs)
-- | Read package list
--
@@ -905,15 +1018,15 @@ packageNoIndexFromCache _verbosity mkPkg cache = do
-- all .cabal edits and preference-updates. The masking happens
-- here, i.e. the semantics that later entries in a tar file mask
-- earlier ones is resolved in this function.
-packageListFromCache :: Verbosity
- -> (PackageEntry -> pkg)
- -> Handle
- -> Cache
- -> IO ([pkg], [Dependency])
+packageListFromCache
+ :: Verbosity
+ -> (PackageEntry -> pkg)
+ -> Handle
+ -> Cache
+ -> IO ([pkg], [Dependency])
packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cacheEntries
where
accum !srcpkgs btrs !prefs [] = return (Map.elems srcpkgs ++ btrs, Map.elems prefs)
-
accum srcpkgs btrs prefs (CachePackageId pkgid blockno _ : entries) = do
-- Given the cache entry, make a package index entry.
-- The magic here is that we use lazy IO to read the .cabal file
@@ -921,23 +1034,22 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach
-- Most of the time we only need the package id.
~(pkg, pkgtxt) <- unsafeInterleaveIO $ do
pkgtxt <- getEntryContent blockno
- pkg <- readPackageDescription pkgid pkgtxt
+ pkg <- readPackageDescription pkgid pkgtxt
return (pkg, pkgtxt)
let srcpkg = mkPkg (NormalPackage pkgid pkg pkgtxt blockno)
accum (Map.insert pkgid srcpkg srcpkgs) btrs prefs entries
-
accum srcpkgs btrs prefs (CacheBuildTreeRef refType blockno : entries) = do
-- We have to read the .cabal file eagerly here because we can't cache the
-- package id for build tree references - the user might edit the .cabal
-- file after the reference was added to the index.
path <- liftM byteStringToFilePath . getEntryContent $ blockno
- pkg <- do let err = "Error reading package index from cache."
- file <- tryFindAddSourcePackageDesc verbosity path err
- PackageDesc.Parse.readGenericPackageDescription normal file
+ pkg <- do
+ let err = "Error reading package index from cache."
+ file <- tryFindAddSourcePackageDesc verbosity path err
+ PackageDesc.Parse.readGenericPackageDescription normal file
let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)
- accum srcpkgs (srcpkg:btrs) prefs entries
-
+ accum srcpkgs (srcpkg : btrs) prefs entries
accum srcpkgs btrs prefs (CachePreference pref@(Dependency pn _ _) _ _ : entries) =
accum srcpkgs btrs (Map.insert pn pref prefs) entries
@@ -947,41 +1059,44 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach
case Tar.entryContent entry of
Tar.NormalFile content _size -> return content
Tar.OtherEntryType typecode content _size
- | Tar.isBuildTreeRefTypeCode typecode
- -> return content
+ | Tar.isBuildTreeRefTypeCode typecode ->
+ return content
_ -> interror "unexpected tar entry type"
readPackageDescription :: PackageIdentifier -> ByteString -> IO GenericPackageDescription
readPackageDescription pkgid content =
case snd $ PackageDesc.Parse.runParseResult $ parseGenericPackageDescription $ BS.toStrict content of
- Right gpd -> return gpd
- Left (Just specVer, _) | specVer >= mkVersion [2,2] -> return (dummyPackageDescription specVer)
- Left _ -> interror "failed to parse .cabal file"
+ Right gpd -> return gpd
+ Left (Just specVer, _) | specVer >= mkVersion [2, 2] -> return (dummyPackageDescription specVer)
+ Left _ -> interror "failed to parse .cabal file"
where
dummyPackageDescription :: Version -> GenericPackageDescription
- dummyPackageDescription specVer = GenericPackageDescription
- { packageDescription = emptyPackageDescription
- { package = pkgid
- , synopsis = dummySynopsis
- }
+ dummyPackageDescription specVer =
+ GenericPackageDescription
+ { packageDescription =
+ emptyPackageDescription
+ { package = pkgid
+ , synopsis = dummySynopsis
+ }
, gpdScannedVersion = Just specVer -- tells index scanner to skip this file.
- , genPackageFlags = []
- , condLibrary = Nothing
+ , genPackageFlags = []
+ , condLibrary = Nothing
, condSubLibraries = []
- , condForeignLibs = []
- , condExecutables = []
- , condTestSuites = []
- , condBenchmarks = []
+ , condForeignLibs = []
+ , condExecutables = []
+ , condTestSuites = []
+ , condBenchmarks = []
}
dummySynopsis = "<could not be parsed due to unsupported CABAL spec-version>"
interror :: String -> IO a
- interror msg = die' verbosity $ "internal error when reading package index: " ++ msg
- ++ "The package index or index cache is probably "
- ++ "corrupt. Running cabal update might fix it."
-
-
+ interror msg =
+ die' verbosity $
+ "internal error when reading package index: "
+ ++ msg
+ ++ "The package index or index cache is probably "
+ ++ "corrupt. Running cabal update might fix it."
------------------------------------------------------------------------
-- Index cache data structure --
@@ -993,44 +1108,50 @@ packageListFromCache verbosity mkPkg hnd Cache{..} = accum mempty [] mempty cach
-- 'die's if it fails again).
readIndexCache :: Verbosity -> Index -> IO Cache
readIndexCache verbosity index = do
- cacheOrFail <- readIndexCache' index
- case cacheOrFail of
- Left msg -> do
- warn verbosity $ concat
- [ "Parsing the index cache failed (", msg, "). "
- , "Trying to regenerate the index cache..."
- ]
-
- updatePackageIndexCacheFile verbosity index
+ cacheOrFail <- readIndexCache' index
+ case cacheOrFail of
+ Left msg -> do
+ warn verbosity $
+ concat
+ [ "Parsing the index cache failed ("
+ , msg
+ , "). "
+ , "Trying to regenerate the index cache..."
+ ]
- either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index
+ updatePackageIndexCacheFile verbosity index
- Right res -> return (hashConsCache res)
+ either (die' verbosity) (return . hashConsCache) =<< readIndexCache' index
+ Right res -> return (hashConsCache res)
readNoIndexCache :: Verbosity -> Index -> IO NoIndexCache
readNoIndexCache verbosity index = do
- cacheOrFail <- readNoIndexCache' index
- case cacheOrFail of
- Left msg -> do
- warn verbosity $ concat
- [ "Parsing the index cache failed (", msg, "). "
- , "Trying to regenerate the index cache..."
- ]
+ cacheOrFail <- readNoIndexCache' index
+ case cacheOrFail of
+ Left msg -> do
+ warn verbosity $
+ concat
+ [ "Parsing the index cache failed ("
+ , msg
+ , "). "
+ , "Trying to regenerate the index cache..."
+ ]
- updatePackageIndexCacheFile verbosity index
+ updatePackageIndexCacheFile verbosity index
- either (die' verbosity) return =<< readNoIndexCache' index
+ either (die' verbosity) return =<< readNoIndexCache' index
- -- we don't hash cons local repository cache, they are hopefully small
- Right res -> return res
+ -- we don't hash cons local repository cache, they are hopefully small
+ Right res -> return res
-- | Read the 'Index' cache from the filesystem without attempting to
-- regenerate on parsing failures.
readIndexCache' :: Index -> IO (Either String Cache)
readIndexCache' index
| is01Index index = structuredDecodeFileOrFail (cacheFile index)
- | otherwise = liftM (Right .read00IndexCache) $
- BSS.readFile (cacheFile index)
+ | otherwise =
+ liftM (Right . read00IndexCache) $
+ BSS.readFile (cacheFile index)
readNoIndexCache' :: Index -> IO (Either String NoIndexCache)
readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)
@@ -1039,47 +1160,47 @@ readNoIndexCache' index = structuredDecodeFileOrFail (cacheFile index)
writeIndexCache :: Index -> Cache -> IO ()
writeIndexCache index cache
| is01Index index = structuredEncodeFile (cacheFile index) cache
- | otherwise = writeFile (cacheFile index) (show00IndexCache cache)
+ | otherwise = writeFile (cacheFile index) (show00IndexCache cache)
writeNoIndexCache :: Verbosity -> Index -> NoIndexCache -> IO ()
writeNoIndexCache verbosity index cache = do
- let path = cacheFile index
- createDirectoryIfMissingVerbose verbosity True (takeDirectory path)
- structuredEncodeFile path cache
+ let path = cacheFile index
+ createDirectoryIfMissingVerbose verbosity True (takeDirectory path)
+ structuredEncodeFile path cache
-- | Write the 'IndexState' to the filesystem
writeIndexTimestamp :: Index -> RepoIndexState -> IO ()
-writeIndexTimestamp index st
- = writeFile (timestampFile index) (prettyShow st)
+writeIndexTimestamp index st =
+ writeFile (timestampFile index) (prettyShow st)
-- | Read out the "current" index timestamp, i.e., what
-- timestamp you would use to revert to this version
currentIndexTimestamp :: Verbosity -> RepoContext -> Repo -> IO Timestamp
currentIndexTimestamp verbosity repoCtxt r = do
- mb_is <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
- case mb_is of
- Just (IndexStateTime ts) -> return ts
- _ -> do
- (_,_,isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead
- return (isiHeadTime isi)
+ mb_is <- readIndexTimestamp verbosity (RepoIndex repoCtxt r)
+ case mb_is of
+ Just (IndexStateTime ts) -> return ts
+ _ -> do
+ (_, _, isi) <- readRepoIndex verbosity repoCtxt r IndexStateHead
+ return (isiHeadTime isi)
-- | Read the 'IndexState' from the filesystem
readIndexTimestamp :: Verbosity -> Index -> IO (Maybe RepoIndexState)
-readIndexTimestamp verbosity index
- = fmap simpleParsec (readFile (timestampFile index))
- `catchIO` \e ->
- if isDoesNotExistError e
- then return Nothing
- else do
- warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e
- return Nothing
+readIndexTimestamp verbosity index =
+ fmap simpleParsec (readFile (timestampFile index))
+ `catchIO` \e ->
+ if isDoesNotExistError e
+ then return Nothing
+ else do
+ warn verbosity $ "Warning: could not read current index timestamp: " ++ displayException e
+ return Nothing
-- | Optimise sharing of equal values inside 'Cache'
--
-- c.f. https://en.wikipedia.org/wiki/Hash_consing
hashConsCache :: Cache -> Cache
-hashConsCache cache0
- = cache0 { cacheEntries = go mempty mempty (cacheEntries cache0) }
+hashConsCache cache0 =
+ cache0{cacheEntries = go mempty mempty (cacheEntries cache0)}
where
-- TODO/NOTE:
--
@@ -1092,72 +1213,70 @@ hashConsCache cache0
go _ _ [] = []
-- for now we only optimise only CachePackageIds since those
-- represent the vast majority
- go !pns !pvs (CachePackageId pid bno ts : rest)
- = CachePackageId pid' bno ts : go pns' pvs' rest
+ go !pns !pvs (CachePackageId pid bno ts : rest) =
+ CachePackageId pid' bno ts : go pns' pvs' rest
where
!pid' = PackageIdentifier pn' pv'
- (!pn',!pns') = mapIntern pn pns
- (!pv',!pvs') = mapIntern pv pvs
+ (!pn', !pns') = mapIntern pn pns
+ (!pv', !pvs') = mapIntern pv pvs
PackageIdentifier pn pv = pid
+ go pns pvs (x : xs) = x : go pns pvs xs
- go pns pvs (x:xs) = x : go pns pvs xs
-
- mapIntern :: Ord k => k -> Map.Map k k -> (k,Map.Map k k)
- mapIntern k m = maybe (k,Map.insert k k m) (\k' -> (k',m)) (Map.lookup k m)
+ mapIntern :: Ord k => k -> Map.Map k k -> (k, Map.Map k k)
+ mapIntern k m = maybe (k, Map.insert k k m) (\k' -> (k', m)) (Map.lookup k m)
-- | Cabal caches various information about the Hackage index
data Cache = Cache
- { cacheHeadTs :: Timestamp
- -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the
- -- invariant of 'cacheEntries' being in chronological order is
- -- violated, this corresponds to the last (seen) 'Timestamp' in
- -- 'cacheEntries'
- , cacheEntries :: [IndexCacheEntry]
- }
+ { cacheHeadTs :: Timestamp
+ -- ^ maximum/latest 'Timestamp' among 'cacheEntries'; unless the
+ -- invariant of 'cacheEntries' being in chronological order is
+ -- violated, this corresponds to the last (seen) 'Timestamp' in
+ -- 'cacheEntries'
+ , cacheEntries :: [IndexCacheEntry]
+ }
deriving (Show, Generic)
instance NFData Cache where
- rnf = rnf . cacheEntries
+ rnf = rnf . cacheEntries
-- | Cache format for 'file+noindex' repositories
newtype NoIndexCache = NoIndexCache
- { noIndexCacheEntries :: [NoIndexCacheEntry]
- }
+ { noIndexCacheEntries :: [NoIndexCacheEntry]
+ }
deriving (Show, Generic)
instance NFData NoIndexCache where
- rnf = rnf . noIndexCacheEntries
+ rnf = rnf . noIndexCacheEntries
-- | Tar files are block structured with 512 byte blocks. Every header and file
-- content starts on a block boundary.
---
type BlockNo = Word32 -- Tar.TarEntryOffset
data IndexCacheEntry
- = CachePackageId PackageId !BlockNo !Timestamp
- | CachePreference Dependency !BlockNo !Timestamp
- | CacheBuildTreeRef !BuildTreeRefType !BlockNo
- -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build
- deriving (Eq,Show,Generic)
+ = CachePackageId PackageId !BlockNo !Timestamp
+ | CachePreference Dependency !BlockNo !Timestamp
+ | CacheBuildTreeRef !BuildTreeRefType !BlockNo
+ -- NB: CacheBuildTreeRef is irrelevant for 01-index & v2-build
+ deriving (Eq, Show, Generic)
data NoIndexCacheEntry
- = CacheGPD GenericPackageDescription !BSS.ByteString
- | NoIndexCachePreference [Dependency]
- deriving (Eq,Show,Generic)
+ = CacheGPD GenericPackageDescription !BSS.ByteString
+ | NoIndexCachePreference [Dependency]
+ deriving (Eq, Show, Generic)
instance NFData IndexCacheEntry where
- rnf (CachePackageId pkgid _ _) = rnf pkgid
- rnf (CachePreference dep _ _) = rnf dep
- rnf (CacheBuildTreeRef _ _) = ()
+ rnf (CachePackageId pkgid _ _) = rnf pkgid
+ rnf (CachePreference dep _ _) = rnf dep
+ rnf (CacheBuildTreeRef _ _) = ()
instance NFData NoIndexCacheEntry where
- rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs
- rnf (NoIndexCachePreference dep) = rnf dep
+ rnf (CacheGPD gpd bs) = rnf gpd `seq` rnf bs
+ rnf (NoIndexCachePreference dep) = rnf dep
cacheEntryTimestamp :: IndexCacheEntry -> Timestamp
-cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp
+cacheEntryTimestamp (CacheBuildTreeRef _ _) = nullTimestamp
cacheEntryTimestamp (CachePreference _ _ ts) = ts
-cacheEntryTimestamp (CachePackageId _ _ ts) = ts
+cacheEntryTimestamp (CachePackageId _ _ ts) = ts
----------------------------------------------------------------------------
-- new binary 01-index.cache format
@@ -1172,28 +1291,28 @@ instance Structured NoIndexCache
-- | We need to save only .cabal file contents
instance Binary NoIndexCacheEntry where
- put (CacheGPD _ bs) = do
- put (0 :: Word8)
- put bs
- put (NoIndexCachePreference dep) = do
- put (1 :: Word8)
- put dep
-
- get = do
- t :: Word8 <- get
- case t of
- 0 -> do
- bs <- get
- case parseGenericPackageDescriptionMaybe bs of
- Just gpd -> return (CacheGPD gpd bs)
- Nothing -> fail "Failed to parse GPD"
- 1 -> do
- dep <- get
- pure $ NoIndexCachePreference dep
- _ -> fail "Failed to parse NoIndexCacheEntry"
+ put (CacheGPD _ bs) = do
+ put (0 :: Word8)
+ put bs
+ put (NoIndexCachePreference dep) = do
+ put (1 :: Word8)
+ put dep
+
+ get = do
+ t :: Word8 <- get
+ case t of
+ 0 -> do
+ bs <- get
+ case parseGenericPackageDescriptionMaybe bs of
+ Just gpd -> return (CacheGPD gpd bs)
+ Nothing -> fail "Failed to parse GPD"
+ 1 -> do
+ dep <- get
+ pure $ NoIndexCachePreference dep
+ _ -> fail "Failed to parse NoIndexCacheEntry"
instance Structured NoIndexCacheEntry where
- structure = nominalStructure
+ structure = nominalStructure
----------------------------------------------------------------------------
-- legacy 00-index.cache format
@@ -1201,64 +1320,69 @@ instance Structured NoIndexCacheEntry where
packageKey, blocknoKey, buildTreeRefKey, preferredVersionKey :: String
packageKey = "pkg:"
blocknoKey = "b#"
-buildTreeRefKey = "build-tree-ref:"
+buildTreeRefKey = "build-tree-ref:"
preferredVersionKey = "pref-ver:"
-- legacy 00-index.cache format
read00IndexCache :: BSS.ByteString -> Cache
-read00IndexCache bs = Cache
- { cacheHeadTs = nullTimestamp
- , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs
- }
+read00IndexCache bs =
+ Cache
+ { cacheHeadTs = nullTimestamp
+ , cacheEntries = mapMaybe read00IndexCacheEntry $ BSS.lines bs
+ }
read00IndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry
read00IndexCacheEntry = \line ->
case BSS.words line of
[key, pkgnamestr, pkgverstr, sep, blocknostr]
| key == BSS.pack packageKey && sep == BSS.pack blocknoKey ->
- case (parseName pkgnamestr, parseVer pkgverstr [],
- parseBlockNo blocknostr) of
- (Just pkgname, Just pkgver, Just blockno)
- -> Just (CachePackageId (PackageIdentifier pkgname pkgver)
- blockno nullTimestamp)
- _ -> Nothing
+ case ( parseName pkgnamestr
+ , parseVer pkgverstr []
+ , parseBlockNo blocknostr
+ ) of
+ (Just pkgname, Just pkgver, Just blockno) ->
+ Just
+ ( CachePackageId
+ (PackageIdentifier pkgname pkgver)
+ blockno
+ nullTimestamp
+ )
+ _ -> Nothing
[key, typecodestr, blocknostr] | key == BSS.pack buildTreeRefKey ->
case (parseRefType typecodestr, parseBlockNo blocknostr) of
- (Just refType, Just blockno)
- -> Just (CacheBuildTreeRef refType blockno)
+ (Just refType, Just blockno) ->
+ Just (CacheBuildTreeRef refType blockno)
_ -> Nothing
-
- (key: remainder) | key == BSS.pack preferredVersionKey -> do
+ (key : remainder) | key == BSS.pack preferredVersionKey -> do
pref <- simpleParsecBS (BSS.unwords remainder)
return $ CachePreference pref 0 nullTimestamp
-
- _ -> Nothing
+ _ -> Nothing
where
parseName str
- | BSS.all (\c -> isAlphaNum c || c == '-') str
- = Just (mkPackageName (BSS.unpack str))
+ | BSS.all (\c -> isAlphaNum c || c == '-') str =
+ Just (mkPackageName (BSS.unpack str))
| otherwise = Nothing
parseVer str vs =
case BSS.readInt str of
- Nothing -> Nothing
+ Nothing -> Nothing
Just (v, str') -> case BSS.uncons str' of
- Just ('.', str'') -> parseVer str'' (v:vs)
- Just _ -> Nothing
- Nothing -> Just (mkVersion (reverse (v:vs)))
+ Just ('.', str'') -> parseVer str'' (v : vs)
+ Just _ -> Nothing
+ Nothing -> Just (mkVersion (reverse (v : vs)))
parseBlockNo str =
case BSS.readInt str of
Just (blockno, remainder)
| BSS.null remainder -> Just (fromIntegral blockno)
- _ -> Nothing
+ _ -> Nothing
parseRefType str =
case BSS.uncons str of
Just (typeCode, remainder)
- | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode
- -> Just (refTypeFromTypeCode typeCode)
- _ -> Nothing
+ | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode ->
+ Just (refTypeFromTypeCode typeCode)
+ _ -> Nothing
-- legacy 00-index.cache format
show00IndexCache :: Cache -> String
@@ -1266,19 +1390,19 @@ show00IndexCache Cache{..} = unlines $ map show00IndexCacheEntry cacheEntries
show00IndexCacheEntry :: IndexCacheEntry -> String
show00IndexCacheEntry entry = unwords $ case entry of
- CachePackageId pkgid b _ ->
- [ packageKey
- , prettyShow (packageName pkgid)
- , prettyShow (packageVersion pkgid)
- , blocknoKey
- , show b
- ]
- CacheBuildTreeRef tr b ->
- [ buildTreeRefKey
- , [typeCodeFromRefType tr]
- , show b
- ]
- CachePreference dep _ _ ->
- [ preferredVersionKey
- , prettyShow dep
- ]
+ CachePackageId pkgid b _ ->
+ [ packageKey
+ , prettyShow (packageName pkgid)
+ , prettyShow (packageVersion pkgid)
+ , blocknoKey
+ , show b
+ ]
+ CacheBuildTreeRef tr b ->
+ [ buildTreeRefKey
+ , [typeCodeFromRefType tr]
+ , show b
+ ]
+ CachePreference dep _ _ ->
+ [ preferredVersionKey
+ , prettyShow dep
+ ]
diff --git a/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs b/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs
index d257e2ded147117fc614fac6784d03ddcc5092dd..e65000e6b98513f1cfe7d7dd3dfeabcecec1a432 100644
--- a/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs
+++ b/cabal-install/src/Distribution/Client/IndexUtils/ActiveRepos.hs
@@ -1,14 +1,15 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module Distribution.Client.IndexUtils.ActiveRepos (
- ActiveRepos (..),
- defaultActiveRepos,
- filterSkippedActiveRepos,
- ActiveRepoEntry (..),
- CombineStrategy (..),
- organizeByRepos,
-) where
+
+module Distribution.Client.IndexUtils.ActiveRepos
+ ( ActiveRepos (..)
+ , defaultActiveRepos
+ , filterSkippedActiveRepos
+ , ActiveRepoEntry (..)
+ , CombineStrategy (..)
+ , organizeByRepos
+ ) where
import Distribution.Client.Compat.Prelude
import Distribution.Client.Types.RepoName (RepoName (..))
@@ -17,7 +18,7 @@ import Prelude ()
import Distribution.Parsec (parsecLeadingCommaNonEmpty)
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- $setup
-- >>> import Distribution.Parsec
@@ -31,31 +32,31 @@ newtype ActiveRepos = ActiveRepos [ActiveRepoEntry]
deriving (Eq, Show, Generic)
defaultActiveRepos :: ActiveRepos
-defaultActiveRepos = ActiveRepos [ ActiveRepoRest CombineStrategyMerge ]
+defaultActiveRepos = ActiveRepos [ActiveRepoRest CombineStrategyMerge]
-- | Note, this does nothing if 'ActiveRepoRest' is present.
filterSkippedActiveRepos :: ActiveRepos -> ActiveRepos
filterSkippedActiveRepos repos@(ActiveRepos entries)
- | any isActiveRepoRest entries = repos
- | otherwise = ActiveRepos (filter notSkipped entries)
+ | any isActiveRepoRest entries = repos
+ | otherwise = ActiveRepos (filter notSkipped entries)
where
isActiveRepoRest (ActiveRepoRest _) = True
- isActiveRepoRest _ = False
+ isActiveRepoRest _ = False
notSkipped (ActiveRepo _ CombineStrategySkip) = False
- notSkipped _ = True
+ notSkipped _ = True
instance Binary ActiveRepos
instance Structured ActiveRepos
instance NFData ActiveRepos
instance Pretty ActiveRepos where
- pretty (ActiveRepos [])
- = Disp.text ":none"
- pretty (ActiveRepos repos)
- = Disp.hsep
- $ Disp.punctuate Disp.comma
- $ map pretty repos
+ pretty (ActiveRepos []) =
+ Disp.text ":none"
+ pretty (ActiveRepos repos) =
+ Disp.hsep $
+ Disp.punctuate Disp.comma $
+ map pretty repos
-- | Note: empty string is not valid 'ActiveRepos'.
--
@@ -70,16 +71,18 @@ instance Pretty ActiveRepos where
--
-- >>> simpleParsec "hackage.haskell.org, :rest, head.hackage:override" :: Maybe ActiveRepos
-- Just (ActiveRepos [ActiveRepo (RepoName "hackage.haskell.org") CombineStrategyMerge,ActiveRepoRest CombineStrategyMerge,ActiveRepo (RepoName "head.hackage") CombineStrategyOverride])
---
instance Parsec ActiveRepos where
- parsec = ActiveRepos [] <$ P.try (P.string ":none")
- <|> do
- repos <- parsecLeadingCommaNonEmpty parsec
- return (ActiveRepos (toList repos))
+ parsec =
+ ActiveRepos [] <$ P.try (P.string ":none")
+ <|> do
+ repos <- parsecLeadingCommaNonEmpty parsec
+ return (ActiveRepos (toList repos))
data ActiveRepoEntry
- = ActiveRepoRest CombineStrategy -- ^ rest repositories, i.e. not explicitly listed as 'ActiveRepo'
- | ActiveRepo RepoName CombineStrategy -- ^ explicit repository name
+ = -- | rest repositories, i.e. not explicitly listed as 'ActiveRepo'
+ ActiveRepoRest CombineStrategy
+ | -- | explicit repository name
+ ActiveRepo RepoName CombineStrategy
deriving (Eq, Show, Generic)
instance Binary ActiveRepoEntry
@@ -87,33 +90,37 @@ instance Structured ActiveRepoEntry
instance NFData ActiveRepoEntry
instance Pretty ActiveRepoEntry where
- pretty (ActiveRepoRest s) =
- Disp.text ":rest" <<>> Disp.colon <<>> pretty s
- pretty (ActiveRepo r s) =
- pretty r <<>> Disp.colon <<>> pretty s
+ pretty (ActiveRepoRest s) =
+ Disp.text ":rest" <<>> Disp.colon <<>> pretty s
+ pretty (ActiveRepo r s) =
+ pretty r <<>> Disp.colon <<>> pretty s
instance Parsec ActiveRepoEntry where
- parsec = leadColon <|> leadRepo where
- leadColon = do
- _ <- P.char ':'
- token <- P.munch1 isAlpha
- case token of
- "rest" -> ActiveRepoRest <$> strategyP
- "repo" -> P.char ':' *> leadRepo
- _ -> P.unexpected $ "Unknown active repository entry type: " ++ token
-
- leadRepo = do
- r <- parsec
- s <- strategyP
- return (ActiveRepo r s)
-
- strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)
+ parsec = leadColon <|> leadRepo
+ where
+ leadColon = do
+ _ <- P.char ':'
+ token <- P.munch1 isAlpha
+ case token of
+ "rest" -> ActiveRepoRest <$> strategyP
+ "repo" -> P.char ':' *> leadRepo
+ _ -> P.unexpected $ "Unknown active repository entry type: " ++ token
+
+ leadRepo = do
+ r <- parsec
+ s <- strategyP
+ return (ActiveRepo r s)
+
+ strategyP = P.option CombineStrategyMerge (P.char ':' *> parsec)
data CombineStrategy
- = CombineStrategySkip -- ^ skip this repository
- | CombineStrategyMerge -- ^ merge existing versions
- | CombineStrategyOverride -- ^ if later repository specifies a package,
- -- all package versions are replaced
+ = -- | skip this repository
+ CombineStrategySkip
+ | -- | merge existing versions
+ CombineStrategyMerge
+ | -- | if later repository specifies a package,
+ -- all package versions are replaced
+ CombineStrategyOverride
deriving (Eq, Show, Enum, Bounded, Generic)
instance Binary CombineStrategy
@@ -121,16 +128,17 @@ instance Structured CombineStrategy
instance NFData CombineStrategy
instance Pretty CombineStrategy where
- pretty CombineStrategySkip = Disp.text "skip"
- pretty CombineStrategyMerge = Disp.text "merge"
- pretty CombineStrategyOverride = Disp.text "override"
+ pretty CombineStrategySkip = Disp.text "skip"
+ pretty CombineStrategyMerge = Disp.text "merge"
+ pretty CombineStrategyOverride = Disp.text "override"
instance Parsec CombineStrategy where
- parsec = P.choice
- [ CombineStrategySkip <$ P.string "skip"
- , CombineStrategyMerge <$ P.string "merge"
- , CombineStrategyOverride <$ P.string "override"
- ]
+ parsec =
+ P.choice
+ [ CombineStrategySkip <$ P.string "skip"
+ , CombineStrategyMerge <$ P.string "merge"
+ , CombineStrategyOverride <$ P.string "override"
+ ]
-------------------------------------------------------------------------------
-- Organisation
@@ -153,38 +161,39 @@ instance Parsec CombineStrategy where
--
-- Note: currently if 'ActiveRepoRest' is provided more than once,
-- rest-repositories will be multiple times in the output.
---
organizeByRepos
- :: forall a. ActiveRepos
- -> (a -> RepoName)
- -> [a]
- -> Either String [(a, CombineStrategy)]
+ :: forall a
+ . ActiveRepos
+ -> (a -> RepoName)
+ -> [a]
+ -> Either String [(a, CombineStrategy)]
organizeByRepos (ActiveRepos xs0) sel ys0 =
- -- here we use lazyness to do only one traversal
- let (rest, result) = case go rest xs0 ys0 of
- Right (rest', result') -> (rest', Right result')
- Left err -> ([], Left err)
- in result
+ -- here we use lazyness to do only one traversal
+ let (rest, result) = case go rest xs0 ys0 of
+ Right (rest', result') -> (rest', Right result')
+ Left err -> ([], Left err)
+ in result
where
go :: [a] -> [ActiveRepoEntry] -> [a] -> Either String ([a], [(a, CombineStrategy)])
- go _rest [] ys = Right (ys, [])
- go rest (ActiveRepoRest s : xs) ys =
- go rest xs ys <&> \(rest', result) ->
- (rest', map (\x -> (x, s)) rest ++ result)
- go rest (ActiveRepo r s : xs) ys = do
- (z, zs) <- extract r ys
- go rest xs zs <&> \(rest', result) ->
- (rest', (z, s) : result)
+ go _rest [] ys = Right (ys, [])
+ go rest (ActiveRepoRest s : xs) ys =
+ go rest xs ys <&> \(rest', result) ->
+ (rest', map (\x -> (x, s)) rest ++ result)
+ go rest (ActiveRepo r s : xs) ys = do
+ (z, zs) <- extract r ys
+ go rest xs zs <&> \(rest', result) ->
+ (rest', (z, s) : result)
extract :: RepoName -> [a] -> Either String (a, [a])
- extract r = loop id where
- loop _acc [] = Left $ "no repository provided " ++ prettyShow r
- loop acc (x:xs)
- | sel x == r = Right (x, acc xs)
- | otherwise = loop (acc . (x :)) xs
+ extract r = loop id
+ where
+ loop _acc [] = Left $ "no repository provided " ++ prettyShow r
+ loop acc (x : xs)
+ | sel x == r = Right (x, acc xs)
+ | otherwise = loop (acc . (x :)) xs
(<&>)
- :: Either err ([s], b)
- -> (([s], b) -> ([s], c))
- -> Either err ([s], c)
+ :: Either err ([s], b)
+ -> (([s], b) -> ([s], c))
+ -> Either err ([s], c)
(<&>) = flip fmap
diff --git a/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs b/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs
index cbd01de141e5048e9a6558e239fbb338f3e8a908..8acf2b3bdc3950e1e434d19a064cf4bf3898d35f 100644
--- a/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs
+++ b/cabal-install/src/Distribution/Client/IndexUtils/IndexState.hs
@@ -1,31 +1,32 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.IndexUtils.IndexUtils
-- Copyright : (c) 2016 Herbert Valerio Riedel
-- License : BSD3
--
-- Package repositories index state.
---
-module Distribution.Client.IndexUtils.IndexState (
- RepoIndexState(..),
- TotalIndexState,
- headTotalIndexState,
- makeTotalIndexState,
- lookupIndexState,
- insertIndexState,
-) where
+module Distribution.Client.IndexUtils.IndexState
+ ( RepoIndexState (..)
+ , TotalIndexState
+ , headTotalIndexState
+ , makeTotalIndexState
+ , lookupIndexState
+ , insertIndexState
+ ) where
import Distribution.Client.Compat.Prelude
import Distribution.Client.IndexUtils.Timestamp (Timestamp)
-import Distribution.Client.Types.RepoName (RepoName (..))
+import Distribution.Client.Types.RepoName (RepoName (..))
import Distribution.Parsec (parsecLeadingCommaNonEmpty)
-import qualified Data.Map.Strict as Map
+import qualified Data.Map.Strict as Map
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- $setup
-- >>> import Distribution.Parsec
@@ -43,14 +44,17 @@ instance Structured TotalIndexState
instance NFData TotalIndexState
instance Pretty TotalIndexState where
- pretty (TIS IndexStateHead m)
- | not (Map.null m)
- = Disp.hsep $ Disp.punctuate Disp.comma
+ pretty (TIS IndexStateHead m)
+ | not (Map.null m) =
+ Disp.hsep $
+ Disp.punctuate
+ Disp.comma
[ pretty rn Disp.<+> pretty idx
| (rn, idx) <- Map.toList m
]
- pretty (TIS def m) = foldl' go (pretty def) (Map.toList m) where
- go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx
+ pretty (TIS def m) = foldl' go (pretty def) (Map.toList m)
+ where
+ go doc (rn, idx) = doc <<>> Disp.comma Disp.<+> pretty rn Disp.<+> pretty idx
-- |
--
@@ -68,29 +72,29 @@ instance Pretty TotalIndexState where
--
-- >>> simpleParsec "hackage.haskell.org 2020-02-04T12:34:56Z" :: Maybe TotalIndexState
-- Just (TIS IndexStateHead (fromList [(RepoName "hackage.haskell.org",IndexStateTime (TS 1580819696))]))
---
instance Parsec TotalIndexState where
- parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0 where
- single0 = startsWithRepoName <|> TokTimestamp <$> parsec
- startsWithRepoName = do
- reponame <- parsec
- -- the "HEAD" is technically a valid reponame...
- if reponame == RepoName "HEAD"
- then return TokHead
- else do
- P.spaces
- TokRepo reponame <$> parsec
-
- add :: TotalIndexState -> Tok -> TotalIndexState
- add _ TokHead = headTotalIndexState
- add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty
- add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m)
+ parsec = normalise . foldl' add headTotalIndexState <$> parsecLeadingCommaNonEmpty single0
+ where
+ single0 = startsWithRepoName <|> TokTimestamp <$> parsec
+ startsWithRepoName = do
+ reponame <- parsec
+ -- the "HEAD" is technically a valid reponame...
+ if reponame == RepoName "HEAD"
+ then return TokHead
+ else do
+ P.spaces
+ TokRepo reponame <$> parsec
+
+ add :: TotalIndexState -> Tok -> TotalIndexState
+ add _ TokHead = headTotalIndexState
+ add _ (TokTimestamp ts) = TIS (IndexStateTime ts) Map.empty
+ add (TIS def m) (TokRepo rn idx) = TIS def (Map.insert rn idx m)
-- used in Parsec TotalIndexState implementation
data Tok
- = TokRepo RepoName RepoIndexState
- | TokTimestamp Timestamp
- | TokHead
+ = TokRepo RepoName RepoIndexState
+ | TokTimestamp Timestamp
+ | TokHead
-- | Remove non-default values from 'TotalIndexState'.
normalise :: TotalIndexState -> TotalIndexState
@@ -111,8 +115,8 @@ lookupIndexState rn (TIS def m) = Map.findWithDefault def rn m
-- | Insert a 'RepoIndexState' to 'TotalIndexState'.
insertIndexState :: RepoName -> RepoIndexState -> TotalIndexState -> TotalIndexState
insertIndexState rn idx (TIS def m)
- | idx == def = TIS def (Map.delete rn m)
- | otherwise = TIS def (Map.insert rn idx m)
+ | idx == def = TIS def (Map.delete rn m)
+ | otherwise = TIS def (Map.insert rn idx m)
-------------------------------------------------------------------------------
-- Repository index state
@@ -120,19 +124,22 @@ insertIndexState rn idx (TIS def m)
-- | Specification of the state of a specific repo package index
data RepoIndexState
- = IndexStateHead -- ^ Use all available entries
- | IndexStateTime !Timestamp -- ^ Use all entries that existed at the specified time
- deriving (Eq,Generic,Show)
+ = -- | Use all available entries
+ IndexStateHead
+ | -- | Use all entries that existed at the specified time
+ IndexStateTime !Timestamp
+ deriving (Eq, Generic, Show)
instance Binary RepoIndexState
instance Structured RepoIndexState
instance NFData RepoIndexState
instance Pretty RepoIndexState where
- pretty IndexStateHead = Disp.text "HEAD"
- pretty (IndexStateTime ts) = pretty ts
+ pretty IndexStateHead = Disp.text "HEAD"
+ pretty (IndexStateTime ts) = pretty ts
instance Parsec RepoIndexState where
- parsec = parseHead <|> parseTime where
- parseHead = IndexStateHead <$ P.string "HEAD"
- parseTime = IndexStateTime <$> parsec
+ parsec = parseHead <|> parseTime
+ where
+ parseHead = IndexStateHead <$ P.string "HEAD"
+ parseTime = IndexStateTime <$> parsec
diff --git a/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs b/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs
index 48d3017d0e8d7e3380f535277fafac2da911e3a0..3dfe296343715ad8f2ba48ed3478714c35093419 100644
--- a/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs
+++ b/cabal-install/src/Distribution/Client/IndexUtils/Timestamp.hs
@@ -1,57 +1,57 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.IndexUtils.Timestamp
-- Copyright : (c) 2016 Herbert Valerio Riedel
-- License : BSD3
--
-- Timestamp type used in package indexes
-
module Distribution.Client.IndexUtils.Timestamp
- ( Timestamp
- , nullTimestamp
- , epochTimeToTimestamp
- , timestampToUTCTime
- , utcTimeToTimestamp
- , maximumTimestamp
- ) where
+ ( Timestamp
+ , nullTimestamp
+ , epochTimeToTimestamp
+ , timestampToUTCTime
+ , utcTimeToTimestamp
+ , maximumTimestamp
+ ) where
import Distribution.Client.Compat.Prelude
-- read is needed for Text instance
import Prelude (read)
-import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)
+import Data.Time (UTCTime (..), fromGregorianValid, makeTimeOfDayValid, showGregorian, timeOfDayToTime, timeToTimeOfDay)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
-import qualified Codec.Archive.Tar.Entry as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- | UNIX timestamp (expressed in seconds since unix epoch, i.e. 1970).
newtype Timestamp = TS Int64 -- Tar.EpochTime
- deriving (Eq,Ord,Enum,NFData,Show,Generic)
+ deriving (Eq, Ord, Enum, NFData, Show, Generic)
epochTimeToTimestamp :: Tar.EpochTime -> Maybe Timestamp
epochTimeToTimestamp et
- | ts == nullTimestamp = Nothing
- | otherwise = Just ts
+ | ts == nullTimestamp = Nothing
+ | otherwise = Just ts
where
ts = TS et
timestampToUTCTime :: Timestamp -> Maybe UTCTime
timestampToUTCTime (TS t)
- | t == minBound = Nothing
- | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t)
+ | t == minBound = Nothing
+ | otherwise = Just $ posixSecondsToUTCTime (fromIntegral t)
utcTimeToTimestamp :: UTCTime -> Maybe Timestamp
utcTimeToTimestamp utct
- | minTime <= t, t <= maxTime = Just (TS (fromIntegral t))
- | otherwise = Nothing
+ | minTime <= t, t <= maxTime = Just (TS (fromIntegral t))
+ | otherwise = Nothing
where
maxTime = toInteger (maxBound :: Int64)
minTime = toInteger (succ minBound :: Int64)
@@ -65,13 +65,13 @@ utcTimeToTimestamp utct
-- values.
maximumTimestamp :: [Timestamp] -> Timestamp
maximumTimestamp [] = nullTimestamp
-maximumTimestamp xs@(_:_) = maximum xs
+maximumTimestamp xs@(_ : _) = maximum xs
-- returns 'Nothing' if not representable as 'Timestamp'
posixSecondsToTimestamp :: Integer -> Maybe Timestamp
posixSecondsToTimestamp pt
- | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt))
- | otherwise = Nothing
+ | minTs <= pt, pt <= maxTs = Just (TS (fromInteger pt))
+ | otherwise = Nothing
where
maxTs = toInteger (maxBound :: Int64)
minTs = toInteger (succ minBound :: Int64)
@@ -86,10 +86,10 @@ posixSecondsToTimestamp pt
-- to hold.
showTimestamp :: Timestamp -> String
showTimestamp ts = case timestampToUTCTime ts of
- Nothing -> ""
- -- Note: we don't use 'formatTime' here to avoid incurring a
- -- dependency on 'old-locale' for older `time` libs
- Just UTCTime{..} -> showGregorian utctDay ++ ('T':showTOD utctDayTime) ++ "Z"
+ Nothing -> ""
+ -- Note: we don't use 'formatTime' here to avoid incurring a
+ -- dependency on 'old-locale' for older `time` libs
+ Just UTCTime{..} -> showGregorian utctDay ++ ('T' : showTOD utctDayTime) ++ "Z"
where
showTOD = show . timeToTimeOfDay
@@ -97,63 +97,65 @@ instance Binary Timestamp
instance Structured Timestamp
instance Pretty Timestamp where
- pretty = Disp.text . showTimestamp
+ pretty = Disp.text . showTimestamp
instance Parsec Timestamp where
- parsec = parsePosix <|> parseUTC
- where
- -- | Parses unix timestamps, e.g. @"\@1474626019"@
- parsePosix = do
- _ <- P.char '@'
- t <- P.integral -- note, no negative timestamps
- maybe (fail (show t ++ " is not representable as timestamp")) return $
- posixSecondsToTimestamp t
-
- -- | Parses ISO8601/RFC3339-style UTC timestamps,
- -- e.g. @"2017-12-31T23:59:59Z"@
- --
- -- TODO: support numeric tz offsets; allow to leave off seconds
- parseUTC = do
- -- Note: we don't use 'Data.Time.Format.parseTime' here since
- -- we want more control over the accepted formats.
-
- ye <- parseYear
- _ <- P.char '-'
- mo <- parseTwoDigits
- _ <- P.char '-'
- da <- parseTwoDigits
- _ <- P.char 'T'
-
- utctDay <- maybe (fail (show (ye,mo,da) ++ " is not valid gregorian date")) return $
- fromGregorianValid ye mo da
-
- ho <- parseTwoDigits
- _ <- P.char ':'
- mi <- parseTwoDigits
- _ <- P.char ':'
- se <- parseTwoDigits
- _ <- P.char 'Z'
-
- utctDayTime <- maybe (fail (show (ho,mi,se) ++ " is not valid time of day")) (return . timeOfDayToTime) $
- makeTimeOfDayValid ho mi (realToFrac (se::Int))
-
- let utc = UTCTime {..}
-
- maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc
-
- parseTwoDigits = do
- d1 <- P.satisfy isDigit
- d2 <- P.satisfy isDigit
- return (read [d1,d2])
-
- -- A year must have at least 4 digits; e.g. "0097" is fine,
- -- while "97" is not c.f. RFC3339 which
- -- deprecates 2-digit years
- parseYear = do
- sign <- P.option ' ' (P.char '-')
- ds <- P.munch1 isDigit
- when (length ds < 4) $ fail "Year should have at least 4 digits"
- return (read (sign:ds))
+ parsec = parsePosix <|> parseUTC
+ where
+ -- \| Parses unix timestamps, e.g. @"\@1474626019"@
+ parsePosix = do
+ _ <- P.char '@'
+ t <- P.integral -- note, no negative timestamps
+ maybe (fail (show t ++ " is not representable as timestamp")) return $
+ posixSecondsToTimestamp t
+
+ -- \| Parses ISO8601/RFC3339-style UTC timestamps,
+ -- e.g. @"2017-12-31T23:59:59Z"@
+ --
+ -- TODO: support numeric tz offsets; allow to leave off seconds
+ parseUTC = do
+ -- Note: we don't use 'Data.Time.Format.parseTime' here since
+ -- we want more control over the accepted formats.
+
+ ye <- parseYear
+ _ <- P.char '-'
+ mo <- parseTwoDigits
+ _ <- P.char '-'
+ da <- parseTwoDigits
+ _ <- P.char 'T'
+
+ utctDay <-
+ maybe (fail (show (ye, mo, da) ++ " is not valid gregorian date")) return $
+ fromGregorianValid ye mo da
+
+ ho <- parseTwoDigits
+ _ <- P.char ':'
+ mi <- parseTwoDigits
+ _ <- P.char ':'
+ se <- parseTwoDigits
+ _ <- P.char 'Z'
+
+ utctDayTime <-
+ maybe (fail (show (ho, mi, se) ++ " is not valid time of day")) (return . timeOfDayToTime) $
+ makeTimeOfDayValid ho mi (realToFrac (se :: Int))
+
+ let utc = UTCTime{..}
+
+ maybe (fail (show utc ++ " is not representable as timestamp")) return $ utcTimeToTimestamp utc
+
+ parseTwoDigits = do
+ d1 <- P.satisfy isDigit
+ d2 <- P.satisfy isDigit
+ return (read [d1, d2])
+
+ -- A year must have at least 4 digits; e.g. "0097" is fine,
+ -- while "97" is not c.f. RFC3339 which
+ -- deprecates 2-digit years
+ parseYear = do
+ sign <- P.option ' ' (P.char '-')
+ ds <- P.munch1 isDigit
+ when (length ds < 4) $ fail "Year should have at least 4 digits"
+ return (read (sign : ds))
-- | Special timestamp value to be used when 'timestamp' is
-- missing/unknown/invalid
diff --git a/cabal-install/src/Distribution/Client/Init.hs b/cabal-install/src/Distribution/Client/Init.hs
index b217827f422c7f0aa5b3f8c4511ecfcf80eefe2a..1a8be086a3ff09f859f92bb10414c34ae6a23213 100644
--- a/cabal-install/src/Distribution/Client/Init.hs
+++ b/cabal-install/src/Distribution/Client/Init.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Init
-- Copyright : (c) Brent Yorgey 2009
@@ -10,43 +13,36 @@
--
-- Implementation of the 'cabal init' command, which creates an initial .cabal
-- file for a project.
---
------------------------------------------------------------------------------
-
-module Distribution.Client.Init
-( -- * Commands
- initCmd
-) where
+module Distribution.Client.Init (initCmd) where
+import Distribution.Client.IndexUtils
+import Distribution.Client.Init.FileCreators
import qualified Distribution.Client.Init.Interactive.Command as Interactive
import qualified Distribution.Client.Init.NonInteractive.Command as NonInteractive
import qualified Distribution.Client.Init.Simple as Simple
-import Distribution.Verbosity
+import Distribution.Client.Init.Types
import Distribution.Client.Setup (RepoContext)
import Distribution.Simple.Compiler
import Distribution.Simple.Program (ProgramDb)
-import Distribution.Client.Init.Types
import Distribution.Simple.Setup
-import Distribution.Client.IndexUtils
-import System.IO (hSetBuffering, stdout, BufferMode (NoBuffering))
-import Distribution.Client.Init.FileCreators
+import Distribution.Verbosity
+import System.IO (BufferMode (NoBuffering), hSetBuffering, stdout)
-- | This is the main driver for the init script.
---
initCmd
- :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> ProgramDb
- -> InitFlags
- -> IO ()
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> ProgramDb
+ -> InitFlags
+ -> IO ()
initCmd v packageDBs repoCtxt comp progdb initFlags = do
- installedPkgIndex <- getInstalledPackages v comp packageDBs progdb
- sourcePkgDb <- getSourcePackages v repoCtxt
- hSetBuffering stdout NoBuffering
- settings <- createProject v installedPkgIndex sourcePkgDb initFlags
- writeProject settings
+ installedPkgIndex <- getInstalledPackages v comp packageDBs progdb
+ sourcePkgDb <- getSourcePackages v repoCtxt
+ hSetBuffering stdout NoBuffering
+ settings <- createProject v installedPkgIndex sourcePkgDb initFlags
+ writeProject settings
where
-- When no flag is set, default to interactive.
--
@@ -60,5 +56,5 @@ initCmd v packageDBs repoCtxt comp progdb initFlags = do
| fromFlagOrDefault False (simpleProject initFlags) =
Simple.createProject
| otherwise = case interactive initFlags of
- Flag False -> NonInteractive.createProject comp
- _ -> Interactive.createProject
+ Flag False -> NonInteractive.createProject comp
+ _ -> Interactive.createProject
diff --git a/cabal-install/src/Distribution/Client/Init/Defaults.hs b/cabal-install/src/Distribution/Client/Init/Defaults.hs
index 8a695d7de1a9b20f73181f8e4c241ecaa67a4e7c..9be998feda79fea1dabc864488681b19a3160321 100644
--- a/cabal-install/src/Distribution/Client/Init/Defaults.hs
+++ b/cabal-install/src/Distribution/Client/Init/Defaults.hs
@@ -1,4 +1,7 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Init.Defaults
-- Copyright : (c) Brent Yorgey 2009
@@ -9,54 +12,50 @@
-- Portability : portable
--
-- Default values to use in cabal init (if not specified in config/flags).
---
------------------------------------------------------------------------------
module Distribution.Client.Init.Defaults
+ ( -- * default init values
+ defaultApplicationDir
+ , defaultSourceDir
+ , defaultCabalVersion
+ , defaultCabalVersions
+ , defaultPackageType
+ , defaultLicense
+ , defaultLicenseIds
+ , defaultMainIs
+ , defaultChangelog
+ , defaultCategories
+ , defaultInitFlags
+ , defaultLanguage
+ , defaultVersion
+ , defaultTestDir
+
+ -- * MyLib defaults
+ , myLibModule
+ , myLibTestFile
+ , myLibFile
+ , myLibHs
+ , myExeHs
+ , myLibExeHs
+ , myTestHs
+ ) where
-( -- * default init values
- defaultApplicationDir
-, defaultSourceDir
-, defaultCabalVersion
-, defaultCabalVersions
-, defaultPackageType
-, defaultLicense
-, defaultLicenseIds
-, defaultMainIs
-, defaultChangelog
-, defaultCategories
-, defaultInitFlags
-, defaultLanguage
-, defaultVersion
-, defaultTestDir
- -- * MyLib defaults
-, myLibModule
-, myLibTestFile
-, myLibFile
-, myLibHs
-, myExeHs
-, myLibExeHs
-, myTestHs
-) where
-
-
-import Distribution.ModuleName (ModuleName)
-import qualified Distribution.ModuleName as ModuleName(fromString)
import Distribution.CabalSpecVersion (CabalSpecVersion (..))
-import Distribution.Client.Init.Types (PackageType(..), InitFlags(..), HsFilePath, toHsFilePath)
+import Distribution.Client.Init.Types (HsFilePath, InitFlags (..), PackageType (..), toHsFilePath)
+import Distribution.FieldGrammar.Newtypes
+import Distribution.ModuleName (ModuleName)
+import qualified Distribution.ModuleName as ModuleName (fromString)
import qualified Distribution.SPDX.License as SPDX
import qualified Distribution.SPDX.LicenseId as SPDX
+import Distribution.Simple (Language (..), License (..))
import Distribution.Simple.Flag (toFlag)
-import Distribution.Verbosity (normal)
import Distribution.Types.Version
-import Distribution.FieldGrammar.Newtypes
-import Distribution.Simple (Language(..), License(..))
-
+import Distribution.Verbosity (normal)
-- -------------------------------------------------------------------- --
-- Default flag and init values
defaultVersion :: Version
-defaultVersion = mkVersion [0,1,0,0]
+defaultVersion = mkVersion [0, 1, 0, 0]
defaultApplicationDir :: String
defaultApplicationDir = "app"
@@ -79,7 +78,7 @@ defaultChangelog = "CHANGELOG.md"
defaultLicense :: CabalSpecVersion -> SpecLicense
defaultLicense csv
| csv < CabalSpecV2_2 = SpecLicense $ Right AllRightsReserved
- | otherwise = SpecLicense $ Left SPDX.NONE
+ | otherwise = SpecLicense $ Left SPDX.NONE
defaultMainIs :: HsFilePath
defaultMainIs = toHsFilePath "Main.hs"
@@ -89,57 +88,57 @@ defaultLanguage = Haskell2010
defaultLicenseIds :: [SPDX.LicenseId]
defaultLicenseIds =
- [ SPDX.BSD_2_Clause
- , SPDX.BSD_3_Clause
- , SPDX.Apache_2_0
- , SPDX.MIT
- , SPDX.MPL_2_0
- , SPDX.ISC
- , SPDX.GPL_2_0_only
- , SPDX.GPL_3_0_only
- , SPDX.LGPL_2_1_only
- , SPDX.LGPL_3_0_only
- , SPDX.AGPL_3_0_only
- , SPDX.GPL_2_0_or_later
- , SPDX.GPL_3_0_or_later
- , SPDX.LGPL_2_1_or_later
- , SPDX.LGPL_3_0_or_later
- , SPDX.AGPL_3_0_or_later
- ]
+ [ SPDX.BSD_2_Clause
+ , SPDX.BSD_3_Clause
+ , SPDX.Apache_2_0
+ , SPDX.MIT
+ , SPDX.MPL_2_0
+ , SPDX.ISC
+ , SPDX.GPL_2_0_only
+ , SPDX.GPL_3_0_only
+ , SPDX.LGPL_2_1_only
+ , SPDX.LGPL_3_0_only
+ , SPDX.AGPL_3_0_only
+ , SPDX.GPL_2_0_or_later
+ , SPDX.GPL_3_0_or_later
+ , SPDX.LGPL_2_1_or_later
+ , SPDX.LGPL_3_0_or_later
+ , SPDX.AGPL_3_0_or_later
+ ]
defaultCategories :: [String]
defaultCategories =
- [ "Codec"
- , "Concurrency"
- , "Control"
- , "Data"
- , "Database"
- , "Development"
- , "Distribution"
- , "Game"
- , "Graphics"
- , "Language"
- , "Math"
- , "Network"
- , "Sound"
- , "System"
- , "Testing"
- , "Text"
- , "Web"
- ]
+ [ "Codec"
+ , "Concurrency"
+ , "Control"
+ , "Data"
+ , "Database"
+ , "Development"
+ , "Distribution"
+ , "Game"
+ , "Graphics"
+ , "Language"
+ , "Math"
+ , "Network"
+ , "Sound"
+ , "System"
+ , "Testing"
+ , "Text"
+ , "Web"
+ ]
defaultCabalVersions :: [CabalSpecVersion]
defaultCabalVersions =
- [ CabalSpecV1_24
- , CabalSpecV2_0
- , CabalSpecV2_2
- , CabalSpecV2_4
- , CabalSpecV3_0
- , CabalSpecV3_4
- ]
+ [ CabalSpecV1_24
+ , CabalSpecV2_0
+ , CabalSpecV2_2
+ , CabalSpecV2_4
+ , CabalSpecV3_0
+ , CabalSpecV3_4
+ ]
defaultInitFlags :: InitFlags
-defaultInitFlags = mempty { initVerbosity = toFlag normal }
+defaultInitFlags = mempty{initVerbosity = toFlag normal}
-- -------------------------------------------------------------------- --
-- MyLib defaults
@@ -155,38 +154,40 @@ myLibFile = toHsFilePath "MyLib.hs"
-- | Default MyLib.hs file. Used when no Lib.hs exists.
myLibHs :: String
-myLibHs = unlines
- [ "module MyLib (someFunc) where"
- , ""
- , "someFunc :: IO ()"
- , "someFunc = putStrLn \"someFunc\""
- ]
+myLibHs =
+ unlines
+ [ "module MyLib (someFunc) where"
+ , ""
+ , "someFunc :: IO ()"
+ , "someFunc = putStrLn \"someFunc\""
+ ]
myExeHs :: [String]
myExeHs =
- [ "module Main where"
- , ""
- , "main :: IO ()"
- , "main = putStrLn \"Hello, Haskell!\""
- ]
+ [ "module Main where"
+ , ""
+ , "main :: IO ()"
+ , "main = putStrLn \"Hello, Haskell!\""
+ ]
myLibExeHs :: [String]
myLibExeHs =
- [ "module Main where"
- , ""
- , "import qualified MyLib (someFunc)"
- , ""
- , "main :: IO ()"
- , "main = do"
- , " putStrLn \"Hello, Haskell!\""
- , " MyLib.someFunc"
- ]
-
--- | Default MyLibTest.hs file.
-myTestHs :: String
-myTestHs = unlines
- [ "module Main (main) where"
+ [ "module Main where"
+ , ""
+ , "import qualified MyLib (someFunc)"
, ""
, "main :: IO ()"
- , "main = putStrLn \"Test suite not yet implemented.\""
+ , "main = do"
+ , " putStrLn \"Hello, Haskell!\""
+ , " MyLib.someFunc"
]
+
+-- | Default MyLibTest.hs file.
+myTestHs :: String
+myTestHs =
+ unlines
+ [ "module Main (main) where"
+ , ""
+ , "main :: IO ()"
+ , "main = putStrLn \"Test suite not yet implemented.\""
+ ]
diff --git a/cabal-install/src/Distribution/Client/Init/FileCreators.hs b/cabal-install/src/Distribution/Client/Init/FileCreators.hs
index 90846acaac0b29c4872aa0f38cfe1ab257dd3bc8..18ea0bc71a195af8d1c219c882e25a78c51b21fe 100644
--- a/cabal-install/src/Distribution/Client/Init/FileCreators.hs
+++ b/cabal-install/src/Distribution/Client/Init/FileCreators.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Init.FileCreators
-- Copyright : (c) Brent Yorgey 2009
@@ -11,51 +15,59 @@
-- Portability : portable
--
-- Functions to create files during 'cabal init'.
---
------------------------------------------------------------------------------
module Distribution.Client.Init.FileCreators
-( -- * Commands
- writeProject
-, writeLicense
-, writeChangeLog
-, prepareLibTarget
-, prepareExeTarget
-, prepareTestTarget
-) where
-
-import Prelude hiding (writeFile, readFile)
-import Distribution.Client.Compat.Prelude hiding (head, empty, writeFile, readFile)
+ ( -- * Commands
+ writeProject
+ , writeLicense
+ , writeChangeLog
+ , prepareLibTarget
+ , prepareExeTarget
+ , prepareTestTarget
+ ) where
+
+import Distribution.Client.Compat.Prelude hiding (empty, head, readFile, writeFile)
+import Prelude hiding (readFile, writeFile)
import qualified Data.Set as Set (member)
+import Distribution.CabalSpecVersion (showCabalSpecVersion)
import Distribution.Client.Init.Defaults
+import Distribution.Client.Init.Format
import Distribution.Client.Init.Licenses
- ( bsd2, bsd3, gplv2, gplv3, lgpl21, lgpl3, agplv3, apache20, mit, mpl20, isc )
-import Distribution.Client.Init.Types hiding (putStrLn, putStr, message)
+ ( agplv3
+ , apache20
+ , bsd2
+ , bsd3
+ , gplv2
+ , gplv3
+ , isc
+ , lgpl21
+ , lgpl3
+ , mit
+ , mpl20
+ )
+import Distribution.Client.Init.Types hiding (message, putStr, putStrLn)
import qualified Distribution.Client.Init.Types as T
-import Distribution.Fields.Pretty (PrettyField(..), showFields')
+import Distribution.Fields.Pretty (PrettyField (..), showFields')
import qualified Distribution.SPDX as SPDX
import Distribution.Types.PackageName
-import Distribution.Client.Init.Format
-import Distribution.CabalSpecVersion (showCabalSpecVersion)
-import System.FilePath ((</>), (<.>))
import Distribution.FieldGrammar.Newtypes
import Distribution.License (licenseToSPDX)
+import System.FilePath ((<.>), (</>))
-- -------------------------------------------------------------------- --
-- File generation
writeProject :: Interactive m => ProjectSettings -> m ()
writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget)
- | null pkgName = do
+ | null pkgName = do
message opts T.Error "no package name given, so no .cabal file can be generated\n"
- | otherwise = do
-
+ | otherwise = do
-- clear prompt history a bit"
- message opts T.Log
- $ "Using cabal specification: "
- ++ showCabalSpecVersion (_optCabalSpec opts)
+ message opts T.Log $
+ "Using cabal specification: "
+ ++ showCabalSpecVersion (_optCabalSpec opts)
writeLicense opts pkgDesc
writeChangeLog opts pkgDesc
@@ -67,8 +79,9 @@ writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget)
exeStanza <- prepareExeTarget opts exeTarget
testStanza <- prepareTestTarget opts testTarget
- (reusedCabal, cabalContents) <- writeCabalFile opts $
- pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]
+ (reusedCabal, cabalContents) <-
+ writeCabalFile opts $
+ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]
when (null $ _pkgSynopsis pkgDesc) $
message opts T.Warning "No synopsis given. You should edit the .cabal file and add one."
@@ -85,83 +98,85 @@ writeProject (ProjectSettings opts pkgDesc libTarget exeTarget testTarget)
where
pkgName = unPackageName $ _optPkgName opts
-
prepareLibTarget
- :: Interactive m
- => WriteOpts
- -> Maybe LibTarget
- -> m (PrettyField FieldAnnotation)
+ :: Interactive m
+ => WriteOpts
+ -> Maybe LibTarget
+ -> m (PrettyField FieldAnnotation)
prepareLibTarget _ Nothing = return PrettyEmpty
prepareLibTarget opts (Just libTarget) = do
- void $ writeDirectoriesSafe opts $ filter (/= ".") srcDirs
- -- avoid writing when conflicting exposed paths may
- -- exist.
- when (expMods == (myLibModule :| [])) . void $
- writeFileSafe opts libPath myLibHs
+ void $ writeDirectoriesSafe opts $ filter (/= ".") srcDirs
+ -- avoid writing when conflicting exposed paths may
+ -- exist.
+ when (expMods == (myLibModule :| [])) . void $
+ writeFileSafe opts libPath myLibHs
- return $ mkLibStanza opts libTarget
+ return $ mkLibStanza opts libTarget
where
expMods = _libExposedModules libTarget
srcDirs = _libSourceDirs libTarget
libPath = case srcDirs of
- path:_ -> path </> _hsFilePath myLibFile
+ path : _ -> path </> _hsFilePath myLibFile
_ -> _hsFilePath myLibFile
prepareExeTarget
- :: Interactive m
- => WriteOpts
- -> Maybe ExeTarget
- -> m (PrettyField FieldAnnotation)
+ :: Interactive m
+ => WriteOpts
+ -> Maybe ExeTarget
+ -> m (PrettyField FieldAnnotation)
prepareExeTarget _ Nothing = return PrettyEmpty
prepareExeTarget opts (Just exeTarget) = do
- void $ writeDirectoriesSafe opts appDirs
- void $ writeFileSafe opts mainPath mainHs
- return $ mkExeStanza opts exeTarget
+ void $ writeDirectoriesSafe opts appDirs
+ void $ writeFileSafe opts mainPath mainHs
+ return $ mkExeStanza opts exeTarget
where
exeMainIs = _exeMainIs exeTarget
pkgType = _optPkgType opts
appDirs = _exeApplicationDirs exeTarget
mainFile = _hsFilePath exeMainIs
mainPath = case appDirs of
- appPath:_ -> appPath </> mainFile
+ appPath : _ -> appPath </> mainFile
_ -> mainFile
- mainHs = unlines . mkLiterate exeMainIs $
- if pkgType == LibraryAndExecutable
- then myLibExeHs
- else myExeHs
+ mainHs =
+ unlines . mkLiterate exeMainIs $
+ if pkgType == LibraryAndExecutable
+ then myLibExeHs
+ else myExeHs
prepareTestTarget
- :: Interactive m
- => WriteOpts
- -> Maybe TestTarget
- -> m (PrettyField FieldAnnotation)
+ :: Interactive m
+ => WriteOpts
+ -> Maybe TestTarget
+ -> m (PrettyField FieldAnnotation)
prepareTestTarget _ Nothing = return PrettyEmpty
prepareTestTarget opts (Just testTarget) = do
- void $ writeDirectoriesSafe opts testDirs'
- void $ writeFileSafe opts testPath myTestHs
- return $ mkTestStanza opts testTarget
+ void $ writeDirectoriesSafe opts testDirs'
+ void $ writeFileSafe opts testPath myTestHs
+ return $ mkTestStanza opts testTarget
where
testDirs' = _testDirs testTarget
testMainIs = _hsFilePath $ _testMainIs testTarget
testPath = case testDirs' of
- p:_ -> p </> testMainIs
+ p : _ -> p </> testMainIs
_ -> testMainIs
writeCabalFile
- :: Interactive m
- => WriteOpts
- -> [PrettyField FieldAnnotation]
- -- ^ .cabal fields
- -> m (Bool, String)
+ :: Interactive m
+ => WriteOpts
+ -> [PrettyField FieldAnnotation]
+ -- ^ .cabal fields
+ -> m (Bool, String)
writeCabalFile opts fields = do
- let cabalContents = showFields'
+ let cabalContents =
+ showFields'
annCommentLines
postProcessFieldLines
- 4 fields
+ 4
+ fields
- reusedCabal <- writeFileSafe opts cabalFileName cabalContents
- return (reusedCabal, cabalContents)
+ reusedCabal <- writeFileSafe opts cabalFileName cabalContents
+ return (reusedCabal, cabalContents)
where
cabalFileName = pkgName ++ ".cabal"
pkgName = unPackageName $ _optPkgName opts
@@ -174,7 +189,6 @@ writeCabalFile opts fields = do
--
-- If the license type is unknown no license file will be prepared and
-- a warning will be raised.
---
writeLicense :: Interactive m => WriteOpts -> PkgDescription -> m ()
writeLicense writeOpts pkgDesc = do
year <- show <$> getCurrentYear
@@ -207,34 +221,35 @@ writeLicense writeOpts pkgDesc = do
_ -> Nothing
-- | Writes the changelog to the current directory.
---
writeChangeLog :: Interactive m => WriteOpts -> PkgDescription -> m ()
writeChangeLog opts pkgDesc
| Just docs <- _pkgExtraDocFiles pkgDesc
- , defaultChangelog `Set.member` docs = go
+ , defaultChangelog `Set.member` docs =
+ go
| defaultChangelog `elem` _pkgExtraSrcFiles pkgDesc = go
| otherwise = return ()
- where
- changeLog = unlines
- [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc)
- , ""
- , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd"
- , ""
- , "* First version. Released on an unsuspecting world."
- ]
-
- go =
- void $ writeFileSafe opts defaultChangelog changeLog
+ where
+ changeLog =
+ unlines
+ [ "# Revision history for " ++ prettyShow (_pkgName pkgDesc)
+ , ""
+ , "## " ++ prettyShow (_pkgVersion pkgDesc) ++ " -- YYYY-mm-dd"
+ , ""
+ , "* First version. Released on an unsuspecting world."
+ ]
+
+ go =
+ void $ writeFileSafe opts defaultChangelog changeLog
-- -------------------------------------------------------------------- --
-- Utilities
-data WriteAction = Overwrite | Fresh | Existing deriving Eq
+data WriteAction = Overwrite | Fresh | Existing deriving (Eq)
instance Show WriteAction where
show Overwrite = "Overwriting"
- show Fresh = "Creating fresh"
- show Existing = "Using existing"
+ show Fresh = "Creating fresh"
+ show Existing = "Using existing"
-- | Possibly generate a message to stdout, taking into account the
-- --quiet flag.
@@ -245,65 +260,67 @@ message opts = T.message (_optVerbosity opts)
-- the overwrite flag is set.
writeFileSafe :: Interactive m => WriteOpts -> FilePath -> String -> m Bool
writeFileSafe opts fileName content = do
- exists <- doesFileExist fileName
+ exists <- doesFileExist fileName
- let action
- | exists && doOverwrite = Overwrite
- | not exists = Fresh
- | otherwise = Existing
+ let action
+ | exists && doOverwrite = Overwrite
+ | not exists = Fresh
+ | otherwise = Existing
- go exists
+ go exists
- message opts T.Log $ show action ++ " file " ++ fileName ++ "..."
- return $ action == Existing
+ message opts T.Log $ show action ++ " file " ++ fileName ++ "..."
+ return $ action == Existing
where
doOverwrite = _optOverwrite opts
go exists
| not exists = do
- writeFile fileName content
+ writeFile fileName content
| exists && doOverwrite = do
- newName <- findNewPath fileName
- message opts T.Log $ concat
- [ fileName
- , " already exists. Backing up old version in "
- , newName
- ]
-
- copyFile fileName newName -- backups the old file
- removeExistingFile fileName -- removes the original old file
- writeFile fileName content -- writes the new file
+ newName <- findNewPath fileName
+ message opts T.Log $
+ concat
+ [ fileName
+ , " already exists. Backing up old version in "
+ , newName
+ ]
+
+ copyFile fileName newName -- backups the old file
+ removeExistingFile fileName -- removes the original old file
+ writeFile fileName content -- writes the new file
| otherwise = return ()
writeDirectoriesSafe :: Interactive m => WriteOpts -> [String] -> m Bool
writeDirectoriesSafe opts dirs = fmap or $ for dirs $ \dir -> do
- exists <- doesDirectoryExist dir
+ exists <- doesDirectoryExist dir
- let action
- | exists && doOverwrite = Overwrite
- | not exists = Fresh
- | otherwise = Existing
+ let action
+ | exists && doOverwrite = Overwrite
+ | not exists = Fresh
+ | otherwise = Existing
- go dir exists
+ go dir exists
- message opts T.Log $ show action ++ " directory ./" ++ dir ++ "..."
- return $ action == Existing
+ message opts T.Log $ show action ++ " directory ./" ++ dir ++ "..."
+ return $ action == Existing
where
doOverwrite = _optOverwrite opts
go dir exists
| not exists = do
- createDirectory dir
+ createDirectory dir
| exists && doOverwrite = do
- newDir <- findNewPath dir
- message opts T.Log $ concat
- [ dir
- , " already exists. Backing up old version in "
- , newDir
- ]
-
- renameDirectory dir newDir -- backups the old directory
- createDirectory dir -- creates the new directory
+ newDir <- findNewPath dir
+ message opts T.Log $
+ concat
+ [ dir
+ , " already exists. Backing up old version in "
+ , newDir
+ ]
+
+ renameDirectory dir newDir -- backups the old directory
+ createDirectory dir -- creates the new directory
| otherwise = return ()
findNewPath :: Interactive m => FilePath -> m FilePath
diff --git a/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs b/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs
index 8ddc6795a7d37d19c2cd8702e19033fd5f134c91..9e1ed191f94b93cf3ad82ee9f3042b5682659b3b 100644
--- a/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs
+++ b/cabal-install/src/Distribution/Client/Init/FlagExtractors.hs
@@ -1,67 +1,66 @@
{-# LANGUAGE LambdaCase #-}
-module Distribution.Client.Init.FlagExtractors
-( -- * Flag extractors
- getPackageDir
-, getSimpleProject
-, getMinimal
-, getCabalVersion
-, getCabalVersionNoPrompt
-, getPackageName
-, getVersion
-, getLicense
-, getAuthor
-, getEmail
-, getHomepage
-, getSynopsis
-, getCategory
-, getExtraSrcFiles
-, getExtraDocFiles
-, getPackageType
-, getMainFile
-, getInitializeTestSuite
-, getTestDirs
-, getLanguage
-, getNoComments
-, getAppDirs
-, getSrcDirs
-, getExposedModules
-, getBuildTools
-, getDependencies
-, getOtherExts
-, getOverwrite
-, getOtherModules
- -- * Shared prompts
-, simpleProjectPrompt
-, initializeTestSuitePrompt
-, packageTypePrompt
-, testMainPrompt
-, dependenciesPrompt
-) where
-
+module Distribution.Client.Init.FlagExtractors
+ ( -- * Flag extractors
+ getPackageDir
+ , getSimpleProject
+ , getMinimal
+ , getCabalVersion
+ , getCabalVersionNoPrompt
+ , getPackageName
+ , getVersion
+ , getLicense
+ , getAuthor
+ , getEmail
+ , getHomepage
+ , getSynopsis
+ , getCategory
+ , getExtraSrcFiles
+ , getExtraDocFiles
+ , getPackageType
+ , getMainFile
+ , getInitializeTestSuite
+ , getTestDirs
+ , getLanguage
+ , getNoComments
+ , getAppDirs
+ , getSrcDirs
+ , getExposedModules
+ , getBuildTools
+ , getDependencies
+ , getOtherExts
+ , getOverwrite
+ , getOtherModules
+
+ -- * Shared prompts
+ , simpleProjectPrompt
+ , initializeTestSuitePrompt
+ , packageTypePrompt
+ , testMainPrompt
+ , dependenciesPrompt
+ ) where
+
+import Distribution.Client.Compat.Prelude hiding (getLine, last, putStr, putStrLn)
import Prelude ()
-import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last)
import qualified Data.List.NonEmpty as NEL
-import Distribution.CabalSpecVersion (CabalSpecVersion(..))
-import Distribution.Version (Version)
-import Distribution.ModuleName (ModuleName)
-import Distribution.Types.Dependency (Dependency(..))
-import Distribution.Types.PackageName (PackageName)
+import Distribution.CabalSpecVersion (CabalSpecVersion (..))
import Distribution.Client.Init.Defaults
-import Distribution.FieldGrammar.Newtypes (SpecLicense)
import Distribution.Client.Init.Types
-import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault, flagToMaybe)
+import Distribution.FieldGrammar.Newtypes (SpecLicense)
+import Distribution.ModuleName (ModuleName)
import Distribution.Simple.Flag (flagElim)
+import Distribution.Simple.Setup (Flag (..), flagToMaybe, fromFlagOrDefault)
+import Distribution.Types.Dependency (Dependency (..))
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Version (Version)
-import Language.Haskell.Extension (Language(..), Extension(..))
-import Distribution.Client.Init.Prompt
import qualified Data.Set as Set
-import Distribution.Simple.PackageIndex
+import Distribution.Client.Init.Prompt
import Distribution.Client.Init.Utils
-
-
+import Distribution.Simple.PackageIndex
+import Language.Haskell.Extension (Extension (..), Language (..))
-- -------------------------------------------------------------------- --
-- Flag extraction
@@ -135,25 +134,28 @@ getExtraSrcFiles = pure . flagElim mempty Set.fromList . extraSrc
-- | Try to guess extra source files (don't prompt the user).
getExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set String))
-getExtraDocFiles = pure
- . Just
- . flagElim (Set.singleton defaultChangelog) Set.fromList
- . extraDoc
+getExtraDocFiles =
+ pure
+ . Just
+ . flagElim (Set.singleton defaultChangelog) Set.fromList
+ . extraDoc
-- | Ask whether the project builds a library or executable.
getPackageType :: Interactive m => InitFlags -> m PackageType -> m PackageType
-getPackageType InitFlags
- { initializeTestSuite = Flag True
- , packageType = NoFlag
- } _ = return TestSuite
+getPackageType
+ InitFlags
+ { initializeTestSuite = Flag True
+ , packageType = NoFlag
+ }
+ _ = return TestSuite
getPackageType flags act = fromFlagOrPrompt (packageType flags) act
getMainFile :: Interactive m => InitFlags -> m HsFilePath -> m HsFilePath
getMainFile flags act = case mainIs flags of
- Flag a
- | isHsFilePath a -> return $ toHsFilePath a
- | otherwise -> act
- NoFlag -> act
+ Flag a
+ | isHsFilePath a -> return $ toHsFilePath a
+ | otherwise -> act
+ NoFlag -> act
getInitializeTestSuite :: Interactive m => InitFlags -> m Bool -> m Bool
getInitializeTestSuite flags = fromFlagOrPrompt (initializeTestSuite flags)
@@ -179,7 +181,8 @@ getSrcDirs flags = fromFlagOrPrompt (sourceDirs flags)
-- | Retrieve the list of exposed modules
getExposedModules :: Interactive m => InitFlags -> m (NonEmpty ModuleName)
-getExposedModules = return
+getExposedModules =
+ return
. fromMaybe (myLibModule NEL.:| [])
. join
. flagToMaybe
@@ -204,46 +207,48 @@ getBuildTools = flagElim (return []) (foldM go []) . buildTools
-- | Retrieve the list of dependencies
getDependencies
- :: Interactive m
- => InitFlags
- -> m [Dependency]
- -> m [Dependency]
+ :: Interactive m
+ => InitFlags
+ -> m [Dependency]
+ -> m [Dependency]
getDependencies flags = fromFlagOrPrompt (dependencies flags)
-
-- | Retrieve the list of extensions
getOtherExts :: Interactive m => InitFlags -> m [Extension]
-getOtherExts = return . fromFlagOrDefault [] . otherExts
+getOtherExts = return . fromFlagOrDefault [] . otherExts
-- | Tell whether to overwrite files on write
---
getOverwrite :: Interactive m => InitFlags -> m Bool
-getOverwrite = return . fromFlagOrDefault False . overwrite
+getOverwrite = return . fromFlagOrDefault False . overwrite
-- -------------------------------------------------------------------- --
-- Shared prompts
simpleProjectPrompt :: Interactive m => InitFlags -> m Bool
-simpleProjectPrompt flags = getSimpleProject flags $
+simpleProjectPrompt flags =
+ getSimpleProject flags $
promptYesNo
"Should I generate a simple project with sensible defaults"
(DefaultPrompt True)
initializeTestSuitePrompt :: Interactive m => InitFlags -> m Bool
-initializeTestSuitePrompt flags = getInitializeTestSuite flags $
+initializeTestSuitePrompt flags =
+ getInitializeTestSuite flags $
promptYesNo
"Should I generate a test suite for the library"
(DefaultPrompt True)
packageTypePrompt :: Interactive m => InitFlags -> m PackageType
packageTypePrompt flags = getPackageType flags $ do
- pt <- promptList "What does the package build"
+ pt <-
+ promptList
+ "What does the package build"
packageTypes
(DefaultPrompt "Executable")
Nothing
False
- return $ fromMaybe Executable (parsePackageType pt)
+ return $ fromMaybe Executable (parsePackageType pt)
where
packageTypes =
[ "Library"
@@ -261,31 +266,34 @@ packageTypePrompt flags = getPackageType flags $ do
testMainPrompt :: Interactive m => m HsFilePath
testMainPrompt = do
- fp <- promptList "What is the main module of the test suite?"
+ fp <-
+ promptList
+ "What is the main module of the test suite?"
[defaultMainIs', "Main.lhs"]
(DefaultPrompt defaultMainIs')
Nothing
True
- let hs = toHsFilePath fp
+ let hs = toHsFilePath fp
- case _hsFileType hs of
- InvalidHsPath -> do
- putStrLn $ concat
+ case _hsFileType hs of
+ InvalidHsPath -> do
+ putStrLn $
+ concat
[ "Main file "
, show hs
, " is not a valid haskell file. Source files must end in .hs or .lhs."
]
- testMainPrompt
- _ -> return hs
+ testMainPrompt
+ _ -> return hs
where
defaultMainIs' = show defaultMainIs
dependenciesPrompt
- :: Interactive m
- => InstalledPackageIndex
- -> InitFlags
- -> m [Dependency]
+ :: Interactive m
+ => InstalledPackageIndex
+ -> InitFlags
+ -> m [Dependency]
dependenciesPrompt pkgIx flags = getDependencies flags (getBaseDep pkgIx flags)
-- -------------------------------------------------------------------- --
@@ -293,10 +301,9 @@ dependenciesPrompt pkgIx flags = getDependencies flags (getBaseDep pkgIx flags)
-- | If a flag is defined, return its value or else execute
-- an interactive action.
---
fromFlagOrPrompt
- :: Interactive m
- => Flag a
- -> m a
- -> m a
+ :: Interactive m
+ => Flag a
+ -> m a
+ -> m a
fromFlagOrPrompt flag action = flagElim action return flag
diff --git a/cabal-install/src/Distribution/Client/Init/Format.hs b/cabal-install/src/Distribution/Client/Init/Format.hs
index 48eab2ce1a248bf0e9852cf6352bd56db8ee6f66..d2ed5a8c873ec484dd4a49c6eff9397ed865709a 100644
--- a/cabal-install/src/Distribution/Client/Init/Format.hs
+++ b/cabal-install/src/Distribution/Client/Init/Format.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+
-- |
-- Module : Distribution.Client.Init.Format
-- Copyright : (c) Brent Yorgey 2009
@@ -9,66 +10,68 @@
-- Portability : portable
--
-- Pretty printing and field formatting utilities used for file creation.
---
module Distribution.Client.Init.Format
-( -- * cabal file formatters
- listFieldS
-, field
-, fieldD
-, commentedOutWithComments
-, withComments
-, annNoComments
-, postProcessFieldLines
- -- * stanza generation
-, mkCommonStanza
-, mkLibStanza
-, mkExeStanza
-, mkTestStanza
-, mkPkgDescription
-) where
-
+ ( -- * cabal file formatters
+ listFieldS
+ , field
+ , fieldD
+ , commentedOutWithComments
+ , withComments
+ , annNoComments
+ , postProcessFieldLines
+
+ -- * stanza generation
+ , mkCommonStanza
+ , mkLibStanza
+ , mkExeStanza
+ , mkTestStanza
+ , mkPkgDescription
+ ) where
-import Distribution.Pretty
-import Distribution.Fields
+import Distribution.CabalSpecVersion
import Distribution.Client.Init.Types
+import Distribution.FieldGrammar.Newtypes (SpecLicense (SpecLicense))
+import Distribution.Fields
import Distribution.License
-import Text.PrettyPrint
-import Distribution.Solver.Compat.Prelude hiding (empty)
+import Distribution.Package (unPackageName)
import Distribution.PackageDescription.FieldGrammar
+import Distribution.Pretty
+import qualified Distribution.SPDX.License as SPDX
import Distribution.Simple.Utils hiding (cabalVersion)
+import Distribution.Solver.Compat.Prelude hiding (empty)
import Distribution.Utils.Path
-import Distribution.Package (unPackageName)
-import qualified Distribution.SPDX.License as SPDX
-import Distribution.CabalSpecVersion
-import Distribution.FieldGrammar.Newtypes (SpecLicense(SpecLicense))
-
+import Text.PrettyPrint
-- | Construct a 'PrettyField' from a field that can be automatically
-- converted to a 'Doc' via 'display'.
field
- :: Pretty b
- => FieldName
- -> (a -> b)
- -> a
- -> [String]
- -> Bool
- -> WriteOpts
- -> PrettyField FieldAnnotation
+ :: Pretty b
+ => FieldName
+ -> (a -> b)
+ -> a
+ -> [String]
+ -> Bool
+ -> WriteOpts
+ -> PrettyField FieldAnnotation
field fieldName modifier fieldContents =
- fieldD fieldName (pretty $ modifier fieldContents)
+ fieldD fieldName (pretty $ modifier fieldContents)
-- | Construct a 'PrettyField' from a 'Doc' Flag.
fieldD
- :: FieldName -- ^ Name of the field
- -> Doc -- ^ Field contents
- -> [String] -- ^ Comment to explain the field
- -> Bool -- ^ Should the field be included (commented out) even if blank?
- -> WriteOpts
- -> PrettyField FieldAnnotation
+ :: FieldName
+ -- ^ Name of the field
+ -> Doc
+ -- ^ Field contents
+ -> [String]
+ -- ^ Comment to explain the field
+ -> Bool
+ -- ^ Should the field be included (commented out) even if blank?
+ -> WriteOpts
+ -> PrettyField FieldAnnotation
fieldD fieldName fieldContents fieldComments includeField opts
- -- If the "--no-comments" or "--minimal" flag is set, strip comments.
- | hasNoComments || isMinimal = contents NoComment
- | otherwise = contents $ commentPositionFor fieldName fieldComments
+ -- If the "--no-comments" or "--minimal" flag is set, strip comments.
+ | hasNoComments || isMinimal = contents NoComment
+ | otherwise = contents $ commentPositionFor fieldName fieldComments
where
commentPositionFor fn
| fn == "cabal-version" = CommentAfter
@@ -78,32 +81,32 @@ fieldD fieldName fieldContents fieldComments includeField opts
hasNoComments = _optNoComments opts
contents
- -- If there is no content, optionally produce a commented out field.
+ -- If there is no content, optionally produce a commented out field.
| fieldContents == empty = fieldSEmptyContents
- | otherwise = fieldSWithContents
+ | otherwise = fieldSWithContents
fieldSEmptyContents cs
| not includeField || isMinimal = PrettyEmpty
- | otherwise = PrettyField
- (commentedOutWithComments cs)
- fieldName
- empty
+ | otherwise =
+ PrettyField
+ (commentedOutWithComments cs)
+ fieldName
+ empty
fieldSWithContents cs =
PrettyField (withComments cs) fieldName fieldContents
-
-- | A field annotation instructing the pretty printer to comment out the field
-- and any contents, with no comments.
commentedOutWithComments :: CommentPosition -> FieldAnnotation
commentedOutWithComments (CommentBefore cs) = FieldAnnotation True . CommentBefore $ map commentNoTrailing cs
-commentedOutWithComments (CommentAfter cs) = FieldAnnotation True . CommentAfter $ map commentNoTrailing cs
+commentedOutWithComments (CommentAfter cs) = FieldAnnotation True . CommentAfter $ map commentNoTrailing cs
commentedOutWithComments NoComment = FieldAnnotation True NoComment
-- | A field annotation with the specified comment lines.
withComments :: CommentPosition -> FieldAnnotation
withComments (CommentBefore cs) = FieldAnnotation False . CommentBefore $ map commentNoTrailing cs
-withComments (CommentAfter cs) = FieldAnnotation False . CommentAfter $ map commentNoTrailing cs
+withComments (CommentAfter cs) = FieldAnnotation False . CommentAfter $ map commentNoTrailing cs
withComments NoComment = FieldAnnotation False NoComment
-- | A field annotation with no comments.
@@ -123,162 +126,231 @@ postProcessFieldLines ann
mkCommonStanza :: WriteOpts -> PrettyField FieldAnnotation
mkCommonStanza opts = case specHasCommonStanzas $ _optCabalSpec opts of
NoCommonStanzas -> PrettyEmpty
- _ -> PrettySection
- annNoComments
- "common"
- [text "warnings"]
- [field "ghc-options" text "-Wall" [] False opts]
+ _ ->
+ PrettySection
+ annNoComments
+ "common"
+ [text "warnings"]
+ [field "ghc-options" text "-Wall" [] False opts]
mkLibStanza :: WriteOpts -> LibTarget -> PrettyField FieldAnnotation
mkLibStanza opts (LibTarget srcDirs lang expMods otherMods exts deps tools) =
- PrettySection annNoComments (toUTF8BS "library") []
+ PrettySection
+ annNoComments
+ (toUTF8BS "library")
+ []
[ case specHasCommonStanzas $ _optCabalSpec opts of
NoCommonStanzas -> PrettyEmpty
- _ -> field "import" (hsep . map text) ["warnings"]
- ["Import common warning flags."]
- False
- opts
-
- , field "exposed-modules" formatExposedModules (toList expMods)
- ["Modules exported by the library."]
- True
- opts
-
- , field "other-modules" formatOtherModules otherMods
- ["Modules included in this library but not exported."]
- True
- opts
-
- , field "other-extensions" formatOtherExtensions exts
- ["LANGUAGE extensions used by modules in this package."]
- True
- opts
-
- , field "build-depends" formatDependencyList deps
- ["Other library packages from which modules are imported."]
- True
- opts
-
- , field "hs-source-dirs" formatHsSourceDirs (unsafeMakeSymbolicPath <$> srcDirs)
- ["Directories containing source files."]
- True
- opts
-
- , field (buildToolTag opts) formatDependencyList tools
- ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]
- False
- opts
-
- , field "default-language" id lang
- ["Base language which the package is written in."]
- True
- opts
+ _ ->
+ field
+ "import"
+ (hsep . map text)
+ ["warnings"]
+ ["Import common warning flags."]
+ False
+ opts
+ , field
+ "exposed-modules"
+ formatExposedModules
+ (toList expMods)
+ ["Modules exported by the library."]
+ True
+ opts
+ , field
+ "other-modules"
+ formatOtherModules
+ otherMods
+ ["Modules included in this library but not exported."]
+ True
+ opts
+ , field
+ "other-extensions"
+ formatOtherExtensions
+ exts
+ ["LANGUAGE extensions used by modules in this package."]
+ True
+ opts
+ , field
+ "build-depends"
+ formatDependencyList
+ deps
+ ["Other library packages from which modules are imported."]
+ True
+ opts
+ , field
+ "hs-source-dirs"
+ formatHsSourceDirs
+ (unsafeMakeSymbolicPath <$> srcDirs)
+ ["Directories containing source files."]
+ True
+ opts
+ , field
+ (buildToolTag opts)
+ formatDependencyList
+ tools
+ ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]
+ False
+ opts
+ , field
+ "default-language"
+ id
+ lang
+ ["Base language which the package is written in."]
+ True
+ opts
]
mkExeStanza :: WriteOpts -> ExeTarget -> PrettyField FieldAnnotation
mkExeStanza opts (ExeTarget exeMain appDirs lang otherMods exts deps tools) =
- PrettySection annNoComments (toUTF8BS "executable") [exeName]
- [ case specHasCommonStanzas $ _optCabalSpec opts of
- NoCommonStanzas -> PrettyEmpty
- _ -> field "import" (hsep . map text) ["warnings"]
+ PrettySection
+ annNoComments
+ (toUTF8BS "executable")
+ [exeName]
+ [ case specHasCommonStanzas $ _optCabalSpec opts of
+ NoCommonStanzas -> PrettyEmpty
+ _ ->
+ field
+ "import"
+ (hsep . map text)
+ ["warnings"]
["Import common warning flags."]
False
opts
-
- , field "main-is" unsafeFromHs exeMain
- [".hs or .lhs file containing the Main module."]
- True
+ , field
+ "main-is"
+ unsafeFromHs
+ exeMain
+ [".hs or .lhs file containing the Main module."]
+ True
opts
-
- , field "other-modules" formatOtherModules otherMods
- [ "Modules included in this executable, other than Main." ]
+ , field
+ "other-modules"
+ formatOtherModules
+ otherMods
+ ["Modules included in this executable, other than Main."]
True
opts
-
- , field "other-extensions" formatOtherExtensions exts
+ , field
+ "other-extensions"
+ formatOtherExtensions
+ exts
["LANGUAGE extensions used by modules in this package."]
True
opts
- , field "build-depends" formatDependencyList deps
+ , field
+ "build-depends"
+ formatDependencyList
+ deps
["Other library packages from which modules are imported."]
True
opts
-
- , field "hs-source-dirs" formatHsSourceDirs
+ , field
+ "hs-source-dirs"
+ formatHsSourceDirs
(unsafeMakeSymbolicPath <$> appDirs)
["Directories containing source files."]
True
opts
-
- , field (buildToolTag opts) formatDependencyList tools
+ , field
+ (buildToolTag opts)
+ formatDependencyList
+ tools
["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]
False
opts
-
- , field "default-language" id lang
+ , field
+ "default-language"
+ id
+ lang
["Base language which the package is written in."]
True
opts
- ]
- where
- exeName = pretty $ _optPkgName opts
+ ]
+ where
+ exeName = pretty $ _optPkgName opts
mkTestStanza :: WriteOpts -> TestTarget -> PrettyField FieldAnnotation
mkTestStanza opts (TestTarget testMain dirs lang otherMods exts deps tools) =
- PrettySection annNoComments (toUTF8BS "test-suite") [suiteName]
- [ case specHasCommonStanzas $ _optCabalSpec opts of
- NoCommonStanzas -> PrettyEmpty
- _ -> field "import" (hsep . map text) ["warnings"]
- ["Import common warning flags."]
- False
- opts
-
- , field "default-language" id lang
- ["Base language which the package is written in."]
- True
- opts
- , field "other-modules" formatOtherModules otherMods
- [ "Modules included in this executable, other than Main." ]
- True
- opts
-
- , field "other-extensions" formatOtherExtensions exts
- ["LANGUAGE extensions used by modules in this package."]
- True
- opts
-
- , field "type" text "exitcode-stdio-1.0"
- ["The interface type and version of the test suite."]
- True
- opts
-
- , field "hs-source-dirs" formatHsSourceDirs
- (unsafeMakeSymbolicPath <$> dirs)
- ["Directories containing source files."]
- True
- opts
-
- , field "main-is" unsafeFromHs testMain
- ["The entrypoint to the test suite."]
- True
- opts
-
- , field "build-depends" formatDependencyList deps
- ["Test dependencies."]
- True
- opts
-
- , field (buildToolTag opts) formatDependencyList tools
- ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]
- False
- opts
- ]
- where
- suiteName = text $ unPackageName (_optPkgName opts) ++ "-test"
+ PrettySection
+ annNoComments
+ (toUTF8BS "test-suite")
+ [suiteName]
+ [ case specHasCommonStanzas $ _optCabalSpec opts of
+ NoCommonStanzas -> PrettyEmpty
+ _ ->
+ field
+ "import"
+ (hsep . map text)
+ ["warnings"]
+ ["Import common warning flags."]
+ False
+ opts
+ , field
+ "default-language"
+ id
+ lang
+ ["Base language which the package is written in."]
+ True
+ opts
+ , field
+ "other-modules"
+ formatOtherModules
+ otherMods
+ ["Modules included in this executable, other than Main."]
+ True
+ opts
+ , field
+ "other-extensions"
+ formatOtherExtensions
+ exts
+ ["LANGUAGE extensions used by modules in this package."]
+ True
+ opts
+ , field
+ "type"
+ text
+ "exitcode-stdio-1.0"
+ ["The interface type and version of the test suite."]
+ True
+ opts
+ , field
+ "hs-source-dirs"
+ formatHsSourceDirs
+ (unsafeMakeSymbolicPath <$> dirs)
+ ["Directories containing source files."]
+ True
+ opts
+ , field
+ "main-is"
+ unsafeFromHs
+ testMain
+ ["The entrypoint to the test suite."]
+ True
+ opts
+ , field
+ "build-depends"
+ formatDependencyList
+ deps
+ ["Test dependencies."]
+ True
+ opts
+ , field
+ (buildToolTag opts)
+ formatDependencyList
+ tools
+ ["Extra tools (e.g. alex, hsc2hs, ...) needed to build the source."]
+ False
+ opts
+ ]
+ where
+ suiteName = text $ unPackageName (_optPkgName opts) ++ "-test"
mkPkgDescription :: WriteOpts -> PkgDescription -> [PrettyField FieldAnnotation]
mkPkgDescription opts pkgDesc =
- [ field "cabal-version" text ((if cabalSpec < CabalSpecV1_12 then ">=" else "") ++ showCabalSpecVersion cabalSpec)
+ [ field
+ "cabal-version"
+ text
+ ((if cabalSpec < CabalSpecV1_12 then ">=" else "") ++ showCabalSpecVersion cabalSpec)
[ "The cabal-version field refers to the version of the .cabal specification,"
, "and can be different from the cabal-install (the tool) version and the"
, "Cabal (the library) version you are using. As such, the Cabal (the library)"
@@ -288,9 +360,11 @@ mkPkgDescription opts pkgDesc =
]
False
opts
-
- , field "name" pretty (_pkgName pkgDesc)
- ["Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by"
+ , field
+ "name"
+ pretty
+ (_pkgName pkgDesc)
+ [ "Initial package description '" ++ prettyShow (_optPkgName opts) ++ "' generated by"
, "'cabal init'. For further documentation, see:"
, " http://haskell.org/cabal/users-guide/"
, ""
@@ -298,88 +372,120 @@ mkPkgDescription opts pkgDesc =
]
True
opts
-
- , field "version" pretty (_pkgVersion pkgDesc)
- ["The package version.",
- "See the Haskell package versioning policy (PVP) for standards",
- "guiding when and how versions should be incremented.",
- "https://pvp.haskell.org",
- "PVP summary: +-+------- breaking API changes",
- " | | +----- non-breaking API additions",
- " | | | +--- code changes with no API change"]
+ , field
+ "version"
+ pretty
+ (_pkgVersion pkgDesc)
+ [ "The package version."
+ , "See the Haskell package versioning policy (PVP) for standards"
+ , "guiding when and how versions should be incremented."
+ , "https://pvp.haskell.org"
+ , "PVP summary: +-+------- breaking API changes"
+ , " | | +----- non-breaking API additions"
+ , " | | | +--- code changes with no API change"
+ ]
True
opts
-
- , field "synopsis" text (_pkgSynopsis pkgDesc)
+ , field
+ "synopsis"
+ text
+ (_pkgSynopsis pkgDesc)
["A short (one-line) description of the package."]
True
opts
-
- , field "description" text ""
+ , field
+ "description"
+ text
+ ""
["A longer description of the package."]
True
opts
-
- , field "homepage" text (_pkgHomePage pkgDesc)
+ , field
+ "homepage"
+ text
+ (_pkgHomePage pkgDesc)
["URL for the project homepage or repository."]
False
opts
-
- , field "bug-reports" text ""
+ , field
+ "bug-reports"
+ text
+ ""
["A URL where users can report bugs."]
False
opts
-
- , field "license" pretty (_pkgLicense pkgDesc)
+ , field
+ "license"
+ pretty
+ (_pkgLicense pkgDesc)
["The license under which the package is released."]
True
opts
-
- , case _pkgLicense pkgDesc of
- SpecLicense (Left SPDX.NONE) -> PrettyEmpty
- SpecLicense (Right AllRightsReserved) -> PrettyEmpty
- SpecLicense (Right UnspecifiedLicense) -> PrettyEmpty
- _ -> field "license-file" text "LICENSE"
- ["The file containing the license text."]
- False
- opts
-
- , field "author" text (_pkgAuthor pkgDesc)
+ , case _pkgLicense pkgDesc of
+ SpecLicense (Left SPDX.NONE) -> PrettyEmpty
+ SpecLicense (Right AllRightsReserved) -> PrettyEmpty
+ SpecLicense (Right UnspecifiedLicense) -> PrettyEmpty
+ _ ->
+ field
+ "license-file"
+ text
+ "LICENSE"
+ ["The file containing the license text."]
+ False
+ opts
+ , field
+ "author"
+ text
+ (_pkgAuthor pkgDesc)
["The package author(s)."]
True
opts
-
- , field "maintainer" text (_pkgEmail pkgDesc)
+ , field
+ "maintainer"
+ text
+ (_pkgEmail pkgDesc)
["An email address to which users can send suggestions, bug reports, and patches."]
True
opts
-
- , field "copyright" text ""
+ , field
+ "copyright"
+ text
+ ""
["A copyright notice."]
True
opts
-
- , field "category" text (_pkgCategory pkgDesc)
+ , field
+ "category"
+ text
+ (_pkgCategory pkgDesc)
[]
False
opts
- , field "build-type" text "Simple"
+ , field
+ "build-type"
+ text
+ "Simple"
[]
False
opts
- , case _pkgExtraDocFiles pkgDesc of
- Nothing -> PrettyEmpty
- Just fs ->
- field "extra-doc-files" formatExtraSourceFiles (toList fs)
+ , case _pkgExtraDocFiles pkgDesc of
+ Nothing -> PrettyEmpty
+ Just fs ->
+ field
+ "extra-doc-files"
+ formatExtraSourceFiles
+ (toList fs)
["Extra doc files to be distributed with the package, such as a CHANGELOG or a README."]
True
opts
-
- , field "extra-source-files" formatExtraSourceFiles (toList $ _pkgExtraSrcFiles pkgDesc)
+ , field
+ "extra-source-files"
+ formatExtraSourceFiles
+ (toList $ _pkgExtraSrcFiles pkgDesc)
["Extra source files to be distributed with the package, such as examples, or a tutorial module."]
True
opts
- ]
+ ]
where
cabalSpec = _pkgCabalVersion pkgDesc
@@ -399,4 +505,4 @@ buildToolTag opts
commentNoTrailing :: String -> String
commentNoTrailing "" = "--"
-commentNoTrailing c = "-- " ++ c
+commentNoTrailing c = "-- " ++ c
diff --git a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs
index bf27eb301181072bb10706ec3a5a0251196738db..2fab0db25ccbda2997ffd73b4aa4f2632382c61b 100644
--- a/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs
+++ b/cabal-install/src/Distribution/Client/Init/Interactive/Command.hs
@@ -1,5 +1,10 @@
-{-# LANGUAGE LambdaCase, MultiWayIf #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Init.Command
-- Copyright : (c) Brent Yorgey 2009
@@ -11,71 +16,67 @@
--
-- Implementation of the 'cabal init' command, which creates an initial .cabal
-- file for a project.
---
------------------------------------------------------------------------------
module Distribution.Client.Init.Interactive.Command
-( -- * Commands
- createProject
- -- ** Target generation
-, genPkgDescription
-, genLibTarget
-, genExeTarget
-, genTestTarget
- -- ** Prompts
-, cabalVersionPrompt
-, packageNamePrompt
-, versionPrompt
-, licensePrompt
-, authorPrompt
-, emailPrompt
-, homepagePrompt
-, synopsisPrompt
-, categoryPrompt
-, mainFilePrompt
-, testDirsPrompt
-, languagePrompt
-, noCommentsPrompt
-, appDirsPrompt
-, dependenciesPrompt
-, srcDirsPrompt
-) where
-
-
+ ( -- * Commands
+ createProject
+
+ -- ** Target generation
+ , genPkgDescription
+ , genLibTarget
+ , genExeTarget
+ , genTestTarget
+
+ -- ** Prompts
+ , cabalVersionPrompt
+ , packageNamePrompt
+ , versionPrompt
+ , licensePrompt
+ , authorPrompt
+ , emailPrompt
+ , homepagePrompt
+ , synopsisPrompt
+ , categoryPrompt
+ , mainFilePrompt
+ , testDirsPrompt
+ , languagePrompt
+ , noCommentsPrompt
+ , appDirsPrompt
+ , dependenciesPrompt
+ , srcDirsPrompt
+ ) where
+
+import Distribution.Client.Compat.Prelude hiding (getLine, last, putStr, putStrLn)
import Prelude ()
-import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last)
-import Distribution.CabalSpecVersion (CabalSpecVersion(..), showCabalSpecVersion)
-import Distribution.Version (Version)
-import Distribution.Types.PackageName (PackageName, unPackageName)
-import qualified Distribution.SPDX as SPDX
+import Distribution.CabalSpecVersion (CabalSpecVersion (..), showCabalSpecVersion)
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.FlagExtractors
+import Distribution.Client.Init.NonInteractive.Heuristics (guessAuthorEmail, guessAuthorName)
import Distribution.Client.Init.Prompt
import Distribution.Client.Init.Types
import Distribution.Client.Init.Utils
-import Distribution.Client.Init.NonInteractive.Heuristics (guessAuthorName, guessAuthorEmail)
-import Distribution.FieldGrammar.Newtypes (SpecLicense(..))
-import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault)
+import Distribution.Client.Types (SourcePackageDb (..))
+import Distribution.FieldGrammar.Newtypes (SpecLicense (..))
+import qualified Distribution.SPDX as SPDX
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import Distribution.Client.Types (SourcePackageDb(..))
+import Distribution.Simple.Setup (Flag (..), fromFlagOrDefault)
import Distribution.Solver.Types.PackageIndex (elemByPackageName)
+import Distribution.Types.PackageName (PackageName, unPackageName)
+import Distribution.Version (Version)
-import Language.Haskell.Extension (Language(..))
import Distribution.License (knownLicenses)
import Distribution.Parsec (simpleParsec')
-
+import Language.Haskell.Extension (Language (..))
-- | Main driver for interactive prompt code.
---
createProject
- :: Interactive m
- => Verbosity
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> InitFlags
- -> m ProjectSettings
+ :: Interactive m
+ => Verbosity
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> InitFlags
+ -> m ProjectSettings
createProject v pkgIx srcDb initFlags = do
-
-- The workflow is as follows:
--
-- 1. Get the package type, supplied as either a program input or
@@ -101,59 +102,81 @@ createProject v pkgIx srcDb initFlags = do
let pkgName = _pkgName pkgDesc
cabalSpec = _pkgCabalVersion pkgDesc
- mkOpts cs = WriteOpts
- doOverwrite isMinimal cs
- v pkgDir pkgType pkgName
- initFlags' = initFlags { cabalVersion = Flag cabalSpec }
+ mkOpts cs =
+ WriteOpts
+ doOverwrite
+ isMinimal
+ cs
+ v
+ pkgDir
+ pkgType
+ pkgName
+ initFlags' = initFlags{cabalVersion = Flag cabalSpec}
case pkgType of
Library -> do
libTarget <- genLibTarget initFlags' pkgIx
- testTarget <- addLibDepToTest pkgName <$>
- genTestTarget initFlags' pkgIx
+ testTarget <-
+ addLibDepToTest pkgName
+ <$> genTestTarget initFlags' pkgIx
comments <- noCommentsPrompt initFlags'
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc
- (Just libTarget) Nothing testTarget
-
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ (Just libTarget)
+ Nothing
+ testTarget
Executable -> do
exeTarget <- genExeTarget initFlags' pkgIx
comments <- noCommentsPrompt initFlags'
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc Nothing
- (Just exeTarget) Nothing
-
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ Nothing
+ (Just exeTarget)
+ Nothing
LibraryAndExecutable -> do
libTarget <- genLibTarget initFlags' pkgIx
- exeTarget <- addLibDepToExe pkgName <$>
- genExeTarget initFlags' pkgIx
+ exeTarget <-
+ addLibDepToExe pkgName
+ <$> genExeTarget initFlags' pkgIx
- testTarget <- addLibDepToTest pkgName <$>
- genTestTarget initFlags' pkgIx
+ testTarget <-
+ addLibDepToTest pkgName
+ <$> genTestTarget initFlags' pkgIx
comments <- noCommentsPrompt initFlags'
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc (Just libTarget)
- (Just exeTarget) testTarget
-
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ (Just libTarget)
+ (Just exeTarget)
+ testTarget
TestSuite -> do
-- the line below is necessary because if both package type and test flags
-- are *not* passed, the user will be prompted for a package type (which
-- includes TestSuite in the list). It prevents that the user end up with a
-- TestSuite target with initializeTestSuite set to NoFlag, thus avoiding the prompt.
- let initFlags'' = initFlags' { initializeTestSuite = Flag True }
+ let initFlags'' = initFlags'{initializeTestSuite = Flag True}
testTarget <- genTestTarget initFlags'' pkgIx
comments <- noCommentsPrompt initFlags''
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc
- Nothing Nothing testTarget
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ Nothing
+ Nothing
+ testTarget
-- -------------------------------------------------------------------- --
-- Target and pkg description generation
@@ -162,15 +185,14 @@ createProject v pkgIx srcDb initFlags = do
-- generate a 'PkgDescription' object for creation. If the user specifies
-- the generation of a simple package, then a simple target with defaults
-- is generated.
---
genPkgDescription
- :: Interactive m
- => InitFlags
- -> SourcePackageDb
- -> m PkgDescription
+ :: Interactive m
+ => InitFlags
+ -> SourcePackageDb
+ -> m PkgDescription
genPkgDescription flags' srcDb = do
csv <- cabalVersionPrompt flags'
- let flags = flags' { cabalVersion = Flag csv }
+ let flags = flags'{cabalVersion = Flag csv}
PkgDescription csv
<$> packageNamePrompt srcDb flags
<*> versionPrompt flags
@@ -187,13 +209,13 @@ genPkgDescription flags' srcDb = do
-- generate a 'LibTarget' object for creation. If the user specifies
-- the generation of a simple package, then a simple target with defaults
-- is generated.
---
genLibTarget
- :: Interactive m
- => InitFlags
- -> InstalledPackageIndex
- -> m LibTarget
-genLibTarget flags pkgs = LibTarget
+ :: Interactive m
+ => InitFlags
+ -> InstalledPackageIndex
+ -> m LibTarget
+genLibTarget flags pkgs =
+ LibTarget
<$> srcDirsPrompt flags
<*> languagePrompt flags "library"
<*> getExposedModules flags
@@ -206,13 +228,13 @@ genLibTarget flags pkgs = LibTarget
-- generate a 'ExeTarget' object for creation. If the user specifies
-- the generation of a simple package, then a simple target with defaults
-- is generated.
---
genExeTarget
- :: Interactive m
- => InitFlags
- -> InstalledPackageIndex
- -> m ExeTarget
-genExeTarget flags pkgs = ExeTarget
+ :: Interactive m
+ => InitFlags
+ -> InstalledPackageIndex
+ -> m ExeTarget
+genExeTarget flags pkgs =
+ ExeTarget
<$> mainFilePrompt flags
<*> appDirsPrompt flags
<*> languagePrompt flags "executable"
@@ -229,25 +251,25 @@ genExeTarget flags pkgs = ExeTarget
-- Note: this workflow is only enabled if the user answers affirmatively
-- when prompted, or if the user passes in the flag to enable
-- test suites at command line.
---
genTestTarget
- :: Interactive m
- => InitFlags
- -> InstalledPackageIndex
- -> m (Maybe TestTarget)
+ :: Interactive m
+ => InitFlags
+ -> InstalledPackageIndex
+ -> m (Maybe TestTarget)
genTestTarget flags pkgs = initializeTestSuitePrompt flags >>= go
where
go initialized
| not initialized = return Nothing
- | otherwise = fmap Just $ TestTarget
- <$> testMainPrompt
- <*> testDirsPrompt flags
- <*> languagePrompt flags "test suite"
- <*> getOtherModules flags
- <*> getOtherExts flags
- <*> dependenciesPrompt pkgs flags
- <*> getBuildTools flags
-
+ | otherwise =
+ fmap Just $
+ TestTarget
+ <$> testMainPrompt
+ <*> testDirsPrompt flags
+ <*> languagePrompt flags "test suite"
+ <*> getOtherModules flags
+ <*> getOtherExts flags
+ <*> dependenciesPrompt pkgs flags
+ <*> getBuildTools flags
-- -------------------------------------------------------------------- --
-- Prompts
@@ -261,13 +283,15 @@ overwritePrompt flags = do
cabalVersionPrompt :: Interactive m => InitFlags -> m CabalSpecVersion
cabalVersionPrompt flags = getCabalVersion flags $ do
- v <- promptList "Please choose version of the Cabal specification to use"
+ v <-
+ promptList
+ "Please choose version of the Cabal specification to use"
ppVersions
(DefaultPrompt ppDefault)
(Just takeVersion)
False
- -- take just the version numbers for convenience
- return $ parseCabalVersion (takeVersion v)
+ -- take just the version numbers for convenience
+ return $ parseCabalVersion (takeVersion v)
where
-- only used when presenting the default in prompt
takeVersion = takeWhile (/= ' ')
@@ -283,38 +307,39 @@ cabalVersionPrompt flags = getCabalVersion flags $ do
parseCabalVersion "3.0" = CabalSpecV3_0
parseCabalVersion "3.4" = CabalSpecV3_4
parseCabalVersion _ = defaultCabalVersion -- 2.4
-
displayCabalVersion :: CabalSpecVersion -> String
displayCabalVersion v = case v of
- CabalSpecV2_0 -> "2.0 (support for Backpack, internal sub-libs, '^>=' operator)"
- CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)"
- CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)"
- CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"
- CabalSpecV3_4 -> "3.4 (+ sublibraries in 'mixins', optional 'default-language')"
+ CabalSpecV2_0 -> "2.0 (support for Backpack, internal sub-libs, '^>=' operator)"
+ CabalSpecV2_2 -> "2.2 (+ support for 'common', 'elif', redundant commas, SPDX)"
+ CabalSpecV2_4 -> "2.4 (+ support for '**' globbing)"
+ CabalSpecV3_0 -> "3.0 (+ set notation for ==, common stanzas in ifs, more redundant commas, better pkgconfig-depends)"
+ CabalSpecV3_4 -> "3.4 (+ sublibraries in 'mixins', optional 'default-language')"
_ -> showCabalSpecVersion v
packageNamePrompt :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName
packageNamePrompt srcDb flags = getPackageName flags $ do
- defName <- case packageDir flags of
- Flag b -> filePathToPkgName b
- NoFlag -> currentDirPkgName
+ defName <- case packageDir flags of
+ Flag b -> filePathToPkgName b
+ NoFlag -> currentDirPkgName
- go $ DefaultPrompt defName
+ go $ DefaultPrompt defName
where
- go defName = prompt "Package name" defName >>= \n ->
- if isPkgRegistered n
- then do
- don'tUseName <- promptYesNo (promptOtherNameMsg n) (DefaultPrompt True)
- if don'tUseName
- then go defName
- else return n
- else return n
+ go defName =
+ prompt "Package name" defName >>= \n ->
+ if isPkgRegistered n
+ then do
+ don'tUseName <- promptYesNo (promptOtherNameMsg n) (DefaultPrompt True)
+ if don'tUseName
+ then go defName
+ else return n
+ else return n
isPkgRegistered = elemByPackageName (packageIndex srcDb)
- inUseMsg pn = "The name "
- ++ unPackageName pn
- ++ " is already in use by another package on Hackage."
+ inUseMsg pn =
+ "The name "
+ ++ unPackageName pn
+ ++ " is already in use by another package on Hackage."
promptOtherNameMsg pn = inUseMsg pn ++ " Do you want to choose a different name (y/n)"
@@ -325,34 +350,38 @@ versionPrompt flags = getVersion flags go
vv <- promptStr "Package version" (DefaultPrompt $ prettyShow defaultVersion)
case simpleParsec vv of
Nothing -> do
- putStrLn
- $ "Version must be a valid PVP format (e.g. 0.1.0.0): "
- ++ vv
+ putStrLn $
+ "Version must be a valid PVP format (e.g. 0.1.0.0): "
+ ++ vv
go
Just v -> return v
licensePrompt :: Interactive m => InitFlags -> m SpecLicense
licensePrompt flags = getLicense flags $ do
- let csv = fromFlagOrDefault defaultCabalVersion (cabalVersion flags)
- l <- promptList "Please choose a license"
+ let csv = fromFlagOrDefault defaultCabalVersion (cabalVersion flags)
+ l <-
+ promptList
+ "Please choose a license"
(licenses csv)
(DefaultPrompt "BSD-3-Clause")
Nothing
True
- case simpleParsec' csv l of
- Nothing -> do
- putStrLn ( "The license must be a valid SPDX expression:"
- ++ "\n - On the SPDX License List: https://spdx.org/licenses/"
- ++ "\n - NONE, if you do not want to grant any license"
- ++ "\n - LicenseRef-( alphanumeric | - | . )+"
- )
- licensePrompt flags
- Just l' -> return l'
+ case simpleParsec' csv l of
+ Nothing -> do
+ putStrLn
+ ( "The license must be a valid SPDX expression:"
+ ++ "\n - On the SPDX License List: https://spdx.org/licenses/"
+ ++ "\n - NONE, if you do not want to grant any license"
+ ++ "\n - LicenseRef-( alphanumeric | - | . )+"
+ )
+ licensePrompt flags
+ Just l' -> return l'
where
- licenses csv = if csv >= CabalSpecV2_2
- then SPDX.licenseId <$> defaultLicenseIds
- else fmap prettyShow knownLicenses
+ licenses csv =
+ if csv >= CabalSpecV2_2
+ then SPDX.licenseId <$> defaultLicenseIds
+ else fmap prettyShow knownLicenses
authorPrompt :: Interactive m => InitFlags -> m String
authorPrompt flags = getAuthor flags $ guessAuthorName >>= promptOrDefault "Author name"
@@ -361,17 +390,24 @@ emailPrompt :: Interactive m => InitFlags -> m String
emailPrompt flags = getEmail flags $ guessAuthorEmail >>= promptOrDefault "Maintainer email"
homepagePrompt :: Interactive m => InitFlags -> m String
-homepagePrompt flags = getHomepage flags $
+homepagePrompt flags =
+ getHomepage flags $
promptStr "Project homepage URL" OptionalPrompt
synopsisPrompt :: Interactive m => InitFlags -> m String
-synopsisPrompt flags = getSynopsis flags $
+synopsisPrompt flags =
+ getSynopsis flags $
promptStr "Project synopsis" OptionalPrompt
categoryPrompt :: Interactive m => InitFlags -> m String
-categoryPrompt flags = getCategory flags $ promptList
- "Project category" defaultCategories
- (DefaultPrompt "") (Just matchNone) True
+categoryPrompt flags =
+ getCategory flags $
+ promptList
+ "Project category"
+ defaultCategories
+ (DefaultPrompt "")
+ (Just matchNone)
+ True
where
matchNone s
| null s = "(none)"
@@ -382,72 +418,79 @@ mainFilePrompt flags = getMainFile flags go
where
defaultMainIs' = show defaultMainIs
go = do
- fp <- promptList "What is the main module of the executable"
- [defaultMainIs', "Main.lhs"]
- (DefaultPrompt defaultMainIs')
- Nothing
- True
+ fp <-
+ promptList
+ "What is the main module of the executable"
+ [defaultMainIs', "Main.lhs"]
+ (DefaultPrompt defaultMainIs')
+ Nothing
+ True
let hs = toHsFilePath fp
case _hsFileType hs of
InvalidHsPath -> do
- putStrLn $ concat
- [ "Main file "
- , show hs
- , " is not a valid haskell file. Source files must end in .hs or .lhs."
- ]
+ putStrLn $
+ concat
+ [ "Main file "
+ , show hs
+ , " is not a valid haskell file. Source files must end in .hs or .lhs."
+ ]
go
-
_ -> return hs
testDirsPrompt :: Interactive m => InitFlags -> m [String]
testDirsPrompt flags = getTestDirs flags $ do
- dir <- promptStr "Test directory" (DefaultPrompt defaultTestDir)
- return [dir]
+ dir <- promptStr "Test directory" (DefaultPrompt defaultTestDir)
+ return [dir]
languagePrompt :: Interactive m => InitFlags -> String -> m Language
languagePrompt flags pkgType = getLanguage flags $ do
- let h2010 = "Haskell2010"
- h98 = "Haskell98"
- ghc2021 = "GHC2021 (requires at least GHC 9.2)"
+ let h2010 = "Haskell2010"
+ h98 = "Haskell98"
+ ghc2021 = "GHC2021 (requires at least GHC 9.2)"
- l <- promptList ("Choose a language for your " ++ pkgType)
+ l <-
+ promptList
+ ("Choose a language for your " ++ pkgType)
[h2010, h98, ghc2021]
(DefaultPrompt h2010)
Nothing
True
- if
- | l == h2010 -> return Haskell2010
- | l == h98 -> return Haskell98
- | l == ghc2021 -> return GHC2021
- | otherwise -> return $ UnknownLanguage l
+ if
+ | l == h2010 -> return Haskell2010
+ | l == h98 -> return Haskell98
+ | l == ghc2021 -> return GHC2021
+ | otherwise -> return $ UnknownLanguage l
noCommentsPrompt :: Interactive m => InitFlags -> m Bool
noCommentsPrompt flags = getNoComments flags $ do
- doComments <- promptYesNo
+ doComments <-
+ promptYesNo
"Add informative comments to each field in the cabal file. (y/n)"
(DefaultPrompt True)
- --
- -- if --no-comments is flagged, then we choose not to generate comments
- -- for fields in the cabal file, but it's a nicer UX to present the
- -- affirmative question which must be negated.
- --
+ --
+ -- if --no-comments is flagged, then we choose not to generate comments
+ -- for fields in the cabal file, but it's a nicer UX to present the
+ -- affirmative question which must be negated.
+ --
- return (not doComments)
+ return (not doComments)
-- | Ask for the application root directory.
appDirsPrompt :: Interactive m => InitFlags -> m [String]
appDirsPrompt flags = getAppDirs flags $ do
- dir <- promptList promptMsg
+ dir <-
+ promptList
+ promptMsg
[defaultApplicationDir, "exe", "src-exe"]
(DefaultPrompt defaultApplicationDir)
Nothing
True
- return [dir]
+ return [dir]
where
promptMsg = case mainIs flags of
Flag p -> "Application (" ++ p ++ ") directory"
@@ -456,13 +499,15 @@ appDirsPrompt flags = getAppDirs flags $ do
-- | Ask for the source (library) root directory.
srcDirsPrompt :: Interactive m => InitFlags -> m [String]
srcDirsPrompt flags = getSrcDirs flags $ do
- dir <- promptList "Library source directory"
+ dir <-
+ promptList
+ "Library source directory"
[defaultSourceDir, "lib", "src-lib"]
(DefaultPrompt defaultSourceDir)
Nothing
True
- return [dir]
+ return [dir]
promptOrDefault :: Interactive m => String -> Maybe String -> m String
-promptOrDefault s = maybe (promptStr s MandatoryPrompt) (promptStr s . DefaultPrompt)
+promptOrDefault s = maybe (promptStr s MandatoryPrompt) (promptStr s . DefaultPrompt)
diff --git a/cabal-install/src/Distribution/Client/Init/Licenses.hs b/cabal-install/src/Distribution/Client/Init/Licenses.hs
index e08d3580fe3eedb203ba3963f23c4744289a13a7..ef648e9351f52821ab32d629fe80012a968b0109 100644
--- a/cabal-install/src/Distribution/Client/Init/Licenses.hs
+++ b/cabal-install/src/Distribution/Client/Init/Licenses.hs
@@ -1,13 +1,12 @@
-{-|
-Module : Distribution.Client.Init.Licenses
-
-Description : Factory functions for producing known license types.
-
-License : BSD-like
-Maintainer : cabal-devel@haskell.org
-Stability : provisional
-Portability : portable
--}
+-- |
+-- Module : Distribution.Client.Init.Licenses
+--
+-- Description : Factory functions for producing known license types.
+--
+-- License : BSD-like
+-- Maintainer : cabal-devel@haskell.org
+-- Stability : provisional
+-- Portability : portable
module Distribution.Client.Init.Licenses
( License
, bsd2
@@ -28,7 +27,8 @@ import Prelude (String, unlines, (++))
type License = String
bsd2 :: String -> String -> License
-bsd2 authors year = unlines
+bsd2 authors year =
+ unlines
[ "Copyright (c) " ++ year ++ ", " ++ authors
, "All rights reserved."
, ""
@@ -58,7 +58,8 @@ bsd2 authors year = unlines
]
bsd3 :: String -> String -> License
-bsd3 authors year = unlines
+bsd3 authors year =
+ unlines
[ "Copyright (c) " ++ year ++ ", " ++ authors
, ""
, "All rights reserved."
@@ -92,7 +93,8 @@ bsd3 authors year = unlines
]
gplv2 :: License
-gplv2 = unlines
+gplv2 =
+ unlines
[ " GNU GENERAL PUBLIC LICENSE"
, " Version 2, June 1991"
, ""
@@ -435,7 +437,8 @@ gplv2 = unlines
]
gplv3 :: License
-gplv3 = unlines
+gplv3 =
+ unlines
[ " GNU GENERAL PUBLIC LICENSE"
, " Version 3, 29 June 2007"
, ""
@@ -1113,7 +1116,8 @@ gplv3 = unlines
]
agplv3 :: License
-agplv3 = unlines
+agplv3 =
+ unlines
[ " GNU AFFERO GENERAL PUBLIC LICENSE"
, " Version 3, 19 November 2007"
, ""
@@ -1778,7 +1782,8 @@ agplv3 = unlines
]
lgpl21 :: License
-lgpl21 = unlines
+lgpl21 =
+ unlines
[ " GNU LESSER GENERAL PUBLIC LICENSE"
, " Version 2.1, February 1999"
, ""
@@ -2284,7 +2289,8 @@ lgpl21 = unlines
]
lgpl3 :: License
-lgpl3 = unlines
+lgpl3 =
+ unlines
[ " GNU LESSER GENERAL PUBLIC LICENSE"
, " Version 3, 29 June 2007"
, ""
@@ -2453,7 +2459,8 @@ lgpl3 = unlines
]
apache20 :: License
-apache20 = unlines
+apache20 =
+ unlines
[ ""
, " Apache License"
, " Version 2.0, January 2004"
@@ -2659,7 +2666,8 @@ apache20 = unlines
]
mit :: String -> String -> License
-mit authors year = unlines
+mit authors year =
+ unlines
[ "Copyright (c) " ++ year ++ " " ++ authors
, ""
, "Permission is hereby granted, free of charge, to any person obtaining"
@@ -2683,7 +2691,8 @@ mit authors year = unlines
]
mpl20 :: License
-mpl20 = unlines
+mpl20 =
+ unlines
[ "Mozilla Public License Version 2.0"
, "=================================="
, ""
@@ -3060,7 +3069,8 @@ mpl20 = unlines
]
isc :: String -> String -> License
-isc authors year = unlines
+isc authors year =
+ unlines
[ "Copyright (c) " ++ year ++ " " ++ authors
, ""
, "Permission to use, copy, modify, and/or distribute this software for any purpose"
diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs
index bc317247dfe9dc6a0629ee5e076b04636f29f904..8c37cad96f22474aa94c70d234fed87ba43cb63e 100644
--- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs
+++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Command.hs
@@ -1,82 +1,81 @@
{-# LANGUAGE LambdaCase #-}
+
module Distribution.Client.Init.NonInteractive.Command
-( genPkgDescription
-, genLibTarget
-, genExeTarget
-, genTestTarget
-, createProject
-, packageTypeHeuristics
-, authorHeuristics
-, emailHeuristics
-, cabalVersionHeuristics
-, packageNameHeuristics
-, versionHeuristics
-, mainFileHeuristics
-, testDirsHeuristics
-, initializeTestSuiteHeuristics
-, exposedModulesHeuristics
-, libOtherModulesHeuristics
-, exeOtherModulesHeuristics
-, testOtherModulesHeuristics
-, buildToolsHeuristics
-, dependenciesHeuristics
-, otherExtsHeuristics
-, licenseHeuristics
-, homepageHeuristics
-, synopsisHeuristics
-, categoryHeuristics
-, extraDocFileHeuristics
-, appDirsHeuristics
-, srcDirsHeuristics
-, languageHeuristics
-, noCommentsHeuristics
-, minimalHeuristics
-, overwriteHeuristics
-) where
+ ( genPkgDescription
+ , genLibTarget
+ , genExeTarget
+ , genTestTarget
+ , createProject
+ , packageTypeHeuristics
+ , authorHeuristics
+ , emailHeuristics
+ , cabalVersionHeuristics
+ , packageNameHeuristics
+ , versionHeuristics
+ , mainFileHeuristics
+ , testDirsHeuristics
+ , initializeTestSuiteHeuristics
+ , exposedModulesHeuristics
+ , libOtherModulesHeuristics
+ , exeOtherModulesHeuristics
+ , testOtherModulesHeuristics
+ , buildToolsHeuristics
+ , dependenciesHeuristics
+ , otherExtsHeuristics
+ , licenseHeuristics
+ , homepageHeuristics
+ , synopsisHeuristics
+ , categoryHeuristics
+ , extraDocFileHeuristics
+ , appDirsHeuristics
+ , srcDirsHeuristics
+ , languageHeuristics
+ , noCommentsHeuristics
+ , minimalHeuristics
+ , overwriteHeuristics
+ ) where
+
import Distribution.Client.Init.Types
+import Distribution.Client.Compat.Prelude hiding (getLine, head, last, putStr, putStrLn)
import Prelude ()
-import Distribution.Client.Compat.Prelude hiding (putStr, putStrLn, getLine, last, head)
-import Data.List (last, head)
+import Data.List (head, last)
import qualified Data.List.NonEmpty as NEL
-import Distribution.CabalSpecVersion (CabalSpecVersion(..))
-import Distribution.Version (Version)
-import Distribution.ModuleName (ModuleName, components)
-import Distribution.Types.Dependency (Dependency(..))
-import Distribution.Types.PackageName (PackageName, unPackageName)
+import Distribution.CabalSpecVersion (CabalSpecVersion (..))
import Distribution.Client.Init.Defaults
+import Distribution.Client.Init.FlagExtractors
import Distribution.Client.Init.NonInteractive.Heuristics
import Distribution.Client.Init.Utils
-import Distribution.Client.Init.FlagExtractors
-import Distribution.Simple.Setup (Flag(..), fromFlagOrDefault)
+import Distribution.Client.Types (SourcePackageDb (..))
+import Distribution.ModuleName (ModuleName, components)
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import Distribution.Client.Types (SourcePackageDb(..))
+import Distribution.Simple.Setup (Flag (..), fromFlagOrDefault)
import Distribution.Solver.Types.PackageIndex (elemByPackageName)
+import Distribution.Types.Dependency (Dependency (..))
+import Distribution.Types.PackageName (PackageName, unPackageName)
import Distribution.Utils.Generic (safeHead)
import Distribution.Verbosity
+import Distribution.Version (Version)
-import Language.Haskell.Extension (Language(..), Extension(..))
+import Language.Haskell.Extension (Extension (..), Language (..))
-import System.FilePath (splitDirectories, (</>))
-import Distribution.Simple.Compiler
import qualified Data.Set as Set
import Distribution.FieldGrammar.Newtypes
-
+import Distribution.Simple.Compiler
+import System.FilePath (splitDirectories, (</>))
-- | Main driver for interactive prompt code.
---
createProject
- :: Interactive m
- => Compiler
- -> Verbosity
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> InitFlags
- -> m ProjectSettings
+ :: Interactive m
+ => Compiler
+ -> Verbosity
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> InitFlags
+ -> m ProjectSettings
createProject comp v pkgIx srcDb initFlags = do
-
-- The workflow is as follows:
--
-- 1. Get the package type, supplied as either a program input or
@@ -108,62 +107,85 @@ createProject comp v pkgIx srcDb initFlags = do
let pkgName = _pkgName pkgDesc
cabalSpec = _pkgCabalVersion pkgDesc
- mkOpts cs = WriteOpts
- doOverwrite isMinimal cs
- v pkgDir pkgType pkgName
+ mkOpts cs =
+ WriteOpts
+ doOverwrite
+ isMinimal
+ cs
+ v
+ pkgDir
+ pkgType
+ pkgName
case pkgType of
Library -> do
libTarget <- genLibTarget initFlags comp pkgIx cabalSpec
- testTarget <- addLibDepToTest pkgName <$>
- genTestTarget initFlags comp pkgIx cabalSpec
-
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc
- (Just libTarget) Nothing testTarget
-
+ testTarget <-
+ addLibDepToTest pkgName
+ <$> genTestTarget initFlags comp pkgIx cabalSpec
+
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ (Just libTarget)
+ Nothing
+ testTarget
Executable -> do
exeTarget <- genExeTarget initFlags comp pkgIx cabalSpec
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc Nothing
- (Just exeTarget) Nothing
-
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ Nothing
+ (Just exeTarget)
+ Nothing
LibraryAndExecutable -> do
libTarget <- genLibTarget initFlags comp pkgIx cabalSpec
- exeTarget <- addLibDepToExe pkgName <$>
- genExeTarget initFlags comp pkgIx cabalSpec
- testTarget <- addLibDepToTest pkgName <$>
- genTestTarget initFlags comp pkgIx cabalSpec
-
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc (Just libTarget)
- (Just exeTarget) testTarget
-
+ exeTarget <-
+ addLibDepToExe pkgName
+ <$> genExeTarget initFlags comp pkgIx cabalSpec
+ testTarget <-
+ addLibDepToTest pkgName
+ <$> genTestTarget initFlags comp pkgIx cabalSpec
+
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ (Just libTarget)
+ (Just exeTarget)
+ testTarget
TestSuite -> do
testTarget <- genTestTarget initFlags comp pkgIx cabalSpec
- return $ ProjectSettings
- (mkOpts comments cabalSpec) pkgDesc
- Nothing Nothing testTarget
+ return $
+ ProjectSettings
+ (mkOpts comments cabalSpec)
+ pkgDesc
+ Nothing
+ Nothing
+ testTarget
genPkgDescription
:: Interactive m
=> InitFlags
-> SourcePackageDb
-> m PkgDescription
-genPkgDescription flags srcDb = PkgDescription
- <$> cabalVersionHeuristics flags
- <*> packageNameHeuristics srcDb flags
- <*> versionHeuristics flags
- <*> licenseHeuristics flags
- <*> authorHeuristics flags
- <*> emailHeuristics flags
- <*> homepageHeuristics flags
- <*> synopsisHeuristics flags
- <*> categoryHeuristics flags
- <*> getExtraSrcFiles flags
- <*> extraDocFileHeuristics flags
+genPkgDescription flags srcDb =
+ PkgDescription
+ <$> cabalVersionHeuristics flags
+ <*> packageNameHeuristics srcDb flags
+ <*> versionHeuristics flags
+ <*> licenseHeuristics flags
+ <*> authorHeuristics flags
+ <*> emailHeuristics flags
+ <*> homepageHeuristics flags
+ <*> synopsisHeuristics flags
+ <*> categoryHeuristics flags
+ <*> getExtraSrcFiles flags
+ <*> extraDocFileHeuristics flags
genLibTarget
:: Interactive m
@@ -173,7 +195,7 @@ genLibTarget
-> CabalSpecVersion
-> m LibTarget
genLibTarget flags comp pkgs v = do
- srcDirs <- srcDirsHeuristics flags
+ srcDirs <- srcDirsHeuristics flags
let srcDir = fromMaybe defaultSourceDir $ safeHead srcDirs
LibTarget srcDirs
<$> languageHeuristics flags comp
@@ -191,7 +213,7 @@ genExeTarget
-> CabalSpecVersion
-> m ExeTarget
genExeTarget flags comp pkgs v = do
- appDirs <- appDirsHeuristics flags
+ appDirs <- appDirsHeuristics flags
let appDir = fromMaybe defaultApplicationDir $ safeHead appDirs
ExeTarget
<$> mainFileHeuristics flags
@@ -214,15 +236,17 @@ genTestTarget flags comp pkgs v = do
testDirs' <- testDirsHeuristics flags
let testDir = fromMaybe defaultTestDir $ safeHead testDirs'
if not initialized
- then return Nothing
- else fmap Just $ TestTarget
- <$> testMainHeuristics flags
- <*> pure testDirs'
- <*> languageHeuristics flags comp
- <*> testOtherModulesHeuristics flags
- <*> otherExtsHeuristics flags testDir
- <*> dependenciesHeuristics flags testDir pkgs
- <*> buildToolsHeuristics flags testDir v
+ then return Nothing
+ else
+ fmap Just $
+ TestTarget
+ <$> testMainHeuristics flags
+ <*> pure testDirs'
+ <*> languageHeuristics flags comp
+ <*> testOtherModulesHeuristics flags
+ <*> otherExtsHeuristics flags testDir
+ <*> dependenciesHeuristics flags testDir pkgs
+ <*> buildToolsHeuristics flags testDir v
-- -------------------------------------------------------------------- --
-- Get flags from init config
@@ -247,21 +271,22 @@ cabalVersionHeuristics flags = getCabalVersion flags guessCabalSpecVersion
-- using an existing package name.
packageNameHeuristics :: Interactive m => SourcePackageDb -> InitFlags -> m PackageName
packageNameHeuristics sourcePkgDb flags = getPackageName flags $ do
- defName <- guessPackageName =<< case packageDir flags of
+ defName <-
+ guessPackageName =<< case packageDir flags of
Flag a -> return a
NoFlag -> last . splitDirectories <$> getCurrentDirectory
- when (isPkgRegistered defName)
- $ putStrLn (inUseMsg defName)
-
- return defName
+ when (isPkgRegistered defName) $
+ putStrLn (inUseMsg defName)
+ return defName
where
isPkgRegistered = elemByPackageName (packageIndex sourcePkgDb)
- inUseMsg pn = "The name "
- ++ unPackageName pn
- ++ " is already in use by another package on Hackage."
+ inUseMsg pn =
+ "The name "
+ ++ unPackageName pn
+ ++ " is already in use by another package on Hackage."
-- | Package version: use 0.1.0.0 as a last resort
versionHeuristics :: Interactive m => InitFlags -> m Version
@@ -276,14 +301,16 @@ licenseHeuristics flags = getLicense flags $ guessLicense flags
-- | The author's name. Prompt, or try to guess from an existing
-- git repo.
authorHeuristics :: Interactive m => InitFlags -> m String
-authorHeuristics flags = guessAuthorName >>=
- maybe (getAuthor flags $ return "Unknown") (getAuthor flags . return)
+authorHeuristics flags =
+ guessAuthorName
+ >>= maybe (getAuthor flags $ return "Unknown") (getAuthor flags . return)
-- | The author's email. Prompt, or try to guess from an existing
-- git repo.
emailHeuristics :: Interactive m => InitFlags -> m String
-emailHeuristics flags = guessAuthorEmail >>=
- maybe (getEmail flags $ return "Unknown") (getEmail flags . return)
+emailHeuristics flags =
+ guessAuthorEmail
+ >>= maybe (getEmail flags $ return "Unknown") (getEmail flags . return)
-- | Prompt for a homepage URL for the package.
homepageHeuristics :: Interactive m => InitFlags -> m String
@@ -355,18 +382,17 @@ exposedModulesHeuristics flags = do
if exists
then do
- modules <- filter isHaskell <$> listFilesRecursive srcDir
+ modules <- filter isHaskell <$> listFilesRecursive srcDir
modulesNames <- catMaybes <$> traverse retrieveModuleName modules
otherModules' <- libOtherModulesHeuristics flags
return $ filter (`notElem` otherModules') modulesNames
+ else return []
- else
- return []
-
- return $ if null mods
- then myLibModule NEL.:| []
- else NEL.fromList mods
+ return $
+ if null mods
+ then myLibModule NEL.:| []
+ else NEL.fromList mods
-- | Retrieve the list of other modules for Libraries, filtering them
-- based on the last component of the module name
@@ -379,16 +405,18 @@ libOtherModulesHeuristics flags = case otherModules flags of
Flag x -> fromMaybe defaultSourceDir $ safeHead x
NoFlag -> defaultSourceDir
- libDir <- (</> srcDir) <$> case packageDir flags of
- Flag x -> return x
- NoFlag -> getCurrentDirectory
+ libDir <-
+ (</> srcDir) <$> case packageDir flags of
+ Flag x -> return x
+ NoFlag -> getCurrentDirectory
exists <- doesDirectoryExist libDir
if exists
then do
otherModules' <- filter isHaskell <$> listFilesRecursive libDir
filter ((`elem` otherCandidates) . last . components)
- . catMaybes <$> traverse retrieveModuleName otherModules'
+ . catMaybes
+ <$> traverse retrieveModuleName otherModules'
else return []
-- | Retrieve the list of other modules for Executables, it lists everything
@@ -401,15 +429,17 @@ exeOtherModulesHeuristics flags = case otherModules flags of
Flag x -> fromMaybe defaultApplicationDir $ safeHead x
NoFlag -> defaultApplicationDir
- exeDir <- (</> appDir) <$> case packageDir flags of
- Flag x -> return x
- NoFlag -> getCurrentDirectory
+ exeDir <-
+ (</> appDir) <$> case packageDir flags of
+ Flag x -> return x
+ NoFlag -> getCurrentDirectory
exists <- doesDirectoryExist exeDir
if exists
then do
- otherModules' <- filter (\f -> not (isMain f) && isHaskell f)
- <$> listFilesRecursive exeDir
+ otherModules' <-
+ filter (\f -> not (isMain f) && isHaskell f)
+ <$> listFilesRecursive exeDir
catMaybes <$> traverse retrieveModuleName otherModules'
else return []
@@ -423,25 +453,27 @@ testOtherModulesHeuristics flags = case otherModules flags of
Flag x -> fromMaybe defaultTestDir $ safeHead x
NoFlag -> defaultTestDir
- testDir' <- (</> testDir) <$> case packageDir flags of
- Flag x -> return x
- NoFlag -> getCurrentDirectory
+ testDir' <-
+ (</> testDir) <$> case packageDir flags of
+ Flag x -> return x
+ NoFlag -> getCurrentDirectory
exists <- doesDirectoryExist testDir'
if exists
then do
- otherModules' <- filter (\f -> not (isMain f) && isHaskell f)
- <$> listFilesRecursive testDir'
+ otherModules' <-
+ filter (\f -> not (isMain f) && isHaskell f)
+ <$> listFilesRecursive testDir'
catMaybes <$> traverse retrieveModuleName otherModules'
else return []
-- | Retrieve the list of build tools
buildToolsHeuristics
- :: Interactive m
- => InitFlags
- -> FilePath
- -> CabalSpecVersion
- -> m [Dependency]
+ :: Interactive m
+ => InitFlags
+ -> FilePath
+ -> CabalSpecVersion
+ -> m [Dependency]
buildToolsHeuristics flags fp v = case buildTools flags of
Flag{} -> getBuildTools flags
NoFlag -> retrieveBuildTools v fp
@@ -455,9 +487,9 @@ dependenciesHeuristics flags fp pkgIx = getDependencies flags $ do
Flag x -> x
NoFlag -> map moduleName sources
- groupedDeps = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources
+ groupedDeps = concatMap (\s -> map (\i -> (moduleName s, i)) (imports s)) sources
filteredDeps = filter ((`notElem` mods) . snd) groupedDeps
- preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps
+ preludeNub = nubBy (\a b -> snd a == snd b) $ (fromString "Prelude", fromString "Prelude") : filteredDeps
retrieveDependencies (fromFlagOrDefault normal $ initVerbosity flags) flags preludeNub pkgIx
@@ -469,9 +501,8 @@ otherExtsHeuristics flags fp = case otherExts flags of
exists <- doesDirectoryExist fp
if exists
then do
- sources <- listFilesRecursive fp
+ sources <- listFilesRecursive fp
extensions' <- traverse retrieveModuleExtensions . filter isHaskell $ sources
return $ nub . join $ extensions'
- else
- return []
+ else return []
diff --git a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
index 04c4927987167610143b71cf95e5b522576f0640..0fe0129d2c36043c69cb4454922cc8908da38d84 100644
--- a/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
+++ b/cabal-install/src/Distribution/Client/Init/NonInteractive/Heuristics.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE LambdaCase #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Init.NonInteractive.Heuristics
-- Copyright : (c) Benedikt Huber 2009
@@ -10,8 +14,6 @@
-- Portability : portable
--
-- Heuristics for creating initial cabal files.
---
------------------------------------------------------------------------------
module Distribution.Client.Init.NonInteractive.Heuristics
( guessPackageName
, guessMainFile
@@ -26,25 +28,23 @@ module Distribution.Client.Init.NonInteractive.Heuristics
, guessApplicationDirectories
) where
-import Distribution.Client.Compat.Prelude hiding (readFile, (<|>), many)
+import Distribution.Client.Compat.Prelude hiding (many, readFile, (<|>))
import Distribution.Simple.Setup (fromFlagOrDefault)
import qualified Data.List as L
+import qualified Data.Set as Set
+import Distribution.CabalSpecVersion
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)
import Distribution.Client.Init.Types
import Distribution.Client.Init.Utils
-import System.FilePath
-import Distribution.CabalSpecVersion
-import Language.Haskell.Extension
-import Distribution.Version
-import Distribution.Types.PackageName (PackageName)
-import Distribution.Simple.Compiler
-import qualified Data.Set as Set
import Distribution.FieldGrammar.Newtypes
-
-
+import Distribution.Simple.Compiler
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Version
+import Language.Haskell.Extension
+import System.FilePath
-- | Guess the main file, returns a default value if none is found.
guessMainFile :: Interactive m => FilePath -> m HsFilePath
@@ -52,12 +52,12 @@ guessMainFile pkgDir = do
exists <- doesDirectoryExist pkgDir
if exists
then do
- files <- filter isMain <$> listFilesRecursive pkgDir
- return $ if null files
- then defaultMainIs
- else toHsFilePath $ L.head files
- else
- return defaultMainIs
+ files <- filter isMain <$> listFilesRecursive pkgDir
+ return $
+ if null files
+ then defaultMainIs
+ else toHsFilePath $ L.head files
+ else return defaultMainIs
-- | Juggling characters around to guess the desired cabal version based on
-- the system's cabal version.
@@ -66,15 +66,16 @@ guessCabalSpecVersion = do
(_, verString, _) <- readProcessWithExitCode "cabal" ["--version"] ""
case simpleParsec $ takeWhile (not . isSpace) $ dropWhile (not . isDigit) verString of
Just v -> pure $ fromMaybe defaultCabalVersion $ case versionNumbers v of
- [x,y,_,_] -> cabalSpecFromVersionDigits [x,y]
- [x,y,_] -> cabalSpecFromVersionDigits [x,y]
+ [x, y, _, _] -> cabalSpecFromVersionDigits [x, y]
+ [x, y, _] -> cabalSpecFromVersionDigits [x, y]
_ -> Just defaultCabalVersion
Nothing -> pure defaultCabalVersion
-- | Guess the language specification based on the GHC version
guessLanguage :: Interactive m => Compiler -> m Language
-guessLanguage Compiler {compilerId = CompilerId GHC ver} =
- return $ if ver < mkVersion [7,0,1]
+guessLanguage Compiler{compilerId = CompilerId GHC ver} =
+ return $
+ if ver < mkVersion [7, 0, 1]
then Haskell98
else Haskell2010
guessLanguage _ = return defaultLanguage
@@ -92,63 +93,68 @@ guessLicense flags = return . defaultLicense $ getCabalVersionNoPrompt flags
guessExtraDocFiles :: Interactive m => InitFlags -> m (Maybe (Set FilePath))
guessExtraDocFiles flags = do
pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
- files <- getDirectoryContents pkgDir
+ files <- getDirectoryContents pkgDir
let extraDocCandidates = ["CHANGES", "CHANGELOG", "README"]
extraDocs = [y | x <- extraDocCandidates, y <- files, x == map toUpper (takeBaseName y)]
- return $ Just $ if null extraDocs
- then Set.singleton defaultChangelog
- else Set.fromList extraDocs
+ return $
+ Just $
+ if null extraDocs
+ then Set.singleton defaultChangelog
+ else Set.fromList extraDocs
-- | Try to guess the package type from the files in the package directory,
-- looking for unique characteristics from each type, defaults to Executable.
guessPackageType :: Interactive m => InitFlags -> m PackageType
guessPackageType flags = do
if fromFlagOrDefault False (initializeTestSuite flags)
- then
- return TestSuite
+ then return TestSuite
else do
- let lastDir dirs = L.last . splitDirectories $ dirs
- srcCandidates = [defaultSourceDir, "src", "source"]
+ let lastDir dirs = L.last . splitDirectories $ dirs
+ srcCandidates = [defaultSourceDir, "src", "source"]
testCandidates = [defaultTestDir, "test", "tests"]
pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
- files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir
- files' <- filter (not . null . map (`elem` testCandidates) . splitDirectories) <$>
- listFilesRecursive pkgDir
+ files <- listFilesInside (\x -> return $ lastDir x `notElem` testCandidates) pkgDir
+ files' <-
+ filter (not . null . map (`elem` testCandidates) . splitDirectories)
+ <$> listFilesRecursive pkgDir
- let hasExe = not $ null [f | f <- files, isMain $ takeFileName f]
- hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates]
- hasTest = not $ null [f | f <- files', isMain $ takeFileName f]
+ let hasExe = not $ null [f | f <- files, isMain $ takeFileName f]
+ hasLib = not $ null [f | f <- files, lastDir f `elem` srcCandidates]
+ hasTest = not $ null [f | f <- files', isMain $ takeFileName f]
return $ case (hasLib, hasExe, hasTest) of
- (True , True , _ ) -> LibraryAndExecutable
- (True , False, _ ) -> Library
+ (True, True, _) -> LibraryAndExecutable
+ (True, False, _) -> Library
(False, False, True) -> TestSuite
- _ -> Executable
+ _ -> Executable
-- | Try to guess the application directories from the package directory,
-- using a default value as fallback.
guessApplicationDirectories :: Interactive m => InitFlags -> m [FilePath]
guessApplicationDirectories flags = do
- pkgDirs <- fromFlagOrDefault getCurrentDirectory
- (return <$> packageDir flags)
+ pkgDirs <-
+ fromFlagOrDefault
+ getCurrentDirectory
+ (return <$> packageDir flags)
pkgDirsContents <- listDirectory pkgDirs
- let candidates = [defaultApplicationDir, "app", "src-exe"] in
- return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of
- [] -> [defaultApplicationDir]
- x -> map (</> pkgDirs) . nub $ x
+ let candidates = [defaultApplicationDir, "app", "src-exe"]
+ in return $ case [y | x <- candidates, y <- pkgDirsContents, x == y] of
+ [] -> [defaultApplicationDir]
+ x -> map (</> pkgDirs) . nub $ x
-- | Try to guess the source directories, using a default value as fallback.
guessSourceDirectories :: Interactive m => InitFlags -> m [FilePath]
guessSourceDirectories flags = do
pkgDir <- fromFlagOrDefault getCurrentDirectory $ return <$> packageDir flags
- doesDirectoryExist (pkgDir </> "src") >>= return . \case
- False -> [defaultSourceDir]
- True -> ["src"]
+ doesDirectoryExist (pkgDir </> "src")
+ >>= return . \case
+ False -> [defaultSourceDir]
+ True -> ["src"]
-- | Guess author and email using git configuration options.
guessAuthorName :: Interactive m => m (Maybe String)
@@ -164,10 +170,9 @@ guessGitInfo target = do
then do
globalInfo <- readProcessWithExitCode "git" ["config", "--global", target] ""
case fst' globalInfo of
- ExitSuccess -> return $ Just (trim $ snd' globalInfo)
- _ -> return Nothing
- else return $ Just (trim $ snd' localInfo)
-
+ ExitSuccess -> return $ Just (trim $ snd' globalInfo)
+ _ -> return Nothing
+ else return $ Just (trim $ snd' localInfo)
where
fst' (x, _, _) = x
snd' (_, x, _) = x
diff --git a/cabal-install/src/Distribution/Client/Init/Prompt.hs b/cabal-install/src/Distribution/Client/Init/Prompt.hs
index 2e7e25e25f7d3da4e0e18ede8322259340b535df..7464a0d0145124976ca15ef629a8f90315b2eed5 100644
--- a/cabal-install/src/Distribution/Client/Init/Prompt.hs
+++ b/cabal-install/src/Distribution/Client/Init/Prompt.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Init.Prompt
-- Copyright : (c) Brent Yorgey 2009
@@ -11,23 +15,19 @@
-- Portability : portable
--
-- User prompt utility functions for use by the 'cabal init' command.
---
------------------------------------------------------------------------------
-
module Distribution.Client.Init.Prompt
-( prompt
-, promptYesNo
-, promptStr
-, promptList
-) where
+ ( prompt
+ , promptYesNo
+ , promptStr
+ , promptList
+ ) where
-import Prelude hiding (break, putStrLn, getLine, putStr)
+import Prelude hiding (break, getLine, putStr, putStrLn)
import Distribution.Client.Compat.Prelude hiding (break, empty, getLine, putStr, putStrLn)
import Distribution.Client.Init.Types
import qualified System.IO
-
-- | Create a prompt with optional default value that returns a
-- String.
promptStr :: Interactive m => String -> DefaultPrompt String -> m String
@@ -35,21 +35,21 @@ promptStr = promptDefault Right id
-- | Create a yes/no prompt with optional default value.
promptYesNo
- :: Interactive m
- => String
- -- ^ prompt message
- -> DefaultPrompt Bool
- -- ^ optional default value
- -> m Bool
+ :: Interactive m
+ => String
+ -- ^ prompt message
+ -> DefaultPrompt Bool
+ -- ^ optional default value
+ -> m Bool
promptYesNo =
- promptDefault recogniseYesNo showYesNo
+ promptDefault recogniseYesNo showYesNo
where
recogniseYesNo s
| (toLower <$> s) == "y" = Right True
| (toLower <$> s) == "n" || s == "N" = Right False
| otherwise = Left $ "Cannot parse input: " ++ s
- showYesNo True = "y"
+ showYesNo True = "y"
showYesNo False = "n"
-- | Create a prompt with optional default value that returns a value
@@ -68,94 +68,101 @@ mkDefPrompt msg def = msg ++ "?" ++ format def
-- | Create a prompt from a list of strings
promptList
- :: Interactive m
- => String
- -- ^ prompt
- -> [String]
- -- ^ choices
- -> DefaultPrompt String
- -- ^ optional default value
- -> Maybe (String -> String)
- -- ^ modify the default value to present in-prompt
- -- e.g. empty string maps to "(none)", but only in the
- -- prompt.
- -> Bool
- -- ^ whether to allow an 'other' option
- -> m String
+ :: Interactive m
+ => String
+ -- ^ prompt
+ -> [String]
+ -- ^ choices
+ -> DefaultPrompt String
+ -- ^ optional default value
+ -> Maybe (String -> String)
+ -- ^ modify the default value to present in-prompt
+ -- e.g. empty string maps to "(none)", but only in the
+ -- prompt.
+ -> Bool
+ -- ^ whether to allow an 'other' option
+ -> m String
promptList msg choices def modDef hasOther = do
putStrLn $ msg ++ ":"
-- Output nicely formatted list of options
- for_ prettyChoices $ \(i,c) -> do
- let star = if DefaultPrompt c == def
- then "*"
- else " "
-
- let output = concat $ if i < 10
- then [" ", star, " ", show i, ") ", c]
- else [" ", star, show i, ") ", c]
+ for_ prettyChoices $ \(i, c) -> do
+ let star =
+ if DefaultPrompt c == def
+ then "*"
+ else " "
+
+ let output =
+ concat $
+ if i < 10
+ then [" ", star, " ", show i, ") ", c]
+ else [" ", star, show i, ") ", c]
putStrLn output
go
- where
- prettyChoices =
- let cs = if hasOther
- then choices ++ ["Other (specify)"]
- else choices
- in zip [1::Int .. length choices + 1] cs
-
- numChoices = length choices
-
- invalidChoice input = do
- let msg' = if null input
- then "Empty input is not a valid choice."
- else concat
- [ input
- , " is not a valid choice. Please choose a number from 1 to "
- , show (length prettyChoices)
- , "."
- ]
+ where
+ prettyChoices =
+ let cs =
+ if hasOther
+ then choices ++ ["Other (specify)"]
+ else choices
+ in zip [1 :: Int .. length choices + 1] cs
+
+ numChoices = length choices
+
+ invalidChoice input = do
+ let msg' =
+ if null input
+ then "Empty input is not a valid choice."
+ else
+ concat
+ [ input
+ , " is not a valid choice. Please choose a number from 1 to "
+ , show (length prettyChoices)
+ , "."
+ ]
putStrLn msg'
breakOrContinue ("promptList: " ++ input) go
- go = do
- putStr
- $ mkDefPrompt "Your choice"
- $ maybe def (<$> def) modDef
-
- input <- getLine
- case def of
- DefaultPrompt d | null input -> return d
- _ -> case readMaybe input of
- Nothing -> invalidChoice input
- Just n
- | n > 0, n <= numChoices -> return $ choices !! (n-1)
- | n == numChoices + 1, hasOther ->
- promptStr "Please specify" OptionalPrompt
- | otherwise -> invalidChoice (show n)
+ go = do
+ putStr $
+ mkDefPrompt "Your choice" $
+ maybe def (<$> def) modDef
+
+ input <- getLine
+ case def of
+ DefaultPrompt d | null input -> return d
+ _ -> case readMaybe input of
+ Nothing -> invalidChoice input
+ Just n
+ | n > 0, n <= numChoices -> return $ choices !! (n - 1)
+ | n == numChoices + 1
+ , hasOther ->
+ promptStr "Please specify" OptionalPrompt
+ | otherwise -> invalidChoice (show n)
-- | Create a prompt with an optional default value.
promptDefault
- :: Interactive m
- => (String -> Either String t)
- -- ^ parser
- -> (t -> String)
- -- ^ pretty-printer
- -> String
- -- ^ prompt message
- -> (DefaultPrompt t)
- -- ^ optional default value
- -> m t
+ :: Interactive m
+ => (String -> Either String t)
+ -- ^ parser
+ -> (t -> String)
+ -- ^ pretty-printer
+ -> String
+ -- ^ prompt message
+ -> (DefaultPrompt t)
+ -- ^ optional default value
+ -> m t
promptDefault parse pprint msg def = do
putStr $ mkDefPrompt msg (pprint <$> def)
hFlush System.IO.stdout
input <- getLine
case def of
- DefaultPrompt d | null input -> return d
- _ -> case parse input of
- Right t -> return t
+ DefaultPrompt d | null input -> return d
+ _ -> case parse input of
+ Right t -> return t
Left err -> do
putStrLn $ "Couldn't parse " ++ input ++ ", please try again!"
breakOrContinue
@@ -164,8 +171,8 @@ promptDefault parse pprint msg def = do
-- | Prompt utility for breaking out of an interactive loop
-- in the pure case
---
breakOrContinue :: Interactive m => String -> m a -> m a
-breakOrContinue msg act = break >>= \case
+breakOrContinue msg act =
+ break >>= \case
True -> throwPrompt $ BreakException msg
False -> act
diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs
index 1b624b373a3e9c15a90cfaf7b4151ab6c9df5680..4d413085547f6d4eda29b9e0b0425374d88541df 100644
--- a/cabal-install/src/Distribution/Client/Init/Simple.hs
+++ b/cabal-install/src/Distribution/Client/Init/Simple.hs
@@ -1,90 +1,111 @@
module Distribution.Client.Init.Simple
-( -- * Project creation
- createProject
- -- * Gen targets
-, genSimplePkgDesc
-, genSimpleLibTarget
-, genSimpleExeTarget
-, genSimpleTestTarget
-) where
+ ( -- * Project creation
+ createProject
+ -- * Gen targets
+ , genSimplePkgDesc
+ , genSimpleLibTarget
+ , genSimpleExeTarget
+ , genSimpleTestTarget
+ ) where
-import Distribution.Client.Init.Types
-import Distribution.Verbosity
-import Distribution.Simple.PackageIndex
-import Distribution.Client.Types.SourcePackageDb (SourcePackageDb(..))
import qualified Data.List.NonEmpty as NEL
-import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep, fixupDocFiles)
+import qualified Data.Set as Set
import Distribution.Client.Init.Defaults
-import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag (..))
import Distribution.Client.Init.FlagExtractors
-import qualified Data.Set as Set
+import Distribution.Client.Init.Types
+import Distribution.Client.Init.Utils (currentDirPkgName, fixupDocFiles, mkPackageNameDep)
+import Distribution.Client.Types.SourcePackageDb (SourcePackageDb (..))
+import Distribution.Simple.Flag (Flag (..), flagElim, fromFlagOrDefault)
+import Distribution.Simple.PackageIndex
import Distribution.Types.Dependency
import Distribution.Types.PackageName (unPackageName)
-
+import Distribution.Verbosity
createProject
- :: Interactive m
- => Verbosity
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> InitFlags
- -> m ProjectSettings
+ :: Interactive m
+ => Verbosity
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> InitFlags
+ -> m ProjectSettings
createProject v pkgIx _srcDb initFlags = do
- pkgType <- packageTypePrompt initFlags
- isMinimal <- getMinimal initFlags
- doOverwrite <- getOverwrite initFlags
- pkgDir <- getPackageDir initFlags
- pkgDesc <- fixupDocFiles v =<< genSimplePkgDesc initFlags
-
- let pkgName = _pkgName pkgDesc
- cabalSpec = _pkgCabalVersion pkgDesc
- mkOpts cs = WriteOpts
- doOverwrite isMinimal cs
- v pkgDir pkgType pkgName
-
- basedFlags <- addBaseDepToFlags pkgIx initFlags
-
- case pkgType of
- Library -> do
- libTarget <- genSimpleLibTarget basedFlags
- testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags
- return $ ProjectSettings
- (mkOpts False cabalSpec) pkgDesc
- (Just libTarget) Nothing testTarget
-
- Executable -> do
- exeTarget <- genSimpleExeTarget basedFlags
- return $ ProjectSettings
- (mkOpts False cabalSpec) pkgDesc
- Nothing (Just exeTarget) Nothing
-
- LibraryAndExecutable -> do
- libTarget <- genSimpleLibTarget basedFlags
- testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags
- exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget basedFlags
- return $ ProjectSettings
- (mkOpts False cabalSpec) pkgDesc
- (Just libTarget) (Just exeTarget) testTarget
-
- TestSuite -> do
- testTarget <- genSimpleTestTarget basedFlags
- return $ ProjectSettings
- (mkOpts False cabalSpec) pkgDesc
- Nothing Nothing testTarget
+ pkgType <- packageTypePrompt initFlags
+ isMinimal <- getMinimal initFlags
+ doOverwrite <- getOverwrite initFlags
+ pkgDir <- getPackageDir initFlags
+ pkgDesc <- fixupDocFiles v =<< genSimplePkgDesc initFlags
+
+ let pkgName = _pkgName pkgDesc
+ cabalSpec = _pkgCabalVersion pkgDesc
+ mkOpts cs =
+ WriteOpts
+ doOverwrite
+ isMinimal
+ cs
+ v
+ pkgDir
+ pkgType
+ pkgName
+
+ basedFlags <- addBaseDepToFlags pkgIx initFlags
+
+ case pkgType of
+ Library -> do
+ libTarget <- genSimpleLibTarget basedFlags
+ testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags
+ return $
+ ProjectSettings
+ (mkOpts False cabalSpec)
+ pkgDesc
+ (Just libTarget)
+ Nothing
+ testTarget
+ Executable -> do
+ exeTarget <- genSimpleExeTarget basedFlags
+ return $
+ ProjectSettings
+ (mkOpts False cabalSpec)
+ pkgDesc
+ Nothing
+ (Just exeTarget)
+ Nothing
+ LibraryAndExecutable -> do
+ libTarget <- genSimpleLibTarget basedFlags
+ testTarget <- addLibDepToTest pkgName <$> genSimpleTestTarget basedFlags
+ exeTarget <- addLibDepToExe pkgName <$> genSimpleExeTarget basedFlags
+ return $
+ ProjectSettings
+ (mkOpts False cabalSpec)
+ pkgDesc
+ (Just libTarget)
+ (Just exeTarget)
+ testTarget
+ TestSuite -> do
+ testTarget <- genSimpleTestTarget basedFlags
+ return $
+ ProjectSettings
+ (mkOpts False cabalSpec)
+ pkgDesc
+ Nothing
+ Nothing
+ testTarget
where
-- Add package name as dependency of test suite
--
addLibDepToTest _ Nothing = Nothing
- addLibDepToTest n (Just t) = Just $ t
- { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]
- }
+ addLibDepToTest n (Just t) =
+ Just $
+ t
+ { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]
+ }
-- Add package name as dependency of executable
--
- addLibDepToExe n exe = exe
- { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]
- }
+ addLibDepToExe n exe =
+ exe
+ { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]
+ }
genSimplePkgDesc :: Interactive m => InitFlags -> m PkgDescription
genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName
@@ -94,44 +115,46 @@ genSimplePkgDesc flags = mkPkgDesc <$> currentDirPkgName
extractExtraDoc [] = defaultExtraDoc
extractExtraDoc fs = Just $ Set.fromList fs
- mkPkgDesc pkgName = PkgDescription
- (fromFlagOrDefault defaultCabalVersion (cabalVersion flags))
- pkgName
- (fromFlagOrDefault defaultVersion (version flags))
- (fromFlagOrDefault (defaultLicense $ getCabalVersionNoPrompt flags) (license flags))
- (fromFlagOrDefault "" (author flags))
- (fromFlagOrDefault "" (email flags))
- (fromFlagOrDefault "" (homepage flags))
- (fromFlagOrDefault "" (synopsis flags))
- (fromFlagOrDefault "" (category flags))
- (flagElim mempty Set.fromList (extraSrc flags))
- (flagElim defaultExtraDoc extractExtraDoc (extraDoc flags))
+ mkPkgDesc pkgName =
+ PkgDescription
+ (fromFlagOrDefault defaultCabalVersion (cabalVersion flags))
+ pkgName
+ (fromFlagOrDefault defaultVersion (version flags))
+ (fromFlagOrDefault (defaultLicense $ getCabalVersionNoPrompt flags) (license flags))
+ (fromFlagOrDefault "" (author flags))
+ (fromFlagOrDefault "" (email flags))
+ (fromFlagOrDefault "" (homepage flags))
+ (fromFlagOrDefault "" (synopsis flags))
+ (fromFlagOrDefault "" (category flags))
+ (flagElim mempty Set.fromList (extraSrc flags))
+ (flagElim defaultExtraDoc extractExtraDoc (extraDoc flags))
genSimpleLibTarget :: Interactive m => InitFlags -> m LibTarget
genSimpleLibTarget flags = do
- buildToolDeps <- getBuildTools flags
- return $ LibTarget
+ buildToolDeps <- getBuildTools flags
+ return $
+ LibTarget
{ _libSourceDirs = fromFlagOrDefault [defaultSourceDir] $ sourceDirs flags
, _libLanguage = fromFlagOrDefault defaultLanguage $ language flags
, _libExposedModules =
- flagElim (myLibModule NEL.:| []) extractMods $ exposedModules flags
+ flagElim (myLibModule NEL.:| []) extractMods $ exposedModules flags
, _libOtherModules = fromFlagOrDefault [] $ otherModules flags
, _libOtherExts = fromFlagOrDefault [] $ otherExts flags
, _libDependencies = fromFlagOrDefault [] $ dependencies flags
, _libBuildTools = buildToolDeps
}
-
where
extractMods [] = myLibModule NEL.:| []
extractMods as = NEL.fromList as
genSimpleExeTarget :: Interactive m => InitFlags -> m ExeTarget
genSimpleExeTarget flags = do
- buildToolDeps <- getBuildTools flags
- return $ ExeTarget
+ buildToolDeps <- getBuildTools flags
+ return $
+ ExeTarget
{ _exeMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags
- , _exeApplicationDirs =
- fromFlagOrDefault [defaultApplicationDir] $ applicationDirs flags
+ , _exeApplicationDirs =
+ fromFlagOrDefault [defaultApplicationDir] $ applicationDirs flags
, _exeLanguage = fromFlagOrDefault defaultLanguage $ language flags
, _exeOtherModules = fromFlagOrDefault [] $ otherModules flags
, _exeOtherExts = fromFlagOrDefault [] $ otherExts flags
@@ -145,16 +168,18 @@ genSimpleTestTarget flags = go =<< initializeTestSuitePrompt flags
go initialized
| not initialized = return Nothing
| otherwise = do
- buildToolDeps <- getBuildTools flags
- return $ Just $ TestTarget
- { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags
- , _testDirs = fromFlagOrDefault [defaultTestDir] $ testDirs flags
- , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags
- , _testOtherModules = fromFlagOrDefault [] $ otherModules flags
- , _testOtherExts = fromFlagOrDefault [] $ otherExts flags
- , _testDependencies = fromFlagOrDefault [] $ dependencies flags
- , _testBuildTools = buildToolDeps
- }
+ buildToolDeps <- getBuildTools flags
+ return $
+ Just $
+ TestTarget
+ { _testMainIs = flagElim defaultMainIs toHsFilePath $ mainIs flags
+ , _testDirs = fromFlagOrDefault [defaultTestDir] $ testDirs flags
+ , _testLanguage = fromFlagOrDefault defaultLanguage $ language flags
+ , _testOtherModules = fromFlagOrDefault [] $ otherModules flags
+ , _testOtherExts = fromFlagOrDefault [] $ otherExts flags
+ , _testDependencies = fromFlagOrDefault [] $ dependencies flags
+ , _testBuildTools = buildToolDeps
+ }
-- -------------------------------------------------------------------- --
-- Utils
@@ -166,10 +191,11 @@ addBaseDepToFlags pkgIx initFlags = case dependencies initFlags of
Flag as
| any ((==) "base" . unPackageName . depPkgName) as -> return initFlags
| otherwise -> do
- based <- dependenciesPrompt pkgIx initFlags
- return $ initFlags
- { dependencies = Flag $ based ++ as
- }
+ based <- dependenciesPrompt pkgIx initFlags
+ return $
+ initFlags
+ { dependencies = Flag $ based ++ as
+ }
NoFlag -> do
based <- dependenciesPrompt pkgIx initFlags
- return initFlags { dependencies = Flag based }
+ return initFlags{dependencies = Flag based}
diff --git a/cabal-install/src/Distribution/Client/Init/Types.hs b/cabal-install/src/Distribution/Client/Init/Types.hs
index 36d32a89977a23fad6d542546838eb4a8eaf8d0b..41513d0f048b6eb536cd049a1ff94879d62282bc 100644
--- a/cabal-install/src/Distribution/Client/Init/Types.hs
+++ b/cabal-install/src/Distribution/Client/Init/Types.hs
@@ -1,7 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE BangPatterns #-}
+
-- |
-- Module : Distribution.Client.Init.Types
-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009
@@ -12,71 +13,75 @@
-- Portability : portable
--
-- Some types used by the 'cabal init' command.
---
module Distribution.Client.Init.Types
-( -- * Data
- InitFlags(..)
- -- ** Targets and descriptions
-, PkgDescription(..)
-, LibTarget(..)
-, ExeTarget(..)
-, TestTarget(..)
- -- ** package types
-, PackageType(..)
- -- ** Main file
-, HsFilePath(..)
-, HsFileType(..)
-, fromHsFilePath
-, toHsFilePath
-, toLiterateHs
-, toStandardHs
-, mkLiterate
-, isHsFilePath
- -- * Typeclasses
-, Interactive(..)
-, BreakException(..)
-, PurePrompt(..)
-, evalPrompt
-, Severity(..)
- -- * Aliases
-, IsLiterate
-, IsSimple
- -- * File creator opts
-, WriteOpts(..)
-, ProjectSettings(..)
- -- * Formatters
-, FieldAnnotation(..)
- -- * Other conveniences
-, DefaultPrompt(..)
-) where
-
+ ( -- * Data
+ InitFlags (..)
+
+ -- ** Targets and descriptions
+ , PkgDescription (..)
+ , LibTarget (..)
+ , ExeTarget (..)
+ , TestTarget (..)
+
+ -- ** package types
+ , PackageType (..)
+
+ -- ** Main file
+ , HsFilePath (..)
+ , HsFileType (..)
+ , fromHsFilePath
+ , toHsFilePath
+ , toLiterateHs
+ , toStandardHs
+ , mkLiterate
+ , isHsFilePath
+
+ -- * Typeclasses
+ , Interactive (..)
+ , BreakException (..)
+ , PurePrompt (..)
+ , evalPrompt
+ , Severity (..)
+
+ -- * Aliases
+ , IsLiterate
+ , IsSimple
+
+ -- * File creator opts
+ , WriteOpts (..)
+ , ProjectSettings (..)
+
+ -- * Formatters
+ , FieldAnnotation (..)
+
+ -- * Other conveniences
+ , DefaultPrompt (..)
+ ) where
-import qualified Distribution.Client.Compat.Prelude as P
import Distribution.Client.Compat.Prelude as P hiding (getLine, putStr, putStrLn)
+import qualified Distribution.Client.Compat.Prelude as P
import Prelude (read)
import Control.Monad.Catch
import Data.List.NonEmpty (fromList)
-import Distribution.Simple.Setup (Flag(..))
-import Distribution.Types.Dependency as P
-import Distribution.Verbosity (silent)
-import Distribution.Version
-import qualified Distribution.Package as P
-import Distribution.ModuleName
import Distribution.CabalSpecVersion
import Distribution.Client.Utils as P
import Distribution.Fields.Pretty
-import Language.Haskell.Extension ( Language(..), Extension )
+import Distribution.ModuleName
+import qualified Distribution.Package as P
+import Distribution.Simple.Setup (Flag (..))
+import Distribution.Verbosity (silent)
+import Distribution.Version
+import Language.Haskell.Extension (Extension, Language (..))
import qualified System.IO
-import qualified System.Directory as P
-import qualified System.Process as Process
import qualified Distribution.Compat.Environment as P
-import System.FilePath
import Distribution.FieldGrammar.Newtypes (SpecLicense)
-
+import qualified System.Directory as P
+import System.FilePath
+import qualified System.Process as Process
-- -------------------------------------------------------------------- --
-- Flags
@@ -84,42 +89,41 @@ import Distribution.FieldGrammar.Newtypes (SpecLicense)
-- | InitFlags is a subset of flags available in the
-- @.cabal@ file that represent options that are relevant to the
-- init command process.
---
-data InitFlags =
- InitFlags
- { interactive :: Flag Bool
- , quiet :: Flag Bool
- , packageDir :: Flag FilePath
- , noComments :: Flag Bool
- , minimal :: Flag Bool
- , simpleProject :: Flag Bool
- , packageName :: Flag P.PackageName
- , version :: Flag Version
- , cabalVersion :: Flag CabalSpecVersion
- , license :: Flag SpecLicense
- , author :: Flag String
- , email :: Flag String
- , homepage :: Flag String
- , synopsis :: Flag String
- , category :: Flag String
- , extraSrc :: Flag [String]
- , extraDoc :: Flag [String]
- , packageType :: Flag PackageType
- , mainIs :: Flag FilePath
- , language :: Flag Language
- , exposedModules :: Flag [ModuleName]
- , otherModules :: Flag [ModuleName]
- , otherExts :: Flag [Extension]
- , dependencies :: Flag [P.Dependency]
- , applicationDirs :: Flag [String]
- , sourceDirs :: Flag [String]
- , buildTools :: Flag [String]
- , initializeTestSuite :: Flag Bool
- , testDirs :: Flag [String]
- , initHcPath :: Flag FilePath
- , initVerbosity :: Flag Verbosity
- , overwrite :: Flag Bool
- } deriving (Eq, Show, Generic)
+data InitFlags = InitFlags
+ { interactive :: Flag Bool
+ , quiet :: Flag Bool
+ , packageDir :: Flag FilePath
+ , noComments :: Flag Bool
+ , minimal :: Flag Bool
+ , simpleProject :: Flag Bool
+ , packageName :: Flag P.PackageName
+ , version :: Flag Version
+ , cabalVersion :: Flag CabalSpecVersion
+ , license :: Flag SpecLicense
+ , author :: Flag String
+ , email :: Flag String
+ , homepage :: Flag String
+ , synopsis :: Flag String
+ , category :: Flag String
+ , extraSrc :: Flag [String]
+ , extraDoc :: Flag [String]
+ , packageType :: Flag PackageType
+ , mainIs :: Flag FilePath
+ , language :: Flag Language
+ , exposedModules :: Flag [ModuleName]
+ , otherModules :: Flag [ModuleName]
+ , otherExts :: Flag [Extension]
+ , dependencies :: Flag [P.Dependency]
+ , applicationDirs :: Flag [String]
+ , sourceDirs :: Flag [String]
+ , buildTools :: Flag [String]
+ , initializeTestSuite :: Flag Bool
+ , testDirs :: Flag [String]
+ , initHcPath :: Flag FilePath
+ , initVerbosity :: Flag Verbosity
+ , overwrite :: Flag Bool
+ }
+ deriving (Eq, Show, Generic)
instance Monoid InitFlags where
mempty = gmempty
@@ -134,322 +138,329 @@ instance Semigroup InitFlags where
-- | 'PkgDescription' represents the relevant options set by the
-- user when building a package description during the init command
-- process.
---
data PkgDescription = PkgDescription
- { _pkgCabalVersion :: CabalSpecVersion
- , _pkgName :: P.PackageName
- , _pkgVersion :: Version
- , _pkgLicense :: SpecLicense
- , _pkgAuthor :: String
- , _pkgEmail :: String
- , _pkgHomePage :: String
- , _pkgSynopsis :: String
- , _pkgCategory :: String
- , _pkgExtraSrcFiles :: Set String
- , _pkgExtraDocFiles :: Maybe (Set String)
- } deriving (Show, Eq)
+ { _pkgCabalVersion :: CabalSpecVersion
+ , _pkgName :: P.PackageName
+ , _pkgVersion :: Version
+ , _pkgLicense :: SpecLicense
+ , _pkgAuthor :: String
+ , _pkgEmail :: String
+ , _pkgHomePage :: String
+ , _pkgSynopsis :: String
+ , _pkgCategory :: String
+ , _pkgExtraSrcFiles :: Set String
+ , _pkgExtraDocFiles :: Maybe (Set String)
+ }
+ deriving (Show, Eq)
-- | 'LibTarget' represents the relevant options set by the
-- user when building a library package during the init command
-- process.
---
data LibTarget = LibTarget
- { _libSourceDirs :: [String]
- , _libLanguage :: Language
- , _libExposedModules :: NonEmpty ModuleName
- , _libOtherModules :: [ModuleName]
- , _libOtherExts :: [Extension]
- , _libDependencies :: [P.Dependency]
- , _libBuildTools :: [P.Dependency]
- } deriving (Show, Eq)
+ { _libSourceDirs :: [String]
+ , _libLanguage :: Language
+ , _libExposedModules :: NonEmpty ModuleName
+ , _libOtherModules :: [ModuleName]
+ , _libOtherExts :: [Extension]
+ , _libDependencies :: [P.Dependency]
+ , _libBuildTools :: [P.Dependency]
+ }
+ deriving (Show, Eq)
-- | 'ExeTarget' represents the relevant options set by the
-- user when building an executable package.
---
data ExeTarget = ExeTarget
- { _exeMainIs :: HsFilePath
- , _exeApplicationDirs :: [String]
- , _exeLanguage :: Language
- , _exeOtherModules :: [ModuleName]
- , _exeOtherExts :: [Extension]
- , _exeDependencies :: [P.Dependency]
- , _exeBuildTools :: [P.Dependency]
- } deriving (Show, Eq)
+ { _exeMainIs :: HsFilePath
+ , _exeApplicationDirs :: [String]
+ , _exeLanguage :: Language
+ , _exeOtherModules :: [ModuleName]
+ , _exeOtherExts :: [Extension]
+ , _exeDependencies :: [P.Dependency]
+ , _exeBuildTools :: [P.Dependency]
+ }
+ deriving (Show, Eq)
-- | 'TestTarget' represents the relevant options set by the
-- user when building a library package.
---
data TestTarget = TestTarget
- { _testMainIs :: HsFilePath
- , _testDirs :: [String]
- , _testLanguage :: Language
- , _testOtherModules :: [ModuleName]
- , _testOtherExts :: [Extension]
- , _testDependencies :: [P.Dependency]
- , _testBuildTools :: [P.Dependency]
- } deriving (Show, Eq)
+ { _testMainIs :: HsFilePath
+ , _testDirs :: [String]
+ , _testLanguage :: Language
+ , _testOtherModules :: [ModuleName]
+ , _testOtherExts :: [Extension]
+ , _testDependencies :: [P.Dependency]
+ , _testBuildTools :: [P.Dependency]
+ }
+ deriving (Show, Eq)
-- -------------------------------------------------------------------- --
-- File creator options
data WriteOpts = WriteOpts
- { _optOverwrite :: Bool
- , _optMinimal :: Bool
- , _optNoComments :: Bool
- , _optVerbosity :: Verbosity
- , _optPkgDir :: FilePath
- , _optPkgType :: PackageType
- , _optPkgName :: P.PackageName
- , _optCabalSpec :: CabalSpecVersion
- } deriving (Eq, Show)
+ { _optOverwrite :: Bool
+ , _optMinimal :: Bool
+ , _optNoComments :: Bool
+ , _optVerbosity :: Verbosity
+ , _optPkgDir :: FilePath
+ , _optPkgType :: PackageType
+ , _optPkgName :: P.PackageName
+ , _optCabalSpec :: CabalSpecVersion
+ }
+ deriving (Eq, Show)
data ProjectSettings = ProjectSettings
- { _pkgOpts :: WriteOpts
- , _pkgDesc :: PkgDescription
- , _pkgLibTarget :: Maybe LibTarget
- , _pkgExeTarget :: Maybe ExeTarget
- , _pkgTestTarget :: Maybe TestTarget
- } deriving (Eq, Show)
+ { _pkgOpts :: WriteOpts
+ , _pkgDesc :: PkgDescription
+ , _pkgLibTarget :: Maybe LibTarget
+ , _pkgExeTarget :: Maybe ExeTarget
+ , _pkgTestTarget :: Maybe TestTarget
+ }
+ deriving (Eq, Show)
-- -------------------------------------------------------------------- --
-- Other types
-- | Enum to denote whether the user wants to build a library target,
-- executable target, library and executable targets, or a standalone test suite.
---
data PackageType = Library | Executable | LibraryAndExecutable | TestSuite
- deriving (Eq, Show, Generic)
+ deriving (Eq, Show, Generic)
data HsFileType
- = Literate
- | Standard
- | InvalidHsPath
- deriving (Eq, Show)
+ = Literate
+ | Standard
+ | InvalidHsPath
+ deriving (Eq, Show)
data HsFilePath = HsFilePath
- { _hsFilePath :: FilePath
- , _hsFileType :: HsFileType
- } deriving Eq
+ { _hsFilePath :: FilePath
+ , _hsFileType :: HsFileType
+ }
+ deriving (Eq)
instance Show HsFilePath where
- show (HsFilePath fp ty) = case ty of
- Literate -> fp
- Standard -> fp
- InvalidHsPath -> "Invalid haskell source file: " ++ fp
+ show (HsFilePath fp ty) = case ty of
+ Literate -> fp
+ Standard -> fp
+ InvalidHsPath -> "Invalid haskell source file: " ++ fp
fromHsFilePath :: HsFilePath -> Maybe FilePath
fromHsFilePath (HsFilePath fp ty) = case ty of
- Literate -> Just fp
- Standard -> Just fp
- InvalidHsPath -> Nothing
+ Literate -> Just fp
+ Standard -> Just fp
+ InvalidHsPath -> Nothing
isHsFilePath :: FilePath -> Bool
isHsFilePath fp = case _hsFileType $ toHsFilePath fp of
- InvalidHsPath -> False
- _ -> True
+ InvalidHsPath -> False
+ _ -> True
toHsFilePath :: FilePath -> HsFilePath
toHsFilePath fp
- | takeExtension fp == ".lhs" = HsFilePath fp Literate
- | takeExtension fp == ".hs" = HsFilePath fp Standard
- | otherwise = HsFilePath fp InvalidHsPath
+ | takeExtension fp == ".lhs" = HsFilePath fp Literate
+ | takeExtension fp == ".hs" = HsFilePath fp Standard
+ | otherwise = HsFilePath fp InvalidHsPath
toLiterateHs :: HsFilePath -> HsFilePath
-toLiterateHs (HsFilePath fp Standard) = HsFilePath
+toLiterateHs (HsFilePath fp Standard) =
+ HsFilePath
(dropExtension fp ++ ".lhs")
Literate
toLiterateHs a = a
toStandardHs :: HsFilePath -> HsFilePath
-toStandardHs (HsFilePath fp Literate) = HsFilePath
+toStandardHs (HsFilePath fp Literate) =
+ HsFilePath
(dropExtension fp ++ ".hs")
Standard
toStandardHs a = a
mkLiterate :: HsFilePath -> [String] -> [String]
mkLiterate (HsFilePath _ Literate) hs =
- (\line -> if null line then line else "> " ++ line) <$> hs
+ (\line -> if null line then line else "> " ++ line) <$> hs
mkLiterate _ hs = hs
-- -------------------------------------------------------------------- --
-- Interactive prompt monad
newtype PurePrompt a = PurePrompt
- { _runPrompt
- :: NonEmpty String
- -> Either BreakException (a, NonEmpty String)
- } deriving (Functor)
+ { _runPrompt
+ :: NonEmpty String
+ -> Either BreakException (a, NonEmpty String)
+ }
+ deriving (Functor)
evalPrompt :: PurePrompt a -> NonEmpty String -> a
evalPrompt act s = case _runPrompt act s of
- Left e -> error $ show e
- Right (a,_) -> a
+ Left e -> error $ show e
+ Right (a, _) -> a
instance Applicative PurePrompt where
- pure a = PurePrompt $ \s -> Right (a, s)
- PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of
+ pure a = PurePrompt $ \s -> Right (a, s)
+ PurePrompt ff <*> PurePrompt aa = PurePrompt $ \s -> case ff s of
+ Left e -> Left e
+ Right (f, s') -> case aa s' of
Left e -> Left e
- Right (f, s') -> case aa s' of
- Left e -> Left e
- Right (a, s'') -> Right (f a, s'')
+ Right (a, s'') -> Right (f a, s'')
instance Monad PurePrompt where
- return = pure
- PurePrompt a >>= k = PurePrompt $ \s -> case a s of
- Left e -> Left e
- Right (a', s') -> _runPrompt (k a') s'
+ return = pure
+ PurePrompt a >>= k = PurePrompt $ \s -> case a s of
+ Left e -> Left e
+ Right (a', s') -> _runPrompt (k a') s'
class Monad m => Interactive m where
- -- input functions
- getLine :: m String
- readFile :: FilePath -> m String
- getCurrentDirectory :: m FilePath
- getHomeDirectory :: m FilePath
- getDirectoryContents :: FilePath -> m [FilePath]
- listDirectory :: FilePath -> m [FilePath]
- doesDirectoryExist :: FilePath -> m Bool
- doesFileExist :: FilePath -> m Bool
- canonicalizePathNoThrow :: FilePath -> m FilePath
- readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String)
- getEnvironment :: m [(String, String)]
- getCurrentYear :: m Integer
- listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath]
- listFilesRecursive :: FilePath -> m [FilePath]
-
- -- output functions
- putStr :: String -> m ()
- putStrLn :: String -> m ()
- createDirectory :: FilePath -> m ()
- removeDirectory :: FilePath -> m ()
- writeFile :: FilePath -> String -> m ()
- removeExistingFile :: FilePath -> m ()
- copyFile :: FilePath -> FilePath -> m ()
- renameDirectory :: FilePath -> FilePath -> m ()
- hFlush :: System.IO.Handle -> m ()
- message :: Verbosity -> Severity -> String -> m ()
-
- -- misc functions
- break :: m Bool
- throwPrompt :: BreakException -> m a
+ -- input functions
+ getLine :: m String
+ readFile :: FilePath -> m String
+ getCurrentDirectory :: m FilePath
+ getHomeDirectory :: m FilePath
+ getDirectoryContents :: FilePath -> m [FilePath]
+ listDirectory :: FilePath -> m [FilePath]
+ doesDirectoryExist :: FilePath -> m Bool
+ doesFileExist :: FilePath -> m Bool
+ canonicalizePathNoThrow :: FilePath -> m FilePath
+ readProcessWithExitCode :: FilePath -> [String] -> String -> m (ExitCode, String, String)
+ getEnvironment :: m [(String, String)]
+ getCurrentYear :: m Integer
+ listFilesInside :: (FilePath -> m Bool) -> FilePath -> m [FilePath]
+ listFilesRecursive :: FilePath -> m [FilePath]
+
+ -- output functions
+ putStr :: String -> m ()
+ putStrLn :: String -> m ()
+ createDirectory :: FilePath -> m ()
+ removeDirectory :: FilePath -> m ()
+ writeFile :: FilePath -> String -> m ()
+ removeExistingFile :: FilePath -> m ()
+ copyFile :: FilePath -> FilePath -> m ()
+ renameDirectory :: FilePath -> FilePath -> m ()
+ hFlush :: System.IO.Handle -> m ()
+ message :: Verbosity -> Severity -> String -> m ()
+
+ -- misc functions
+ break :: m Bool
+ throwPrompt :: BreakException -> m a
instance Interactive IO where
- getLine = P.getLine
- readFile = P.readFile
- getCurrentDirectory = P.getCurrentDirectory
- getHomeDirectory = P.getHomeDirectory
- getDirectoryContents = P.getDirectoryContents
- listDirectory = P.listDirectory
- doesDirectoryExist = P.doesDirectoryExist
- doesFileExist = P.doesFileExist
- canonicalizePathNoThrow = P.canonicalizePathNoThrow
- readProcessWithExitCode = Process.readProcessWithExitCode
- getEnvironment = P.getEnvironment
- getCurrentYear = P.getCurrentYear
- listFilesInside = P.listFilesInside
- listFilesRecursive = P.listFilesRecursive
-
- putStr = P.putStr
- putStrLn = P.putStrLn
- createDirectory = P.createDirectory
- removeDirectory = P.removeDirectoryRecursive
- writeFile = P.writeFile
- removeExistingFile = P.removeExistingFile
- copyFile = P.copyFile
- renameDirectory = P.renameDirectory
- hFlush = System.IO.hFlush
- message q severity msg
- | q == silent = pure ()
- | otherwise = putStrLn $ "[" ++ show severity ++ "] " ++ msg
- break = return False
- throwPrompt = throwM
+ getLine = P.getLine
+ readFile = P.readFile
+ getCurrentDirectory = P.getCurrentDirectory
+ getHomeDirectory = P.getHomeDirectory
+ getDirectoryContents = P.getDirectoryContents
+ listDirectory = P.listDirectory
+ doesDirectoryExist = P.doesDirectoryExist
+ doesFileExist = P.doesFileExist
+ canonicalizePathNoThrow = P.canonicalizePathNoThrow
+ readProcessWithExitCode = Process.readProcessWithExitCode
+ getEnvironment = P.getEnvironment
+ getCurrentYear = P.getCurrentYear
+ listFilesInside = P.listFilesInside
+ listFilesRecursive = P.listFilesRecursive
+
+ putStr = P.putStr
+ putStrLn = P.putStrLn
+ createDirectory = P.createDirectory
+ removeDirectory = P.removeDirectoryRecursive
+ writeFile = P.writeFile
+ removeExistingFile = P.removeExistingFile
+ copyFile = P.copyFile
+ renameDirectory = P.renameDirectory
+ hFlush = System.IO.hFlush
+ message q severity msg
+ | q == silent = pure ()
+ | otherwise = putStrLn $ "[" ++ show severity ++ "] " ++ msg
+ break = return False
+ throwPrompt = throwM
instance Interactive PurePrompt where
- getLine = pop
- readFile !_ = pop
- getCurrentDirectory = popAbsolute
- getHomeDirectory = popAbsolute
- -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]"
- getDirectoryContents !_ = popList
- listDirectory !_ = popList
- doesDirectoryExist !_ = popBool
- doesFileExist !_ = popBool
- canonicalizePathNoThrow !_ = popAbsolute
- readProcessWithExitCode !_ !_ !_ = do
- input <- pop
- return (ExitSuccess, input, "")
- getEnvironment = fmap (map read) popList
- getCurrentYear = fmap read pop
- listFilesInside pred' !_ = do
- input <- map splitDirectories <$> popList
- map joinPath <$> filterM (fmap and . traverse pred') input
- listFilesRecursive !_ = popList
-
- putStr !_ = return ()
- putStrLn !_ = return ()
- createDirectory !d = checkInvalidPath d ()
- removeDirectory !d = checkInvalidPath d ()
- writeFile !f !_ = checkInvalidPath f ()
- removeExistingFile !f = checkInvalidPath f ()
- copyFile !f !_ = checkInvalidPath f ()
- renameDirectory !d !_ = checkInvalidPath d ()
- hFlush _ = return ()
- message !_ !severity !msg = case severity of
- Error -> PurePrompt $ \_ -> Left $ BreakException
- (show severity ++ ": " ++ msg)
- _ -> return ()
-
- break = return True
- throwPrompt (BreakException e) = PurePrompt $ \s -> Left $ BreakException
- ("Error: " ++ e ++ "\nStacktrace: " ++ show s)
+ getLine = pop
+ readFile !_ = pop
+ getCurrentDirectory = popAbsolute
+ getHomeDirectory = popAbsolute
+
+ -- expects stack input of form "[\"foo\", \"bar\", \"baz\"]"
+ getDirectoryContents !_ = popList
+ listDirectory !_ = popList
+ doesDirectoryExist !_ = popBool
+ doesFileExist !_ = popBool
+ canonicalizePathNoThrow !_ = popAbsolute
+ readProcessWithExitCode !_ !_ !_ = do
+ input <- pop
+ return (ExitSuccess, input, "")
+ getEnvironment = fmap (map read) popList
+ getCurrentYear = fmap read pop
+ listFilesInside pred' !_ = do
+ input <- map splitDirectories <$> popList
+ map joinPath <$> filterM (fmap and . traverse pred') input
+ listFilesRecursive !_ = popList
+
+ putStr !_ = return ()
+ putStrLn !_ = return ()
+ createDirectory !d = checkInvalidPath d ()
+ removeDirectory !d = checkInvalidPath d ()
+ writeFile !f !_ = checkInvalidPath f ()
+ removeExistingFile !f = checkInvalidPath f ()
+ copyFile !f !_ = checkInvalidPath f ()
+ renameDirectory !d !_ = checkInvalidPath d ()
+ hFlush _ = return ()
+ message !_ !severity !msg = case severity of
+ Error -> PurePrompt $ \_ ->
+ Left $
+ BreakException
+ (show severity ++ ": " ++ msg)
+ _ -> return ()
+
+ break = return True
+ throwPrompt (BreakException e) = PurePrompt $ \s ->
+ Left $
+ BreakException
+ ("Error: " ++ e ++ "\nStacktrace: " ++ show s)
pop :: PurePrompt String
-pop = PurePrompt $ \ (p:|ps) -> Right (p,fromList ps)
+pop = PurePrompt $ \(p :| ps) -> Right (p, fromList ps)
popAbsolute :: PurePrompt String
popAbsolute = do
- input <- pop
- return $ "/home/test/" ++ input
+ input <- pop
+ return $ "/home/test/" ++ input
popBool :: PurePrompt Bool
-popBool = pop >>= \case
+popBool =
+ pop >>= \case
"True" -> pure True
"False" -> pure False
s -> throwPrompt $ BreakException $ "popBool: " ++ s
popList :: PurePrompt [String]
-popList = pop >>= \a -> case P.safeRead a of
+popList =
+ pop >>= \a -> case P.safeRead a of
Nothing -> throwPrompt $ BreakException ("popList: " ++ show a)
Just as -> return as
checkInvalidPath :: String -> a -> PurePrompt a
checkInvalidPath path act =
- -- The check below is done this way so it's easier to append
- -- more invalid paths in the future, if necessary
- if path `elem` ["."] then
- throwPrompt $ BreakException $ "Invalid path: " ++ path
- else
- return act
+ -- The check below is done this way so it's easier to append
+ -- more invalid paths in the future, if necessary
+ if path `elem` ["."]
+ then throwPrompt $ BreakException $ "Invalid path: " ++ path
+ else return act
-- | A pure exception thrown exclusively by the pure prompter
-- to cancel infinite loops in the prompting process.
--
-- For example, in order to break on parse errors, or user-driven
-- continuations that do not make sense to test.
---
newtype BreakException = BreakException String deriving (Eq, Show)
instance Exception BreakException
-- | Used to inform the intent of prompted messages.
---
data Severity = Log | Info | Warning | Error deriving (Eq, Show)
-- | Convenience alias for the literate haskell flag
---
type IsLiterate = Bool
-- | Convenience alias for generating simple projects
---
type IsSimple = Bool
-- | Defines whether or not a prompt will have a default value,
@@ -466,7 +477,7 @@ data DefaultPrompt t
-- | Annotations for cabal file PrettyField.
data FieldAnnotation = FieldAnnotation
{ annCommentedOut :: Bool
- -- ^ True iif the field and its contents should be commented out.
+ -- ^ True iif the field and its contents should be commented out.
, annCommentLines :: CommentPosition
- -- ^ Comment lines to place before the field or section.
+ -- ^ Comment lines to place before the field or section.
}
diff --git a/cabal-install/src/Distribution/Client/Init/Utils.hs b/cabal-install/src/Distribution/Client/Init/Utils.hs
index 91d887e4e4674d362ebd2ff11d81cbbf0f7eaaf1..e8cde1184aec60323c46aedb0eaa56f0d2d3885c 100644
--- a/cabal-install/src/Distribution/Client/Init/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Init/Utils.hs
@@ -1,65 +1,64 @@
{-# LANGUAGE RecordWildCards #-}
module Distribution.Client.Init.Utils
-( SourceFileEntry(..)
-, retrieveSourceFiles
-, retrieveModuleName
-, retrieveModuleImports
-, retrieveModuleExtensions
-, retrieveBuildTools
-, retrieveDependencies
-, isMain
-, isHaskell
-, isSourceFile
-, trim
-, currentDirPkgName
-, filePathToPkgName
-, mkPackageNameDep
-, fixupDocFiles
-, mkStringyDep
-, getBaseDep
-, addLibDepToExe
-, addLibDepToTest
-) where
-
-
-import qualified Prelude ()
-import Distribution.Client.Compat.Prelude hiding (putStrLn, empty, readFile, Parsec, many)
+ ( SourceFileEntry (..)
+ , retrieveSourceFiles
+ , retrieveModuleName
+ , retrieveModuleImports
+ , retrieveModuleExtensions
+ , retrieveBuildTools
+ , retrieveDependencies
+ , isMain
+ , isHaskell
+ , isSourceFile
+ , trim
+ , currentDirPkgName
+ , filePathToPkgName
+ , mkPackageNameDep
+ , fixupDocFiles
+ , mkStringyDep
+ , getBaseDep
+ , addLibDepToExe
+ , addLibDepToTest
+ ) where
+
+import Distribution.Client.Compat.Prelude hiding (Parsec, empty, many, putStrLn, readFile)
import Distribution.Utils.Generic (isInfixOf, safeLast)
+import qualified Prelude ()
import Control.Monad (forM)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
-import Language.Haskell.Extension (Extension(..))
+import Language.Haskell.Extension (Extension (..))
import System.FilePath
-import Distribution.CabalSpecVersion (CabalSpecVersion(..))
-import Distribution.ModuleName (ModuleName)
-import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed)
-import qualified Distribution.Package as P
-import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex)
-import Distribution.Simple.Setup (Flag(..))
-import Distribution.Utils.String (trim)
-import Distribution.Version
+import Distribution.CabalSpecVersion (CabalSpecVersion (..))
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.Types
import Distribution.Client.Utils (pvpize)
-import Distribution.Types.PackageName
-import Distribution.Types.Dependency (Dependency, mkDependency)
import qualified Distribution.Compat.NonEmptySet as NES
+import Distribution.InstalledPackageInfo (InstalledPackageInfo, exposed)
+import Distribution.ModuleName (ModuleName)
+import qualified Distribution.Package as P
+import Distribution.Simple.PackageIndex (InstalledPackageIndex, moduleNameIndex)
+import Distribution.Simple.Setup (Flag (..))
+import Distribution.Types.Dependency (Dependency, mkDependency)
import Distribution.Types.LibraryName
+import Distribution.Types.PackageName
+import Distribution.Utils.String (trim)
import Distribution.Verbosity (silent)
+import Distribution.Version
-
--- |Data type of source files found in the working directory
+-- | Data type of source files found in the working directory
data SourceFileEntry = SourceFileEntry
- { relativeSourcePath :: FilePath
- , moduleName :: ModuleName
- , fileExtension :: String
- , imports :: [ModuleName]
- , extensions :: [Extension]
- } deriving Show
+ { relativeSourcePath :: FilePath
+ , moduleName :: ModuleName
+ , fileExtension :: String
+ , imports :: [ModuleName]
+ , extensions :: [Extension]
+ }
+ deriving (Show)
-- Unfortunately we cannot use the version exported by Distribution.Simple.Program
knownSuffixHandlers :: CabalSpecVersion -> String -> String
@@ -83,11 +82,12 @@ knownSuffixHandlers v s
".cpphs" -> "cpp:cpp"
_ -> ""
-
-- | Check if a given file has main file characteristics
isMain :: String -> Bool
-isMain f = (isInfixOf "Main" f || isInfixOf "main" f)
- && isSuffixOf ".hs" f || isSuffixOf ".lhs" f
+isMain f =
+ (isInfixOf "Main" f || isInfixOf "main" f)
+ && isSuffixOf ".hs" f
+ || isSuffixOf ".lhs" f
-- | Check if a given file has a Haskell extension
isHaskell :: String -> Bool
@@ -105,13 +105,12 @@ retrieveBuildTools v fp = do
let tools =
[ mkStringyDep (knownSuffixHandlers v f)
- | f <- files, isBuildTool v f
+ | f <- files
+ , isBuildTool v f
]
return tools
-
- else
- return []
+ else return []
retrieveSourceFiles :: Interactive m => FilePath -> m [SourceFileEntry]
retrieveSourceFiles fp = do
@@ -128,76 +127,69 @@ retrieveSourceFiles fp = do
case maybeModuleName of
Nothing -> return Nothing
Just moduleName -> do
-
- let fileExtension = takeExtension f
+ let fileExtension = takeExtension f
relativeSourcePath <- makeRelative f <$> getCurrentDirectory
- imports <- retrieveModuleImports f
- extensions <- retrieveModuleExtensions f
+ imports <- retrieveModuleImports f
+ extensions <- retrieveModuleExtensions f
- return . Just $ SourceFileEntry {..}
- else
- return Nothing
+ return . Just $ SourceFileEntry{..}
+ else return Nothing
return . catMaybes $ entries
-
- else
- return []
+ else return []
-- | Given a module, retrieve its name
retrieveModuleName :: Interactive m => FilePath -> m (Maybe ModuleName)
retrieveModuleName m = do
- rawModule <- trim . grabModuleName <$> readFile m
-
- if isInfixOf rawModule (dirToModuleName m)
- then
- return $ Just $ fromString rawModule
- else do
- putStrLn
- $ "Warning: found module that doesn't match directory structure: "
+ rawModule <- trim . grabModuleName <$> readFile m
+
+ if isInfixOf rawModule (dirToModuleName m)
+ then return $ Just $ fromString rawModule
+ else do
+ putStrLn $
+ "Warning: found module that doesn't match directory structure: "
++ rawModule
- return Nothing
+ return Nothing
where
dirToModuleName = map (\x -> if x == '/' || x == '\\' then '.' else x)
stop c = (c /= '\n') && (c /= ' ')
grabModuleName [] = []
- grabModuleName ('-':'-':xs) = grabModuleName $ dropWhile' (/= '\n') xs
- grabModuleName ('m':'o':'d':'u':'l':'e':' ':xs) = takeWhile' stop xs
- grabModuleName (_:xs) = grabModuleName xs
+ grabModuleName ('-' : '-' : xs) = grabModuleName $ dropWhile' (/= '\n') xs
+ grabModuleName ('m' : 'o' : 'd' : 'u' : 'l' : 'e' : ' ' : xs) = takeWhile' stop xs
+ grabModuleName (_ : xs) = grabModuleName xs
-- | Given a module, retrieve all of its imports
retrieveModuleImports :: Interactive m => FilePath -> m [ModuleName]
retrieveModuleImports m = do
map (fromString . trim) . grabModuleImports <$> readFile m
-
where
stop c = (c /= '\n') && (c /= ' ') && (c /= '(')
grabModuleImports [] = []
- grabModuleImports ('-':'-':xs) = grabModuleImports $ dropWhile' (/= '\n') xs
- grabModuleImports ('i':'m':'p':'o':'r':'t':' ':xs) = case trim xs of -- in case someone uses a weird formatting
- ('q':'u':'a':'l':'i':'f':'i':'e':'d':' ':ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys)
- _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs)
- grabModuleImports (_:xs) = grabModuleImports xs
+ grabModuleImports ('-' : '-' : xs) = grabModuleImports $ dropWhile' (/= '\n') xs
+ grabModuleImports ('i' : 'm' : 'p' : 'o' : 'r' : 't' : ' ' : xs) = case trim xs of -- in case someone uses a weird formatting
+ ('q' : 'u' : 'a' : 'l' : 'i' : 'f' : 'i' : 'e' : 'd' : ' ' : ys) -> takeWhile' stop ys : grabModuleImports (dropWhile' stop ys)
+ _ -> takeWhile' stop xs : grabModuleImports (dropWhile' stop xs)
+ grabModuleImports (_ : xs) = grabModuleImports xs
-- | Given a module, retrieve all of its language pragmas
retrieveModuleExtensions :: Interactive m => FilePath -> m [Extension]
retrieveModuleExtensions m = do
catMaybes <$> map (simpleParsec . trim) . grabModuleExtensions <$> readFile m
-
where
stop c = (c /= '\n') && (c /= ' ') && (c /= ',') && (c /= '#')
grabModuleExtensions [] = []
- grabModuleExtensions ('-':'-':xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs
- grabModuleExtensions ('L':'A':'N':'G':'U':'A':'G':'E':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)
- grabModuleExtensions (_:xs) = grabModuleExtensions xs
+ grabModuleExtensions ('-' : '-' : xs) = grabModuleExtensions $ dropWhile' (/= '\n') xs
+ grabModuleExtensions ('L' : 'A' : 'N' : 'G' : 'U' : 'A' : 'G' : 'E' : xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)
+ grabModuleExtensions (_ : xs) = grabModuleExtensions xs
grabModuleExtensions' [] = []
- grabModuleExtensions' ('#':xs) = grabModuleExtensions xs
- grabModuleExtensions' (',':xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)
- grabModuleExtensions' (_:xs) = grabModuleExtensions xs
+ grabModuleExtensions' ('#' : xs) = grabModuleExtensions xs
+ grabModuleExtensions' (',' : xs) = takeWhile' stop xs : grabModuleExtensions' (dropWhile' stop xs)
+ grabModuleExtensions' (_ : xs) = grabModuleExtensions xs
takeWhile' :: (Char -> Bool) -> String -> String
takeWhile' p = takeWhile p . trim
@@ -208,7 +200,7 @@ dropWhile' p = dropWhile p . trim
-- | Check whether a potential source file is located in one of the
-- source directories.
isSourceFile :: Maybe [FilePath] -> SourceFileEntry -> Bool
-isSourceFile Nothing sf = isSourceFile (Just ["."]) sf
+isSourceFile Nothing sf = isSourceFile (Just ["."]) sf
isSourceFile (Just srcDirs) sf = any (equalFilePath (relativeSourcePath sf)) srcDirs
retrieveDependencies :: Interactive m => Verbosity -> InitFlags -> [(ModuleName, ModuleName)] -> InstalledPackageIndex -> m [P.Dependency]
@@ -216,11 +208,11 @@ retrieveDependencies v flags mods' pkgIx = do
let mods = mods'
modMap :: M.Map ModuleName [InstalledPackageInfo]
- modMap = M.map (filter exposed) $ moduleNameIndex pkgIx
+ modMap = M.map (filter exposed) $ moduleNameIndex pkgIx
modDeps :: [(ModuleName, ModuleName, Maybe [InstalledPackageInfo])]
modDeps = map (\(mn, ds) -> (mn, ds, M.lookup ds modMap)) mods
- -- modDeps = map (id &&& flip M.lookup modMap) mods
+ -- modDeps = map (id &&& flip M.lookup modMap) mods
message v Log "Guessing dependencies..."
nub . catMaybes <$> traverse (chooseDep v flags) modDeps
@@ -236,49 +228,49 @@ chooseDep
-> m (Maybe P.Dependency)
chooseDep v flags (importer, m, mipi) = case mipi of
-- We found some packages: group them by name.
- Just ps@(_:_) ->
+ Just ps@(_ : _) ->
case NE.groupBy (\x y -> P.pkgName x == P.pkgName y) $ map P.packageId ps of
- -- if there's only one group, i.e. multiple versions of a single package,
- -- we make it into a dependency, choosing the latest-ish version.
+ -- if there's only one group, i.e. multiple versions of a single package,
+ -- we make it into a dependency, choosing the latest-ish version.
-- Given a list of available versions of the same package, pick a dependency.
[grp] -> fmap Just $ case grp of
-
-- If only one version, easy. We change e.g. 0.4.2 into 0.4.*
- (pid:|[]) ->
- return $ P.Dependency
+ (pid :| []) ->
+ return $
+ P.Dependency
(P.pkgName pid)
(pvpize desugar . P.pkgVersion $ pid)
- P.mainLibSet --TODO sublibraries
+ P.mainLibSet -- TODO sublibraries
-- Otherwise, choose the latest version and issue a warning.
pids -> do
message v Warning ("multiple versions of " ++ prettyShow (P.pkgName . NE.head $ pids) ++ " provide " ++ prettyShow m ++ ", choosing the latest.")
- return $ P.Dependency
+ return $
+ P.Dependency
(P.pkgName . NE.head $ pids)
(pvpize desugar . maximum . fmap P.pkgVersion $ pids)
- P.mainLibSet --TODO take into account sublibraries
+ P.mainLibSet -- TODO take into account sublibraries
-- if multiple packages are found, we refuse to choose between
-- different packages and make the user do it
- grps -> do
+ grps -> do
message v Warning ("multiple packages found providing " ++ prettyShow m ++ ": " ++ intercalate ", " (fmap (prettyShow . P.pkgName . NE.head) grps))
message v Warning "You will need to pick one and manually add it to the build-depends field."
return Nothing
-
_ -> do
message v Warning ("no package found providing " ++ prettyShow m ++ " in " ++ prettyShow importer ++ ".")
return Nothing
-
where
-- desugar if cabal version lower than 2.0
desugar = case cabalVersion flags of
- Flag x -> x < CabalSpecV2_0
+ Flag x -> x < CabalSpecV2_0
NoFlag -> defaultCabalVersion < CabalSpecV2_0
filePathToPkgName :: Interactive m => FilePath -> m P.PackageName
-filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)
- . canonicalizePathNoThrow
+filePathToPkgName =
+ fmap (mkPackageName . repair . fromMaybe "" . safeLast . splitDirectories)
+ . canonicalizePathNoThrow
where
-- Treat each span of non-alphanumeric characters as a hyphen. Each
-- hyphenated component of a package name must contain at least one
@@ -288,12 +280,14 @@ filePathToPkgName = fmap (mkPackageName . repair . fromMaybe "" . safeLast . spl
-- "x12-foo3".
repair = repair' ('x' :) id
repair' invalid valid x = case dropWhile (not . isAlphaNum) x of
- "" -> repairComponent ""
- x' -> let (c, r) = first repairComponent $ span isAlphaNum x'
- in c ++ repairRest r
+ "" -> repairComponent ""
+ x' ->
+ let (c, r) = first repairComponent $ span isAlphaNum x'
+ in c ++ repairRest r
where
- repairComponent c | all isDigit c = invalid c
- | otherwise = valid c
+ repairComponent c
+ | all isDigit c = invalid c
+ | otherwise = valid c
repairRest = repair' id ('-' :)
currentDirPkgName :: Interactive m => m P.PackageName
@@ -309,37 +303,46 @@ mkPackageNameDep pkg = mkDependency pkg anyVersion (NES.singleton LMainLibName)
fixupDocFiles :: Interactive m => Verbosity -> PkgDescription -> m PkgDescription
fixupDocFiles v pkgDesc
| _pkgCabalVersion pkgDesc < CabalSpecV1_18 = do
- message v Warning $ concat
- [ "Cabal spec versions < 1.18 do not support extra-doc-files. "
- , "Doc files will be treated as extra-src-files."
- ]
-
- return $ pkgDesc
- { _pkgExtraSrcFiles =_pkgExtraSrcFiles pkgDesc
- <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc)
- , _pkgExtraDocFiles = Nothing
- }
+ message v Warning $
+ concat
+ [ "Cabal spec versions < 1.18 do not support extra-doc-files. "
+ , "Doc files will be treated as extra-src-files."
+ ]
+
+ return $
+ pkgDesc
+ { _pkgExtraSrcFiles =
+ _pkgExtraSrcFiles pkgDesc
+ <> fromMaybe mempty (_pkgExtraDocFiles pkgDesc)
+ , _pkgExtraDocFiles = Nothing
+ }
| otherwise = return pkgDesc
mkStringyDep :: String -> Dependency
mkStringyDep = mkPackageNameDep . mkPackageName
-
getBaseDep :: Interactive m => InstalledPackageIndex -> InitFlags -> m [Dependency]
-getBaseDep pkgIx flags = retrieveDependencies silent flags
- [(fromString "Prelude", fromString "Prelude")] pkgIx
+getBaseDep pkgIx flags =
+ retrieveDependencies
+ silent
+ flags
+ [(fromString "Prelude", fromString "Prelude")]
+ pkgIx
-- Add package name as dependency of test suite
--
addLibDepToTest :: PackageName -> Maybe TestTarget -> Maybe TestTarget
addLibDepToTest _ Nothing = Nothing
-addLibDepToTest n (Just t) = Just $ t
- { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]
- }
+addLibDepToTest n (Just t) =
+ Just $
+ t
+ { _testDependencies = _testDependencies t ++ [mkPackageNameDep n]
+ }
-- Add package name as dependency of executable
--
addLibDepToExe :: PackageName -> ExeTarget -> ExeTarget
-addLibDepToExe n exe = exe
- { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]
- }
+addLibDepToExe n exe =
+ exe
+ { _exeDependencies = _exeDependencies exe ++ [mkPackageNameDep n]
+ }
diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs
index b0cf35873e92151ddfd0ac74f3cb1d236d1c7f76..93ad8e5ae2e776d64fd42571e778510881434138 100644
--- a/cabal-install/src/Distribution/Client/Install.hs
+++ b/cabal-install/src/Distribution/Client/Install.hs
@@ -1,6 +1,9 @@
{-# LANGUAGE CPP #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Install
-- Copyright : (c) 2005 David Himmelstrup
@@ -13,166 +16,281 @@
-- Portability : portable
--
-- High level interface to package installation.
------------------------------------------------------------------------------
-module Distribution.Client.Install (
- -- * High-level interface
- install,
+module Distribution.Client.Install
+ ( -- * High-level interface
+ install
-- * Lower-level interface that allows to manipulate the install plan
- makeInstallContext,
- makeInstallPlan,
- processInstallPlan,
- InstallArgs,
- InstallContext,
+ , makeInstallContext
+ , makeInstallPlan
+ , processInstallPlan
+ , InstallArgs
+ , InstallContext
-- * Prune certain packages from the install plan
- pruneInstallPlan
+ , pruneInstallPlan
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
-import Distribution.Utils.Generic(safeLast)
+import Distribution.Utils.Generic (safeLast)
+import Prelude ()
+import Control.Exception as Exception
+ ( Handler (Handler)
+ , bracket
+ , catches
+ , handleJust
+ )
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
-import Control.Exception as Exception
- ( bracket, catches, Handler(Handler), handleJust )
import System.Directory
- ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,
- createDirectoryIfMissing, removeFile, renameDirectory,
- getDirectoryContents )
+ ( createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ , getDirectoryContents
+ , getTemporaryDirectory
+ , removeFile
+ , renameDirectory
+ )
import System.FilePath
- ( (</>), (<.>), equalFilePath, takeDirectory )
+ ( equalFilePath
+ , takeDirectory
+ , (<.>)
+ , (</>)
+ )
import System.IO
- ( openFile, IOMode(AppendMode), hClose )
+ ( IOMode (AppendMode)
+ , hClose
+ , openFile
+ )
import System.IO.Error
- ( isDoesNotExistError, ioeGetFileName )
+ ( ioeGetFileName
+ , isDoesNotExistError
+ )
-import Distribution.Client.Targets
+import Distribution.Client.BuildReports.Anonymous (showBuildReport)
+import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
+import qualified Distribution.Client.BuildReports.Storage as BuildReports
+ ( fromInstallPlan
+ , fromPlanningFailure
+ , storeAnonymous
+ , storeLocal
+ )
+import Distribution.Client.BuildReports.Types
+ ( ReportLevel (..)
+ )
+import Distribution.Client.Config
+ ( defaultReportsDir
+ , defaultUserInstall
+ )
import Distribution.Client.Configure
- ( chooseCabalVersion, configureSetupScript, checkConfigExFlags )
+ ( checkConfigExFlags
+ , chooseCabalVersion
+ , configureSetupScript
+ )
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
- ( Solver(..) )
+ ( Solver (..)
+ )
import Distribution.Client.FetchUtils
-import Distribution.Client.HttpUtils
- ( HttpTransport (..) )
-import Distribution.Solver.Types.PackageFixedDeps
import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)
+import Distribution.Client.HttpUtils
+ ( HttpTransport (..)
+ )
import Distribution.Client.IndexUtils as IndexUtils
- ( getSourcePackagesAtIndexState, getInstalledPackages )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
+ ( getInstalledPackages
+ , getSourcePackagesAtIndexState
+ )
import Distribution.Client.InstallPlan (InstallPlan)
-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import qualified Distribution.Client.InstallSymlink as InstallSymlink
+ ( symlinkBinaries
+ )
+import Distribution.Client.JobControl
import Distribution.Client.Setup
- ( GlobalFlags(..), RepoContext(..)
- , ConfigFlags(..), configureCommand, filterConfigureFlags
- , ConfigExFlags(..), InstallFlags(..)
- , filterTestFlags )
-import Distribution.Client.Config
- ( defaultReportsDir, defaultUserInstall )
+ ( ConfigExFlags (..)
+ , ConfigFlags (..)
+ , GlobalFlags (..)
+ , InstallFlags (..)
+ , RepoContext (..)
+ , configureCommand
+ , filterConfigureFlags
+ , filterTestFlags
+ )
+import Distribution.Client.SetupWrapper
+ ( SetupScriptOptions (..)
+ , defaultSetupScriptOptions
+ , setupWrapper
+ )
+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.Client.Tar (extractTarGzFile)
+import Distribution.Client.Targets
import Distribution.Client.Types as Source
-import Distribution.Client.BuildReports.Types
- ( ReportLevel(..) )
-import Distribution.Client.SetupWrapper
- ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
-import Distribution.Client.BuildReports.Anonymous (showBuildReport)
-import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
-import qualified Distribution.Client.BuildReports.Storage as BuildReports
- ( storeAnonymous, storeLocal, fromInstallPlan, fromPlanningFailure )
-import qualified Distribution.Client.InstallSymlink as InstallSymlink
- ( symlinkBinaries )
import Distribution.Client.Types.OverwritePolicy (OverwritePolicy (..))
import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade
import qualified Distribution.InstalledPackageInfo as Installed
-import Distribution.Client.JobControl
+import Distribution.Solver.Types.PackageFixedDeps
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ConstraintSource
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.LabeledPackageConstraint
-import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.OptionalStanza
import qualified Distribution.Solver.Types.PackageIndex as SourcePackageIndex
-import Distribution.Solver.Types.PkgConfigDb
- ( PkgConfigDb, readPkgConfigDb )
-import Distribution.Solver.Types.SourcePackage as SourcePackage
+import Distribution.Solver.Types.PkgConfigDb
+ ( PkgConfigDb
+ , readPkgConfigDb
+ )
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SourcePackage as SourcePackage
-import Distribution.Utils.NubList
+import Distribution.Client.Utils
+ ( MergeResult (..)
+ , ProgressPhase (..)
+ , determineNumJobs
+ , logDirChange
+ , mergeBy
+ , progressMessage
+ )
+import Distribution.Package
+ ( HasMungedPackageId (..)
+ , HasUnitId (..)
+ , Package (..)
+ , PackageId
+ , PackageIdentifier (..)
+ , UnitId
+ , packageName
+ , packageVersion
+ )
+import Distribution.PackageDescription
+ ( GenericPackageDescription (..)
+ , PackageDescription
+ )
+import qualified Distribution.PackageDescription as PackageDescription
+import Distribution.PackageDescription.Configuration
+ ( finalizePD
+ )
+import Distribution.Simple.BuildPaths (exeExtension)
import Distribution.Simple.Compiler
- ( CompilerId(..), Compiler(compilerId), compilerFlavor
- , CompilerInfo(..), compilerInfo, PackageDB(..), PackageDBStack )
-import Distribution.Simple.Program (ProgramDb)
+ ( Compiler (compilerId)
+ , CompilerId (..)
+ , CompilerInfo (..)
+ , PackageDB (..)
+ , PackageDBStack
+ , compilerFlavor
+ , compilerInfo
+ )
+import Distribution.Simple.Configure (interpretPackageDbFlags)
+import Distribution.Simple.InstallDirs as InstallDirs
+ ( PathTemplate
+ , fromPathTemplate
+ , initialPathTemplateEnv
+ , installDirsTemplateEnv
+ , substPathTemplate
+ , toPathTemplate
+ )
import qualified Distribution.Simple.InstallDirs as InstallDirs
-import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.Program (ProgramDb)
+import Distribution.Simple.Register (defaultRegisterOptions, registerPackage)
import Distribution.Simple.Setup
- ( haddockCommand, HaddockFlags(..)
- , buildCommand, BuildFlags(..), emptyBuildFlags
- , TestFlags, BenchmarkFlags
- , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref )
+ ( BenchmarkFlags
+ , BuildFlags (..)
+ , HaddockFlags (..)
+ , TestFlags
+ , buildCommand
+ , defaultDistPref
+ , emptyBuildFlags
+ , flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ , haddockCommand
+ , toFlag
+ )
import qualified Distribution.Simple.Setup as Cabal
- ( Flag(..)
- , copyCommand, CopyFlags(..), emptyCopyFlags
- , registerCommand, RegisterFlags(..), emptyRegisterFlags
- , testCommand, TestFlags(..) )
+ ( CopyFlags (..)
+ , Flag (..)
+ , RegisterFlags (..)
+ , TestFlags (..)
+ , copyCommand
+ , emptyCopyFlags
+ , emptyRegisterFlags
+ , registerCommand
+ , testCommand
+ )
import Distribution.Simple.Utils
- ( createDirectoryIfMissingVerbose, writeFileAtomic )
-import Distribution.Simple.InstallDirs as InstallDirs
- ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate
- , initialPathTemplateEnv, installDirsTemplateEnv )
-import Distribution.Simple.Configure (interpretPackageDbFlags)
-import Distribution.Simple.Register (registerPackage, defaultRegisterOptions)
-import Distribution.Package
- ( PackageIdentifier(..), PackageId, packageName, packageVersion
- , Package(..), HasMungedPackageId(..), HasUnitId(..)
- , UnitId )
-import Distribution.Types.GivenComponent
- ( GivenComponent(..) )
-import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint(..), thisPackageVersionConstraint )
-import Distribution.Types.MungedPackageId
-import qualified Distribution.PackageDescription as PackageDescription
-import Distribution.PackageDescription
- ( PackageDescription, GenericPackageDescription(..) )
-import Distribution.Types.Flag
- ( PackageFlag(..), FlagAssignment, mkFlagAssignment
- , showFlagAssignment, diffFlagAssignment, nullFlagAssignment )
-import Distribution.PackageDescription.Configuration
- ( finalizePD )
-import Distribution.Version
- ( Version, VersionRange, foldVersionRange )
+ ( createDirectoryIfMissingVerbose
+ , writeFileAtomic
+ )
import Distribution.Simple.Utils as Utils
- ( notice, info, warn, debug, debugNoWrap, die'
- , withTempDirectory )
-import Distribution.Client.Utils
- ( determineNumJobs, logDirChange, mergeBy, MergeResult(..)
- , ProgressPhase(..), progressMessage )
+ ( debug
+ , debugNoWrap
+ , die'
+ , info
+ , notice
+ , warn
+ , withTempDirectory
+ )
import Distribution.System
- ( Platform, OS(Windows), buildOS, buildPlatform )
+ ( OS (Windows)
+ , Platform
+ , buildOS
+ , buildPlatform
+ )
+import Distribution.Types.Flag
+ ( FlagAssignment
+ , PackageFlag (..)
+ , diffFlagAssignment
+ , mkFlagAssignment
+ , nullFlagAssignment
+ , showFlagAssignment
+ )
+import Distribution.Types.GivenComponent
+ ( GivenComponent (..)
+ )
+import Distribution.Types.MungedPackageId
+import Distribution.Types.PackageVersionConstraint
+ ( PackageVersionConstraint (..)
+ , thisPackageVersionConstraint
+ )
+import Distribution.Utils.NubList
import Distribution.Verbosity as Verbosity
- ( modifyVerbosity, normal, verbose )
-import Distribution.Simple.BuildPaths ( exeExtension )
+ ( modifyVerbosity
+ , normal
+ , verbose
+ )
+import Distribution.Version
+ ( Version
+ , VersionRange
+ , foldVersionRange
+ )
import qualified Data.ByteString as BS
---TODO:
+-- TODO:
+
-- * assign flags to packages individually
+
-- * complain about flags that do not apply to any package given as target
-- so flags do not apply to dependencies, only listed, can use flag
-- constraints for dependencies
+
-- * allow flag constraints
+
-- * allow installed constraints
+
-- * allow flag and installed preferences
+
-- * allow persistent configure flags for each package individually
-- ------------------------------------------------------------
+
-- * Top level user actions
+
-- ------------------------------------------------------------
-- | Installs the packages needed to satisfy a list of dependencies.
---
install
:: Verbosity
-> PackageDBStack
@@ -189,83 +307,134 @@ install
-> BenchmarkFlags
-> [UserTarget]
-> IO ()
-install verbosity packageDBs repos comp platform progdb
- globalFlags configFlags configExFlags installFlags
- haddockFlags testFlags benchmarkFlags userTargets0 = do
-
+install
+ verbosity
+ packageDBs
+ repos
+ comp
+ platform
+ progdb
+ globalFlags
+ configFlags
+ configExFlags
+ installFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags
+ userTargets0 = do
unless (installRootCmd installFlags == Cabal.NoFlag) $
- warn verbosity $ "--root-cmd is no longer supported, "
- ++ "see https://github.com/haskell/cabal/issues/3353"
- ++ " (if you didn't type --root-cmd, comment out root-cmd"
- ++ " in your ~/.config/cabal/config file)"
+ warn verbosity $
+ "--root-cmd is no longer supported, "
+ ++ "see https://github.com/haskell/cabal/issues/3353"
+ ++ " (if you didn't type --root-cmd, comment out root-cmd"
+ ++ " in your ~/.config/cabal/config file)"
let userOrSandbox = fromFlag (configUserInstall configFlags)
unless userOrSandbox $
- warn verbosity $ "the --global flag is deprecated -- "
- ++ "it is generally considered a bad idea to install packages "
- ++ "into the global store"
+ warn verbosity $
+ "the --global flag is deprecated -- "
+ ++ "it is generally considered a bad idea to install packages "
+ ++ "into the global store"
installContext <- makeInstallContext verbosity args (Just userTargets0)
- planResult <- foldProgress logMsg (return . Left) (return . Right) =<<
- makeInstallPlan verbosity args installContext
+ planResult <-
+ foldProgress logMsg (return . Left) (return . Right)
+ =<< makeInstallPlan verbosity args installContext
case planResult of
- Left message -> do
- reportPlanningFailure verbosity args installContext message
- die'' message
- Right installPlan ->
- processInstallPlan verbosity args installContext installPlan
- where
- args :: InstallArgs
- args = (packageDBs, repos, comp, platform, progdb,
- globalFlags, configFlags, configExFlags,
- installFlags, haddockFlags, testFlags, benchmarkFlags)
-
- die'' = die' verbosity
-
- logMsg message rest = debugNoWrap verbosity message >> rest
+ Left message -> do
+ reportPlanningFailure verbosity args installContext message
+ die'' message
+ Right installPlan ->
+ processInstallPlan verbosity args installContext installPlan
+ where
+ args :: InstallArgs
+ args =
+ ( packageDBs
+ , repos
+ , comp
+ , platform
+ , progdb
+ , globalFlags
+ , configFlags
+ , configExFlags
+ , installFlags
+ , haddockFlags
+ , testFlags
+ , benchmarkFlags
+ )
+
+ die'' = die' verbosity
+
+ logMsg message rest = debugNoWrap verbosity message >> rest
-- TODO: Make InstallContext a proper data type with documented fields.
+
-- | Common context for makeInstallPlan and processInstallPlan.
-type InstallContext = ( InstalledPackageIndex, SourcePackageDb
- , PkgConfigDb
- , [UserTarget], [PackageSpecifier UnresolvedSourcePackage]
- , HttpTransport )
+type InstallContext =
+ ( InstalledPackageIndex
+ , SourcePackageDb
+ , PkgConfigDb
+ , [UserTarget]
+ , [PackageSpecifier UnresolvedSourcePackage]
+ , HttpTransport
+ )
-- TODO: Make InstallArgs a proper data type with documented fields or just get
-- rid of it completely.
+
-- | Initial arguments given to 'install' or 'makeInstallContext'.
-type InstallArgs = ( PackageDBStack
- , RepoContext
- , Compiler
- , Platform
- , ProgramDb
- , GlobalFlags
- , ConfigFlags
- , ConfigExFlags
- , InstallFlags
- , HaddockFlags
- , TestFlags
- , BenchmarkFlags )
+type InstallArgs =
+ ( PackageDBStack
+ , RepoContext
+ , Compiler
+ , Platform
+ , ProgramDb
+ , GlobalFlags
+ , ConfigFlags
+ , ConfigExFlags
+ , InstallFlags
+ , HaddockFlags
+ , TestFlags
+ , BenchmarkFlags
+ )
-- | Make an install context given install arguments.
-makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
- -> IO InstallContext
-makeInstallContext verbosity
- (packageDBs, repoCtxt, comp, _, progdb,
- _, _, configExFlags, installFlags, _, _, _) mUserTargets = do
-
+makeInstallContext
+ :: Verbosity
+ -> InstallArgs
+ -> Maybe [UserTarget]
+ -> IO InstallContext
+makeInstallContext
+ verbosity
+ ( packageDBs
+ , repoCtxt
+ , comp
+ , _
+ , progdb
+ , _
+ , _
+ , configExFlags
+ , installFlags
+ , _
+ , _
+ , _
+ )
+ mUserTargets = do
let idxState = flagToMaybe (installIndexState installFlags)
- installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
(sourcePkgDb, _, _) <- getSourcePackagesAtIndexState verbosity repoCtxt idxState Nothing
- pkgConfigDb <- readPkgConfigDb verbosity progdb
+ pkgConfigDb <- readPkgConfigDb verbosity progdb
- checkConfigExFlags verbosity installedPkgIndex
- (packageIndex sourcePkgDb) configExFlags
+ checkConfigExFlags
+ verbosity
+ installedPkgIndex
+ (packageIndex sourcePkgDb)
+ configExFlags
transport <- repoContextGetTransport repoCtxt
(userTargets, pkgSpecifiers) <- case mUserTargets of
- Nothing ->
+ Nothing ->
-- We want to distinguish between the case where the user has given an
-- empty list of targets on the command-line and the case where we
-- specifically want to have an empty list of targets.
@@ -273,514 +442,672 @@ makeInstallContext verbosity
Just userTargets0 -> do
-- For install, if no target is given it means we use the current
-- directory as the single target.
- let userTargets | null userTargets0 = [UserTargetLocalDir "."]
- | otherwise = userTargets0
-
- pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
- (packageIndex sourcePkgDb)
- userTargets
+ let userTargets
+ | null userTargets0 = [UserTargetLocalDir "."]
+ | otherwise = userTargets0
+
+ pkgSpecifiers <-
+ resolveUserTargets
+ verbosity
+ repoCtxt
+ (packageIndex sourcePkgDb)
+ userTargets
return (userTargets, pkgSpecifiers)
- return (installedPkgIndex, sourcePkgDb, pkgConfigDb, userTargets
- ,pkgSpecifiers, transport)
+ return
+ ( installedPkgIndex
+ , sourcePkgDb
+ , pkgConfigDb
+ , userTargets
+ , pkgSpecifiers
+ , transport
+ )
-- | Make an install plan given install context and install arguments.
-makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
- -> IO (Progress String String SolverInstallPlan)
-makeInstallPlan verbosity
- (_, _, comp, platform,_,
- _, configFlags, configExFlags, installFlags,
- _, _, _)
- (installedPkgIndex, sourcePkgDb, pkgConfigDb,
- _, pkgSpecifiers, _) = do
-
- solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))
- (compilerInfo comp)
+makeInstallPlan
+ :: Verbosity
+ -> InstallArgs
+ -> InstallContext
+ -> IO (Progress String String SolverInstallPlan)
+makeInstallPlan
+ verbosity
+ ( _
+ , _
+ , comp
+ , platform
+ , _
+ , _
+ , configFlags
+ , configExFlags
+ , installFlags
+ , _
+ , _
+ , _
+ )
+ ( installedPkgIndex
+ , sourcePkgDb
+ , pkgConfigDb
+ , _
+ , pkgSpecifiers
+ , _
+ ) = do
+ solver <-
+ chooseSolver
+ verbosity
+ (fromFlag (configSolver configExFlags))
+ (compilerInfo comp)
notice verbosity "Resolving dependencies..."
- return $ planPackages verbosity comp platform solver
- configFlags configExFlags installFlags
- installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers
+ return $
+ planPackages
+ verbosity
+ comp
+ platform
+ solver
+ configFlags
+ configExFlags
+ installFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+ pkgSpecifiers
-- | Given an install plan, perform the actual installations.
-processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
- -> SolverInstallPlan
- -> IO ()
-processInstallPlan verbosity
- args@(_,_, _, _, _, _, configFlags, _, installFlags, _, _, _)
- (installedPkgIndex, sourcePkgDb, _,
- userTargets, pkgSpecifiers, _) installPlan0 = do
-
- checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
- installFlags pkgSpecifiers
+processInstallPlan
+ :: Verbosity
+ -> InstallArgs
+ -> InstallContext
+ -> SolverInstallPlan
+ -> IO ()
+processInstallPlan
+ verbosity
+ args@(_, _, _, _, _, _, configFlags, _, installFlags, _, _, _)
+ ( installedPkgIndex
+ , sourcePkgDb
+ , _
+ , userTargets
+ , pkgSpecifiers
+ , _
+ )
+ installPlan0 = do
+ checkPrintPlan
+ verbosity
+ installedPkgIndex
+ installPlan
+ sourcePkgDb
+ installFlags
+ pkgSpecifiers
unless (dryRun || nothingToInstall) $ do
- buildOutcomes <- performInstallations verbosity
- args installedPkgIndex installPlan
+ buildOutcomes <-
+ performInstallations
+ verbosity
+ args
+ installedPkgIndex
+ installPlan
postInstallActions verbosity args userTargets installPlan buildOutcomes
- where
- installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
- dryRun = fromFlag (installDryRun installFlags)
- nothingToInstall = null (fst (InstallPlan.ready installPlan))
+ where
+ installPlan = InstallPlan.configureInstallPlan configFlags installPlan0
+ dryRun = fromFlag (installDryRun installFlags)
+ nothingToInstall = null (fst (InstallPlan.ready installPlan))
-- ------------------------------------------------------------
--- * Installation planning
--- ------------------------------------------------------------
-
-planPackages :: Verbosity
- -> Compiler
- -> Platform
- -> Solver
- -> ConfigFlags
- -> ConfigExFlags
- -> InstallFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> PkgConfigDb
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> Progress String String SolverInstallPlan
-planPackages verbosity comp platform solver
- configFlags configExFlags installFlags
- installedPkgIndex sourcePkgDb pkgConfigDb pkgSpecifiers =
-
- resolveDependencies
- platform (compilerInfo comp) pkgConfigDb
- solver
- resolverParams
-
- >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
-
- where
- resolverParams =
-
- setMaxBackjumps (if maxBackjumps < 0 then Nothing
- else Just maxBackjumps)
-
- . setIndependentGoals independentGoals
-
- . setReorderGoals reorderGoals
-
- . setCountConflicts countConflicts
-
- . setFineGrainedConflicts fineGrainedConflicts
-
- . setMinimizeConflictSet minimizeConflictSet
-
- . setAvoidReinstalls avoidReinstalls
- . setShadowPkgs shadowPkgs
-
- . setStrongFlags strongFlags
-
- . setAllowBootLibInstalls allowBootLibInstalls
-
- . setOnlyConstrained onlyConstrained
-
- . setSolverVerbosity verbosity
-
- . setPreferenceDefault (if upgradeDeps then PreferAllLatest
- else PreferLatestForSelected)
-
- . removeLowerBounds allowOlder
- . removeUpperBounds allowNewer
+-- * Installation planning
- . addPreferences
- -- preferences from the config file or command line
- [ PackageVersionPreference name ver
- | PackageVersionConstraint name ver <- configPreferences configExFlags ]
+-- ------------------------------------------------------------
- . addConstraints
- -- version constraints from the config file or command line
+planPackages
+ :: Verbosity
+ -> Compiler
+ -> Platform
+ -> Solver
+ -> ConfigFlags
+ -> ConfigExFlags
+ -> InstallFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> PkgConfigDb
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> Progress String String SolverInstallPlan
+planPackages
+ verbosity
+ comp
+ platform
+ solver
+ configFlags
+ configExFlags
+ installFlags
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDb
+ pkgSpecifiers =
+ resolveDependencies
+ platform
+ (compilerInfo comp)
+ pkgConfigDb
+ solver
+ resolverParams
+ >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return
+ where
+ resolverParams =
+ setMaxBackjumps
+ ( if maxBackjumps < 0
+ then Nothing
+ else Just maxBackjumps
+ )
+ . setIndependentGoals independentGoals
+ . setReorderGoals reorderGoals
+ . setCountConflicts countConflicts
+ . setFineGrainedConflicts fineGrainedConflicts
+ . setMinimizeConflictSet minimizeConflictSet
+ . setAvoidReinstalls avoidReinstalls
+ . setShadowPkgs shadowPkgs
+ . setStrongFlags strongFlags
+ . setAllowBootLibInstalls allowBootLibInstalls
+ . setOnlyConstrained onlyConstrained
+ . setSolverVerbosity verbosity
+ . setPreferenceDefault
+ ( if upgradeDeps
+ then PreferAllLatest
+ else PreferLatestForSelected
+ )
+ . removeLowerBounds allowOlder
+ . removeUpperBounds allowNewer
+ . addPreferences
+ -- preferences from the config file or command line
+ [ PackageVersionPreference name ver
+ | PackageVersionConstraint name ver <- configPreferences configExFlags
+ ]
+ . addConstraints
+ -- version constraints from the config file or command line
[ LabeledPackageConstraint (userToPackageConstraint pc) src
- | (pc, src) <- configExConstraints configExFlags ]
-
- . addConstraints
- --FIXME: this just applies all flags to all targets which
- -- is silly. We should check if the flags are appropriate
- [ let pc = PackageConstraint
- (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
- (PackagePropertyFlags flags)
- in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
- | let flags = configConfigurationsFlags configFlags
- , not (nullFlagAssignment flags)
- , pkgSpecifier <- pkgSpecifiers ]
-
- . addConstraints
- [ let pc = PackageConstraint
- (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
- (PackagePropertyStanzas stanzas)
- in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
- | pkgSpecifier <- pkgSpecifiers ]
-
- . (if reinstall then reinstallTargets else id)
-
- -- Don't solve for executables, the legacy install codepath
- -- doesn't understand how to install them
- . setSolveExecutables (SolveExecutables False)
-
- $ standardInstallPolicy
- installedPkgIndex sourcePkgDb pkgSpecifiers
-
- stanzas = [ TestStanzas | testsEnabled ]
- ++ [ BenchStanzas | benchmarksEnabled ]
- testsEnabled = fromFlagOrDefault False $ configTests configFlags
- benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
-
- reinstall = fromFlag (installOverrideReinstall installFlags) ||
- fromFlag (installReinstall installFlags)
- reorderGoals = fromFlag (installReorderGoals installFlags)
- countConflicts = fromFlag (installCountConflicts installFlags)
- fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags)
- minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags)
- independentGoals = fromFlag (installIndependentGoals installFlags)
- avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)
- shadowPkgs = fromFlag (installShadowPkgs installFlags)
- strongFlags = fromFlag (installStrongFlags installFlags)
- maxBackjumps = fromFlag (installMaxBackjumps installFlags)
- allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)
- onlyConstrained = fromFlag (installOnlyConstrained installFlags)
- upgradeDeps = fromFlag (installUpgradeDeps installFlags)
- onlyDeps = fromFlag (installOnlyDeps installFlags)
-
- allowOlder = fromMaybe (AllowOlder mempty)
- (configAllowOlder configExFlags)
- allowNewer = fromMaybe (AllowNewer mempty)
- (configAllowNewer configExFlags)
+ | (pc, src) <- configExConstraints configExFlags
+ ]
+ . addConstraints
+ -- FIXME: this just applies all flags to all targets which
+ -- is silly. We should check if the flags are appropriate
+ [ let pc =
+ PackageConstraint
+ (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
+ (PackagePropertyFlags flags)
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
+ | let flags = configConfigurationsFlags configFlags
+ , not (nullFlagAssignment flags)
+ , pkgSpecifier <- pkgSpecifiers
+ ]
+ . addConstraints
+ [ let pc =
+ PackageConstraint
+ (scopeToplevel $ pkgSpecifierTarget pkgSpecifier)
+ (PackagePropertyStanzas stanzas)
+ in LabeledPackageConstraint pc ConstraintSourceConfigFlagOrTarget
+ | pkgSpecifier <- pkgSpecifiers
+ ]
+ . (if reinstall then reinstallTargets else id)
+ -- Don't solve for executables, the legacy install codepath
+ -- doesn't understand how to install them
+ . setSolveExecutables (SolveExecutables False)
+ $ standardInstallPolicy
+ installedPkgIndex
+ sourcePkgDb
+ pkgSpecifiers
+
+ stanzas =
+ [TestStanzas | testsEnabled]
+ ++ [BenchStanzas | benchmarksEnabled]
+ testsEnabled = fromFlagOrDefault False $ configTests configFlags
+ benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags
+
+ reinstall =
+ fromFlag (installOverrideReinstall installFlags)
+ || fromFlag (installReinstall installFlags)
+ reorderGoals = fromFlag (installReorderGoals installFlags)
+ countConflicts = fromFlag (installCountConflicts installFlags)
+ fineGrainedConflicts = fromFlag (installFineGrainedConflicts installFlags)
+ minimizeConflictSet = fromFlag (installMinimizeConflictSet installFlags)
+ independentGoals = fromFlag (installIndependentGoals installFlags)
+ avoidReinstalls = fromFlag (installAvoidReinstalls installFlags)
+ shadowPkgs = fromFlag (installShadowPkgs installFlags)
+ strongFlags = fromFlag (installStrongFlags installFlags)
+ maxBackjumps = fromFlag (installMaxBackjumps installFlags)
+ allowBootLibInstalls = fromFlag (installAllowBootLibInstalls installFlags)
+ onlyConstrained = fromFlag (installOnlyConstrained installFlags)
+ upgradeDeps = fromFlag (installUpgradeDeps installFlags)
+ onlyDeps = fromFlag (installOnlyDeps installFlags)
+
+ allowOlder =
+ fromMaybe
+ (AllowOlder mempty)
+ (configAllowOlder configExFlags)
+ allowNewer =
+ fromMaybe
+ (AllowNewer mempty)
+ (configAllowNewer configExFlags)
-- | Remove the provided targets from the install plan.
-pruneInstallPlan :: Package targetpkg
- => [PackageSpecifier targetpkg]
- -> SolverInstallPlan
- -> Progress String String SolverInstallPlan
+pruneInstallPlan
+ :: Package targetpkg
+ => [PackageSpecifier targetpkg]
+ -> SolverInstallPlan
+ -> Progress String String SolverInstallPlan
pruneInstallPlan pkgSpecifiers =
-- TODO: this is a general feature and should be moved to D.C.Dependency
-- Also, the InstallPlan.remove should return info more precise to the
-- problem, rather than the very general PlanProblem type.
either (Fail . explain) Done
- . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)
+ . SolverInstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)
where
explain :: [SolverInstallPlan.SolverPlanProblem] -> String
explain problems =
"Cannot select only the dependencies (as requested by the "
- ++ "'--only-dependencies' flag), "
- ++ (case pkgids of
- [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "
- _ -> "the packages "
- ++ intercalate ", " (map prettyShow pkgids) ++ " are ")
- ++ "required by a dependency of one of the other targets."
+ ++ "'--only-dependencies' flag), "
+ ++ ( case pkgids of
+ [pkgid] -> "the package " ++ prettyShow pkgid ++ " is "
+ _ ->
+ "the packages "
+ ++ intercalate ", " (map prettyShow pkgids)
+ ++ " are "
+ )
+ ++ "required by a dependency of one of the other targets."
where
pkgids =
- nub [ depid
- | SolverInstallPlan.PackageMissingDeps _ depids <- problems
- , depid <- depids
- , packageName depid `elem` targetnames ]
+ nub
+ [ depid
+ | SolverInstallPlan.PackageMissingDeps _ depids <- problems
+ , depid <- depids
+ , packageName depid `elem` targetnames
+ ]
- targetnames = map pkgSpecifierTarget pkgSpecifiers
+ targetnames = map pkgSpecifierTarget pkgSpecifiers
-- ------------------------------------------------------------
+
-- * Informational messages
+
-- ------------------------------------------------------------
-- | Perform post-solver checks of the install plan and print it if
-- either requested or needed.
-checkPrintPlan :: Verbosity
- -> InstalledPackageIndex
- -> InstallPlan
- -> SourcePackageDb
- -> InstallFlags
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> IO ()
-checkPrintPlan verbosity installed installPlan sourcePkgDb
- installFlags pkgSpecifiers = do
-
- -- User targets that are already installed.
- let preExistingTargets =
- [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers,
- InstallPlan.PreExisting p <- InstallPlan.toList installPlan,
- packageName p `elem` tgts ]
-
- -- If there's nothing to install, we print the already existing
- -- target packages as an explanation.
- when nothingToInstall $
- notice verbosity $ unlines $
- "All the requested packages are already installed:"
- : map (prettyShow . packageId) preExistingTargets
- ++ ["Use --reinstall if you want to reinstall anyway."]
-
- let lPlan =
- [ (pkg, status)
- | pkg <- InstallPlan.executionOrder installPlan
- , let status = packageStatus installed pkg ]
- -- Are any packages classified as reinstalls?
- let reinstalledPkgs =
- [ ipkg
- | (_pkg, status) <- lPlan
- , ipkg <- extractReinstalls status ]
- -- Packages that are already broken.
- let oldBrokenPkgs =
+checkPrintPlan
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> InstallPlan
+ -> SourcePackageDb
+ -> InstallFlags
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> IO ()
+checkPrintPlan
+ verbosity
+ installed
+ installPlan
+ sourcePkgDb
+ installFlags
+ pkgSpecifiers = do
+ -- User targets that are already installed.
+ let preExistingTargets =
+ [ p | let tgts = map pkgSpecifierTarget pkgSpecifiers, InstallPlan.PreExisting p <- InstallPlan.toList installPlan, packageName p `elem` tgts
+ ]
+
+ -- If there's nothing to install, we print the already existing
+ -- target packages as an explanation.
+ when nothingToInstall $
+ notice verbosity $
+ unlines $
+ "All the requested packages are already installed:"
+ : map (prettyShow . packageId) preExistingTargets
+ ++ ["Use --reinstall if you want to reinstall anyway."]
+
+ let lPlan =
+ [ (pkg, status)
+ | pkg <- InstallPlan.executionOrder installPlan
+ , let status = packageStatus installed pkg
+ ]
+ -- Are any packages classified as reinstalls?
+ let reinstalledPkgs =
+ [ ipkg
+ | (_pkg, status) <- lPlan
+ , ipkg <- extractReinstalls status
+ ]
+ -- Packages that are already broken.
+ let oldBrokenPkgs =
map Installed.installedUnitId
- . PackageIndex.reverseDependencyClosure installed
- . map (Installed.installedUnitId . fst)
- . PackageIndex.brokenPackages
- $ installed
- let excluded = reinstalledPkgs ++ oldBrokenPkgs
- -- Packages that are reverse dependencies of replaced packages are very
- -- likely to be broken. We exclude packages that are already broken.
- let newBrokenPkgs =
- filter (\ p -> not (Installed.installedUnitId p `elem` excluded))
- (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
- let containsReinstalls = not (null reinstalledPkgs)
- let breaksPkgs = not (null newBrokenPkgs)
-
- let adaptedVerbosity
- | containsReinstalls
- , not overrideReinstall = modifyVerbosity (max verbose) verbosity
- | otherwise = verbosity
-
- -- We print the install plan if we are in a dry-run or if we are confronted
- -- with a dangerous install plan.
- when (dryRun || containsReinstalls && not overrideReinstall) $
- printPlan (dryRun || breaksPkgs && not overrideReinstall)
- adaptedVerbosity lPlan sourcePkgDb
-
- -- If the install plan is dangerous, we print various warning messages. In
- -- particular, if we can see that packages are likely to be broken, we even
- -- bail out (unless installation has been forced with --force-reinstalls).
- when containsReinstalls $ do
- if breaksPkgs
- then do
- (if dryRun || overrideReinstall then warn else die') verbosity $ unlines $
- "The following packages are likely to be broken by the reinstalls:"
- : map (prettyShow . mungedId) newBrokenPkgs
- ++ if overrideReinstall
- then if dryRun then [] else
- ["Continuing even though " ++
- "the plan contains dangerous reinstalls."]
- else
- ["Use --force-reinstalls if you want to install anyway."]
- else unless dryRun $ warn verbosity
- "Note that reinstalls are always dangerous. Continuing anyway..."
-
- -- If we are explicitly told to not download anything, check that all packages
- -- are already fetched.
- let offline = fromFlagOrDefault False (installOfflineMode installFlags)
- when offline $ do
- let pkgs = [ confPkgSource cpkg
- | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan ]
- notFetched <- fmap (map packageId)
- . filterM (fmap isNothing . checkFetched . srcpkgSource)
- $ pkgs
- unless (null notFetched) $
- die' verbosity $ "Can't download packages in offline mode. "
- ++ "Must download the following packages to proceed:\n"
- ++ intercalate ", " (map prettyShow notFetched)
- ++ "\nTry using 'cabal fetch'."
-
- where
- nothingToInstall = null (fst (InstallPlan.ready installPlan))
-
- dryRun = fromFlag (installDryRun installFlags)
- overrideReinstall = fromFlag (installOverrideReinstall installFlags)
-
-data PackageStatus = NewPackage
- | NewVersion [Version]
- | Reinstall [UnitId] [PackageChange]
+ . PackageIndex.reverseDependencyClosure installed
+ . map (Installed.installedUnitId . fst)
+ . PackageIndex.brokenPackages
+ $ installed
+ let excluded = reinstalledPkgs ++ oldBrokenPkgs
+ -- Packages that are reverse dependencies of replaced packages are very
+ -- likely to be broken. We exclude packages that are already broken.
+ let newBrokenPkgs =
+ filter
+ (\p -> not (Installed.installedUnitId p `elem` excluded))
+ (PackageIndex.reverseDependencyClosure installed reinstalledPkgs)
+ let containsReinstalls = not (null reinstalledPkgs)
+ let breaksPkgs = not (null newBrokenPkgs)
+
+ let adaptedVerbosity
+ | containsReinstalls
+ , not overrideReinstall =
+ modifyVerbosity (max verbose) verbosity
+ | otherwise = verbosity
+
+ -- We print the install plan if we are in a dry-run or if we are confronted
+ -- with a dangerous install plan.
+ when (dryRun || containsReinstalls && not overrideReinstall) $
+ printPlan
+ (dryRun || breaksPkgs && not overrideReinstall)
+ adaptedVerbosity
+ lPlan
+ sourcePkgDb
+
+ -- If the install plan is dangerous, we print various warning messages. In
+ -- particular, if we can see that packages are likely to be broken, we even
+ -- bail out (unless installation has been forced with --force-reinstalls).
+ when containsReinstalls $ do
+ if breaksPkgs
+ then do
+ (if dryRun || overrideReinstall then warn else die') verbosity $
+ unlines $
+ "The following packages are likely to be broken by the reinstalls:"
+ : map (prettyShow . mungedId) newBrokenPkgs
+ ++ if overrideReinstall
+ then
+ if dryRun
+ then []
+ else
+ [ "Continuing even though "
+ ++ "the plan contains dangerous reinstalls."
+ ]
+ else ["Use --force-reinstalls if you want to install anyway."]
+ else
+ unless dryRun $
+ warn
+ verbosity
+ "Note that reinstalls are always dangerous. Continuing anyway..."
+
+ -- If we are explicitly told to not download anything, check that all packages
+ -- are already fetched.
+ let offline = fromFlagOrDefault False (installOfflineMode installFlags)
+ when offline $ do
+ let pkgs =
+ [ confPkgSource cpkg
+ | InstallPlan.Configured cpkg <- InstallPlan.toList installPlan
+ ]
+ notFetched <-
+ fmap (map packageId)
+ . filterM (fmap isNothing . checkFetched . srcpkgSource)
+ $ pkgs
+ unless (null notFetched) $
+ die' verbosity $
+ "Can't download packages in offline mode. "
+ ++ "Must download the following packages to proceed:\n"
+ ++ intercalate ", " (map prettyShow notFetched)
+ ++ "\nTry using 'cabal fetch'."
+ where
+ nothingToInstall = null (fst (InstallPlan.ready installPlan))
+
+ dryRun = fromFlag (installDryRun installFlags)
+ overrideReinstall = fromFlag (installOverrideReinstall installFlags)
+
+data PackageStatus
+ = NewPackage
+ | NewVersion [Version]
+ | Reinstall [UnitId] [PackageChange]
type PackageChange = MergeResult MungedPackageId MungedPackageId
extractReinstalls :: PackageStatus -> [UnitId]
extractReinstalls (Reinstall ipids _) = ipids
-extractReinstalls _ = []
+extractReinstalls _ = []
-packageStatus :: InstalledPackageIndex
- -> ReadyPackage
- -> PackageStatus
+packageStatus
+ :: InstalledPackageIndex
+ -> ReadyPackage
+ -> PackageStatus
packageStatus installedPkgIndex cpkg =
- case PackageIndex.lookupPackageName installedPkgIndex
- (packageName cpkg) of
+ case PackageIndex.lookupPackageName
+ installedPkgIndex
+ (packageName cpkg) of
[] -> NewPackage
- ps -> case filter ((== mungedId cpkg)
- . mungedId) (concatMap snd ps) of
- [] -> NewVersion (map fst ps)
- pkgs@(pkg:_) -> Reinstall (map Installed.installedUnitId pkgs)
- (changes pkg cpkg)
-
+ ps -> case filter
+ ( (== mungedId cpkg)
+ . mungedId
+ )
+ (concatMap snd ps) of
+ [] -> NewVersion (map fst ps)
+ pkgs@(pkg : _) ->
+ Reinstall
+ (map Installed.installedUnitId pkgs)
+ (changes pkg cpkg)
where
-
- changes :: Installed.InstalledPackageInfo
- -> ReadyPackage
- -> [PackageChange]
- changes pkg (ReadyPackage pkg') = filter changed $
- mergeBy (comparing mungedName)
- -- deps of installed pkg
- (resolveInstalledIds $ Installed.depends pkg)
- -- deps of configured pkg
- (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))
+ changes
+ :: Installed.InstalledPackageInfo
+ -> ReadyPackage
+ -> [PackageChange]
+ changes pkg (ReadyPackage pkg') =
+ filter changed $
+ mergeBy
+ (comparing mungedName)
+ -- deps of installed pkg
+ (resolveInstalledIds $ Installed.depends pkg)
+ -- deps of configured pkg
+ (resolveInstalledIds $ CD.nonSetupDeps (depends pkg'))
-- convert to source pkg ids via index
resolveInstalledIds :: [UnitId] -> [MungedPackageId]
resolveInstalledIds =
- nub
- . sort
- . map mungedId
- . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex)
-
- changed (InBoth pkgid pkgid') = pkgid /= pkgid'
- changed _ = True
-
-printPlan :: Bool -- is dry run
- -> Verbosity
- -> [(ReadyPackage, PackageStatus)]
- -> SourcePackageDb
- -> IO ()
+ nub
+ . sort
+ . map mungedId
+ . mapMaybe (PackageIndex.lookupUnitId installedPkgIndex)
+
+ changed (InBoth pkgid pkgid') = pkgid /= pkgid'
+ changed _ = True
+
+printPlan
+ :: Bool -- is dry run
+ -> Verbosity
+ -> [(ReadyPackage, PackageStatus)]
+ -> SourcePackageDb
+ -> IO ()
printPlan dryRun verbosity plan sourcePkgDb = case plan of
- [] -> return ()
+ [] -> return ()
pkgs
- | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $
- ("In order, the following " ++ wouldWill ++ " be installed:")
- : map showPkgAndReason pkgs
- | otherwise -> notice verbosity $ unlines $
- ("In order, the following " ++ wouldWill
- ++ " be installed (use -v for more details):")
- : map showPkg pkgs
+ | verbosity >= Verbosity.verbose ->
+ notice verbosity $
+ unlines $
+ ("In order, the following " ++ wouldWill ++ " be installed:")
+ : map showPkgAndReason pkgs
+ | otherwise ->
+ notice verbosity $
+ unlines $
+ ( "In order, the following "
+ ++ wouldWill
+ ++ " be installed (use -v for more details):"
+ )
+ : map showPkg pkgs
where
- wouldWill | dryRun = "would"
- | otherwise = "will"
+ wouldWill
+ | dryRun = "would"
+ | otherwise = "will"
- showPkg (pkg, _) = prettyShow (packageId pkg) ++
- showLatest (pkg)
+ showPkg (pkg, _) =
+ prettyShow (packageId pkg)
+ ++ showLatest (pkg)
- showPkgAndReason (ReadyPackage pkg', pr) = unwords
+ showPkgAndReason (ReadyPackage pkg', pr) =
+ unwords
[ prettyShow (packageId pkg')
, showLatest pkg'
, showFlagAssignment (nonDefaultFlags pkg')
, showStanzas (confPkgStanzas pkg')
, showDep pkg'
, case pr of
- NewPackage -> "(new package)"
- NewVersion _ -> "(new version)"
- Reinstall _ cs -> "(reinstall)" ++ case cs of
- [] -> ""
- diff -> "(changes: " ++ intercalate ", " (map change diff)
- ++ ")"
+ NewPackage -> "(new package)"
+ NewVersion _ -> "(new version)"
+ Reinstall _ cs ->
+ "(reinstall)" ++ case cs of
+ [] -> ""
+ diff ->
+ "(changes: "
+ ++ intercalate ", " (map change diff)
+ ++ ")"
]
showLatest :: Package srcpkg => srcpkg -> String
showLatest pkg = case mLatestVersion of
- Just latestVersion ->
- if packageVersion pkg < latestVersion
- then ("(latest: " ++ prettyShow latestVersion ++ ")")
- else ""
- Nothing -> ""
+ Just latestVersion ->
+ if packageVersion pkg < latestVersion
+ then ("(latest: " ++ prettyShow latestVersion ++ ")")
+ else ""
+ Nothing -> ""
where
mLatestVersion :: Maybe Version
- mLatestVersion = fmap packageVersion $
- safeLast $
- SourcePackageIndex.lookupPackageName
- (packageIndex sourcePkgDb)
- (packageName pkg)
+ mLatestVersion =
+ fmap packageVersion $
+ safeLast $
+ SourcePackageIndex.lookupPackageName
+ (packageIndex sourcePkgDb)
+ (packageName pkg)
toFlagAssignment :: [PackageFlag] -> FlagAssignment
- toFlagAssignment = mkFlagAssignment . map (\ f -> (flagName f, flagDefault f))
+ toFlagAssignment = mkFlagAssignment . map (\f -> (flagName f, flagDefault f))
nonDefaultFlags :: ConfiguredPackage loc -> FlagAssignment
nonDefaultFlags cpkg =
let defaultAssignment =
toFlagAssignment
- (genPackageFlags (SourcePackage.srcpkgDescription $
- confPkgSource cpkg))
- in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment
-
- change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed"
- change (InBoth pkgid pkgid') = prettyShow pkgid ++ " -> "
- ++ prettyShow (mungedVersion pkgid')
- change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added"
-
- showDep pkg | Just rdeps <- Map.lookup (packageId pkg) revDeps
- = " (via: " ++ unwords (map prettyShow rdeps) ++ ")"
- | otherwise = ""
+ ( genPackageFlags
+ ( SourcePackage.srcpkgDescription $
+ confPkgSource cpkg
+ )
+ )
+ in confPkgFlags cpkg `diffFlagAssignment` defaultAssignment
+
+ change (OnlyInLeft pkgid) = prettyShow pkgid ++ " removed"
+ change (InBoth pkgid pkgid') =
+ prettyShow pkgid
+ ++ " -> "
+ ++ prettyShow (mungedVersion pkgid')
+ change (OnlyInRight pkgid') = prettyShow pkgid' ++ " added"
+
+ showDep pkg
+ | Just rdeps <- Map.lookup (packageId pkg) revDeps =
+ " (via: " ++ unwords (map prettyShow rdeps) ++ ")"
+ | otherwise = ""
revDepGraphEdges :: [(PackageId, PackageId)]
- revDepGraphEdges = [ (rpid, packageId cpkg)
- | (ReadyPackage cpkg, _) <- plan
- , ConfiguredId
- rpid
- (Just
- (PackageDescription.CLibName
- PackageDescription.LMainLibName))
- _
- <- CD.flatDeps (confPkgDeps cpkg) ]
+ revDepGraphEdges =
+ [ (rpid, packageId cpkg)
+ | (ReadyPackage cpkg, _) <- plan
+ , ConfiguredId
+ rpid
+ ( Just
+ ( PackageDescription.CLibName
+ PackageDescription.LMainLibName
+ )
+ )
+ _ <-
+ CD.flatDeps (confPkgDeps cpkg)
+ ]
revDeps :: Map.Map PackageId [PackageId]
- revDeps = Map.fromListWith (++) (map (fmap (:[])) revDepGraphEdges)
+ revDeps = Map.fromListWith (++) (map (fmap (: [])) revDepGraphEdges)
-- ------------------------------------------------------------
+
-- * Post installation stuff
+
-- ------------------------------------------------------------
-- | Report a solver failure. This works slightly differently to
-- 'postInstallActions', as (by definition) we don't have an install plan.
-reportPlanningFailure :: Verbosity -> InstallArgs -> InstallContext -> String
- -> IO ()
-reportPlanningFailure verbosity
- (_, _, comp, platform, _
- ,_, configFlags, _, installFlags, _, _, _)
+reportPlanningFailure
+ :: Verbosity
+ -> InstallArgs
+ -> InstallContext
+ -> String
+ -> IO ()
+reportPlanningFailure
+ verbosity
+ ( _
+ , _
+ , comp
+ , platform
+ , _
+ , _
+ , configFlags
+ , _
+ , installFlags
+ , _
+ , _
+ , _
+ )
(_, sourcePkgDb, _, _, pkgSpecifiers, _)
message = do
+ when reportFailure $ do
+ -- Only create reports for explicitly named packages
+ let pkgids =
+ filter
+ (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb))
+ $ mapMaybe theSpecifiedPackage pkgSpecifiers
+
+ buildReports =
+ BuildReports.fromPlanningFailure
+ platform
+ (compilerId comp)
+ pkgids
+ (configConfigurationsFlags configFlags)
+
+ unless (null buildReports) $
+ info verbosity $
+ "Solver failure will be reported for "
+ ++ intercalate "," (map prettyShow pkgids)
+
+ -- Save reports
+ BuildReports.storeLocal
+ (compilerInfo comp)
+ (fromNubList $ installSummaryFile installFlags)
+ buildReports
+ platform
- when reportFailure $ do
-
- -- Only create reports for explicitly named packages
- let pkgids = filter
- (SourcePackageIndex.elemByPackageId (packageIndex sourcePkgDb)) $
- mapMaybe theSpecifiedPackage pkgSpecifiers
-
- buildReports = BuildReports.fromPlanningFailure platform
- (compilerId comp) pkgids
- (configConfigurationsFlags configFlags)
-
- unless (null buildReports) $
- info verbosity $
- "Solver failure will be reported for "
- ++ intercalate "," (map prettyShow pkgids)
-
- -- Save reports
- BuildReports.storeLocal (compilerInfo comp)
- (fromNubList $ installSummaryFile installFlags)
- buildReports platform
-
- -- Save solver log
- case logFile of
- Nothing -> return ()
- Just template -> for_ pkgids $ \pkgid ->
- let env = initialPathTemplateEnv pkgid dummyIpid
- (compilerInfo comp) platform
- path = fromPathTemplate $ substPathTemplate env template
- in writeFile path message
-
- where
- reportFailure = fromFlag (installReportPlanningFailure installFlags)
- logFile = flagToMaybe (installLogFile installFlags)
-
- -- A IPID is calculated from the transitive closure of
- -- dependencies, but when the solver fails we don't have that.
- -- So we fail.
- dummyIpid = error "reportPlanningFailure: installed package ID not available"
+ -- Save solver log
+ case logFile of
+ Nothing -> return ()
+ Just template -> for_ pkgids $ \pkgid ->
+ let env =
+ initialPathTemplateEnv
+ pkgid
+ dummyIpid
+ (compilerInfo comp)
+ platform
+ path = fromPathTemplate $ substPathTemplate env template
+ in writeFile path message
+ where
+ reportFailure = fromFlag (installReportPlanningFailure installFlags)
+ logFile = flagToMaybe (installLogFile installFlags)
+
+ -- A IPID is calculated from the transitive closure of
+ -- dependencies, but when the solver fails we don't have that.
+ -- So we fail.
+ dummyIpid = error "reportPlanningFailure: installed package ID not available"
-- | If a 'PackageSpecifier' refers to a single package, return Just that
-- package.
theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage pkgSpec =
case pkgSpec of
- NamedPackage name [PackagePropertyVersion version]
- -> PackageIdentifier name <$> trivialRange version
+ NamedPackage name [PackagePropertyVersion version] ->
+ PackageIdentifier name <$> trivialRange version
NamedPackage _ _ -> Nothing
SpecificSourcePackage pkg -> Just $ packageId pkg
where
- -- | If a range includes only a single version, return Just that version.
+ -- \| If a range includes only a single version, return Just that version.
trivialRange :: VersionRange -> Maybe Version
- trivialRange = foldVersionRange
+ trivialRange =
+ foldVersionRange
Nothing
- Just -- "== v"
+ Just -- "== v"
(\_ -> Nothing)
(\_ -> Nothing)
(\_ _ -> Nothing)
@@ -793,201 +1120,276 @@ theSpecifiedPackage pkgSpec =
-- * symlinking binaries
-- * updating indexes
-- * error reporting
---
-postInstallActions :: Verbosity
- -> InstallArgs
- -> [UserTarget]
- -> InstallPlan
- -> BuildOutcomes
- -> IO ()
-postInstallActions verbosity
- (packageDBs, _, comp, platform, progdb
- ,globalFlags, configFlags, _, installFlags, _, _, _)
- _ installPlan buildOutcomes = do
-
- let buildReports = BuildReports.fromInstallPlan platform (compilerId comp)
- installPlan buildOutcomes
- BuildReports.storeLocal (compilerInfo comp)
- (fromNubList $ installSummaryFile installFlags)
- buildReports
- platform
- when (reportingLevel >= AnonymousReports) $
- BuildReports.storeAnonymous buildReports
- when (reportingLevel == DetailedReports) $
- storeDetailedBuildReports verbosity logsDir buildReports
-
- regenerateHaddockIndex verbosity packageDBs comp platform progdb
- configFlags installFlags buildOutcomes
-
- symlinkBinaries verbosity platform comp configFlags installFlags
- installPlan buildOutcomes
-
- printBuildFailures verbosity buildOutcomes
-
- where
- reportingLevel = fromFlag (installBuildReports installFlags)
- logsDir = fromFlag (globalLogsDir globalFlags)
-
-storeDetailedBuildReports :: Verbosity -> FilePath
- -> [(BuildReports.BuildReport, Maybe Repo)] -> IO ()
-storeDetailedBuildReports verbosity logsDir reports = sequence_
- [ do allReportsDir <- defaultReportsDir
- let logFileName = prettyShow (BuildReports.package report) <.> "log"
- logFile = logsDir </> logFileName
- reportsDir = allReportsDir </> unRepoName (remoteRepoName remoteRepo)
- reportFile = reportsDir </> logFileName
-
- handleMissingLogFile $ do
- buildLog <- readFile logFile
- createDirectoryIfMissing True reportsDir -- FIXME
- writeFile reportFile (show (showBuildReport report, buildLog))
-
- | (report, Just repo) <- reports
- , Just remoteRepo <- [maybeRepoRemote repo]
- , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]
-
+postInstallActions
+ :: Verbosity
+ -> InstallArgs
+ -> [UserTarget]
+ -> InstallPlan
+ -> BuildOutcomes
+ -> IO ()
+postInstallActions
+ verbosity
+ ( packageDBs
+ , _
+ , comp
+ , platform
+ , progdb
+ , globalFlags
+ , configFlags
+ , _
+ , installFlags
+ , _
+ , _
+ , _
+ )
+ _
+ installPlan
+ buildOutcomes = do
+ let buildReports =
+ BuildReports.fromInstallPlan
+ platform
+ (compilerId comp)
+ installPlan
+ buildOutcomes
+ BuildReports.storeLocal
+ (compilerInfo comp)
+ (fromNubList $ installSummaryFile installFlags)
+ buildReports
+ platform
+ when (reportingLevel >= AnonymousReports) $
+ BuildReports.storeAnonymous buildReports
+ when (reportingLevel == DetailedReports) $
+ storeDetailedBuildReports verbosity logsDir buildReports
+
+ regenerateHaddockIndex
+ verbosity
+ packageDBs
+ comp
+ platform
+ progdb
+ configFlags
+ installFlags
+ buildOutcomes
+
+ symlinkBinaries
+ verbosity
+ platform
+ comp
+ configFlags
+ installFlags
+ installPlan
+ buildOutcomes
+
+ printBuildFailures verbosity buildOutcomes
+ where
+ reportingLevel = fromFlag (installBuildReports installFlags)
+ logsDir = fromFlag (globalLogsDir globalFlags)
+
+storeDetailedBuildReports
+ :: Verbosity
+ -> FilePath
+ -> [(BuildReports.BuildReport, Maybe Repo)]
+ -> IO ()
+storeDetailedBuildReports verbosity logsDir reports =
+ sequence_
+ [ do
+ allReportsDir <- defaultReportsDir
+ let logFileName = prettyShow (BuildReports.package report) <.> "log"
+ logFile = logsDir </> logFileName
+ reportsDir = allReportsDir </> unRepoName (remoteRepoName remoteRepo)
+ reportFile = reportsDir </> logFileName
+
+ handleMissingLogFile $ do
+ buildLog <- readFile logFile
+ createDirectoryIfMissing True reportsDir -- FIXME
+ writeFile reportFile (show (showBuildReport report, buildLog))
+ | (report, Just repo) <- reports
+ , Just remoteRepo <- [maybeRepoRemote repo]
+ , isLikelyToHaveLogFile (BuildReports.installOutcome report)
+ ]
where
- isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True
- isLikelyToHaveLogFile BuildReports.BuildFailed {} = True
- isLikelyToHaveLogFile BuildReports.InstallFailed {} = True
- isLikelyToHaveLogFile BuildReports.InstallOk {} = True
- isLikelyToHaveLogFile _ = False
+ isLikelyToHaveLogFile BuildReports.ConfigureFailed{} = True
+ isLikelyToHaveLogFile BuildReports.BuildFailed{} = True
+ isLikelyToHaveLogFile BuildReports.InstallFailed{} = True
+ isLikelyToHaveLogFile BuildReports.InstallOk{} = True
+ isLikelyToHaveLogFile _ = False
handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->
- warn verbosity $ "Missing log file for build report: "
- ++ fromMaybe "" (ioeGetFileName ioe)
+ warn verbosity $
+ "Missing log file for build report: "
+ ++ fromMaybe "" (ioeGetFileName ioe)
missingFile ioe
- | isDoesNotExistError ioe = Just ioe
- missingFile _ = Nothing
-
-
-regenerateHaddockIndex :: Verbosity
- -> [PackageDB]
- -> Compiler
- -> Platform
- -> ProgramDb
- -> ConfigFlags
- -> InstallFlags
- -> BuildOutcomes
- -> IO ()
-regenerateHaddockIndex verbosity packageDBs comp platform progdb
- configFlags installFlags buildOutcomes
- | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do
-
- defaultDirs <- InstallDirs.defaultInstallDirs
- (compilerFlavor comp)
- (fromFlag (configUserInstall configFlags))
- True
- let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
- indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate
-
- notice verbosity $
- "Updating documentation index " ++ indexFile
-
- --TODO: might be nice if the install plan gave us the new InstalledPackageInfo
- installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
- Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile
-
- | otherwise = return ()
- where
- haddockIndexFileIsRequested =
- fromFlag (installDocumentation installFlags)
- && isJust (flagToMaybe (installHaddockIndex installFlags))
-
- -- We want to regenerate the index if some new documentation was actually
- -- installed. Since the index can be only per-user or per-sandbox (see
- -- #1337), we don't do it for global installs or special cases where we're
- -- installing into a specific db.
- shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes
- where
- someDocsWereInstalled = any installedDocs . Map.elems
- installedDocs (Right (BuildResult DocsOk _ _)) = True
- installedDocs _ = False
-
- normalUserInstall = (UserPackageDB `elem` packageDBs)
- && all (not . isSpecificPackageDB) packageDBs
- isSpecificPackageDB (SpecificPackageDB _) = True
- isSpecificPackageDB _ = False
-
- substHaddockIndexFileName defaultDirs = fromPathTemplate
- . substPathTemplate env
- where
- env = env0 ++ installDirsTemplateEnv absoluteDirs
- env0 = InstallDirs.compilerTemplateEnv (compilerInfo comp)
- ++ InstallDirs.platformTemplateEnv platform
- ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform
- absoluteDirs = InstallDirs.substituteInstallDirTemplates
- env0 templateDirs
- templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
- defaultDirs (configInstallDirs configFlags)
-
-
-symlinkBinaries :: Verbosity
- -> Platform -> Compiler
- -> ConfigFlags
- -> InstallFlags
- -> InstallPlan
- -> BuildOutcomes
- -> IO ()
-symlinkBinaries verbosity platform comp configFlags installFlags
- plan buildOutcomes = do
- failed <- InstallSymlink.symlinkBinaries platform comp
- NeverOverwrite
- configFlags installFlags
- plan buildOutcomes
- case failed of
- [] -> return ()
- [(_, exe, path)] ->
- warn verbosity $
- "could not create a symlink in " ++ bindir ++ " for "
- ++ prettyShow exe ++ " because the file exists there already but is not "
- ++ "managed by cabal. You can create a symlink for this executable "
- ++ "manually if you wish. The executable file has been installed at "
- ++ path
- exes ->
- warn verbosity $
- "could not create symlinks in " ++ bindir ++ " for "
- ++ intercalate ", " [ prettyShow exe | (_, exe, _) <- exes ]
- ++ " because the files exist there already and are not "
- ++ "managed by cabal. You can create symlinks for these executables "
- ++ "manually if you wish. The executable files have been installed at "
- ++ intercalate ", " [ path | (_, _, path) <- exes ]
- where
- bindir = fromFlag (installSymlinkBinDir installFlags)
+ | isDoesNotExistError ioe = Just ioe
+ missingFile _ = Nothing
+regenerateHaddockIndex
+ :: Verbosity
+ -> [PackageDB]
+ -> Compiler
+ -> Platform
+ -> ProgramDb
+ -> ConfigFlags
+ -> InstallFlags
+ -> BuildOutcomes
+ -> IO ()
+regenerateHaddockIndex
+ verbosity
+ packageDBs
+ comp
+ platform
+ progdb
+ configFlags
+ installFlags
+ buildOutcomes
+ | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do
+ defaultDirs <-
+ InstallDirs.defaultInstallDirs
+ (compilerFlavor comp)
+ (fromFlag (configUserInstall configFlags))
+ True
+ let indexFileTemplate = fromFlag (installHaddockIndex installFlags)
+ indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate
+
+ notice verbosity $
+ "Updating documentation index " ++ indexFile
+
+ -- TODO: might be nice if the install plan gave us the new InstalledPackageInfo
+ installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
+ Haddock.regenerateHaddockIndex verbosity installedPkgIndex progdb indexFile
+ | otherwise = return ()
+ where
+ haddockIndexFileIsRequested =
+ fromFlag (installDocumentation installFlags)
+ && isJust (flagToMaybe (installHaddockIndex installFlags))
+
+ -- We want to regenerate the index if some new documentation was actually
+ -- installed. Since the index can be only per-user or per-sandbox (see
+ -- #1337), we don't do it for global installs or special cases where we're
+ -- installing into a specific db.
+ shouldRegenerateHaddockIndex = normalUserInstall && someDocsWereInstalled buildOutcomes
+ where
+ someDocsWereInstalled = any installedDocs . Map.elems
+ installedDocs (Right (BuildResult DocsOk _ _)) = True
+ installedDocs _ = False
+
+ normalUserInstall =
+ (UserPackageDB `elem` packageDBs)
+ && all (not . isSpecificPackageDB) packageDBs
+ isSpecificPackageDB (SpecificPackageDB _) = True
+ isSpecificPackageDB _ = False
+
+ substHaddockIndexFileName defaultDirs =
+ fromPathTemplate
+ . substPathTemplate env
+ where
+ env = env0 ++ installDirsTemplateEnv absoluteDirs
+ env0 =
+ InstallDirs.compilerTemplateEnv (compilerInfo comp)
+ ++ InstallDirs.platformTemplateEnv platform
+ ++ InstallDirs.abiTemplateEnv (compilerInfo comp) platform
+ absoluteDirs =
+ InstallDirs.substituteInstallDirTemplates
+ env0
+ templateDirs
+ templateDirs =
+ InstallDirs.combineInstallDirs
+ fromFlagOrDefault
+ defaultDirs
+ (configInstallDirs configFlags)
+
+symlinkBinaries
+ :: Verbosity
+ -> Platform
+ -> Compiler
+ -> ConfigFlags
+ -> InstallFlags
+ -> InstallPlan
+ -> BuildOutcomes
+ -> IO ()
+symlinkBinaries
+ verbosity
+ platform
+ comp
+ configFlags
+ installFlags
+ plan
+ buildOutcomes = do
+ failed <-
+ InstallSymlink.symlinkBinaries
+ platform
+ comp
+ NeverOverwrite
+ configFlags
+ installFlags
+ plan
+ buildOutcomes
+ case failed of
+ [] -> return ()
+ [(_, exe, path)] ->
+ warn verbosity $
+ "could not create a symlink in "
+ ++ bindir
+ ++ " for "
+ ++ prettyShow exe
+ ++ " because the file exists there already but is not "
+ ++ "managed by cabal. You can create a symlink for this executable "
+ ++ "manually if you wish. The executable file has been installed at "
+ ++ path
+ exes ->
+ warn verbosity $
+ "could not create symlinks in "
+ ++ bindir
+ ++ " for "
+ ++ intercalate ", " [prettyShow exe | (_, exe, _) <- exes]
+ ++ " because the files exist there already and are not "
+ ++ "managed by cabal. You can create symlinks for these executables "
+ ++ "manually if you wish. The executable files have been installed at "
+ ++ intercalate ", " [path | (_, _, path) <- exes]
+ where
+ bindir = fromFlag (installSymlinkBinDir installFlags)
printBuildFailures :: Verbosity -> BuildOutcomes -> IO ()
printBuildFailures verbosity buildOutcomes =
case [ (pkgid, failure)
- | (pkgid, Left failure) <- Map.toList buildOutcomes ] of
- [] -> return ()
- failed -> die' verbosity . unlines
- $ "Some packages failed to install:"
- : [ prettyShow pkgid ++ printFailureReason reason
- | (pkgid, reason) <- failed ]
+ | (pkgid, Left failure) <- Map.toList buildOutcomes
+ ] of
+ [] -> return ()
+ failed ->
+ die' verbosity . unlines $
+ "Some packages failed to install:"
+ : [ prettyShow pkgid ++ printFailureReason reason
+ | (pkgid, reason) <- failed
+ ]
where
printFailureReason reason = case reason of
GracefulFailure msg -> msg
- DependentFailed pkgid -> " depends on " ++ prettyShow pkgid
- ++ " which failed to install."
- DownloadFailed e -> " failed while downloading the package."
- ++ showException e
- UnpackFailed e -> " failed while unpacking the package."
- ++ showException e
- ConfigureFailed e -> " failed during the configure step."
- ++ showException e
- BuildFailed e -> " failed during the building phase."
- ++ showException e
- TestsFailed e -> " failed during the tests phase."
- ++ showException e
- InstallFailed e -> " failed during the final install step."
- ++ showException e
-
+ DependentFailed pkgid ->
+ " depends on "
+ ++ prettyShow pkgid
+ ++ " which failed to install."
+ DownloadFailed e ->
+ " failed while downloading the package."
+ ++ showException e
+ UnpackFailed e ->
+ " failed while unpacking the package."
+ ++ showException e
+ ConfigureFailed e ->
+ " failed during the configure step."
+ ++ showException e
+ BuildFailed e ->
+ " failed during the building phase."
+ ++ showException e
+ TestsFailed e ->
+ " failed during the tests phase."
+ ++ showException e
+ InstallFailed e ->
+ " failed during the final install step."
+ ++ showException e
-- This will never happen, but we include it for completeness
PlanningFailed -> " failed during the planning phase."
- showException e = " The exception was:\n " ++ show e ++ maybeOOM e
+ showException e = " The exception was:\n " ++ show e ++ maybeOOM e
#ifdef mingw32_HOST_OS
maybeOOM _ = ""
#else
@@ -999,140 +1401,193 @@ printBuildFailures verbosity buildOutcomes =
#endif
-- ------------------------------------------------------------
+
-- * Actually do the installations
+
-- ------------------------------------------------------------
-data InstallMisc = InstallMisc {
- libVersion :: Maybe Version
+data InstallMisc = InstallMisc
+ { libVersion :: Maybe Version
}
-- | If logging is enabled, contains location of the log file and the verbosity
-- level for logging.
type UseLogFile = Maybe (PackageIdentifier -> UnitId -> FilePath, Verbosity)
-performInstallations :: Verbosity
- -> InstallArgs
- -> InstalledPackageIndex
- -> InstallPlan
- -> IO BuildOutcomes
-performInstallations verbosity
- (packageDBs, repoCtxt, comp, platform, progdb,
- globalFlags, configFlags, configExFlags, installFlags,
- haddockFlags, testFlags, _)
- installedPkgIndex installPlan = do
-
- info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."
-
- jobControl <- if parallelInstall then newParallelJobControl numJobs
- else newSerialJobControl
- fetchLimit <- newJobLimit (min numJobs numFetchJobs)
- installLock <- newLock -- serialise installation
- cacheLock <- newLock -- serialise access to setup exe cache
-
- executeInstallPlan verbosity jobControl keepGoing useLogFile
- installPlan $ \rpkg ->
- installReadyPackage platform cinfo configFlags
- rpkg $ \configFlags' src pkg pkgoverride ->
- fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->
- installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->
- installUnpackedPackage verbosity installLock numJobs
- (setupScriptOptions installedPkgIndex
- cacheLock rpkg)
- configFlags'
- installFlags haddockFlags testFlags
- comp progdb
- platform pkg rpkg pkgoverride mpath useLogFile
+performInstallations
+ :: Verbosity
+ -> InstallArgs
+ -> InstalledPackageIndex
+ -> InstallPlan
+ -> IO BuildOutcomes
+performInstallations
+ verbosity
+ ( packageDBs
+ , repoCtxt
+ , comp
+ , platform
+ , progdb
+ , globalFlags
+ , configFlags
+ , configExFlags
+ , installFlags
+ , haddockFlags
+ , testFlags
+ , _
+ )
+ installedPkgIndex
+ installPlan = do
+ info verbosity $ "Number of threads used: " ++ (show numJobs) ++ "."
+
+ jobControl <-
+ if parallelInstall
+ then newParallelJobControl numJobs
+ else newSerialJobControl
+ fetchLimit <- newJobLimit (min numJobs numFetchJobs)
+ installLock <- newLock -- serialise installation
+ cacheLock <- newLock -- serialise access to setup exe cache
+ executeInstallPlan
+ verbosity
+ jobControl
+ keepGoing
+ useLogFile
+ installPlan
+ $ \rpkg ->
+ installReadyPackage
+ platform
+ cinfo
+ configFlags
+ rpkg
+ $ \configFlags' src pkg pkgoverride ->
+ fetchSourcePackage verbosity repoCtxt fetchLimit src $ \src' ->
+ installLocalPackage verbosity (packageId pkg) src' distPref $ \mpath ->
+ installUnpackedPackage
+ verbosity
+ installLock
+ numJobs
+ ( setupScriptOptions
+ installedPkgIndex
+ cacheLock
+ rpkg
+ )
+ configFlags'
+ installFlags
+ haddockFlags
+ testFlags
+ comp
+ progdb
+ platform
+ pkg
+ rpkg
+ pkgoverride
+ mpath
+ useLogFile
+ where
+ cinfo = compilerInfo comp
+
+ numJobs = determineNumJobs (installNumJobs installFlags)
+ numFetchJobs = 2
+ parallelInstall = numJobs >= 2
+ keepGoing = fromFlag (installKeepGoing installFlags)
+ distPref =
+ fromFlagOrDefault
+ (useDistPref defaultSetupScriptOptions)
+ (configDistPref configFlags)
+
+ setupScriptOptions index lock rpkg =
+ configureSetupScript
+ packageDBs
+ comp
+ platform
+ progdb
+ distPref
+ (chooseCabalVersion configExFlags (libVersion miscOptions))
+ (Just lock)
+ parallelInstall
+ index
+ (Just rpkg)
+
+ reportingLevel = fromFlag (installBuildReports installFlags)
+ logsDir = fromFlag (globalLogsDir globalFlags)
+
+ -- Should the build output be written to a log file instead of stdout?
+ useLogFile :: UseLogFile
+ useLogFile =
+ fmap
+ ((\f -> (f, loggingVerbosity)) . substLogFileName)
+ logFileTemplate
+ where
+ installLogFile' = flagToMaybe $ installLogFile installFlags
+ defaultTemplate =
+ toPathTemplate $
+ logsDir </> "$compiler" </> "$libname" <.> "log"
+
+ -- If the user has specified --remote-build-reporting=detailed, use the
+ -- default log file location. If the --build-log option is set, use the
+ -- provided location. Otherwise don't use logging, unless building in
+ -- parallel (in which case the default location is used).
+ logFileTemplate :: Maybe PathTemplate
+ logFileTemplate
+ | useDefaultTemplate = Just defaultTemplate
+ | otherwise = installLogFile'
+
+ -- If the user has specified --remote-build-reporting=detailed or
+ -- --build-log, use more verbose logging.
+ loggingVerbosity :: Verbosity
+ loggingVerbosity
+ | overrideVerbosity = modifyVerbosity (max verbose) verbosity
+ | otherwise = verbosity
+
+ useDefaultTemplate :: Bool
+ useDefaultTemplate
+ | reportingLevel == DetailedReports = True
+ | isJust installLogFile' = False
+ | parallelInstall = True
+ | otherwise = False
+
+ overrideVerbosity :: Bool
+ overrideVerbosity
+ | reportingLevel == DetailedReports = True
+ | isJust installLogFile' = True
+ | parallelInstall = False
+ | otherwise = False
+
+ substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath
+ substLogFileName template pkg uid =
+ fromPathTemplate
+ . substPathTemplate env
+ $ template
+ where
+ env =
+ initialPathTemplateEnv
+ (packageId pkg)
+ uid
+ (compilerInfo comp)
+ platform
- where
- cinfo = compilerInfo comp
-
- numJobs = determineNumJobs (installNumJobs installFlags)
- numFetchJobs = 2
- parallelInstall = numJobs >= 2
- keepGoing = fromFlag (installKeepGoing installFlags)
- distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)
- (configDistPref configFlags)
-
- setupScriptOptions index lock rpkg =
- configureSetupScript
- packageDBs
- comp
- platform
- progdb
- distPref
- (chooseCabalVersion configExFlags (libVersion miscOptions))
- (Just lock)
- parallelInstall
- index
- (Just rpkg)
-
- reportingLevel = fromFlag (installBuildReports installFlags)
- logsDir = fromFlag (globalLogsDir globalFlags)
-
- -- Should the build output be written to a log file instead of stdout?
- useLogFile :: UseLogFile
- useLogFile = fmap ((\f -> (f, loggingVerbosity)) . substLogFileName)
- logFileTemplate
- where
- installLogFile' = flagToMaybe $ installLogFile installFlags
- defaultTemplate = toPathTemplate $
- logsDir </> "$compiler" </> "$libname" <.> "log"
-
- -- If the user has specified --remote-build-reporting=detailed, use the
- -- default log file location. If the --build-log option is set, use the
- -- provided location. Otherwise don't use logging, unless building in
- -- parallel (in which case the default location is used).
- logFileTemplate :: Maybe PathTemplate
- logFileTemplate
- | useDefaultTemplate = Just defaultTemplate
- | otherwise = installLogFile'
-
- -- If the user has specified --remote-build-reporting=detailed or
- -- --build-log, use more verbose logging.
- loggingVerbosity :: Verbosity
- loggingVerbosity | overrideVerbosity = modifyVerbosity (max verbose) verbosity
- | otherwise = verbosity
-
- useDefaultTemplate :: Bool
- useDefaultTemplate
- | reportingLevel == DetailedReports = True
- | isJust installLogFile' = False
- | parallelInstall = True
- | otherwise = False
-
- overrideVerbosity :: Bool
- overrideVerbosity
- | reportingLevel == DetailedReports = True
- | isJust installLogFile' = True
- | parallelInstall = False
- | otherwise = False
-
- substLogFileName :: PathTemplate -> PackageIdentifier -> UnitId -> FilePath
- substLogFileName template pkg uid = fromPathTemplate
- . substPathTemplate env
- $ template
- where env = initialPathTemplateEnv (packageId pkg) uid
- (compilerInfo comp) platform
-
- miscOptions = InstallMisc {
- libVersion = flagToMaybe (configCabalVersion configExFlags)
- }
-
-
-executeInstallPlan :: Verbosity
- -> JobControl IO (UnitId, BuildOutcome)
- -> Bool
- -> UseLogFile
- -> InstallPlan
- -> (ReadyPackage -> IO BuildOutcome)
- -> IO BuildOutcomes
-executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =
- InstallPlan.execute
- jobCtl keepGoing depsFailure plan0 $ \pkg -> do
- buildOutcome <- installPkg pkg
- printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome
- return buildOutcome
+ miscOptions =
+ InstallMisc
+ { libVersion = flagToMaybe (configCabalVersion configExFlags)
+ }
+executeInstallPlan
+ :: Verbosity
+ -> JobControl IO (UnitId, BuildOutcome)
+ -> Bool
+ -> UseLogFile
+ -> InstallPlan
+ -> (ReadyPackage -> IO BuildOutcome)
+ -> IO BuildOutcomes
+executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =
+ InstallPlan.execute
+ jobCtl
+ keepGoing
+ depsFailure
+ plan0
+ $ \pkg -> do
+ buildOutcome <- installPkg pkg
+ printBuildResult (packageId pkg) (installedUnitId pkg) buildOutcome
+ return buildOutcome
where
depsFailure = DependentFailed . packageId
@@ -1140,16 +1595,16 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =
-- otherwise.
printBuildResult :: PackageId -> UnitId -> BuildOutcome -> IO ()
printBuildResult pkgid uid buildOutcome = case buildOutcome of
- (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid)
- (Left _) -> do
- notice verbosity $ "Failed to install " ++ prettyShow pkgid
- when (verbosity >= normal) $
- case useLogFile of
- Nothing -> return ()
- Just (mkLogFileName, _) -> do
- let logName = mkLogFileName pkgid uid
- putStr $ "Build log ( " ++ logName ++ " ):\n"
- printFile logName
+ (Right _) -> progressMessage verbosity ProgressCompleted (prettyShow pkgid)
+ (Left _) -> do
+ notice verbosity $ "Failed to install " ++ prettyShow pkgid
+ when (verbosity >= normal) $
+ case useLogFile of
+ Nothing -> return ()
+ Just (mkLogFileName, _) -> do
+ let logName = mkLogFileName pkgid uid
+ putStr $ "Build log ( " ++ logName ++ " ):\n"
+ printFile logName
printFile :: FilePath -> IO ()
printFile path = readFile path >>= putStr
@@ -1162,47 +1617,75 @@ executeInstallPlan verbosity jobCtl keepGoing useLogFile plan0 installPkg =
--
-- NB: when updating this function, don't forget to also update
-- 'configurePackage' in D.C.Configure.
-installReadyPackage :: Platform -> CompilerInfo
- -> ConfigFlags
- -> ReadyPackage
- -> (ConfigFlags -> UnresolvedPkgLoc
- -> PackageDescription
- -> PackageDescriptionOverride
- -> a)
- -> a
-installReadyPackage platform cinfo configFlags
- (ReadyPackage (ConfiguredPackage ipid
- (SourcePackage _ gpkg source pkgoverride)
- flags stanzas deps))
- installPkg =
- installPkg configFlags {
- configIPID = toFlag (prettyShow ipid),
- configConfigurationsFlags = flags,
- -- We generate the legacy constraints as well as the new style precise deps.
- -- In the end only one set gets passed to Setup.hs configure, depending on
- -- the Cabal version we are talking to.
- configConstraints = [ thisPackageVersionConstraint srcid
- | ConfiguredId
- srcid
- (Just
- (PackageDescription.CLibName
- PackageDescription.LMainLibName))
- _ipid
- <- CD.nonSetupDeps deps ],
- configDependencies = [ GivenComponent (packageName srcid) cname dep_ipid
- | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid
- <- CD.nonSetupDeps deps ],
- -- Use '--exact-configuration' if supported.
- configExactConfiguration = toFlag True,
- configBenchmarks = toFlag False,
- configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
- } source pkg pkgoverride
- where
- pkg = case finalizePD flags (enableStanzas stanzas)
- (const True)
- platform cinfo [] gpkg of
- Left _ -> error "finalizePD ReadyPackage failed"
- Right (desc, _) -> desc
+installReadyPackage
+ :: Platform
+ -> CompilerInfo
+ -> ConfigFlags
+ -> ReadyPackage
+ -> ( ConfigFlags
+ -> UnresolvedPkgLoc
+ -> PackageDescription
+ -> PackageDescriptionOverride
+ -> a
+ )
+ -> a
+installReadyPackage
+ platform
+ cinfo
+ configFlags
+ ( ReadyPackage
+ ( ConfiguredPackage
+ ipid
+ (SourcePackage _ gpkg source pkgoverride)
+ flags
+ stanzas
+ deps
+ )
+ )
+ installPkg =
+ installPkg
+ configFlags
+ { configIPID = toFlag (prettyShow ipid)
+ , configConfigurationsFlags = flags
+ , -- We generate the legacy constraints as well as the new style precise deps.
+ -- In the end only one set gets passed to Setup.hs configure, depending on
+ -- the Cabal version we are talking to.
+ configConstraints =
+ [ thisPackageVersionConstraint srcid
+ | ConfiguredId
+ srcid
+ ( Just
+ ( PackageDescription.CLibName
+ PackageDescription.LMainLibName
+ )
+ )
+ _ipid <-
+ CD.nonSetupDeps deps
+ ]
+ , configDependencies =
+ [ GivenComponent (packageName srcid) cname dep_ipid
+ | ConfiguredId srcid (Just (PackageDescription.CLibName cname)) dep_ipid <-
+ CD.nonSetupDeps deps
+ ]
+ , -- Use '--exact-configuration' if supported.
+ configExactConfiguration = toFlag True
+ , configBenchmarks = toFlag False
+ , configTests = toFlag (TestStanzas `optStanzaSetMember` stanzas)
+ }
+ source
+ pkg
+ pkgoverride
+ where
+ pkg = case finalizePD
+ flags
+ (enableStanzas stanzas)
+ (const True)
+ platform
+ cinfo
+ []
+ gpkg of
+ Left _ -> error "finalizePD ReadyPackage failed"
+ Right (desc, _) -> desc
fetchSourcePackage
:: Verbosity
@@ -1215,89 +1698,120 @@ fetchSourcePackage verbosity repoCtxt fetchLimit src installPkg = do
fetched <- checkFetched src
case fetched of
Just src' -> installPkg src'
- Nothing -> onFailure DownloadFailed $ do
- loc <- withJobLimit fetchLimit $
- fetchPackage verbosity repoCtxt src
- installPkg loc
-
+ Nothing -> onFailure DownloadFailed $ do
+ loc <-
+ withJobLimit fetchLimit $
+ fetchPackage verbosity repoCtxt src
+ installPkg loc
installLocalPackage
:: Verbosity
- -> PackageIdentifier -> ResolvedPkgLoc -> FilePath
+ -> PackageIdentifier
+ -> ResolvedPkgLoc
+ -> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
installLocalPackage verbosity pkgid location distPref installPkg =
-
case location of
-
LocalUnpackedPackage dir ->
installPkg (Just dir)
-
RemoteSourceRepoPackage _repo dir ->
installPkg (Just dir)
-
LocalTarballPackage tarballPath ->
- installLocalTarballPackage verbosity
- pkgid tarballPath distPref installPkg
-
+ installLocalTarballPackage
+ verbosity
+ pkgid
+ tarballPath
+ distPref
+ installPkg
RemoteTarballPackage _ tarballPath ->
- installLocalTarballPackage verbosity
- pkgid tarballPath distPref installPkg
-
+ installLocalTarballPackage
+ verbosity
+ pkgid
+ tarballPath
+ distPref
+ installPkg
RepoTarballPackage _ _ tarballPath ->
- installLocalTarballPackage verbosity
- pkgid tarballPath distPref installPkg
+ installLocalTarballPackage
+ verbosity
+ pkgid
+ tarballPath
+ distPref
+ installPkg
installLocalTarballPackage
:: Verbosity
- -> PackageIdentifier -> FilePath -> FilePath
+ -> PackageIdentifier
+ -> FilePath
+ -> FilePath
-> (Maybe FilePath -> IO BuildOutcome)
-> IO BuildOutcome
-installLocalTarballPackage verbosity pkgid
- tarballPath distPref installPkg = do
- tmp <- getTemporaryDirectory
- withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->
- onFailure UnpackFailed $ do
- let relUnpackedPath = prettyShow pkgid
- absUnpackedPath = tmpDirPath </> relUnpackedPath
- descFilePath = absUnpackedPath
- </> prettyShow (packageName pkgid) <.> "cabal"
- info verbosity $ "Extracting " ++ tarballPath
- ++ " to " ++ tmpDirPath ++ "..."
- extractTarGzFile tmpDirPath relUnpackedPath tarballPath
- exists <- doesFileExist descFilePath
- unless exists $
- die' verbosity $ "Package .cabal file not found: " ++ show descFilePath
- maybeRenameDistDir absUnpackedPath
- installPkg (Just absUnpackedPath)
-
- where
- -- 'cabal sdist' puts pre-generated files in the 'dist'
- -- directory. This fails when a nonstandard build directory name
- -- is used (as is the case with sandboxes), so we need to rename
- -- the 'dist' dir here.
- --
- -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still
- -- fails even with this workaround. We probably can live with that.
- maybeRenameDistDir :: FilePath -> IO ()
- maybeRenameDistDir absUnpackedPath = do
- let distDirPath = absUnpackedPath </> defaultDistPref
- distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")
- distDirPathNew = absUnpackedPath </> distPref
- distDirExists <- doesDirectoryExist distDirPath
- when (distDirExists
- && (not $ distDirPath `equalFilePath` distDirPathNew)) $ do
- -- NB: we need to handle the case when 'distDirPathNew' is a
- -- subdirectory of 'distDirPath' (e.g. the former is
- -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').
- debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '"
- ++ distDirPathTmp ++ "'."
- renameDirectory distDirPath distDirPathTmp
- when (distDirPath `isPrefixOf` distDirPathNew) $
- createDirectoryIfMissingVerbose verbosity False distDirPath
- debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '"
- ++ distDirPathNew ++ "'."
- renameDirectory distDirPathTmp distDirPathNew
+installLocalTarballPackage
+ verbosity
+ pkgid
+ tarballPath
+ distPref
+ installPkg = do
+ tmp <- getTemporaryDirectory
+ withTempDirectory verbosity tmp "cabal-tmp" $ \tmpDirPath ->
+ onFailure UnpackFailed $ do
+ let relUnpackedPath = prettyShow pkgid
+ absUnpackedPath = tmpDirPath </> relUnpackedPath
+ descFilePath =
+ absUnpackedPath
+ </> prettyShow (packageName pkgid)
+ <.> "cabal"
+ info verbosity $
+ "Extracting "
+ ++ tarballPath
+ ++ " to "
+ ++ tmpDirPath
+ ++ "..."
+ extractTarGzFile tmpDirPath relUnpackedPath tarballPath
+ exists <- doesFileExist descFilePath
+ unless exists $
+ die' verbosity $
+ "Package .cabal file not found: " ++ show descFilePath
+ maybeRenameDistDir absUnpackedPath
+ installPkg (Just absUnpackedPath)
+ where
+ -- 'cabal sdist' puts pre-generated files in the 'dist'
+ -- directory. This fails when a nonstandard build directory name
+ -- is used (as is the case with sandboxes), so we need to rename
+ -- the 'dist' dir here.
+ --
+ -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still
+ -- fails even with this workaround. We probably can live with that.
+ maybeRenameDistDir :: FilePath -> IO ()
+ maybeRenameDistDir absUnpackedPath = do
+ let distDirPath = absUnpackedPath </> defaultDistPref
+ distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")
+ distDirPathNew = absUnpackedPath </> distPref
+ distDirExists <- doesDirectoryExist distDirPath
+ when
+ ( distDirExists
+ && (not $ distDirPath `equalFilePath` distDirPathNew)
+ )
+ $ do
+ -- NB: we need to handle the case when 'distDirPathNew' is a
+ -- subdirectory of 'distDirPath' (e.g. the former is
+ -- 'dist/dist-sandbox-3688fbc2' and the latter is 'dist').
+ debug verbosity $
+ "Renaming '"
+ ++ distDirPath
+ ++ "' to '"
+ ++ distDirPathTmp
+ ++ "'."
+ renameDirectory distDirPath distDirPathTmp
+ when (distDirPath `isPrefixOf` distDirPathNew) $
+ createDirectoryIfMissingVerbose verbosity False distDirPath
+ debug verbosity $
+ "Renaming '"
+ ++ distDirPathTmp
+ ++ "' to '"
+ ++ distDirPathNew
+ ++ "'."
+ renameDirectory distDirPathTmp distDirPathNew
installUnpackedPackage
:: Verbosity
@@ -1314,235 +1828,301 @@ installUnpackedPackage
-> PackageDescription
-> ReadyPackage
-> PackageDescriptionOverride
- -> Maybe FilePath -- ^ Directory to change to before starting the installation.
- -> UseLogFile -- ^ File to log output to (if any)
+ -> Maybe FilePath
+ -- ^ Directory to change to before starting the installation.
+ -> UseLogFile
+ -- ^ File to log output to (if any)
-> IO BuildOutcome
-installUnpackedPackage verbosity installLock numJobs
- scriptOptions
- configFlags installFlags haddockFlags testFlags comp progdb
- platform pkg rpkg pkgoverride workingDir useLogFile = do
- -- Override the .cabal file if necessary
- case pkgoverride of
- Nothing -> return ()
- Just pkgtxt -> do
- let descFilePath = fromMaybe "." workingDir
- </> prettyShow (packageName pkgid) <.> "cabal"
- info verbosity $
- "Updating " ++ prettyShow (packageName pkgid) <.> "cabal"
- ++ " with the latest revision from the index."
- writeFileAtomic descFilePath pkgtxt
-
- -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if
- -- the setup script was compiled against an old version of the Cabal lib).
- configFlags' <- addDefaultInstallDirs configFlags
- -- Filter out flags not supported by the old versions of the Cabal lib.
- let configureFlags :: Version -> ConfigFlags
- configureFlags = filterConfigureFlags configFlags' {
- configVerbosity = toFlag verbosity'
- }
-
- -- Path to the optional log file.
- mLogPath <- maybeLogPath
-
- logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do
- -- Configure phase
- onFailure ConfigureFailed $ do
- noticeProgress ProgressStarting
- setup configureCommand configureFlags mLogPath
-
- -- Build phase
- onFailure BuildFailed $ do
- noticeProgress ProgressBuilding
- setup buildCommand' buildFlags mLogPath
-
- -- Doc generation phase
- docsResult <- if shouldHaddock
- then (do setup haddockCommand haddockFlags' mLogPath
- return DocsOk)
- `catchIO` (\_ -> return DocsFailed)
- `catchExit` (\_ -> return DocsFailed)
- else return DocsNotTried
-
- -- Tests phase
- onFailure TestsFailed $ do
- when (testsEnabled && PackageDescription.hasTests pkg) $
- setup Cabal.testCommand testFlags' mLogPath
+installUnpackedPackage
+ verbosity
+ installLock
+ numJobs
+ scriptOptions
+ configFlags
+ installFlags
+ haddockFlags
+ testFlags
+ comp
+ progdb
+ platform
+ pkg
+ rpkg
+ pkgoverride
+ workingDir
+ useLogFile = do
+ -- Override the .cabal file if necessary
+ case pkgoverride of
+ Nothing -> return ()
+ Just pkgtxt -> do
+ let descFilePath =
+ fromMaybe "." workingDir
+ </> prettyShow (packageName pkgid)
+ <.> "cabal"
+ info verbosity $
+ "Updating "
+ ++ prettyShow (packageName pkgid) <.> "cabal"
+ ++ " with the latest revision from the index."
+ writeFileAtomic descFilePath pkgtxt
+
+ -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if
+ -- the setup script was compiled against an old version of the Cabal lib).
+ configFlags' <- addDefaultInstallDirs configFlags
+ -- Filter out flags not supported by the old versions of the Cabal lib.
+ let configureFlags :: Version -> ConfigFlags
+ configureFlags =
+ filterConfigureFlags
+ configFlags'
+ { configVerbosity = toFlag verbosity'
+ }
- let testsResult | testsEnabled = TestsOk
- | otherwise = TestsNotTried
-
- -- Install phase
- onFailure InstallFailed $ criticalSection installLock $ do
- -- Actual installation
- withWin32SelfUpgrade verbosity uid configFlags
- cinfo platform pkg $ do
- setup Cabal.copyCommand copyFlags mLogPath
-
- -- Capture installed package configuration file, so that
- -- it can be incorporated into the final InstallPlan
- ipkgs <- genPkgConfs mLogPath
- let ipkgs' = case ipkgs of
- [ipkg] -> [ipkg { Installed.installedUnitId = uid }]
- _ -> ipkgs
- let packageDBs = interpretPackageDbFlags
- (fromFlag (configUserInstall configFlags))
- (configPackageDBs configFlags)
- for_ ipkgs' $ \ipkg' ->
- registerPackage verbosity comp progdb
- packageDBs ipkg'
- defaultRegisterOptions
-
- return (Right (BuildResult docsResult testsResult (find ((==uid).installedUnitId) ipkgs')))
+ -- Path to the optional log file.
+ mLogPath <- maybeLogPath
+
+ logDirChange (maybe (const (return ())) appendFile mLogPath) workingDir $ do
+ -- Configure phase
+ onFailure ConfigureFailed $ do
+ noticeProgress ProgressStarting
+ setup configureCommand configureFlags mLogPath
+
+ -- Build phase
+ onFailure BuildFailed $ do
+ noticeProgress ProgressBuilding
+ setup buildCommand' buildFlags mLogPath
+
+ -- Doc generation phase
+ docsResult <-
+ if shouldHaddock
+ then
+ ( do
+ setup haddockCommand haddockFlags' mLogPath
+ return DocsOk
+ )
+ `catchIO` (\_ -> return DocsFailed)
+ `catchExit` (\_ -> return DocsFailed)
+ else return DocsNotTried
+
+ -- Tests phase
+ onFailure TestsFailed $ do
+ when (testsEnabled && PackageDescription.hasTests pkg) $
+ setup Cabal.testCommand testFlags' mLogPath
- where
- pkgid = packageId pkg
- uid = installedUnitId rpkg
- cinfo = compilerInfo comp
- buildCommand' = buildCommand progdb
- dispname = prettyShow pkgid
- isParallelBuild = numJobs >= 2
-
- noticeProgress phase = when isParallelBuild $
- progressMessage verbosity phase dispname
-
- buildFlags _ = emptyBuildFlags {
- buildDistPref = configDistPref configFlags,
- buildVerbosity = toFlag verbosity'
- }
- shouldHaddock = fromFlag (installDocumentation installFlags)
- haddockFlags' _ = haddockFlags {
- haddockVerbosity = toFlag verbosity',
- haddockDistPref = configDistPref configFlags
- }
- testsEnabled = fromFlag (configTests configFlags)
- && fromFlagOrDefault False (installRunTests installFlags)
- testFlags' = filterTestFlags testFlags {
- Cabal.testDistPref = configDistPref configFlags
- }
- copyFlags _ = Cabal.emptyCopyFlags {
- Cabal.copyDistPref = configDistPref configFlags,
- Cabal.copyDest = toFlag InstallDirs.NoCopyDest,
- Cabal.copyVerbosity = toFlag verbosity'
- }
- shouldRegister = PackageDescription.hasLibs pkg
- registerFlags _ = Cabal.emptyRegisterFlags {
- Cabal.regDistPref = configDistPref configFlags,
- Cabal.regVerbosity = toFlag verbosity'
- }
- verbosity' = maybe verbosity snd useLogFile
- tempTemplate name = name ++ "-" ++ prettyShow pkgid
-
- addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
- addDefaultInstallDirs configFlags' = do
- defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False
- return $ configFlags' {
- configInstallDirs = fmap Cabal.Flag .
- InstallDirs.substituteInstallDirTemplates env $
- InstallDirs.combineInstallDirs fromFlagOrDefault
- defInstallDirs (configInstallDirs configFlags)
+ let testsResult
+ | testsEnabled = TestsOk
+ | otherwise = TestsNotTried
+
+ -- Install phase
+ onFailure InstallFailed $ criticalSection installLock $ do
+ -- Actual installation
+ withWin32SelfUpgrade
+ verbosity
+ uid
+ configFlags
+ cinfo
+ platform
+ pkg
+ $ do
+ setup Cabal.copyCommand copyFlags mLogPath
+
+ -- Capture installed package configuration file, so that
+ -- it can be incorporated into the final InstallPlan
+ ipkgs <- genPkgConfs mLogPath
+ let ipkgs' = case ipkgs of
+ [ipkg] -> [ipkg{Installed.installedUnitId = uid}]
+ _ -> ipkgs
+ let packageDBs =
+ interpretPackageDbFlags
+ (fromFlag (configUserInstall configFlags))
+ (configPackageDBs configFlags)
+ for_ ipkgs' $ \ipkg' ->
+ registerPackage
+ verbosity
+ comp
+ progdb
+ packageDBs
+ ipkg'
+ defaultRegisterOptions
+
+ return (Right (BuildResult docsResult testsResult (find ((== uid) . installedUnitId) ipkgs')))
+ where
+ pkgid = packageId pkg
+ uid = installedUnitId rpkg
+ cinfo = compilerInfo comp
+ buildCommand' = buildCommand progdb
+ dispname = prettyShow pkgid
+ isParallelBuild = numJobs >= 2
+
+ noticeProgress phase =
+ when isParallelBuild $
+ progressMessage verbosity phase dispname
+
+ buildFlags _ =
+ emptyBuildFlags
+ { buildDistPref = configDistPref configFlags
+ , buildVerbosity = toFlag verbosity'
+ }
+ shouldHaddock = fromFlag (installDocumentation installFlags)
+ haddockFlags' _ =
+ haddockFlags
+ { haddockVerbosity = toFlag verbosity'
+ , haddockDistPref = configDistPref configFlags
}
+ testsEnabled =
+ fromFlag (configTests configFlags)
+ && fromFlagOrDefault False (installRunTests installFlags)
+ testFlags' =
+ filterTestFlags
+ testFlags
+ { Cabal.testDistPref = configDistPref configFlags
+ }
+ copyFlags _ =
+ Cabal.emptyCopyFlags
+ { Cabal.copyDistPref = configDistPref configFlags
+ , Cabal.copyDest = toFlag InstallDirs.NoCopyDest
+ , Cabal.copyVerbosity = toFlag verbosity'
+ }
+ shouldRegister = PackageDescription.hasLibs pkg
+ registerFlags _ =
+ Cabal.emptyRegisterFlags
+ { Cabal.regDistPref = configDistPref configFlags
+ , Cabal.regVerbosity = toFlag verbosity'
+ }
+ verbosity' = maybe verbosity snd useLogFile
+ tempTemplate name = name ++ "-" ++ prettyShow pkgid
+
+ addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags
+ addDefaultInstallDirs configFlags' = do
+ defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False
+ return $
+ configFlags'
+ { configInstallDirs =
+ fmap Cabal.Flag
+ . InstallDirs.substituteInstallDirTemplates env
+ $ InstallDirs.combineInstallDirs
+ fromFlagOrDefault
+ defInstallDirs
+ (configInstallDirs configFlags)
+ }
where
CompilerId flavor _ = compilerInfoId cinfo
- env = initialPathTemplateEnv pkgid uid cinfo platform
- userInstall = fromFlagOrDefault defaultUserInstall
- (configUserInstall configFlags')
-
- genPkgConfs :: Maybe FilePath
- -> IO [Installed.InstalledPackageInfo]
- genPkgConfs mLogPath =
- if shouldRegister then do
- tmp <- getTemporaryDirectory
- withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do
- let pkgConfDest = dir </> "pkgConf"
- registerFlags' version = (registerFlags version) {
- Cabal.regGenPkgConf = toFlag (Just pkgConfDest)
- }
- setup Cabal.registerCommand registerFlags' mLogPath
- is_dir <- doesDirectoryExist pkgConfDest
- let notHidden = not . isHidden
- isHidden name = "." `isPrefixOf` name
- if is_dir
- -- Sort so that each prefix of the package
- -- configurations is well formed
- then traverse (readPkgConf pkgConfDest) . sort . filter notHidden
+ env = initialPathTemplateEnv pkgid uid cinfo platform
+ userInstall =
+ fromFlagOrDefault
+ defaultUserInstall
+ (configUserInstall configFlags')
+
+ genPkgConfs
+ :: Maybe FilePath
+ -> IO [Installed.InstalledPackageInfo]
+ genPkgConfs mLogPath =
+ if shouldRegister
+ then do
+ tmp <- getTemporaryDirectory
+ withTempDirectory verbosity tmp (tempTemplate "pkgConf") $ \dir -> do
+ let pkgConfDest = dir </> "pkgConf"
+ registerFlags' version =
+ (registerFlags version)
+ { Cabal.regGenPkgConf = toFlag (Just pkgConfDest)
+ }
+ setup Cabal.registerCommand registerFlags' mLogPath
+ is_dir <- doesDirectoryExist pkgConfDest
+ let notHidden = not . isHidden
+ isHidden name = "." `isPrefixOf` name
+ if is_dir
+ then -- Sort so that each prefix of the package
+ -- configurations is well formed
+
+ traverse (readPkgConf pkgConfDest) . sort . filter notHidden
=<< getDirectoryContents pkgConfDest
- else fmap (:[]) $ readPkgConf "." pkgConfDest
- else return []
-
- readPkgConf :: FilePath -> FilePath
- -> IO Installed.InstalledPackageInfo
- readPkgConf pkgConfDir pkgConfFile = do
- pkgConfText <- BS.readFile (pkgConfDir </> pkgConfFile)
- case Installed.parseInstalledPackageInfo pkgConfText of
- Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
- Right (warns, pkgConf) -> do
- unless (null warns) $
- warn verbosity $ unlines warns
- return pkgConf
-
- pkgConfParseFailed :: String -> IO a
- pkgConfParseFailed perror =
- die' verbosity $ "Couldn't parse the output of 'setup register --gen-pkg-config':"
+ else fmap (: []) $ readPkgConf "." pkgConfDest
+ else return []
+
+ readPkgConf
+ :: FilePath
+ -> FilePath
+ -> IO Installed.InstalledPackageInfo
+ readPkgConf pkgConfDir pkgConfFile = do
+ pkgConfText <- BS.readFile (pkgConfDir </> pkgConfFile)
+ case Installed.parseInstalledPackageInfo pkgConfText of
+ Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
+ Right (warns, pkgConf) -> do
+ unless (null warns) $
+ warn verbosity $
+ unlines warns
+ return pkgConf
+
+ pkgConfParseFailed :: String -> IO a
+ pkgConfParseFailed perror =
+ die' verbosity $
+ "Couldn't parse the output of 'setup register --gen-pkg-config':"
++ show perror
- maybeLogPath :: IO (Maybe FilePath)
- maybeLogPath =
- case useLogFile of
- Nothing -> return Nothing
- Just (mkLogFileName, _) -> do
- let logFileName = mkLogFileName (packageId pkg) uid
- logDir = takeDirectory logFileName
- unless (null logDir) $ createDirectoryIfMissing True logDir
- logFileExists <- doesFileExist logFileName
- when logFileExists $ removeFile logFileName
- return (Just logFileName)
-
- setup cmd flags mLogPath =
- Exception.bracket
- (traverse (\path -> openFile path AppendMode) mLogPath)
- (traverse_ hClose)
- (\logFileHandle ->
- setupWrapper verbosity
- scriptOptions { useLoggingHandle = logFileHandle
- , useWorkingDir = workingDir }
- (Just pkg)
- cmd flags (const []))
-
+ maybeLogPath :: IO (Maybe FilePath)
+ maybeLogPath =
+ case useLogFile of
+ Nothing -> return Nothing
+ Just (mkLogFileName, _) -> do
+ let logFileName = mkLogFileName (packageId pkg) uid
+ logDir = takeDirectory logFileName
+ unless (null logDir) $ createDirectoryIfMissing True logDir
+ logFileExists <- doesFileExist logFileName
+ when logFileExists $ removeFile logFileName
+ return (Just logFileName)
+
+ setup cmd flags mLogPath =
+ Exception.bracket
+ (traverse (\path -> openFile path AppendMode) mLogPath)
+ (traverse_ hClose)
+ ( \logFileHandle ->
+ setupWrapper
+ verbosity
+ scriptOptions
+ { useLoggingHandle = logFileHandle
+ , useWorkingDir = workingDir
+ }
+ (Just pkg)
+ cmd
+ flags
+ (const [])
+ )
-- helper
onFailure :: (SomeException -> BuildFailure) -> IO BuildOutcome -> IO BuildOutcome
onFailure result action =
- action `catches`
- [ Handler $ \ioe -> handler (ioe :: IOException)
- , Handler $ \exit -> handler (exit :: ExitCode)
- ]
+ action
+ `catches` [ Handler $ \ioe -> handler (ioe :: IOException)
+ , Handler $ \exit -> handler (exit :: ExitCode)
+ ]
where
handler :: Exception e => e -> IO BuildOutcome
handler = return . Left . result . toException
-
-- ------------------------------------------------------------
+
-- * Weird windows hacks
+
-- ------------------------------------------------------------
-withWin32SelfUpgrade :: Verbosity
- -> UnitId
- -> ConfigFlags
- -> CompilerInfo
- -> Platform
- -> PackageDescription
- -> IO a -> IO a
+withWin32SelfUpgrade
+ :: Verbosity
+ -> UnitId
+ -> ConfigFlags
+ -> CompilerInfo
+ -> Platform
+ -> PackageDescription
+ -> IO a
+ -> IO a
withWin32SelfUpgrade _ _ _ _ _ _ action | buildOS /= Windows = action
withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do
-
- defaultDirs <- InstallDirs.defaultInstallDirs
- compFlavor
- (fromFlag (configUserInstall configFlags))
- (PackageDescription.hasLibs pkg)
-
- Win32SelfUpgrade.possibleSelfUpgrade verbosity
- (exeInstallPaths defaultDirs) action
-
+ defaultDirs <-
+ InstallDirs.defaultInstallDirs
+ compFlavor
+ (fromFlag (configUserInstall configFlags))
+ (PackageDescription.hasLibs pkg)
+
+ Win32SelfUpgrade.possibleSelfUpgrade
+ verbosity
+ (exeInstallPaths defaultDirs)
+ action
where
pkgid = packageId pkg
(CompilerId compFlavor _) = compilerInfoId cinfo
@@ -1552,19 +2132,33 @@ withWin32SelfUpgrade verbosity uid configFlags cinfo platform pkg action = do
| exe <- PackageDescription.executables pkg
, PackageDescription.buildable (PackageDescription.buildInfo exe)
, let exeName = prefix ++ prettyShow (PackageDescription.exeName exe) ++ suffix
- prefix = substTemplate prefixTemplate
- suffix = substTemplate suffixTemplate ]
+ prefix = substTemplate prefixTemplate
+ suffix = substTemplate suffixTemplate
+ ]
where
fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
- templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
- defaultDirs (configInstallDirs configFlags)
- absoluteDirs = InstallDirs.absoluteInstallDirs
- pkgid uid
- cinfo InstallDirs.NoCopyDest
- platform templateDirs
- substTemplate = InstallDirs.fromPathTemplate
- . InstallDirs.substPathTemplate env
- where env = InstallDirs.initialPathTemplateEnv pkgid uid
- cinfo platform
+ templateDirs =
+ InstallDirs.combineInstallDirs
+ fromFlagOrDefault
+ defaultDirs
+ (configInstallDirs configFlags)
+ absoluteDirs =
+ InstallDirs.absoluteInstallDirs
+ pkgid
+ uid
+ cinfo
+ InstallDirs.NoCopyDest
+ platform
+ templateDirs
+ substTemplate =
+ InstallDirs.fromPathTemplate
+ . InstallDirs.substPathTemplate env
+ where
+ env =
+ InstallDirs.initialPathTemplateEnv
+ pkgid
+ uid
+ cinfo
+ platform
diff --git a/cabal-install/src/Distribution/Client/InstallPlan.hs b/cabal-install/src/Distribution/Client/InstallPlan.hs
index 9b8fa6cba0c4b75c84b3ea68849a92bde6f778f4..0d872579e87c349c8a44d72939d2ff965fddcbb7 100644
--- a/cabal-install/src/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/src/Distribution/Client/InstallPlan.hs
@@ -1,11 +1,15 @@
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.InstallPlan
-- Copyright : (c) Duncan Coutts 2008
@@ -16,96 +20,99 @@
-- Portability : portable
--
-- Package installation plan
---
------------------------------------------------------------------------------
-module Distribution.Client.InstallPlan (
- InstallPlan,
- GenericInstallPlan,
- PlanPackage,
- GenericPlanPackage(..),
- foldPlanPackage,
- IsUnit,
-
- -- * Operations on 'InstallPlan's
- new,
- toGraph,
- toList,
- toMap,
- keys,
- keysSet,
- planIndepGoals,
- depends,
-
- fromSolverInstallPlan,
- fromSolverInstallPlanWithProgress,
- configureInstallPlan,
- remove,
- installed,
- lookup,
- directDeps,
- revDirectDeps,
-
- -- * Traversal
- executionOrder,
- execute,
- BuildOutcomes,
- lookupBuildOutcome,
- -- ** Traversal helpers
- -- $traversal
- Processing,
- ready,
- completed,
- failed,
-
- -- * Display
- showPlanGraph,
- showInstallPlan,
-
- -- * Graph-like operations
- dependencyClosure,
- reverseTopologicalOrder,
- reverseDependencyClosure,
+module Distribution.Client.InstallPlan
+ ( InstallPlan
+ , GenericInstallPlan
+ , PlanPackage
+ , GenericPlanPackage (..)
+ , foldPlanPackage
+ , IsUnit
+
+ -- * Operations on 'InstallPlan's
+ , new
+ , toGraph
+ , toList
+ , toMap
+ , keys
+ , keysSet
+ , planIndepGoals
+ , depends
+ , fromSolverInstallPlan
+ , fromSolverInstallPlanWithProgress
+ , configureInstallPlan
+ , remove
+ , installed
+ , lookup
+ , directDeps
+ , revDirectDeps
+
+ -- * Traversal
+ , executionOrder
+ , execute
+ , BuildOutcomes
+ , lookupBuildOutcome
+
+ -- ** Traversal helpers
+ -- $traversal
+ , Processing
+ , ready
+ , completed
+ , failed
+
+ -- * Display
+ , showPlanGraph
+ , showInstallPlan
+
+ -- * Graph-like operations
+ , dependencyClosure
+ , reverseTopologicalOrder
+ , reverseDependencyClosure
) where
-import Distribution.Client.Compat.Prelude hiding (toList, lookup, tail)
-import Prelude (tail)
+import Distribution.Client.Compat.Prelude hiding (lookup, tail, toList)
import Distribution.Compat.Stack (WithCallStack)
+import Prelude (tail)
import Distribution.Client.Types hiding (BuildOutcomes)
import qualified Distribution.PackageDescription as PD
import qualified Distribution.Simple.Configure as Configure
import qualified Distribution.Simple.Setup as Cabal
+import Distribution.Client.JobControl
+import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
+import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
import Distribution.InstalledPackageInfo
- ( InstalledPackageInfo )
+ ( InstalledPackageInfo
+ )
import Distribution.Package
- ( Package(..), HasMungedPackageId(..)
- , HasUnitId(..), UnitId )
-import Distribution.Solver.Types.SolverPackage
-import Distribution.Client.JobControl
+ ( HasMungedPackageId (..)
+ , HasUnitId (..)
+ , Package (..)
+ , UnitId
+ )
import Distribution.Pretty (defaultStyle)
+import Distribution.Solver.Types.SolverPackage
import Text.PrettyPrint
-import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
-import Distribution.Client.SolverInstallPlan (SolverInstallPlan)
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.SolverId
-import Distribution.Solver.Types.InstSolverPackage
+import Distribution.Solver.Types.InstSolverPackage
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SolverId
-import Distribution.Utils.LogProgress
-import Distribution.Utils.Structured (Structured (..), Structure(Nominal))
+import Distribution.Utils.LogProgress
+import Distribution.Utils.Structured (Structure (Nominal), Structured (..))
-- TODO: Need this when we compute final UnitIds
-- import qualified Distribution.Simple.Configure as Configure
-import qualified Data.Foldable as Foldable (all, toList)
-import qualified Distribution.Compat.Graph as Graph
-import Distribution.Compat.Graph (Graph, IsNode(..))
import Control.Exception
- ( assert )
+ ( assert
+ )
+import qualified Data.Foldable as Foldable (all, toList)
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Distribution.Compat.Graph (Graph, IsNode (..))
+import qualified Distribution.Compat.Graph as Graph
-- When cabal tries to install a number of packages, including all their
-- dependencies it has a non-trivial problem to solve.
@@ -161,27 +168,28 @@ import qualified Data.Set as Set
-- to get this wrong (and, for instance, call graph traversal functions from
-- Cabal rather than from cabal-install). Instead, see 'PackageInstalled'.
data GenericPlanPackage ipkg srcpkg
- = PreExisting ipkg
- | Configured srcpkg
- | Installed srcpkg
+ = PreExisting ipkg
+ | Configured srcpkg
+ | Installed srcpkg
deriving (Eq, Show, Generic)
displayGenericPlanPackage :: (IsUnit ipkg, IsUnit srcpkg) => GenericPlanPackage ipkg srcpkg -> String
displayGenericPlanPackage (PreExisting pkg) = "PreExisting " ++ prettyShow (nodeKey pkg)
-displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)
-displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg)
+displayGenericPlanPackage (Configured pkg) = "Configured " ++ prettyShow (nodeKey pkg)
+displayGenericPlanPackage (Installed pkg) = "Installed " ++ prettyShow (nodeKey pkg)
-- | Convenience combinator for destructing 'GenericPlanPackage'.
-- This is handy because if you case manually, you have to handle
-- 'Configured' and 'Installed' separately (where often you want
-- them to be the same.)
-foldPlanPackage :: (ipkg -> a)
- -> (srcpkg -> a)
- -> GenericPlanPackage ipkg srcpkg
- -> a
-foldPlanPackage f _ (PreExisting ipkg) = f ipkg
+foldPlanPackage
+ :: (ipkg -> a)
+ -> (srcpkg -> a)
+ -> GenericPlanPackage ipkg srcpkg
+ -> a
+foldPlanPackage f _ (PreExisting ipkg) = f ipkg
foldPlanPackage _ g (Configured srcpkg) = g srcpkg
-foldPlanPackage _ g (Installed srcpkg) = g srcpkg
+foldPlanPackage _ g (Installed srcpkg) = g srcpkg
type IsUnit a = (IsNode a, Key a ~ UnitId)
@@ -190,133 +198,183 @@ depends = nodeNeighbors
-- NB: Expanded constraint synonym here to avoid undecidable
-- instance errors in GHC 7.8 and earlier.
-instance (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
- => IsNode (GenericPlanPackage ipkg srcpkg) where
- type Key (GenericPlanPackage ipkg srcpkg) = UnitId
- nodeKey (PreExisting ipkg) = nodeKey ipkg
- nodeKey (Configured spkg) = nodeKey spkg
- nodeKey (Installed spkg) = nodeKey spkg
- nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
- nodeNeighbors (Configured spkg) = nodeNeighbors spkg
- nodeNeighbors (Installed spkg) = nodeNeighbors spkg
+instance
+ (IsNode ipkg, IsNode srcpkg, Key ipkg ~ UnitId, Key srcpkg ~ UnitId)
+ => IsNode (GenericPlanPackage ipkg srcpkg)
+ where
+ type Key (GenericPlanPackage ipkg srcpkg) = UnitId
+ nodeKey (PreExisting ipkg) = nodeKey ipkg
+ nodeKey (Configured spkg) = nodeKey spkg
+ nodeKey (Installed spkg) = nodeKey spkg
+ nodeNeighbors (PreExisting ipkg) = nodeNeighbors ipkg
+ nodeNeighbors (Configured spkg) = nodeNeighbors spkg
+ nodeNeighbors (Installed spkg) = nodeNeighbors spkg
instance (Binary ipkg, Binary srcpkg) => Binary (GenericPlanPackage ipkg srcpkg)
instance (Structured ipkg, Structured srcpkg) => Structured (GenericPlanPackage ipkg srcpkg)
-type PlanPackage = GenericPlanPackage
- InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)
+type PlanPackage =
+ GenericPlanPackage
+ InstalledPackageInfo
+ (ConfiguredPackage UnresolvedPkgLoc)
-instance (Package ipkg, Package srcpkg) =>
- Package (GenericPlanPackage ipkg srcpkg) where
- packageId (PreExisting ipkg) = packageId ipkg
- packageId (Configured spkg) = packageId spkg
- packageId (Installed spkg) = packageId spkg
-
-instance (HasMungedPackageId ipkg, HasMungedPackageId srcpkg) =>
- HasMungedPackageId (GenericPlanPackage ipkg srcpkg) where
- mungedId (PreExisting ipkg) = mungedId ipkg
- mungedId (Configured spkg) = mungedId spkg
- mungedId (Installed spkg) = mungedId spkg
+instance
+ (Package ipkg, Package srcpkg)
+ => Package (GenericPlanPackage ipkg srcpkg)
+ where
+ packageId (PreExisting ipkg) = packageId ipkg
+ packageId (Configured spkg) = packageId spkg
+ packageId (Installed spkg) = packageId spkg
-instance (HasUnitId ipkg, HasUnitId srcpkg) =>
- HasUnitId
- (GenericPlanPackage ipkg srcpkg) where
+instance
+ (HasMungedPackageId ipkg, HasMungedPackageId srcpkg)
+ => HasMungedPackageId (GenericPlanPackage ipkg srcpkg)
+ where
+ mungedId (PreExisting ipkg) = mungedId ipkg
+ mungedId (Configured spkg) = mungedId spkg
+ mungedId (Installed spkg) = mungedId spkg
+
+instance
+ (HasUnitId ipkg, HasUnitId srcpkg)
+ => HasUnitId
+ (GenericPlanPackage ipkg srcpkg)
+ where
installedUnitId (PreExisting ipkg) = installedUnitId ipkg
- installedUnitId (Configured spkg) = installedUnitId spkg
- installedUnitId (Installed spkg) = installedUnitId spkg
-
-instance (HasConfiguredId ipkg, HasConfiguredId srcpkg) =>
- HasConfiguredId (GenericPlanPackage ipkg srcpkg) where
- configuredId (PreExisting ipkg) = configuredId ipkg
- configuredId (Configured spkg) = configuredId spkg
- configuredId (Installed spkg) = configuredId spkg
-
-data GenericInstallPlan ipkg srcpkg = GenericInstallPlan {
- planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg)),
- planIndepGoals :: !IndependentGoals
+ installedUnitId (Configured spkg) = installedUnitId spkg
+ installedUnitId (Installed spkg) = installedUnitId spkg
+
+instance
+ (HasConfiguredId ipkg, HasConfiguredId srcpkg)
+ => HasConfiguredId (GenericPlanPackage ipkg srcpkg)
+ where
+ configuredId (PreExisting ipkg) = configuredId ipkg
+ configuredId (Configured spkg) = configuredId spkg
+ configuredId (Installed spkg) = configuredId spkg
+
+data GenericInstallPlan ipkg srcpkg = GenericInstallPlan
+ { planGraph :: !(Graph (GenericPlanPackage ipkg srcpkg))
+ , planIndepGoals :: !IndependentGoals
}
deriving (Typeable)
-- | 'GenericInstallPlan' specialised to most commonly used types.
-type InstallPlan = GenericInstallPlan
- InstalledPackageInfo (ConfiguredPackage UnresolvedPkgLoc)
+type InstallPlan =
+ GenericInstallPlan
+ InstalledPackageInfo
+ (ConfiguredPackage UnresolvedPkgLoc)
-- | Smart constructor that deals with caching the 'Graph' representation.
---
-mkInstallPlan :: (IsUnit ipkg, IsUnit srcpkg)
- => String
- -> Graph (GenericPlanPackage ipkg srcpkg)
- -> IndependentGoals
- -> GenericInstallPlan ipkg srcpkg
+mkInstallPlan
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => String
+ -> Graph (GenericPlanPackage ipkg srcpkg)
+ -> IndependentGoals
+ -> GenericInstallPlan ipkg srcpkg
mkInstallPlan loc graph indepGoals =
- assert (valid loc graph)
- GenericInstallPlan {
- planGraph = graph,
- planIndepGoals = indepGoals
- }
+ assert
+ (valid loc graph)
+ GenericInstallPlan
+ { planGraph = graph
+ , planIndepGoals = indepGoals
+ }
internalError :: WithCallStack (String -> String -> a)
-internalError loc msg = error $ "internal error in InstallPlan." ++ loc
- ++ if null msg then "" else ": " ++ msg
+internalError loc msg =
+ error $
+ "internal error in InstallPlan."
+ ++ loc
+ ++ if null msg then "" else ": " ++ msg
instance (Structured ipkg, Structured srcpkg) => Structured (GenericInstallPlan ipkg srcpkg) where
- structure p = Nominal (typeRep p) 0 "GenericInstallPlan"
- [ structure (Proxy :: Proxy ipkg)
- , structure (Proxy :: Proxy srcpkg)
- ]
-
-instance (IsNode ipkg, Key ipkg ~ UnitId, IsNode srcpkg, Key srcpkg ~ UnitId,
- Binary ipkg, Binary srcpkg)
- => Binary (GenericInstallPlan ipkg srcpkg) where
- put GenericInstallPlan {
- planGraph = graph,
- planIndepGoals = indepGoals
- } = put graph >> put indepGoals
-
- get = do
- graph <- get
- indepGoals <- get
- return $! mkInstallPlan "(instance Binary)" graph indepGoals
-
-showPlanGraph :: (Package ipkg, Package srcpkg,
- IsUnit ipkg, IsUnit srcpkg)
- => Graph (GenericPlanPackage ipkg srcpkg) -> String
-showPlanGraph graph = renderStyle defaultStyle $
+ structure p =
+ Nominal
+ (typeRep p)
+ 0
+ "GenericInstallPlan"
+ [ structure (Proxy :: Proxy ipkg)
+ , structure (Proxy :: Proxy srcpkg)
+ ]
+
+instance
+ ( IsNode ipkg
+ , Key ipkg ~ UnitId
+ , IsNode srcpkg
+ , Key srcpkg ~ UnitId
+ , Binary ipkg
+ , Binary srcpkg
+ )
+ => Binary (GenericInstallPlan ipkg srcpkg)
+ where
+ put
+ GenericInstallPlan
+ { planGraph = graph
+ , planIndepGoals = indepGoals
+ } = put graph >> put indepGoals
+
+ get = do
+ graph <- get
+ indepGoals <- get
+ return $! mkInstallPlan "(instance Binary)" graph indepGoals
+
+showPlanGraph
+ :: ( Package ipkg
+ , Package srcpkg
+ , IsUnit ipkg
+ , IsUnit srcpkg
+ )
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> String
+showPlanGraph graph =
+ renderStyle defaultStyle $
vcat (map dispPlanPackage (Foldable.toList graph))
- where dispPlanPackage p =
- hang (hsep [ text (showPlanPackageTag p)
- , pretty (packageId p)
- , parens (pretty (nodeKey p))]) 2
- (vcat (map pretty (nodeNeighbors p)))
-
-showInstallPlan :: (Package ipkg, Package srcpkg,
- IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg -> String
+ where
+ dispPlanPackage p =
+ hang
+ ( hsep
+ [ text (showPlanPackageTag p)
+ , pretty (packageId p)
+ , parens (pretty (nodeKey p))
+ ]
+ )
+ 2
+ (vcat (map pretty (nodeNeighbors p)))
+
+showInstallPlan
+ :: ( Package ipkg
+ , Package srcpkg
+ , IsUnit ipkg
+ , IsUnit srcpkg
+ )
+ => GenericInstallPlan ipkg srcpkg
+ -> String
showInstallPlan = showPlanGraph . planGraph
showPlanPackageTag :: GenericPlanPackage ipkg srcpkg -> String
-showPlanPackageTag (PreExisting _) = "PreExisting"
-showPlanPackageTag (Configured _) = "Configured"
-showPlanPackageTag (Installed _) = "Installed"
+showPlanPackageTag (PreExisting _) = "PreExisting"
+showPlanPackageTag (Configured _) = "Configured"
+showPlanPackageTag (Installed _) = "Installed"
-- | Build an installation plan from a valid set of resolved packages.
---
-new :: (IsUnit ipkg, IsUnit srcpkg)
- => IndependentGoals
- -> Graph (GenericPlanPackage ipkg srcpkg)
- -> GenericInstallPlan ipkg srcpkg
+new
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => IndependentGoals
+ -> Graph (GenericPlanPackage ipkg srcpkg)
+ -> GenericInstallPlan ipkg srcpkg
new indepGoals graph = mkInstallPlan "new" graph indepGoals
-toGraph :: GenericInstallPlan ipkg srcpkg
- -> Graph (GenericPlanPackage ipkg srcpkg)
+toGraph
+ :: GenericInstallPlan ipkg srcpkg
+ -> Graph (GenericPlanPackage ipkg srcpkg)
toGraph = planGraph
-toList :: GenericInstallPlan ipkg srcpkg
- -> [GenericPlanPackage ipkg srcpkg]
+toList
+ :: GenericInstallPlan ipkg srcpkg
+ -> [GenericPlanPackage ipkg srcpkg]
toList = Foldable.toList . planGraph
-toMap :: GenericInstallPlan ipkg srcpkg
- -> Map UnitId (GenericPlanPackage ipkg srcpkg)
+toMap
+ :: GenericInstallPlan ipkg srcpkg
+ -> Map UnitId (GenericPlanPackage ipkg srcpkg)
toMap = Graph.toMap . planGraph
keys :: GenericInstallPlan ipkg srcpkg -> [UnitId]
@@ -330,70 +388,74 @@ keysSet = Graph.keysSet . planGraph
-- package. This is primarily useful for obtaining an install plan for
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
---
-remove :: (IsUnit ipkg, IsUnit srcpkg)
- => (GenericPlanPackage ipkg srcpkg -> Bool)
- -> GenericInstallPlan ipkg srcpkg
- -> GenericInstallPlan ipkg srcpkg
+remove
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => (GenericPlanPackage ipkg srcpkg -> Bool)
+ -> GenericInstallPlan ipkg srcpkg
+ -> GenericInstallPlan ipkg srcpkg
remove shouldRemove plan =
- mkInstallPlan "remove" newGraph (planIndepGoals plan)
+ mkInstallPlan "remove" newGraph (planIndepGoals plan)
where
- newGraph = Graph.fromDistinctList $
- filter (not . shouldRemove) (toList plan)
+ newGraph =
+ Graph.fromDistinctList $
+ filter (not . shouldRemove) (toList plan)
-- | Change a number of packages in the 'Configured' state to the 'Installed'
-- state.
--
-- To preserve invariants, the package must have all of its dependencies
-- already installed too (that is 'PreExisting' or 'Installed').
---
-installed :: (IsUnit ipkg, IsUnit srcpkg)
- => (srcpkg -> Bool)
- -> GenericInstallPlan ipkg srcpkg
- -> GenericInstallPlan ipkg srcpkg
+installed
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => (srcpkg -> Bool)
+ -> GenericInstallPlan ipkg srcpkg
+ -> GenericInstallPlan ipkg srcpkg
installed shouldBeInstalled installPlan =
- foldl' markInstalled installPlan
- [ pkg
- | Configured pkg <- reverseTopologicalOrder installPlan
- , shouldBeInstalled pkg ]
+ foldl'
+ markInstalled
+ installPlan
+ [ pkg
+ | Configured pkg <- reverseTopologicalOrder installPlan
+ , shouldBeInstalled pkg
+ ]
where
markInstalled plan pkg =
assert (all isInstalled (directDeps plan (nodeKey pkg))) $
- plan {
- planGraph = Graph.insert (Installed pkg) (planGraph plan)
- }
+ plan
+ { planGraph = Graph.insert (Installed pkg) (planGraph plan)
+ }
-- | Lookup a package in the plan.
---
-lookup :: (IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg
- -> UnitId
- -> Maybe (GenericPlanPackage ipkg srcpkg)
+lookup
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => GenericInstallPlan ipkg srcpkg
+ -> UnitId
+ -> Maybe (GenericPlanPackage ipkg srcpkg)
lookup plan pkgid = Graph.lookup pkgid (planGraph plan)
-- | Find all the direct dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
---
-directDeps :: GenericInstallPlan ipkg srcpkg
- -> UnitId
- -> [GenericPlanPackage ipkg srcpkg]
+directDeps
+ :: GenericInstallPlan ipkg srcpkg
+ -> UnitId
+ -> [GenericPlanPackage ipkg srcpkg]
directDeps plan pkgid =
case Graph.neighbors (planGraph plan) pkgid of
Just deps -> deps
- Nothing -> internalError "directDeps" "package not in graph"
+ Nothing -> internalError "directDeps" "package not in graph"
-- | Find all the direct reverse dependencies of the given package.
--
-- Note that the package must exist in the plan or it is an error.
---
-revDirectDeps :: GenericInstallPlan ipkg srcpkg
- -> UnitId
- -> [GenericPlanPackage ipkg srcpkg]
+revDirectDeps
+ :: GenericInstallPlan ipkg srcpkg
+ -> UnitId
+ -> [GenericPlanPackage ipkg srcpkg]
revDirectDeps plan pkgid =
case Graph.revNeighbors (planGraph plan) pkgid of
Just deps -> deps
- Nothing -> internalError "revDirectDeps" "package not in graph"
+ Nothing -> internalError "revDirectDeps" "package not in graph"
-- | Return all the packages in the 'InstallPlan' in reverse topological order.
-- That is, for each package, all dependencies of the package appear first.
@@ -402,30 +464,30 @@ revDirectDeps plan pkgid =
-- source packages rather than just the source ones. Also, while both this
-- and 'executionOrder' produce reverse topological orderings of the package
-- dependency graph, it is not necessarily exactly the same order.
---
-reverseTopologicalOrder :: GenericInstallPlan ipkg srcpkg
- -> [GenericPlanPackage ipkg srcpkg]
+reverseTopologicalOrder
+ :: GenericInstallPlan ipkg srcpkg
+ -> [GenericPlanPackage ipkg srcpkg]
reverseTopologicalOrder plan = Graph.revTopSort (planGraph plan)
-
-- | Return the packages in the plan that are direct or indirect dependencies of
-- the given packages.
---
-dependencyClosure :: GenericInstallPlan ipkg srcpkg
- -> [UnitId]
- -> [GenericPlanPackage ipkg srcpkg]
-dependencyClosure plan = fromMaybe []
- . Graph.closure (planGraph plan)
+dependencyClosure
+ :: GenericInstallPlan ipkg srcpkg
+ -> [UnitId]
+ -> [GenericPlanPackage ipkg srcpkg]
+dependencyClosure plan =
+ fromMaybe []
+ . Graph.closure (planGraph plan)
-- | Return the packages in the plan that depend directly or indirectly on the
-- given packages.
---
-reverseDependencyClosure :: GenericInstallPlan ipkg srcpkg
- -> [UnitId]
- -> [GenericPlanPackage ipkg srcpkg]
-reverseDependencyClosure plan = fromMaybe []
- . Graph.revClosure (planGraph plan)
-
+reverseDependencyClosure
+ :: GenericInstallPlan ipkg srcpkg
+ -> [UnitId]
+ -> [GenericPlanPackage ipkg srcpkg]
+reverseDependencyClosure plan =
+ fromMaybe []
+ . Graph.revClosure (planGraph plan)
-- Alert alert! Why does SolverId map to a LIST of plan packages?
-- The sordid story has to do with 'build-depends' on a package
@@ -440,112 +502,131 @@ reverseDependencyClosure plan = fromMaybe []
-- etc). This similarly implies we can't return a 'ConfiguredId'
-- because that's not enough information.
-fromSolverInstallPlan ::
- (IsUnit ipkg, IsUnit srcpkg)
- => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
- -> SolverInstallPlan.SolverPlanPackage
- -> [GenericPlanPackage ipkg srcpkg] )
- -> SolverInstallPlan
- -> GenericInstallPlan ipkg srcpkg
+fromSolverInstallPlan
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
+ -> SolverInstallPlan.SolverPlanPackage
+ -> [GenericPlanPackage ipkg srcpkg]
+ )
+ -> SolverInstallPlan
+ -> GenericInstallPlan ipkg srcpkg
fromSolverInstallPlan f plan =
- mkInstallPlan "fromSolverInstallPlan"
- (Graph.fromDistinctList pkgs'')
- (SolverInstallPlan.planIndepGoals plan)
+ mkInstallPlan
+ "fromSolverInstallPlan"
+ (Graph.fromDistinctList pkgs'')
+ (SolverInstallPlan.planIndepGoals plan)
where
- (_, _, pkgs'') = foldl' f' (Map.empty, Map.empty, [])
- (SolverInstallPlan.reverseTopologicalOrder plan)
+ (_, _, pkgs'') =
+ foldl'
+ f'
+ (Map.empty, Map.empty, [])
+ (SolverInstallPlan.reverseTopologicalOrder plan)
f' (pidMap, ipiMap, pkgs) pkg = (pidMap', ipiMap', pkgs' ++ pkgs)
where
- pkgs' = f (mapDep pidMap ipiMap) pkg
+ pkgs' = f (mapDep pidMap ipiMap) pkg
- (pidMap', ipiMap')
- = case nodeKey pkg of
+ (pidMap', ipiMap') =
+ case nodeKey pkg of
PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
- PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
+ PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
mapDep _ ipiMap (PreExistingId _pid uid)
- | Just pkgs <- Map.lookup uid ipiMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
+ | Just pkgs <- Map.lookup uid ipiMap = pkgs
+ | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
mapDep pidMap _ (PlannedId pid)
- | Just pkgs <- Map.lookup pid pidMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
- -- This shouldn't happen, since mapDep should only be called
- -- on neighbor SolverId, which must have all been done already
- -- by the reverse top-sort (we assume the graph is not broken).
-
-
-fromSolverInstallPlanWithProgress ::
- (IsUnit ipkg, IsUnit srcpkg)
- => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
- -> SolverInstallPlan.SolverPlanPackage
- -> LogProgress [GenericPlanPackage ipkg srcpkg] )
- -> SolverInstallPlan
- -> LogProgress (GenericInstallPlan ipkg srcpkg)
+ | Just pkgs <- Map.lookup pid pidMap = pkgs
+ | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
+
+-- This shouldn't happen, since mapDep should only be called
+-- on neighbor SolverId, which must have all been done already
+-- by the reverse top-sort (we assume the graph is not broken).
+
+fromSolverInstallPlanWithProgress
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => ( (SolverId -> [GenericPlanPackage ipkg srcpkg])
+ -> SolverInstallPlan.SolverPlanPackage
+ -> LogProgress [GenericPlanPackage ipkg srcpkg]
+ )
+ -> SolverInstallPlan
+ -> LogProgress (GenericInstallPlan ipkg srcpkg)
fromSolverInstallPlanWithProgress f plan = do
- (_, _, pkgs'') <- foldM f' (Map.empty, Map.empty, [])
- (SolverInstallPlan.reverseTopologicalOrder plan)
- return $ mkInstallPlan "fromSolverInstallPlanWithProgress"
- (Graph.fromDistinctList pkgs'')
- (SolverInstallPlan.planIndepGoals plan)
+ (_, _, pkgs'') <-
+ foldM
+ f'
+ (Map.empty, Map.empty, [])
+ (SolverInstallPlan.reverseTopologicalOrder plan)
+ return $
+ mkInstallPlan
+ "fromSolverInstallPlanWithProgress"
+ (Graph.fromDistinctList pkgs'')
+ (SolverInstallPlan.planIndepGoals plan)
where
f' (pidMap, ipiMap, pkgs) pkg = do
- pkgs' <- f (mapDep pidMap ipiMap) pkg
- let (pidMap', ipiMap')
- = case nodeKey pkg of
- PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
- PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
- return (pidMap', ipiMap', pkgs' ++ pkgs)
+ pkgs' <- f (mapDep pidMap ipiMap) pkg
+ let (pidMap', ipiMap') =
+ case nodeKey pkg of
+ PreExistingId _ uid -> (pidMap, Map.insert uid pkgs' ipiMap)
+ PlannedId pid -> (Map.insert pid pkgs' pidMap, ipiMap)
+ return (pidMap', ipiMap', pkgs' ++ pkgs)
mapDep _ ipiMap (PreExistingId _pid uid)
- | Just pkgs <- Map.lookup uid ipiMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
+ | Just pkgs <- Map.lookup uid ipiMap = pkgs
+ | otherwise = error ("fromSolverInstallPlan: PreExistingId " ++ prettyShow uid)
mapDep pidMap _ (PlannedId pid)
- | Just pkgs <- Map.lookup pid pidMap = pkgs
- | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
- -- This shouldn't happen, since mapDep should only be called
- -- on neighbor SolverId, which must have all been done already
- -- by the reverse top-sort (we assume the graph is not broken).
+ | Just pkgs <- Map.lookup pid pidMap = pkgs
+ | otherwise = error ("fromSolverInstallPlan: PlannedId " ++ prettyShow pid)
+
+-- This shouldn't happen, since mapDep should only be called
+-- on neighbor SolverId, which must have all been done already
+-- by the reverse top-sort (we assume the graph is not broken).
-- | Conversion of 'SolverInstallPlan' to 'InstallPlan'.
-- Similar to 'elaboratedInstallPlan'
configureInstallPlan :: Cabal.ConfigFlags -> SolverInstallPlan -> InstallPlan
configureInstallPlan configFlags solverPlan =
- flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
- [case planpkg of
+ flip fromSolverInstallPlan solverPlan $ \mapDep planpkg ->
+ [ case planpkg of
SolverInstallPlan.PreExisting pkg ->
PreExisting (instSolverPkgIPI pkg)
-
- SolverInstallPlan.Configured pkg ->
+ SolverInstallPlan.Configured pkg ->
Configured (configureSolverPackage mapDep pkg)
- ]
+ ]
where
- configureSolverPackage :: (SolverId -> [PlanPackage])
- -> SolverPackage UnresolvedPkgLoc
- -> ConfiguredPackage UnresolvedPkgLoc
+ configureSolverPackage
+ :: (SolverId -> [PlanPackage])
+ -> SolverPackage UnresolvedPkgLoc
+ -> ConfiguredPackage UnresolvedPkgLoc
configureSolverPackage mapDep spkg =
- ConfiguredPackage {
- confPkgId = Configure.computeComponentId
- (Cabal.fromFlagOrDefault False
- (Cabal.configDeterministic configFlags))
- Cabal.NoFlag
- Cabal.NoFlag
- (packageId spkg)
- (PD.CLibName PD.LMainLibName)
- (Just (map confInstId (CD.libraryDeps deps),
- solverPkgFlags spkg)),
- confPkgSource = solverPkgSource spkg,
- confPkgFlags = solverPkgFlags spkg,
- confPkgStanzas = solverPkgStanzas spkg,
- confPkgDeps = deps
+ ConfiguredPackage
+ { confPkgId =
+ Configure.computeComponentId
+ ( Cabal.fromFlagOrDefault
+ False
+ (Cabal.configDeterministic configFlags)
+ )
+ Cabal.NoFlag
+ Cabal.NoFlag
+ (packageId spkg)
+ (PD.CLibName PD.LMainLibName)
+ ( Just
+ ( map confInstId (CD.libraryDeps deps)
+ , solverPkgFlags spkg
+ )
+ )
+ , confPkgSource = solverPkgSource spkg
+ , confPkgFlags = solverPkgFlags spkg
+ , confPkgStanzas = solverPkgStanzas spkg
+ , confPkgDeps = deps
-- NB: no support for executable dependencies
- }
+ }
where
deps = fmap (concatMap (map configuredId . mapDep)) (solverPkgLibDeps spkg)
-
-- ------------------------------------------------------------
+
-- * Primitives for traversing plans
+
-- ------------------------------------------------------------
-- $traversal
@@ -580,14 +661,13 @@ configureInstallPlan configFlags solverPlan =
-- other packages that depend on the failed package. In addition it returns
-- the other failed packages.
-
-- | The 'Processing' type is used to keep track of the state of a traversal
-- and includes the set of packages that are in the processing state, e.g. in
-- the process of being installed, plus those that have been completed and
-- those where processing failed.
---
data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
- -- processing, completed, failed
+
+-- processing, completed, failed
-- | The packages in the plan that are initially ready to be installed.
-- That is they are in the configured state and have all their dependencies
@@ -597,18 +677,18 @@ data Processing = Processing !(Set UnitId) !(Set UnitId) !(Set UnitId)
-- a 'Processing' state containing those same packages. The assumption is that
-- all the packages that are ready will now be processed and so we can consider
-- them to be in the processing state.
---
-ready :: (IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg
- -> ([GenericReadyPackage srcpkg], Processing)
+ready
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => GenericInstallPlan ipkg srcpkg
+ -> ([GenericReadyPackage srcpkg], Processing)
ready plan =
- assert (processingInvariant plan processing) $
+ assert (processingInvariant plan processing) $
(readyPackages, processing)
where
!processing =
Processing
- (Set.fromList [ nodeKey pkg | pkg <- readyPackages ])
- (Set.fromList [ nodeKey pkg | pkg <- toList plan, isInstalled pkg ])
+ (Set.fromList [nodeKey pkg | pkg <- readyPackages])
+ (Set.fromList [nodeKey pkg | pkg <- toList plan, isInstalled pkg])
Set.empty
readyPackages =
[ ReadyPackage pkg
@@ -617,88 +697,98 @@ ready plan =
]
isInstalled :: GenericPlanPackage a b -> Bool
-isInstalled (PreExisting {}) = True
-isInstalled (Installed {}) = True
-isInstalled _ = False
+isInstalled (PreExisting{}) = True
+isInstalled (Installed{}) = True
+isInstalled _ = False
-- | Given a package in the processing state, mark the package as completed
-- and return any packages that are newly in the processing state (ie ready to
-- process), along with the updated 'Processing' state.
---
-completed :: forall ipkg srcpkg. (IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg
- -> Processing -> UnitId
- -> ([GenericReadyPackage srcpkg], Processing)
+completed
+ :: forall ipkg srcpkg
+ . (IsUnit ipkg, IsUnit srcpkg)
+ => GenericInstallPlan ipkg srcpkg
+ -> Processing
+ -> UnitId
+ -> ([GenericReadyPackage srcpkg], Processing)
completed plan (Processing processingSet completedSet failedSet) pkgid =
- assert (pkgid `Set.member` processingSet) $
+ assert (pkgid `Set.member` processingSet) $
assert (processingInvariant plan processing') $
-
- ( map asReadyPackage newlyReady
- , processing' )
+ ( map asReadyPackage newlyReady
+ , processing'
+ )
where
- completedSet' = Set.insert pkgid completedSet
+ completedSet' = Set.insert pkgid completedSet
-- each direct reverse dep where all direct deps are completed
- newlyReady = [ dep
- | dep <- revDirectDeps plan pkgid
- , all ((`Set.member` completedSet') . nodeKey)
- (directDeps plan (nodeKey dep))
- ]
+ newlyReady =
+ [ dep
+ | dep <- revDirectDeps plan pkgid
+ , all
+ ((`Set.member` completedSet') . nodeKey)
+ (directDeps plan (nodeKey dep))
+ ]
- processingSet' = foldl' (flip Set.insert)
- (Set.delete pkgid processingSet)
- (map nodeKey newlyReady)
- processing' = Processing processingSet' completedSet' failedSet
+ processingSet' =
+ foldl'
+ (flip Set.insert)
+ (Set.delete pkgid processingSet)
+ (map nodeKey newlyReady)
+ processing' = Processing processingSet' completedSet' failedSet
asReadyPackage :: GenericPlanPackage ipkg srcpkg -> GenericReadyPackage srcpkg
- asReadyPackage (Configured pkg) = ReadyPackage pkg
+ asReadyPackage (Configured pkg) = ReadyPackage pkg
asReadyPackage pkg = internalError "completed" $ "not in configured state: " ++ displayGenericPlanPackage pkg
-failed :: (IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg
- -> Processing -> UnitId
- -> ([srcpkg], Processing)
+failed
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => GenericInstallPlan ipkg srcpkg
+ -> Processing
+ -> UnitId
+ -> ([srcpkg], Processing)
failed plan (Processing processingSet completedSet failedSet) pkgid =
- assert (pkgid `Set.member` processingSet) $
+ assert (pkgid `Set.member` processingSet) $
assert (all (`Set.notMember` processingSet) (tail newlyFailedIds)) $
- assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $
- -- but note that some newlyFailed may already be in the failed set
- -- since one package can depend on two packages that both fail and
- -- so would be in the rev-dep closure for both.
- assert (processingInvariant plan processing') $
-
- ( map asConfiguredPackage (tail newlyFailed)
- , processing' )
+ assert (all (`Set.notMember` completedSet) (tail newlyFailedIds)) $
+ -- but note that some newlyFailed may already be in the failed set
+ -- since one package can depend on two packages that both fail and
+ -- so would be in the rev-dep closure for both.
+ assert (processingInvariant plan processing') $
+ ( map asConfiguredPackage (tail newlyFailed)
+ , processing'
+ )
where
processingSet' = Set.delete pkgid processingSet
- failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds
+ failedSet' = failedSet `Set.union` Set.fromList newlyFailedIds
newlyFailedIds = map nodeKey newlyFailed
- newlyFailed = fromMaybe (internalError "failed" "package not in graph")
- $ Graph.revClosure (planGraph plan) [pkgid]
- processing' = Processing processingSet' completedSet failedSet'
+ newlyFailed =
+ fromMaybe (internalError "failed" "package not in graph") $
+ Graph.revClosure (planGraph plan) [pkgid]
+ processing' = Processing processingSet' completedSet failedSet'
asConfiguredPackage (Configured pkg) = pkg
asConfiguredPackage pkg = internalError "failed" $ "not in configured state: " ++ displayGenericPlanPackage pkg
-processingInvariant :: (IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg
- -> Processing -> Bool
+processingInvariant
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => GenericInstallPlan ipkg srcpkg
+ -> Processing
+ -> Bool
processingInvariant plan (Processing processingSet completedSet failedSet) =
-
- -- All the packages in the three sets are actually in the graph
- assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet) $
- assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet) $
- assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet) $
-
+ -- All the packages in the three sets are actually in the graph
+ assert (Foldable.all (flip Graph.member (planGraph plan)) processingSet)
+ $ assert (Foldable.all (flip Graph.member (planGraph plan)) completedSet)
+ $ assert (Foldable.all (flip Graph.member (planGraph plan)) failedSet)
+ $
-- The processing, completed and failed sets are disjoint from each other
- assert (noIntersection processingSet completedSet) $
- assert (noIntersection processingSet failedSet) $
- assert (noIntersection failedSet completedSet) $
-
+ assert (noIntersection processingSet completedSet)
+ $ assert (noIntersection processingSet failedSet)
+ $ assert (noIntersection failedSet completedSet)
+ $
-- Packages that depend on a package that's still processing cannot be
-- completed
- assert (noIntersection (reverseClosure processingSet) completedSet) $
-
+ assert (noIntersection (reverseClosure processingSet) completedSet)
+ $
-- On the other hand, packages that depend on a package that's still
-- processing /can/ have failed (since they may have depended on multiple
-- packages that were processing, but it only takes one to fail to cause
@@ -706,40 +796,50 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
-- intersection (reverseClosure processingSet) failedSet
-- The failed set is upwards closed, i.e. equal to its own rev dep closure
- assert (failedSet == reverseClosure failedSet) $
-
+ assert (failedSet == reverseClosure failedSet)
+ $
-- All immediate reverse deps of packages that are currently processing
-- are not currently being processed (ie not in the processing set).
- assert (and [ rdeppkgid `Set.notMember` processingSet
- | pkgid <- Set.toList processingSet
- , rdeppkgid <- maybe (internalError "processingInvariant" "")
- (map nodeKey)
- (Graph.revNeighbors (planGraph plan) pkgid)
- ]) $
-
+ assert
+ ( and
+ [ rdeppkgid `Set.notMember` processingSet
+ | pkgid <- Set.toList processingSet
+ , rdeppkgid <-
+ maybe
+ (internalError "processingInvariant" "")
+ (map nodeKey)
+ (Graph.revNeighbors (planGraph plan) pkgid)
+ ]
+ )
+ $
-- Packages from the processing or failed sets are only ever in the
-- configured state.
- assert (and [ case Graph.lookup pkgid (planGraph plan) of
- Just (Configured _) -> True
- Just (PreExisting _) -> False
- Just (Installed _) -> False
- Nothing -> False
- | pkgid <- Set.toList processingSet ++ Set.toList failedSet ])
-
- -- We use asserts rather than returning False so that on failure we get
- -- better details on which bit of the invariant was violated.
- True
+ assert
+ ( and
+ [ case Graph.lookup pkgid (planGraph plan) of
+ Just (Configured _) -> True
+ Just (PreExisting _) -> False
+ Just (Installed _) -> False
+ Nothing -> False
+ | pkgid <- Set.toList processingSet ++ Set.toList failedSet
+ ]
+ )
+ -- We use asserts rather than returning False so that on failure we get
+ -- better details on which bit of the invariant was violated.
+ True
where
- reverseClosure = Set.fromList
- . map nodeKey
- . fromMaybe (internalError "processingInvariant" "")
- . Graph.revClosure (planGraph plan)
- . Set.toList
+ reverseClosure =
+ Set.fromList
+ . map nodeKey
+ . fromMaybe (internalError "processingInvariant" "")
+ . Graph.revClosure (planGraph plan)
+ . Set.toList
noIntersection a b = Set.null (Set.intersection a b)
-
-- ------------------------------------------------------------
+
-- * Traversing plans
+
-- ------------------------------------------------------------
-- | Flatten an 'InstallPlan', producing the sequence of source packages in
@@ -750,36 +850,37 @@ processingInvariant plan (Processing processingSet completedSet failedSet) =
-- in-order 'JobControl'), which is a reverse topological orderings of the
-- source packages in the dependency graph, albeit not necessarily exactly the
-- same ordering as that produced by 'reverseTopologicalOrder'.
---
-executionOrder :: (IsUnit ipkg, IsUnit srcpkg)
- => GenericInstallPlan ipkg srcpkg
- -> [GenericReadyPackage srcpkg]
+executionOrder
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => GenericInstallPlan ipkg srcpkg
+ -> [GenericReadyPackage srcpkg]
executionOrder plan =
- let (newpkgs, processing) = ready plan
- in tryNewTasks processing newpkgs
+ let (newpkgs, processing) = ready plan
+ in tryNewTasks processing newpkgs
where
- tryNewTasks _processing [] = []
- tryNewTasks processing (p:todo) = waitForTasks processing p todo
+ tryNewTasks _processing [] = []
+ tryNewTasks processing (p : todo) = waitForTasks processing p todo
waitForTasks processing p todo =
- p : tryNewTasks processing' (todo++nextpkgs)
+ p : tryNewTasks processing' (todo ++ nextpkgs)
where
(nextpkgs, processing') = completed plan processing (nodeKey p)
-
-- ------------------------------------------------------------
+
-- * Executing plans
+
-- ------------------------------------------------------------
-- | The set of results we get from executing an install plan.
---
type BuildOutcomes failure result = Map UnitId (Either failure result)
-- | Lookup the build result for a single package.
---
-lookupBuildOutcome :: HasUnitId pkg
- => pkg -> BuildOutcomes failure result
- -> Maybe (Either failure result)
+lookupBuildOutcome
+ :: HasUnitId pkg
+ => pkg
+ -> BuildOutcomes failure result
+ -> Maybe (Either failure result)
lookupBuildOutcome = Map.lookup . installedUnitId
-- | Execute an install plan. This traverses the plan in dependency order.
@@ -796,162 +897,188 @@ lookupBuildOutcome = Map.lookup . installedUnitId
-- in the plan. In particular in the default mode where we stop as soon as
-- possible after a failure then there may be packages which are skipped and
-- these will have no 'BuildOutcome'.
---
-execute :: forall m ipkg srcpkg result failure.
- (IsUnit ipkg, IsUnit srcpkg,
- Monad m)
- => JobControl m (UnitId, Either failure result)
- -> Bool -- ^ Keep going after failure
- -> (srcpkg -> failure) -- ^ Value for dependents of failed packages
- -> GenericInstallPlan ipkg srcpkg
- -> (GenericReadyPackage srcpkg -> m (Either failure result))
- -> m (BuildOutcomes failure result)
+execute
+ :: forall m ipkg srcpkg result failure
+ . ( IsUnit ipkg
+ , IsUnit srcpkg
+ , Monad m
+ )
+ => JobControl m (UnitId, Either failure result)
+ -> Bool
+ -- ^ Keep going after failure
+ -> (srcpkg -> failure)
+ -- ^ Value for dependents of failed packages
+ -> GenericInstallPlan ipkg srcpkg
+ -> (GenericReadyPackage srcpkg -> m (Either failure result))
+ -> m (BuildOutcomes failure result)
execute jobCtl keepGoing depFailure plan installPkg =
- let (newpkgs, processing) = ready plan
- in tryNewTasks Map.empty False False processing newpkgs
+ let (newpkgs, processing) = ready plan
+ in tryNewTasks Map.empty False False processing newpkgs
where
- tryNewTasks :: BuildOutcomes failure result
- -> Bool -> Bool -> Processing
- -> [GenericReadyPackage srcpkg]
- -> m (BuildOutcomes failure result)
+ tryNewTasks
+ :: BuildOutcomes failure result
+ -> Bool
+ -> Bool
+ -> Processing
+ -> [GenericReadyPackage srcpkg]
+ -> m (BuildOutcomes failure result)
tryNewTasks !results tasksFailed tasksRemaining !processing newpkgs
-- we were in the process of cancelling and now we're finished
- | tasksFailed && not keepGoing && not tasksRemaining
- = return results
-
+ | tasksFailed && not keepGoing && not tasksRemaining =
+ return results
-- we are still in the process of cancelling, wait for remaining tasks
- | tasksFailed && not keepGoing && tasksRemaining
- = waitForTasks results tasksFailed processing
-
+ | tasksFailed && not keepGoing && tasksRemaining =
+ waitForTasks results tasksFailed processing
-- no new tasks to do and all tasks are done so we're finished
- | null newpkgs && not tasksRemaining
- = return results
-
+ | null newpkgs && not tasksRemaining =
+ return results
-- no new tasks to do, remaining tasks to wait for
- | null newpkgs
- = waitForTasks results tasksFailed processing
-
+ | null newpkgs =
+ waitForTasks results tasksFailed processing
-- new tasks to do, spawn them, then wait for tasks to complete
- | otherwise
- = do sequence_ [ spawnJob jobCtl $ do
- result <- installPkg pkg
- return (nodeKey pkg, result)
- | pkg <- newpkgs ]
- waitForTasks results tasksFailed processing
-
- waitForTasks :: BuildOutcomes failure result
- -> Bool -> Processing
- -> m (BuildOutcomes failure result)
+ | otherwise =
+ do
+ sequence_
+ [ spawnJob jobCtl $ do
+ result <- installPkg pkg
+ return (nodeKey pkg, result)
+ | pkg <- newpkgs
+ ]
+ waitForTasks results tasksFailed processing
+
+ waitForTasks
+ :: BuildOutcomes failure result
+ -> Bool
+ -> Processing
+ -> m (BuildOutcomes failure result)
waitForTasks !results tasksFailed !processing = do
(pkgid, result) <- collectJob jobCtl
case result of
-
Right _success -> do
- tasksRemaining <- remainingJobs jobCtl
- tryNewTasks results' tasksFailed tasksRemaining
- processing' nextpkgs
+ tasksRemaining <- remainingJobs jobCtl
+ tryNewTasks
+ results'
+ tasksFailed
+ tasksRemaining
+ processing'
+ nextpkgs
where
results' = Map.insert pkgid result results
(nextpkgs, processing') = completed plan processing pkgid
-
Left _failure -> do
- -- if this is the first failure and we're not trying to keep going
- -- then try to cancel as many of the remaining jobs as possible
- when (not tasksFailed && not keepGoing) $
- cancelJobs jobCtl
+ -- if this is the first failure and we're not trying to keep going
+ -- then try to cancel as many of the remaining jobs as possible
+ when (not tasksFailed && not keepGoing) $
+ cancelJobs jobCtl
- tasksRemaining <- remainingJobs jobCtl
- tryNewTasks results' True tasksRemaining processing' []
+ tasksRemaining <- remainingJobs jobCtl
+ tryNewTasks results' True tasksRemaining processing' []
where
(depsfailed, processing') = failed plan processing pkgid
- results' = Map.insert pkgid result results `Map.union` depResults
- depResults = Map.fromList
- [ (nodeKey deppkg, Left (depFailure deppkg))
- | deppkg <- depsfailed ]
+ results' = Map.insert pkgid result results `Map.union` depResults
+ depResults =
+ Map.fromList
+ [ (nodeKey deppkg, Left (depFailure deppkg))
+ | deppkg <- depsfailed
+ ]
-- ------------------------------------------------------------
+
-- * Checking validity of plans
+
-- ------------------------------------------------------------
-- | A valid installation plan is a set of packages that is closed, acyclic
-- and respects the package state relation.
--
-- * if the result is @False@ use 'problems' to get a detailed list.
---
-valid :: (IsUnit ipkg, IsUnit srcpkg)
- => String -> Graph (GenericPlanPackage ipkg srcpkg) -> Bool
+valid
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => String
+ -> Graph (GenericPlanPackage ipkg srcpkg)
+ -> Bool
valid loc graph =
- case problems graph of
- [] -> True
- ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
-
-data PlanProblem ipkg srcpkg =
- PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
- | PackageCycle [GenericPlanPackage ipkg srcpkg]
- | PackageStateInvalid (GenericPlanPackage ipkg srcpkg)
- (GenericPlanPackage ipkg srcpkg)
-
-showPlanProblem :: (IsUnit ipkg, IsUnit srcpkg)
- => PlanProblem ipkg srcpkg -> String
+ case problems graph of
+ [] -> True
+ ps -> internalError loc ('\n' : unlines (map showPlanProblem ps))
+
+data PlanProblem ipkg srcpkg
+ = PackageMissingDeps (GenericPlanPackage ipkg srcpkg) [UnitId]
+ | PackageCycle [GenericPlanPackage ipkg srcpkg]
+ | PackageStateInvalid
+ (GenericPlanPackage ipkg srcpkg)
+ (GenericPlanPackage ipkg srcpkg)
+
+showPlanProblem
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => PlanProblem ipkg srcpkg
+ -> String
showPlanProblem (PackageMissingDeps pkg missingDeps) =
- "Package " ++ prettyShow (nodeKey pkg)
- ++ " depends on the following packages which are missing from the plan: "
- ++ intercalate ", " (map prettyShow missingDeps)
-
+ "Package "
+ ++ prettyShow (nodeKey pkg)
+ ++ " depends on the following packages which are missing from the plan: "
+ ++ intercalate ", " (map prettyShow missingDeps)
showPlanProblem (PackageCycle cycleGroup) =
- "The following packages are involved in a dependency cycle "
- ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)
+ "The following packages are involved in a dependency cycle "
+ ++ intercalate ", " (map (prettyShow . nodeKey) cycleGroup)
showPlanProblem (PackageStateInvalid pkg pkg') =
- "Package " ++ prettyShow (nodeKey pkg)
- ++ " is in the " ++ showPlanPackageTag pkg
- ++ " state but it depends on package " ++ prettyShow (nodeKey pkg')
- ++ " which is in the " ++ showPlanPackageTag pkg'
- ++ " state"
+ "Package "
+ ++ prettyShow (nodeKey pkg)
+ ++ " is in the "
+ ++ showPlanPackageTag pkg
+ ++ " state but it depends on package "
+ ++ prettyShow (nodeKey pkg')
+ ++ " which is in the "
+ ++ showPlanPackageTag pkg'
+ ++ " state"
-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
---
-problems :: (IsUnit ipkg, IsUnit srcpkg)
- => Graph (GenericPlanPackage ipkg srcpkg)
- -> [PlanProblem ipkg srcpkg]
+problems
+ :: (IsUnit ipkg, IsUnit srcpkg)
+ => Graph (GenericPlanPackage ipkg srcpkg)
+ -> [PlanProblem ipkg srcpkg]
problems graph =
-
- [ PackageMissingDeps pkg
- (mapMaybe
- (fmap nodeKey . flip Graph.lookup graph)
- missingDeps)
- | (pkg, missingDeps) <- Graph.broken graph ]
-
- ++ [ PackageCycle cycleGroup
- | cycleGroup <- Graph.cycles graph ]
-{-
- ++ [ PackageInconsistency name inconsistencies
- | (name, inconsistencies) <-
- dependencyInconsistencies indepGoals graph ]
- --TODO: consider re-enabling this one, see SolverInstallPlan
--}
- ++ [ PackageStateInvalid pkg pkg'
- | pkg <- Foldable.toList graph
- , Just pkg' <- map (flip Graph.lookup graph)
- (nodeNeighbors pkg)
- , not (stateDependencyRelation pkg pkg') ]
+ [ PackageMissingDeps
+ pkg
+ ( mapMaybe
+ (fmap nodeKey . flip Graph.lookup graph)
+ missingDeps
+ )
+ | (pkg, missingDeps) <- Graph.broken graph
+ ]
+ ++ [ PackageCycle cycleGroup
+ | cycleGroup <- Graph.cycles graph
+ ]
+ {-
+ ++ [ PackageInconsistency name inconsistencies
+ | (name, inconsistencies) <-
+ dependencyInconsistencies indepGoals graph ]
+ --TODO: consider re-enabling this one, see SolverInstallPlan
+ -}
+ ++ [ PackageStateInvalid pkg pkg'
+ | pkg <- Foldable.toList graph
+ , Just pkg' <-
+ map
+ (flip Graph.lookup graph)
+ (nodeNeighbors pkg)
+ , not (stateDependencyRelation pkg pkg')
+ ]
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @stateDependencyRelation a b = True@.
---
-stateDependencyRelation :: GenericPlanPackage ipkg srcpkg
- -> GenericPlanPackage ipkg srcpkg -> Bool
+stateDependencyRelation
+ :: GenericPlanPackage ipkg srcpkg
+ -> GenericPlanPackage ipkg srcpkg
+ -> Bool
stateDependencyRelation PreExisting{} PreExisting{} = True
-
-stateDependencyRelation Installed{} PreExisting{} = True
-stateDependencyRelation Installed{} Installed{} = True
-
-stateDependencyRelation Configured{} PreExisting{} = True
-stateDependencyRelation Configured{} Installed{} = True
-stateDependencyRelation Configured{} Configured{} = True
-
-stateDependencyRelation _ _ = False
+stateDependencyRelation Installed{} PreExisting{} = True
+stateDependencyRelation Installed{} Installed{} = True
+stateDependencyRelation Configured{} PreExisting{} = True
+stateDependencyRelation Configured{} Installed{} = True
+stateDependencyRelation Configured{} Configured{} = True
+stateDependencyRelation _ _ = False
diff --git a/cabal-install/src/Distribution/Client/InstallSymlink.hs b/cabal-install/src/Distribution/Client/InstallSymlink.hs
index 5acf00920027c416f3a4d8b86837d1a5d6186069..cf57c54818ee59d134fa3746bf15dba35da0301c 100644
--- a/cabal-install/src/Distribution/Client/InstallSymlink.hs
+++ b/cabal-install/src/Distribution/Client/InstallSymlink.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.InstallSymlink
-- Copyright : (c) Duncan Coutts 2008
@@ -11,60 +15,87 @@
-- Portability : portable
--
-- Managing installing binaries with symlinks.
------------------------------------------------------------------------------
-module Distribution.Client.InstallSymlink (
- symlinkBinaries,
- symlinkBinary,
- trySymlink,
- promptRun
+module Distribution.Client.InstallSymlink
+ ( symlinkBinaries
+ , symlinkBinary
+ , trySymlink
+ , promptRun
) where
import Distribution.Client.Compat.Prelude hiding (ioError)
import Prelude ()
-import Distribution.Client.Types
- ( ConfiguredPackage(..), BuildOutcomes )
-import Distribution.Client.Setup
- ( InstallFlags(installSymlinkBinDir) )
-import qualified Distribution.Client.InstallPlan as InstallPlan
import Distribution.Client.InstallPlan (InstallPlan)
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.Setup
+ ( InstallFlags (installSymlinkBinDir)
+ )
+import Distribution.Client.Types
+ ( BuildOutcomes
+ , ConfiguredPackage (..)
+ )
-import Distribution.Solver.Types.SourcePackage
import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.SourcePackage
-import Distribution.Package
- ( PackageIdentifier, Package(packageId), UnitId, installedUnitId )
-import Distribution.Types.UnqualComponentName
import Distribution.Compiler
- ( CompilerId(..) )
-import qualified Distribution.PackageDescription as PackageDescription
+ ( CompilerId (..)
+ )
+import Distribution.Package
+ ( Package (packageId)
+ , PackageIdentifier
+ , UnitId
+ , installedUnitId
+ )
import Distribution.PackageDescription
- ( PackageDescription )
+ ( PackageDescription
+ )
+import qualified Distribution.PackageDescription as PackageDescription
import Distribution.PackageDescription.Configuration
- ( finalizePD )
-import Distribution.Simple.Setup
- ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
-import qualified Distribution.Simple.InstallDirs as InstallDirs
+ ( finalizePD
+ )
import Distribution.Simple.Compiler
- ( Compiler, compilerInfo, CompilerInfo(..) )
+ ( Compiler
+ , CompilerInfo (..)
+ , compilerInfo
+ )
+import qualified Distribution.Simple.InstallDirs as InstallDirs
+import Distribution.Simple.Setup
+ ( ConfigFlags (..)
+ , flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ )
+import Distribution.Simple.Utils (info, withTempDirectory)
import Distribution.System
- ( Platform )
-import Distribution.Simple.Utils ( info, withTempDirectory )
+ ( Platform
+ )
+import Distribution.Types.UnqualComponentName
import System.Directory
- ( canonicalizePath, getTemporaryDirectory, removeFile )
+ ( canonicalizePath
+ , getTemporaryDirectory
+ , removeFile
+ )
import System.FilePath
- ( (</>), splitPath, joinPath, isAbsolute )
+ ( isAbsolute
+ , joinPath
+ , splitPath
+ , (</>)
+ )
-import System.IO.Error
- ( isDoesNotExistError, ioError )
import Control.Exception
- ( assert )
+ ( assert
+ )
+import System.IO.Error
+ ( ioError
+ , isDoesNotExistError
+ )
-import Distribution.Client.Compat.Directory ( createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink )
+import Distribution.Client.Compat.Directory (createFileLink, getSymbolicLinkTarget, pathIsSymbolicLink)
+import Distribution.Client.Init.Prompt (promptYesNo)
+import Distribution.Client.Init.Types (DefaultPrompt (MandatoryPrompt))
import Distribution.Client.Types.OverwritePolicy
-import Distribution.Client.Init.Types ( DefaultPrompt(MandatoryPrompt) )
-import Distribution.Client.Init.Prompt ( promptYesNo )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
@@ -88,117 +119,168 @@ import qualified Data.ByteString.Char8 as BS8
-- This is an optional feature that users can choose to use or not. It is
-- controlled from the config file. Of course it only works on POSIX systems
-- with symlinks so is not available to Windows users.
---
-symlinkBinaries :: Platform -> Compiler
- -> OverwritePolicy
- -> ConfigFlags
- -> InstallFlags
- -> InstallPlan
- -> BuildOutcomes
- -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
-symlinkBinaries platform comp overwritePolicy
- configFlags installFlags
- plan buildOutcomes =
- case flagToMaybe (installSymlinkBinDir installFlags) of
- Nothing -> return []
- Just symlinkBinDir
- | null exes -> return []
- | otherwise -> do
- publicBinDir <- canonicalizePath symlinkBinDir
--- TODO: do we want to do this here? :
--- createDirectoryIfMissing True publicBinDir
- fmap catMaybes $ sequenceA
- [ do privateBinDir <- pkgBinDir pkg ipid
- ok <- symlinkBinary
- overwritePolicy
- publicBinDir privateBinDir
- (prettyShow publicExeName) privateExeName
- if ok
- then return Nothing
- else return (Just (pkgid, publicExeName,
- privateBinDir </> privateExeName))
- | (rpkg, pkg, exe) <- exes
- , let pkgid = packageId pkg
- -- This is a bit dodgy; probably won't work for Backpack packages
- ipid = installedUnitId rpkg
- publicExeName = PackageDescription.exeName exe
- privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix
- prefix = substTemplate pkgid ipid prefixTemplate
- suffix = substTemplate pkgid ipid suffixTemplate ]
- where
- exes =
- [ (cpkg, pkg, exe)
- | InstallPlan.Configured cpkg <- InstallPlan.toList plan
- , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of
- Just (Right _success) -> True
- _ -> False
- , let pkg :: PackageDescription
- pkg = pkgDescription cpkg
- , exe <- PackageDescription.executables pkg
- , PackageDescription.buildable (PackageDescription.buildInfo exe) ]
+symlinkBinaries
+ :: Platform
+ -> Compiler
+ -> OverwritePolicy
+ -> ConfigFlags
+ -> InstallFlags
+ -> InstallPlan
+ -> BuildOutcomes
+ -> IO [(PackageIdentifier, UnqualComponentName, FilePath)]
+symlinkBinaries
+ platform
+ comp
+ overwritePolicy
+ configFlags
+ installFlags
+ plan
+ buildOutcomes =
+ case flagToMaybe (installSymlinkBinDir installFlags) of
+ Nothing -> return []
+ Just symlinkBinDir
+ | null exes -> return []
+ | otherwise -> do
+ publicBinDir <- canonicalizePath symlinkBinDir
+ -- TODO: do we want to do this here? :
+ -- createDirectoryIfMissing True publicBinDir
+ fmap catMaybes $
+ sequenceA
+ [ do
+ privateBinDir <- pkgBinDir pkg ipid
+ ok <-
+ symlinkBinary
+ overwritePolicy
+ publicBinDir
+ privateBinDir
+ (prettyShow publicExeName)
+ privateExeName
+ if ok
+ then return Nothing
+ else
+ return
+ ( Just
+ ( pkgid
+ , publicExeName
+ , privateBinDir </> privateExeName
+ )
+ )
+ | (rpkg, pkg, exe) <- exes
+ , let pkgid = packageId pkg
+ -- This is a bit dodgy; probably won't work for Backpack packages
+ ipid = installedUnitId rpkg
+ publicExeName = PackageDescription.exeName exe
+ privateExeName = prefix ++ unUnqualComponentName publicExeName ++ suffix
+ prefix = substTemplate pkgid ipid prefixTemplate
+ suffix = substTemplate pkgid ipid suffixTemplate
+ ]
+ where
+ exes =
+ [ (cpkg, pkg, exe)
+ | InstallPlan.Configured cpkg <- InstallPlan.toList plan
+ , case InstallPlan.lookupBuildOutcome cpkg buildOutcomes of
+ Just (Right _success) -> True
+ _ -> False
+ , let pkg :: PackageDescription
+ pkg = pkgDescription cpkg
+ , exe <- PackageDescription.executables pkg
+ , PackageDescription.buildable (PackageDescription.buildInfo exe)
+ ]
- pkgDescription (ConfiguredPackage _ (SourcePackage _ gpd _ _)
- flags stanzas _) =
- case finalizePD flags (enableStanzas stanzas)
- (const True)
- platform cinfo [] gpd of
- Left _ -> error "finalizePD ReadyPackage failed"
- Right (desc, _) -> desc
+ pkgDescription
+ ( ConfiguredPackage
+ _
+ (SourcePackage _ gpd _ _)
+ flags
+ stanzas
+ _
+ ) =
+ case finalizePD
+ flags
+ (enableStanzas stanzas)
+ (const True)
+ platform
+ cinfo
+ []
+ gpd of
+ Left _ -> error "finalizePD ReadyPackage failed"
+ Right (desc, _) -> desc
- -- This is sadly rather complicated. We're kind of re-doing part of the
- -- configuration for the package. :-(
- pkgBinDir :: PackageDescription -> UnitId -> IO FilePath
- pkgBinDir pkg ipid = do
- defaultDirs <- InstallDirs.defaultInstallDirs
- compilerFlavor
- (fromFlag (configUserInstall configFlags))
- (PackageDescription.hasLibs pkg)
- let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
- defaultDirs (configInstallDirs configFlags)
- absoluteDirs = InstallDirs.absoluteInstallDirs
- (packageId pkg) ipid
- cinfo InstallDirs.NoCopyDest
- platform templateDirs
- canonicalizePath (InstallDirs.bindir absoluteDirs)
+ -- This is sadly rather complicated. We're kind of re-doing part of the
+ -- configuration for the package. :-(
+ pkgBinDir :: PackageDescription -> UnitId -> IO FilePath
+ pkgBinDir pkg ipid = do
+ defaultDirs <-
+ InstallDirs.defaultInstallDirs
+ compilerFlavor
+ (fromFlag (configUserInstall configFlags))
+ (PackageDescription.hasLibs pkg)
+ let templateDirs =
+ InstallDirs.combineInstallDirs
+ fromFlagOrDefault
+ defaultDirs
+ (configInstallDirs configFlags)
+ absoluteDirs =
+ InstallDirs.absoluteInstallDirs
+ (packageId pkg)
+ ipid
+ cinfo
+ InstallDirs.NoCopyDest
+ platform
+ templateDirs
+ canonicalizePath (InstallDirs.bindir absoluteDirs)
- substTemplate pkgid ipid = InstallDirs.fromPathTemplate
- . InstallDirs.substPathTemplate env
- where env = InstallDirs.initialPathTemplateEnv pkgid ipid
- cinfo platform
+ substTemplate pkgid ipid =
+ InstallDirs.fromPathTemplate
+ . InstallDirs.substPathTemplate env
+ where
+ env =
+ InstallDirs.initialPathTemplateEnv
+ pkgid
+ ipid
+ cinfo
+ platform
- fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
- prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
- suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
- cinfo = compilerInfo comp
- (CompilerId compilerFlavor _) = compilerInfoId cinfo
+ fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
+ prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
+ suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
+ cinfo = compilerInfo comp
+ (CompilerId compilerFlavor _) = compilerInfoId cinfo
-- | Symlink binary.
--
-- The paths are take in pieces, so we can make relative link when possible.
---
-symlinkBinary ::
- OverwritePolicy -- ^ Whether to force overwrite an existing file
- -> FilePath -- ^ The canonical path of the public bin dir eg
- -- @/home/user/bin@
- -> FilePath -- ^ The canonical path of the private bin dir eg
- -- @/home/user/.cabal/bin@
- -> FilePath -- ^ The name of the executable to go in the public bin
- -- dir, eg @foo@
- -> String -- ^ The name of the executable to in the private bin
- -- dir, eg @foo-1.0@
- -> IO Bool -- ^ If creating the symlink was successful. @False@ if
- -- there was another file there already that we did
- -- not own. Other errors like permission errors just
- -- propagate as exceptions.
+symlinkBinary
+ :: OverwritePolicy
+ -- ^ Whether to force overwrite an existing file
+ -> FilePath
+ -- ^ The canonical path of the public bin dir eg
+ -- @/home/user/bin@
+ -> FilePath
+ -- ^ The canonical path of the private bin dir eg
+ -- @/home/user/.cabal/bin@
+ -> FilePath
+ -- ^ The name of the executable to go in the public bin
+ -- dir, eg @foo@
+ -> String
+ -- ^ The name of the executable to in the private bin
+ -- dir, eg @foo-1.0@
+ -> IO Bool
+ -- ^ If creating the symlink was successful. @False@ if
+ -- there was another file there already that we did
+ -- not own. Other errors like permission errors just
+ -- propagate as exceptions.
symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName = do
- ok <- targetOkToOverwrite (publicBindir </> publicName)
- (privateBindir </> privateName)
+ ok <-
+ targetOkToOverwrite
+ (publicBindir </> publicName)
+ (privateBindir </> privateName)
case ok of
- NotExists -> mkLink
- OkToOverwrite -> overwrite
+ NotExists -> mkLink
+ OkToOverwrite -> overwrite
NotOurFile ->
case overwritePolicy of
- NeverOverwrite -> return False
+ NeverOverwrite -> return False
AlwaysOverwrite -> overwrite
PromptOverwrite -> maybeOverwrite
where
@@ -210,8 +292,8 @@ symlinkBinary overwritePolicy publicBindir privateBindir publicName privateName
overwrite :: IO Bool
overwrite = rmLink *> mkLink
maybeOverwrite :: IO Bool
- maybeOverwrite
- = promptRun
+ maybeOverwrite =
+ promptRun
"Existing file found while installing symlink. Do you want to overwrite that file? (y/n)"
overwrite
@@ -223,22 +305,24 @@ promptRun s m = do
-- | Check a file path of a symlink that we would like to create to see if it
-- is OK. For it to be OK to overwrite it must either not already exist yet or
-- be a symlink to our target (in which case we can assume ownership).
---
-targetOkToOverwrite :: FilePath -- ^ The file path of the symlink to the private
- -- binary that we would like to create
- -> FilePath -- ^ The canonical path of the private binary.
- -- Use 'canonicalizePath' to make this.
- -> IO SymlinkStatus
+targetOkToOverwrite
+ :: FilePath
+ -- ^ The file path of the symlink to the private
+ -- binary that we would like to create
+ -> FilePath
+ -- ^ The canonical path of the private binary.
+ -- Use 'canonicalizePath' to make this.
+ -> IO SymlinkStatus
targetOkToOverwrite symlink target = handleNotExist $ do
isLink <- pathIsSymbolicLink symlink
if not isLink
then return NotOurFile
- else do target' <- canonicalizePath =<< getSymbolicLinkTarget symlink
- -- This partially relies on canonicalizePath handling symlinks
- if target == target'
- then return OkToOverwrite
- else return NotOurFile
-
+ else do
+ target' <- canonicalizePath =<< getSymbolicLinkTarget symlink
+ -- This partially relies on canonicalizePath handling symlinks
+ if target == target'
+ then return OkToOverwrite
+ else return NotOurFile
where
handleNotExist action = catchIO action $ \ioexception ->
-- If the target doesn't exist then there's no problem overwriting it!
@@ -247,35 +331,38 @@ targetOkToOverwrite symlink target = handleNotExist $ do
else ioError ioexception
data SymlinkStatus
- = NotExists -- ^ The file doesn't exist so we can make a symlink.
- | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll
- -- have to delete it first before we make a new symlink.
- | NotOurFile -- ^ A file already exists and it is not one of our existing
- -- symlinks (either because it is not a symlink or because
- -- it points somewhere other than our managed space).
- deriving Show
+ = -- | The file doesn't exist so we can make a symlink.
+ NotExists
+ | -- | A symlink already exists, though it is ours. We'll
+ -- have to delete it first before we make a new symlink.
+ OkToOverwrite
+ | -- | A file already exists and it is not one of our existing
+ -- symlinks (either because it is not a symlink or because
+ -- it points somewhere other than our managed space).
+ NotOurFile
+ deriving (Show)
-- | Take two canonical paths and produce a relative path to get from the first
-- to the second, even if it means adding @..@ path components.
---
makeRelative :: FilePath -> FilePath -> FilePath
-makeRelative a b = assert (isAbsolute a && isAbsolute b) $
- let as = splitPath a
- bs = splitPath b
- commonLen = length $ takeWhile id $ zipWith (==) as bs
- in joinPath $ [ ".." | _ <- drop commonLen as ]
- ++ drop commonLen bs
+makeRelative a b =
+ assert (isAbsolute a && isAbsolute b) $
+ let as = splitPath a
+ bs = splitPath b
+ commonLen = length $ takeWhile id $ zipWith (==) as bs
+ in joinPath $
+ [".." | _ <- drop commonLen as]
+ ++ drop commonLen bs
-- | Try to make a symlink in a temporary directory.
--
-- If this works, we can try to symlink: even on Windows.
---
trySymlink :: Verbosity -> IO Bool
trySymlink verbosity = do
tmp <- getTemporaryDirectory
withTempDirectory verbosity tmp "cabal-symlink-test" $ \tmpDirPath -> do
let from = tmpDirPath </> "file.txt"
- let to = tmpDirPath </> "file2.txt"
+ let to = tmpDirPath </> "file2.txt"
-- create a file
BS.writeFile from (BS8.pack "TEST")
diff --git a/cabal-install/src/Distribution/Client/JobControl.hs b/cabal-install/src/Distribution/Client/JobControl.hs
index c9c16647ac1af65d223aa741d78fb6bd8e20774a..d45efe3c8b24ebb665fb3e0e052b33e2c6c74aa2 100644
--- a/cabal-install/src/Distribution/Client/JobControl.hs
+++ b/cabal-install/src/Distribution/Client/JobControl.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE FlexibleContexts #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.JobControl
-- Copyright : (c) Duncan Coutts 2012
@@ -10,74 +14,65 @@
-- Portability : portable
--
-- A job control concurrency abstraction
------------------------------------------------------------------------------
-module Distribution.Client.JobControl (
- JobControl,
- newSerialJobControl,
- newParallelJobControl,
- spawnJob,
- collectJob,
- remainingJobs,
- cancelJobs,
-
- JobLimit,
- newJobLimit,
- withJobLimit,
-
- Lock,
- newLock,
- criticalSection
+module Distribution.Client.JobControl
+ ( JobControl
+ , newSerialJobControl
+ , newParallelJobControl
+ , spawnJob
+ , collectJob
+ , remainingJobs
+ , cancelJobs
+ , JobLimit
+ , newJobLimit
+ , withJobLimit
+ , Lock
+ , newLock
+ , criticalSection
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Control.Monad (forever, replicateM_)
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Concurrent.STM (STM, atomically)
-import Control.Concurrent.STM.TVar
import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
import Control.Exception (bracket_, try)
-import Distribution.Compat.Stack
+import Control.Monad (forever, replicateM_)
import Distribution.Client.Compat.Semaphore
-
+import Distribution.Compat.Stack
-- | A simple concurrency abstraction. Jobs can be spawned and can complete
-- in any order. This allows both serial and parallel implementations.
---
-data JobControl m a = JobControl {
- -- | Add a new job to the pool of jobs
- spawnJob :: m a -> m (),
-
- -- | Wait until one job is complete
- collectJob :: m a,
-
- -- | Returns True if there are any outstanding jobs
- -- (ie spawned but yet to be collected)
- remainingJobs :: m Bool,
-
- -- | Try to cancel any outstanding but not-yet-started jobs.
- -- Call 'remainingJobs' after this to find out if any jobs are left
- -- (ie could not be cancelled).
- cancelJobs :: m ()
- }
-
+data JobControl m a = JobControl
+ { spawnJob :: m a -> m ()
+ -- ^ Add a new job to the pool of jobs
+ , collectJob :: m a
+ -- ^ Wait until one job is complete
+ , remainingJobs :: m Bool
+ -- ^ Returns True if there are any outstanding jobs
+ -- (ie spawned but yet to be collected)
+ , cancelJobs :: m ()
+ -- ^ Try to cancel any outstanding but not-yet-started jobs.
+ -- Call 'remainingJobs' after this to find out if any jobs are left
+ -- (ie could not be cancelled).
+ }
-- | Make a 'JobControl' that executes all jobs serially and in order.
-- It only executes jobs on demand when they are collected, not eagerly.
--
-- Cancelling will cancel /all/ jobs that have not been collected yet.
---
newSerialJobControl :: IO (JobControl IO a)
newSerialJobControl = do
- qVar <- newTChanIO
- return JobControl {
- spawnJob = spawn qVar,
- collectJob = collect qVar,
- remainingJobs = remaining qVar,
- cancelJobs = cancel qVar
- }
+ qVar <- newTChanIO
+ return
+ JobControl
+ { spawnJob = spawn qVar
+ , collectJob = collect qVar
+ , remainingJobs = remaining qVar
+ , cancelJobs = cancel qVar
+ }
where
spawn :: TChan (IO a) -> IO a -> IO ()
spawn qVar job = atomically $ writeTChan qVar job
@@ -87,7 +82,7 @@ newSerialJobControl = do
join $ atomically $ readTChan qVar
remaining :: TChan (IO a) -> IO Bool
- remaining qVar = fmap not $ atomically $ isEmptyTChan qVar
+ remaining qVar = fmap not $ atomically $ isEmptyTChan qVar
cancel :: TChan (IO a) -> IO ()
cancel qVar = do
@@ -100,25 +95,26 @@ newSerialJobControl = do
-- Cancelling will cancel jobs that have not yet begun executing, but jobs
-- that have already been executed or are currently executing cannot be
-- cancelled.
---
newParallelJobControl :: WithCallStack (Int -> IO (JobControl IO a))
-newParallelJobControl n | n < 1 || n > 1000 =
- error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n
+newParallelJobControl n
+ | n < 1 || n > 1000 =
+ error $ "newParallelJobControl: not a sensible number of jobs: " ++ show n
newParallelJobControl maxJobLimit = do
- inqVar <- newTChanIO
- outqVar <- newTChanIO
- countVar <- newTVarIO 0
- replicateM_ maxJobLimit $
- forkIO $
- worker inqVar outqVar
- return JobControl {
- spawnJob = spawn inqVar countVar,
- collectJob = collect outqVar countVar,
- remainingJobs = remaining countVar,
- cancelJobs = cancel inqVar countVar
- }
+ inqVar <- newTChanIO
+ outqVar <- newTChanIO
+ countVar <- newTVarIO 0
+ replicateM_ maxJobLimit $
+ forkIO $
+ worker inqVar outqVar
+ return
+ JobControl
+ { spawnJob = spawn inqVar countVar
+ , collectJob = collect outqVar countVar
+ , remainingJobs = remaining countVar
+ , cancelJobs = cancel inqVar countVar
+ }
where
- worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO ()
+ worker :: TChan (IO a) -> TChan (Either SomeException a) -> IO ()
worker inqVar outqVar =
forever $ do
job <- atomically $ readTChan inqVar
@@ -128,7 +124,7 @@ newParallelJobControl maxJobLimit = do
spawn :: TChan (IO a) -> TVar Int -> IO a -> IO ()
spawn inqVar countVar job =
atomically $ do
- modifyTVar' countVar (+1)
+ modifyTVar' countVar (+ 1)
writeTChan inqVar job
collect :: TChan (Either SomeException a) -> TVar Int -> IO a
@@ -139,7 +135,7 @@ newParallelJobControl maxJobLimit = do
either throwIO return res
remaining :: TVar Int -> IO Bool
- remaining countVar = fmap (/=0) $ atomically $ readTVar countVar
+ remaining countVar = fmap (/= 0) $ atomically $ readTVar countVar
cancel :: TChan (IO a) -> TVar Int -> IO ()
cancel inqVar countVar =
@@ -154,7 +150,7 @@ readAllTChan qvar = go []
mx <- tryReadTChan qvar
case mx of
Nothing -> return (reverse xs)
- Just x -> go (x:xs)
+ Just x -> go (x : xs)
-------------------------
-- Job limits and locks
diff --git a/cabal-install/src/Distribution/Client/List.hs b/cabal-install/src/Distribution/Client/List.hs
index a8bede49dd74b383c6fbb311a88344890259ae5a..ef9285bf39da27a7e5039ac9068ab34e57ffcbd6 100644
--- a/cabal-install/src/Distribution/Client/List.hs
+++ b/cabal-install/src/Distribution/Client/List.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.List
-- Copyright : (c) David Himmelstrup 2005
@@ -9,264 +13,368 @@
-- Maintainer : cabal-devel@haskell.org
--
-- Search for and print information about packages
------------------------------------------------------------------------------
-module Distribution.Client.List (
- list, info
+module Distribution.Client.List
+ ( list
+ , info
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Package
- ( PackageName, Package(..), packageName
- , packageVersion, UnitId )
-import Distribution.Types.Dependency
-import Distribution.Types.UnqualComponentName
-import Distribution.ModuleName (ModuleName)
-import Distribution.License (License)
import qualified Distribution.InstalledPackageInfo as Installed
-import qualified Distribution.PackageDescription as Source
+import Distribution.License (License)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Package
+ ( Package (..)
+ , PackageName
+ , UnitId
+ , packageName
+ , packageVersion
+ )
import Distribution.PackageDescription
- ( PackageFlag(..), unFlagName )
+ ( PackageFlag (..)
+ , unFlagName
+ )
+import qualified Distribution.PackageDescription as Source
import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription )
+ ( flattenPackageDescription
+ )
+import Distribution.Types.Dependency
+import Distribution.Types.UnqualComponentName
import Distribution.Simple.Compiler
- ( Compiler, PackageDBStack )
-import Distribution.Simple.Program (ProgramDb)
-import Distribution.Simple.Utils
- ( equating, die', notice )
-import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault)
+ ( Compiler
+ , PackageDBStack
+ )
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
+import Distribution.Simple.Program (ProgramDb)
+import Distribution.Simple.Setup (fromFlag, fromFlagOrDefault)
+import Distribution.Simple.Utils
+ ( die'
+ , equating
+ , notice
+ )
import Distribution.Version
- ( Version, mkVersion, versionNumbers, VersionRange, withinRange, anyVersion
- , intersectVersionRanges, simplifyVersionRange )
+ ( Version
+ , VersionRange
+ , anyVersion
+ , intersectVersionRanges
+ , mkVersion
+ , simplifyVersionRange
+ , versionNumbers
+ , withinRange
+ )
import qualified Distribution.SPDX as SPDX
-import Distribution.Solver.Types.PackageConstraint
+import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
-import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.SourcePackage
-import Distribution.Client.Types
- ( SourcePackageDb(..), PackageSpecifier(..), UnresolvedSourcePackage )
-import Distribution.Client.Targets
- ( UserTarget, resolveUserTargets )
+import Distribution.Client.FetchUtils
+ ( isFetched
+ )
+import Distribution.Client.IndexUtils as IndexUtils
+ ( getInstalledPackages
+ , getSourcePackages
+ )
import Distribution.Client.Setup
- ( GlobalFlags(..), ListFlags(..), InfoFlags(..)
- , RepoContext(..) )
+ ( GlobalFlags (..)
+ , InfoFlags (..)
+ , ListFlags (..)
+ , RepoContext (..)
+ )
+import Distribution.Client.Targets
+ ( UserTarget
+ , resolveUserTargets
+ )
+import Distribution.Client.Types
+ ( PackageSpecifier (..)
+ , SourcePackageDb (..)
+ , UnresolvedSourcePackage
+ )
import Distribution.Client.Utils
- ( mergeBy, MergeResult(..) )
-import Distribution.Client.IndexUtils as IndexUtils
- ( getSourcePackages, getInstalledPackages )
-import Distribution.Client.FetchUtils
- ( isFetched )
+ ( MergeResult (..)
+ , mergeBy
+ )
+import Control.Exception
+ ( assert
+ )
import Data.Bits ((.|.))
import Data.List
- ( maximumBy )
-import Data.List.NonEmpty (groupBy)
+ ( maximumBy
+ )
import qualified Data.List as L
-import Data.Maybe
- ( fromJust )
+import Data.List.NonEmpty (groupBy)
import qualified Data.Map as Map
+import Data.Maybe
+ ( fromJust
+ )
import Data.Tree as Tree
-import Control.Exception
- ( assert )
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint
- ( lineLength, ribbonsPerLine, Doc, renderStyle, char
- , nest, ($+$), text, vcat, style, parens, fsep)
import System.Directory
- ( doesDirectoryExist )
+ ( doesDirectoryExist
+ )
+import Text.PrettyPrint
+ ( Doc
+ , char
+ , fsep
+ , lineLength
+ , nest
+ , parens
+ , renderStyle
+ , ribbonsPerLine
+ , style
+ , text
+ , vcat
+ , ($+$)
+ )
+import qualified Text.PrettyPrint as Disp
import Distribution.Utils.ShortText (ShortText)
import qualified Distribution.Utils.ShortText as ShortText
import qualified Text.Regex.Base as Regex
import qualified Text.Regex.Posix.String as Regex
-
-- | Return a list of packages matching given search strings.
-getPkgList :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Maybe (Compiler, ProgramDb)
- -> ListFlags
- -> [String]
- -> IO [PackageDisplayInfo]
+getPkgList
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Maybe (Compiler, ProgramDb)
+ -> ListFlags
+ -> [String]
+ -> IO [PackageDisplayInfo]
getPkgList verbosity packageDBs repoCtxt mcompprogdb listFlags pats = do
- installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->
- getInstalledPackages verbosity comp packageDBs progdb
- sourcePkgDb <- getSourcePackages verbosity repoCtxt
-
- regexps <- for pats $ \pat -> do
- e <- Regex.compile compOption Regex.execBlank pat
- case e of
- Right r -> return r
- Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err
-
- let sourcePkgIndex = packageIndex sourcePkgDb
- prefs name = fromMaybe anyVersion
- (Map.lookup name (packagePreferences sourcePkgDb))
-
- pkgsInfoMatching ::
- [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
- pkgsInfoMatching =
- let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex
- matchingSource = matchingPackages (\ idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex
- in mergePackages matchingInstalled matchingSource
-
- pkgsInfo ::
- [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
- pkgsInfo
- -- gather info for all packages
- | null regexps = mergePackages
- (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)
- ( PackageIndex.allPackages sourcePkgIndex)
-
- -- gather info for packages matching search term
- | otherwise = pkgsInfoMatching
-
- matches :: [PackageDisplayInfo]
- matches = [ mergePackageInfo pref
- installedPkgs sourcePkgs selectedPkg False
- | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo
- , not onlyInstalled || not (null installedPkgs)
- , let pref = prefs pkgname
- selectedPkg = latestWithPref pref sourcePkgs ]
- return matches
+ installedPkgIndex <- for mcompprogdb $ \(comp, progdb) ->
+ getInstalledPackages verbosity comp packageDBs progdb
+ sourcePkgDb <- getSourcePackages verbosity repoCtxt
+
+ regexps <- for pats $ \pat -> do
+ e <- Regex.compile compOption Regex.execBlank pat
+ case e of
+ Right r -> return r
+ Left err -> die' verbosity $ "Failed to compile regex " ++ pat ++ ": " ++ snd err
+
+ let sourcePkgIndex = packageIndex sourcePkgDb
+ prefs name =
+ fromMaybe
+ anyVersion
+ (Map.lookup name (packagePreferences sourcePkgDb))
+
+ pkgsInfoMatching
+ :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
+ pkgsInfoMatching =
+ let matchingInstalled = maybe [] (matchingPackages InstalledPackageIndex.searchWithPredicate regexps) installedPkgIndex
+ matchingSource = matchingPackages (\idx n -> concatMap snd (PackageIndex.searchWithPredicate idx n)) regexps sourcePkgIndex
+ in mergePackages matchingInstalled matchingSource
+
+ pkgsInfo
+ :: [(PackageName, [Installed.InstalledPackageInfo], [UnresolvedSourcePackage])]
+ pkgsInfo
+ -- gather info for all packages
+ | null regexps =
+ mergePackages
+ (maybe [] InstalledPackageIndex.allPackages installedPkgIndex)
+ (PackageIndex.allPackages sourcePkgIndex)
+ -- gather info for packages matching search term
+ | otherwise = pkgsInfoMatching
+
+ matches :: [PackageDisplayInfo]
+ matches =
+ [ mergePackageInfo
+ pref
+ installedPkgs
+ sourcePkgs
+ selectedPkg
+ False
+ | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo
+ , not onlyInstalled || not (null installedPkgs)
+ , let pref = prefs pkgname
+ selectedPkg = latestWithPref pref sourcePkgs
+ ]
+ return matches
where
- onlyInstalled = fromFlagOrDefault False (listInstalled listFlags)
+ onlyInstalled = fromFlagOrDefault False (listInstalled listFlags)
caseInsensitive = fromFlagOrDefault True (listCaseInsensitive listFlags)
- compOption | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase
- | otherwise = Regex.compExtended
+ compOption
+ | caseInsensitive = Regex.compExtended .|. Regex.compIgnoreCase
+ | otherwise = Regex.compExtended
matchingPackages search regexps index =
[ pkg
| re <- regexps
- , pkg <- search index (Regex.matchTest re) ]
-
+ , pkg <- search index (Regex.matchTest re)
+ ]
-- | Show information about packages.
-list :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Maybe (Compiler, ProgramDb)
- -> ListFlags
- -> [String]
- -> IO ()
+list
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Maybe (Compiler, ProgramDb)
+ -> ListFlags
+ -> [String]
+ -> IO ()
list verbosity packageDBs repos mcompProgdb listFlags pats = do
- matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats
-
- if simpleOutput
- then putStr $ unlines
- [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version
- | pkg <- matches
- , version <- if onlyInstalled
- then installedVersions pkg
- else nub . sort $ installedVersions pkg
- ++ sourceVersions pkg ]
- -- Note: this only works because for 'list', one cannot currently
- -- specify any version constraints, so listing all installed
- -- and source ones works.
- else
- if null matches
- then notice verbosity "No matches found."
- else putStr $ unlines (map showPackageSummaryInfo matches)
+ matches <- getPkgList verbosity packageDBs repos mcompProgdb listFlags pats
+
+ if simpleOutput
+ then
+ putStr $
+ unlines
+ [ prettyShow (pkgName pkg) ++ " " ++ prettyShow version
+ | pkg <- matches
+ , version <-
+ if onlyInstalled
+ then installedVersions pkg
+ else
+ nub . sort $
+ installedVersions pkg
+ ++ sourceVersions pkg
+ ]
+ else -- Note: this only works because for 'list', one cannot currently
+ -- specify any version constraints, so listing all installed
+ -- and source ones works.
+
+ if null matches
+ then notice verbosity "No matches found."
+ else putStr $ unlines (map showPackageSummaryInfo matches)
where
onlyInstalled = fromFlag (listInstalled listFlags)
- simpleOutput = fromFlag (listSimpleOutput listFlags)
-
-info :: Verbosity
- -> PackageDBStack
- -> RepoContext
- -> Compiler
- -> ProgramDb
- -> GlobalFlags
- -> InfoFlags
- -> [UserTarget]
- -> IO ()
+ simpleOutput = fromFlag (listSimpleOutput listFlags)
+
+info
+ :: Verbosity
+ -> PackageDBStack
+ -> RepoContext
+ -> Compiler
+ -> ProgramDb
+ -> GlobalFlags
+ -> InfoFlags
+ -> [UserTarget]
+ -> IO ()
info verbosity _ _ _ _ _ _ [] =
- notice verbosity "No packages requested. Nothing to do."
-
-info verbosity packageDBs repoCtxt comp progdb
- _ _listFlags userTargets = do
-
+ notice verbosity "No packages requested. Nothing to do."
+info
+ verbosity
+ packageDBs
+ repoCtxt
+ comp
+ progdb
+ _
+ _listFlags
+ userTargets = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs progdb
- sourcePkgDb <- getSourcePackages verbosity repoCtxt
+ sourcePkgDb <- getSourcePackages verbosity repoCtxt
let sourcePkgIndex = packageIndex sourcePkgDb
- prefs name = fromMaybe anyVersion
- (Map.lookup name (packagePreferences sourcePkgDb))
-
- -- Users may specify names of packages that are only installed, not
- -- just available source packages, so we must resolve targets using
- -- the combination of installed and source packages.
- let sourcePkgs' = PackageIndex.fromList
- $ map packageId
- (InstalledPackageIndex.allPackages installedPkgIndex)
- ++ map packageId
- (PackageIndex.allPackages sourcePkgIndex)
- pkgSpecifiers <- resolveUserTargets verbosity repoCtxt
- sourcePkgs' userTargets
-
- pkgsinfo <- sequenceA
- [ do pkginfo <- either (die' verbosity) return $
- gatherPkgInfo prefs
- installedPkgIndex sourcePkgIndex
- pkgSpecifier
- updateFileSystemPackageDetails pkginfo
- | pkgSpecifier <- pkgSpecifiers ]
+ prefs name =
+ fromMaybe
+ anyVersion
+ (Map.lookup name (packagePreferences sourcePkgDb))
+
+ -- Users may specify names of packages that are only installed, not
+ -- just available source packages, so we must resolve targets using
+ -- the combination of installed and source packages.
+ let sourcePkgs' =
+ PackageIndex.fromList $
+ map
+ packageId
+ (InstalledPackageIndex.allPackages installedPkgIndex)
+ ++ map
+ packageId
+ (PackageIndex.allPackages sourcePkgIndex)
+ pkgSpecifiers <-
+ resolveUserTargets
+ verbosity
+ repoCtxt
+ sourcePkgs'
+ userTargets
+
+ pkgsinfo <-
+ sequenceA
+ [ do
+ pkginfo <-
+ either (die' verbosity) return $
+ gatherPkgInfo
+ prefs
+ installedPkgIndex
+ sourcePkgIndex
+ pkgSpecifier
+ updateFileSystemPackageDetails pkginfo
+ | pkgSpecifier <- pkgSpecifiers
+ ]
putStr $ unlines (map showPackageDetailedInfo pkgsinfo)
-
- where
- gatherPkgInfo :: (PackageName -> VersionRange) ->
- InstalledPackageIndex ->
- PackageIndex.PackageIndex UnresolvedSourcePackage ->
- PackageSpecifier UnresolvedSourcePackage ->
- Either String PackageDisplayInfo
- gatherPkgInfo prefs installedPkgIndex sourcePkgIndex
- (NamedPackage name props)
- | null (selectedInstalledPkgs) && null (selectedSourcePkgs)
- = Left $ "There is no available version of " ++ prettyShow name
- ++ " that satisfies "
- ++ prettyShow (simplifyVersionRange verConstraint)
-
- | otherwise
- = Right $ mergePackageInfo pref installedPkgs
- sourcePkgs selectedSourcePkg'
- showPkgVersion
- where
- (pref, installedPkgs, sourcePkgs) =
- sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
-
- selectedInstalledPkgs = InstalledPackageIndex.lookupDependency
- installedPkgIndex
- name verConstraint
- selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex
- name verConstraint
- selectedSourcePkg' = latestWithPref pref selectedSourcePkgs
-
- -- display a specific package version if the user
- -- supplied a non-trivial version constraint
- showPkgVersion = not (null verConstraints)
- verConstraint = foldr intersectVersionRanges anyVersion verConstraints
- verConstraints = [ vr | PackagePropertyVersion vr <- props ]
-
- gatherPkgInfo prefs installedPkgIndex sourcePkgIndex
- (SpecificSourcePackage pkg) =
- Right $ mergePackageInfo pref installedPkgs sourcePkgs
- selectedPkg True
- where
- name = packageName pkg
- selectedPkg = Just pkg
- (pref, installedPkgs, sourcePkgs) =
- sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
-
-sourcePkgsInfo ::
- (PackageName -> VersionRange)
+ where
+ gatherPkgInfo
+ :: (PackageName -> VersionRange)
+ -> InstalledPackageIndex
+ -> PackageIndex.PackageIndex UnresolvedSourcePackage
+ -> PackageSpecifier UnresolvedSourcePackage
+ -> Either String PackageDisplayInfo
+ gatherPkgInfo
+ prefs
+ installedPkgIndex
+ sourcePkgIndex
+ (NamedPackage name props)
+ | null (selectedInstalledPkgs) && null (selectedSourcePkgs) =
+ Left $
+ "There is no available version of "
+ ++ prettyShow name
+ ++ " that satisfies "
+ ++ prettyShow (simplifyVersionRange verConstraint)
+ | otherwise =
+ Right $
+ mergePackageInfo
+ pref
+ installedPkgs
+ sourcePkgs
+ selectedSourcePkg'
+ showPkgVersion
+ where
+ (pref, installedPkgs, sourcePkgs) =
+ sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
+
+ selectedInstalledPkgs =
+ InstalledPackageIndex.lookupDependency
+ installedPkgIndex
+ name
+ verConstraint
+ selectedSourcePkgs =
+ PackageIndex.lookupDependency
+ sourcePkgIndex
+ name
+ verConstraint
+ selectedSourcePkg' = latestWithPref pref selectedSourcePkgs
+
+ -- display a specific package version if the user
+ -- supplied a non-trivial version constraint
+ showPkgVersion = not (null verConstraints)
+ verConstraint = foldr intersectVersionRanges anyVersion verConstraints
+ verConstraints = [vr | PackagePropertyVersion vr <- props]
+ gatherPkgInfo
+ prefs
+ installedPkgIndex
+ sourcePkgIndex
+ (SpecificSourcePackage pkg) =
+ Right $
+ mergePackageInfo
+ pref
+ installedPkgs
+ sourcePkgs
+ selectedPkg
+ True
+ where
+ name = packageName pkg
+ selectedPkg = Just pkg
+ (pref, installedPkgs, sourcePkgs) =
+ sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex
+
+sourcePkgsInfo
+ :: (PackageName -> VersionRange)
-> PackageName
-> InstalledPackageIndex
-> PackageIndex.PackageIndex UnresolvedSourcePackage
@@ -274,157 +382,179 @@ sourcePkgsInfo ::
sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =
(pref, installedPkgs, sourcePkgs)
where
- pref = prefs name
- installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName
- installedPkgIndex name)
- sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name
-
+ pref = prefs name
+ installedPkgs =
+ concatMap
+ snd
+ ( InstalledPackageIndex.lookupPackageName
+ installedPkgIndex
+ name
+ )
+ sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name
-- | The info that we can display for each package. It is information per
-- package name and covers all installed and available versions.
---
-data PackageDisplayInfo = PackageDisplayInfo {
- pkgName :: PackageName,
- selectedVersion :: Maybe Version,
- selectedSourcePkg :: Maybe UnresolvedSourcePackage,
- installedVersions :: [Version],
- sourceVersions :: [Version],
- preferredVersions :: VersionRange,
- homepage :: ShortText,
- bugReports :: ShortText,
- sourceRepo :: String, -- TODO
- synopsis :: ShortText,
- description :: ShortText,
- category :: ShortText,
- license :: Either SPDX.License License,
- author :: ShortText,
- maintainer :: ShortText,
- dependencies :: [ExtDependency],
- flags :: [PackageFlag],
- hasLib :: Bool,
- hasExe :: Bool,
- executables :: [UnqualComponentName],
- modules :: [ModuleName],
- haddockHtml :: FilePath,
- haveTarball :: Bool
+data PackageDisplayInfo = PackageDisplayInfo
+ { pkgName :: PackageName
+ , selectedVersion :: Maybe Version
+ , selectedSourcePkg :: Maybe UnresolvedSourcePackage
+ , installedVersions :: [Version]
+ , sourceVersions :: [Version]
+ , preferredVersions :: VersionRange
+ , homepage :: ShortText
+ , bugReports :: ShortText
+ , sourceRepo :: String -- TODO
+ , synopsis :: ShortText
+ , description :: ShortText
+ , category :: ShortText
+ , license :: Either SPDX.License License
+ , author :: ShortText
+ , maintainer :: ShortText
+ , dependencies :: [ExtDependency]
+ , flags :: [PackageFlag]
+ , hasLib :: Bool
+ , hasExe :: Bool
+ , executables :: [UnqualComponentName]
+ , modules :: [ModuleName]
+ , haddockHtml :: FilePath
+ , haveTarball :: Bool
}
-- | Covers source dependencies and installed dependencies in
-- one type.
-data ExtDependency = SourceDependency Dependency
- | InstalledDependency UnitId
+data ExtDependency
+ = SourceDependency Dependency
+ | InstalledDependency UnitId
showPackageSummaryInfo :: PackageDisplayInfo -> String
showPackageSummaryInfo pkginfo =
- renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
- char '*' <+> pretty (pkgName pkginfo)
- $+$
- (nest 4 $ vcat [
- maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs
- , text "Default available version:" <+>
- case selectedSourcePkg pkginfo of
- Nothing -> text "[ Not available from any configured repository ]"
- Just pkg -> pretty (packageVersion pkg)
- , text "Installed versions:" <+>
- case installedVersions pkginfo of
- [] | hasLib pkginfo -> text "[ Not installed ]"
- | otherwise -> text "[ Unknown ]"
- versions -> dispTopVersions 4
- (preferredVersions pkginfo) versions
- , maybeShowST (homepage pkginfo) "Homepage:" text
- , text "License: " <+> either pretty pretty (license pkginfo)
- ])
- $+$ text ""
+ renderStyle (style{lineLength = 80, ribbonsPerLine = 1}) $
+ char '*'
+ <+> pretty (pkgName pkginfo)
+ $+$ ( nest 4 $
+ vcat
+ [ maybeShowST (synopsis pkginfo) "Synopsis:" reflowParagraphs
+ , text "Default available version:"
+ <+> case selectedSourcePkg pkginfo of
+ Nothing -> text "[ Not available from any configured repository ]"
+ Just pkg -> pretty (packageVersion pkg)
+ , text "Installed versions:"
+ <+> case installedVersions pkginfo of
+ []
+ | hasLib pkginfo -> text "[ Not installed ]"
+ | otherwise -> text "[ Unknown ]"
+ versions ->
+ dispTopVersions
+ 4
+ (preferredVersions pkginfo)
+ versions
+ , maybeShowST (homepage pkginfo) "Homepage:" text
+ , text "License: " <+> either pretty pretty (license pkginfo)
+ ]
+ )
+ $+$ text ""
where
maybeShowST l s f
- | ShortText.null l = Disp.empty
- | otherwise = text s <+> f (ShortText.fromShortText l)
+ | ShortText.null l = Disp.empty
+ | otherwise = text s <+> f (ShortText.fromShortText l)
showPackageDetailedInfo :: PackageDisplayInfo -> String
showPackageDetailedInfo pkginfo =
- renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $
- char '*' <+> pretty (pkgName pkginfo)
- <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
- <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')
- <<>> parens pkgkind
- $+$
- (nest 4 $ vcat [
- entryST "Synopsis" synopsis hideIfNull reflowParagraphs
- , entry "Versions available" sourceVersions
- (altText null "[ Not available from server ]")
- (dispTopVersions 9 (preferredVersions pkginfo))
- , entry "Versions installed" installedVersions
- (altText null (if hasLib pkginfo then "[ Not installed ]"
- else "[ Unknown ]"))
- (dispTopVersions 4 (preferredVersions pkginfo))
- , entryST "Homepage" homepage orNotSpecified text
- , entryST "Bug reports" bugReports orNotSpecified text
- , entryST "Description" description hideIfNull reflowParagraphs
- , entryST "Category" category hideIfNull text
- , entry "License" license alwaysShow (either pretty pretty)
- , entryST "Author" author hideIfNull reflowLines
- , entryST "Maintainer" maintainer hideIfNull reflowLines
- , entry "Source repo" sourceRepo orNotSpecified text
- , entry "Executables" executables hideIfNull (commaSep pretty)
- , entry "Flags" flags hideIfNull (commaSep dispFlag)
- , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
- , entry "Documentation" haddockHtml showIfInstalled text
- , entry "Cached" haveTarball alwaysShow dispYesNo
- , if not (hasLib pkginfo) then mempty else
- text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))
- ])
- $+$ text ""
+ renderStyle (style{lineLength = 80, ribbonsPerLine = 1}) $
+ char '*'
+ <+> pretty (pkgName pkginfo)
+ <<>> maybe Disp.empty (\v -> char '-' Disp.<> pretty v) (selectedVersion pkginfo)
+ <+> text (replicate (16 - length (prettyShow (pkgName pkginfo))) ' ')
+ <<>> parens pkgkind
+ $+$ ( nest 4 $
+ vcat
+ [ entryST "Synopsis" synopsis hideIfNull reflowParagraphs
+ , entry
+ "Versions available"
+ sourceVersions
+ (altText null "[ Not available from server ]")
+ (dispTopVersions 9 (preferredVersions pkginfo))
+ , entry
+ "Versions installed"
+ installedVersions
+ ( altText
+ null
+ ( if hasLib pkginfo
+ then "[ Not installed ]"
+ else "[ Unknown ]"
+ )
+ )
+ (dispTopVersions 4 (preferredVersions pkginfo))
+ , entryST "Homepage" homepage orNotSpecified text
+ , entryST "Bug reports" bugReports orNotSpecified text
+ , entryST "Description" description hideIfNull reflowParagraphs
+ , entryST "Category" category hideIfNull text
+ , entry "License" license alwaysShow (either pretty pretty)
+ , entryST "Author" author hideIfNull reflowLines
+ , entryST "Maintainer" maintainer hideIfNull reflowLines
+ , entry "Source repo" sourceRepo orNotSpecified text
+ , entry "Executables" executables hideIfNull (commaSep pretty)
+ , entry "Flags" flags hideIfNull (commaSep dispFlag)
+ , entry "Dependencies" dependencies hideIfNull (commaSep dispExtDep)
+ , entry "Documentation" haddockHtml showIfInstalled text
+ , entry "Cached" haveTarball alwaysShow dispYesNo
+ , if not (hasLib pkginfo)
+ then mempty
+ else text "Modules:" $+$ nest 4 (vcat (map pretty . sort . modules $ pkginfo))
+ ]
+ )
+ $+$ text ""
where
entry fname field cond format = case cond (field pkginfo) of
- Nothing -> label <+> format (field pkginfo)
- Just Nothing -> mempty
+ Nothing -> label <+> format (field pkginfo)
+ Just Nothing -> mempty
Just (Just other) -> label <+> text other
where
- label = text fname Disp.<> char ':' Disp.<> padding
- padding = text (replicate (13 - length fname ) ' ')
+ label = text fname Disp.<> char ':' Disp.<> padding
+ padding = text (replicate (13 - length fname) ' ')
entryST fname field = entry fname (ShortText.fromShortText . field)
- normal = Nothing
- hide = Just Nothing
+ normal = Nothing
+ hide = Just Nothing
replace msg = Just (Just msg)
alwaysShow = const normal
hideIfNull v = if null v then hide else normal
showIfInstalled v
| not isInstalled = hide
- | null v = replace "[ Not installed ]"
- | otherwise = normal
+ | null v = replace "[ Not installed ]"
+ | otherwise = normal
altText nul msg v = if nul v then replace msg else normal
orNotSpecified = altText null "[ Not specified ]"
commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f
dispFlag = text . unFlagName . flagName
- dispYesNo True = text "Yes"
+ dispYesNo True = text "Yes"
dispYesNo False = text "No"
- dispExtDep (SourceDependency dep) = pretty dep
+ dispExtDep (SourceDependency dep) = pretty dep
dispExtDep (InstalledDependency dep) = pretty dep
isInstalled = not (null (installedVersions pkginfo))
hasExes = length (executables pkginfo) >= 2
- --TODO: exclude non-buildable exes
- pkgkind | hasLib pkginfo && hasExes = text "programs and library"
- | hasLib pkginfo && hasExe pkginfo = text "program and library"
- | hasLib pkginfo = text "library"
- | hasExes = text "programs"
- | hasExe pkginfo = text "program"
- | otherwise = mempty
-
+ -- TODO: exclude non-buildable exes
+ pkgkind
+ | hasLib pkginfo && hasExes = text "programs and library"
+ | hasLib pkginfo && hasExe pkginfo = text "program and library"
+ | hasLib pkginfo = text "library"
+ | hasExes = text "programs"
+ | hasExe pkginfo = text "program"
+ | otherwise = mempty
reflowParagraphs :: String -> Doc
reflowParagraphs =
- vcat
- . intersperse (text "") -- re-insert blank lines
- . map (fsep . map text . concatMap words) -- reflow paragraphs
- . filter (/= [""])
- . L.groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines
- . lines
+ vcat
+ . intersperse (text "") -- re-insert blank lines
+ . map (fsep . map text . concatMap words) -- reflow paragraphs
+ . filter (/= [""])
+ . L.groupBy (\x y -> "" `notElem` [x, y]) -- break on blank lines
+ . lines
reflowLines :: String -> Doc
reflowLines = vcat . map text . lines
@@ -435,147 +565,203 @@ reflowLines = vcat . map text . lines
-- * We're building info about a various versions of a single named package so
-- the input package info records are all supposed to refer to the same
-- package name.
---
-mergePackageInfo :: VersionRange
- -> [Installed.InstalledPackageInfo]
- -> [UnresolvedSourcePackage]
- -> Maybe UnresolvedSourcePackage
- -> Bool
- -> PackageDisplayInfo
+mergePackageInfo
+ :: VersionRange
+ -> [Installed.InstalledPackageInfo]
+ -> [UnresolvedSourcePackage]
+ -> Maybe UnresolvedSourcePackage
+ -> Bool
+ -> PackageDisplayInfo
mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =
assert (length installedPkgs + length sourcePkgs > 0) $
- PackageDisplayInfo {
- pkgName = combine packageName source
- packageName installed,
- selectedVersion = if showVer then fmap packageVersion selectedPkg
- else Nothing,
- selectedSourcePkg = sourceSelected,
- installedVersions = map packageVersion installedPkgs,
- sourceVersions = map packageVersion sourcePkgs,
- preferredVersions = versionPref,
-
- license = combine Source.licenseRaw source
- Installed.license installed,
- maintainer = combine Source.maintainer source
- Installed.maintainer installed,
- author = combine Source.author source
- Installed.author installed,
- homepage = combine Source.homepage source
- Installed.homepage installed,
- bugReports = maybe mempty Source.bugReports source,
- sourceRepo = fromMaybe mempty . join
- . fmap (uncons Nothing Source.repoLocation
- . sortBy (comparing Source.repoKind)
- . Source.sourceRepos)
- $ source,
- --TODO: installed package info is missing synopsis
- synopsis = maybe mempty Source.synopsis source,
- description = combine Source.description source
- Installed.description installed,
- category = combine Source.category source
- Installed.category installed,
- flags = maybe [] Source.genPackageFlags sourceGeneric,
- hasLib = isJust installed
- || maybe False (isJust . Source.condLibrary) sourceGeneric,
- hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric,
- executables = map fst (maybe [] Source.condExecutables sourceGeneric),
- modules = combine (map Installed.exposedName . Installed.exposedModules)
- installed
- -- NB: only for the PUBLIC library
- (concatMap getListOfExposedModules . maybeToList . Source.library)
- source,
- dependencies =
- combine (map (SourceDependency . simplifyDependency)
- . Source.allBuildDepends) source
- (map InstalledDependency . Installed.depends) installed,
- haddockHtml = fromMaybe "" . join
- . fmap (listToMaybe . Installed.haddockHTMLs)
- $ installed,
- haveTarball = False
- }
+ PackageDisplayInfo
+ { pkgName =
+ combine
+ packageName
+ source
+ packageName
+ installed
+ , selectedVersion =
+ if showVer
+ then fmap packageVersion selectedPkg
+ else Nothing
+ , selectedSourcePkg = sourceSelected
+ , installedVersions = map packageVersion installedPkgs
+ , sourceVersions = map packageVersion sourcePkgs
+ , preferredVersions = versionPref
+ , license =
+ combine
+ Source.licenseRaw
+ source
+ Installed.license
+ installed
+ , maintainer =
+ combine
+ Source.maintainer
+ source
+ Installed.maintainer
+ installed
+ , author =
+ combine
+ Source.author
+ source
+ Installed.author
+ installed
+ , homepage =
+ combine
+ Source.homepage
+ source
+ Installed.homepage
+ installed
+ , bugReports = maybe mempty Source.bugReports source
+ , sourceRepo =
+ fromMaybe mempty
+ . join
+ . fmap
+ ( uncons Nothing Source.repoLocation
+ . sortBy (comparing Source.repoKind)
+ . Source.sourceRepos
+ )
+ $ source
+ , -- TODO: installed package info is missing synopsis
+ synopsis = maybe mempty Source.synopsis source
+ , description =
+ combine
+ Source.description
+ source
+ Installed.description
+ installed
+ , category =
+ combine
+ Source.category
+ source
+ Installed.category
+ installed
+ , flags = maybe [] Source.genPackageFlags sourceGeneric
+ , hasLib =
+ isJust installed
+ || maybe False (isJust . Source.condLibrary) sourceGeneric
+ , hasExe = maybe False (not . null . Source.condExecutables) sourceGeneric
+ , executables = map fst (maybe [] Source.condExecutables sourceGeneric)
+ , modules =
+ combine
+ (map Installed.exposedName . Installed.exposedModules)
+ installed
+ -- NB: only for the PUBLIC library
+ (concatMap getListOfExposedModules . maybeToList . Source.library)
+ source
+ , dependencies =
+ combine
+ ( map (SourceDependency . simplifyDependency)
+ . Source.allBuildDepends
+ )
+ source
+ (map InstalledDependency . Installed.depends)
+ installed
+ , haddockHtml =
+ fromMaybe ""
+ . join
+ . fmap (listToMaybe . Installed.haddockHTMLs)
+ $ installed
+ , haveTarball = False
+ }
where
- combine f x g y = fromJust (fmap f x `mplus` fmap g y)
+ combine f x g y = fromJust (fmap f x `mplus` fmap g y)
installed :: Maybe Installed.InstalledPackageInfo
installed = latestWithPref versionPref installedPkgs
- getListOfExposedModules lib = Source.exposedModules lib
- ++ map Source.moduleReexportName
- (Source.reexportedModules lib)
+ getListOfExposedModules lib =
+ Source.exposedModules lib
+ ++ map
+ Source.moduleReexportName
+ (Source.reexportedModules lib)
sourceSelected
| isJust selectedPkg = selectedPkg
- | otherwise = latestWithPref versionPref sourcePkgs
+ | otherwise = latestWithPref versionPref sourcePkgs
sourceGeneric = fmap srcpkgDescription sourceSelected
- source = fmap flattenPackageDescription sourceGeneric
+ source = fmap flattenPackageDescription sourceGeneric
uncons :: b -> (a -> b) -> [a] -> b
- uncons z _ [] = z
- uncons _ f (x:_) = f x
-
+ uncons z _ [] = z
+ uncons _ f (x : _) = f x
-- | Not all the info is pure. We have to check if the docs really are
-- installed, because the registered package info lies. Similarly we have to
-- check if the tarball has indeed been fetched.
---
updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo
updateFileSystemPackageDetails pkginfo = do
- fetched <- maybe (return False) (isFetched . srcpkgSource)
- (selectedSourcePkg pkginfo)
+ fetched <-
+ maybe
+ (return False)
+ (isFetched . srcpkgSource)
+ (selectedSourcePkg pkginfo)
docsExist <- doesDirectoryExist (haddockHtml pkginfo)
- return pkginfo {
- haveTarball = fetched,
- haddockHtml = if docsExist then haddockHtml pkginfo else ""
- }
+ return
+ pkginfo
+ { haveTarball = fetched
+ , haddockHtml = if docsExist then haddockHtml pkginfo else ""
+ }
latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg
-latestWithPref _ [] = Nothing
+latestWithPref _ [] = Nothing
latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)
where
- prefThenVersion pkg = let ver = packageVersion pkg
- in (withinRange ver pref, ver)
-
+ prefThenVersion pkg =
+ let ver = packageVersion pkg
+ in (withinRange ver pref, ver)
-- | Rearrange installed and source packages into groups referring to the
-- same package by name. In the result pairs, the lists are guaranteed to not
-- both be empty.
---
-mergePackages :: [Installed.InstalledPackageInfo]
- -> [UnresolvedSourcePackage]
- -> [( PackageName
- , [Installed.InstalledPackageInfo]
- , [UnresolvedSourcePackage] )]
+mergePackages
+ :: [Installed.InstalledPackageInfo]
+ -> [UnresolvedSourcePackage]
+ -> [ ( PackageName
+ , [Installed.InstalledPackageInfo]
+ , [UnresolvedSourcePackage]
+ )
+ ]
mergePackages installedPkgs sourcePkgs =
- map collect
- $ mergeBy (\i a -> fst i `compare` fst a)
- (groupOn packageName installedPkgs)
- (groupOn packageName sourcePkgs)
+ map collect $
+ mergeBy
+ (\i a -> fst i `compare` fst a)
+ (groupOn packageName installedPkgs)
+ (groupOn packageName sourcePkgs)
where
- collect (OnlyInLeft (name,is) ) = (name, is, [])
- collect ( InBoth (_,is) (name,as)) = (name, is, as)
- collect (OnlyInRight (name,as)) = (name, [], as)
+ collect (OnlyInLeft (name, is)) = (name, is, [])
+ collect (InBoth (_, is) (name, as)) = (name, is, as)
+ collect (OnlyInRight (name, as)) = (name, [], as)
-groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
-groupOn key = map (\xs -> (key (head xs), toList xs))
- . groupBy (equating key)
- . sortBy (comparing key)
+groupOn :: Ord key => (a -> key) -> [a] -> [(key, [a])]
+groupOn key =
+ map (\xs -> (key (head xs), toList xs))
+ . groupBy (equating key)
+ . sortBy (comparing key)
dispTopVersions :: Int -> VersionRange -> [Version] -> Doc
dispTopVersions n pref vs =
- (Disp.fsep . Disp.punctuate (Disp.char ',')
- . map (\ver -> if ispref ver then pretty ver else parens (pretty ver))
- . sort . take n . interestingVersions ispref
- $ vs)
+ ( Disp.fsep
+ . Disp.punctuate (Disp.char ',')
+ . map (\ver -> if ispref ver then pretty ver else parens (pretty ver))
+ . sort
+ . take n
+ . interestingVersions ispref
+ $ vs
+ )
<+> trailingMessage
-
where
ispref ver = withinRange ver pref
extra = length vs - n
trailingMessage
| extra <= 0 = Disp.empty
- | otherwise = Disp.parens $ Disp.text "and"
- <+> Disp.int (length vs - n)
- <+> if extra == 1 then Disp.text "other"
- else Disp.text "others"
+ | otherwise =
+ Disp.parens $
+ Disp.text "and"
+ <+> Disp.int (length vs - n)
+ <+> if extra == 1
+ then Disp.text "other"
+ else Disp.text "others"
-- | Reorder a bunch of versions to put the most interesting / significant
-- versions first. A preferred version range is taken into account.
@@ -584,30 +770,30 @@ dispTopVersions n pref vs =
-- to present to the user, e.g.
--
-- > let selectVersions = sort . take 5 . interestingVersions pref
---
interestingVersions :: (Version -> Bool) -> [Version] -> [Version]
interestingVersions pref =
- map (mkVersion . fst) . filter snd
- . concat . Tree.levels
+ map (mkVersion . fst)
+ . filter snd
+ . concat
+ . Tree.levels
. swizzleTree
- . reorderTree (\(Node (v,_) _) -> pref (mkVersion v))
+ . reorderTree (\(Node (v, _) _) -> pref (mkVersion v))
. reverseTree
. mkTree
. map (or0 . versionNumbers)
-
where
- or0 [] = 0 :| []
- or0 (x:xs) = x :| xs
+ or0 [] = 0 :| []
+ or0 (x : xs) = x :| xs
swizzleTree = unfoldTree (spine [])
where
- spine ts' (Node x []) = (x, ts')
- spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t
+ spine ts' (Node x []) = (x, ts')
+ spine ts' (Node x (t : ts)) = spine (Node x ts : ts') t
reorderTree _ (Node x []) = Node x []
reorderTree p (Node x ts) = Node x (ts' ++ ts'')
where
- (ts',ts'') = partition p (map (reorderTree p) ts)
+ (ts', ts'') = partition p (map (reorderTree p) ts)
reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))
@@ -615,13 +801,14 @@ interestingVersions pref =
mkTree xs = unfoldTree step (False, [], xs)
where
step :: (Bool, [a], [NonEmpty a]) -> (([a], Bool), [(Bool, [a], [NonEmpty a])])
- step (node,ns,vs) =
+ step (node, ns, vs) =
( (reverse ns, node)
- , [ (any null vs', n:ns, mapMaybe nonEmpty (toList vs'))
+ , [ (any null vs', n : ns, mapMaybe nonEmpty (toList vs'))
| (n, vs') <- groups vs
]
)
groups :: [NonEmpty a] -> [(a, NonEmpty [a])]
- groups = map (\g -> (head (head g), fmap tail g))
- . groupBy (equating head)
+ groups =
+ map (\g -> (head (head g), fmap tail g))
+ . groupBy (equating head)
diff --git a/cabal-install/src/Distribution/Client/Main.hs b/cabal-install/src/Distribution/Client/Main.hs
index 889fa634390632b1c85fe861b5fb2e5688ecff65..1a3cc94d49f546382a2142c14f98522cd80aea5b 100644
--- a/cabal-install/src/Distribution/Client/Main.hs
+++ b/cabal-install/src/Distribution/Client/Main.hs
@@ -3,6 +3,9 @@
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Main
-- Copyright : (c) David Himmelstrup 2005
@@ -15,166 +18,254 @@
-- Entry point to the default cabal-install front-end.
--
-- @since 3.10.0.0
------------------------------------------------------------------------------
-
module Distribution.Client.Main (main) where
import Distribution.Client.Setup
- ( GlobalFlags(..), globalCommand, withRepoContext
- , ConfigFlags(..)
- , ConfigExFlags(..), defaultConfigExFlags, configureExCommand
- , reconfigureCommand
- , configCompilerAux', configPackageDB'
- , BuildFlags(..)
- , buildCommand, replCommand, testCommand, benchmarkCommand
- , InstallFlags(..), defaultInstallFlags
- , installCommand
- , FetchFlags(..), fetchCommand
- , FreezeFlags(..), freezeCommand
- , genBoundsCommand
- , GetFlags(..), getCommand, unpackCommand
- , checkCommand
- , formatCommand
- , ListFlags(..), listCommand, listNeedsCompiler
- , InfoFlags(..), infoCommand
- , UploadFlags(..), uploadCommand
- , ReportFlags(..), reportCommand
- , runCommand
- , InitFlags(initVerbosity, initHcPath), initCommand
- , ActAsSetupFlags(..), actAsSetupCommand
- , UserConfigFlags(..), userConfigCommand
- , reportCommand
- , manpageCommand
- , haddockCommand
- , cleanCommand
- , copyCommand
- , registerCommand
- )
+ ( ActAsSetupFlags (..)
+ , BuildFlags (..)
+ , ConfigExFlags (..)
+ , ConfigFlags (..)
+ , FetchFlags (..)
+ , FreezeFlags (..)
+ , GetFlags (..)
+ , GlobalFlags (..)
+ , InfoFlags (..)
+ , InitFlags (initHcPath, initVerbosity)
+ , InstallFlags (..)
+ , ListFlags (..)
+ , ReportFlags (..)
+ , UploadFlags (..)
+ , UserConfigFlags (..)
+ , actAsSetupCommand
+ , benchmarkCommand
+ , buildCommand
+ , checkCommand
+ , cleanCommand
+ , configCompilerAux'
+ , configPackageDB'
+ , configureExCommand
+ , copyCommand
+ , defaultConfigExFlags
+ , defaultInstallFlags
+ , fetchCommand
+ , formatCommand
+ , freezeCommand
+ , genBoundsCommand
+ , getCommand
+ , globalCommand
+ , haddockCommand
+ , infoCommand
+ , initCommand
+ , installCommand
+ , listCommand
+ , listNeedsCompiler
+ , manpageCommand
+ , reconfigureCommand
+ , registerCommand
+ , replCommand
+ , reportCommand
+ , runCommand
+ , testCommand
+ , unpackCommand
+ , uploadCommand
+ , userConfigCommand
+ , withRepoContext
+ )
import Distribution.Simple.Setup
- ( HaddockTarget(..)
- , HaddockFlags(..), defaultHaddockFlags
- , HscolourFlags(..), hscolourCommand
- , ReplFlags(..)
- , CopyFlags(..)
- , RegisterFlags(..)
- , CleanFlags(..)
- , TestFlags(..), BenchmarkFlags(..)
- , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag
- , configAbsolutePaths
- )
+ ( BenchmarkFlags (..)
+ , CleanFlags (..)
+ , CopyFlags (..)
+ , Flag (..)
+ , HaddockFlags (..)
+ , HaddockTarget (..)
+ , HscolourFlags (..)
+ , RegisterFlags (..)
+ , ReplFlags (..)
+ , TestFlags (..)
+ , configAbsolutePaths
+ , defaultHaddockFlags
+ , flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ , hscolourCommand
+ , toFlag
+ )
-import Prelude ()
import Distribution.Client.Compat.Prelude hiding (get)
+import Prelude ()
-import Distribution.Client.SetupWrapper
- ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
import Distribution.Client.Config
- ( SavedConfig(..), loadConfig, defaultConfigFile, userConfigDiff
- , userConfigUpdate, createDefaultConfigFile, getConfigFilePath )
-import Distribution.Client.Targets
- ( readUserTargets )
+ ( SavedConfig (..)
+ , createDefaultConfigFile
+ , defaultConfigFile
+ , getConfigFilePath
+ , loadConfig
+ , userConfigDiff
+ , userConfigUpdate
+ )
import qualified Distribution.Client.List as List
- ( list, info )
+ ( info
+ , list
+ )
+import Distribution.Client.SetupWrapper
+ ( SetupScriptOptions (..)
+ , defaultSetupScriptOptions
+ , setupWrapper
+ )
+import Distribution.Client.Targets
+ ( readUserTargets
+ )
+import qualified Distribution.Client.CmdBench as CmdBench
+import qualified Distribution.Client.CmdBuild as CmdBuild
+import qualified Distribution.Client.CmdClean as CmdClean
import qualified Distribution.Client.CmdConfigure as CmdConfigure
-import qualified Distribution.Client.CmdUpdate as CmdUpdate
-import qualified Distribution.Client.CmdBuild as CmdBuild
-import qualified Distribution.Client.CmdRepl as CmdRepl
-import qualified Distribution.Client.CmdFreeze as CmdFreeze
-import qualified Distribution.Client.CmdHaddock as CmdHaddock
+import qualified Distribution.Client.CmdExec as CmdExec
+import qualified Distribution.Client.CmdFreeze as CmdFreeze
+import qualified Distribution.Client.CmdHaddock as CmdHaddock
import qualified Distribution.Client.CmdHaddockProject as CmdHaddockProject
-import qualified Distribution.Client.CmdInstall as CmdInstall
-import qualified Distribution.Client.CmdRun as CmdRun
-import qualified Distribution.Client.CmdTest as CmdTest
-import qualified Distribution.Client.CmdBench as CmdBench
-import qualified Distribution.Client.CmdExec as CmdExec
-import qualified Distribution.Client.CmdClean as CmdClean
-import qualified Distribution.Client.CmdSdist as CmdSdist
-import qualified Distribution.Client.CmdListBin as CmdListBin
-import qualified Distribution.Client.CmdOutdated as CmdOutdated
-import Distribution.Client.CmdLegacy
-
-import Distribution.Client.Install (install)
-import Distribution.Client.Configure (configure, writeConfigFlags)
-import Distribution.Client.Fetch (fetch)
-import Distribution.Client.Freeze (freeze)
-import Distribution.Client.GenBounds (genBounds)
-import Distribution.Client.Check as Check (check)
---import Distribution.Client.Clean (clean)
+import qualified Distribution.Client.CmdInstall as CmdInstall
+import Distribution.Client.CmdLegacy
+import qualified Distribution.Client.CmdListBin as CmdListBin
+import qualified Distribution.Client.CmdOutdated as CmdOutdated
+import qualified Distribution.Client.CmdRepl as CmdRepl
+import qualified Distribution.Client.CmdRun as CmdRun
+import qualified Distribution.Client.CmdSdist as CmdSdist
+import qualified Distribution.Client.CmdTest as CmdTest
+import qualified Distribution.Client.CmdUpdate as CmdUpdate
+
+import Distribution.Client.Check as Check (check)
+import Distribution.Client.Configure (configure, writeConfigFlags)
+import Distribution.Client.Fetch (fetch)
+import Distribution.Client.Freeze (freeze)
+import Distribution.Client.GenBounds (genBounds)
+import Distribution.Client.Install (install)
+
+-- import Distribution.Client.Clean (clean)
+
+import Distribution.Client.Get (get)
+import Distribution.Client.Init (initCmd)
+import Distribution.Client.Manpage (manpageCmd)
+import Distribution.Client.ManpageFlags (ManpageFlags (..))
+import Distribution.Client.Nix
+ ( nixInstantiate
+ , nixShell
+ )
+import Distribution.Client.Reconfigure (Check (..), reconfigure)
+import Distribution.Client.Run (run, splitRunArgs)
+import Distribution.Client.Sandbox
+ ( findSavedDistPref
+ , loadConfigOrSandboxConfig
+ , updateInstallDirs
+ )
+import Distribution.Client.Signal
+ ( installTerminationHandler
+ )
+import Distribution.Client.Tar (createTarGzFile)
+import Distribution.Client.Types.Credentials (Password (..))
import qualified Distribution.Client.Upload as Upload
-import Distribution.Client.Run (run, splitRunArgs)
-import Distribution.Client.Get (get)
-import Distribution.Client.Reconfigure (Check(..), reconfigure)
-import Distribution.Client.Nix (nixInstantiate
- ,nixShell
- )
-import Distribution.Client.Sandbox (loadConfigOrSandboxConfig
- ,findSavedDistPref
- ,updateInstallDirs)
-import Distribution.Client.Tar (createTarGzFile)
-import Distribution.Client.Types.Credentials (Password (..))
-import Distribution.Client.Init (initCmd)
-import Distribution.Client.Manpage (manpageCmd)
-import Distribution.Client.ManpageFlags (ManpageFlags (..))
import Distribution.Client.Utils
- ( determineNumJobs, relaxEncodingErrors )
-import Distribution.Client.Signal
- ( installTerminationHandler )
+ ( determineNumJobs
+ , relaxEncodingErrors
+ )
import Distribution.Client.Version
- ( cabalInstallVersion )
+ ( cabalInstallVersion
+ )
import Distribution.Package (packageId)
import Distribution.PackageDescription
- ( BuildType(..), Executable(..), buildable )
+ ( BuildType (..)
+ , Executable (..)
+ , buildable
+ )
+import qualified Distribution.Make as Make
import Distribution.PackageDescription.PrettyPrint
- ( writeGenericPackageDescription )
+ ( writeGenericPackageDescription
+ )
import qualified Distribution.Simple as Simple
-import qualified Distribution.Make as Make
-import qualified Distribution.Types.UnqualComponentName as Make
import Distribution.Simple.Build
- ( startInterpreter )
+ ( startInterpreter
+ )
import Distribution.Simple.Command
- ( CommandParse(..), CommandUI(..), Command, CommandSpec(..)
- , CommandType(..), commandsRun, commandAddAction, hiddenCommand
- , commandFromSpec, commandShowOptions )
+ ( Command
+ , CommandParse (..)
+ , CommandSpec (..)
+ , CommandType (..)
+ , CommandUI (..)
+ , commandAddAction
+ , commandFromSpec
+ , commandShowOptions
+ , commandsRun
+ , hiddenCommand
+ )
import Distribution.Simple.Compiler (PackageDBStack)
import Distribution.Simple.Configure
- ( configCompilerAuxEx, ConfigStateFileError(..)
- , getPersistBuildConfig, interpretPackageDbFlags
- , tryGetPersistBuildConfig )
+ ( ConfigStateFileError (..)
+ , configCompilerAuxEx
+ , getPersistBuildConfig
+ , interpretPackageDbFlags
+ , tryGetPersistBuildConfig
+ )
import qualified Distribution.Simple.LocalBuildInfo as LBI
-import Distribution.Simple.PackageDescription ( readGenericPackageDescription )
-import Distribution.Simple.Program (defaultProgramDb
- ,configureAllKnownPrograms
- ,simpleProgramInvocation
- ,getProgramInvocationOutput)
+import Distribution.Simple.PackageDescription (readGenericPackageDescription)
+import Distribution.Simple.Program
+ ( configureAllKnownPrograms
+ , defaultProgramDb
+ , getProgramInvocationOutput
+ , simpleProgramInvocation
+ )
import Distribution.Simple.Program.Db (reconfigurePrograms)
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Utils
- ( cabalVersion, die', dieNoVerbosity, info, notice, topHandler
- , findPackageDesc, tryFindPackageDesc, createDirectoryIfMissingVerbose )
+ ( cabalVersion
+ , createDirectoryIfMissingVerbose
+ , die'
+ , dieNoVerbosity
+ , findPackageDesc
+ , info
+ , notice
+ , topHandler
+ , tryFindPackageDesc
+ )
import Distribution.Text
- ( display )
+ ( display
+ )
+import qualified Distribution.Types.UnqualComponentName as Make
import Distribution.Verbosity as Verbosity
- ( normal )
+ ( normal
+ )
import Distribution.Version
- ( Version, mkVersion, orLaterVersion )
+ ( Version
+ , mkVersion
+ , orLaterVersion
+ )
+import Control.Exception (AssertionFailed, assert, try)
+import Data.Monoid (Any (..))
import Distribution.Compat.ResponseFile
-import System.Environment (getProgName)
-import System.FilePath ( dropExtension, splitExtension
- , takeExtension, (</>), (<.>) )
-import System.IO ( BufferMode(LineBuffering), hSetBuffering
- , hPutStrLn, stderr, stdout )
-import System.Directory ( doesFileExist, getCurrentDirectory
- , withCurrentDirectory)
-import Data.Monoid (Any(..))
-import Control.Exception (AssertionFailed, assert, try)
-
+import System.Directory
+ ( doesFileExist
+ , getCurrentDirectory
+ , withCurrentDirectory
+ )
+import System.Environment (getProgName)
+import System.FilePath
+ ( dropExtension
+ , splitExtension
+ , takeExtension
+ , (<.>)
+ , (</>)
+ )
+import System.IO
+ ( BufferMode (LineBuffering)
+ , hPutStrLn
+ , hSetBuffering
+ , stderr
+ , stdout
+ )
-- | Entry point
---
main :: [String] -> IO ()
main args = do
installTerminationHandler
@@ -194,12 +285,13 @@ main args = do
-- | Check whether assertions are enabled and print a warning in that case.
warnIfAssertionsAreEnabled :: IO ()
warnIfAssertionsAreEnabled =
- assert False (return ()) `catch`
- (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg)
+ assert False (return ())
+ `catch` (\(_e :: AssertionFailed) -> hPutStrLn stderr assertionsEnabledMsg)
+ where
-- Andreas, 2022-12-30, issue #8654:
-- The verbosity machinery is not in place at this point (option -v not parsed),
-- so instead of using function @warn@, we print straight to stderr.
- where
+
assertionsEnabledMsg =
"Warning: this is a debug build of cabal-install with assertions enabled."
@@ -207,34 +299,33 @@ mainWorker :: [String] -> IO ()
mainWorker args = do
topHandler $
case commandsRun (globalCommand commands) commands args of
- CommandHelp help -> printGlobalHelp help
- CommandList opts -> printOptionsList opts
- CommandErrors errs -> printErrors errs
- CommandReadyToGo (globalFlags, commandParse) ->
+ CommandHelp help -> printGlobalHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (globalFlags, commandParse) ->
case commandParse of
- _ | fromFlagOrDefault False (globalVersion globalFlags)
- -> printVersion
- | fromFlagOrDefault False (globalNumericVersion globalFlags)
- -> printNumericVersion
- CommandHelp help -> printCommandHelp help
- CommandList opts -> printOptionsList opts
-
- CommandErrors errs -> do
+ _
+ | fromFlagOrDefault False (globalVersion globalFlags) ->
+ printVersion
+ | fromFlagOrDefault False (globalNumericVersion globalFlags) ->
+ printNumericVersion
+ CommandHelp help -> printCommandHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> do
-- Check whether cabal is called from a script, like #!/path/to/cabal.
case args of
- [] -> printErrors errs
- script : scriptArgs -> CmdRun.validScript script >>= \case
- False -> printErrors errs
- True -> do
- -- In main operation (not help, version etc.) print warning if assertions are on.
- warnIfAssertionsAreEnabled
- CmdRun.handleShebang script scriptArgs
-
- CommandReadyToGo action -> do
+ [] -> printErrors errs
+ script : scriptArgs ->
+ CmdRun.validScript script >>= \case
+ False -> printErrors errs
+ True -> do
+ -- In main operation (not help, version etc.) print warning if assertions are on.
+ warnIfAssertionsAreEnabled
+ CmdRun.handleShebang script scriptArgs
+ CommandReadyToGo action -> do
-- In main operation (not help, version etc.) print warning if assertions are on.
warnIfAssertionsAreEnabled
action globalFlags
-
where
printCommandHelp help = do
pname <- getProgName
@@ -243,20 +334,26 @@ mainWorker args = do
pname <- getProgName
configFile <- defaultConfigFile
putStr (help pname)
- putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"
- ++ " " ++ configFile ++ "\n"
+ putStr $
+ "\nYou can edit the cabal configuration file to set defaults:\n"
+ ++ " "
+ ++ configFile
+ ++ "\n"
exists <- doesFileExist configFile
unless exists $
- putStrLn $ "This file will be generated with sensible "
- ++ "defaults if you run 'cabal update'."
+ putStrLn $
+ "This file will be generated with sensible "
+ ++ "defaults if you run 'cabal update'."
printOptionsList = putStr . unlines
printErrors errs = dieNoVerbosity $ intercalate "\n" errs
printNumericVersion = putStrLn $ display cabalInstallVersion
- printVersion = putStrLn $ "cabal-install version "
- ++ display cabalInstallVersion
- ++ "\ncompiled using version "
- ++ display cabalVersion
- ++ " of the Cabal library "
+ printVersion =
+ putStrLn $
+ "cabal-install version "
+ ++ display cabalInstallVersion
+ ++ "\ncompiled using version "
+ ++ display cabalVersion
+ ++ " of the Cabal library "
commands = map commandFromSpec commandSpecs
commandSpecs =
@@ -273,112 +370,145 @@ mainWorker args = do
, regularCmd genBoundsCommand genBoundsAction
, regularCmd CmdOutdated.outdatedCommand CmdOutdated.outdatedAction
, wrapperCmd hscolourCommand hscolourVerbosity hscolourDistPref
- , hiddenCmd formatCommand formatAction
- , hiddenCmd actAsSetupCommand actAsSetupAction
- , hiddenCmd manpageCommand (manpageAction commandSpecs)
- , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction
-
- ] ++ concat
- [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction
- , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction
- , newCmd CmdBuild.buildCommand CmdBuild.buildAction
- , newCmd CmdRepl.replCommand CmdRepl.replAction
- , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction
- , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction
- , newCmd CmdHaddockProject.haddockProjectCommand
- CmdHaddockProject.haddockProjectAction
- , newCmd CmdInstall.installCommand CmdInstall.installAction
- , newCmd CmdRun.runCommand CmdRun.runAction
- , newCmd CmdTest.testCommand CmdTest.testAction
- , newCmd CmdBench.benchCommand CmdBench.benchAction
- , newCmd CmdExec.execCommand CmdExec.execAction
- , newCmd CmdClean.cleanCommand CmdClean.cleanAction
- , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction
-
- , legacyCmd configureExCommand configureAction
- , legacyCmd buildCommand buildAction
- , legacyCmd replCommand replAction
- , legacyCmd freezeCommand freezeAction
- , legacyCmd haddockCommand haddockAction
- , legacyCmd installCommand installAction
- , legacyCmd runCommand runAction
- , legacyCmd testCommand testAction
- , legacyCmd benchmarkCommand benchmarkAction
- , legacyCmd cleanCommand cleanAction
- , legacyWrapperCmd copyCommand copyVerbosity copyDistPref
- , legacyWrapperCmd registerCommand regVerbosity regDistPref
- , legacyCmd reconfigureCommand reconfigureAction
+ , hiddenCmd formatCommand formatAction
+ , hiddenCmd actAsSetupCommand actAsSetupAction
+ , hiddenCmd manpageCommand (manpageAction commandSpecs)
+ , regularCmd CmdListBin.listbinCommand CmdListBin.listbinAction
]
+ ++ concat
+ [ newCmd CmdConfigure.configureCommand CmdConfigure.configureAction
+ , newCmd CmdUpdate.updateCommand CmdUpdate.updateAction
+ , newCmd CmdBuild.buildCommand CmdBuild.buildAction
+ , newCmd CmdRepl.replCommand CmdRepl.replAction
+ , newCmd CmdFreeze.freezeCommand CmdFreeze.freezeAction
+ , newCmd CmdHaddock.haddockCommand CmdHaddock.haddockAction
+ , newCmd
+ CmdHaddockProject.haddockProjectCommand
+ CmdHaddockProject.haddockProjectAction
+ , newCmd CmdInstall.installCommand CmdInstall.installAction
+ , newCmd CmdRun.runCommand CmdRun.runAction
+ , newCmd CmdTest.testCommand CmdTest.testAction
+ , newCmd CmdBench.benchCommand CmdBench.benchAction
+ , newCmd CmdExec.execCommand CmdExec.execAction
+ , newCmd CmdClean.cleanCommand CmdClean.cleanAction
+ , newCmd CmdSdist.sdistCommand CmdSdist.sdistAction
+ , legacyCmd configureExCommand configureAction
+ , legacyCmd buildCommand buildAction
+ , legacyCmd replCommand replAction
+ , legacyCmd freezeCommand freezeAction
+ , legacyCmd haddockCommand haddockAction
+ , legacyCmd installCommand installAction
+ , legacyCmd runCommand runAction
+ , legacyCmd testCommand testAction
+ , legacyCmd benchmarkCommand benchmarkAction
+ , legacyCmd cleanCommand cleanAction
+ , legacyWrapperCmd copyCommand copyVerbosity copyDistPref
+ , legacyWrapperCmd registerCommand regVerbosity regDistPref
+ , legacyCmd reconfigureCommand reconfigureAction
+ ]
type Action = GlobalFlags -> IO ()
-- Duplicated in Distribution.Client.CmdLegacy. Any changes must be
-- reflected there, as well.
-regularCmd :: CommandUI flags -> (flags -> [String] -> action)
- -> CommandSpec action
+regularCmd
+ :: CommandUI flags
+ -> (flags -> [String] -> action)
+ -> CommandSpec action
regularCmd ui action =
CommandSpec ui ((flip commandAddAction) action) NormalCommand
-hiddenCmd :: CommandUI flags -> (flags -> [String] -> action)
- -> CommandSpec action
+hiddenCmd
+ :: CommandUI flags
+ -> (flags -> [String] -> action)
+ -> CommandSpec action
hiddenCmd ui action =
- CommandSpec ui (\ui' -> hiddenCommand (commandAddAction ui' action))
- HiddenCommand
-
-wrapperCmd :: Monoid flags => CommandUI flags -> (flags -> Flag Verbosity)
- -> (flags -> Flag String) -> CommandSpec Action
+ CommandSpec
+ ui
+ (\ui' -> hiddenCommand (commandAddAction ui' action))
+ HiddenCommand
+
+wrapperCmd
+ :: Monoid flags
+ => CommandUI flags
+ -> (flags -> Flag Verbosity)
+ -> (flags -> Flag String)
+ -> CommandSpec Action
wrapperCmd ui verbosity distPref =
CommandSpec ui (\ui' -> wrapperAction ui' verbosity distPref) NormalCommand
-wrapperAction :: Monoid flags
- => CommandUI flags
- -> (flags -> Flag Verbosity)
- -> (flags -> Flag String)
- -> Command Action
+wrapperAction
+ :: Monoid flags
+ => CommandUI flags
+ -> (flags -> Flag Verbosity)
+ -> (flags -> Flag String)
+ -> Command Action
wrapperAction command verbosityFlag distPrefFlag =
- commandAddAction command
- { commandDefaultFlags = mempty } $ \flags extraArgs globalFlags -> do
- let verbosity = fromFlagOrDefault normal (verbosityFlag flags)
- load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
- let config = either (\(SomeException _) -> mempty) id load
- distPref <- findSavedDistPref config (distPrefFlag flags)
- let setupScriptOptions = defaultSetupScriptOptions { useDistPref = distPref }
- setupWrapper verbosity setupScriptOptions Nothing
- command (const flags) (const extraArgs)
-
-configureAction :: (ConfigFlags, ConfigExFlags)
- -> [String] -> Action
+ commandAddAction
+ command
+ { commandDefaultFlags = mempty
+ }
+ $ \flags extraArgs globalFlags -> do
+ let verbosity = fromFlagOrDefault normal (verbosityFlag flags)
+ load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
+ let config = either (\(SomeException _) -> mempty) id load
+ distPref <- findSavedDistPref config (distPrefFlag flags)
+ let setupScriptOptions = defaultSetupScriptOptions{useDistPref = distPref}
+ setupWrapper
+ verbosity
+ setupScriptOptions
+ Nothing
+ command
+ (const flags)
+ (const extraArgs)
+
+configureAction
+ :: (ConfigFlags, ConfigExFlags)
+ -> [String]
+ -> Action
configureAction (configFlags, configExFlags) extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
- config <- updateInstallDirs (configUserInstall configFlags)
- <$> loadConfigOrSandboxConfig verbosity globalFlags
+ config <-
+ updateInstallDirs (configUserInstall configFlags)
+ <$> loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (configDistPref configFlags)
nixInstantiate verbosity distPref True globalFlags config
nixShell verbosity distPref globalFlags config $ do
- let configFlags' = savedConfigureFlags config `mappend` configFlags
+ let configFlags' = savedConfigureFlags config `mappend` configFlags
configExFlags' = savedConfigureExFlags config `mappend` configExFlags
- globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, progdb) <- configCompilerAuxEx configFlags'
writeConfigFlags verbosity distPref (configFlags', configExFlags')
-- What package database(s) to use
let packageDBs :: PackageDBStack
- packageDBs
- = interpretPackageDbFlags
+ packageDBs =
+ interpretPackageDbFlags
(fromFlag (configUserInstall configFlags'))
(configPackageDBs configFlags')
withRepoContext verbosity globalFlags' $ \repoContext ->
- configure verbosity packageDBs repoContext
- comp platform progdb configFlags' configExFlags' extraArgs
-
-reconfigureAction :: (ConfigFlags, ConfigExFlags)
- -> [String] -> Action
+ configure
+ verbosity
+ packageDBs
+ repoContext
+ comp
+ platform
+ progdb
+ configFlags'
+ configExFlags'
+ extraArgs
+
+reconfigureAction
+ :: (ConfigFlags, ConfigExFlags)
+ -> [String]
+ -> Action
reconfigureAction flags@(configFlags, _) _ globalFlags = do
let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)
- config <- updateInstallDirs (configUserInstall configFlags)
- <$> loadConfigOrSandboxConfig verbosity globalFlags
+ config <-
+ updateInstallDirs (configUserInstall configFlags)
+ <$> loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (configDistPref configFlags)
let checkFlags = Check $ \_ saved -> do
let flags' = saved <> flags
@@ -387,15 +517,21 @@ reconfigureAction flags@(configFlags, _) _ globalFlags = do
where
-- This message is correct, but not very specific: it will list all
-- of the new flags, even if some have not actually changed. The
- -- *minimal* set of changes is more difficult to determine.
+ -- \*minimal* set of changes is more difficult to determine.
message =
"flags changed: "
- ++ unwords (commandShowOptions configureExCommand flags)
+ ++ unwords (commandShowOptions configureExCommand flags)
nixInstantiate verbosity distPref True globalFlags config
_ <-
- reconfigure configureAction
- verbosity distPref NoFlag
- checkFlags [] globalFlags config
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ NoFlag
+ checkFlags
+ []
+ globalFlags
+ config
pure ()
buildAction :: BuildFlags -> [String] -> Action
@@ -406,56 +542,69 @@ buildAction buildFlags extraArgs globalFlags = do
-- Calls 'configureAction' to do the real work, so nothing special has to be
-- done to support sandboxes.
config' <-
- reconfigure configureAction
- verbosity distPref (buildNumJobs buildFlags)
- mempty [] globalFlags config
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ (buildNumJobs buildFlags)
+ mempty
+ []
+ globalFlags
+ config
nixShell verbosity distPref globalFlags config $ do
build verbosity config' distPref buildFlags extraArgs
-
-- | Actually do the work of building the package. This is separate from
-- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke
-- 'reconfigure' twice.
build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()
build verbosity config distPref buildFlags extraArgs =
- setupWrapper verbosity setupOptions Nothing
- (Cabal.buildCommand progDb) mkBuildFlags (const extraArgs)
+ setupWrapper
+ verbosity
+ setupOptions
+ Nothing
+ (Cabal.buildCommand progDb)
+ mkBuildFlags
+ (const extraArgs)
where
- progDb = defaultProgramDb
- setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
+ progDb = defaultProgramDb
+ setupOptions = defaultSetupScriptOptions{useDistPref = distPref}
mkBuildFlags version = filterBuildFlags version config buildFlags'
- buildFlags' = buildFlags
- { buildVerbosity = toFlag verbosity
- , buildDistPref = toFlag distPref
- }
+ buildFlags' =
+ buildFlags
+ { buildVerbosity = toFlag verbosity
+ , buildDistPref = toFlag distPref
+ }
-- | Make sure that we don't pass new flags to setup scripts compiled against
-- old versions of Cabal.
filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags
filterBuildFlags version config buildFlags
- | version >= mkVersion [1,19,1] = buildFlags_latest
+ | version >= mkVersion [1, 19, 1] = buildFlags_latest
-- Cabal < 1.19.1 doesn't support 'build -j'.
- | otherwise = buildFlags_pre_1_19_1
+ | otherwise = buildFlags_pre_1_19_1
where
- buildFlags_pre_1_19_1 = buildFlags {
- buildNumJobs = NoFlag
- }
- buildFlags_latest = buildFlags {
- -- Take the 'jobs' setting config file into account.
- buildNumJobs = Flag . Just . determineNumJobs $
- (numJobsConfigFlag `mappend` numJobsCmdLineFlag)
- }
- numJobsConfigFlag = installNumJobs . savedInstallFlags $ config
+ buildFlags_pre_1_19_1 =
+ buildFlags
+ { buildNumJobs = NoFlag
+ }
+ buildFlags_latest =
+ buildFlags
+ { -- Take the 'jobs' setting config file into account.
+ buildNumJobs =
+ Flag . Just . determineNumJobs $
+ (numJobsConfigFlag `mappend` numJobsCmdLineFlag)
+ }
+ numJobsConfigFlag = installNumJobs . savedInstallFlags $ config
numJobsCmdLineFlag = buildNumJobs buildFlags
-
replAction :: ReplFlags -> [String] -> Action
replAction replFlags extraArgs globalFlags = do
let verbosity = fromFlagOrDefault normal (replVerbosity replFlags)
config <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (replDistPref replFlags)
- cwd <- getCurrentDirectory
+ cwd <- getCurrentDirectory
pkgDesc <- findPackageDesc cwd
let
-- There is a .cabal file in the current directory: start a REPL and load
@@ -464,18 +613,26 @@ replAction replFlags extraArgs globalFlags = do
-- Calls 'configureAction' to do the real work, so nothing special has to
-- be done to support sandboxes.
_ <-
- reconfigure configureAction
- verbosity distPref NoFlag
- mempty [] globalFlags config
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ NoFlag
+ mempty
+ []
+ globalFlags
+ config
let progDb = defaultProgramDb
- setupOptions = defaultSetupScriptOptions
- { useCabalVersion = orLaterVersion $ mkVersion [1,18,0]
- , useDistPref = distPref
- }
- replFlags' = replFlags
- { replVerbosity = toFlag verbosity
- , replDistPref = toFlag distPref
- }
+ setupOptions =
+ defaultSetupScriptOptions
+ { useCabalVersion = orLaterVersion $ mkVersion [1, 18, 0]
+ , useDistPref = distPref
+ }
+ replFlags' =
+ replFlags
+ { replVerbosity = toFlag verbosity
+ , replDistPref = toFlag distPref
+ }
nixShell verbosity distPref globalFlags config $
setupWrapper verbosity setupOptions Nothing (Cabal.replCommand progDb) (const replFlags') (const extraArgs)
@@ -485,130 +642,189 @@ replAction replFlags extraArgs globalFlags = do
onNoPkgDesc = do
let configFlags = savedConfigureFlags config
(comp, platform, programDb) <- configCompilerAux' configFlags
- programDb' <- reconfigurePrograms verbosity
- (replProgramPaths replFlags)
- (replProgramArgs replFlags)
- programDb
+ programDb' <-
+ reconfigurePrograms
+ verbosity
+ (replProgramPaths replFlags)
+ (replProgramArgs replFlags)
+ programDb
nixShell verbosity distPref globalFlags config $ do
- startInterpreter verbosity programDb' comp platform
- (configPackageDB' configFlags)
+ startInterpreter
+ verbosity
+ programDb'
+ comp
+ platform
+ (configPackageDB' configFlags)
either (const onNoPkgDesc) (const onPkgDesc) pkgDesc
-installAction :: ( ConfigFlags, ConfigExFlags, InstallFlags
- , HaddockFlags, TestFlags, BenchmarkFlags )
- -> [String] -> Action
+installAction
+ :: ( ConfigFlags
+ , ConfigExFlags
+ , InstallFlags
+ , HaddockFlags
+ , TestFlags
+ , BenchmarkFlags
+ )
+ -> [String]
+ -> Action
installAction (configFlags, _, installFlags, _, _, _) _ globalFlags
| fromFlagOrDefault False (installOnly installFlags) = do
let verb = fromFlagOrDefault normal (configVerbosity configFlags)
config <- loadConfigOrSandboxConfig verb globalFlags
dist <- findSavedDistPref config (configDistPref configFlags)
- let setupOpts = defaultSetupScriptOptions { useDistPref = dist }
+ let setupOpts = defaultSetupScriptOptions{useDistPref = dist}
setupWrapper
- verb setupOpts Nothing
- installCommand (const (mempty, mempty, mempty, mempty, mempty, mempty))
- (const [])
-
+ verb
+ setupOpts
+ Nothing
+ installCommand
+ (const (mempty, mempty, mempty, mempty, mempty, mempty))
+ (const [])
installAction
- ( configFlags, configExFlags, installFlags
- , haddockFlags, testFlags, benchmarkFlags )
- extraArgs globalFlags = do
- let verb = fromFlagOrDefault normal (configVerbosity configFlags)
- config <- updateInstallDirs (configUserInstall configFlags)
- <$> loadConfigOrSandboxConfig verb globalFlags
-
- dist <- findSavedDistPref config (configDistPref configFlags)
-
- do
- targets <- readUserTargets verb extraArgs
-
- let configFlags' = maybeForceTests installFlags' $
- savedConfigureFlags config `mappend`
- configFlags { configDistPref = toFlag dist }
- configExFlags' = defaultConfigExFlags `mappend`
- savedConfigureExFlags config `mappend` configExFlags
- installFlags' = defaultInstallFlags `mappend`
- savedInstallFlags config `mappend` installFlags
- haddockFlags' = defaultHaddockFlags `mappend`
- savedHaddockFlags config `mappend`
- haddockFlags { haddockDistPref = toFlag dist }
- testFlags' = Cabal.defaultTestFlags `mappend`
- savedTestFlags config `mappend`
- testFlags { testDistPref = toFlag dist }
- benchmarkFlags' = Cabal.defaultBenchmarkFlags `mappend`
- savedBenchmarkFlags config `mappend`
- benchmarkFlags { benchmarkDistPref = toFlag dist }
- globalFlags' = savedGlobalFlags config `mappend` globalFlags
- (comp, platform, progdb) <- configCompilerAux' configFlags'
-
- -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the
- -- future.
- progdb' <- configureAllKnownPrograms verb progdb
-
- configFlags'' <- configAbsolutePaths configFlags'
-
- withRepoContext verb globalFlags' $ \repoContext ->
- install verb
- (configPackageDB' configFlags'')
- repoContext
- comp platform progdb'
- globalFlags' configFlags'' configExFlags'
- installFlags' haddockFlags' testFlags' benchmarkFlags'
- targets
-
- where
- -- '--run-tests' implies '--enable-tests'.
- maybeForceTests installFlags' configFlags' =
- if fromFlagOrDefault False (installRunTests installFlags')
- then configFlags' { configTests = toFlag True }
+ ( configFlags
+ , configExFlags
+ , installFlags
+ , haddockFlags
+ , testFlags
+ , benchmarkFlags
+ )
+ extraArgs
+ globalFlags = do
+ let verb = fromFlagOrDefault normal (configVerbosity configFlags)
+ config <-
+ updateInstallDirs (configUserInstall configFlags)
+ <$> loadConfigOrSandboxConfig verb globalFlags
+
+ dist <- findSavedDistPref config (configDistPref configFlags)
+
+ do
+ targets <- readUserTargets verb extraArgs
+
+ let configFlags' =
+ maybeForceTests installFlags' $
+ savedConfigureFlags config
+ `mappend` configFlags{configDistPref = toFlag dist}
+ configExFlags' =
+ defaultConfigExFlags
+ `mappend` savedConfigureExFlags config
+ `mappend` configExFlags
+ installFlags' =
+ defaultInstallFlags
+ `mappend` savedInstallFlags config
+ `mappend` installFlags
+ haddockFlags' =
+ defaultHaddockFlags
+ `mappend` savedHaddockFlags config
+ `mappend` haddockFlags{haddockDistPref = toFlag dist}
+ testFlags' =
+ Cabal.defaultTestFlags
+ `mappend` savedTestFlags config
+ `mappend` testFlags{testDistPref = toFlag dist}
+ benchmarkFlags' =
+ Cabal.defaultBenchmarkFlags
+ `mappend` savedBenchmarkFlags config
+ `mappend` benchmarkFlags{benchmarkDistPref = toFlag dist}
+ globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ (comp, platform, progdb) <- configCompilerAux' configFlags'
+
+ -- TODO: Redesign ProgramDB API to prevent such problems as #2241 in the
+ -- future.
+ progdb' <- configureAllKnownPrograms verb progdb
+
+ configFlags'' <- configAbsolutePaths configFlags'
+
+ withRepoContext verb globalFlags' $ \repoContext ->
+ install
+ verb
+ (configPackageDB' configFlags'')
+ repoContext
+ comp
+ platform
+ progdb'
+ globalFlags'
+ configFlags''
+ configExFlags'
+ installFlags'
+ haddockFlags'
+ testFlags'
+ benchmarkFlags'
+ targets
+ where
+ -- '--run-tests' implies '--enable-tests'.
+ maybeForceTests installFlags' configFlags' =
+ if fromFlagOrDefault False (installRunTests installFlags')
+ then configFlags'{configTests = toFlag True}
else configFlags'
-testAction :: (BuildFlags, TestFlags) -> [String] -> GlobalFlags
- -> IO ()
+testAction
+ :: (BuildFlags, TestFlags)
+ -> [String]
+ -> GlobalFlags
+ -> IO ()
testAction (buildFlags, testFlags) extraArgs globalFlags = do
- let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
+ let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
config <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (testDistPref testFlags)
- let buildFlags' = buildFlags
- { buildVerbosity = testVerbosity testFlags }
+ let buildFlags' =
+ buildFlags
+ { buildVerbosity = testVerbosity testFlags
+ }
checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
if fromFlagOrDefault False (configTests configFlags)
then pure (mempty, flags)
else do
info verbosity "reconfiguring to enable tests"
- let flags' = ( configFlags { configTests = toFlag True }
- , configExFlags
- )
+ let flags' =
+ ( configFlags{configTests = toFlag True}
+ , configExFlags
+ )
pure (Any True, flags')
_ <-
- reconfigure configureAction
- verbosity distPref (buildNumJobs buildFlags')
- checkFlags [] globalFlags config
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ (buildNumJobs buildFlags')
+ checkFlags
+ []
+ globalFlags
+ config
nixShell verbosity distPref globalFlags config $ do
- let setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
- testFlags' = testFlags { testDistPref = toFlag distPref }
+ let setupOptions = defaultSetupScriptOptions{useDistPref = distPref}
+ testFlags' = testFlags{testDistPref = toFlag distPref}
-- The package was just configured, so the LBI must be available.
- names <- componentNamesFromLBI verbosity distPref "test suites"
- (\c -> case c of { LBI.CTest{} -> True; _ -> False })
+ names <-
+ componentNamesFromLBI
+ verbosity
+ distPref
+ "test suites"
+ (\c -> case c of LBI.CTest{} -> True; _ -> False)
let extraArgs'
| null extraArgs = case names of
- ComponentNamesUnknown -> []
- ComponentNames names' -> [ Make.unUnqualComponentName name
- | LBI.CTestName name <- names' ]
- | otherwise = extraArgs
+ ComponentNamesUnknown -> []
+ ComponentNames names' ->
+ [ Make.unUnqualComponentName name
+ | LBI.CTestName name <- names'
+ ]
+ | otherwise = extraArgs
build verbosity config distPref buildFlags' extraArgs'
setupWrapper verbosity setupOptions Nothing Cabal.testCommand (const testFlags') (const extraArgs')
-data ComponentNames = ComponentNamesUnknown
- | ComponentNames [LBI.ComponentName]
+data ComponentNames
+ = ComponentNamesUnknown
+ | ComponentNames [LBI.ComponentName]
-- | Return the names of all buildable components matching a given predicate.
-componentNamesFromLBI :: Verbosity -> FilePath -> String
- -> (LBI.Component -> Bool)
- -> IO ComponentNames
+componentNamesFromLBI
+ :: Verbosity
+ -> FilePath
+ -> String
+ -> (LBI.Component -> Bool)
+ -> IO ComponentNames
componentNamesFromLBI verbosity distPref targetsDescr compPred = do
eLBI <- tryGetPersistBuildConfig distPref
case eLBI of
@@ -617,64 +833,87 @@ componentNamesFromLBI verbosity distPref targetsDescr compPred = do
-- script built against a different Cabal version, so it's crucial that
-- we ignore the bad version error here.
ConfigStateFileBadVersion _ _ _ -> return ComponentNamesUnknown
- _ -> die' verbosity (show err)
+ _ -> die' verbosity (show err)
Right lbi -> do
let pkgDescr = LBI.localPkgDescr lbi
- names = map LBI.componentName
- . filter (buildable . LBI.componentBuildInfo)
- . filter compPred $
- LBI.pkgComponents pkgDescr
+ names =
+ map LBI.componentName
+ . filter (buildable . LBI.componentBuildInfo)
+ . filter compPred
+ $ LBI.pkgComponents pkgDescr
if null names
- then do notice verbosity $ "Package has no buildable "
- ++ targetsDescr ++ "."
- exitSuccess -- See #3215.
-
+ then do
+ notice verbosity $
+ "Package has no buildable "
+ ++ targetsDescr
+ ++ "."
+ exitSuccess -- See #3215.
else return $! (ComponentNames names)
-benchmarkAction :: (BuildFlags, BenchmarkFlags)
- -> [String] -> GlobalFlags
- -> IO ()
+benchmarkAction
+ :: (BuildFlags, BenchmarkFlags)
+ -> [String]
+ -> GlobalFlags
+ -> IO ()
benchmarkAction
(buildFlags, benchmarkFlags)
- extraArgs globalFlags = do
- let verbosity = fromFlagOrDefault normal
- (buildVerbosity buildFlags)
-
- config <- loadConfigOrSandboxConfig verbosity globalFlags
- distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)
- let buildFlags' = buildFlags
- { buildVerbosity = benchmarkVerbosity benchmarkFlags }
-
- let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
- if fromFlagOrDefault False (configBenchmarks configFlags)
- then pure (mempty, flags)
- else do
- info verbosity "reconfiguring to enable benchmarks"
- let flags' = ( configFlags { configBenchmarks = toFlag True }
- , configExFlags
- )
- pure (Any True, flags')
-
- config' <-
- reconfigure configureAction
- verbosity distPref (buildNumJobs buildFlags')
- checkFlags [] globalFlags config
- nixShell verbosity distPref globalFlags config $ do
- let setupOptions = defaultSetupScriptOptions { useDistPref = distPref }
- benchmarkFlags'= benchmarkFlags { benchmarkDistPref = toFlag distPref }
-
- -- The package was just configured, so the LBI must be available.
- names <- componentNamesFromLBI verbosity distPref "benchmarks"
- (\c -> case c of { LBI.CBench{} -> True; _ -> False; })
- let extraArgs'
- | null extraArgs = case names of
- ComponentNamesUnknown -> []
- ComponentNames names' -> [ Make.unUnqualComponentName name
- | LBI.CBenchName name <- names']
- | otherwise = extraArgs
+ extraArgs
+ globalFlags = do
+ let verbosity =
+ fromFlagOrDefault
+ normal
+ (buildVerbosity buildFlags)
+
+ config <- loadConfigOrSandboxConfig verbosity globalFlags
+ distPref <- findSavedDistPref config (benchmarkDistPref benchmarkFlags)
+ let buildFlags' =
+ buildFlags
+ { buildVerbosity = benchmarkVerbosity benchmarkFlags
+ }
- build verbosity config' distPref buildFlags' extraArgs'
- setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs')
+ let checkFlags = Check $ \_ flags@(configFlags, configExFlags) ->
+ if fromFlagOrDefault False (configBenchmarks configFlags)
+ then pure (mempty, flags)
+ else do
+ info verbosity "reconfiguring to enable benchmarks"
+ let flags' =
+ ( configFlags{configBenchmarks = toFlag True}
+ , configExFlags
+ )
+ pure (Any True, flags')
+
+ config' <-
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ (buildNumJobs buildFlags')
+ checkFlags
+ []
+ globalFlags
+ config
+ nixShell verbosity distPref globalFlags config $ do
+ let setupOptions = defaultSetupScriptOptions{useDistPref = distPref}
+ benchmarkFlags' = benchmarkFlags{benchmarkDistPref = toFlag distPref}
+
+ -- The package was just configured, so the LBI must be available.
+ names <-
+ componentNamesFromLBI
+ verbosity
+ distPref
+ "benchmarks"
+ (\c -> case c of LBI.CBench{} -> True; _ -> False)
+ let extraArgs'
+ | null extraArgs = case names of
+ ComponentNamesUnknown -> []
+ ComponentNames names' ->
+ [ Make.unUnqualComponentName name
+ | LBI.CBenchName name <- names'
+ ]
+ | otherwise = extraArgs
+
+ build verbosity config' distPref buildFlags' extraArgs'
+ setupWrapper verbosity setupOptions Nothing Cabal.benchmarkCommand (const benchmarkFlags') (const extraArgs')
haddockAction :: HaddockFlags -> [String] -> Action
haddockAction haddockFlags extraArgs globalFlags = do
@@ -682,17 +921,31 @@ haddockAction haddockFlags extraArgs globalFlags = do
config <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (haddockDistPref haddockFlags)
config' <-
- reconfigure configureAction
- verbosity distPref NoFlag
- mempty [] globalFlags config
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ NoFlag
+ mempty
+ []
+ globalFlags
+ config
nixShell verbosity distPref globalFlags config $ do
- let haddockFlags' = defaultHaddockFlags `mappend`
- savedHaddockFlags config' `mappend`
- haddockFlags { haddockDistPref = toFlag distPref }
- setupScriptOptions = defaultSetupScriptOptions
- { useDistPref = distPref }
- setupWrapper verbosity setupScriptOptions Nothing
- haddockCommand (const haddockFlags') (const extraArgs)
+ let haddockFlags' =
+ defaultHaddockFlags
+ `mappend` savedHaddockFlags config'
+ `mappend` haddockFlags{haddockDistPref = toFlag distPref}
+ setupScriptOptions =
+ defaultSetupScriptOptions
+ { useDistPref = distPref
+ }
+ setupWrapper
+ verbosity
+ setupScriptOptions
+ Nothing
+ haddockCommand
+ (const haddockFlags')
+ (const extraArgs)
when (haddockForHackage haddockFlags == Flag ForHackage) $ do
pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
let dest = distPref </> name <.> "tar.gz"
@@ -706,13 +959,19 @@ cleanAction cleanFlags extraArgs globalFlags = do
load <- try (loadConfigOrSandboxConfig verbosity globalFlags)
let config = either (\(SomeException _) -> mempty) id load
distPref <- findSavedDistPref config (cleanDistPref cleanFlags)
- let setupScriptOptions = defaultSetupScriptOptions
- { useDistPref = distPref
- , useWin32CleanHack = True
- }
- cleanFlags' = cleanFlags { cleanDistPref = toFlag distPref }
- setupWrapper verbosity setupScriptOptions Nothing
- cleanCommand (const cleanFlags') (const extraArgs)
+ let setupScriptOptions =
+ defaultSetupScriptOptions
+ { useDistPref = distPref
+ , useWin32CleanHack = True
+ }
+ cleanFlags' = cleanFlags{cleanDistPref = toFlag distPref}
+ setupWrapper
+ verbosity
+ setupScriptOptions
+ Nothing
+ cleanCommand
+ (const cleanFlags')
+ (const extraArgs)
where
verbosity = fromFlagOrDefault normal (cleanVerbosity cleanFlags)
@@ -721,24 +980,28 @@ listAction listFlags extraArgs globalFlags = do
let verbosity = fromFlag (listVerbosity listFlags)
config <- loadConfigOrSandboxConfig verbosity globalFlags
let configFlags' = savedConfigureFlags config
- configFlags = configFlags'
- { configPackageDBs = configPackageDBs configFlags'
- `mappend` listPackageDBs listFlags
- , configHcPath = listHcPath listFlags
- }
- globalFlags' = savedGlobalFlags config `mappend` globalFlags
- compProgdb <- if listNeedsCompiler listFlags
+ configFlags =
+ configFlags'
+ { configPackageDBs =
+ configPackageDBs configFlags'
+ `mappend` listPackageDBs listFlags
+ , configHcPath = listHcPath listFlags
+ }
+ globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ compProgdb <-
+ if listNeedsCompiler listFlags
then do
- (comp, _, progdb) <- configCompilerAux' configFlags
- return (Just (comp, progdb))
+ (comp, _, progdb) <- configCompilerAux' configFlags
+ return (Just (comp, progdb))
else return Nothing
withRepoContext verbosity globalFlags' $ \repoContext ->
- List.list verbosity
- (configPackageDB' configFlags)
- repoContext
- compProgdb
- listFlags
- extraArgs
+ List.list
+ verbosity
+ (configPackageDB' configFlags)
+ repoContext
+ compProgdb
+ listFlags
+ extraArgs
infoAction :: InfoFlags -> [String] -> Action
infoAction infoFlags extraArgs globalFlags = do
@@ -746,36 +1009,44 @@ infoAction infoFlags extraArgs globalFlags = do
targets <- readUserTargets verbosity extraArgs
config <- loadConfigOrSandboxConfig verbosity globalFlags
let configFlags' = savedConfigureFlags config
- configFlags = configFlags' {
- configPackageDBs = configPackageDBs configFlags'
- `mappend` infoPackageDBs infoFlags
- }
- globalFlags' = savedGlobalFlags config `mappend` globalFlags
+ configFlags =
+ configFlags'
+ { configPackageDBs =
+ configPackageDBs configFlags'
+ `mappend` infoPackageDBs infoFlags
+ }
+ globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, _, progdb) <- configCompilerAuxEx configFlags
withRepoContext verbosity globalFlags' $ \repoContext ->
- List.info verbosity
- (configPackageDB' configFlags)
- repoContext
- comp
- progdb
- globalFlags'
- infoFlags
- targets
+ List.info
+ verbosity
+ (configPackageDB' configFlags)
+ repoContext
+ comp
+ progdb
+ globalFlags'
+ infoFlags
+ targets
fetchAction :: FetchFlags -> [String] -> Action
fetchAction fetchFlags extraArgs globalFlags = do
let verbosity = fromFlag (fetchVerbosity fetchFlags)
targets <- readUserTargets verbosity extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags)
- let configFlags = savedConfigureFlags config
+ let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, progdb) <- configCompilerAux' configFlags
withRepoContext verbosity globalFlags' $ \repoContext ->
- fetch verbosity
- (configPackageDB' configFlags)
- repoContext
- comp platform progdb globalFlags' fetchFlags
- targets
+ fetch
+ verbosity
+ (configPackageDB' configFlags)
+ repoContext
+ comp
+ platform
+ progdb
+ globalFlags'
+ fetchFlags
+ targets
freezeAction :: FreezeFlags -> [String] -> Action
freezeAction freezeFlags _extraArgs globalFlags = do
@@ -783,16 +1054,20 @@ freezeAction freezeFlags _extraArgs globalFlags = do
config <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config NoFlag
nixShell verbosity distPref globalFlags config $ do
- let configFlags = savedConfigureFlags config
+ let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, progdb) <- configCompilerAux' configFlags
withRepoContext verbosity globalFlags' $ \repoContext ->
- freeze verbosity
- (configPackageDB' configFlags)
- repoContext
- comp platform progdb
- globalFlags' freezeFlags
+ freeze
+ verbosity
+ (configPackageDB' configFlags)
+ repoContext
+ comp
+ platform
+ progdb
+ globalFlags'
+ freezeFlags
genBoundsAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()
genBoundsAction freezeFlags _extraArgs globalFlags = do
@@ -800,76 +1075,91 @@ genBoundsAction freezeFlags _extraArgs globalFlags = do
config <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config NoFlag
nixShell verbosity distPref globalFlags config $ do
- let configFlags = savedConfigureFlags config
+ let configFlags = savedConfigureFlags config
globalFlags' = savedGlobalFlags config `mappend` globalFlags
(comp, platform, progdb) <- configCompilerAux' configFlags
withRepoContext verbosity globalFlags' $ \repoContext ->
- genBounds verbosity
- (configPackageDB' configFlags)
- repoContext
- comp platform progdb
- globalFlags' freezeFlags
+ genBounds
+ verbosity
+ (configPackageDB' configFlags)
+ repoContext
+ comp
+ platform
+ progdb
+ globalFlags'
+ freezeFlags
uploadAction :: UploadFlags -> [String] -> Action
uploadAction uploadFlags extraArgs globalFlags = do
config <- loadConfig verbosity (globalConfigFile globalFlags)
let uploadFlags' = savedUploadFlags config `mappend` uploadFlags
globalFlags' = savedGlobalFlags config `mappend` globalFlags
- tarfiles = extraArgs
+ tarfiles = extraArgs
when (null tarfiles && not (fromFlag (uploadDoc uploadFlags'))) $
die' verbosity "the 'upload' command expects at least one .tar.gz archive."
checkTarFiles extraArgs
maybe_password <-
- case uploadPasswordCmd uploadFlags'
- of Flag (xs:xss) -> Just . Password <$>
- getProgramInvocationOutput verbosity
- (simpleProgramInvocation xs xss)
- _ -> pure $ flagToMaybe $ uploadPassword uploadFlags'
+ case uploadPasswordCmd uploadFlags' of
+ Flag (xs : xss) ->
+ Just . Password
+ <$> getProgramInvocationOutput
+ verbosity
+ (simpleProgramInvocation xs xss)
+ _ -> pure $ flagToMaybe $ uploadPassword uploadFlags'
withRepoContext verbosity globalFlags' $ \repoContext -> do
if fromFlag (uploadDoc uploadFlags')
- then do
- when (length tarfiles > 1) $
- die' verbosity $ "the 'upload' command can only upload documentation "
- ++ "for one package at a time."
- tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles
- Upload.uploadDoc verbosity
- repoContext
- (flagToMaybe $ uploadUsername uploadFlags')
- maybe_password
- (fromFlag (uploadCandidate uploadFlags'))
- tarfile
- else do
- Upload.upload verbosity
- repoContext
- (flagToMaybe $ uploadUsername uploadFlags')
- maybe_password
- (fromFlag (uploadCandidate uploadFlags'))
- tarfiles
- where
+ then do
+ when (length tarfiles > 1) $
+ die' verbosity $
+ "the 'upload' command can only upload documentation "
+ ++ "for one package at a time."
+ tarfile <- maybe (generateDocTarball config) return $ listToMaybe tarfiles
+ Upload.uploadDoc
+ verbosity
+ repoContext
+ (flagToMaybe $ uploadUsername uploadFlags')
+ maybe_password
+ (fromFlag (uploadCandidate uploadFlags'))
+ tarfile
+ else do
+ Upload.upload
+ verbosity
+ repoContext
+ (flagToMaybe $ uploadUsername uploadFlags')
+ maybe_password
+ (fromFlag (uploadCandidate uploadFlags'))
+ tarfiles
+ where
verbosity = fromFlag (uploadVerbosity uploadFlags)
checkTarFiles tarfiles
- | not (null otherFiles)
- = die' verbosity $ "the 'upload' command expects only .tar.gz archives: "
- ++ intercalate ", " otherFiles
- | otherwise = sequence_
- [ do exists <- doesFileExist tarfile
- unless exists $ die' verbosity $ "file not found: " ++ tarfile
- | tarfile <- tarfiles ]
-
- where otherFiles = filter (not . isTarGzFile) tarfiles
- isTarGzFile file = case splitExtension file of
- (file', ".gz") -> takeExtension file' == ".tar"
- _ -> False
+ | not (null otherFiles) =
+ die' verbosity $
+ "the 'upload' command expects only .tar.gz archives: "
+ ++ intercalate ", " otherFiles
+ | otherwise =
+ sequence_
+ [ do
+ exists <- doesFileExist tarfile
+ unless exists $ die' verbosity $ "file not found: " ++ tarfile
+ | tarfile <- tarfiles
+ ]
+ where
+ otherFiles = filter (not . isTarGzFile) tarfiles
+ isTarGzFile file = case splitExtension file of
+ (file', ".gz") -> takeExtension file' == ".tar"
+ _ -> False
generateDocTarball config = do
notice verbosity $
"No documentation tarball specified. "
- ++ "Building a documentation tarball with default settings...\n"
- ++ "If you need to customise Haddock options, "
- ++ "run 'haddock --for-hackage' first "
- ++ "to generate a documentation tarball."
- haddockAction (defaultHaddockFlags { haddockForHackage = Flag ForHackage })
- [] globalFlags
+ ++ "Building a documentation tarball with default settings...\n"
+ ++ "If you need to customise Haddock options, "
+ ++ "run 'haddock --for-hackage' first "
+ ++ "to generate a documentation tarball."
+ haddockAction
+ (defaultHaddockFlags{haddockForHackage = Flag ForHackage})
+ []
+ globalFlags
distPref <- findSavedDistPref config NoFlag
pkg <- fmap LBI.localPkgDescr (getPersistBuildConfig distPref)
return $ distPref </> display (packageId pkg) ++ "-docs" <.> "tar.gz"
@@ -878,7 +1168,8 @@ checkAction :: Flag Verbosity -> [String] -> Action
checkAction verbosityFlag extraArgs _globalFlags = do
let verbosity = fromFlag verbosityFlag
unless (null extraArgs) $
- die' verbosity $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
+ die' verbosity $
+ "'check' doesn't take any extra arguments: " ++ unwords extraArgs
allOk <- Check.check (fromFlag verbosityFlag)
unless allOk exitFailure
@@ -886,9 +1177,10 @@ formatAction :: Flag Verbosity -> [String] -> Action
formatAction verbosityFlag extraArgs _globalFlags = do
let verbosity = fromFlag verbosityFlag
path <- case extraArgs of
- [] -> do cwd <- getCurrentDirectory
- tryFindPackageDesc verbosity cwd
- (p:_) -> return p
+ [] -> do
+ cwd <- getCurrentDirectory
+ tryFindPackageDesc verbosity cwd
+ (p : _) -> return p
pkgDesc <- readGenericPackageDescription verbosity path
-- Uses 'writeFileAtomic' under the hood.
writeGenericPackageDescription path pkgDesc
@@ -897,25 +1189,34 @@ reportAction :: ReportFlags -> [String] -> Action
reportAction reportFlags extraArgs globalFlags = do
let verbosity = fromFlag (reportVerbosity reportFlags)
unless (null extraArgs) $
- die' verbosity $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
+ die' verbosity $
+ "'report' doesn't take any extra arguments: " ++ unwords extraArgs
config <- loadConfig verbosity (globalConfigFile globalFlags)
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
reportFlags' = savedReportFlags config `mappend` reportFlags
withRepoContext verbosity globalFlags' $ \repoContext ->
- Upload.report verbosity repoContext
- (flagToMaybe $ reportUsername reportFlags')
- (flagToMaybe $ reportPassword reportFlags')
+ Upload.report
+ verbosity
+ repoContext
+ (flagToMaybe $ reportUsername reportFlags')
+ (flagToMaybe $ reportPassword reportFlags')
runAction :: BuildFlags -> [String] -> Action
runAction buildFlags extraArgs globalFlags = do
- let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
+ let verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)
config <- loadConfigOrSandboxConfig verbosity globalFlags
distPref <- findSavedDistPref config (buildDistPref buildFlags)
config' <-
- reconfigure configureAction
- verbosity distPref (buildNumJobs buildFlags)
- mempty [] globalFlags config
+ reconfigure
+ configureAction
+ verbosity
+ distPref
+ (buildNumJobs buildFlags)
+ mempty
+ []
+ globalFlags
+ config
nixShell verbosity distPref globalFlags config $ do
lbi <- getPersistBuildConfig distPref
(exe, exeArgs) <- splitRunArgs verbosity lbi extraArgs
@@ -930,11 +1231,12 @@ getAction getFlags extraArgs globalFlags = do
config <- loadConfigOrSandboxConfig verbosity globalFlags
let globalFlags' = savedGlobalFlags config `mappend` globalFlags
withRepoContext verbosity (savedGlobalFlags config) $ \repoContext ->
- get verbosity
- repoContext
- globalFlags'
- getFlags
- targets
+ get
+ verbosity
+ repoContext
+ globalFlags'
+ getFlags
+ targets
unpackAction :: GetFlags -> [String] -> Action
unpackAction getFlags extraArgs globalFlags = do
@@ -949,9 +1251,10 @@ initAction initFlags extraArgs globalFlags = do
[projectDir] -> do
createDirectoryIfMissingVerbose verbosity True projectDir
withCurrentDirectory projectDir initAction'
- _ -> die' verbosity $
- "'init' only takes a single, optional, extra " ++
- "argument for the project root directory"
+ _ ->
+ die' verbosity $
+ "'init' only takes a single, optional, extra "
+ ++ "argument for the project root directory"
where
initAction' = do
confFlags <- loadConfigOrSandboxConfig verbosity globalFlags
@@ -963,51 +1266,60 @@ initAction initFlags extraArgs globalFlags = do
(comp, _, progdb) <- configCompilerAux' confFlags'
withRepoContext verbosity globalFlags' $ \repoContext ->
- initCmd verbosity (configPackageDB' confFlags')
- repoContext comp progdb initFlags'
+ initCmd
+ verbosity
+ (configPackageDB' confFlags')
+ repoContext
+ comp
+ progdb
+ initFlags'
verbosity = fromFlag (initVerbosity initFlags)
- compFlags = mempty { configHcPath = initHcPath initFlags }
+ compFlags = mempty{configHcPath = initHcPath initFlags}
userConfigAction :: UserConfigFlags -> [String] -> Action
userConfigAction ucflags extraArgs globalFlags = do
- let verbosity = fromFlag (userConfigVerbosity ucflags)
- frc = fromFlag (userConfigForce ucflags)
+ let verbosity = fromFlag (userConfigVerbosity ucflags)
+ frc = fromFlag (userConfigForce ucflags)
extraLines = fromFlag (userConfigAppendLines ucflags)
case extraArgs of
- ("init":_) -> do
- path <- configFile
+ ("init" : _) -> do
+ path <- configFile
fileExists <- doesFileExist path
if (not fileExists || (fileExists && frc))
- then void $ createDefaultConfigFile verbosity extraLines path
- else die' verbosity $ path ++ " already exists."
- ("diff":_) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines
- ("update":_) -> userConfigUpdate verbosity globalFlags extraLines
+ then void $ createDefaultConfigFile verbosity extraLines path
+ else die' verbosity $ path ++ " already exists."
+ ("diff" : _) -> traverse_ putStrLn =<< userConfigDiff verbosity globalFlags extraLines
+ ("update" : _) -> userConfigUpdate verbosity globalFlags extraLines
-- Error handling.
[] -> die' verbosity $ "Please specify a subcommand (see 'help user-config')"
- _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs
- where configFile = getConfigFilePath (globalConfigFile globalFlags)
+ _ -> die' verbosity $ "Unknown 'user-config' subcommand: " ++ unwords extraArgs
+ where
+ configFile = getConfigFilePath (globalConfigFile globalFlags)
-- | Used as an entry point when cabal-install needs to invoke itself
-- as a setup script. This can happen e.g. when doing parallel builds.
---
actAsSetupAction :: ActAsSetupFlags -> [String] -> Action
actAsSetupAction actAsSetupFlags args _globalFlags =
let bt = fromFlag (actAsSetupBuildType actAsSetupFlags)
- in case bt of
- Simple -> Simple.defaultMainArgs args
- Configure -> Simple.defaultMainWithHooksArgs
- Simple.autoconfUserHooks args
- Make -> Make.defaultMainArgs args
- Custom -> error "actAsSetupAction Custom"
+ in case bt of
+ Simple -> Simple.defaultMainArgs args
+ Configure ->
+ Simple.defaultMainWithHooksArgs
+ Simple.autoconfUserHooks
+ args
+ Make -> Make.defaultMainArgs args
+ Custom -> error "actAsSetupAction Custom"
manpageAction :: [CommandSpec action] -> ManpageFlags -> [String] -> Action
manpageAction commands flags extraArgs _ = do
let verbosity = fromFlag (manpageVerbosity flags)
unless (null extraArgs) $
- die' verbosity $ "'man' doesn't take any extra arguments: " ++ unwords extraArgs
+ die' verbosity $
+ "'man' doesn't take any extra arguments: " ++ unwords extraArgs
pname <- getProgName
- let cabalCmd = if takeExtension pname == ".exe"
- then dropExtension pname
- else pname
+ let cabalCmd =
+ if takeExtension pname == ".exe"
+ then dropExtension pname
+ else pname
manpageCmd cabalCmd commands flags
diff --git a/cabal-install/src/Distribution/Client/Manpage.hs b/cabal-install/src/Distribution/Client/Manpage.hs
index 34023c7bd488ffa53088542ebf22c08959573d8d..7bdb5bc1eb60363a4ebd4a5167607d878b7cd47a 100644
--- a/cabal-install/src/Distribution/Client/Manpage.hs
+++ b/cabal-install/src/Distribution/Client/Manpage.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE CPP #-}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Manpage
-- Copyright : (c) Maciek Makowski 2015
@@ -10,7 +12,6 @@
-- Portability : portable
--
-- Functions for building the manual page.
-
module Distribution.Client.Manpage
( -- * Manual page generation
manpage
@@ -20,24 +21,32 @@ module Distribution.Client.Manpage
, manpageOptions
) where
+import qualified Data.List.NonEmpty as List1
import Distribution.Client.Compat.Prelude
import Prelude ()
-import qualified Data.List.NonEmpty as List1
-import Distribution.Client.Init.Utils (trim)
+import Distribution.Client.Init.Utils (trim)
import Distribution.Client.ManpageFlags
-import Distribution.Client.Setup (globalCommand)
-import Distribution.Compat.Process (proc)
+import Distribution.Client.Setup (globalCommand)
+import Distribution.Compat.Process (proc)
import Distribution.Simple.Command
-import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault)
+import Distribution.Simple.Flag (fromFlag, fromFlagOrDefault)
import Distribution.Simple.Utils
- ( IOData(..), IODataMode(..), ignoreSigPipe, rawSystemStdInOut, rawSystemProcAction,
- fromCreatePipe, die' )
-import System.IO (hClose, hPutStr)
-import System.Environment (lookupEnv)
+ ( IOData (..)
+ , IODataMode (..)
+ , die'
+ , fromCreatePipe
+ , ignoreSigPipe
+ , rawSystemProcAction
+ , rawSystemStdInOut
+ )
+import System.Environment (lookupEnv)
+import System.IO (hClose, hPutStr)
import qualified System.Process as Process
-data FileInfo = FileInfo String String -- ^ path, description
+data FileInfo
+ = -- | path, description
+ FileInfo String String
-------------------------------------------------------------------------------
--
@@ -51,10 +60,10 @@ files =
manpageCmd :: String -> [CommandSpec a] -> ManpageFlags -> IO ()
manpageCmd pname commands flags
- | fromFlagOrDefault False (manpageRaw flags)
- = putStrLn contents
- | otherwise
- = ignoreSigPipe $ do
+ | fromFlagOrDefault False (manpageRaw flags) =
+ putStrLn contents
+ | otherwise =
+ ignoreSigPipe $ do
-- 2021-10-08, issue #7714
-- @cabal man --raw | man -l -@ does not work on macOS/BSD,
-- because BSD-man does not support option @-l@, rather would
@@ -67,29 +76,31 @@ manpageCmd pname commands flags
-- So let us simulate this!
-- Feed contents into @nroff -man /dev/stdin@
- (formatted, _errors, ec1) <- rawSystemStdInOut
- verbosity
- "nroff"
- [ "-man", "/dev/stdin" ]
- Nothing -- Inherit working directory
- Nothing -- Inherit environment
- (Just $ IODataText contents)
- IODataModeText
+ (formatted, _errors, ec1) <-
+ rawSystemStdInOut
+ verbosity
+ "nroff"
+ ["-man", "/dev/stdin"]
+ Nothing -- Inherit working directory
+ Nothing -- Inherit environment
+ (Just $ IODataText contents)
+ IODataModeText
unless (ec1 == ExitSuccess) $ exitWith ec1
pagerAndArgs <- fromMaybe "less -R" <$> lookupEnv "PAGER"
-- 'less' is borked with color sequences otherwise, hence -R
(pager, pagerArgs) <- case words pagerAndArgs of
- [] -> die' verbosity "man: empty value of the PAGER environment variable"
- (p:pa) -> pure (p, pa)
+ [] -> die' verbosity "man: empty value of the PAGER environment variable"
+ (p : pa) -> pure (p, pa)
-- Pipe output of @nroff@ into @less@
- (ec2, _) <- rawSystemProcAction verbosity
- (proc pager pagerArgs) { Process.std_in = Process.CreatePipe }
- $ \mIn _ _ -> do
- let wIn = fromCreatePipe mIn
- hPutStr wIn formatted
- hClose wIn
+ (ec2, _) <- rawSystemProcAction
+ verbosity
+ (proc pager pagerArgs){Process.std_in = Process.CreatePipe}
+ $ \mIn _ _ -> do
+ let wIn = fromCreatePipe mIn
+ hPutStr wIn formatted
+ hClose wIn
exitWith ec2
where
contents :: String
@@ -98,46 +109,47 @@ manpageCmd pname commands flags
-- | Produces a manual page with @troff@ markup.
manpage :: String -> [CommandSpec a] -> String
-manpage pname commands = unlines $
- [ ".TH " ++ map toUpper pname ++ " 1"
- , ".SH NAME"
- , pname ++ " \\- a system for building and packaging Haskell libraries and programs"
- , ".SH SYNOPSIS"
- , ".B " ++ pname
- , ".I command"
- , ".RI < arguments |[ options ]>..."
- , ""
- , "Where the"
- , ".I commands"
- , "are"
- , ""
- ] ++
- concatMap (commandSynopsisLines pname) commands ++
- [ ".SH DESCRIPTION"
- , "Cabal is the standard package system for Haskell software. It helps people to configure, "
- , "build and install Haskell software and to distribute it easily to other users and developers."
- , ""
- , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "
- , "installing existing packages and developing new packages. "
- , "It can be used to work with local packages or to install packages from online package archives, "
- , "including automatically installing dependencies. By default it is configured to use Hackage, "
- , "which is Haskell's central package archive that contains thousands of libraries and applications "
- , "in the Cabal package format."
- , ".SH OPTIONS"
- , "Global options:"
- , ""
- ] ++
- optionsLines (globalCommand []) ++
- [ ".SH COMMANDS"
- ] ++
- concatMap (commandDetailsLines pname) commands ++
- [ ".SH FILES"
- ] ++
- concatMap fileLines files ++
- [ ".SH BUGS"
- , "To browse the list of known issues or report a new one please see "
- , "https://github.com/haskell/cabal/labels/cabal-install."
- ]
+manpage pname commands =
+ unlines $
+ [ ".TH " ++ map toUpper pname ++ " 1"
+ , ".SH NAME"
+ , pname ++ " \\- a system for building and packaging Haskell libraries and programs"
+ , ".SH SYNOPSIS"
+ , ".B " ++ pname
+ , ".I command"
+ , ".RI < arguments |[ options ]>..."
+ , ""
+ , "Where the"
+ , ".I commands"
+ , "are"
+ , ""
+ ]
+ ++ concatMap (commandSynopsisLines pname) commands
+ ++ [ ".SH DESCRIPTION"
+ , "Cabal is the standard package system for Haskell software. It helps people to configure, "
+ , "build and install Haskell software and to distribute it easily to other users and developers."
+ , ""
+ , "The command line " ++ pname ++ " tool (also referred to as cabal-install) helps with "
+ , "installing existing packages and developing new packages. "
+ , "It can be used to work with local packages or to install packages from online package archives, "
+ , "including automatically installing dependencies. By default it is configured to use Hackage, "
+ , "which is Haskell's central package archive that contains thousands of libraries and applications "
+ , "in the Cabal package format."
+ , ".SH OPTIONS"
+ , "Global options:"
+ , ""
+ ]
+ ++ optionsLines (globalCommand [])
+ ++ [ ".SH COMMANDS"
+ ]
+ ++ concatMap (commandDetailsLines pname) commands
+ ++ [ ".SH FILES"
+ ]
+ ++ concatMap fileLines files
+ ++ [ ".SH BUGS"
+ , "To browse the list of known issues or report a new one please see "
+ , "https://github.com/haskell/cabal/labels/cabal-install."
+ ]
commandSynopsisLines :: String -> CommandSpec action -> [String]
commandSynopsisLines pname (CommandSpec ui _ NormalCommand) =
@@ -153,37 +165,37 @@ commandDetailsLines pname (CommandSpec ui _ NormalCommand) =
, ""
, commandUsage ui pname
, ""
- ] ++
- optional removeLineBreaks commandDescription ++
- optional id commandNotes ++
- [ "Flags:"
- , ".RS"
- ] ++
- optionsLines ui ++
- [ ".RE"
- , ""
]
+ ++ optional removeLineBreaks commandDescription
+ ++ optional id commandNotes
+ ++ [ "Flags:"
+ , ".RS"
+ ]
+ ++ optionsLines ui
+ ++ [ ".RE"
+ , ""
+ ]
where
optional f field =
case field ui of
- Just text -> [ f $ text pname, "" ]
- Nothing -> []
+ Just text -> [f $ text pname, ""]
+ Nothing -> []
-- 2021-10-12, https://github.com/haskell/cabal/issues/7714#issuecomment-940842905
-- Line breaks just before e.g. 'new-build' cause weird @nroff@ warnings.
-- Thus:
-- Remove line breaks but preserve paragraph breaks.
-- We group lines by empty/non-empty and then 'unwords'
-- blocks consisting of non-empty lines.
- removeLineBreaks
- = unlines
- . concatMap unwordsNonEmpty
- . List1.groupWith null
- . map trim
- . lines
+ removeLineBreaks =
+ unlines
+ . concatMap unwordsNonEmpty
+ . List1.groupWith null
+ . map trim
+ . lines
unwordsNonEmpty :: List1.NonEmpty String -> [String]
unwordsNonEmpty ls1 = if null (List1.head ls1) then ls else [unwords ls]
- where ls = List1.toList ls1
-
+ where
+ ls = List1.toList ls1
commandDetailsLines _ (CommandSpec _ _ HiddenCommand) = []
optionsLines :: CommandUI flags -> [String]
@@ -198,27 +210,28 @@ optionLines (ReqArg description (optionChars, optionStrings) placeHolder _ _) =
optionLines (OptArg description (optionChars, optionStrings) placeHolder _ _ _) =
argOptionLines description optionChars optionStrings (Optional, placeHolder)
optionLines (BoolOpt description (trueChars, trueStrings) (falseChars, falseStrings) _ _) =
- optionLinesIfPresent trueChars trueStrings ++
- optionLinesIfPresent falseChars falseStrings ++
- optionDescriptionLines description
+ optionLinesIfPresent trueChars trueStrings
+ ++ optionLinesIfPresent falseChars falseStrings
+ ++ optionDescriptionLines description
optionLines (ChoiceOpt options) =
concatMap choiceLines options
where
choiceLines (description, (optionChars, optionStrings), _, _) =
- [ optionsLine optionChars optionStrings ] ++
- optionDescriptionLines description
+ [optionsLine optionChars optionStrings]
+ ++ optionDescriptionLines description
argOptionLines :: String -> [Char] -> [String] -> OptionArg -> [String]
argOptionLines description optionChars optionStrings arg =
[ optionsLine optionChars optionStrings
, optionArgLine arg
- ] ++
- optionDescriptionLines description
+ ]
+ ++ optionDescriptionLines description
optionLinesIfPresent :: [Char] -> [String] -> [String]
optionLinesIfPresent optionChars optionStrings =
- if null optionChars && null optionStrings then []
- else [ optionsLine optionChars optionStrings, ".br" ]
+ if null optionChars && null optionStrings
+ then []
+ else [optionsLine optionChars optionStrings, ".br"]
optionDescriptionLines :: String -> [String]
optionDescriptionLines description =
diff --git a/cabal-install/src/Distribution/Client/ManpageFlags.hs b/cabal-install/src/Distribution/Client/ManpageFlags.hs
index 79ed9e5dc6a9085a5470b29fb290069a1e6de4a0..ba76e314af281140c461fec1722fbf7bb031c8be 100644
--- a/cabal-install/src/Distribution/Client/ManpageFlags.hs
+++ b/cabal-install/src/Distribution/Client/ManpageFlags.hs
@@ -1,23 +1,25 @@
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase #-}
+
module Distribution.Client.ManpageFlags
-( ManpageFlags (..)
-, defaultManpageFlags
-, manpageOptions,
-) where
+ ( ManpageFlags (..)
+ , defaultManpageFlags
+ , manpageOptions
+ ) where
import Distribution.Client.Compat.Prelude
import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs (..), option)
-import Distribution.Simple.Setup (Flag (..), toFlag, trueArg, optionVerbosity)
-import Distribution.Verbosity (normal)
+import Distribution.Simple.Setup (Flag (..), optionVerbosity, toFlag, trueArg)
+import Distribution.Verbosity (normal)
data ManpageFlags = ManpageFlags
{ manpageVerbosity :: Flag Verbosity
- , manpageRaw :: Flag Bool
- } deriving (Eq, Show, Generic)
+ , manpageRaw :: Flag Bool
+ }
+ deriving (Eq, Show, Generic)
-instance Monoid ManpageFlags where
+instance Monoid ManpageFlags where
mempty = gmempty
mappend = (<>)
@@ -25,16 +27,20 @@ instance Semigroup ManpageFlags where
(<>) = gmappend
defaultManpageFlags :: ManpageFlags
-defaultManpageFlags = ManpageFlags
+defaultManpageFlags =
+ ManpageFlags
{ manpageVerbosity = toFlag normal
- , manpageRaw = toFlag False
+ , manpageRaw = toFlag False
}
manpageOptions :: ShowOrParseArgs -> [OptionField ManpageFlags]
manpageOptions _ =
- [ optionVerbosity manpageVerbosity (\v flags -> flags { manpageVerbosity = v })
- , option "" ["raw"]
+ [ optionVerbosity manpageVerbosity (\v flags -> flags{manpageVerbosity = v})
+ , option
+ ""
+ ["raw"]
"Output raw troff content"
- manpageRaw (\v flags -> flags { manpageRaw = v })
+ manpageRaw
+ (\v flags -> flags{manpageRaw = v})
trueArg
- ]
+ ]
diff --git a/cabal-install/src/Distribution/Client/Nix.hs b/cabal-install/src/Distribution/Client/Nix.hs
index 4798f8e8be95640daba1da00d0bdba3667f77378..34a12f9157b8cb8d99259efb6aa2d8c5304bc770 100644
--- a/cabal-install/src/Distribution/Client/Nix.hs
+++ b/cabal-install/src/Distribution/Client/Nix.hs
@@ -2,67 +2,82 @@
{-# LANGUAGE ViewPatterns #-}
module Distribution.Client.Nix
- ( findNixExpr
- , inNixShell
- , nixInstantiate
- , nixShell
- ) where
+ ( findNixExpr
+ , inNixShell
+ , nixInstantiate
+ , nixShell
+ ) where
import Distribution.Client.Compat.Prelude
import Control.Exception (bracket)
import System.Directory
- ( canonicalizePath, createDirectoryIfMissing, doesDirectoryExist
- , doesFileExist, removeDirectoryRecursive, removeFile )
+ ( canonicalizePath
+ , createDirectoryIfMissing
+ , doesDirectoryExist
+ , doesFileExist
+ , removeDirectoryRecursive
+ , removeFile
+ )
import System.Environment (getArgs, getExecutablePath)
import System.FilePath
- ( (</>), replaceExtension, takeDirectory, takeFileName )
-import System.IO (IOMode(..), hClose, openFile)
+ ( replaceExtension
+ , takeDirectory
+ , takeFileName
+ , (</>)
+ )
+import System.IO (IOMode (..), hClose, openFile)
import System.IO.Error (isDoesNotExistError)
import System.Process (showCommandForUser)
import Distribution.Compat.Environment
- ( lookupEnv, setEnv, unsetEnv )
+ ( lookupEnv
+ , setEnv
+ , unsetEnv
+ )
import Distribution.Simple.Program
- ( Program(..), ProgramDb
- , addKnownProgram, configureProgram, emptyProgramDb, getDbProgramOutput
- , runDbProgram, simpleProgram )
+ ( Program (..)
+ , ProgramDb
+ , addKnownProgram
+ , configureProgram
+ , emptyProgramDb
+ , getDbProgramOutput
+ , runDbProgram
+ , simpleProgram
+ )
import Distribution.Simple.Setup (fromFlagOrDefault)
import Distribution.Simple.Utils (debug, existsAndIsMoreRecentThan)
-import Distribution.Client.Config (SavedConfig(..))
-import Distribution.Client.GlobalFlags (GlobalFlags(..))
-
+import Distribution.Client.Config (SavedConfig (..))
+import Distribution.Client.GlobalFlags (GlobalFlags (..))
configureOneProgram :: Verbosity -> Program -> IO ProgramDb
configureOneProgram verb prog =
configureProgram verb prog (addKnownProgram prog emptyProgramDb)
-
touchFile :: FilePath -> IO ()
touchFile path = do
catch (removeFile path) (\e -> when (isDoesNotExistError e) (return ()))
createDirectoryIfMissing True (takeDirectory path)
openFile path WriteMode >>= hClose
-
findNixExpr :: GlobalFlags -> SavedConfig -> IO (Maybe FilePath)
findNixExpr globalFlags config = do
-- criteria for deciding to run nix-shell
let nixEnabled =
- fromFlagOrDefault False
- (globalNix (savedGlobalFlags config) <> globalNix globalFlags)
+ fromFlagOrDefault
+ False
+ (globalNix (savedGlobalFlags config) <> globalNix globalFlags)
if nixEnabled
then do
- let exprPaths = [ "shell.nix", "default.nix" ]
+ let exprPaths = ["shell.nix", "default.nix"]
filterM doesFileExist exprPaths >>= \case
[] -> return Nothing
(path : _) -> return (Just path)
else return Nothing
-
-- set IN_NIX_SHELL so that builtins.getEnv in Nix works as in nix-shell
inFakeNixShell :: IO a -> IO a
inFakeNixShell f =
@@ -74,7 +89,6 @@ inFakeNixShell f =
return old
resetEnv var = maybe (unsetEnv var) (setEnv var)
-
nixInstantiate
:: Verbosity
-> FilePath
@@ -96,30 +110,32 @@ nixInstantiate verb dist force' globalFlags config =
let ready = alreadyInShell || (instantiated && upToDate && not force')
unless ready $ do
-
let prog = simpleProgram "nix-instantiate"
progdb <- configureOneProgram verb prog
removeGCRoots verb dist
touchFile timestamp
- _ <- inFakeNixShell
- (getDbProgramOutput verb prog progdb
- [ "--add-root", shellDrv, "--indirect", shellNix ])
+ _ <-
+ inFakeNixShell
+ ( getDbProgramOutput
+ verb
+ prog
+ progdb
+ ["--add-root", shellDrv, "--indirect", shellNix]
+ )
return ()
-
nixShell
:: Verbosity
-> FilePath
-> GlobalFlags
-> SavedConfig
-> IO ()
- -- ^ The action to perform inside a nix-shell. This is also the action
- -- that will be performed immediately if Nix is disabled.
+ -- ^ The action to perform inside a nix-shell. This is also the action
+ -- that will be performed immediately if Nix is disabled.
-> IO ()
nixShell verb dist globalFlags config go = do
-
alreadyInShell <- inNixShell
if alreadyInShell
@@ -128,7 +144,6 @@ nixShell verb dist globalFlags config go = do
findNixExpr globalFlags config >>= \case
Nothing -> go
Just shellNix -> do
-
let prog = simpleProgram "nix-shell"
progdb <- configureOneProgram verb prog
@@ -143,12 +158,18 @@ nixShell verb dist globalFlags config go = do
-- automatically.
shellDrv <- drvPath dist shellNix
args <- getArgs
- runDbProgram verb prog progdb
- [ "--add-root", gcrootPath dist </> "result", "--indirect", shellDrv
- , "--run", showCommandForUser cabal args
+ runDbProgram
+ verb
+ prog
+ progdb
+ [ "--add-root"
+ , gcrootPath dist </> "result"
+ , "--indirect"
+ , shellDrv
+ , "--run"
+ , showCommandForUser cabal args
]
-
drvPath :: FilePath -> FilePath -> IO FilePath
drvPath dist path = do
-- We do not actually care about canonicity, but makeAbsolute is only
@@ -159,20 +180,16 @@ drvPath dist path = do
-- Nix garbage collector roots must be absolute paths
return (distNix </> replaceExtension (takeFileName path) "drv")
-
timestampPath :: FilePath -> FilePath -> FilePath
timestampPath dist path =
dist </> "nix" </> replaceExtension (takeFileName path) "drv.timestamp"
-
gcrootPath :: FilePath -> FilePath
gcrootPath dist = dist </> "nix" </> "gcroots"
-
inNixShell :: IO Bool
inNixShell = isJust <$> lookupEnv "CABAL_IN_NIX_SHELL"
-
removeGCRoots :: Verbosity -> FilePath -> IO ()
removeGCRoots verb dist = do
let tgt = gcrootPath dist
diff --git a/cabal-install/src/Distribution/Client/NixStyleOptions.hs b/cabal-install/src/Distribution/Client/NixStyleOptions.hs
index 965ef74c5beb9037400bc3351a38a30feb4900b6..2e9bfb913821212ae65f6a998e36e8c213d94b4f 100644
--- a/cabal-install/src/Distribution/Client/NixStyleOptions.hs
+++ b/cabal-install/src/Distribution/Client/NixStyleOptions.hs
@@ -4,84 +4,123 @@
--
-- The commands take a lot of the same options, which affect how install plan
-- is constructed.
-module Distribution.Client.NixStyleOptions (
- NixStyleFlags (..),
- nixStyleOptions,
- defaultNixStyleFlags,
-) where
+module Distribution.Client.NixStyleOptions
+ ( NixStyleFlags (..)
+ , nixStyleOptions
+ , defaultNixStyleFlags
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs)
-import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags)
-import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))
+import Distribution.Simple.Command (OptionField (..), ShowOrParseArgs)
+import Distribution.Simple.Setup (BenchmarkFlags, HaddockFlags, TestFlags)
+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))
import Distribution.Client.ProjectFlags
- (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions)
+ ( ProjectFlags (..)
+ , defaultProjectFlags
+ , projectFlagsOptions
+ )
import Distribution.Client.Setup
- (ConfigExFlags, ConfigFlags (..), InstallFlags (..), benchmarkOptions, configureExOptions,
- configureOptions, haddockOptions, installOptions, liftOptions, testOptions)
+ ( ConfigExFlags
+ , ConfigFlags (..)
+ , InstallFlags (..)
+ , benchmarkOptions
+ , configureExOptions
+ , configureOptions
+ , haddockOptions
+ , installOptions
+ , liftOptions
+ , testOptions
+ )
data NixStyleFlags a = NixStyleFlags
- { configFlags :: ConfigFlags
- , configExFlags :: ConfigExFlags
- , installFlags :: InstallFlags
- , haddockFlags :: HaddockFlags
- , testFlags :: TestFlags
- , benchmarkFlags :: BenchmarkFlags
- , projectFlags :: ProjectFlags
- , extraFlags :: a
- }
+ { configFlags :: ConfigFlags
+ , configExFlags :: ConfigExFlags
+ , installFlags :: InstallFlags
+ , haddockFlags :: HaddockFlags
+ , testFlags :: TestFlags
+ , benchmarkFlags :: BenchmarkFlags
+ , projectFlags :: ProjectFlags
+ , extraFlags :: a
+ }
nixStyleOptions
- :: (ShowOrParseArgs -> [OptionField a])
- -> ShowOrParseArgs -> [OptionField (NixStyleFlags a)]
+ :: (ShowOrParseArgs -> [OptionField a])
+ -> ShowOrParseArgs
+ -> [OptionField (NixStyleFlags a)]
nixStyleOptions commandOptions showOrParseArgs =
- liftOptions configFlags set1
- -- Note: [Hidden Flags]
- -- hide "constraint", "dependency", and
- -- "exact-configuration" from the configure options.
- (filter ((`notElem` ["constraint", "dependency"
- , "exact-configuration"])
- . optionName) $ configureOptions showOrParseArgs)
- ++ liftOptions configExFlags set2 (configureExOptions showOrParseArgs
- ConstraintSourceCommandlineFlag)
- ++ liftOptions installFlags set3
- -- hide "target-package-db" and "symlink-bindir" flags from the
- -- install options.
- -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags
- (filter ((`notElem` ["target-package-db", "symlink-bindir"])
- . optionName) $
- installOptions showOrParseArgs)
- ++ liftOptions haddockFlags set4
- -- hide "verbose" and "builddir" flags from the
- -- haddock options.
- (filter ((`notElem` ["v", "verbose", "builddir"])
- . optionName) $
- haddockOptions showOrParseArgs)
- ++ liftOptions testFlags set5 (testOptions showOrParseArgs)
- ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs)
- ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs)
- ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs)
+ liftOptions
+ configFlags
+ set1
+ -- Note: [Hidden Flags]
+ -- hide "constraint", "dependency", and
+ -- "exact-configuration" from the configure options.
+ ( filter
+ ( ( `notElem`
+ [ "constraint"
+ , "dependency"
+ , "exact-configuration"
+ ]
+ )
+ . optionName
+ )
+ $ configureOptions showOrParseArgs
+ )
+ ++ liftOptions
+ configExFlags
+ set2
+ ( configureExOptions
+ showOrParseArgs
+ ConstraintSourceCommandlineFlag
+ )
+ ++ liftOptions
+ installFlags
+ set3
+ -- hide "target-package-db" and "symlink-bindir" flags from the
+ -- install options.
+ -- "symlink-bindir" is obsoleted by "installdir" in ClientInstallFlags
+ ( filter
+ ( (`notElem` ["target-package-db", "symlink-bindir"])
+ . optionName
+ )
+ $ installOptions showOrParseArgs
+ )
+ ++ liftOptions
+ haddockFlags
+ set4
+ -- hide "verbose" and "builddir" flags from the
+ -- haddock options.
+ ( filter
+ ( (`notElem` ["v", "verbose", "builddir"])
+ . optionName
+ )
+ $ haddockOptions showOrParseArgs
+ )
+ ++ liftOptions testFlags set5 (testOptions showOrParseArgs)
+ ++ liftOptions benchmarkFlags set6 (benchmarkOptions showOrParseArgs)
+ ++ liftOptions projectFlags set7 (projectFlagsOptions showOrParseArgs)
+ ++ liftOptions extraFlags set8 (commandOptions showOrParseArgs)
where
- set1 x flags = flags { configFlags = x }
- set2 x flags = flags { configExFlags = x }
- set3 x flags = flags { installFlags = x }
- set4 x flags = flags { haddockFlags = x }
- set5 x flags = flags { testFlags = x }
- set6 x flags = flags { benchmarkFlags = x }
- set7 x flags = flags { projectFlags = x }
- set8 x flags = flags { extraFlags = x }
+ set1 x flags = flags{configFlags = x}
+ set2 x flags = flags{configExFlags = x}
+ set3 x flags = flags{installFlags = x}
+ set4 x flags = flags{haddockFlags = x}
+ set5 x flags = flags{testFlags = x}
+ set6 x flags = flags{benchmarkFlags = x}
+ set7 x flags = flags{projectFlags = x}
+ set8 x flags = flags{extraFlags = x}
-defaultNixStyleFlags :: a -> NixStyleFlags a
-defaultNixStyleFlags x = NixStyleFlags
- { configFlags = mempty
- , configExFlags = mempty
- , installFlags = mempty
- , haddockFlags = mempty
- , testFlags = mempty
+defaultNixStyleFlags :: a -> NixStyleFlags a
+defaultNixStyleFlags x =
+ NixStyleFlags
+ { configFlags = mempty
+ , configExFlags = mempty
+ , installFlags = mempty
+ , haddockFlags = mempty
+ , testFlags = mempty
, benchmarkFlags = mempty
- , projectFlags = defaultProjectFlags
- , extraFlags = x
+ , projectFlags = defaultProjectFlags
+ , extraFlags = x
}
diff --git a/cabal-install/src/Distribution/Client/PackageHash.hs b/cabal-install/src/Distribution/Client/PackageHash.hs
index d2a3d1d901d7213cf4cd8e6cb9913a7c5ff3b5ea..18be444cde71b15af0fe58a0f126ceff464ce4a2 100644
--- a/cabal-install/src/Distribution/Client/PackageHash.hs
+++ b/cabal-install/src/Distribution/Client/PackageHash.hs
@@ -1,5 +1,7 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Functions to calculate nix-style hashes for package ids.
--
@@ -8,40 +10,56 @@
-- * the package tarball
-- * the ids of all the direct dependencies
-- * other local configuration (flags, profiling, etc)
---
-module Distribution.Client.PackageHash (
- -- * Calculating package hashes
- PackageHashInputs(..),
- PackageHashConfigInputs(..),
- PackageSourceHash,
- hashedInstalledPackageId,
- hashPackageHashInputs,
- renderPackageHashInputs,
+module Distribution.Client.PackageHash
+ ( -- * Calculating package hashes
+ PackageHashInputs (..)
+ , PackageHashConfigInputs (..)
+ , PackageSourceHash
+ , hashedInstalledPackageId
+ , hashPackageHashInputs
+ , renderPackageHashInputs
+
-- ** Platform-specific variations
- hashedInstalledPackageIdLong,
- hashedInstalledPackageIdShort,
+ , hashedInstalledPackageIdLong
+ , hashedInstalledPackageIdShort
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
+import Distribution.Client.HashValue
+import Distribution.Client.Types
+ ( InstalledPackageId
+ )
import Distribution.Package
- ( PackageId, PackageIdentifier(..), mkComponentId
- , PkgconfigName )
-import Distribution.System
- ( Platform, OS(Windows, OSX), buildOS )
-import Distribution.Types.Flag
- ( FlagAssignment, showFlagAssignment )
+ ( PackageId
+ , PackageIdentifier (..)
+ , PkgconfigName
+ , mkComponentId
+ )
import Distribution.Simple.Compiler
- ( CompilerId, OptimisationLevel(..), DebugInfoLevel(..)
- , ProfDetailLevel(..), PackageDB, showProfDetailLevel )
+ ( CompilerId
+ , DebugInfoLevel (..)
+ , OptimisationLevel (..)
+ , PackageDB
+ , ProfDetailLevel (..)
+ , showProfDetailLevel
+ )
import Distribution.Simple.InstallDirs
- ( PathTemplate, fromPathTemplate )
-import Distribution.Types.PkgconfigVersion (PkgconfigVersion)
-import Distribution.Client.HashValue
-import Distribution.Client.Types
- ( InstalledPackageId )
+ ( PathTemplate
+ , fromPathTemplate
+ )
import qualified Distribution.Solver.Types.ComponentDeps as CD
+import Distribution.System
+ ( OS (OSX, Windows)
+ , Platform
+ , buildOS
+ )
+import Distribution.Types.Flag
+ ( FlagAssignment
+ , showFlagAssignment
+ )
+import Distribution.Types.PkgconfigVersion (PkgconfigVersion)
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as Map
@@ -57,36 +75,34 @@ import qualified Data.Set as Set
-- Note that due to path length limitations on Windows, this function uses
-- a different method on Windows that produces shorted package ids.
-- See 'hashedInstalledPackageIdLong' vs 'hashedInstalledPackageIdShort'.
---
hashedInstalledPackageId :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageId
| buildOS == Windows = hashedInstalledPackageIdShort
- | buildOS == OSX = hashedInstalledPackageIdVeryShort
- | otherwise = hashedInstalledPackageIdLong
+ | buildOS == OSX = hashedInstalledPackageIdVeryShort
+ | otherwise = hashedInstalledPackageIdLong
-- | Calculate a 'InstalledPackageId' for a package using our nix-style
-- inputs hashing method.
--
-- This produces large ids with big hashes. It is only suitable for systems
-- without significant path length limitations (ie not Windows).
---
hashedInstalledPackageIdLong :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdLong
- pkghashinputs@PackageHashInputs{pkgHashPkgId,pkgHashComponent}
- = mkComponentId $
- prettyShow pkgHashPkgId -- to be a bit user friendly
+ pkghashinputs@PackageHashInputs{pkgHashPkgId, pkgHashComponent} =
+ mkComponentId $
+ prettyShow pkgHashPkgId -- to be a bit user friendly
++ maybe "" displayComponent pkgHashComponent
++ "-"
++ showHashValue (hashPackageHashInputs pkghashinputs)
- where
- displayComponent :: CD.Component -> String
- displayComponent CD.ComponentLib = ""
- displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s
- displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s
- displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s
- displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s
- displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s
- displayComponent CD.ComponentSetup = "-setup"
+ where
+ displayComponent :: CD.Component -> String
+ displayComponent CD.ComponentLib = ""
+ displayComponent (CD.ComponentSubLib s) = "-l-" ++ prettyShow s
+ displayComponent (CD.ComponentFLib s) = "-f-" ++ prettyShow s
+ displayComponent (CD.ComponentExe s) = "-e-" ++ prettyShow s
+ displayComponent (CD.ComponentTest s) = "-t-" ++ prettyShow s
+ displayComponent (CD.ComponentBench s) = "-b-" ++ prettyShow s
+ displayComponent CD.ComponentSetup = "-setup"
-- | On Windows we have serious problems with path lengths. Windows imposes a
-- maximum path length of 260 chars, and even if we can use the windows long
@@ -105,22 +121,23 @@ hashedInstalledPackageIdLong
-- Truncating the hash size is disappointing but also technically ok. We
-- rely on the hash primarily for collision avoidance not for any security
-- properties (at least for now).
---
hashedInstalledPackageIdShort :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
- mkComponentId $
- intercalate "-"
- -- max length now 64
- [ truncateStr 14 (prettyShow name)
- , truncateStr 8 (prettyShow version)
- , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))
- ]
+ mkComponentId $
+ intercalate
+ "-"
+ -- max length now 64
+ [ truncateStr 14 (prettyShow name)
+ , truncateStr 8 (prettyShow version)
+ , showHashValue (truncateHash 20 (hashPackageHashInputs pkghashinputs))
+ ]
where
PackageIdentifier name version = pkgHashPkgId
-- Truncate a string, with a visual indication that it is truncated.
- truncateStr n s | length s <= n = s
- | otherwise = take (n-1) s ++ "_"
+ truncateStr n s
+ | length s <= n = s
+ | otherwise = take (n - 1) s ++ "_"
-- | On macOS we shorten the name very aggressively. The mach-o linker on
-- macOS has a limited load command size, to which the name of the library
@@ -148,7 +165,8 @@ hashedInstalledPackageIdShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
hashedInstalledPackageIdVeryShort :: PackageHashInputs -> InstalledPackageId
hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId} =
mkComponentId $
- intercalate "-"
+ intercalate
+ "-"
[ filter (not . flip elem "aeiou") (prettyShow name)
, prettyShow version
, showHashValue (truncateHash 4 (hashPackageHashInputs pkghashinputs))
@@ -158,95 +176,89 @@ hashedInstalledPackageIdVeryShort pkghashinputs@PackageHashInputs{pkgHashPkgId}
-- | All the information that contributes to a package's hash, and thus its
-- 'InstalledPackageId'.
---
-data PackageHashInputs = PackageHashInputs {
- pkgHashPkgId :: PackageId,
- pkgHashComponent :: Maybe CD.Component,
- pkgHashSourceHash :: PackageSourceHash,
- pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion),
- pkgHashDirectDeps :: Set InstalledPackageId,
- pkgHashOtherConfig :: PackageHashConfigInputs
- }
+data PackageHashInputs = PackageHashInputs
+ { pkgHashPkgId :: PackageId
+ , pkgHashComponent :: Maybe CD.Component
+ , pkgHashSourceHash :: PackageSourceHash
+ , pkgHashPkgConfigDeps :: Set (PkgconfigName, Maybe PkgconfigVersion)
+ , pkgHashDirectDeps :: Set InstalledPackageId
+ , pkgHashOtherConfig :: PackageHashConfigInputs
+ }
type PackageSourceHash = HashValue
-- | Those parts of the package configuration that contribute to the
-- package hash.
---
-data PackageHashConfigInputs = PackageHashConfigInputs {
- pkgHashCompilerId :: CompilerId,
- pkgHashPlatform :: Platform,
- pkgHashFlagAssignment :: FlagAssignment, -- complete not partial
- pkgHashConfigureScriptArgs :: [String], -- just ./configure for build-type Configure
- pkgHashVanillaLib :: Bool,
- pkgHashSharedLib :: Bool,
- pkgHashDynExe :: Bool,
- pkgHashFullyStaticExe :: Bool,
- pkgHashGHCiLib :: Bool,
- pkgHashProfLib :: Bool,
- pkgHashProfExe :: Bool,
- pkgHashProfLibDetail :: ProfDetailLevel,
- pkgHashProfExeDetail :: ProfDetailLevel,
- pkgHashCoverage :: Bool,
- pkgHashOptimization :: OptimisationLevel,
- pkgHashSplitObjs :: Bool,
- pkgHashSplitSections :: Bool,
- pkgHashStripLibs :: Bool,
- pkgHashStripExes :: Bool,
- pkgHashDebugInfo :: DebugInfoLevel,
- pkgHashProgramArgs :: Map String [String],
- pkgHashExtraLibDirs :: [FilePath],
- pkgHashExtraLibDirsStatic :: [FilePath],
- pkgHashExtraFrameworkDirs :: [FilePath],
- pkgHashExtraIncludeDirs :: [FilePath],
- pkgHashProgPrefix :: Maybe PathTemplate,
- pkgHashProgSuffix :: Maybe PathTemplate,
- pkgHashPackageDbs :: [Maybe PackageDB],
-
- -- Haddock options
- pkgHashDocumentation :: Bool,
- pkgHashHaddockHoogle :: Bool,
- pkgHashHaddockHtml :: Bool,
- pkgHashHaddockHtmlLocation :: Maybe String,
- pkgHashHaddockForeignLibs :: Bool,
- pkgHashHaddockExecutables :: Bool,
- pkgHashHaddockTestSuites :: Bool,
- pkgHashHaddockBenchmarks :: Bool,
- pkgHashHaddockInternal :: Bool,
- pkgHashHaddockCss :: Maybe FilePath,
- pkgHashHaddockLinkedSource :: Bool,
- pkgHashHaddockQuickJump :: Bool,
- pkgHashHaddockContents :: Maybe PathTemplate,
- pkgHashHaddockIndex :: Maybe PathTemplate,
- pkgHashHaddockBaseUrl :: Maybe String,
- pkgHashHaddockLib :: Maybe String,
- pkgHashHaddockOutputDir :: Maybe FilePath
-
--- TODO: [required eventually] pkgHashToolsVersions ?
--- TODO: [required eventually] pkgHashToolsExtraOptions ?
- }
- deriving Show
-
+data PackageHashConfigInputs = PackageHashConfigInputs
+ { pkgHashCompilerId :: CompilerId
+ , pkgHashPlatform :: Platform
+ , pkgHashFlagAssignment :: FlagAssignment -- complete not partial
+ , pkgHashConfigureScriptArgs :: [String] -- just ./configure for build-type Configure
+ , pkgHashVanillaLib :: Bool
+ , pkgHashSharedLib :: Bool
+ , pkgHashDynExe :: Bool
+ , pkgHashFullyStaticExe :: Bool
+ , pkgHashGHCiLib :: Bool
+ , pkgHashProfLib :: Bool
+ , pkgHashProfExe :: Bool
+ , pkgHashProfLibDetail :: ProfDetailLevel
+ , pkgHashProfExeDetail :: ProfDetailLevel
+ , pkgHashCoverage :: Bool
+ , pkgHashOptimization :: OptimisationLevel
+ , pkgHashSplitObjs :: Bool
+ , pkgHashSplitSections :: Bool
+ , pkgHashStripLibs :: Bool
+ , pkgHashStripExes :: Bool
+ , pkgHashDebugInfo :: DebugInfoLevel
+ , pkgHashProgramArgs :: Map String [String]
+ , pkgHashExtraLibDirs :: [FilePath]
+ , pkgHashExtraLibDirsStatic :: [FilePath]
+ , pkgHashExtraFrameworkDirs :: [FilePath]
+ , pkgHashExtraIncludeDirs :: [FilePath]
+ , pkgHashProgPrefix :: Maybe PathTemplate
+ , pkgHashProgSuffix :: Maybe PathTemplate
+ , pkgHashPackageDbs :: [Maybe PackageDB]
+ , -- Haddock options
+ pkgHashDocumentation :: Bool
+ , pkgHashHaddockHoogle :: Bool
+ , pkgHashHaddockHtml :: Bool
+ , pkgHashHaddockHtmlLocation :: Maybe String
+ , pkgHashHaddockForeignLibs :: Bool
+ , pkgHashHaddockExecutables :: Bool
+ , pkgHashHaddockTestSuites :: Bool
+ , pkgHashHaddockBenchmarks :: Bool
+ , pkgHashHaddockInternal :: Bool
+ , pkgHashHaddockCss :: Maybe FilePath
+ , pkgHashHaddockLinkedSource :: Bool
+ , pkgHashHaddockQuickJump :: Bool
+ , pkgHashHaddockContents :: Maybe PathTemplate
+ , pkgHashHaddockIndex :: Maybe PathTemplate
+ , pkgHashHaddockBaseUrl :: Maybe String
+ , pkgHashHaddockLib :: Maybe String
+ , pkgHashHaddockOutputDir :: Maybe FilePath
+ -- TODO: [required eventually] pkgHashToolsVersions ?
+ -- TODO: [required eventually] pkgHashToolsExtraOptions ?
+ }
+ deriving (Show)
-- | Calculate the overall hash to be used for an 'InstalledPackageId'.
---
hashPackageHashInputs :: PackageHashInputs -> HashValue
hashPackageHashInputs = hashValue . renderPackageHashInputs
-- | Render a textual representation of the 'PackageHashInputs'.
--
-- The 'hashValue' of this text is the overall package hash.
---
renderPackageHashInputs :: PackageHashInputs -> LBS.ByteString
-renderPackageHashInputs PackageHashInputs{
- pkgHashPkgId,
- pkgHashComponent,
- pkgHashSourceHash,
- pkgHashDirectDeps,
- pkgHashPkgConfigDeps,
- pkgHashOtherConfig =
- PackageHashConfigInputs{..}
- } =
+renderPackageHashInputs
+ PackageHashInputs
+ { pkgHashPkgId
+ , pkgHashComponent
+ , pkgHashSourceHash
+ , pkgHashDirectDeps
+ , pkgHashPkgConfigDeps
+ , pkgHashOtherConfig =
+ PackageHashConfigInputs{..}
+ } =
-- The purpose of this somewhat laboured rendering (e.g. why not just
-- use show?) is so that existing package hashes do not change
-- unnecessarily when new configuration inputs are added into the hash.
@@ -258,72 +270,85 @@ renderPackageHashInputs PackageHashInputs{
-- change the hashes of existing packages and so fewer packages will need
-- to be rebuilt.
- --TODO: [nice to have] ultimately we probably want to put this config info
+ -- TODO: [nice to have] ultimately we probably want to put this config info
-- into the ghc-pkg db. At that point this should probably be changed to
-- use the config file infrastructure so it can be read back in again.
- LBS.pack $ unlines $ catMaybes $
- [ entry "pkgid" prettyShow pkgHashPkgId
- , mentry "component" show pkgHashComponent
- , entry "src" showHashValue pkgHashSourceHash
- , entry "pkg-config-deps"
- (intercalate ", " . map (\(pn, mb_v) -> prettyShow pn ++
- case mb_v of
- Nothing -> ""
- Just v -> " " ++ prettyShow v)
- . Set.toList) pkgHashPkgConfigDeps
- , entry "deps" (intercalate ", " . map prettyShow
- . Set.toList) pkgHashDirectDeps
- -- and then all the config
- , entry "compilerid" prettyShow pkgHashCompilerId
- , entry "platform" prettyShow pkgHashPlatform
- , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment
- , opt "configure-script" [] unwords pkgHashConfigureScriptArgs
- , opt "vanilla-lib" True prettyShow pkgHashVanillaLib
- , opt "shared-lib" False prettyShow pkgHashSharedLib
- , opt "dynamic-exe" False prettyShow pkgHashDynExe
- , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe
- , opt "ghci-lib" False prettyShow pkgHashGHCiLib
- , opt "prof-lib" False prettyShow pkgHashProfLib
- , opt "prof-exe" False prettyShow pkgHashProfExe
- , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail
- , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail
- , opt "hpc" False prettyShow pkgHashCoverage
- , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization
- , opt "split-objs" False prettyShow pkgHashSplitObjs
- , opt "split-sections" False prettyShow pkgHashSplitSections
- , opt "stripped-lib" False prettyShow pkgHashStripLibs
- , opt "stripped-exe" True prettyShow pkgHashStripExes
- , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo
- , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs
- , opt "extra-lib-dirs-static" [] unwords pkgHashExtraLibDirsStatic
- , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs
- , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs
- , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix
- , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix
- , opt "package-dbs" [] (unwords . map show) pkgHashPackageDbs
-
- , opt "documentation" False prettyShow pkgHashDocumentation
- , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle
- , opt "haddock-html" False prettyShow pkgHashHaddockHtml
- , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation
- , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs
- , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables
- , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites
- , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks
- , opt "haddock-internal" False prettyShow pkgHashHaddockInternal
- , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss
- , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource
- , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump
- , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents
- , opt "haddock-index-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockIndex
- , opt "haddock-base-url" Nothing (fromMaybe "") pkgHashHaddockBaseUrl
- , opt "haddock-lib" Nothing (fromMaybe "") pkgHashHaddockLib
- , opt "haddock-output-dir" Nothing (fromMaybe "") pkgHashHaddockOutputDir
-
- ] ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs
- where
- entry key format value = Just (key ++ ": " ++ format value)
- mentry key format value = fmap (\v -> key ++ ": " ++ format v) value
- opt key def format value
- | value == def = Nothing
- | otherwise = entry key format value
+ LBS.pack $
+ unlines $
+ catMaybes $
+ [ entry "pkgid" prettyShow pkgHashPkgId
+ , mentry "component" show pkgHashComponent
+ , entry "src" showHashValue pkgHashSourceHash
+ , entry
+ "pkg-config-deps"
+ ( intercalate ", "
+ . map
+ ( \(pn, mb_v) ->
+ prettyShow pn
+ ++ case mb_v of
+ Nothing -> ""
+ Just v -> " " ++ prettyShow v
+ )
+ . Set.toList
+ )
+ pkgHashPkgConfigDeps
+ , entry
+ "deps"
+ ( intercalate ", "
+ . map prettyShow
+ . Set.toList
+ )
+ pkgHashDirectDeps
+ , -- and then all the config
+ entry "compilerid" prettyShow pkgHashCompilerId
+ , entry "platform" prettyShow pkgHashPlatform
+ , opt "flags" mempty showFlagAssignment pkgHashFlagAssignment
+ , opt "configure-script" [] unwords pkgHashConfigureScriptArgs
+ , opt "vanilla-lib" True prettyShow pkgHashVanillaLib
+ , opt "shared-lib" False prettyShow pkgHashSharedLib
+ , opt "dynamic-exe" False prettyShow pkgHashDynExe
+ , opt "fully-static-exe" False prettyShow pkgHashFullyStaticExe
+ , opt "ghci-lib" False prettyShow pkgHashGHCiLib
+ , opt "prof-lib" False prettyShow pkgHashProfLib
+ , opt "prof-exe" False prettyShow pkgHashProfExe
+ , opt "prof-lib-detail" ProfDetailDefault showProfDetailLevel pkgHashProfLibDetail
+ , opt "prof-exe-detail" ProfDetailDefault showProfDetailLevel pkgHashProfExeDetail
+ , opt "hpc" False prettyShow pkgHashCoverage
+ , opt "optimisation" NormalOptimisation (show . fromEnum) pkgHashOptimization
+ , opt "split-objs" False prettyShow pkgHashSplitObjs
+ , opt "split-sections" False prettyShow pkgHashSplitSections
+ , opt "stripped-lib" False prettyShow pkgHashStripLibs
+ , opt "stripped-exe" True prettyShow pkgHashStripExes
+ , opt "debug-info" NormalDebugInfo (show . fromEnum) pkgHashDebugInfo
+ , opt "extra-lib-dirs" [] unwords pkgHashExtraLibDirs
+ , opt "extra-lib-dirs-static" [] unwords pkgHashExtraLibDirsStatic
+ , opt "extra-framework-dirs" [] unwords pkgHashExtraFrameworkDirs
+ , opt "extra-include-dirs" [] unwords pkgHashExtraIncludeDirs
+ , opt "prog-prefix" Nothing (maybe "" fromPathTemplate) pkgHashProgPrefix
+ , opt "prog-suffix" Nothing (maybe "" fromPathTemplate) pkgHashProgSuffix
+ , opt "package-dbs" [] (unwords . map show) pkgHashPackageDbs
+ , opt "documentation" False prettyShow pkgHashDocumentation
+ , opt "haddock-hoogle" False prettyShow pkgHashHaddockHoogle
+ , opt "haddock-html" False prettyShow pkgHashHaddockHtml
+ , opt "haddock-html-location" Nothing (fromMaybe "") pkgHashHaddockHtmlLocation
+ , opt "haddock-foreign-libraries" False prettyShow pkgHashHaddockForeignLibs
+ , opt "haddock-executables" False prettyShow pkgHashHaddockExecutables
+ , opt "haddock-tests" False prettyShow pkgHashHaddockTestSuites
+ , opt "haddock-benchmarks" False prettyShow pkgHashHaddockBenchmarks
+ , opt "haddock-internal" False prettyShow pkgHashHaddockInternal
+ , opt "haddock-css" Nothing (fromMaybe "") pkgHashHaddockCss
+ , opt "haddock-hyperlink-source" False prettyShow pkgHashHaddockLinkedSource
+ , opt "haddock-quickjump" False prettyShow pkgHashHaddockQuickJump
+ , opt "haddock-contents-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockContents
+ , opt "haddock-index-location" Nothing (maybe "" fromPathTemplate) pkgHashHaddockIndex
+ , opt "haddock-base-url" Nothing (fromMaybe "") pkgHashHaddockBaseUrl
+ , opt "haddock-lib" Nothing (fromMaybe "") pkgHashHaddockLib
+ , opt "haddock-output-dir" Nothing (fromMaybe "") pkgHashHaddockOutputDir
+ ]
+ ++ Map.foldrWithKey (\prog args acc -> opt (prog ++ "-options") [] unwords args : acc) [] pkgHashProgramArgs
+ where
+ entry key format value = Just (key ++ ": " ++ format value)
+ mentry key format value = fmap (\v -> key ++ ": " ++ format v) value
+ opt key def format value
+ | value == def = Nothing
+ | otherwise = entry key format value
diff --git a/cabal-install/src/Distribution/Client/ParseUtils.hs b/cabal-install/src/Distribution/Client/ParseUtils.hs
index 0b8e45c56415cae3c328c2beb0dbfad29cbd76a8..44cdc4ccc22932bdc4f11216d4e8c9560cdcfd16 100644
--- a/cabal-install/src/Distribution/Client/ParseUtils.hs
+++ b/cabal-install/src/Distribution/Client/ParseUtils.hs
@@ -1,137 +1,150 @@
-{-# LANGUAGE ExistentialQuantification, NamedFieldPuns, RankNTypes #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.ParseUtils
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Parsing utilities.
------------------------------------------------------------------------------
-
-module Distribution.Client.ParseUtils (
-
- -- * Fields and field utilities
- FieldDescr(..),
- liftField,
- liftFields,
- filterFields,
- mapFieldNames,
- commandOptionToField,
- commandOptionsToFields,
+module Distribution.Client.ParseUtils
+ ( -- * Fields and field utilities
+ FieldDescr (..)
+ , liftField
+ , liftFields
+ , filterFields
+ , mapFieldNames
+ , commandOptionToField
+ , commandOptionsToFields
-- * Sections and utilities
- SectionDescr(..),
- liftSection,
+ , SectionDescr (..)
+ , liftSection
-- * FieldGrammar sections
- FGSectionDescr(..),
+ , FGSectionDescr (..)
-- * Parsing and printing flat config
- parseFields,
- ppFields,
- ppSection,
+ , parseFields
+ , ppFields
+ , ppSection
-- * Parsing and printing config with sections and subsections
- parseFieldsAndSections,
- ppFieldsAndSections,
+ , parseFieldsAndSections
+ , ppFieldsAndSections
-- ** Top level of config files
- parseConfig,
- showConfig,
+ , parseConfig
+ , showConfig
)
- where
+where
import Distribution.Client.Compat.Prelude hiding (empty, get)
import Prelude ()
import Distribution.Deprecated.ParseUtils
- ( FieldDescr(..), ParseResult(..), warning, LineNo, lineNo
- , Field(..), liftField, readFields )
+ ( Field (..)
+ , FieldDescr (..)
+ , LineNo
+ , ParseResult (..)
+ , liftField
+ , lineNo
+ , readFields
+ , warning
+ )
import Distribution.Deprecated.ViewAsFieldDescr
- ( viewAsFieldDescr )
+ ( viewAsFieldDescr
+ )
import Distribution.Simple.Command
- ( OptionField )
+ ( OptionField
+ )
-import Text.PrettyPrint ( ($+$) )
import qualified Data.ByteString as BS
import qualified Data.Map as Map
+import Text.PrettyPrint (($+$))
import qualified Text.PrettyPrint as Disp
- ( (<>), Doc, text, colon, vcat, empty, isEmpty, nest )
+ ( Doc
+ , colon
+ , empty
+ , isEmpty
+ , nest
+ , text
+ , vcat
+ , (<>)
+ )
-- For new parser stuff
import Distribution.CabalSpecVersion (cabalSpecLatest)
-import Distribution.FieldGrammar (partitionFields, parseFieldGrammar)
+import Distribution.FieldGrammar (parseFieldGrammar, partitionFields)
+import qualified Distribution.FieldGrammar as FG
+import qualified Distribution.Fields as F
import Distribution.Fields.ParseResult (runParseResult)
import Distribution.Parsec.Error (showPError)
import Distribution.Parsec.Position (Position (..))
import Distribution.Parsec.Warning (showPWarning)
import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS)
-import qualified Distribution.Fields as F
-import qualified Distribution.FieldGrammar as FG
-
-------------------------
-- FieldDescr utilities
--
-liftFields :: (b -> a)
- -> (a -> b -> b)
- -> [FieldDescr a]
- -> [FieldDescr b]
+liftFields
+ :: (b -> a)
+ -> (a -> b -> b)
+ -> [FieldDescr a]
+ -> [FieldDescr b]
liftFields get set = map (liftField get set)
-
-- | Given a collection of field descriptions, keep only a given list of them,
-- identified by name.
---
filterFields :: [String] -> [FieldDescr a] -> [FieldDescr a]
filterFields includeFields = filter ((`elem` includeFields) . fieldName)
-- | Apply a name mangling function to the field names of all the field
-- descriptions. The typical use case is to apply some prefix.
---
mapFieldNames :: (String -> String) -> [FieldDescr a] -> [FieldDescr a]
mapFieldNames mangleName =
- map (\descr -> descr { fieldName = mangleName (fieldName descr) })
-
+ map (\descr -> descr{fieldName = mangleName (fieldName descr)})
-- | Reuse a command line 'OptionField' as a config file 'FieldDescr'.
---
commandOptionToField :: OptionField a -> FieldDescr a
commandOptionToField = viewAsFieldDescr
-- | Reuse a bunch of command line 'OptionField's as config file 'FieldDescr's.
---
commandOptionsToFields :: [OptionField a] -> [FieldDescr a]
commandOptionsToFields = map viewAsFieldDescr
-
------------------------------------------
-- SectionDescr definition and utilities
--
-- | The description of a section in a config file. It can contain both
-- fields and optionally further subsections. See also 'FieldDescr'.
---
-data SectionDescr a = forall b. SectionDescr {
- sectionName :: String,
- sectionFields :: [FieldDescr b],
- sectionSubsections :: [SectionDescr b],
- sectionGet :: a -> [(String, b)],
- sectionSet :: LineNo -> String -> b -> a -> ParseResult a,
- sectionEmpty :: b
- }
+data SectionDescr a = forall b.
+ SectionDescr
+ { sectionName :: String
+ , sectionFields :: [FieldDescr b]
+ , sectionSubsections :: [SectionDescr b]
+ , sectionGet :: a -> [(String, b)]
+ , sectionSet :: LineNo -> String -> b -> a -> ParseResult a
+ , sectionEmpty :: b
+ }
-- | 'FieldGrammar' section description
-data FGSectionDescr g a = forall s. FGSectionDescr
- { fgSectionName :: String
- , fgSectionGrammar :: g s s
- -- todo: add subsections?
- , fgSectionGet :: a -> [(String, s)]
- , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a
- }
+data FGSectionDescr g a = forall s.
+ FGSectionDescr
+ { fgSectionName :: String
+ , fgSectionGrammar :: g s s
+ , -- todo: add subsections?
+ fgSectionGet :: a -> [(String, s)]
+ , fgSectionSet :: LineNo -> String -> s -> a -> ParseResult a
+ }
-- | To help construction of config file descriptions in a modular way it is
-- useful to define fields and sections on local types and then hoist them
@@ -139,18 +152,17 @@ data FGSectionDescr g a = forall s. FGSectionDescr
--
-- This is essentially a lens operation for 'SectionDescr' to help embedding
-- one inside another.
---
-liftSection :: (b -> a)
- -> (a -> b -> b)
- -> SectionDescr a
- -> SectionDescr b
+liftSection
+ :: (b -> a)
+ -> (a -> b -> b)
+ -> SectionDescr a
+ -> SectionDescr b
liftSection get' set' (SectionDescr name fields sections get set empty) =
- let sectionGet' = get . get'
- sectionSet' lineno param x y = do
- x' <- set lineno param x (get' y)
- return (set' x' y)
- in SectionDescr name fields sections sectionGet' sectionSet' empty
-
+ let sectionGet' = get . get'
+ sectionSet' lineno param x y = do
+ x' <- set lineno param x (get' y)
+ return (set' x' y)
+ in SectionDescr name fields sections sectionGet' sectionSet' empty
-------------------------------------
-- Parsing and printing flat config
@@ -161,12 +173,11 @@ liftSection get' set' (SectionDescr name fields sections get set empty) =
--
-- This only covers the case of flat configuration without subsections. See
-- also 'parseFieldsAndSections'.
---
parseFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
parseFields fieldDescrs =
- foldM setField
+ foldM setField
where
- fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
+ fieldMap = Map.fromList [(fieldName f, f) | f <- fieldDescrs]
setField accum (F line name value) =
case Map.lookup name fieldMap of
@@ -176,43 +187,52 @@ parseFields fieldDescrs =
-- it was automatically added to many config files
-- before that, so its warning is silently ignored
unless (name == "world-file") $
- warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
+ warning $
+ "Unrecognized field " ++ name ++ " on line " ++ show line
return accum
-
setField accum f = do
warning $ "Unrecognized stanza on line " ++ show (lineNo f)
return accum
-- | This is a customised version of the functions from Distribution.Deprecated.ParseUtils
-- that also optionally print default values for empty fields as comments.
---
ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
ppFields fields def cur =
- Disp.vcat [ ppField name (fmap getter def) (getter cur)
- | FieldDescr name getter _ <- fields]
+ Disp.vcat
+ [ ppField name (fmap getter def) (getter cur)
+ | FieldDescr name getter _ <- fields
+ ]
ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc
ppField name mdef cur
- | Disp.isEmpty cur = maybe Disp.empty
- (\def -> Disp.text "--" <+> Disp.text name
- Disp.<> Disp.colon <+> def) mdef
- | otherwise = Disp.text name Disp.<> Disp.colon <+> cur
+ | Disp.isEmpty cur =
+ maybe
+ Disp.empty
+ ( \def ->
+ Disp.text "--"
+ <+> Disp.text name
+ Disp.<> Disp.colon
+ <+> def
+ )
+ mdef
+ | otherwise = Disp.text name Disp.<> Disp.colon <+> cur
-- | Pretty print a section.
--
-- Since 'ppFields' does not cover subsections you can use this to add them.
-- Or alternatively use a 'SectionDescr' and use 'ppFieldsAndSections'.
---
ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc
ppSection name arg fields def cur
| Disp.isEmpty fieldsDoc = Disp.empty
- | otherwise = Disp.text name <+> argDoc
- $+$ (Disp.nest 2 fieldsDoc)
+ | otherwise =
+ Disp.text name
+ <+> argDoc
+ $+$ (Disp.nest 2 fieldsDoc)
where
fieldsDoc = ppFields fields def cur
- argDoc | arg == "" = Disp.empty
- | otherwise = Disp.text arg
-
+ argDoc
+ | arg == "" = Disp.empty
+ | otherwise = Disp.text arg
-----------------------------------------
-- Parsing and printing non-flat config
@@ -220,28 +240,33 @@ ppSection name arg fields def cur
-- | Much like 'parseFields' but it also allows subsections. The permitted
-- subsections are given by a list of 'SectionDescr's.
---
parseFieldsAndSections
- :: [FieldDescr a] -- ^ field
- -> [SectionDescr a] -- ^ legacy sections
- -> [FGSectionDescr FG.ParsecFieldGrammar a] -- ^ FieldGrammar sections
- -> a
- -> [Field] -> ParseResult a
+ :: [FieldDescr a]
+ -- ^ field
+ -> [SectionDescr a]
+ -- ^ legacy sections
+ -> [FGSectionDescr FG.ParsecFieldGrammar a]
+ -- ^ FieldGrammar sections
+ -> a
+ -> [Field]
+ -> ParseResult a
parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
- foldM setField
+ foldM setField
where
- fieldMap = Map.fromList [ (fieldName f, f) | f <- fieldDescrs ]
- sectionMap = Map.fromList [ (sectionName s, s) | s <- sectionDescrs ]
- fgSectionMap = Map.fromList [ (fgSectionName s, s) | s <- fgSectionDescrs ]
+ fieldMap = Map.fromList [(fieldName f, f) | f <- fieldDescrs]
+ sectionMap = Map.fromList [(sectionName s, s) | s <- sectionDescrs]
+ fgSectionMap = Map.fromList [(fgSectionName s, s) | s <- fgSectionDescrs]
setField a (F line name value) =
case Map.lookup name fieldMap of
Just (FieldDescr _ _ set) -> set line value a
Nothing -> do
- warning $ "Unrecognized field '" ++ name
- ++ "' on line " ++ show line
+ warning $
+ "Unrecognized field '"
+ ++ name
+ ++ "' on line "
+ ++ show line
return a
-
setField a (Section line name param fields) =
case Left <$> Map.lookup name sectionMap <|> Right <$> Map.lookup name fgSectionMap of
Just (Left (SectionDescr _ fieldDescrs' sectionDescrs' _ set sectionEmpty)) -> do
@@ -252,8 +277,11 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
(fields2, sections) = partitionFields fields1
-- TODO: recurse into sections
for_ (concat sections) $ \(FG.MkSection (F.Name (Position line' _) name') _ _) ->
- warning $ "Unrecognized section '" ++ fromUTF8BS name'
- ++ "' on line " ++ show line'
+ warning $
+ "Unrecognized section '"
+ ++ fromUTF8BS name'
+ ++ "' on line "
+ ++ show line'
case runParseResult $ parseFieldGrammar cabalSpecLatest fields2 grammar of
(warnings, Right b) -> do
for_ warnings $ \w -> warning $ showPWarning "???" w
@@ -263,18 +291,21 @@ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs =
case errs of
err :| _errs -> fail $ showPError "???" err
Nothing -> do
- warning $ "Unrecognized section '" ++ name
- ++ "' on line " ++ show line
+ warning $
+ "Unrecognized section '"
+ ++ name
+ ++ "' on line "
+ ++ show line
return a
convertField :: Field -> F.Field Position
convertField (F line name str) =
- F.Field (F.Name pos (toUTF8BS name)) [ F.FieldLine pos $ toUTF8BS str ]
+ F.Field (F.Name pos (toUTF8BS name)) [F.FieldLine pos $ toUTF8BS str]
where
pos = Position line 0
-- arguments omitted
convertField (Section line name _arg fields) =
- F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)
+ F.Section (F.Name pos (toUTF8BS name)) [] (map convertField fields)
where
pos = Position line 0
@@ -283,72 +314,91 @@ convertField (Section line name _arg fields) =
--
-- Note that unlike 'ppFields', at present it does not support printing
-- default values. If needed, adding such support would be quite reasonable.
---
ppFieldsAndSections :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
ppFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs val =
- ppFields fieldDescrs Nothing val
- $+$
- Disp.vcat (
- [ Disp.text "" $+$ sectionDoc
- | SectionDescr {
- sectionName, sectionGet,
- sectionFields, sectionSubsections
- } <- sectionDescrs
- , (param, x) <- sectionGet val
- , let sectionDoc = ppSectionAndSubsections
- sectionName param
- sectionFields sectionSubsections [] x
- , not (Disp.isEmpty sectionDoc)
- ] ++
- [ Disp.text "" $+$ sectionDoc
- | FGSectionDescr { fgSectionName, fgSectionGrammar, fgSectionGet } <- fgSectionDescrs
- , (param, x) <- fgSectionGet val
- , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x
- , not (Disp.isEmpty sectionDoc)
- ])
+ ppFields fieldDescrs Nothing val
+ $+$ Disp.vcat
+ ( [ Disp.text "" $+$ sectionDoc
+ | SectionDescr
+ { sectionName
+ , sectionGet
+ , sectionFields
+ , sectionSubsections
+ } <-
+ sectionDescrs
+ , (param, x) <- sectionGet val
+ , let sectionDoc =
+ ppSectionAndSubsections
+ sectionName
+ param
+ sectionFields
+ sectionSubsections
+ []
+ x
+ , not (Disp.isEmpty sectionDoc)
+ ]
+ ++ [ Disp.text "" $+$ sectionDoc
+ | FGSectionDescr{fgSectionName, fgSectionGrammar, fgSectionGet} <- fgSectionDescrs
+ , (param, x) <- fgSectionGet val
+ , let sectionDoc = ppFgSection fgSectionName param fgSectionGrammar x
+ , not (Disp.isEmpty sectionDoc)
+ ]
+ )
-- | Unlike 'ppSection' which has to be called directly, this gets used via
-- 'ppFieldsAndSections' and so does not need to be exported.
---
-ppSectionAndSubsections :: String -> String
- -> [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
+ppSectionAndSubsections
+ :: String
+ -> String
+ -> [FieldDescr a]
+ -> [SectionDescr a]
+ -> [FGSectionDescr FG.PrettyFieldGrammar a]
+ -> a
+ -> Disp.Doc
ppSectionAndSubsections name arg fields sections fgSections cur
| Disp.isEmpty fieldsDoc = Disp.empty
- | otherwise = Disp.text name <+> argDoc
- $+$ (Disp.nest 2 fieldsDoc)
+ | otherwise =
+ Disp.text name
+ <+> argDoc
+ $+$ (Disp.nest 2 fieldsDoc)
where
fieldsDoc = showConfig fields sections fgSections cur
- argDoc | arg == "" = Disp.empty
- | otherwise = Disp.text arg
+ argDoc
+ | arg == "" = Disp.empty
+ | otherwise = Disp.text arg
-- |
--
-- TODO: subsections
-- TODO: this should simply build 'PrettyField'
ppFgSection
- :: String -- ^ section name
- -> String -- ^ parameter
- -> FG.PrettyFieldGrammar a a
- -> a
- -> Disp.Doc
+ :: String
+ -- ^ section name
+ -> String
+ -- ^ parameter
+ -> FG.PrettyFieldGrammar a a
+ -> a
+ -> Disp.Doc
ppFgSection secName arg grammar x
- | null prettyFields = Disp.empty
- | otherwise =
- Disp.text secName <+> argDoc
+ | null prettyFields = Disp.empty
+ | otherwise =
+ Disp.text secName
+ <+> argDoc
$+$ (Disp.nest 2 fieldsDoc)
where
prettyFields = FG.prettyFieldGrammar cabalSpecLatest grammar x
- argDoc | arg == "" = Disp.empty
- | otherwise = Disp.text arg
+ argDoc
+ | arg == "" = Disp.empty
+ | otherwise = Disp.text arg
- fieldsDoc = Disp.vcat
+ fieldsDoc =
+ Disp.vcat
[ Disp.text fname' <<>> Disp.colon <<>> doc
| F.PrettyField _ fname doc <- prettyFields -- TODO: this skips sections
, let fname' = fromUTF8BS fname
]
-
-----------------------------------------------
-- Top level config file parsing and printing
--
@@ -357,15 +407,18 @@ ppFgSection secName arg grammar x
-- description of the configuration file in terms of its fields and sections.
--
-- It accumulates the result on top of a given initial (typically empty) value.
---
-parseConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.ParsecFieldGrammar a] -> a
- -> BS.ByteString -> ParseResult a
+parseConfig
+ :: [FieldDescr a]
+ -> [SectionDescr a]
+ -> [FGSectionDescr FG.ParsecFieldGrammar a]
+ -> a
+ -> BS.ByteString
+ -> ParseResult a
parseConfig fieldDescrs sectionDescrs fgSectionDescrs empty str =
- parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
- =<< readFields str
+ parseFieldsAndSections fieldDescrs sectionDescrs fgSectionDescrs empty
+ =<< readFields str
-- | Render a value in the config file syntax, based on a description of the
-- configuration file in terms of its fields and sections.
---
showConfig :: [FieldDescr a] -> [SectionDescr a] -> [FGSectionDescr FG.PrettyFieldGrammar a] -> a -> Disp.Doc
showConfig = ppFieldsAndSections
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
index 19a6661b6f673f633a4473373a289bb603030a98..627ec3acec1a10e0d0a2b908e29d1ba9d6764ae8 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs
@@ -1,117 +1,139 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE NoMonoLocalBinds #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
+
+module Distribution.Client.ProjectBuilding
+ ( -- * Dry run phase
--- |
---
-module Distribution.Client.ProjectBuilding (
- -- * Dry run phase
-- | What bits of the plan will we execute? The dry run does not change
-- anything but tells us what will need to be built.
- rebuildTargetsDryRun,
- improveInstallPlanWithUpToDatePackages,
+ rebuildTargetsDryRun
+ , improveInstallPlanWithUpToDatePackages
-- ** Build status
+
-- | This is the detailed status information we get from the dry run.
- BuildStatusMap,
- BuildStatus(..),
- BuildStatusRebuild(..),
- BuildReason(..),
- MonitorChangedReason(..),
- buildStatusToString,
+ , BuildStatusMap
+ , BuildStatus (..)
+ , BuildStatusRebuild (..)
+ , BuildReason (..)
+ , MonitorChangedReason (..)
+ , buildStatusToString
-- * Build phase
+
-- | Now we actually execute the plan.
- rebuildTargets,
+ , rebuildTargets
+
-- ** Build outcomes
+
-- | This is the outcome for each package of executing the plan.
-- For each package, did the build succeed or fail?
- BuildOutcomes,
- BuildOutcome,
- BuildResult(..),
- BuildFailure(..),
- BuildFailureReason(..),
+ , BuildOutcomes
+ , BuildOutcome
+ , BuildResult (..)
+ , BuildFailure (..)
+ , BuildFailureReason (..)
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.PackageHash (renderPackageHashInputs)
-import Distribution.Client.RebuildMonad
-import Distribution.Client.ProjectConfig
-import Distribution.Client.ProjectPlanning
-import Distribution.Client.ProjectPlanning.Types
-import Distribution.Client.ProjectBuilding.Types
-import Distribution.Client.Store
-
-import Distribution.Client.Types
- hiding (BuildOutcomes, BuildOutcome,
- BuildResult(..), BuildFailure(..))
-import Distribution.Client.InstallPlan
- ( GenericInstallPlan, GenericPlanPackage, IsUnit )
+import Distribution.Client.PackageHash (renderPackageHashInputs)
+import Distribution.Client.ProjectBuilding.Types
+import Distribution.Client.ProjectConfig
+import Distribution.Client.ProjectPlanning
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Client.RebuildMonad
+import Distribution.Client.Store
+
+import Distribution.Client.DistDirLayout
+import Distribution.Client.FetchUtils
+import Distribution.Client.FileMonitor
+import Distribution.Client.GlobalFlags (RepoContext)
+import Distribution.Client.InstallPlan
+ ( GenericInstallPlan
+ , GenericPlanPackage
+ , IsUnit
+ )
import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.DistDirLayout
-import Distribution.Client.FileMonitor
-import Distribution.Client.SetupWrapper
-import Distribution.Client.JobControl
-import Distribution.Client.FetchUtils
-import Distribution.Client.GlobalFlags (RepoContext)
+import Distribution.Client.JobControl
+import Distribution.Client.Setup
+ ( filterConfigureFlags
+ , filterHaddockArgs
+ , filterHaddockFlags
+ , filterTestFlags
+ )
+import Distribution.Client.SetupWrapper
+import Distribution.Client.SourceFiles
+import Distribution.Client.SrcDist (allPackageSourceFiles)
import qualified Distribution.Client.Tar as Tar
-import Distribution.Client.Setup
- ( filterConfigureFlags, filterHaddockArgs
- , filterHaddockFlags, filterTestFlags )
-import Distribution.Client.SourceFiles
-import Distribution.Client.SrcDist (allPackageSourceFiles)
-import Distribution.Client.Utils
- ( ProgressPhase(..), findOpenProgramLocation, progressMessage, removeExistingFile )
-
-import Distribution.Compat.Lens
-import Distribution.Package
-import qualified Distribution.PackageDescription as PD
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.Client.Types hiding
+ ( BuildFailure (..)
+ , BuildOutcome
+ , BuildOutcomes
+ , BuildResult (..)
+ )
+import Distribution.Client.Utils
+ ( ProgressPhase (..)
+ , findOpenProgramLocation
+ , progressMessage
+ , removeExistingFile
+ )
+
+import Distribution.Compat.Lens
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
-import Distribution.Simple.BuildPaths (haddockDirName)
+import Distribution.Package
+import qualified Distribution.PackageDescription as PD
+import Distribution.Simple.BuildPaths (haddockDirName)
+import Distribution.Simple.Command (CommandUI)
+import Distribution.Simple.Compiler
+ ( Compiler
+ , PackageDB (..)
+ , compilerId
+ )
import qualified Distribution.Simple.InstallDirs as InstallDirs
-import Distribution.Types.BuildType
-import Distribution.Types.PackageDescription.Lens (componentModules)
-import Distribution.Simple.Program
-import qualified Distribution.Simple.Setup as Cabal
-import Distribution.Simple.Command (CommandUI)
+import Distribution.Simple.LocalBuildInfo
+ ( ComponentName (..)
+ , LibraryName (..)
+ )
+import Distribution.Simple.Program
import qualified Distribution.Simple.Register as Cabal
-import Distribution.Simple.LocalBuildInfo
- ( ComponentName(..), LibraryName(..) )
-import Distribution.Simple.Compiler
- ( Compiler, compilerId, PackageDB(..) )
+import qualified Distribution.Simple.Setup as Cabal
+import Distribution.Types.BuildType
+import Distribution.Types.PackageDescription.Lens (componentModules)
-import Distribution.Simple.Utils
-import Distribution.Version
-import Distribution.Compat.Graph (IsNode(..))
+import Distribution.Compat.Graph (IsNode (..))
+import Distribution.Simple.Utils
+import Distribution.Version
-import qualified Data.List.NonEmpty as NE
-import qualified Data.Map as Map
-import qualified Data.Set as Set
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as Map
+import qualified Data.Set as Set
import qualified Text.PrettyPrint as Disp
import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
-import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
-import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
-import System.IO (IOMode (AppendMode), Handle, withFile)
+import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
+import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
+import System.IO (Handle, IOMode (AppendMode), withFile)
import Distribution.Compat.Directory (listDirectory)
import Distribution.Simple.Flag (fromFlagOrDefault)
-
------------------------------------------------------------------------------
+
-- * Overall building strategy.
+
------------------------------------------------------------------------------
--
-- We start with an 'ElaboratedInstallPlan' that has already been improved by
@@ -157,9 +179,10 @@ import Distribution.Simple.Flag (fromFlagOrDefault)
-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for
-- details.
-
------------------------------------------------------------------------------
+
-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
+
------------------------------------------------------------------------------
-- Refer to ProjectBuilding.Types for details of these important types:
@@ -175,57 +198,51 @@ import Distribution.Simple.Flag (fromFlagOrDefault)
-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
-- the 'ElaboratedInstallPlan' with packages switched to the
-- 'InstallPlan.Installed' state when we find that they're already up to date.
---
-rebuildTargetsDryRun :: DistDirLayout
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> IO BuildStatusMap
+rebuildTargetsDryRun
+ :: DistDirLayout
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> IO BuildStatusMap
rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
- -- Do the various checks to work out the 'BuildStatus' of each package
- foldMInstallPlanDepOrder dryRunPkg
+ -- Do the various checks to work out the 'BuildStatus' of each package
+ foldMInstallPlanDepOrder dryRunPkg
where
- dryRunPkg :: ElaboratedPlanPackage
- -> [BuildStatus]
- -> IO BuildStatus
+ dryRunPkg
+ :: ElaboratedPlanPackage
+ -> [BuildStatus]
+ -> IO BuildStatus
dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
return BuildStatusPreExisting
-
dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
return BuildStatusInstalled
-
dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
mloc <- checkFetched (elabPkgSourceLocation pkg)
case mloc of
Nothing -> return BuildStatusDownload
-
Just (LocalUnpackedPackage srcdir) ->
-- For the case of a user-managed local dir, irrespective of the
-- build style, we build from that directory and put build
-- artifacts under the shared dist directory.
dryRunLocalPkg pkg depsBuildStatus srcdir
-
-- The rest cases are all tarball cases are,
-- and handled the same as each other though depending on the build style.
- Just (LocalTarballPackage tarball) ->
+ Just (LocalTarballPackage tarball) ->
dryRunTarballPkg pkg depsBuildStatus tarball
-
Just (RemoteTarballPackage _ tarball) ->
dryRunTarballPkg pkg depsBuildStatus tarball
-
Just (RepoTarballPackage _ _ tarball) ->
dryRunTarballPkg pkg depsBuildStatus tarball
-
Just (RemoteSourceRepoPackage _repo tarball) ->
dryRunTarballPkg pkg depsBuildStatus tarball
-
- dryRunTarballPkg :: ElaboratedConfiguredPackage
- -> [BuildStatus]
- -> FilePath
- -> IO BuildStatus
+ dryRunTarballPkg
+ :: ElaboratedConfiguredPackage
+ -> [BuildStatus]
+ -> FilePath
+ -> IO BuildStatus
dryRunTarballPkg pkg depsBuildStatus tarball =
case elabBuildStyle pkg of
- BuildAndInstall -> return (BuildStatusUnpack tarball)
+ BuildAndInstall -> return (BuildStatusUnpack tarball)
BuildInplaceOnly -> do
-- TODO: [nice to have] use a proper file monitor rather
-- than this dir exists test
@@ -237,29 +254,34 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
srcdir :: FilePath
srcdir = distUnpackedSrcDirectory (packageId pkg)
- dryRunLocalPkg :: ElaboratedConfiguredPackage
- -> [BuildStatus]
- -> FilePath
- -> IO BuildStatus
+ dryRunLocalPkg
+ :: ElaboratedConfiguredPackage
+ -> [BuildStatus]
+ -> FilePath
+ -> IO BuildStatus
dryRunLocalPkg pkg depsBuildStatus srcdir = do
- -- Go and do lots of I/O, reading caches and probing files to work out
- -- if anything has changed
- change <- checkPackageFileMonitorChanged
- packageFileMonitor pkg srcdir depsBuildStatus
- case change of
- -- It did change, giving us 'BuildStatusRebuild' info on why
- Left rebuild ->
- return (BuildStatusRebuild srcdir rebuild)
-
- -- No changes, the package is up to date. Use the saved build results.
- Right buildResult ->
- return (BuildStatusUpToDate buildResult)
+ -- Go and do lots of I/O, reading caches and probing files to work out
+ -- if anything has changed
+ change <-
+ checkPackageFileMonitorChanged
+ packageFileMonitor
+ pkg
+ srcdir
+ depsBuildStatus
+ case change of
+ -- It did change, giving us 'BuildStatusRebuild' info on why
+ Left rebuild ->
+ return (BuildStatusRebuild srcdir rebuild)
+ -- No changes, the package is up to date. Use the saved build results.
+ Right buildResult ->
+ return (BuildStatusUpToDate buildResult)
where
packageFileMonitor :: PackageFileMonitor
packageFileMonitor =
- newPackageFileMonitor shared distDirLayout
- (elabDistDirParams shared pkg)
-
+ newPackageFileMonitor
+ shared
+ distDirLayout
+ (elabDistDirParams shared pkg)
-- | A specialised traversal over the packages in an install plan.
--
@@ -268,47 +290,54 @@ rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
-- returned as the final result. In addition, when visiting a package, the
-- visiting function is passed the results for all the immediate package
-- dependencies. This can be used to propagate information from dependencies.
---
foldMInstallPlanDepOrder
- :: forall m ipkg srcpkg b.
- (Monad m, IsUnit ipkg, IsUnit srcpkg)
- => (GenericPlanPackage ipkg srcpkg ->
- [b] -> m b)
+ :: forall m ipkg srcpkg b
+ . (Monad m, IsUnit ipkg, IsUnit srcpkg)
+ => ( GenericPlanPackage ipkg srcpkg
+ -> [b]
+ -> m b
+ )
-> GenericInstallPlan ipkg srcpkg
-> m (Map UnitId b)
foldMInstallPlanDepOrder visit =
- go Map.empty . InstallPlan.reverseTopologicalOrder
+ go Map.empty . InstallPlan.reverseTopologicalOrder
where
- go :: Map UnitId b
- -> [GenericPlanPackage ipkg srcpkg]
- -> m (Map UnitId b)
+ go
+ :: Map UnitId b
+ -> [GenericPlanPackage ipkg srcpkg]
+ -> m (Map UnitId b)
go !results [] = return results
-
go !results (pkg : pkgs) = do
-- we go in the right order so the results map has entries for all deps
let depresults :: [b]
depresults =
- map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results
- in result)
- (InstallPlan.depends pkg)
+ map
+ ( \ipkgid ->
+ let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results
+ in result
+ )
+ (InstallPlan.depends pkg)
result <- visit pkg depresults
let results' = Map.insert (nodeKey pkg) result results
go results' pkgs
-improveInstallPlanWithUpToDatePackages :: BuildStatusMap
- -> ElaboratedInstallPlan
- -> ElaboratedInstallPlan
+improveInstallPlanWithUpToDatePackages
+ :: BuildStatusMap
+ -> ElaboratedInstallPlan
+ -> ElaboratedInstallPlan
improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
- InstallPlan.installed canPackageBeImproved
+ InstallPlan.installed canPackageBeImproved
where
canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
canPackageBeImproved pkg =
case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
- Just BuildStatusUpToDate {} -> True
- Just _ -> False
- Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
- ++ prettyShow (packageId pkg) ++ " not in status map"
-
+ Just BuildStatusUpToDate{} -> True
+ Just _ -> False
+ Nothing ->
+ error $
+ "improveInstallPlanWithUpToDatePackages: "
+ ++ prettyShow (packageId pkg)
+ ++ " not in status map"
-----------------------------
-- Package change detection
@@ -323,58 +352,56 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
-- state updates are split into two, one for package config changes and one
-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'
-- and 'updatePackageBuildFileMonitor'.
---
-data PackageFileMonitor = PackageFileMonitor {
- pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),
- pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc,
- pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
- }
+data PackageFileMonitor = PackageFileMonitor
+ { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage ()
+ , pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc
+ , pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo)
+ }
-- | This is all the components of the 'BuildResult' other than the
-- @['InstalledPackageInfo']@.
--
-- We have to split up the 'BuildResult' components since they get produced
-- at different times (or rather, when different things change).
---
type BuildResultMisc = (DocsResult, TestsResult)
-newPackageFileMonitor :: ElaboratedSharedConfig
- -> DistDirLayout
- -> DistDirParams
- -> PackageFileMonitor
-newPackageFileMonitor shared
- DistDirLayout{distPackageCacheFile}
- dparams =
- PackageFileMonitor {
- pkgFileMonitorConfig =
- FileMonitor {
- fileMonitorCacheFile = distPackageCacheFile dparams "config",
- fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared,
- fileMonitorCheckIfOnlyValueChanged = False
- },
-
- pkgFileMonitorBuild =
- FileMonitor {
- fileMonitorCacheFile = distPackageCacheFile dparams "build",
- fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt ->
- componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
- fileMonitorCheckIfOnlyValueChanged = True
- },
-
- pkgFileMonitorReg =
- newFileMonitor (distPackageCacheFile dparams "registration")
- }
+newPackageFileMonitor
+ :: ElaboratedSharedConfig
+ -> DistDirLayout
+ -> DistDirParams
+ -> PackageFileMonitor
+newPackageFileMonitor
+ shared
+ DistDirLayout{distPackageCacheFile}
+ dparams =
+ PackageFileMonitor
+ { pkgFileMonitorConfig =
+ FileMonitor
+ { fileMonitorCacheFile = distPackageCacheFile dparams "config"
+ , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared
+ , fileMonitorCheckIfOnlyValueChanged = False
+ }
+ , pkgFileMonitorBuild =
+ FileMonitor
+ { fileMonitorCacheFile = distPackageCacheFile dparams "build"
+ , fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt ->
+ componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt
+ , fileMonitorCheckIfOnlyValueChanged = True
+ }
+ , pkgFileMonitorReg =
+ newFileMonitor (distPackageCacheFile dparams "registration")
+ }
-- | Helper function for 'checkPackageFileMonitorChanged',
-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.
--
-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by
-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.
---
-packageFileMonitorKeyValues :: ElaboratedConfiguredPackage
- -> (ElaboratedConfiguredPackage, Set ComponentName)
+packageFileMonitorKeyValues
+ :: ElaboratedConfiguredPackage
+ -> (ElaboratedConfiguredPackage, Set ComponentName)
packageFileMonitorKeyValues elab =
- (elab_config, buildComponents)
+ (elab_config, buildComponents)
where
-- The first part is the value used to guard (re)configuring the package.
-- That is, if this value changes then we will reconfigure.
@@ -391,20 +418,19 @@ packageFileMonitorKeyValues elab =
elab_config :: ElaboratedConfiguredPackage
elab_config =
- elab {
- elabBuildTargets = [],
- elabTestTargets = [],
- elabBenchTargets = [],
- elabReplTarget = Nothing,
- elabHaddockTargets = [],
- elabBuildHaddocks = False,
-
- elabTestMachineLog = Nothing,
- elabTestHumanLog = Nothing,
- elabTestShowDetails = Nothing,
- elabTestKeepTix = False,
- elabTestTestOptions = [],
- elabBenchmarkOptions = []
+ elab
+ { elabBuildTargets = []
+ , elabTestTargets = []
+ , elabBenchTargets = []
+ , elabReplTarget = Nothing
+ , elabHaddockTargets = []
+ , elabBuildHaddocks = False
+ , elabTestMachineLog = Nothing
+ , elabTestHumanLog = Nothing
+ , elabTestShowDetails = Nothing
+ , elabTestKeepTix = False
+ , elabTestTestOptions = []
+ , elabBenchmarkOptions = []
}
-- The second part is the value used to guard the build step. So this is
@@ -416,137 +442,172 @@ packageFileMonitorKeyValues elab =
-- | Do all the checks on whether a package has changed and thus needs either
-- rebuilding or reconfiguring and rebuilding.
---
-checkPackageFileMonitorChanged :: PackageFileMonitor
- -> ElaboratedConfiguredPackage
- -> FilePath
- -> [BuildStatus]
- -> IO (Either BuildStatusRebuild BuildResult)
-checkPackageFileMonitorChanged PackageFileMonitor{..}
- pkg srcdir depsBuildStatus = do
- --TODO: [nice to have] some debug-level message about file
- --changes, like rerunIfChanged
- configChanged <- checkFileMonitorChanged
- pkgFileMonitorConfig srcdir pkgconfig
+checkPackageFileMonitorChanged
+ :: PackageFileMonitor
+ -> ElaboratedConfiguredPackage
+ -> FilePath
+ -> [BuildStatus]
+ -> IO (Either BuildStatusRebuild BuildResult)
+checkPackageFileMonitorChanged
+ PackageFileMonitor{..}
+ pkg
+ srcdir
+ depsBuildStatus = do
+ -- TODO: [nice to have] some debug-level message about file
+ -- changes, like rerunIfChanged
+ configChanged <-
+ checkFileMonitorChanged
+ pkgFileMonitorConfig
+ srcdir
+ pkgconfig
case configChanged of
MonitorChanged monitorReason ->
- return (Left (BuildStatusConfigure monitorReason'))
+ return (Left (BuildStatusConfigure monitorReason'))
where
monitorReason' = fmap (const ()) monitorReason
-
MonitorUnchanged () _
- -- The configChanged here includes the identity of the dependencies,
- -- so depsBuildStatus is just needed for the changes in the content
- -- of dependencies.
+ -- The configChanged here includes the identity of the dependencies,
+ -- so depsBuildStatus is just needed for the changes in the content
+ -- of dependencies.
| any buildStatusRequiresBuild depsBuildStatus -> do
regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
let mreg = changedToMaybe regChanged
return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))
-
| otherwise -> do
- buildChanged <- checkFileMonitorChanged
- pkgFileMonitorBuild srcdir buildComponents
- regChanged <- checkFileMonitorChanged
- pkgFileMonitorReg srcdir ()
+ buildChanged <-
+ checkFileMonitorChanged
+ pkgFileMonitorBuild
+ srcdir
+ buildComponents
+ regChanged <-
+ checkFileMonitorChanged
+ pkgFileMonitorReg
+ srcdir
+ ()
let mreg = changedToMaybe regChanged
case (buildChanged, regChanged) of
(MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->
- return (Left (BuildStatusBuild mreg buildReason))
+ return (Left (BuildStatusBuild mreg buildReason))
where
buildReason = BuildReasonExtraTargets prevBuildComponents
-
(MonitorChanged monitorReason, _) ->
- return (Left (BuildStatusBuild mreg buildReason))
+ return (Left (BuildStatusBuild mreg buildReason))
where
- buildReason = BuildReasonFilesChanged monitorReason'
+ buildReason = BuildReasonFilesChanged monitorReason'
monitorReason' = fmap (const ()) monitorReason
-
(MonitorUnchanged _ _, MonitorChanged monitorReason) ->
-- this should only happen if the file is corrupt or been
-- manually deleted. We don't want to bother with another
-- phase just for this, so we'll reregister by doing a build.
- return (Left (BuildStatusBuild Nothing buildReason))
+ return (Left (BuildStatusBuild Nothing buildReason))
where
- buildReason = BuildReasonFilesChanged monitorReason'
+ buildReason = BuildReasonFilesChanged monitorReason'
monitorReason' = fmap (const ()) monitorReason
-
(MonitorUnchanged _ _, MonitorUnchanged _ _)
| pkgHasEphemeralBuildTargets pkg ->
- return (Left (BuildStatusBuild mreg buildReason))
+ return (Left (BuildStatusBuild mreg buildReason))
where
buildReason = BuildReasonEphemeralTargets
-
(MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->
- return $ Right BuildResult {
- buildResultDocs = docsResult,
- buildResultTests = testsResult,
- buildResultLogFile = Nothing
- }
+ return $
+ Right
+ BuildResult
+ { buildResultDocs = docsResult
+ , buildResultTests = testsResult
+ , buildResultLogFile = Nothing
+ }
where
(docsResult, testsResult) = buildResult
- where
- (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
- changedToMaybe :: MonitorChanged a b -> Maybe b
- changedToMaybe (MonitorChanged _) = Nothing
- changedToMaybe (MonitorUnchanged x _) = Just x
-
-
-updatePackageConfigFileMonitor :: PackageFileMonitor
- -> FilePath
- -> ElaboratedConfiguredPackage
- -> IO ()
-updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}
- srcdir pkg =
- updateFileMonitor pkgFileMonitorConfig srcdir Nothing
- [] pkgconfig ()
- where
- (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg
-
-updatePackageBuildFileMonitor :: PackageFileMonitor
- -> FilePath
- -> MonitorTimestamp
- -> ElaboratedConfiguredPackage
- -> BuildStatusRebuild
- -> [MonitorFilePath]
- -> BuildResultMisc
- -> IO ()
-updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
- srcdir timestamp pkg pkgBuildStatus
- monitors buildResult =
- updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
- monitors buildComponents' buildResult
- where
- (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
-
- -- If the only thing that's changed is that we're now building extra
- -- components, then we can avoid later unnecessary rebuilds by saving the
- -- total set of components that have been built, namely the union of the
- -- existing ones plus the new ones. If files also changed this would be
- -- the wrong thing to do. Note that we rely on the
- -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
- -- that it's /only/ the value that changed not any files that changed.
- buildComponents' =
- case pkgBuildStatus of
- BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)
- -> buildComponents `Set.union` prevBuildComponents
- _ -> buildComponents
-
-updatePackageRegFileMonitor :: PackageFileMonitor
- -> FilePath
- -> Maybe InstalledPackageInfo
- -> IO ()
-updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}
- srcdir mipkg =
- updateFileMonitor pkgFileMonitorReg srcdir Nothing
- [] () mipkg
+ where
+ (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
+ changedToMaybe :: MonitorChanged a b -> Maybe b
+ changedToMaybe (MonitorChanged _) = Nothing
+ changedToMaybe (MonitorUnchanged x _) = Just x
+
+updatePackageConfigFileMonitor
+ :: PackageFileMonitor
+ -> FilePath
+ -> ElaboratedConfiguredPackage
+ -> IO ()
+updatePackageConfigFileMonitor
+ PackageFileMonitor{pkgFileMonitorConfig}
+ srcdir
+ pkg =
+ updateFileMonitor
+ pkgFileMonitorConfig
+ srcdir
+ Nothing
+ []
+ pkgconfig
+ ()
+ where
+ (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg
+
+updatePackageBuildFileMonitor
+ :: PackageFileMonitor
+ -> FilePath
+ -> MonitorTimestamp
+ -> ElaboratedConfiguredPackage
+ -> BuildStatusRebuild
+ -> [MonitorFilePath]
+ -> BuildResultMisc
+ -> IO ()
+updatePackageBuildFileMonitor
+ PackageFileMonitor{pkgFileMonitorBuild}
+ srcdir
+ timestamp
+ pkg
+ pkgBuildStatus
+ monitors
+ buildResult =
+ updateFileMonitor
+ pkgFileMonitorBuild
+ srcdir
+ (Just timestamp)
+ monitors
+ buildComponents'
+ buildResult
+ where
+ (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
+
+ -- If the only thing that's changed is that we're now building extra
+ -- components, then we can avoid later unnecessary rebuilds by saving the
+ -- total set of components that have been built, namely the union of the
+ -- existing ones plus the new ones. If files also changed this would be
+ -- the wrong thing to do. Note that we rely on the
+ -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
+ -- that it's /only/ the value that changed not any files that changed.
+ buildComponents' =
+ case pkgBuildStatus of
+ BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) ->
+ buildComponents `Set.union` prevBuildComponents
+ _ -> buildComponents
+
+updatePackageRegFileMonitor
+ :: PackageFileMonitor
+ -> FilePath
+ -> Maybe InstalledPackageInfo
+ -> IO ()
+updatePackageRegFileMonitor
+ PackageFileMonitor{pkgFileMonitorReg}
+ srcdir
+ mipkg =
+ updateFileMonitor
+ pkgFileMonitorReg
+ srcdir
+ Nothing
+ []
+ ()
+ mipkg
invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
- removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
-
+ removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
------------------------------------------------------------------------------
+
-- * Doing it: executing an 'ElaboratedInstallPlan'
+
------------------------------------------------------------------------------
-- Refer to ProjectBuilding.Types for details of these important types:
@@ -560,153 +621,186 @@ invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
-- | Build things for real.
--
-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
---
-rebuildTargets :: Verbosity
- -> ProjectConfig
- -> DistDirLayout
- -> StoreDirLayout
- -> ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> BuildStatusMap
- -> BuildTimeSettings
- -> IO BuildOutcomes
-rebuildTargets verbosity
- ProjectConfig {
- projectConfigBuildOnly = config
- }
- distDirLayout@DistDirLayout{..}
- storeDirLayout
- installPlan
- sharedPackageConfig@ElaboratedSharedConfig {
- pkgConfigCompiler = compiler,
- pkgConfigCompilerProgs = progdb
- }
- pkgsBuildStatus
- buildSettings@BuildTimeSettings{
- buildSettingNumJobs,
- buildSettingKeepGoing
- }
- | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
- | otherwise = do
- -- Concurrency control: create the job controller and concurrency limits
- -- for downloading, building and installing.
- jobControl <- if isParallelBuild
- then newParallelJobControl buildSettingNumJobs
- else newSerialJobControl
- registerLock <- newLock -- serialise registration
- cacheLock <- newLock -- serialise access to setup exe cache
- --TODO: [code cleanup] eliminate setup exe cache
-
- debug verbosity $
- "Executing install plan "
- ++ if isParallelBuild
- then " in parallel using " ++ show buildSettingNumJobs ++ " threads."
- else " serially."
-
- createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
- createDirectoryIfMissingVerbose verbosity True distTempDirectory
- traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
-
- -- Before traversing the install plan, preemptively find all packages that
- -- will need to be downloaded and start downloading them.
- asyncDownloadPackages verbosity withRepoCtx
- installPlan pkgsBuildStatus $ \downloadMap ->
-
- -- For each package in the plan, in dependency order, but in parallel...
- InstallPlan.execute jobControl keepGoing
- (BuildFailure Nothing . DependentFailed . packageId)
- installPlan $ \pkg ->
- --TODO: review exception handling
- handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
-
- let uid = installedUnitId pkg
- pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in
-
- rebuildTarget
+rebuildTargets
+ :: Verbosity
+ -> ProjectConfig
+ -> DistDirLayout
+ -> StoreDirLayout
+ -> ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> BuildStatusMap
+ -> BuildTimeSettings
+ -> IO BuildOutcomes
+rebuildTargets
+ verbosity
+ ProjectConfig
+ { projectConfigBuildOnly = config
+ }
+ distDirLayout@DistDirLayout{..}
+ storeDirLayout
+ installPlan
+ sharedPackageConfig@ElaboratedSharedConfig
+ { pkgConfigCompiler = compiler
+ , pkgConfigCompilerProgs = progdb
+ }
+ pkgsBuildStatus
+ buildSettings@BuildTimeSettings
+ { buildSettingNumJobs
+ , buildSettingKeepGoing
+ }
+ | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
+ | otherwise = do
+ -- Concurrency control: create the job controller and concurrency limits
+ -- for downloading, building and installing.
+ jobControl <-
+ if isParallelBuild
+ then newParallelJobControl buildSettingNumJobs
+ else newSerialJobControl
+ registerLock <- newLock -- serialise registration
+ cacheLock <- newLock -- serialise access to setup exe cache
+ -- TODO: [code cleanup] eliminate setup exe cache
+ debug verbosity $
+ "Executing install plan "
+ ++ if isParallelBuild
+ then " in parallel using " ++ show buildSettingNumJobs ++ " threads."
+ else " serially."
+
+ createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
+ createDirectoryIfMissingVerbose verbosity True distTempDirectory
+ traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
+
+ -- Before traversing the install plan, preemptively find all packages that
+ -- will need to be downloaded and start downloading them.
+ asyncDownloadPackages
verbosity
- distDirLayout
- storeDirLayout
- buildSettings downloadMap
- registerLock cacheLock
- sharedPackageConfig
- installPlan pkg
- pkgBuildStatus
- where
- isParallelBuild = buildSettingNumJobs >= 2
- keepGoing = buildSettingKeepGoing
- withRepoCtx = projectConfigWithBuilderRepoContext verbosity
- buildSettings
- packageDBsToUse = -- all the package dbs we may need to create
- (Set.toList . Set.fromList)
- [ pkgdb
- | InstallPlan.Configured elab <- InstallPlan.toList installPlan
- , pkgdb <- concat [ elabBuildPackageDBStack elab
- , elabRegisterPackageDBStack elab
- , elabSetupPackageDBStack elab ]
+ withRepoCtx
+ installPlan
+ pkgsBuildStatus
+ $ \downloadMap ->
+ -- For each package in the plan, in dependency order, but in parallel...
+ InstallPlan.execute
+ jobControl
+ keepGoing
+ (BuildFailure Nothing . DependentFailed . packageId)
+ installPlan
+ $ \pkg ->
+ -- TODO: review exception handling
+ handle (\(e :: BuildFailure) -> return (Left e)) $
+ fmap Right $
+ let uid = installedUnitId pkg
+ pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus
+ in rebuildTarget
+ verbosity
+ distDirLayout
+ storeDirLayout
+ buildSettings
+ downloadMap
+ registerLock
+ cacheLock
+ sharedPackageConfig
+ installPlan
+ pkg
+ pkgBuildStatus
+ where
+ isParallelBuild = buildSettingNumJobs >= 2
+ keepGoing = buildSettingKeepGoing
+ withRepoCtx =
+ projectConfigWithBuilderRepoContext
+ verbosity
+ buildSettings
+ packageDBsToUse =
+ -- all the package dbs we may need to create
+ (Set.toList . Set.fromList)
+ [ pkgdb
+ | InstallPlan.Configured elab <- InstallPlan.toList installPlan
+ , pkgdb <-
+ concat
+ [ elabBuildPackageDBStack elab
+ , elabRegisterPackageDBStack elab
+ , elabSetupPackageDBStack elab
+ ]
+ ]
+
+ offlineError :: BuildOutcomes
+ offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload
+ where
+ makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome)
+ makeBuildOutcome
+ ElaboratedConfiguredPackage
+ { elabUnitId
+ , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion}
+ } =
+ ( elabUnitId
+ , Left
+ ( BuildFailure
+ { buildFailureLogFile = Nothing
+ , buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion
+ }
+ )
+ )
+ makeError :: PackageName -> Version -> String
+ makeError n v =
+ "--offline was specified, hence refusing to download the package: "
+ ++ unPackageName n
+ ++ " version "
+ ++ Disp.render (pretty v)
+
+ packagesToDownload :: [ElaboratedConfiguredPackage]
+ packagesToDownload =
+ [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, isRemote $ elabPkgSourceLocation elab
]
-
- offlineError :: BuildOutcomes
- offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload
- where
- makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome)
- makeBuildOutcome ElaboratedConfiguredPackage {
- elabUnitId,
- elabPkgSourceId = PackageIdentifier { pkgName, pkgVersion }
- } = (elabUnitId, Left (BuildFailure {
- buildFailureLogFile = Nothing,
- buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion
- }))
- makeError :: PackageName -> Version -> String
- makeError n v = "--offline was specified, hence refusing to download the package: "
- ++ unPackageName n
- ++ " version " ++ Disp.render (pretty v)
-
- packagesToDownload :: [ElaboratedConfiguredPackage]
- packagesToDownload = [elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan,
- isRemote $ elabPkgSourceLocation elab]
- where
- isRemote :: PackageLocation a -> Bool
- isRemote (RemoteTarballPackage _ _) = True
- isRemote (RepoTarballPackage {}) = True
- isRemote (RemoteSourceRepoPackage _ _) = True
- isRemote _ = False
-
+ where
+ isRemote :: PackageLocation a -> Bool
+ isRemote (RemoteTarballPackage _ _) = True
+ isRemote (RepoTarballPackage{}) = True
+ isRemote (RemoteSourceRepoPackage _ _) = True
+ isRemote _ = False
-- | Create a package DB if it does not currently exist. Note that this action
-- is /not/ safe to run concurrently.
---
-createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb
- -> PackageDB -> IO ()
-createPackageDBIfMissing verbosity compiler progdb
- (SpecificPackageDB dbPath) = do
+createPackageDBIfMissing
+ :: Verbosity
+ -> Compiler
+ -> ProgramDb
+ -> PackageDB
+ -> IO ()
+createPackageDBIfMissing
+ verbosity
+ compiler
+ progdb
+ (SpecificPackageDB dbPath) = do
exists <- Cabal.doesPackageDBExist dbPath
unless exists $ do
createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
Cabal.createPackageDB verbosity compiler progdb False dbPath
createPackageDBIfMissing _ _ _ _ = return ()
-
-- | Given all the context and resources, (re)build an individual package.
---
-rebuildTarget :: Verbosity
- -> DistDirLayout
- -> StoreDirLayout
- -> BuildTimeSettings
- -> AsyncFetchMap
- -> Lock -> Lock
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> ElaboratedReadyPackage
- -> BuildStatus
- -> IO BuildResult
-rebuildTarget verbosity
- distDirLayout@DistDirLayout{distBuildDirectory}
- storeDirLayout
- buildSettings downloadMap
- registerLock cacheLock
- sharedPackageConfig
- plan rpkg@(ReadyPackage pkg)
- pkgBuildStatus
+rebuildTarget
+ :: Verbosity
+ -> DistDirLayout
+ -> StoreDirLayout
+ -> BuildTimeSettings
+ -> AsyncFetchMap
+ -> Lock
+ -> Lock
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedReadyPackage
+ -> BuildStatus
+ -> IO BuildResult
+rebuildTarget
+ verbosity
+ distDirLayout@DistDirLayout{distBuildDirectory}
+ storeDirLayout
+ buildSettings
+ downloadMap
+ registerLock
+ cacheLock
+ sharedPackageConfig
+ plan
+ rpkg@(ReadyPackage pkg)
+ pkgBuildStatus
-- Technically, doing the --only-download filtering only in this function is
-- not perfect. We could also prune the plan at an earlier stage, like it's
-- done with --only-dependencies. But...
@@ -722,77 +816,89 @@ rebuildTarget verbosity
_ -> return ()
return $ BuildResult DocsNotTried TestsNotTried Nothing
| otherwise =
- -- We rely on the 'BuildStatus' to decide which phase to start from:
- case pkgBuildStatus of
- BuildStatusDownload -> downloadPhase
- BuildStatusUnpack tarball -> unpackTarballPhase tarball
- BuildStatusRebuild srcdir status -> rebuildPhase status srcdir
-
- -- TODO: perhaps re-nest the types to make these impossible
- BuildStatusPreExisting {} -> unexpectedState
- BuildStatusInstalled {} -> unexpectedState
- BuildStatusUpToDate {} -> unexpectedState
- where
- unexpectedState = error "rebuildTarget: unexpected package status"
-
- downloadPhase :: IO BuildResult
- downloadPhase = do
- downsrcloc <- annotateFailureNoLog DownloadFailed $
- waitAsyncPackageDownload verbosity downloadMap pkg
+ -- We rely on the 'BuildStatus' to decide which phase to start from:
+ case pkgBuildStatus of
+ BuildStatusDownload -> downloadPhase
+ BuildStatusUnpack tarball -> unpackTarballPhase tarball
+ BuildStatusRebuild srcdir status -> rebuildPhase status srcdir
+ -- TODO: perhaps re-nest the types to make these impossible
+ BuildStatusPreExisting{} -> unexpectedState
+ BuildStatusInstalled{} -> unexpectedState
+ BuildStatusUpToDate{} -> unexpectedState
+ where
+ unexpectedState = error "rebuildTarget: unexpected package status"
+
+ downloadPhase :: IO BuildResult
+ downloadPhase = do
+ downsrcloc <-
+ annotateFailureNoLog DownloadFailed $
+ waitAsyncPackageDownload verbosity downloadMap pkg
case downsrcloc of
DownloadedTarball tarball -> unpackTarballPhase tarball
- --TODO: [nice to have] git/darcs repos etc
+ -- TODO: [nice to have] git/darcs repos etc
-
- unpackTarballPhase :: FilePath -> IO BuildResult
- unpackTarballPhase tarball =
+ unpackTarballPhase :: FilePath -> IO BuildResult
+ unpackTarballPhase tarball =
withTarballLocalDirectory
- verbosity distDirLayout tarball
- (packageId pkg) (elabDistDirParams sharedPackageConfig pkg)
+ verbosity
+ distDirLayout
+ tarball
+ (packageId pkg)
+ (elabDistDirParams sharedPackageConfig pkg)
(elabBuildStyle pkg)
- (elabPkgDescriptionOverride pkg) $
-
- case elabBuildStyle pkg of
- BuildAndInstall -> buildAndInstall
+ (elabPkgDescriptionOverride pkg)
+ $ case elabBuildStyle pkg of
+ BuildAndInstall -> buildAndInstall
BuildInplaceOnly -> buildInplace buildStatus
where
buildStatus = BuildStatusConfigure MonitorFirstRun
- -- Note that this really is rebuild, not build. It can only happen for
- -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
- -- would only start from download or unpack phases.
- --
- rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult
- rebuildPhase buildStatus srcdir =
+ -- Note that this really is rebuild, not build. It can only happen for
+ -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
+ -- would only start from download or unpack phases.
+ --
+ rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult
+ rebuildPhase buildStatus srcdir =
assert (elabBuildStyle pkg == BuildInplaceOnly) $
-
buildInplace buildStatus srcdir builddir
- where
- builddir = distBuildDirectory
- (elabDistDirParams sharedPackageConfig pkg)
+ where
+ builddir =
+ distBuildDirectory
+ (elabDistDirParams sharedPackageConfig pkg)
- buildAndInstall :: FilePath -> FilePath -> IO BuildResult
- buildAndInstall srcdir builddir =
+ buildAndInstall :: FilePath -> FilePath -> IO BuildResult
+ buildAndInstall srcdir builddir =
buildAndInstallUnpackedPackage
- verbosity distDirLayout storeDirLayout
- buildSettings registerLock cacheLock
+ verbosity
+ distDirLayout
+ storeDirLayout
+ buildSettings
+ registerLock
+ cacheLock
sharedPackageConfig
- plan rpkg
- srcdir builddir'
- where
- builddir' = makeRelative srcdir builddir
- --TODO: [nice to have] ^^ do this relative stuff better
+ plan
+ rpkg
+ srcdir
+ builddir'
+ where
+ builddir' = makeRelative srcdir builddir
+ -- TODO: [nice to have] ^^ do this relative stuff better
- buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
- buildInplace buildStatus srcdir builddir =
- --TODO: [nice to have] use a relative build dir rather than absolute
+ buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
+ buildInplace buildStatus srcdir builddir =
+ -- TODO: [nice to have] use a relative build dir rather than absolute
buildInplaceUnpackedPackage
- verbosity distDirLayout
- buildSettings registerLock cacheLock
+ verbosity
+ distDirLayout
+ buildSettings
+ registerLock
+ cacheLock
sharedPackageConfig
- plan rpkg
+ plan
+ rpkg
buildStatus
- srcdir builddir
+ srcdir
+ builddir
-- TODO: [nice to have] do we need to use a with-style for the temp
-- files for downloading http packages, or are we going to cache them
@@ -806,62 +912,65 @@ rebuildTarget verbosity
-- The body action is passed a map from those packages (identified by their
-- location) to a completion var for that package. So the body action should
-- lookup the location and use 'waitAsyncPackageDownload' to get the result.
---
-asyncDownloadPackages :: Verbosity
- -> ((RepoContext -> IO a) -> IO a)
- -> ElaboratedInstallPlan
- -> BuildStatusMap
- -> (AsyncFetchMap -> IO a)
- -> IO a
+asyncDownloadPackages
+ :: Verbosity
+ -> ((RepoContext -> IO a) -> IO a)
+ -> ElaboratedInstallPlan
+ -> BuildStatusMap
+ -> (AsyncFetchMap -> IO a)
+ -> IO a
asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
| null pkgsToDownload = body Map.empty
- | otherwise = withRepoCtx $ \repoctx ->
- asyncFetchPackages verbosity repoctx
- pkgsToDownload body
+ | otherwise = withRepoCtx $ \repoctx ->
+ asyncFetchPackages
+ verbosity
+ repoctx
+ pkgsToDownload
+ body
where
pkgsToDownload :: [PackageLocation (Maybe FilePath)]
pkgsToDownload =
ordNub $
- [ elabPkgSourceLocation elab
- | InstallPlan.Configured elab
- <- InstallPlan.reverseTopologicalOrder installPlan
- , let uid = installedUnitId elab
- pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
- , BuildStatusDownload <- [pkgBuildStatus]
- ]
-
+ [ elabPkgSourceLocation elab
+ | InstallPlan.Configured elab <-
+ InstallPlan.reverseTopologicalOrder installPlan
+ , let uid = installedUnitId elab
+ pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
+ , BuildStatusDownload <- [pkgBuildStatus]
+ ]
-- | Check if a package needs downloading, and if so expect to find a download
-- in progress in the given 'AsyncFetchMap' and wait on it to finish.
---
-waitAsyncPackageDownload :: Verbosity
- -> AsyncFetchMap
- -> ElaboratedConfiguredPackage
- -> IO DownloadedSourceLocation
+waitAsyncPackageDownload
+ :: Verbosity
+ -> AsyncFetchMap
+ -> ElaboratedConfiguredPackage
+ -> IO DownloadedSourceLocation
waitAsyncPackageDownload verbosity downloadMap elab = do
- pkgloc <- waitAsyncFetchPackage verbosity downloadMap
- (elabPkgSourceLocation elab)
- case downloadedSourceLocation pkgloc of
- Just loc -> return loc
- Nothing -> fail "waitAsyncPackageDownload: unexpected source location"
+ pkgloc <-
+ waitAsyncFetchPackage
+ verbosity
+ downloadMap
+ (elabPkgSourceLocation elab)
+ case downloadedSourceLocation pkgloc of
+ Just loc -> return loc
+ Nothing -> fail "waitAsyncPackageDownload: unexpected source location"
data DownloadedSourceLocation = DownloadedTarball FilePath
- --TODO: [nice to have] git/darcs repos etc
-
-downloadedSourceLocation :: PackageLocation FilePath
- -> Maybe DownloadedSourceLocation
-downloadedSourceLocation pkgloc =
- case pkgloc of
- RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
- RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
- _ -> Nothing
-
+-- TODO: [nice to have] git/darcs repos etc
+downloadedSourceLocation
+ :: PackageLocation FilePath
+ -> Maybe DownloadedSourceLocation
+downloadedSourceLocation pkgloc =
+ case pkgloc of
+ RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
+ RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
+ _ -> Nothing
-- | Ensure that the package is unpacked in an appropriate directory, either
-- a temporary one or a persistent one under the shared dist directory.
---
withTarballLocalDirectory
:: Verbosity
-> DistDirLayout
@@ -870,85 +979,109 @@ withTarballLocalDirectory
-> DistDirParams
-> BuildStyle
-> Maybe CabalFileText
- -> (FilePath -> -- Source directory
- FilePath -> -- Build directory
- IO a)
+ -> ( FilePath -- Source directory
+ -> FilePath -- Build directory
+ -> IO a
+ )
-> IO a
-withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
- tarball pkgid dparams buildstyle pkgTextOverride
- buildPkg =
- case buildstyle of
- -- In this case we make a temp dir (e.g. tmp/src2345/), unpack
- -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for
- -- compatibility we put the dist dir within it
- -- (i.e. tmp/src2345/foo-1.0/dist/).
- --
- -- Unfortunately, a few custom Setup.hs scripts do not respect
- -- the --builddir flag and always look for it at ./dist/ so
- -- this way we avoid breaking those packages
- BuildAndInstall ->
- let tmpdir = distTempDirectory in
- withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do
- unpackPackageTarball verbosity tarball unpackdir
- pkgid pkgTextOverride
- let srcdir = unpackdir </> prettyShow pkgid
- builddir = srcdir </> "dist"
- buildPkg srcdir builddir
-
- -- In this case we make sure the tarball has been unpacked to the
- -- appropriate location under the shared dist dir, and then build it
- -- inplace there
- BuildInplaceOnly -> do
- let srcrootdir = distUnpackedSrcRootDirectory
- srcdir = distUnpackedSrcDirectory pkgid
- builddir = distBuildDirectory dparams
- -- TODO: [nice to have] use a proper file monitor rather
- -- than this dir exists test
- exists <- doesDirectoryExist srcdir
- unless exists $ do
- createDirectoryIfMissingVerbose verbosity True srcrootdir
- unpackPackageTarball verbosity tarball srcrootdir
- pkgid pkgTextOverride
- moveTarballShippedDistDirectory verbosity distDirLayout
- srcrootdir pkgid dparams
- buildPkg srcdir builddir
-
-
-unpackPackageTarball :: Verbosity -> FilePath -> FilePath
- -> PackageId -> Maybe CabalFileText
- -> IO ()
-unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
- --TODO: [nice to have] switch to tar package and catch tar exceptions
- annotateFailureNoLog UnpackFailed $ do
-
- -- Unpack the tarball
+withTarballLocalDirectory
+ verbosity
+ distDirLayout@DistDirLayout{..}
+ tarball
+ pkgid
+ dparams
+ buildstyle
+ pkgTextOverride
+ buildPkg =
+ case buildstyle of
+ -- In this case we make a temp dir (e.g. tmp/src2345/), unpack
+ -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for
+ -- compatibility we put the dist dir within it
+ -- (i.e. tmp/src2345/foo-1.0/dist/).
--
- info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
- Tar.extractTarGzFile parentdir pkgsubdir tarball
+ -- Unfortunately, a few custom Setup.hs scripts do not respect
+ -- the --builddir flag and always look for it at ./dist/ so
+ -- this way we avoid breaking those packages
+ BuildAndInstall ->
+ let tmpdir = distTempDirectory
+ in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do
+ unpackPackageTarball
+ verbosity
+ tarball
+ unpackdir
+ pkgid
+ pkgTextOverride
+ let srcdir = unpackdir </> prettyShow pkgid
+ builddir = srcdir </> "dist"
+ buildPkg srcdir builddir
+
+ -- In this case we make sure the tarball has been unpacked to the
+ -- appropriate location under the shared dist dir, and then build it
+ -- inplace there
+ BuildInplaceOnly -> do
+ let srcrootdir = distUnpackedSrcRootDirectory
+ srcdir = distUnpackedSrcDirectory pkgid
+ builddir = distBuildDirectory dparams
+ -- TODO: [nice to have] use a proper file monitor rather
+ -- than this dir exists test
+ exists <- doesDirectoryExist srcdir
+ unless exists $ do
+ createDirectoryIfMissingVerbose verbosity True srcrootdir
+ unpackPackageTarball
+ verbosity
+ tarball
+ srcrootdir
+ pkgid
+ pkgTextOverride
+ moveTarballShippedDistDirectory
+ verbosity
+ distDirLayout
+ srcrootdir
+ pkgid
+ dparams
+ buildPkg srcdir builddir
+
+unpackPackageTarball
+ :: Verbosity
+ -> FilePath
+ -> FilePath
+ -> PackageId
+ -> Maybe CabalFileText
+ -> IO ()
+unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
+ -- TODO: [nice to have] switch to tar package and catch tar exceptions
+ annotateFailureNoLog UnpackFailed $ do
+ -- Unpack the tarball
+ --
+ info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
+ Tar.extractTarGzFile parentdir pkgsubdir tarball
- -- Sanity check
- --
- exists <- doesFileExist cabalFile
- unless exists $
- die' verbosity $
+ -- Sanity check
+ --
+ exists <- doesFileExist cabalFile
+ unless exists $
+ die' verbosity $
"Package .cabal file not found in the tarball: " ++ cabalFile
- -- Overwrite the .cabal with the one from the index, when appropriate
- --
- case pkgTextOverride of
- Nothing -> return ()
- Just pkgtxt -> do
- info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal"
- ++ " with the latest revision from the index."
- writeFileAtomic cabalFile pkgtxt
-
+ -- Overwrite the .cabal with the one from the index, when appropriate
+ --
+ case pkgTextOverride of
+ Nothing -> return ()
+ Just pkgtxt -> do
+ info verbosity $
+ "Updating "
+ ++ prettyShow pkgname <.> "cabal"
+ ++ " with the latest revision from the index."
+ writeFileAtomic cabalFile pkgtxt
where
cabalFile :: FilePath
- cabalFile = parentdir </> pkgsubdir
- </> prettyShow pkgname <.> "cabal"
+ cabalFile =
+ parentdir
+ </> pkgsubdir
+ </> prettyShow pkgname
+ <.> "cabal"
pkgsubdir = prettyShow pkgid
- pkgname = packageName pkgid
-
+ pkgname = packageName pkgid
-- | This is a bit of a hacky workaround. A number of packages ship
-- pre-processed .hs files in a dist directory inside the tarball. We don't
@@ -956,54 +1089,71 @@ unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
-- right place then we'll miss the shipped pre-processed files. This hacky
-- approach to shipped pre-processed files ought to be replaced by a proper
-- system, though we'll still need to keep this hack for older packages.
---
-moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout
- -> FilePath -> PackageId -> DistDirParams
- -> IO ()
-moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
- parentdir pkgid dparams = do
+moveTarballShippedDistDirectory
+ :: Verbosity
+ -> DistDirLayout
+ -> FilePath
+ -> PackageId
+ -> DistDirParams
+ -> IO ()
+moveTarballShippedDistDirectory
+ verbosity
+ DistDirLayout{distBuildDirectory}
+ parentdir
+ pkgid
+ dparams = do
distDirExists <- doesDirectoryExist tarballDistDir
when distDirExists $ do
- debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"
- ++ targetDistDir ++ "'"
- --TODO: [nice to have] or perhaps better to copy, and use a file monitor
+ debug verbosity $
+ "Moving '"
+ ++ tarballDistDir
+ ++ "' to '"
+ ++ targetDistDir
+ ++ "'"
+ -- TODO: [nice to have] or perhaps better to copy, and use a file monitor
renameDirectory tarballDistDir targetDistDir
- where
- tarballDistDir = parentdir </> prettyShow pkgid </> "dist"
- targetDistDir = distBuildDirectory dparams
-
-
-buildAndInstallUnpackedPackage :: Verbosity
- -> DistDirLayout
- -> StoreDirLayout
- -> BuildTimeSettings -> Lock -> Lock
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> ElaboratedReadyPackage
- -> FilePath -> FilePath
- -> IO BuildResult
-buildAndInstallUnpackedPackage verbosity
- distDirLayout@DistDirLayout{distTempDirectory}
- storeDirLayout@StoreDirLayout {
- storePackageDBStack
- }
- BuildTimeSettings {
- buildSettingNumJobs,
- buildSettingLogFile
- }
- registerLock cacheLock
- pkgshared@ElaboratedSharedConfig {
- pkgConfigPlatform = platform,
- pkgConfigCompiler = compiler,
- pkgConfigCompilerProgs = progdb
- }
- plan rpkg@(ReadyPackage pkg)
- srcdir builddir = do
+ where
+ tarballDistDir = parentdir </> prettyShow pkgid </> "dist"
+ targetDistDir = distBuildDirectory dparams
+buildAndInstallUnpackedPackage
+ :: Verbosity
+ -> DistDirLayout
+ -> StoreDirLayout
+ -> BuildTimeSettings
+ -> Lock
+ -> Lock
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedReadyPackage
+ -> FilePath
+ -> FilePath
+ -> IO BuildResult
+buildAndInstallUnpackedPackage
+ verbosity
+ distDirLayout@DistDirLayout{distTempDirectory}
+ storeDirLayout@StoreDirLayout
+ { storePackageDBStack
+ }
+ BuildTimeSettings
+ { buildSettingNumJobs
+ , buildSettingLogFile
+ }
+ registerLock
+ cacheLock
+ pkgshared@ElaboratedSharedConfig
+ { pkgConfigPlatform = platform
+ , pkgConfigCompiler = compiler
+ , pkgConfigCompilerProgs = progdb
+ }
+ plan
+ rpkg@(ReadyPackage pkg)
+ srcdir
+ builddir = do
createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)
initLogFile
- --TODO: [code cleanup] deal consistently with talking to older
+ -- TODO: [code cleanup] deal consistently with talking to older
-- Setup.hs versions, much like we do for ghc, with a proper
-- options type and rendering step which will also let us
-- call directly into the lib, rather than always going via
@@ -1011,8 +1161,8 @@ buildAndInstallUnpackedPackage verbosity
-- passing data like installed packages, compiler, and
-- program db for a quicker configure.
- --TODO: [required feature] docs and tests
- --TODO: [required feature] sudo re-exec
+ -- TODO: [required feature] docs and tests
+ -- TODO: [required feature] sudo re-exec
-- Configure phase
noticeProgress ProgressStarting
@@ -1035,15 +1185,15 @@ buildAndInstallUnpackedPackage verbosity
-- Install phase
noticeProgress ProgressInstalling
annotateFailure mlogFile InstallFailed $ do
-
let copyPkgFiles tmpDir = do
let tmpDirNormalised = normalise tmpDir
setup Cabal.copyCommand (copyFlags tmpDirNormalised)
-- Note that the copy command has put the files into
-- @$tmpDir/$prefix@ so we need to return this dir so
-- the store knows which dir will be the final store entry.
- let prefix = normalise $
- dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
+ let prefix =
+ normalise $
+ dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
entryDir = tmpDirNormalised </> prefix
-- if there weren't anything to build, it might be that directory is not created
@@ -1051,7 +1201,7 @@ buildAndInstallUnpackedPackage verbosity
-- https://github.com/haskell/cabal/issues/4130
createDirectoryIfMissingVerbose verbosity True entryDir
- let hashFileName = entryDir </> "cabal-hash.txt"
+ let hashFileName = entryDir </> "cabal-hash.txt"
outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg)
info verbosity $
@@ -1074,8 +1224,9 @@ buildAndInstallUnpackedPackage verbosity
-- We also normalise paths to ensure that there are no
-- different representations for the same path. Like / and
-- \\ on windows under msys.
- otherFiles <- filter (not . isPrefixOf entryDir) <$>
- listFilesRecursive tmpDirNormalised
+ otherFiles <-
+ filter (not . isPrefixOf entryDir)
+ <$> listFilesRecursive tmpDirNormalised
-- Here's where we could keep track of the installed files
-- ourselves if we wanted to by making a manifest of the
-- files in the tmp dir.
@@ -1093,33 +1244,43 @@ buildAndInstallUnpackedPackage verbosity
registerPkg
| not (elabRequiresRegistration pkg) =
- debug verbosity $
- "registerPkg: elab does NOT require registration for "
- ++ prettyShow uid
+ debug verbosity $
+ "registerPkg: elab does NOT require registration for "
+ ++ prettyShow uid
| otherwise = do
- -- We register ourselves rather than via Setup.hs. We need to
- -- grab and modify the InstalledPackageInfo. We decide what
- -- the installed package id is, not the build system.
- ipkg0 <- generateInstalledPackageInfo
- let ipkg = ipkg0 { Installed.installedUnitId = uid }
- assert ( elabRegisterPackageDBStack pkg
- == storePackageDBStack compid) (return ())
- criticalSection registerLock $
- Cabal.registerPackage
- verbosity compiler progdb
- (storePackageDBStack compid) ipkg
- Cabal.defaultRegisterOptions {
- Cabal.registerMultiInstance = True,
- Cabal.registerSuppressFilesCheck = True
- }
-
+ -- We register ourselves rather than via Setup.hs. We need to
+ -- grab and modify the InstalledPackageInfo. We decide what
+ -- the installed package id is, not the build system.
+ ipkg0 <- generateInstalledPackageInfo
+ let ipkg = ipkg0{Installed.installedUnitId = uid}
+ assert
+ ( elabRegisterPackageDBStack pkg
+ == storePackageDBStack compid
+ )
+ (return ())
+ criticalSection registerLock $
+ Cabal.registerPackage
+ verbosity
+ compiler
+ progdb
+ (storePackageDBStack compid)
+ ipkg
+ Cabal.defaultRegisterOptions
+ { Cabal.registerMultiInstance = True
+ , Cabal.registerSuppressFilesCheck = True
+ }
-- Actual installation
- void $ newStoreEntry verbosity storeDirLayout
- compid uid
- copyPkgFiles registerPkg
+ void $
+ newStoreEntry
+ verbosity
+ storeDirLayout
+ compid
+ uid
+ copyPkgFiles
+ registerPkg
- --TODO: [nice to have] we currently rely on Setup.hs copy to do the right
+ -- TODO: [nice to have] we currently rely on Setup.hs copy to do the right
-- thing. Although we do copy into an image dir and do the move into the
-- final location ourselves, perhaps we ought to do some sanity checks on
-- the image dir first.
@@ -1129,412 +1290,529 @@ buildAndInstallUnpackedPackage verbosity
-- 'withWin32SelfUpgrade' dance, but it would be necessary for a
-- shared bin dir.
- --TODO: [required feature] docs and test phases
- let docsResult = DocsNotTried
+ -- TODO: [required feature] docs and test phases
+ let docsResult = DocsNotTried
testsResult = TestsNotTried
noticeProgress ProgressCompleted
- return BuildResult {
- buildResultDocs = docsResult,
- buildResultTests = testsResult,
- buildResultLogFile = mlogFile
- }
-
- where
- pkgid = packageId rpkg
- uid = installedUnitId rpkg
- compid = compilerId compiler
-
- dispname :: String
- dispname = case elabPkgOrComp pkg of
- ElabPackage _ -> prettyShow pkgid
+ return
+ BuildResult
+ { buildResultDocs = docsResult
+ , buildResultTests = testsResult
+ , buildResultLogFile = mlogFile
+ }
+ where
+ pkgid = packageId rpkg
+ uid = installedUnitId rpkg
+ compid = compilerId compiler
+
+ dispname :: String
+ dispname = case elabPkgOrComp pkg of
+ ElabPackage _ ->
+ prettyShow pkgid
++ " (all, legacy fallback)"
- ElabComponent comp -> prettyShow pkgid
- ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")"
-
- noticeProgress :: ProgressPhase -> IO ()
- noticeProgress phase = when isParallelBuild $
- progressMessage verbosity phase dispname
-
- isParallelBuild = buildSettingNumJobs >= 2
-
- whenHaddock action
- | hasValidHaddockTargets pkg = action
- | otherwise = return ()
-
- configureCommand = Cabal.configureCommand defaultProgramDb
- configureFlags v = flip filterConfigureFlags v $
- setupHsConfigureFlags rpkg pkgshared
- verbosity builddir
- configureArgs _ = setupHsConfigureArgs pkg
-
- buildCommand = Cabal.buildCommand defaultProgramDb
- buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir
-
- haddockCommand = Cabal.haddockCommand
- haddockFlags _ = setupHsHaddockFlags pkg pkgshared
- verbosity builddir
-
- generateInstalledPackageInfo :: IO InstalledPackageInfo
- generateInstalledPackageInfo =
- withTempInstalledPackageInfoFile
- verbosity distTempDirectory $ \pkgConfDest -> do
- let registerFlags _ = setupHsRegisterFlags
- pkg pkgshared
- verbosity builddir
- pkgConfDest
- setup Cabal.registerCommand registerFlags
-
- copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity
- builddir destdir
-
- scriptOptions = setupHsScriptOptions rpkg plan pkgshared
- distDirLayout srcdir builddir
- isParallelBuild cacheLock
-
- setup :: CommandUI flags -> (Version -> flags) -> IO ()
- setup cmd flags = setup' cmd flags (const [])
-
- setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
- -> IO ()
- setup' cmd flags args =
- withLogging $ \mLogFileHandle ->
- setupWrapper
+ ElabComponent comp ->
+ prettyShow pkgid
+ ++ " ("
+ ++ maybe "custom" prettyShow (compComponentName comp)
+ ++ ")"
+
+ noticeProgress :: ProgressPhase -> IO ()
+ noticeProgress phase =
+ when isParallelBuild $
+ progressMessage verbosity phase dispname
+
+ isParallelBuild = buildSettingNumJobs >= 2
+
+ whenHaddock action
+ | hasValidHaddockTargets pkg = action
+ | otherwise = return ()
+
+ configureCommand = Cabal.configureCommand defaultProgramDb
+ configureFlags v =
+ flip filterConfigureFlags v $
+ setupHsConfigureFlags
+ rpkg
+ pkgshared
+ verbosity
+ builddir
+ configureArgs _ = setupHsConfigureArgs pkg
+
+ buildCommand = Cabal.buildCommand defaultProgramDb
+ buildFlags _ = setupHsBuildFlags pkg pkgshared verbosity builddir
+
+ haddockCommand = Cabal.haddockCommand
+ haddockFlags _ =
+ setupHsHaddockFlags
+ pkg
+ pkgshared
verbosity
- scriptOptions
- { useLoggingHandle = mLogFileHandle
- , useExtraEnvOverrides = dataDirsEnvironmentForPlan
- distDirLayout plan }
- (Just (elabPkgDescription pkg))
- cmd flags args
-
- mlogFile :: Maybe FilePath
- mlogFile =
- case buildSettingLogFile of
- Nothing -> Nothing
- Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
-
- initLogFile :: IO ()
- initLogFile =
- case mlogFile of
- Nothing -> return ()
- Just logFile -> do
- createDirectoryIfMissing True (takeDirectory logFile)
- exists <- doesFileExist logFile
- when exists $ removeFile logFile
-
- withLogging :: (Maybe Handle -> IO r) -> IO r
- withLogging action =
- case mlogFile of
- Nothing -> action Nothing
- Just logFile -> withFile logFile AppendMode (action . Just)
+ builddir
+ generateInstalledPackageInfo :: IO InstalledPackageInfo
+ generateInstalledPackageInfo =
+ withTempInstalledPackageInfoFile
+ verbosity
+ distTempDirectory
+ $ \pkgConfDest -> do
+ let registerFlags _ =
+ setupHsRegisterFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ pkgConfDest
+ setup Cabal.registerCommand registerFlags
+
+ copyFlags destdir _ =
+ setupHsCopyFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ destdir
+
+ scriptOptions =
+ setupHsScriptOptions
+ rpkg
+ plan
+ pkgshared
+ distDirLayout
+ srcdir
+ builddir
+ isParallelBuild
+ cacheLock
+
+ setup :: CommandUI flags -> (Version -> flags) -> IO ()
+ setup cmd flags = setup' cmd flags (const [])
+
+ setup'
+ :: CommandUI flags
+ -> (Version -> flags)
+ -> (Version -> [String])
+ -> IO ()
+ setup' cmd flags args =
+ withLogging $ \mLogFileHandle ->
+ setupWrapper
+ verbosity
+ scriptOptions
+ { useLoggingHandle = mLogFileHandle
+ , useExtraEnvOverrides =
+ dataDirsEnvironmentForPlan
+ distDirLayout
+ plan
+ }
+ (Just (elabPkgDescription pkg))
+ cmd
+ flags
+ args
+
+ mlogFile :: Maybe FilePath
+ mlogFile =
+ case buildSettingLogFile of
+ Nothing -> Nothing
+ Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
+
+ initLogFile :: IO ()
+ initLogFile =
+ case mlogFile of
+ Nothing -> return ()
+ Just logFile -> do
+ createDirectoryIfMissing True (takeDirectory logFile)
+ exists <- doesFileExist logFile
+ when exists $ removeFile logFile
+
+ withLogging :: (Maybe Handle -> IO r) -> IO r
+ withLogging action =
+ case mlogFile of
+ Nothing -> action Nothing
+ Just logFile -> withFile logFile AppendMode (action . Just)
hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
hasValidHaddockTargets ElaboratedConfiguredPackage{..}
| not elabBuildHaddocks = False
- | otherwise = any componentHasHaddocks components
+ | otherwise = any componentHasHaddocks components
where
components :: [ComponentTarget]
- components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets
- ++ maybeToList elabReplTarget ++ elabHaddockTargets
+ components =
+ elabBuildTargets
+ ++ elabTestTargets
+ ++ elabBenchTargets
+ ++ maybeToList elabReplTarget
+ ++ elabHaddockTargets
componentHasHaddocks :: ComponentTarget -> Bool
componentHasHaddocks (ComponentTarget name _) =
case name of
- CLibName LMainLibName -> hasHaddocks
- CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks
- CFLibName _ -> elabHaddockForeignLibs && hasHaddocks
- CExeName _ -> elabHaddockExecutables && hasHaddocks
- CTestName _ -> elabHaddockTestSuites && hasHaddocks
- CBenchName _ -> elabHaddockBenchmarks && hasHaddocks
+ CLibName LMainLibName -> hasHaddocks
+ CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks
+ CFLibName _ -> elabHaddockForeignLibs && hasHaddocks
+ CExeName _ -> elabHaddockExecutables && hasHaddocks
+ CTestName _ -> elabHaddockTestSuites && hasHaddocks
+ CBenchName _ -> elabHaddockBenchmarks && hasHaddocks
where
hasHaddocks = not (null (elabPkgDescription ^. componentModules name))
+buildInplaceUnpackedPackage
+ :: Verbosity
+ -> DistDirLayout
+ -> BuildTimeSettings
+ -> Lock
+ -> Lock
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedReadyPackage
+ -> BuildStatusRebuild
+ -> FilePath
+ -> FilePath
+ -> IO BuildResult
+buildInplaceUnpackedPackage
+ verbosity
+ distDirLayout@DistDirLayout
+ { distTempDirectory
+ , distPackageCacheDirectory
+ , distDirectory
+ , distHaddockOutputDir
+ }
+ BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen}
+ registerLock
+ cacheLock
+ pkgshared@ElaboratedSharedConfig
+ { pkgConfigCompiler = compiler
+ , pkgConfigCompilerProgs = progdb
+ , pkgConfigPlatform = platform
+ }
+ plan
+ rpkg@(ReadyPackage pkg)
+ buildStatus
+ srcdir
+ builddir = do
+ -- TODO: [code cleanup] there is duplication between the
+ -- distdirlayout and the builddir here builddir is not
+ -- enough, we also need the per-package cachedir
+ createDirectoryIfMissingVerbose verbosity True builddir
+ createDirectoryIfMissingVerbose
+ verbosity
+ True
+ (distPackageCacheDirectory dparams)
+
+ -- Configure phase
+ --
+ whenReConfigure $ do
+ annotateFailureNoLog ConfigureFailed $
+ setup configureCommand configureFlags configureArgs
+ invalidatePackageRegFileMonitor packageFileMonitor
+ updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
+
+ -- Build phase
+ --
+ let docsResult = DocsNotTried
+ testsResult = TestsNotTried
-buildInplaceUnpackedPackage :: Verbosity
- -> DistDirLayout
- -> BuildTimeSettings -> Lock -> Lock
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> ElaboratedReadyPackage
- -> BuildStatusRebuild
- -> FilePath -> FilePath
- -> IO BuildResult
-buildInplaceUnpackedPackage verbosity
- distDirLayout@DistDirLayout {
- distTempDirectory,
- distPackageCacheDirectory,
- distDirectory,
- distHaddockOutputDir
- }
- BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen}
- registerLock cacheLock
- pkgshared@ElaboratedSharedConfig {
- pkgConfigCompiler = compiler,
- pkgConfigCompilerProgs = progdb,
- pkgConfigPlatform = platform
- }
- plan
- rpkg@(ReadyPackage pkg)
- buildStatus
- srcdir builddir = do
-
- --TODO: [code cleanup] there is duplication between the
- -- distdirlayout and the builddir here builddir is not
- -- enough, we also need the per-package cachedir
- createDirectoryIfMissingVerbose verbosity True builddir
- createDirectoryIfMissingVerbose verbosity True
- (distPackageCacheDirectory dparams)
-
- -- Configure phase
- --
- whenReConfigure $ do
- annotateFailureNoLog ConfigureFailed $
- setup configureCommand configureFlags configureArgs
- invalidatePackageRegFileMonitor packageFileMonitor
- updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
-
- -- Build phase
- --
- let docsResult = DocsNotTried
- testsResult = TestsNotTried
-
- buildResult :: BuildResultMisc
- buildResult = (docsResult, testsResult)
-
- whenRebuild $ do
- timestamp <- beginUpdateFileMonitor
- annotateFailureNoLog BuildFailed $
- setup buildCommand buildFlags buildArgs
-
- let listSimple =
- execRebuild srcdir (needElaboratedConfiguredPackage pkg)
- listSdist =
- fmap (map monitorFileHashed) $
- allPackageSourceFiles verbosity srcdir
- ifNullThen m m' = do xs <- m
- if null xs then m' else return xs
- monitors <- case PD.buildType (elabPkgDescription pkg) of
- Simple -> listSimple
- -- If a Custom setup was used, AND the Cabal is recent
- -- enough to have sdist --list-sources, use that to
- -- determine the files that we need to track. This can
- -- cause unnecessary rebuilding (for example, if README
- -- is edited, we will try to rebuild) but there isn't
- -- a more accurate Custom interface we can use to get
- -- this info. We prefer not to use listSimple here
- -- as it can miss extra source files that are considered
- -- by the Custom setup.
- _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17]
+ buildResult :: BuildResultMisc
+ buildResult = (docsResult, testsResult)
+
+ whenRebuild $ do
+ timestamp <- beginUpdateFileMonitor
+ annotateFailureNoLog BuildFailed $
+ setup buildCommand buildFlags buildArgs
+
+ let listSimple =
+ execRebuild srcdir (needElaboratedConfiguredPackage pkg)
+ listSdist =
+ fmap (map monitorFileHashed) $
+ allPackageSourceFiles verbosity srcdir
+ ifNullThen m m' = do
+ xs <- m
+ if null xs then m' else return xs
+ monitors <- case PD.buildType (elabPkgDescription pkg) of
+ Simple -> listSimple
+ -- If a Custom setup was used, AND the Cabal is recent
+ -- enough to have sdist --list-sources, use that to
+ -- determine the files that we need to track. This can
+ -- cause unnecessary rebuilding (for example, if README
+ -- is edited, we will try to rebuild) but there isn't
+ -- a more accurate Custom interface we can use to get
+ -- this info. We prefer not to use listSimple here
+ -- as it can miss extra source files that are considered
+ -- by the Custom setup.
+ _
+ | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] ->
-- However, sometimes sdist --list-sources will fail
-- and return an empty list. In that case, fall
-- back on the (inaccurate) simple tracking.
- -> listSdist `ifNullThen` listSimple
- | otherwise
- -> listSimple
-
- let dep_monitors = map monitorFileHashed
- $ elabInplaceDependencyBuildCacheFiles
- distDirLayout pkgshared plan pkg
- updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
- pkg buildStatus
- (monitors ++ dep_monitors) buildResult
-
- -- PURPOSELY omitted: no copy!
-
- whenReRegister $ annotateFailureNoLog InstallFailed $ do
- -- Register locally
- mipkg <- if elabRequiresRegistration pkg
- then do
- ipkg0 <- generateInstalledPackageInfo
- -- We register ourselves rather than via Setup.hs. We need to
- -- grab and modify the InstalledPackageInfo. We decide what
- -- the installed package id is, not the build system.
- let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }
- criticalSection registerLock $
- Cabal.registerPackage verbosity compiler progdb
- (elabRegisterPackageDBStack pkg)
- ipkg Cabal.defaultRegisterOptions
- return (Just ipkg)
-
- else return Nothing
-
- updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
-
- whenTest $ do
- annotateFailureNoLog TestsFailed $
- setup testCommand testFlags testArgs
-
- whenBench $
- annotateFailureNoLog BenchFailed $
- setup benchCommand benchFlags benchArgs
-
- -- Repl phase
- --
- whenRepl $
- annotateFailureNoLog ReplFailed $
- setupInteractive replCommand replFlags replArgs
-
- -- Haddock phase
- whenHaddock $
- annotateFailureNoLog HaddocksFailed $ do
- setup haddockCommand haddockFlags haddockArgs
- let haddockTarget = elabHaddockForHackage pkg
- when (haddockTarget == Cabal.ForHackage) $ do
- let dest = distDirectory </> name <.> "tar.gz"
- name = haddockDirName haddockTarget (elabPkgDescription pkg)
- docDir = distBuildDirectory distDirLayout dparams
- </> "doc" </> "html"
- Tar.createTarGzFile dest docDir name
- notice verbosity $ "Documentation tarball created: " ++ dest
-
- when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do
- let dest = docDir </> "index.html"
- name = haddockDirName haddockTarget (elabPkgDescription pkg)
- docDir = case distHaddockOutputDir of
- Nothing -> distBuildDirectory distDirLayout dparams </> "doc" </> "html" </> name
- Just dir -> dir
- exe <- findOpenProgramLocation platform
- case exe of
- Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])
- Left err -> die' verbosity err
-
-
- return BuildResult {
- buildResultDocs = docsResult,
- buildResultTests = testsResult,
- buildResultLogFile = Nothing
- }
+ listSdist `ifNullThen` listSimple
+ | otherwise ->
+ listSimple
+
+ let dep_monitors =
+ map monitorFileHashed $
+ elabInplaceDependencyBuildCacheFiles
+ distDirLayout
+ pkgshared
+ plan
+ pkg
+ updatePackageBuildFileMonitor
+ packageFileMonitor
+ srcdir
+ timestamp
+ pkg
+ buildStatus
+ (monitors ++ dep_monitors)
+ buildResult
+
+ -- PURPOSELY omitted: no copy!
+
+ whenReRegister $ annotateFailureNoLog InstallFailed $ do
+ -- Register locally
+ mipkg <-
+ if elabRequiresRegistration pkg
+ then do
+ ipkg0 <- generateInstalledPackageInfo
+ -- We register ourselves rather than via Setup.hs. We need to
+ -- grab and modify the InstalledPackageInfo. We decide what
+ -- the installed package id is, not the build system.
+ let ipkg = ipkg0{Installed.installedUnitId = ipkgid}
+ criticalSection registerLock $
+ Cabal.registerPackage
+ verbosity
+ compiler
+ progdb
+ (elabRegisterPackageDBStack pkg)
+ ipkg
+ Cabal.defaultRegisterOptions
+ return (Just ipkg)
+ else return Nothing
+
+ updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
+
+ whenTest $ do
+ annotateFailureNoLog TestsFailed $
+ setup testCommand testFlags testArgs
+
+ whenBench $
+ annotateFailureNoLog BenchFailed $
+ setup benchCommand benchFlags benchArgs
+
+ -- Repl phase
+ --
+ whenRepl $
+ annotateFailureNoLog ReplFailed $
+ setupInteractive replCommand replFlags replArgs
- where
- ipkgid = installedUnitId pkg
- dparams = elabDistDirParams pkgshared pkg
+ -- Haddock phase
+ whenHaddock $
+ annotateFailureNoLog HaddocksFailed $ do
+ setup haddockCommand haddockFlags haddockArgs
+ let haddockTarget = elabHaddockForHackage pkg
+ when (haddockTarget == Cabal.ForHackage) $ do
+ let dest = distDirectory </> name <.> "tar.gz"
+ name = haddockDirName haddockTarget (elabPkgDescription pkg)
+ docDir =
+ distBuildDirectory distDirLayout dparams
+ </> "doc"
+ </> "html"
+ Tar.createTarGzFile dest docDir name
+ notice verbosity $ "Documentation tarball created: " ++ dest
+
+ when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do
+ let dest = docDir </> "index.html"
+ name = haddockDirName haddockTarget (elabPkgDescription pkg)
+ docDir = case distHaddockOutputDir of
+ Nothing -> distBuildDirectory distDirLayout dparams </> "doc" </> "html" </> name
+ Just dir -> dir
+ exe <- findOpenProgramLocation platform
+ case exe of
+ Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])
+ Left err -> die' verbosity err
+
+ return
+ BuildResult
+ { buildResultDocs = docsResult
+ , buildResultTests = testsResult
+ , buildResultLogFile = Nothing
+ }
+ where
+ ipkgid = installedUnitId pkg
+ dparams = elabDistDirParams pkgshared pkg
- isParallelBuild = buildSettingNumJobs >= 2
+ isParallelBuild = buildSettingNumJobs >= 2
- packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
+ packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
- whenReConfigure action = case buildStatus of
- BuildStatusConfigure _ -> action
- _ -> return ()
+ whenReConfigure action = case buildStatus of
+ BuildStatusConfigure _ -> action
+ _ -> return ()
- whenRebuild action
- | null (elabBuildTargets pkg)
- -- NB: we have to build the test/bench suite!
- , null (elabTestTargets pkg)
- , null (elabBenchTargets pkg) = return ()
- | otherwise = action
+ whenRebuild action
+ | null (elabBuildTargets pkg)
+ , -- NB: we have to build the test/bench suite!
+ null (elabTestTargets pkg)
+ , null (elabBenchTargets pkg) =
+ return ()
+ | otherwise = action
- whenTest action
- | null (elabTestTargets pkg) = return ()
- | otherwise = action
+ whenTest action
+ | null (elabTestTargets pkg) = return ()
+ | otherwise = action
- whenBench action
- | null (elabBenchTargets pkg) = return ()
- | otherwise = action
+ whenBench action
+ | null (elabBenchTargets pkg) = return ()
+ | otherwise = action
- whenRepl action
- | isNothing (elabReplTarget pkg) = return ()
- | otherwise = action
+ whenRepl action
+ | isNothing (elabReplTarget pkg) = return ()
+ | otherwise = action
- whenHaddock action
- | hasValidHaddockTargets pkg = action
- | otherwise = return ()
+ whenHaddock action
+ | hasValidHaddockTargets pkg = action
+ | otherwise = return ()
- whenReRegister action
- = case buildStatus of
+ whenReRegister action =
+ case buildStatus of
-- We registered the package already
- BuildStatusBuild (Just _) _ ->
+ BuildStatusBuild (Just _) _ ->
info verbosity "whenReRegister: previously registered"
-- There is nothing to register
- _ | null (elabBuildTargets pkg) ->
- info verbosity "whenReRegister: nothing to register"
- | otherwise -> action
-
- configureCommand = Cabal.configureCommand defaultProgramDb
- configureFlags v = flip filterConfigureFlags v $
- setupHsConfigureFlags rpkg pkgshared
- verbosity builddir
- configureArgs _ = setupHsConfigureArgs pkg
-
- buildCommand = Cabal.buildCommand defaultProgramDb
- buildFlags _ = setupHsBuildFlags pkg pkgshared
- verbosity builddir
- buildArgs _ = setupHsBuildArgs pkg
-
- testCommand = Cabal.testCommand -- defaultProgramDb
- testFlags v = flip filterTestFlags v $
- setupHsTestFlags pkg pkgshared
- verbosity builddir
- testArgs _ = setupHsTestArgs pkg
-
- benchCommand = Cabal.benchmarkCommand
- benchFlags _ = setupHsBenchFlags pkg pkgshared
- verbosity builddir
- benchArgs _ = setupHsBenchArgs pkg
-
- replCommand = Cabal.replCommand defaultProgramDb
- replFlags _ = setupHsReplFlags pkg pkgshared
- verbosity builddir
- replArgs _ = setupHsReplArgs pkg
-
- haddockCommand = Cabal.haddockCommand
- haddockFlags v = flip filterHaddockFlags v $
- setupHsHaddockFlags pkg pkgshared
- verbosity builddir
- haddockArgs v = flip filterHaddockArgs v $
- setupHsHaddockArgs pkg
-
- scriptOptions = setupHsScriptOptions rpkg plan pkgshared
- distDirLayout srcdir builddir
- isParallelBuild cacheLock
-
- setupInteractive :: CommandUI flags
- -> (Version -> flags) -> (Version -> [String]) -> IO ()
- setupInteractive cmd flags args =
- setupWrapper verbosity
- scriptOptions { isInteractive = True }
- (Just (elabPkgDescription pkg))
- cmd flags args
-
- setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
- -> IO ()
- setup cmd flags args =
- setupWrapper verbosity
- scriptOptions
- (Just (elabPkgDescription pkg))
- cmd flags args
-
- generateInstalledPackageInfo :: IO InstalledPackageInfo
- generateInstalledPackageInfo =
- withTempInstalledPackageInfoFile
- verbosity distTempDirectory $ \pkgConfDest -> do
- let registerFlags _ = setupHsRegisterFlags
- pkg pkgshared
- verbosity builddir
- pkgConfDest
- setup Cabal.registerCommand registerFlags (const [])
-
-withTempInstalledPackageInfoFile :: Verbosity -> FilePath
- -> (FilePath -> IO ())
- -> IO InstalledPackageInfo
+ _
+ | null (elabBuildTargets pkg) ->
+ info verbosity "whenReRegister: nothing to register"
+ | otherwise -> action
+
+ configureCommand = Cabal.configureCommand defaultProgramDb
+ configureFlags v =
+ flip filterConfigureFlags v $
+ setupHsConfigureFlags
+ rpkg
+ pkgshared
+ verbosity
+ builddir
+ configureArgs _ = setupHsConfigureArgs pkg
+
+ buildCommand = Cabal.buildCommand defaultProgramDb
+ buildFlags _ =
+ setupHsBuildFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ buildArgs _ = setupHsBuildArgs pkg
+
+ testCommand = Cabal.testCommand -- defaultProgramDb
+ testFlags v =
+ flip filterTestFlags v $
+ setupHsTestFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ testArgs _ = setupHsTestArgs pkg
+
+ benchCommand = Cabal.benchmarkCommand
+ benchFlags _ =
+ setupHsBenchFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ benchArgs _ = setupHsBenchArgs pkg
+
+ replCommand = Cabal.replCommand defaultProgramDb
+ replFlags _ =
+ setupHsReplFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ replArgs _ = setupHsReplArgs pkg
+
+ haddockCommand = Cabal.haddockCommand
+ haddockFlags v =
+ flip filterHaddockFlags v $
+ setupHsHaddockFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ haddockArgs v =
+ flip filterHaddockArgs v $
+ setupHsHaddockArgs pkg
+
+ scriptOptions =
+ setupHsScriptOptions
+ rpkg
+ plan
+ pkgshared
+ distDirLayout
+ srcdir
+ builddir
+ isParallelBuild
+ cacheLock
+
+ setupInteractive
+ :: CommandUI flags
+ -> (Version -> flags)
+ -> (Version -> [String])
+ -> IO ()
+ setupInteractive cmd flags args =
+ setupWrapper
+ verbosity
+ scriptOptions{isInteractive = True}
+ (Just (elabPkgDescription pkg))
+ cmd
+ flags
+ args
+
+ setup
+ :: CommandUI flags
+ -> (Version -> flags)
+ -> (Version -> [String])
+ -> IO ()
+ setup cmd flags args =
+ setupWrapper
+ verbosity
+ scriptOptions
+ (Just (elabPkgDescription pkg))
+ cmd
+ flags
+ args
+
+ generateInstalledPackageInfo :: IO InstalledPackageInfo
+ generateInstalledPackageInfo =
+ withTempInstalledPackageInfoFile
+ verbosity
+ distTempDirectory
+ $ \pkgConfDest -> do
+ let registerFlags _ =
+ setupHsRegisterFlags
+ pkg
+ pkgshared
+ verbosity
+ builddir
+ pkgConfDest
+ setup Cabal.registerCommand registerFlags (const [])
+
+withTempInstalledPackageInfoFile
+ :: Verbosity
+ -> FilePath
+ -> (FilePath -> IO ())
+ -> IO InstalledPackageInfo
withTempInstalledPackageInfoFile verbosity tempdir action =
- withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
- -- make absolute since @action@ will often change directory
- abs_dir <- canonicalizePath dir
+ withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
+ -- make absolute since @action@ will often change directory
+ abs_dir <- canonicalizePath dir
- let pkgConfDest = abs_dir </> "pkgConf"
- action pkgConfDest
+ let pkgConfDest = abs_dir </> "pkgConf"
+ action pkgConfDest
- readPkgConf "." pkgConfDest
+ readPkgConf "." pkgConfDest
where
pkgConfParseFailed :: String -> IO a
pkgConfParseFailed perror =
die' verbosity $
- "Couldn't parse the output of 'setup register --gen-pkg-config':"
- ++ show perror
+ "Couldn't parse the output of 'setup register --gen-pkg-config':"
+ ++ show perror
readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
readPkgConf pkgConfDir pkgConfFile = do
@@ -1544,15 +1822,18 @@ withTempInstalledPackageInfoFile verbosity tempdir action =
Right (warns, ipkg) -> return (warns, ipkg)
unless (null warns) $
- warn verbosity $ unlines warns
+ warn verbosity $
+ unlines warns
return ipkg
-
------------------------------------------------------------------------------
+
-- * Utilities
+
------------------------------------------------------------------------------
+{- FOURMOLU_DISABLE -}
annotateFailureNoLog :: (SomeException -> BuildFailureReason)
-> IO a -> IO a
annotateFailureNoLog annotate action =
diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs
index 684ec033956b6c34d3f84b61cc0645f64f3ee8aa..397a01ee68e023090514967c8bc1ec414f5353e5 100644
--- a/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectBuilding/Types.hs
@@ -3,36 +3,34 @@
-- | Types for the "Distribution.Client.ProjectBuilding"
--
-- Moved out to avoid module cycles.
---
-module Distribution.Client.ProjectBuilding.Types (
- -- * Pre-build status
- BuildStatusMap,
- BuildStatus(..),
- buildStatusRequiresBuild,
- buildStatusToString,
- BuildStatusRebuild(..),
- BuildReason(..),
- MonitorChangedReason(..),
+module Distribution.Client.ProjectBuilding.Types
+ ( -- * Pre-build status
+ BuildStatusMap
+ , BuildStatus (..)
+ , buildStatusRequiresBuild
+ , buildStatusToString
+ , BuildStatusRebuild (..)
+ , BuildReason (..)
+ , MonitorChangedReason (..)
-- * Build outcomes
- BuildOutcomes,
- BuildOutcome,
- BuildResult(..),
- BuildFailure(..),
- BuildFailureReason(..),
+ , BuildOutcomes
+ , BuildOutcome
+ , BuildResult (..)
+ , BuildFailure (..)
+ , BuildFailureReason (..)
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.Types (DocsResult, TestsResult)
-import Distribution.Client.FileMonitor (MonitorChangedReason(..))
+import Distribution.Client.FileMonitor (MonitorChangedReason (..))
+import Distribution.Client.Types (DocsResult, TestsResult)
-import Distribution.Package (UnitId, PackageId)
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.Package (PackageId, UnitId)
import Distribution.Simple.LocalBuildInfo (ComponentName)
-
------------------------------------------------------------------------------
-- Pre-build status: result of the dry run
--
@@ -40,7 +38,6 @@ import Distribution.Simple.LocalBuildInfo (ComponentName)
-- | The 'BuildStatus' of every package in the 'ElaboratedInstallPlan'.
--
-- This is used as the result of the dry-run of building an install plan.
---
type BuildStatusMap = Map UnitId BuildStatus
-- | The build status for an individual package is the state that the
@@ -56,150 +53,124 @@ type BuildStatusMap = Map UnitId BuildStatus
--
-- * It tell us what step to start or resume building from, and carries
-- enough information for us to be able to do so.
---
-data BuildStatus =
-
- -- | The package is in the 'InstallPlan.PreExisting' state, so does not
- -- need building.
- BuildStatusPreExisting
-
- -- | The package is in the 'InstallPlan.Installed' state, so does not
- -- need building.
- | BuildStatusInstalled
-
- -- | The package has not been downloaded yet, so it will have to be
- -- downloaded, unpacked and built.
- | BuildStatusDownload
-
- -- | The package has not been unpacked yet, so it will have to be
- -- unpacked and built.
- | BuildStatusUnpack FilePath
-
- -- | The package exists in a local dir already, and just needs building
- -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style
- -- packages.
- | BuildStatusRebuild FilePath BuildStatusRebuild
-
- -- | The package exists in a local dir already, and is fully up to date.
- -- So this package can be put into the 'InstallPlan.Installed' state
- -- and it does not need to be built.
- | BuildStatusUpToDate BuildResult
-
+data BuildStatus
+ = -- | The package is in the 'InstallPlan.PreExisting' state, so does not
+ -- need building.
+ BuildStatusPreExisting
+ | -- | The package is in the 'InstallPlan.Installed' state, so does not
+ -- need building.
+ BuildStatusInstalled
+ | -- | The package has not been downloaded yet, so it will have to be
+ -- downloaded, unpacked and built.
+ BuildStatusDownload
+ | -- | The package has not been unpacked yet, so it will have to be
+ -- unpacked and built.
+ BuildStatusUnpack FilePath
+ | -- | The package exists in a local dir already, and just needs building
+ -- or rebuilding. So this can only happen for 'BuildInplaceOnly' style
+ -- packages.
+ BuildStatusRebuild FilePath BuildStatusRebuild
+ | -- | The package exists in a local dir already, and is fully up to date.
+ -- So this package can be put into the 'InstallPlan.Installed' state
+ -- and it does not need to be built.
+ BuildStatusUpToDate BuildResult
-- | Which 'BuildStatus' values indicate we'll have to do some build work of
-- some sort. In particular we use this as part of checking if any of a
-- package's deps have changed.
---
buildStatusRequiresBuild :: BuildStatus -> Bool
buildStatusRequiresBuild BuildStatusPreExisting = False
-buildStatusRequiresBuild BuildStatusInstalled = False
-buildStatusRequiresBuild BuildStatusUpToDate {} = False
-buildStatusRequiresBuild _ = True
+buildStatusRequiresBuild BuildStatusInstalled = False
+buildStatusRequiresBuild BuildStatusUpToDate{} = False
+buildStatusRequiresBuild _ = True
-- | This is primarily here for debugging. It's not actually used anywhere.
---
buildStatusToString :: BuildStatus -> String
-buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting"
-buildStatusToString BuildStatusInstalled = "BuildStatusInstalled"
-buildStatusToString BuildStatusDownload = "BuildStatusDownload"
-buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp
+buildStatusToString BuildStatusPreExisting = "BuildStatusPreExisting"
+buildStatusToString BuildStatusInstalled = "BuildStatusInstalled"
+buildStatusToString BuildStatusDownload = "BuildStatusDownload"
+buildStatusToString (BuildStatusUnpack fp) = "BuildStatusUnpack " ++ show fp
buildStatusToString (BuildStatusRebuild fp _) = "BuildStatusRebuild " ++ show fp
-buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate"
-
+buildStatusToString (BuildStatusUpToDate _) = "BuildStatusUpToDate"
-- | For a package that is going to be built or rebuilt, the state it's in now.
--
-- So again, this tells us why a package needs to be rebuilt and what build
-- phases need to be run. The 'MonitorChangedReason' gives us details like
-- which file changed, which is mainly for high verbosity debug output.
---
-data BuildStatusRebuild =
-
- -- | The package configuration changed, so the configure and build phases
- -- needs to be (re)run.
- BuildStatusConfigure (MonitorChangedReason ())
-
- -- | The configuration has not changed but the build phase needs to be
- -- rerun. We record the reason the (re)build is needed.
- --
- -- The optional registration info here tells us if we've registered the
- -- package already, or if we still need to do that after building.
- -- @Just Nothing@ indicates that we know that no registration is
- -- necessary (e.g., executable.)
- --
- | BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason
-
-data BuildReason =
- -- | The dependencies of this package have been (re)built so the build
- -- phase needs to be rerun.
- --
- BuildReasonDepsRebuilt
-
- -- | Changes in files within the package (or first run or corrupt cache)
- | BuildReasonFilesChanged (MonitorChangedReason ())
-
- -- | An important special case is that no files have changed but the
- -- set of components the /user asked to build/ has changed. We track the
- -- set of components /we have built/, which of course only grows (until
- -- some other change resets it).
- --
- -- The @Set 'ComponentName'@ is the set of components we have built
- -- previously. When we update the monitor we take the union of the ones
- -- we have built previously with the ones the user has asked for this
- -- time and save those. See 'updatePackageBuildFileMonitor'.
- --
- | BuildReasonExtraTargets (Set ComponentName)
-
- -- | Although we're not going to build any additional targets as a whole,
- -- we're going to build some part of a component or run a repl or any
- -- other action that does not result in additional persistent artifacts.
- --
- | BuildReasonEphemeralTargets
-
+data BuildStatusRebuild
+ = -- | The package configuration changed, so the configure and build phases
+ -- needs to be (re)run.
+ BuildStatusConfigure (MonitorChangedReason ())
+ | -- | The configuration has not changed but the build phase needs to be
+ -- rerun. We record the reason the (re)build is needed.
+ --
+ -- The optional registration info here tells us if we've registered the
+ -- package already, or if we still need to do that after building.
+ -- @Just Nothing@ indicates that we know that no registration is
+ -- necessary (e.g., executable.)
+ BuildStatusBuild (Maybe (Maybe InstalledPackageInfo)) BuildReason
+
+data BuildReason
+ = -- | The dependencies of this package have been (re)built so the build
+ -- phase needs to be rerun.
+ BuildReasonDepsRebuilt
+ | -- | Changes in files within the package (or first run or corrupt cache)
+ BuildReasonFilesChanged (MonitorChangedReason ())
+ | -- | An important special case is that no files have changed but the
+ -- set of components the /user asked to build/ has changed. We track the
+ -- set of components /we have built/, which of course only grows (until
+ -- some other change resets it).
+ --
+ -- The @Set 'ComponentName'@ is the set of components we have built
+ -- previously. When we update the monitor we take the union of the ones
+ -- we have built previously with the ones the user has asked for this
+ -- time and save those. See 'updatePackageBuildFileMonitor'.
+ BuildReasonExtraTargets (Set ComponentName)
+ | -- | Although we're not going to build any additional targets as a whole,
+ -- we're going to build some part of a component or run a repl or any
+ -- other action that does not result in additional persistent artifacts.
+ BuildReasonEphemeralTargets
------------------------------------------------------------------------------
-- Build outcomes: result of the build
--
-- | A summary of the outcome for building a whole set of packages.
---
type BuildOutcomes = Map UnitId BuildOutcome
-- | A summary of the outcome for building a single package: either success
-- or failure.
---
-type BuildOutcome = Either BuildFailure BuildResult
+type BuildOutcome = Either BuildFailure BuildResult
-- | Information arising from successfully building a single package.
---
-data BuildResult = BuildResult {
- buildResultDocs :: DocsResult,
- buildResultTests :: TestsResult,
- buildResultLogFile :: Maybe FilePath
- }
- deriving Show
+data BuildResult = BuildResult
+ { buildResultDocs :: DocsResult
+ , buildResultTests :: TestsResult
+ , buildResultLogFile :: Maybe FilePath
+ }
+ deriving (Show)
-- | Information arising from the failure to build a single package.
---
-data BuildFailure = BuildFailure {
- buildFailureLogFile :: Maybe FilePath,
- buildFailureReason :: BuildFailureReason
- }
+data BuildFailure = BuildFailure
+ { buildFailureLogFile :: Maybe FilePath
+ , buildFailureReason :: BuildFailureReason
+ }
deriving (Show, Typeable)
instance Exception BuildFailure
-- | Detail on the reason that a package failed to build.
---
-data BuildFailureReason = DependentFailed PackageId
- | GracefulFailure String
- | DownloadFailed SomeException
- | UnpackFailed SomeException
- | ConfigureFailed SomeException
- | BuildFailed SomeException
- | ReplFailed SomeException
- | HaddocksFailed SomeException
- | TestsFailed SomeException
- | BenchFailed SomeException
- | InstallFailed SomeException
- deriving Show
+data BuildFailureReason
+ = DependentFailed PackageId
+ | GracefulFailure String
+ | DownloadFailed SomeException
+ | UnpackFailed SomeException
+ | ConfigureFailed SomeException
+ | BuildFailed SomeException
+ | ReplFailed SomeException
+ | HaddocksFailed SomeException
+ | TestsFailed SomeException
+ | BenchFailed SomeException
+ | InstallFailed SomeException
+ deriving (Show)
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig.hs b/cabal-install/src/Distribution/Client/ProjectConfig.hs
index 0807a305815547725a1d87dbb90c4f1ce219e180..a88ec3e829fb53b11e800b38701b2d1f9994aaab 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig.hs
@@ -1,159 +1,227 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Handling project configuration.
---
-module Distribution.Client.ProjectConfig (
-
- -- * Types for project config
- ProjectConfig(..),
- ProjectConfigBuildOnly(..),
- ProjectConfigShared(..),
- ProjectConfigProvenance(..),
- PackageConfig(..),
- MapLast(..),
- MapMappend(..),
+module Distribution.Client.ProjectConfig
+ ( -- * Types for project config
+ ProjectConfig (..)
+ , ProjectConfigBuildOnly (..)
+ , ProjectConfigShared (..)
+ , ProjectConfigProvenance (..)
+ , PackageConfig (..)
+ , MapLast (..)
+ , MapMappend (..)
-- * Project root
- findProjectRoot,
- ProjectRoot(..),
- BadProjectRoot,
+ , findProjectRoot
+ , ProjectRoot (..)
+ , BadProjectRoot
-- * Project config files
- readProjectConfig,
- readGlobalConfig,
- readProjectLocalExtraConfig,
- readProjectLocalFreezeConfig,
- reportParseResult,
- showProjectConfig,
- withProjectOrGlobalConfig,
- writeProjectLocalExtraConfig,
- writeProjectLocalFreezeConfig,
- writeProjectConfigFile,
- commandLineFlagsToProjectConfig,
+ , readProjectConfig
+ , readGlobalConfig
+ , readProjectLocalExtraConfig
+ , readProjectLocalFreezeConfig
+ , reportParseResult
+ , showProjectConfig
+ , withProjectOrGlobalConfig
+ , writeProjectLocalExtraConfig
+ , writeProjectLocalFreezeConfig
+ , writeProjectConfigFile
+ , commandLineFlagsToProjectConfig
-- * Packages within projects
- ProjectPackageLocation(..),
- BadPackageLocations(..),
- BadPackageLocation(..),
- BadPackageLocationMatch(..),
- findProjectPackages,
- fetchAndReadSourcePackages,
+ , ProjectPackageLocation (..)
+ , BadPackageLocations (..)
+ , BadPackageLocation (..)
+ , BadPackageLocationMatch (..)
+ , findProjectPackages
+ , fetchAndReadSourcePackages
-- * Resolving configuration
- lookupLocalPackageConfig,
- projectConfigWithBuilderRepoContext,
- projectConfigWithSolverRepoContext,
- SolverSettings(..),
- resolveSolverSettings,
- BuildTimeSettings(..),
- resolveBuildTimeSettings,
+ , lookupLocalPackageConfig
+ , projectConfigWithBuilderRepoContext
+ , projectConfigWithSolverRepoContext
+ , SolverSettings (..)
+ , resolveSolverSettings
+ , BuildTimeSettings (..)
+ , resolveBuildTimeSettings
-- * Checking configuration
- checkBadPerPackageCompilerPaths,
- BadPerPackageCompilerPaths(..)
+ , checkBadPerPackageCompilerPaths
+ , BadPerPackageCompilerPaths (..)
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.ProjectConfig.Types
+import Distribution.Client.Glob
+ ( isTrivialFilePathGlob
+ )
import Distribution.Client.ProjectConfig.Legacy
+import Distribution.Client.ProjectConfig.Types
import Distribution.Client.RebuildMonad
-import Distribution.Client.Glob
- ( isTrivialFilePathGlob )
import Distribution.Client.VCS
- ( validateSourceRepos, SourceRepoProblem(..)
- , VCS(..), knownVCSs, configureVCS, syncSourceRepos )
+ ( SourceRepoProblem (..)
+ , VCS (..)
+ , configureVCS
+ , knownVCSs
+ , syncSourceRepos
+ , validateSourceRepos
+ )
-import Distribution.Client.Types
-import Distribution.Client.DistDirLayout
- ( DistDirLayout(..), CabalDirLayout(..), ProjectRoot(..), defaultProjectFile )
-import Distribution.Client.GlobalFlags
- ( RepoContext(..), withRepoContext' )
import Distribution.Client.BuildReports.Types
- ( ReportLevel(..) )
+ ( ReportLevel (..)
+ )
import Distribution.Client.Config
- ( loadConfig, getConfigFilePath )
+ ( getConfigFilePath
+ , loadConfig
+ )
+import Distribution.Client.DistDirLayout
+ ( CabalDirLayout (..)
+ , DistDirLayout (..)
+ , ProjectRoot (..)
+ , defaultProjectFile
+ )
+import Distribution.Client.GlobalFlags
+ ( RepoContext (..)
+ , withRepoContext'
+ )
import Distribution.Client.HttpUtils
- ( HttpTransport, configureTransport, transportCheckHttps
- , downloadURI )
+ ( HttpTransport
+ , configureTransport
+ , downloadURI
+ , transportCheckHttps
+ )
+import Distribution.Client.Types
import Distribution.Client.Utils.Parsec (renderParseError)
-import Distribution.Solver.Types.SourcePackage
-import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.PackageConstraint
- ( PackageProperty(..) )
+ ( PackageProperty (..)
+ )
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SourcePackage
+import Distribution.Client.Setup
+ ( defaultMaxBackjumps
+ , defaultSolver
+ )
+import Distribution.Client.SrcDist
+ ( packageDirToSdist
+ )
+import Distribution.Client.Types.SourceRepo
+ ( SourceRepoList
+ , SourceRepositoryPackage (..)
+ , srpFanOut
+ )
+import Distribution.Client.Utils
+ ( determineNumJobs
+ )
+import qualified Distribution.Deprecated.ParseUtils as OldParser
+ ( ParseResult (..)
+ , locatedErrorMsg
+ , showPWarning
+ )
+import Distribution.Fields
+ ( PError
+ , PWarning
+ , runParseResult
+ , showPWarning
+ )
import Distribution.Package
- ( PackageName, PackageId, UnitId, packageId )
-import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint(..) )
-import Distribution.System
- ( Platform )
-import Distribution.Types.GenericPackageDescription
- ( GenericPackageDescription )
+ ( PackageId
+ , PackageName
+ , UnitId
+ , packageId
+ )
import Distribution.PackageDescription.Parsec
- ( parseGenericPackageDescription )
-import Distribution.Fields
- ( runParseResult, PError, PWarning, showPWarning)
-import Distribution.Types.SourceRepo
- ( RepoType(..) )
-import Distribution.Client.Types.SourceRepo
- ( SourceRepoList, SourceRepositoryPackage (..), srpFanOut )
+ ( parseGenericPackageDescription
+ )
import Distribution.Simple.Compiler
- ( Compiler, compilerInfo )
+ ( Compiler
+ , compilerInfo
+ )
+import Distribution.Simple.InstallDirs
+ ( PathTemplate
+ , fromPathTemplate
+ , initialPathTemplateEnv
+ , substPathTemplate
+ , toPathTemplate
+ )
import Distribution.Simple.Program
- ( ConfiguredProgram(..) )
+ ( ConfiguredProgram (..)
+ )
import Distribution.Simple.Setup
- ( Flag(Flag), toFlag, flagToMaybe, flagToList
- , fromFlag, fromFlagOrDefault )
-import Distribution.Client.Setup
- ( defaultSolver, defaultMaxBackjumps )
-import Distribution.Simple.InstallDirs
- ( PathTemplate, fromPathTemplate
- , toPathTemplate, substPathTemplate, initialPathTemplateEnv )
+ ( Flag (Flag)
+ , flagToList
+ , flagToMaybe
+ , fromFlag
+ , fromFlagOrDefault
+ , toFlag
+ )
import Distribution.Simple.Utils
- ( die', warn, notice, info, createDirectoryIfMissingVerbose, maybeExit, rawSystemIOWithEnv )
-import Distribution.Client.Utils
- ( determineNumJobs )
+ ( createDirectoryIfMissingVerbose
+ , die'
+ , info
+ , maybeExit
+ , notice
+ , rawSystemIOWithEnv
+ , warn
+ )
+import Distribution.System
+ ( Platform
+ )
+import Distribution.Types.GenericPackageDescription
+ ( GenericPackageDescription
+ )
+import Distribution.Types.PackageVersionConstraint
+ ( PackageVersionConstraint (..)
+ )
+import Distribution.Types.SourceRepo
+ ( RepoType (..)
+ )
import Distribution.Utils.NubList
- ( fromNubList )
+ ( fromNubList
+ )
import Distribution.Verbosity
- ( modifyVerbosity, verbose )
+ ( modifyVerbosity
+ , verbose
+ )
import Distribution.Version
- ( Version )
-import qualified Distribution.Deprecated.ParseUtils as OldParser
- ( ParseResult(..), locatedErrorMsg, showPWarning )
-import Distribution.Client.SrcDist
- ( packageDirToSdist )
+ ( Version
+ )
-import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
-import qualified Distribution.Client.Tar as Tar
import qualified Distribution.Client.GZipUtils as GZipUtils
+import qualified Distribution.Client.Tar as Tar
import Control.Monad.Trans (liftIO)
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LBS
-import qualified Data.Map as Map
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Hashable as Hashable
import qualified Data.List.NonEmpty as NE
+import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.Hashable as Hashable
import Numeric (showHex)
+import Network.URI
+ ( URI (..)
+ , URIAuth (..)
+ , parseAbsoluteURI
+ , uriToString
+ )
+import System.Directory
import System.FilePath hiding (combine)
import System.IO
- ( withBinaryFile, IOMode(ReadMode) )
-import System.Directory
-import Network.URI
- ( URI(..), URIAuth(..), parseAbsoluteURI, uriToString )
-
+ ( IOMode (ReadMode)
+ , withBinaryFile
+ )
----------------------------------------
-- Resolving configuration to settings
@@ -162,237 +230,268 @@ import Network.URI
-- | Look up a 'PackageConfig' field in the 'ProjectConfig' for a specific
-- 'PackageName'. This returns the configuration that applies to all local
-- packages plus any package-specific configuration for this package.
---
lookupLocalPackageConfig
:: (Semigroup a, Monoid a)
- => (PackageConfig -> a) -> ProjectConfig -> PackageName
+ => (PackageConfig -> a)
+ -> ProjectConfig
+ -> PackageName
-> a
-lookupLocalPackageConfig field ProjectConfig {
- projectConfigLocalPackages,
- projectConfigSpecificPackage
- } pkgname =
+lookupLocalPackageConfig
+ field
+ ProjectConfig
+ { projectConfigLocalPackages
+ , projectConfigSpecificPackage
+ }
+ pkgname =
field projectConfigLocalPackages
- <> maybe mempty field
- (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))
-
+ <> maybe
+ mempty
+ field
+ (Map.lookup pkgname (getMapMappend projectConfigSpecificPackage))
-- | Use a 'RepoContext' based on the 'BuildTimeSettings'.
---
-projectConfigWithBuilderRepoContext :: Verbosity
- -> BuildTimeSettings
- -> (RepoContext -> IO a) -> IO a
+projectConfigWithBuilderRepoContext
+ :: Verbosity
+ -> BuildTimeSettings
+ -> (RepoContext -> IO a)
+ -> IO a
projectConfigWithBuilderRepoContext verbosity BuildTimeSettings{..} =
- withRepoContext'
- verbosity
- buildSettingRemoteRepos
- buildSettingLocalNoIndexRepos
- buildSettingCacheDir
- buildSettingHttpTransport
- (Just buildSettingIgnoreExpiry)
- buildSettingProgPathExtra
-
+ withRepoContext'
+ verbosity
+ buildSettingRemoteRepos
+ buildSettingLocalNoIndexRepos
+ buildSettingCacheDir
+ buildSettingHttpTransport
+ (Just buildSettingIgnoreExpiry)
+ buildSettingProgPathExtra
-- | Use a 'RepoContext', but only for the solver. The solver does not use the
-- full facilities of the 'RepoContext' so we can get away with making one
-- that doesn't have an http transport. And that avoids having to have access
-- to the 'BuildTimeSettings'
---
projectConfigWithSolverRepoContext
- :: Verbosity -> ProjectConfigShared -> ProjectConfigBuildOnly
+ :: Verbosity
+ -> ProjectConfigShared
+ -> ProjectConfigBuildOnly
-> (RepoContext -> IO a)
-> IO a
-projectConfigWithSolverRepoContext verbosity
- ProjectConfigShared{..}
- ProjectConfigBuildOnly{..} =
+projectConfigWithSolverRepoContext
+ verbosity
+ ProjectConfigShared{..}
+ ProjectConfigBuildOnly{..} =
withRepoContext'
verbosity
(fromNubList projectConfigRemoteRepos)
(fromNubList projectConfigLocalNoIndexRepos)
- (fromFlagOrDefault
- (error
- "projectConfigWithSolverRepoContext: projectConfigCacheDir")
- projectConfigCacheDir)
+ ( fromFlagOrDefault
+ ( error
+ "projectConfigWithSolverRepoContext: projectConfigCacheDir"
+ )
+ projectConfigCacheDir
+ )
(flagToMaybe projectConfigHttpTransport)
(flagToMaybe projectConfigIgnoreExpiry)
(fromNubList projectConfigProgPathExtra)
-
-- | Resolve the project configuration, with all its optional fields, into
-- 'SolverSettings' with no optional fields (by applying defaults).
---
resolveSolverSettings :: ProjectConfig -> SolverSettings
-resolveSolverSettings ProjectConfig{
- projectConfigShared,
- projectConfigLocalPackages,
- projectConfigSpecificPackage
- } =
- SolverSettings {..}
- where
- --TODO: [required eventually] some of these settings need validation, e.g.
- -- the flag assignments need checking.
- solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos
- solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos
- solverSettingConstraints = projectConfigConstraints
- solverSettingPreferences = projectConfigPreferences
- solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages
- solverSettingFlagAssignments = fmap packageConfigFlagAssignment
- (getMapMappend projectConfigSpecificPackage)
- solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion
- solverSettingSolver = fromFlag projectConfigSolver
- solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder
- solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer
- solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of
- n | n < 0 -> Nothing
- | otherwise -> Just n
- solverSettingReorderGoals = fromFlag projectConfigReorderGoals
- solverSettingCountConflicts = fromFlag projectConfigCountConflicts
- solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts
- solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet
- solverSettingStrongFlags = fromFlag projectConfigStrongFlags
- solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls
- solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained
- solverSettingIndexState = flagToMaybe projectConfigIndexState
- solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos
- solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals
- solverSettingPreferOldest = fromFlag projectConfigPreferOldest
- --solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs
- --solverSettingReinstall = fromFlag projectConfigReinstall
- --solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls
- --solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall
- --solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps
-
- ProjectConfigShared {..} = defaults <> projectConfigShared
-
- defaults = mempty {
- projectConfigSolver = Flag defaultSolver,
- projectConfigAllowOlder = Just (AllowOlder mempty),
- projectConfigAllowNewer = Just (AllowNewer mempty),
- projectConfigMaxBackjumps = Flag defaultMaxBackjumps,
- projectConfigReorderGoals = Flag (ReorderGoals False),
- projectConfigCountConflicts = Flag (CountConflicts True),
- projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True),
- projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False),
- projectConfigStrongFlags = Flag (StrongFlags False),
- projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False),
- projectConfigOnlyConstrained = Flag OnlyConstrainedNone,
- projectConfigIndependentGoals = Flag (IndependentGoals False),
- projectConfigPreferOldest = Flag (PreferOldest False)
- --projectConfigShadowPkgs = Flag False,
- --projectConfigReinstall = Flag False,
- --projectConfigAvoidReinstalls = Flag False,
- --projectConfigOverrideReinstall = Flag False,
- --projectConfigUpgradeDeps = Flag False
- }
-
+resolveSolverSettings
+ ProjectConfig
+ { projectConfigShared
+ , projectConfigLocalPackages
+ , projectConfigSpecificPackage
+ } =
+ SolverSettings{..}
+ where
+ -- TODO: [required eventually] some of these settings need validation, e.g.
+ -- the flag assignments need checking.
+ solverSettingRemoteRepos = fromNubList projectConfigRemoteRepos
+ solverSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos
+ solverSettingConstraints = projectConfigConstraints
+ solverSettingPreferences = projectConfigPreferences
+ solverSettingFlagAssignment = packageConfigFlagAssignment projectConfigLocalPackages
+ solverSettingFlagAssignments =
+ fmap
+ packageConfigFlagAssignment
+ (getMapMappend projectConfigSpecificPackage)
+ solverSettingCabalVersion = flagToMaybe projectConfigCabalVersion
+ solverSettingSolver = fromFlag projectConfigSolver
+ solverSettingAllowOlder = fromMaybe mempty projectConfigAllowOlder
+ solverSettingAllowNewer = fromMaybe mempty projectConfigAllowNewer
+ solverSettingMaxBackjumps = case fromFlag projectConfigMaxBackjumps of
+ n
+ | n < 0 -> Nothing
+ | otherwise -> Just n
+ solverSettingReorderGoals = fromFlag projectConfigReorderGoals
+ solverSettingCountConflicts = fromFlag projectConfigCountConflicts
+ solverSettingFineGrainedConflicts = fromFlag projectConfigFineGrainedConflicts
+ solverSettingMinimizeConflictSet = fromFlag projectConfigMinimizeConflictSet
+ solverSettingStrongFlags = fromFlag projectConfigStrongFlags
+ solverSettingAllowBootLibInstalls = fromFlag projectConfigAllowBootLibInstalls
+ solverSettingOnlyConstrained = fromFlag projectConfigOnlyConstrained
+ solverSettingIndexState = flagToMaybe projectConfigIndexState
+ solverSettingActiveRepos = flagToMaybe projectConfigActiveRepos
+ solverSettingIndependentGoals = fromFlag projectConfigIndependentGoals
+ solverSettingPreferOldest = fromFlag projectConfigPreferOldest
+ -- solverSettingShadowPkgs = fromFlag projectConfigShadowPkgs
+ -- solverSettingReinstall = fromFlag projectConfigReinstall
+ -- solverSettingAvoidReinstalls = fromFlag projectConfigAvoidReinstalls
+ -- solverSettingOverrideReinstall = fromFlag projectConfigOverrideReinstall
+ -- solverSettingUpgradeDeps = fromFlag projectConfigUpgradeDeps
+
+ ProjectConfigShared{..} = defaults <> projectConfigShared
+
+ defaults =
+ mempty
+ { projectConfigSolver = Flag defaultSolver
+ , projectConfigAllowOlder = Just (AllowOlder mempty)
+ , projectConfigAllowNewer = Just (AllowNewer mempty)
+ , projectConfigMaxBackjumps = Flag defaultMaxBackjumps
+ , projectConfigReorderGoals = Flag (ReorderGoals False)
+ , projectConfigCountConflicts = Flag (CountConflicts True)
+ , projectConfigFineGrainedConflicts = Flag (FineGrainedConflicts True)
+ , projectConfigMinimizeConflictSet = Flag (MinimizeConflictSet False)
+ , projectConfigStrongFlags = Flag (StrongFlags False)
+ , projectConfigAllowBootLibInstalls = Flag (AllowBootLibInstalls False)
+ , projectConfigOnlyConstrained = Flag OnlyConstrainedNone
+ , projectConfigIndependentGoals = Flag (IndependentGoals False)
+ , projectConfigPreferOldest = Flag (PreferOldest False)
+ -- projectConfigShadowPkgs = Flag False,
+ -- projectConfigReinstall = Flag False,
+ -- projectConfigAvoidReinstalls = Flag False,
+ -- projectConfigOverrideReinstall = Flag False,
+ -- projectConfigUpgradeDeps = Flag False
+ }
-- | Resolve the project configuration, with all its optional fields, into
-- 'BuildTimeSettings' with no optional fields (by applying defaults).
---
-resolveBuildTimeSettings :: Verbosity
- -> CabalDirLayout
- -> ProjectConfig
- -> BuildTimeSettings
-resolveBuildTimeSettings verbosity
- CabalDirLayout {
- cabalLogsDirectory
- }
- ProjectConfig {
- projectConfigShared = ProjectConfigShared {
- projectConfigRemoteRepos,
- projectConfigLocalNoIndexRepos,
- projectConfigProgPathExtra
- },
- projectConfigBuildOnly
- } =
- BuildTimeSettings {..}
- where
- buildSettingDryRun = fromFlag projectConfigDryRun
- buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps
- buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload
- buildSettingSummaryFile = fromNubList projectConfigSummaryFile
- --buildSettingLogFile -- defined below, more complicated
- --buildSettingLogVerbosity -- defined below, more complicated
- buildSettingBuildReports = fromFlag projectConfigBuildReports
- buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir
- buildSettingNumJobs = determineNumJobs projectConfigNumJobs
- buildSettingKeepGoing = fromFlag projectConfigKeepGoing
- buildSettingOfflineMode = fromFlag projectConfigOfflineMode
- buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles
- buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos
- buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos
- buildSettingCacheDir = fromFlag projectConfigCacheDir
- buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport
- buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry
- buildSettingReportPlanningFailure
- = fromFlag projectConfigReportPlanningFailure
- buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra
- buildSettingHaddockOpen = False
-
- ProjectConfigBuildOnly{..} = defaults
- <> projectConfigBuildOnly
-
- defaults = mempty {
- projectConfigDryRun = toFlag False,
- projectConfigOnlyDeps = toFlag False,
- projectConfigOnlyDownload = toFlag False,
- projectConfigBuildReports = toFlag NoReports,
- projectConfigReportPlanningFailure = toFlag False,
- projectConfigKeepGoing = toFlag False,
- projectConfigOfflineMode = toFlag False,
- projectConfigKeepTempFiles = toFlag False,
- projectConfigIgnoreExpiry = toFlag False
+resolveBuildTimeSettings
+ :: Verbosity
+ -> CabalDirLayout
+ -> ProjectConfig
+ -> BuildTimeSettings
+resolveBuildTimeSettings
+ verbosity
+ CabalDirLayout
+ { cabalLogsDirectory
}
+ ProjectConfig
+ { projectConfigShared =
+ ProjectConfigShared
+ { projectConfigRemoteRepos
+ , projectConfigLocalNoIndexRepos
+ , projectConfigProgPathExtra
+ }
+ , projectConfigBuildOnly
+ } =
+ BuildTimeSettings{..}
+ where
+ buildSettingDryRun = fromFlag projectConfigDryRun
+ buildSettingOnlyDeps = fromFlag projectConfigOnlyDeps
+ buildSettingOnlyDownload = fromFlag projectConfigOnlyDownload
+ buildSettingSummaryFile = fromNubList projectConfigSummaryFile
+ -- buildSettingLogFile -- defined below, more complicated
+ -- buildSettingLogVerbosity -- defined below, more complicated
+ buildSettingBuildReports = fromFlag projectConfigBuildReports
+ buildSettingSymlinkBinDir = flagToList projectConfigSymlinkBinDir
+ buildSettingNumJobs = determineNumJobs projectConfigNumJobs
+ buildSettingKeepGoing = fromFlag projectConfigKeepGoing
+ buildSettingOfflineMode = fromFlag projectConfigOfflineMode
+ buildSettingKeepTempFiles = fromFlag projectConfigKeepTempFiles
+ buildSettingRemoteRepos = fromNubList projectConfigRemoteRepos
+ buildSettingLocalNoIndexRepos = fromNubList projectConfigLocalNoIndexRepos
+ buildSettingCacheDir = fromFlag projectConfigCacheDir
+ buildSettingHttpTransport = flagToMaybe projectConfigHttpTransport
+ buildSettingIgnoreExpiry = fromFlag projectConfigIgnoreExpiry
+ buildSettingReportPlanningFailure =
+ fromFlag projectConfigReportPlanningFailure
+ buildSettingProgPathExtra = fromNubList projectConfigProgPathExtra
+ buildSettingHaddockOpen = False
+
+ ProjectConfigBuildOnly{..} =
+ defaults
+ <> projectConfigBuildOnly
+
+ defaults =
+ mempty
+ { projectConfigDryRun = toFlag False
+ , projectConfigOnlyDeps = toFlag False
+ , projectConfigOnlyDownload = toFlag False
+ , projectConfigBuildReports = toFlag NoReports
+ , projectConfigReportPlanningFailure = toFlag False
+ , projectConfigKeepGoing = toFlag False
+ , projectConfigOfflineMode = toFlag False
+ , projectConfigKeepTempFiles = toFlag False
+ , projectConfigIgnoreExpiry = toFlag False
+ }
- -- The logging logic: what log file to use and what verbosity.
- --
- -- If the user has specified --remote-build-reporting=detailed, use the
- -- default log file location. If the --build-log option is set, use the
- -- provided location. Otherwise don't use logging, unless building in
- -- parallel (in which case the default location is used).
- --
- buildSettingLogFile :: Maybe (Compiler -> Platform
- -> PackageId -> UnitId -> FilePath)
- buildSettingLogFile
- | useDefaultTemplate = Just (substLogFileName defaultTemplate)
- | otherwise = fmap substLogFileName givenTemplate
-
- defaultTemplate = toPathTemplate $
- cabalLogsDirectory </>
- "$compiler" </> "$libname" <.> "log"
- givenTemplate = flagToMaybe projectConfigLogFile
-
- useDefaultTemplate
- | buildSettingBuildReports == DetailedReports = True
- | isJust givenTemplate = False
- | isParallelBuild = True
- | otherwise = False
-
- isParallelBuild = buildSettingNumJobs >= 2
-
- substLogFileName :: PathTemplate
- -> Compiler -> Platform
- -> PackageId -> UnitId -> FilePath
- substLogFileName template compiler platform pkgid uid =
+ -- The logging logic: what log file to use and what verbosity.
+ --
+ -- If the user has specified --remote-build-reporting=detailed, use the
+ -- default log file location. If the --build-log option is set, use the
+ -- provided location. Otherwise don't use logging, unless building in
+ -- parallel (in which case the default location is used).
+ --
+ buildSettingLogFile
+ :: Maybe
+ ( Compiler
+ -> Platform
+ -> PackageId
+ -> UnitId
+ -> FilePath
+ )
+ buildSettingLogFile
+ | useDefaultTemplate = Just (substLogFileName defaultTemplate)
+ | otherwise = fmap substLogFileName givenTemplate
+
+ defaultTemplate =
+ toPathTemplate $
+ cabalLogsDirectory
+ </> "$compiler"
+ </> "$libname"
+ <.> "log"
+ givenTemplate = flagToMaybe projectConfigLogFile
+
+ useDefaultTemplate
+ | buildSettingBuildReports == DetailedReports = True
+ | isJust givenTemplate = False
+ | isParallelBuild = True
+ | otherwise = False
+
+ isParallelBuild = buildSettingNumJobs >= 2
+
+ substLogFileName
+ :: PathTemplate
+ -> Compiler
+ -> Platform
+ -> PackageId
+ -> UnitId
+ -> FilePath
+ substLogFileName template compiler platform pkgid uid =
fromPathTemplate (substPathTemplate env template)
- where
- env = initialPathTemplateEnv
- pkgid uid (compilerInfo compiler) platform
-
- -- If the user has specified --remote-build-reporting=detailed or
- -- --build-log, use more verbose logging.
- --
- buildSettingLogVerbosity :: Verbosity
- buildSettingLogVerbosity
- | overrideVerbosity = modifyVerbosity (max verbose) verbosity
- | otherwise = verbosity
-
- overrideVerbosity :: Bool
- overrideVerbosity
- | buildSettingBuildReports == DetailedReports = True
- | isJust givenTemplate = True
- | isParallelBuild = False
- | otherwise = False
-
+ where
+ env =
+ initialPathTemplateEnv
+ pkgid
+ uid
+ (compilerInfo compiler)
+ platform
+
+ -- If the user has specified --remote-build-reporting=detailed or
+ -- --build-log, use more verbose logging.
+ --
+ buildSettingLogVerbosity :: Verbosity
+ buildSettingLogVerbosity
+ | overrideVerbosity = modifyVerbosity (max verbose) verbosity
+ | otherwise = verbosity
+
+ overrideVerbosity :: Bool
+ overrideVerbosity
+ | buildSettingBuildReports == DetailedReports = True
+ | isJust givenTemplate = True
+ | isParallelBuild = False
+ | otherwise = False
---------------------------------------------
-- Reading and writing project config files
@@ -405,42 +504,43 @@ resolveBuildTimeSettings verbosity
-- 2. The first directory containing @mprojectFile@/@cabal.project@, starting from the current directory
-- and recursively checking parent directories
-- 3. The current directory
---
findProjectRoot
:: Verbosity
- -> Maybe FilePath -- ^ Explicit project directory
- -> Maybe FilePath -- ^ Explicit project file
+ -> Maybe FilePath
+ -- ^ Explicit project directory
+ -> Maybe FilePath
+ -- ^ Explicit project file
-> IO (Either BadProjectRoot ProjectRoot)
findProjectRoot verbosity mprojectDir mprojectFile = do
case mprojectDir of
Nothing
- | Just file <- mprojectFile, isAbsolute file -> do
+ | Just file <- mprojectFile
+ , isAbsolute file -> do
warn verbosity $
"Specifying an absolute path to the project file is deprecated."
- <> " Use --project-dir to set the project's directory."
+ <> " Use --project-dir to set the project's directory."
doesFileExist file >>= \case
False -> left (BadProjectRootExplicitFile file)
- True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file
-
+ True -> uncurry projectRoot =<< first dropTrailingPathSeparator . splitFileName <$> canonicalizePath file
| otherwise -> probeProjectRoot mprojectFile
+ Just dir ->
+ doesDirectoryExist dir >>= \case
+ False -> left (BadProjectRootDir dir)
+ True -> do
+ projectDir <- canonicalizePath dir
- Just dir -> doesDirectoryExist dir >>= \case
- False -> left (BadProjectRootDir dir)
- True -> do
- projectDir <- canonicalizePath dir
-
- case mprojectFile of
- Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile)
-
- Just projectFile
- | isAbsolute projectFile -> doesFileExist projectFile >>= \case
- False -> left (BadProjectRootAbsoluteFile projectFile)
- True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile
-
- | otherwise -> doesFileExist (projectDir </> projectFile) >>= \case
- False -> left (BadProjectRootDirFile dir projectFile)
- True -> projectRoot projectDir projectFile
+ case mprojectFile of
+ Nothing -> pure $ Right (ProjectRootExplicit projectDir defaultProjectFile)
+ Just projectFile
+ | isAbsolute projectFile ->
+ doesFileExist projectFile >>= \case
+ False -> left (BadProjectRootAbsoluteFile projectFile)
+ True -> Right . ProjectRootExplicitAbsolute dir <$> canonicalizePath projectFile
+ | otherwise ->
+ doesFileExist (projectDir </> projectFile) >>= \case
+ False -> left (BadProjectRootDirFile dir projectFile)
+ True -> projectRoot projectDir projectFile
where
left = pure . Left
@@ -449,9 +549,9 @@ findProjectRoot verbosity mprojectDir mprojectFile = do
probeProjectRoot :: Maybe FilePath -> IO (Either BadProjectRoot ProjectRoot)
probeProjectRoot mprojectFile = do
- startdir <- getCurrentDirectory
- homedir <- getHomeDirectory
- probe startdir homedir
+ startdir <- getCurrentDirectory
+ homedir <- getHomeDirectory
+ probe startdir homedir
where
projectFileName :: String
projectFileName = fromMaybe defaultProjectFile mprojectFile
@@ -464,7 +564,7 @@ probeProjectRoot mprojectFile = do
go :: FilePath -> IO (Either BadProjectRoot ProjectRoot)
go dir | isDrive dir || dir == homedir =
case mprojectFile of
- Nothing -> return (Right (ProjectRootImplicit startdir))
+ Nothing -> return (Right (ProjectRootImplicit startdir))
Just file -> return (Left (BadProjectRootExplicitFile file))
go dir = do
exists <- doesFileExist (dir </> projectFileName)
@@ -473,7 +573,6 @@ probeProjectRoot mprojectFile = do
else go (takeDirectory dir)
-- | Errors returned by 'findProjectRoot'.
---
data BadProjectRoot
= BadProjectRootExplicitFile FilePath
| BadProjectRootDir FilePath
@@ -488,87 +587,94 @@ instance Show BadProjectRoot where
show = renderBadProjectRoot
#endif
+{- FOURMOLU_DISABLE -}
instance Exception BadProjectRoot where
#if MIN_VERSION_base(4,8,0)
displayException = renderBadProjectRoot
#endif
+{- FOURMOLU_ENABLE -}
renderBadProjectRoot :: BadProjectRoot -> String
renderBadProjectRoot = \case
BadProjectRootExplicitFile projectFile ->
"The given project file '" ++ projectFile ++ "' does not exist."
-
BadProjectRootDir dir ->
"The given project directory '" <> dir <> "' does not exist."
-
BadProjectRootAbsoluteFile file ->
"The given project file '" <> file <> "' does not exist."
-
BadProjectRootDirFile dir file ->
"The given project directory/file combination '" <> dir </> file <> "' does not exist."
withProjectOrGlobalConfig
- :: Verbosity -- ^ verbosity
- -> Flag Bool -- ^ whether to ignore local project (--ignore-project flag)
- -> Flag FilePath -- ^ @--cabal-config@
- -> IO a -- ^ with project
- -> (ProjectConfig -> IO a) -- ^ without project
- -> IO a
+ :: Verbosity
+ -- ^ verbosity
+ -> Flag Bool
+ -- ^ whether to ignore local project (--ignore-project flag)
+ -> Flag FilePath
+ -- ^ @--cabal-config@
+ -> IO a
+ -- ^ with project
+ -> (ProjectConfig -> IO a)
+ -- ^ without project
+ -> IO a
withProjectOrGlobalConfig verbosity (Flag True) gcf _with without = do
- globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf
- without globalConfig
-withProjectOrGlobalConfig verbosity _ignorePrj gcf with without =
- withProjectOrGlobalConfig' verbosity gcf with without
+ globalConfig <- runRebuild "" $ readGlobalConfig verbosity gcf
+ without globalConfig
+withProjectOrGlobalConfig verbosity _ignorePrj gcf with without =
+ withProjectOrGlobalConfig' verbosity gcf with without
withProjectOrGlobalConfig'
- :: Verbosity
- -> Flag FilePath
- -> IO a
- -> (ProjectConfig -> IO a)
- -> IO a
+ :: Verbosity
+ -> Flag FilePath
+ -> IO a
+ -> (ProjectConfig -> IO a)
+ -> IO a
withProjectOrGlobalConfig' verbosity globalConfigFlag with without = do
globalConfig <- runRebuild "" $ readGlobalConfig verbosity globalConfigFlag
- catch with
- $ \case
- (BadPackageLocations prov locs)
- | prov == Set.singleton Implicit
- , let
+ catch with $
+ \case
+ (BadPackageLocations prov locs)
+ | prov == Set.singleton Implicit
+ , let
isGlobErr (BadLocGlobEmptyMatch _) = True
isGlobErr _ = False
- , any isGlobErr locs ->
+ , any isGlobErr locs ->
without globalConfig
- err -> throwIO err
+ err -> throwIO err
-- | Read all the config relevant for a project. This includes the project
-- file if any, plus other global config.
---
-readProjectConfig :: Verbosity
- -> HttpTransport
- -> Flag Bool -- ^ @--ignore-project@
- -> Flag FilePath
- -> DistDirLayout
- -> Rebuild ProjectConfigSkeleton
+readProjectConfig
+ :: Verbosity
+ -> HttpTransport
+ -> Flag Bool
+ -- ^ @--ignore-project@
+ -> Flag FilePath
+ -> DistDirLayout
+ -> Rebuild ProjectConfigSkeleton
readProjectConfig verbosity httpTransport ignoreProjectFlag configFileFlag distDirLayout = do
- global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag
- local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout
- freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
- extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout
- if ignoreProjectFlag == Flag True then return (global <> (singletonProjectConfigSkeleton defaultProject))
+ global <- singletonProjectConfigSkeleton <$> readGlobalConfig verbosity configFileFlag
+ local <- readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout
+ freeze <- readProjectLocalFreezeConfig verbosity httpTransport distDirLayout
+ extra <- readProjectLocalExtraConfig verbosity httpTransport distDirLayout
+ if ignoreProjectFlag == Flag True
+ then return (global <> (singletonProjectConfigSkeleton defaultProject))
else return (global <> local <> freeze <> extra)
- where
- defaultProject :: ProjectConfig
- defaultProject = mempty {
- projectPackages = ["./"]
- }
+ where
+ defaultProject :: ProjectConfig
+ defaultProject =
+ mempty
+ { projectPackages = ["./"]
+ }
-- | Reads an explicit @cabal.project@ file in the given project root dir,
-- or returns the default project config for an implicitly defined project.
---
-readProjectLocalConfigOrDefault :: Verbosity
- -> HttpTransport
- -> DistDirLayout
- -> Rebuild ProjectConfigSkeleton
+readProjectLocalConfigOrDefault
+ :: Verbosity
+ -> HttpTransport
+ -> DistDirLayout
+ -> Rebuild ProjectConfigSkeleton
readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do
usesExplicitProjectRoot <- liftIO $ doesFileExist projectFile
if usesExplicitProjectRoot
@@ -577,110 +683,122 @@ readProjectLocalConfigOrDefault verbosity httpTransport distDirLayout = do
else do
monitorFiles [monitorNonExistentFile projectFile]
return (singletonProjectConfigSkeleton defaultImplicitProjectConfig)
-
where
projectFile :: FilePath
projectFile = distProjectFile distDirLayout ""
defaultImplicitProjectConfig :: ProjectConfig
- defaultImplicitProjectConfig = mempty {
- -- We expect a package in the current directory.
- projectPackages = [ "./*.cabal" ],
-
- projectConfigProvenance = Set.singleton Implicit
- }
+ defaultImplicitProjectConfig =
+ mempty
+ { -- We expect a package in the current directory.
+ projectPackages = ["./*.cabal"]
+ , projectConfigProvenance = Set.singleton Implicit
+ }
-- | Reads a @cabal.project.local@ file in the given project root dir,
-- or returns empty. This file gets written by @cabal configure@, or in
-- principle can be edited manually or by other tools.
---
-readProjectLocalExtraConfig :: Verbosity -> HttpTransport -> DistDirLayout
- -> Rebuild ProjectConfigSkeleton
+readProjectLocalExtraConfig
+ :: Verbosity
+ -> HttpTransport
+ -> DistDirLayout
+ -> Rebuild ProjectConfigSkeleton
readProjectLocalExtraConfig verbosity httpTransport distDirLayout =
- readProjectFileSkeleton verbosity httpTransport distDirLayout "local"
- "project local configuration file"
+ readProjectFileSkeleton
+ verbosity
+ httpTransport
+ distDirLayout
+ "local"
+ "project local configuration file"
-- | Reads a @cabal.project.freeze@ file in the given project root dir,
-- or returns empty. This file gets written by @cabal freeze@, or in
-- principle can be edited manually or by other tools.
---
-readProjectLocalFreezeConfig :: Verbosity -> HttpTransport ->DistDirLayout
- -> Rebuild ProjectConfigSkeleton
+readProjectLocalFreezeConfig
+ :: Verbosity
+ -> HttpTransport
+ -> DistDirLayout
+ -> Rebuild ProjectConfigSkeleton
readProjectLocalFreezeConfig verbosity httpTransport distDirLayout =
- readProjectFileSkeleton verbosity httpTransport distDirLayout "freeze"
- "project freeze file"
+ readProjectFileSkeleton
+ verbosity
+ httpTransport
+ distDirLayout
+ "freeze"
+ "project freeze file"
-- | Reads a named extended (with imports and conditionals) config file in the given project root dir, or returns empty.
---
readProjectFileSkeleton :: Verbosity -> HttpTransport -> DistDirLayout -> String -> String -> Rebuild ProjectConfigSkeleton
-readProjectFileSkeleton verbosity httpTransport DistDirLayout{distProjectFile, distDownloadSrcDirectory}
- extensionName extensionDescription = do
+readProjectFileSkeleton
+ verbosity
+ httpTransport
+ DistDirLayout{distProjectFile, distDownloadSrcDirectory}
+ extensionName
+ extensionDescription = do
exists <- liftIO $ doesFileExist extensionFile
if exists
- then do monitorFiles [monitorFileHashed extensionFile]
- pcs <- liftIO readExtensionFile
- monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs)
- pure pcs
- else do monitorFiles [monitorNonExistentFile extensionFile]
- return mempty
- where
- extensionFile = distProjectFile extensionName
+ then do
+ monitorFiles [monitorFileHashed extensionFile]
+ pcs <- liftIO readExtensionFile
+ monitorFiles $ map monitorFileHashed (projectSkeletonImports pcs)
+ pure pcs
+ else do
+ monitorFiles [monitorNonExistentFile extensionFile]
+ return mempty
+ where
+ extensionFile = distProjectFile extensionName
- readExtensionFile =
- reportParseResult verbosity extensionDescription extensionFile
- =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile
- =<< BS.readFile extensionFile
+ readExtensionFile =
+ reportParseResult verbosity extensionDescription extensionFile
+ =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] extensionFile
+ =<< BS.readFile extensionFile
-- | Render the 'ProjectConfig' format.
--
-- For the moment this is implemented in terms of a pretty printer for the
-- legacy configuration types, plus a conversion.
---
showProjectConfig :: ProjectConfig -> String
showProjectConfig =
- showLegacyProjectConfig . convertToLegacyProjectConfig
-
+ showLegacyProjectConfig . convertToLegacyProjectConfig
-- | Write a @cabal.project.local@ file in the given project root dir.
---
writeProjectLocalExtraConfig :: DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalExtraConfig DistDirLayout{distProjectFile} =
- writeProjectConfigFile (distProjectFile "local")
-
+ writeProjectConfigFile (distProjectFile "local")
-- | Write a @cabal.project.freeze@ file in the given project root dir.
---
writeProjectLocalFreezeConfig :: DistDirLayout -> ProjectConfig -> IO ()
writeProjectLocalFreezeConfig DistDirLayout{distProjectFile} =
- writeProjectConfigFile (distProjectFile "freeze")
-
+ writeProjectConfigFile (distProjectFile "freeze")
-- | Write in the @cabal.project@ format to the given file.
---
writeProjectConfigFile :: FilePath -> ProjectConfig -> IO ()
writeProjectConfigFile file =
- writeFile file . showProjectConfig
-
+ writeFile file . showProjectConfig
-- | Read the user's cabal-install config file.
---
readGlobalConfig :: Verbosity -> Flag FilePath -> Rebuild ProjectConfig
readGlobalConfig verbosity configFileFlag = do
- config <- liftIO (loadConfig verbosity configFileFlag)
- configFile <- liftIO (getConfigFilePath configFileFlag)
- monitorFiles [monitorFileHashed configFile]
- return (convertLegacyGlobalConfig config)
+ config <- liftIO (loadConfig verbosity configFileFlag)
+ configFile <- liftIO (getConfigFilePath configFileFlag)
+ monitorFiles [monitorFileHashed configFile]
+ return (convertLegacyGlobalConfig config)
reportParseResult :: Verbosity -> String -> FilePath -> OldParser.ParseResult ProjectConfigSkeleton -> IO ProjectConfigSkeleton
reportParseResult verbosity _filetype filename (OldParser.ParseOk warnings x) = do
- unless (null warnings) $
- let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings)
- in warn verbosity msg
- return x
+ unless (null warnings) $
+ let msg = unlines (map (OldParser.showPWarning (intercalate ", " $ filename : projectSkeletonImports x)) warnings)
+ in warn verbosity msg
+ return x
reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =
- let (line, msg) = OldParser.locatedErrorMsg err
- in die' verbosity $ "Error parsing " ++ filetype ++ " " ++ filename
- ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg
-
+ let (line, msg) = OldParser.locatedErrorMsg err
+ in die' verbosity $
+ "Error parsing "
+ ++ filetype
+ ++ " "
+ ++ filename
+ ++ maybe "" (\n -> ':' : show n) line
+ ++ ":\n"
+ ++ msg
---------------------------------------------
-- Finding packages in the project
@@ -689,21 +807,18 @@ reportParseResult verbosity filetype filename (OldParser.ParseFailed err) =
-- | The location of a package as part of a project. Local file paths are
-- either absolute (if the user specified it as such) or they are relative
-- to the project root.
---
-data ProjectPackageLocation =
- ProjectPackageLocalCabalFile FilePath
- | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
- | ProjectPackageLocalTarball FilePath
- | ProjectPackageRemoteTarball URI
- | ProjectPackageRemoteRepo SourceRepoList
- | ProjectPackageNamed PackageVersionConstraint
- deriving Show
-
+data ProjectPackageLocation
+ = ProjectPackageLocalCabalFile FilePath
+ | ProjectPackageLocalDirectory FilePath FilePath -- dir and .cabal file
+ | ProjectPackageLocalTarball FilePath
+ | ProjectPackageRemoteTarball URI
+ | ProjectPackageRemoteRepo SourceRepoList
+ | ProjectPackageNamed PackageVersionConstraint
+ deriving (Show)
-- | Exception thrown by 'findProjectPackages'.
---
data BadPackageLocations
- = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]
+ = BadPackageLocations (Set ProjectConfigProvenance) [BadPackageLocation]
#if MIN_VERSION_base(4,8,0)
deriving (Show, Typeable)
#else
@@ -713,63 +828,62 @@ instance Show BadPackageLocations where
show = renderBadPackageLocations
#endif
+{- FOURMOLU_DISABLE -}
instance Exception BadPackageLocations where
#if MIN_VERSION_base(4,8,0)
displayException = renderBadPackageLocations
#endif
---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc
+{- FOURMOLU_ENABLE -}
+-- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc
data BadPackageLocation
- = BadPackageLocationFile BadPackageLocationMatch
- | BadLocGlobEmptyMatch String
- | BadLocGlobBadMatches String [BadPackageLocationMatch]
- | BadLocUnexpectedUriScheme String
- | BadLocUnrecognisedUri String
- | BadLocUnrecognised String
- deriving Show
+ = BadPackageLocationFile BadPackageLocationMatch
+ | BadLocGlobEmptyMatch String
+ | BadLocGlobBadMatches String [BadPackageLocationMatch]
+ | BadLocUnexpectedUriScheme String
+ | BadLocUnrecognisedUri String
+ | BadLocUnrecognised String
+ deriving (Show)
data BadPackageLocationMatch
- = BadLocUnexpectedFile String
- | BadLocNonexistantFile String
- | BadLocDirNoCabalFile String
- | BadLocDirManyCabalFiles String
- deriving Show
+ = BadLocUnexpectedFile String
+ | BadLocNonexistantFile String
+ | BadLocDirNoCabalFile String
+ | BadLocDirManyCabalFiles String
+ deriving (Show)
renderBadPackageLocations :: BadPackageLocations -> String
renderBadPackageLocations (BadPackageLocations provenance bpls)
- -- There is no provenance information,
- -- render standard bad package error information.
- | Set.null provenance = renderErrors renderBadPackageLocation
-
- -- The configuration is implicit, render bad package locations
- -- using possibly specialized error messages.
- | Set.singleton Implicit == provenance =
- renderErrors renderImplicitBadPackageLocation
-
- -- The configuration contains both implicit and explicit provenance.
- -- This should not occur, and a message is output to assist debugging.
- | Implicit `Set.member` provenance =
- "Warning: both implicit and explicit configuration is present."
+ -- There is no provenance information,
+ -- render standard bad package error information.
+ | Set.null provenance = renderErrors renderBadPackageLocation
+ -- The configuration is implicit, render bad package locations
+ -- using possibly specialized error messages.
+ | Set.singleton Implicit == provenance =
+ renderErrors renderImplicitBadPackageLocation
+ -- The configuration contains both implicit and explicit provenance.
+ -- This should not occur, and a message is output to assist debugging.
+ | Implicit `Set.member` provenance =
+ "Warning: both implicit and explicit configuration is present."
++ renderExplicit
-
- -- The configuration was read from one or more explicit path(s),
- -- list the locations and render the bad package error information.
- -- The intent is to supersede this with the relevant location information
- -- per package error.
- | otherwise = renderExplicit
+ -- The configuration was read from one or more explicit path(s),
+ -- list the locations and render the bad package error information.
+ -- The intent is to supersede this with the relevant location information
+ -- per package error.
+ | otherwise = renderExplicit
where
renderErrors f = unlines (map f bpls)
renderExplicit =
- "When using configuration(s) from "
+ "When using configuration(s) from "
++ intercalate ", " (mapMaybe getExplicit (Set.toList provenance))
++ ", the following errors occurred:\n"
++ renderErrors renderBadPackageLocation
getExplicit (Explicit path) = Just path
- getExplicit Implicit = Nothing
+ getExplicit Implicit = Nothing
---TODO: [nice to have] keep track of the config file (and src loc) packages
+-- TODO: [nice to have] keep track of the config file (and src loc) packages
-- were listed, to use in error messages
-- | Render bad package location error information for the implicit
@@ -781,225 +895,260 @@ renderBadPackageLocations (BadPackageLocations provenance bpls)
-- is present.
renderImplicitBadPackageLocation :: BadPackageLocation -> String
renderImplicitBadPackageLocation bpl = case bpl of
- BadLocGlobEmptyMatch pkglocstr ->
- "No cabal.project file or cabal file matching the default glob '"
- ++ pkglocstr ++ "' was found.\n"
- ++ "Please create a package description file <pkgname>.cabal "
- ++ "or a cabal.project file referencing the packages you "
- ++ "want to build."
- _ -> renderBadPackageLocation bpl
+ BadLocGlobEmptyMatch pkglocstr ->
+ "No cabal.project file or cabal file matching the default glob '"
+ ++ pkglocstr
+ ++ "' was found.\n"
+ ++ "Please create a package description file <pkgname>.cabal "
+ ++ "or a cabal.project file referencing the packages you "
+ ++ "want to build."
+ _ -> renderBadPackageLocation bpl
renderBadPackageLocation :: BadPackageLocation -> String
renderBadPackageLocation bpl = case bpl of
- BadPackageLocationFile badmatch ->
- renderBadPackageLocationMatch badmatch
- BadLocGlobEmptyMatch pkglocstr ->
- "The package location glob '" ++ pkglocstr
- ++ "' does not match any files or directories."
- BadLocGlobBadMatches pkglocstr failures ->
- "The package location glob '" ++ pkglocstr ++ "' does not match any "
- ++ "recognised forms of package. "
- ++ concatMap ((' ':) . renderBadPackageLocationMatch) failures
- BadLocUnexpectedUriScheme pkglocstr ->
- "The package location URI '" ++ pkglocstr ++ "' does not use a "
- ++ "supported URI scheme. The supported URI schemes are http, https and "
- ++ "file."
- BadLocUnrecognisedUri pkglocstr ->
- "The package location URI '" ++ pkglocstr ++ "' does not appear to "
- ++ "be a valid absolute URI."
- BadLocUnrecognised pkglocstr ->
- "The package location syntax '" ++ pkglocstr ++ "' is not recognised."
+ BadPackageLocationFile badmatch ->
+ renderBadPackageLocationMatch badmatch
+ BadLocGlobEmptyMatch pkglocstr ->
+ "The package location glob '"
+ ++ pkglocstr
+ ++ "' does not match any files or directories."
+ BadLocGlobBadMatches pkglocstr failures ->
+ "The package location glob '"
+ ++ pkglocstr
+ ++ "' does not match any "
+ ++ "recognised forms of package. "
+ ++ concatMap ((' ' :) . renderBadPackageLocationMatch) failures
+ BadLocUnexpectedUriScheme pkglocstr ->
+ "The package location URI '"
+ ++ pkglocstr
+ ++ "' does not use a "
+ ++ "supported URI scheme. The supported URI schemes are http, https and "
+ ++ "file."
+ BadLocUnrecognisedUri pkglocstr ->
+ "The package location URI '"
+ ++ pkglocstr
+ ++ "' does not appear to "
+ ++ "be a valid absolute URI."
+ BadLocUnrecognised pkglocstr ->
+ "The package location syntax '" ++ pkglocstr ++ "' is not recognised."
renderBadPackageLocationMatch :: BadPackageLocationMatch -> String
renderBadPackageLocationMatch bplm = case bplm of
- BadLocUnexpectedFile pkglocstr ->
- "The package location '" ++ pkglocstr ++ "' is not recognised. The "
- ++ "supported file targets are .cabal files, .tar.gz tarballs or package "
- ++ "directories (i.e. directories containing a .cabal file)."
- BadLocNonexistantFile pkglocstr ->
- "The package location '" ++ pkglocstr ++ "' does not exist."
- BadLocDirNoCabalFile pkglocstr ->
- "The package directory '" ++ pkglocstr ++ "' does not contain any "
- ++ ".cabal file."
- BadLocDirManyCabalFiles pkglocstr ->
- "The package directory '" ++ pkglocstr ++ "' contains multiple "
- ++ ".cabal files (which is not currently supported)."
+ BadLocUnexpectedFile pkglocstr ->
+ "The package location '"
+ ++ pkglocstr
+ ++ "' is not recognised. The "
+ ++ "supported file targets are .cabal files, .tar.gz tarballs or package "
+ ++ "directories (i.e. directories containing a .cabal file)."
+ BadLocNonexistantFile pkglocstr ->
+ "The package location '" ++ pkglocstr ++ "' does not exist."
+ BadLocDirNoCabalFile pkglocstr ->
+ "The package directory '"
+ ++ pkglocstr
+ ++ "' does not contain any "
+ ++ ".cabal file."
+ BadLocDirManyCabalFiles pkglocstr ->
+ "The package directory '"
+ ++ pkglocstr
+ ++ "' contains multiple "
+ ++ ".cabal files (which is not currently supported)."
-- | Given the project config,
--
-- Throws 'BadPackageLocations'.
---
-findProjectPackages :: DistDirLayout -> ProjectConfig
- -> Rebuild [ProjectPackageLocation]
-findProjectPackages DistDirLayout{distProjectRootDirectory}
- ProjectConfig{..} = do
-
- requiredPkgs <- findPackageLocations True projectPackages
- optionalPkgs <- findPackageLocations False projectPackagesOptional
- let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo
- namedPkgs = map ProjectPackageNamed projectPackagesNamed
+findProjectPackages
+ :: DistDirLayout
+ -> ProjectConfig
+ -> Rebuild [ProjectPackageLocation]
+findProjectPackages
+ DistDirLayout{distProjectRootDirectory}
+ ProjectConfig{..} = do
+ requiredPkgs <- findPackageLocations True projectPackages
+ optionalPkgs <- findPackageLocations False projectPackagesOptional
+ let repoPkgs = map ProjectPackageRemoteRepo projectPackagesRepo
+ namedPkgs = map ProjectPackageNamed projectPackagesNamed
return (concat [requiredPkgs, optionalPkgs, repoPkgs, namedPkgs])
- where
- findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]
- findPackageLocations required pkglocstr = do
- (problems, pkglocs) <-
- partitionEithers <$> traverse (findPackageLocation required) pkglocstr
- unless (null problems) $
- liftIO $ throwIO $ BadPackageLocations projectConfigProvenance problems
- return (concat pkglocs)
-
-
- findPackageLocation :: Bool -> String
- -> Rebuild (Either BadPackageLocation
- [ProjectPackageLocation])
- findPackageLocation _required@True pkglocstr =
- -- strategy: try first as a file:// or http(s):// URL.
- -- then as a file glob (usually encompassing single file)
- -- finally as a single file, for files that fail to parse as globs
- checkIsUriPackage pkglocstr
- `mplusMaybeT` checkIsFileGlobPackage pkglocstr
- `mplusMaybeT` checkIsSingleFilePackage pkglocstr
- >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return
-
-
- findPackageLocation _required@False pkglocstr = do
- -- just globs for optional case
- res <- checkIsFileGlobPackage pkglocstr
- case res of
- Nothing -> return (Left (BadLocUnrecognised pkglocstr))
- Just (Left _) -> return (Right []) -- it's optional
- Just (Right pkglocs) -> return (Right pkglocs)
-
-
- checkIsUriPackage, checkIsFileGlobPackage, checkIsSingleFilePackage
- :: String -> Rebuild (Maybe (Either BadPackageLocation
- [ProjectPackageLocation]))
- checkIsUriPackage pkglocstr =
- case parseAbsoluteURI pkglocstr of
- Just uri@URI {
- uriScheme = scheme,
- uriAuthority = Just URIAuth { uriRegName = host },
- uriPath = path,
- uriQuery = query,
- uriFragment = frag
- }
- | recognisedScheme && not (null host) ->
- return (Just (Right [ProjectPackageRemoteTarball uri]))
-
- | scheme == "file:" && null host && null query && null frag ->
- checkIsSingleFilePackage path
-
- | not recognisedScheme && not (null host) ->
- return (Just (Left (BadLocUnexpectedUriScheme pkglocstr)))
-
- | recognisedScheme && null host ->
- return (Just (Left (BadLocUnrecognisedUri pkglocstr)))
- where
- recognisedScheme = scheme == "http:" || scheme == "https:"
- || scheme == "file:"
-
- _ -> return Nothing
-
-
- checkIsFileGlobPackage pkglocstr =
- case simpleParsec pkglocstr of
- Nothing -> return Nothing
- Just glob -> liftM Just $ do
- matches <- matchFileGlob glob
- case matches of
- [] | isJust (isTrivialFilePathGlob glob)
- -> return (Left (BadPackageLocationFile
- (BadLocNonexistantFile pkglocstr)))
-
- [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))
-
- _ -> do
- (failures, pkglocs) <- partitionEithers <$>
- traverse checkFilePackageMatch matches
- return $! case (failures, pkglocs) of
- ([failure], []) | isJust (isTrivialFilePathGlob glob)
- -> Left (BadPackageLocationFile failure)
- (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
- _ -> Right pkglocs
-
-
- checkIsSingleFilePackage pkglocstr = do
- let filename = distProjectRootDirectory </> pkglocstr
- isFile <- liftIO $ doesFileExist filename
- isDir <- liftIO $ doesDirectoryExist filename
- if isFile || isDir
- then checkFilePackageMatch pkglocstr
- >>= either (return . Just . Left . BadPackageLocationFile)
- (return . Just . Right . (\x->[x]))
- else return Nothing
-
-
- checkFilePackageMatch :: String -> Rebuild (Either BadPackageLocationMatch
- ProjectPackageLocation)
- checkFilePackageMatch pkglocstr = do
- -- The pkglocstr may be absolute or may be relative to the project root.
- -- Either way, </> does the right thing here. We return relative paths if
- -- they were relative in the first place.
- let abspath = distProjectRootDirectory </> pkglocstr
- isFile <- liftIO $ doesFileExist abspath
- isDir <- liftIO $ doesDirectoryExist abspath
- parentDirExists <- case takeDirectory abspath of
- [] -> return False
- dir -> liftIO $ doesDirectoryExist dir
- case () of
- _ | isDir
- -> do matches <- matchFileGlob (globStarDotCabal pkglocstr)
- case matches of
- [cabalFile]
- -> return (Right (ProjectPackageLocalDirectory
- pkglocstr cabalFile))
- [] -> return (Left (BadLocDirNoCabalFile pkglocstr))
- _ -> return (Left (BadLocDirManyCabalFiles pkglocstr))
-
- | extensionIsTarGz pkglocstr
- -> return (Right (ProjectPackageLocalTarball pkglocstr))
-
- | takeExtension pkglocstr == ".cabal"
- -> return (Right (ProjectPackageLocalCabalFile pkglocstr))
-
- | isFile
- -> return (Left (BadLocUnexpectedFile pkglocstr))
-
- | parentDirExists
- -> return (Left (BadLocNonexistantFile pkglocstr))
-
- | otherwise
- -> return (Left (BadLocUnexpectedFile pkglocstr))
-
-
- extensionIsTarGz f = takeExtension f == ".gz"
- && takeExtension (dropExtension f) == ".tar"
-
+ where
+ findPackageLocations :: Bool -> [String] -> Rebuild [ProjectPackageLocation]
+ findPackageLocations required pkglocstr = do
+ (problems, pkglocs) <-
+ partitionEithers <$> traverse (findPackageLocation required) pkglocstr
+ unless (null problems) $
+ liftIO $
+ throwIO $
+ BadPackageLocations projectConfigProvenance problems
+ return (concat pkglocs)
+
+ findPackageLocation
+ :: Bool
+ -> String
+ -> Rebuild
+ ( Either
+ BadPackageLocation
+ [ProjectPackageLocation]
+ )
+ findPackageLocation _required@True pkglocstr =
+ -- strategy: try first as a file:// or http(s):// URL.
+ -- then as a file glob (usually encompassing single file)
+ -- finally as a single file, for files that fail to parse as globs
+ checkIsUriPackage pkglocstr
+ `mplusMaybeT` checkIsFileGlobPackage pkglocstr
+ `mplusMaybeT` checkIsSingleFilePackage pkglocstr
+ >>= maybe (return (Left (BadLocUnrecognised pkglocstr))) return
+ findPackageLocation _required@False pkglocstr = do
+ -- just globs for optional case
+ res <- checkIsFileGlobPackage pkglocstr
+ case res of
+ Nothing -> return (Left (BadLocUnrecognised pkglocstr))
+ Just (Left _) -> return (Right []) -- it's optional
+ Just (Right pkglocs) -> return (Right pkglocs)
+
+ checkIsUriPackage
+ , checkIsFileGlobPackage
+ , checkIsSingleFilePackage
+ :: String
+ -> Rebuild
+ ( Maybe
+ ( Either
+ BadPackageLocation
+ [ProjectPackageLocation]
+ )
+ )
+ checkIsUriPackage pkglocstr =
+ case parseAbsoluteURI pkglocstr of
+ Just
+ uri@URI
+ { uriScheme = scheme
+ , uriAuthority = Just URIAuth{uriRegName = host}
+ , uriPath = path
+ , uriQuery = query
+ , uriFragment = frag
+ }
+ | recognisedScheme && not (null host) ->
+ return (Just (Right [ProjectPackageRemoteTarball uri]))
+ | scheme == "file:" && null host && null query && null frag ->
+ checkIsSingleFilePackage path
+ | not recognisedScheme && not (null host) ->
+ return (Just (Left (BadLocUnexpectedUriScheme pkglocstr)))
+ | recognisedScheme && null host ->
+ return (Just (Left (BadLocUnrecognisedUri pkglocstr)))
+ where
+ recognisedScheme =
+ scheme == "http:"
+ || scheme == "https:"
+ || scheme == "file:"
+ _ -> return Nothing
+
+ checkIsFileGlobPackage pkglocstr =
+ case simpleParsec pkglocstr of
+ Nothing -> return Nothing
+ Just glob -> liftM Just $ do
+ matches <- matchFileGlob glob
+ case matches of
+ []
+ | isJust (isTrivialFilePathGlob glob) ->
+ return
+ ( Left
+ ( BadPackageLocationFile
+ (BadLocNonexistantFile pkglocstr)
+ )
+ )
+ [] -> return (Left (BadLocGlobEmptyMatch pkglocstr))
+ _ -> do
+ (failures, pkglocs) <-
+ partitionEithers
+ <$> traverse checkFilePackageMatch matches
+ return $! case (failures, pkglocs) of
+ ([failure], [])
+ | isJust (isTrivialFilePathGlob glob) ->
+ Left (BadPackageLocationFile failure)
+ (_, []) -> Left (BadLocGlobBadMatches pkglocstr failures)
+ _ -> Right pkglocs
+
+ checkIsSingleFilePackage pkglocstr = do
+ let filename = distProjectRootDirectory </> pkglocstr
+ isFile <- liftIO $ doesFileExist filename
+ isDir <- liftIO $ doesDirectoryExist filename
+ if isFile || isDir
+ then
+ checkFilePackageMatch pkglocstr
+ >>= either
+ (return . Just . Left . BadPackageLocationFile)
+ (return . Just . Right . (\x -> [x]))
+ else return Nothing
+
+ checkFilePackageMatch
+ :: String
+ -> Rebuild
+ ( Either
+ BadPackageLocationMatch
+ ProjectPackageLocation
+ )
+ checkFilePackageMatch pkglocstr = do
+ -- The pkglocstr may be absolute or may be relative to the project root.
+ -- Either way, </> does the right thing here. We return relative paths if
+ -- they were relative in the first place.
+ let abspath = distProjectRootDirectory </> pkglocstr
+ isFile <- liftIO $ doesFileExist abspath
+ isDir <- liftIO $ doesDirectoryExist abspath
+ parentDirExists <- case takeDirectory abspath of
+ [] -> return False
+ dir -> liftIO $ doesDirectoryExist dir
+ case () of
+ _
+ | isDir ->
+ do
+ matches <- matchFileGlob (globStarDotCabal pkglocstr)
+ case matches of
+ [cabalFile] ->
+ return
+ ( Right
+ ( ProjectPackageLocalDirectory
+ pkglocstr
+ cabalFile
+ )
+ )
+ [] -> return (Left (BadLocDirNoCabalFile pkglocstr))
+ _ -> return (Left (BadLocDirManyCabalFiles pkglocstr))
+ | extensionIsTarGz pkglocstr ->
+ return (Right (ProjectPackageLocalTarball pkglocstr))
+ | takeExtension pkglocstr == ".cabal" ->
+ return (Right (ProjectPackageLocalCabalFile pkglocstr))
+ | isFile ->
+ return (Left (BadLocUnexpectedFile pkglocstr))
+ | parentDirExists ->
+ return (Left (BadLocNonexistantFile pkglocstr))
+ | otherwise ->
+ return (Left (BadLocUnexpectedFile pkglocstr))
+
+ extensionIsTarGz f =
+ takeExtension f == ".gz"
+ && takeExtension (dropExtension f) == ".tar"
-- | A glob to find all the cabal files in a directory.
--
-- For a directory @some/dir/@, this is a glob of the form @some/dir/\*.cabal@.
-- The directory part can be either absolute or relative.
---
globStarDotCabal :: FilePath -> FilePathGlob
globStarDotCabal dir =
- FilePathGlob
- (if isAbsolute dir then FilePathRoot root else FilePathRelative)
- (foldr (\d -> GlobDir [Literal d])
- (GlobFile [WildCard, Literal ".cabal"]) dirComponents)
+ FilePathGlob
+ (if isAbsolute dir then FilePathRoot root else FilePathRelative)
+ ( foldr
+ (\d -> GlobDir [Literal d])
+ (GlobFile [WildCard, Literal ".cabal"])
+ dirComponents
+ )
where
(root, dirComponents) = fmap splitDirectories (splitDrive dir)
-
---TODO: [code cleanup] use sufficiently recent transformers package
+-- TODO: [code cleanup] use sufficiently recent transformers package
mplusMaybeT :: Monad m => m (Maybe a) -> m (Maybe a) -> m (Maybe a)
mplusMaybeT ma mb = do
mx <- ma
case mx of
Nothing -> mb
- Just x -> return (Just x)
-
+ Just x -> return (Just x)
-------------------------------------------------
-- Fetching and reading packages in the project
@@ -1010,7 +1159,6 @@ mplusMaybeT ma mb = do
--
-- Note here is where we convert from project-root relative paths to absolute
-- paths.
---
fetchAndReadSourcePackages
:: Verbosity
-> DistDirLayout
@@ -1018,246 +1166,281 @@ fetchAndReadSourcePackages
-> ProjectConfigBuildOnly
-> [ProjectPackageLocation]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-fetchAndReadSourcePackages verbosity distDirLayout
- projectConfigShared
- projectConfigBuildOnly
- pkgLocations = do
-
+fetchAndReadSourcePackages
+ verbosity
+ distDirLayout
+ projectConfigShared
+ projectConfigBuildOnly
+ pkgLocations = do
pkgsLocalDirectory <-
sequenceA
[ readSourcePackageLocalDirectory verbosity dir cabalFile
| location <- pkgLocations
- , (dir, cabalFile) <- projectPackageLocal location ]
+ , (dir, cabalFile) <- projectPackageLocal location
+ ]
pkgsLocalTarball <-
sequenceA
[ readSourcePackageLocalTarball verbosity path
- | ProjectPackageLocalTarball path <- pkgLocations ]
+ | ProjectPackageLocalTarball path <- pkgLocations
+ ]
pkgsRemoteTarball <- do
- getTransport <- delayInitSharedResource $
- configureTransport verbosity progPathExtra
- preferredHttpTransport
+ getTransport <-
+ delayInitSharedResource $
+ configureTransport
+ verbosity
+ progPathExtra
+ preferredHttpTransport
sequenceA
- [ fetchAndReadSourcePackageRemoteTarball verbosity distDirLayout
- getTransport uri
- | ProjectPackageRemoteTarball uri <- pkgLocations ]
+ [ fetchAndReadSourcePackageRemoteTarball
+ verbosity
+ distDirLayout
+ getTransport
+ uri
+ | ProjectPackageRemoteTarball uri <- pkgLocations
+ ]
pkgsRemoteRepo <-
syncAndReadSourcePackagesRemoteRepos
- verbosity distDirLayout
+ verbosity
+ distDirLayout
projectConfigShared
- [ repo | ProjectPackageRemoteRepo repo <- pkgLocations ]
+ [repo | ProjectPackageRemoteRepo repo <- pkgLocations]
let pkgsNamed =
[ NamedPackage pkgname [PackagePropertyVersion verrange]
- | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations ]
-
- return $ concat
- [ pkgsLocalDirectory
- , pkgsLocalTarball
- , pkgsRemoteTarball
- , pkgsRemoteRepo
- , pkgsNamed
- ]
- where
- projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)]
- projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)]
- where dir = takeDirectory file
- projectPackageLocal _ = []
+ | ProjectPackageNamed (PackageVersionConstraint pkgname verrange) <- pkgLocations
+ ]
+
+ return $
+ concat
+ [ pkgsLocalDirectory
+ , pkgsLocalTarball
+ , pkgsRemoteTarball
+ , pkgsRemoteRepo
+ , pkgsNamed
+ ]
+ where
+ projectPackageLocal (ProjectPackageLocalDirectory dir file) = [(dir, file)]
+ projectPackageLocal (ProjectPackageLocalCabalFile file) = [(dir, file)]
+ where
+ dir = takeDirectory file
+ projectPackageLocal _ = []
- progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared)
- preferredHttpTransport =
- flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly)
+ progPathExtra = fromNubList (projectConfigProgPathExtra projectConfigShared)
+ preferredHttpTransport =
+ flagToMaybe (projectConfigHttpTransport projectConfigBuildOnly)
-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageLocalDirectory' and 'ProjectPackageLocalCabalFile'.
-- We simply read the @.cabal@ file.
---
readSourcePackageLocalDirectory
:: Verbosity
- -> FilePath -- ^ The package directory
- -> FilePath -- ^ The package @.cabal@ file
+ -> FilePath
+ -- ^ The package directory
+ -> FilePath
+ -- ^ The package @.cabal@ file
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalDirectory verbosity dir cabalFile = do
- monitorFiles [monitorFileHashed cabalFile]
- root <- askRoot
- let location = LocalUnpackedPackage (root </> dir)
- liftIO $ fmap (mkSpecificSourcePackage location)
- . readSourcePackageCabalFile verbosity cabalFile
- =<< BS.readFile (root </> cabalFile)
-
+ monitorFiles [monitorFileHashed cabalFile]
+ root <- askRoot
+ let location = LocalUnpackedPackage (root </> dir)
+ liftIO $
+ fmap (mkSpecificSourcePackage location)
+ . readSourcePackageCabalFile verbosity cabalFile
+ =<< BS.readFile (root </> cabalFile)
-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageLocalTarball'. We scan through the @.tar.gz@ file to find
-- the @.cabal@ file and read that.
---
readSourcePackageLocalTarball
:: Verbosity
-> FilePath
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
readSourcePackageLocalTarball verbosity tarballFile = do
- monitorFiles [monitorFile tarballFile]
- root <- askRoot
- let location = LocalTarballPackage (root </> tarballFile)
- liftIO $ fmap (mkSpecificSourcePackage location)
- . uncurry (readSourcePackageCabalFile verbosity)
- =<< extractTarballPackageCabalFile (root </> tarballFile)
+ monitorFiles [monitorFile tarballFile]
+ root <- askRoot
+ let location = LocalTarballPackage (root </> tarballFile)
+ liftIO $
+ fmap (mkSpecificSourcePackage location)
+ . uncurry (readSourcePackageCabalFile verbosity)
+ =<< extractTarballPackageCabalFile (root </> tarballFile)
-- | A helper for 'fetchAndReadSourcePackages' to handle the case of
-- 'ProjectPackageRemoteTarball'. We download the tarball to the dist src dir
-- and after that handle it like the local tarball case.
---
fetchAndReadSourcePackageRemoteTarball
:: Verbosity
-> DistDirLayout
-> Rebuild HttpTransport
-> URI
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
-fetchAndReadSourcePackageRemoteTarball verbosity
- DistDirLayout {
- distDownloadSrcDirectory
- }
- getTransport
- tarballUri =
+fetchAndReadSourcePackageRemoteTarball
+ verbosity
+ DistDirLayout
+ { distDownloadSrcDirectory
+ }
+ getTransport
+ tarballUri =
-- The tarball download is expensive so we use another layer of file
-- monitor to avoid it whenever possible.
rerunIfChanged verbosity monitor tarballUri $ do
-
-- Download
transport <- getTransport
liftIO $ do
transportCheckHttps verbosity transport tarballUri
notice verbosity ("Downloading " ++ show tarballUri)
- createDirectoryIfMissingVerbose verbosity True
- distDownloadSrcDirectory
+ createDirectoryIfMissingVerbose
+ verbosity
+ True
+ distDownloadSrcDirectory
_ <- downloadURI transport verbosity tarballUri tarballFile
return ()
-- Read
monitorFiles [monitorFile tarballFile]
let location = RemoteTarballPackage tarballUri tarballFile
- liftIO $ fmap (mkSpecificSourcePackage location)
- . uncurry (readSourcePackageCabalFile verbosity)
- =<< extractTarballPackageCabalFile tarballFile
- where
- tarballStem :: FilePath
- tarballStem = distDownloadSrcDirectory
- </> localFileNameForRemoteTarball tarballUri
- tarballFile :: FilePath
- tarballFile = tarballStem <.> "tar.gz"
-
- monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
- monitor = newFileMonitor (tarballStem <.> "cache")
+ liftIO $
+ fmap (mkSpecificSourcePackage location)
+ . uncurry (readSourcePackageCabalFile verbosity)
+ =<< extractTarballPackageCabalFile tarballFile
+ where
+ tarballStem :: FilePath
+ tarballStem =
+ distDownloadSrcDirectory
+ </> localFileNameForRemoteTarball tarballUri
+ tarballFile :: FilePath
+ tarballFile = tarballStem <.> "tar.gz"
+ monitor :: FileMonitor URI (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
+ monitor = newFileMonitor (tarballStem <.> "cache")
-- | A helper for 'fetchAndReadSourcePackages' to handle all the cases of
-- 'ProjectPackageRemoteRepo'.
---
syncAndReadSourcePackagesRemoteRepos
:: Verbosity
-> DistDirLayout
-> ProjectConfigShared
-> [SourceRepoList]
-> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
-syncAndReadSourcePackagesRemoteRepos verbosity
- DistDirLayout{distDownloadSrcDirectory}
- ProjectConfigShared {
- projectConfigProgPathExtra
- }
- repos = do
-
- repos' <- either reportSourceRepoProblems return $
- validateSourceRepos repos
+syncAndReadSourcePackagesRemoteRepos
+ verbosity
+ DistDirLayout{distDownloadSrcDirectory}
+ ProjectConfigShared
+ { projectConfigProgPathExtra
+ }
+ repos = do
+ repos' <-
+ either reportSourceRepoProblems return $
+ validateSourceRepos repos
-- All 'SourceRepo's grouped by referring to the "same" remote repo
-- instance. So same location but can differ in commit/tag/branch/subdir.
- let reposByLocation :: Map (RepoType, String)
- [(SourceRepoList, RepoType)]
- reposByLocation = Map.fromListWith (++)
- [ ((rtype, rloc), [(repo, vcsRepoType vcs)])
- | (repo, rloc, rtype, vcs) <- repos' ]
-
- --TODO: pass progPathExtra on to 'configureVCS'
+ let reposByLocation
+ :: Map
+ (RepoType, String)
+ [(SourceRepoList, RepoType)]
+ reposByLocation =
+ Map.fromListWith
+ (++)
+ [ ((rtype, rloc), [(repo, vcsRepoType vcs)])
+ | (repo, rloc, rtype, vcs) <- repos'
+ ]
+
+ -- TODO: pass progPathExtra on to 'configureVCS'
let _progPathExtra = fromNubList projectConfigProgPathExtra
getConfiguredVCS <- delayInitSharedResources $ \repoType ->
- let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs in
- configureVCS verbosity {-progPathExtra-} vcs
+ let vcs = Map.findWithDefault (error $ "Unknown VCS: " ++ prettyShow repoType) repoType knownVCSs
+ in configureVCS verbosity {-progPathExtra-} vcs
- concat <$> sequenceA
- [ rerunIfChanged verbosity monitor repoGroup' $ do
+ concat
+ <$> sequenceA
+ [ rerunIfChanged verbosity monitor repoGroup' $ do
vcs' <- getConfiguredVCS repoType
syncRepoGroupAndReadSourcePackages vcs' pathStem repoGroup'
- | repoGroup@((primaryRepo, repoType):_) <- Map.elems reposByLocation
- , let repoGroup' = map fst repoGroup
- pathStem = distDownloadSrcDirectory
- </> localFileNameForRemoteRepo primaryRepo
- monitor :: FileMonitor
- [SourceRepoList]
- [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
- monitor = newFileMonitor (pathStem <.> "cache")
- ]
- where
- syncRepoGroupAndReadSourcePackages
- :: VCS ConfiguredProgram
- -> FilePath
- -> [SourceRepoList]
- -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
- syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do
- liftIO $ createDirectoryIfMissingVerbose verbosity False
- distDownloadSrcDirectory
+ | repoGroup@((primaryRepo, repoType) : _) <- Map.elems reposByLocation
+ , let repoGroup' = map fst repoGroup
+ pathStem =
+ distDownloadSrcDirectory
+ </> localFileNameForRemoteRepo primaryRepo
+ monitor
+ :: FileMonitor
+ [SourceRepoList]
+ [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
+ monitor = newFileMonitor (pathStem <.> "cache")
+ ]
+ where
+ syncRepoGroupAndReadSourcePackages
+ :: VCS ConfiguredProgram
+ -> FilePath
+ -> [SourceRepoList]
+ -> Rebuild [PackageSpecifier (SourcePackage UnresolvedPkgLoc)]
+ syncRepoGroupAndReadSourcePackages vcs pathStem repoGroup = do
+ liftIO $
+ createDirectoryIfMissingVerbose
+ verbosity
+ False
+ distDownloadSrcDirectory
-- For syncing we don't care about different 'SourceRepo' values that
-- are just different subdirs in the same repo.
- syncSourceRepos verbosity vcs
+ syncSourceRepos
+ verbosity
+ vcs
[ (repo, repoPath)
- | (repo, _, repoPath) <- repoGroupWithPaths ]
+ | (repo, _, repoPath) <- repoGroupWithPaths
+ ]
-- Run post-checkout-command if it is specified
for_ repoGroupWithPaths $ \(repo, _, repoPath) ->
- for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do
- maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing
+ for_ (nonEmpty (srpCommand repo)) $ \(cmd :| args) -> liftIO $ do
+ maybeExit $ rawSystemIOWithEnv verbosity cmd args (Just repoPath) Nothing Nothing Nothing Nothing
-- But for reading we go through each 'SourceRepo' including its subdir
-- value and have to know which path each one ended up in.
sequenceA
[ readPackageFromSourceRepo repoWithSubdir repoPath
| (_, reposWithSubdir, repoPath) <- repoGroupWithPaths
- , repoWithSubdir <- NE.toList reposWithSubdir ]
- where
- -- So to do both things above, we pair them up here.
- repoGroupWithPaths
- :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]
- repoGroupWithPaths =
- zipWith (\(x, y) z -> (x,y,z))
- (mapGroup
- [ (repo { srpSubdir = Proxy }, repo)
- | repo <- foldMap (NE.toList . srpFanOut) repoGroup
- ])
- repoPaths
-
- mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
- mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))
-
- -- The repos in a group are given distinct names by simple enumeration
- -- foo, foo-2, foo-3 etc
- repoPaths :: [FilePath]
- repoPaths = pathStem
- : [ pathStem ++ "-" ++ show (i :: Int) | i <- [2..] ]
-
- readPackageFromSourceRepo
+ , repoWithSubdir <- NE.toList reposWithSubdir
+ ]
+ where
+ -- So to do both things above, we pair them up here.
+ repoGroupWithPaths
+ :: [(SourceRepositoryPackage Proxy, NonEmpty (SourceRepositoryPackage Maybe), FilePath)]
+ repoGroupWithPaths =
+ zipWith
+ (\(x, y) z -> (x, y, z))
+ ( mapGroup
+ [ (repo{srpSubdir = Proxy}, repo)
+ | repo <- foldMap (NE.toList . srpFanOut) repoGroup
+ ]
+ )
+ repoPaths
+
+ mapGroup :: Ord k => [(k, v)] -> [(k, NonEmpty v)]
+ mapGroup = Map.toList . Map.fromListWith (<>) . map (\(k, v) -> (k, pure v))
+
+ -- The repos in a group are given distinct names by simple enumeration
+ -- foo, foo-2, foo-3 etc
+ repoPaths :: [FilePath]
+ repoPaths =
+ pathStem
+ : [pathStem ++ "-" ++ show (i :: Int) | i <- [2 ..]]
+
+ readPackageFromSourceRepo
:: SourceRepositoryPackage Maybe
-> FilePath
-> Rebuild (PackageSpecifier (SourcePackage UnresolvedPkgLoc))
- readPackageFromSourceRepo repo repoPath = do
+ readPackageFromSourceRepo repo repoPath = do
let packageDir :: FilePath
packageDir = maybe repoPath (repoPath </>) (srpSubdir repo)
entries <- liftIO $ getDirectoryContents packageDir
- --TODO: dcoutts 2018-06-23: wrap exceptions
+ -- TODO: dcoutts 2018-06-23: wrap exceptions
case filter (\e -> takeExtension e == ".cabal") entries of
- [] -> liftIO $ throwIO $ NoCabalFileFound packageDir
- (_:_:_) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir
+ [] -> liftIO $ throwIO $ NoCabalFileFound packageDir
+ (_ : _ : _) -> liftIO $ throwIO $ MultipleCabalFilesFound packageDir
[cabalFileName] -> do
let cabalFilePath = packageDir </> cabalFileName
monitorFiles [monitorFileHashed cabalFilePath]
@@ -1271,48 +1454,58 @@ syncAndReadSourcePackagesRemoteRepos verbosity
let location = RemoteSourceRepoPackage repo tarballPath
return $ mkSpecificSourcePackage location gpd
- reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
- reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems
-
- renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
- renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"
+ reportSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> Rebuild a
+ reportSourceRepoProblems = liftIO . die' verbosity . renderSourceRepoProblems
+ renderSourceRepoProblems :: [(SourceRepoList, SourceRepoProblem)] -> String
+ renderSourceRepoProblems = unlines . map show -- "TODO: the repo problems"
-- | Utility used by all the helpers of 'fetchAndReadSourcePackages' to make an
-- appropriate @'PackageSpecifier' ('SourcePackage' (..))@ for a given package
-- from a given location.
---
-mkSpecificSourcePackage :: PackageLocation FilePath
- -> GenericPackageDescription
- -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
+mkSpecificSourcePackage
+ :: PackageLocation FilePath
+ -> GenericPackageDescription
+ -> PackageSpecifier (SourcePackage UnresolvedPkgLoc)
mkSpecificSourcePackage location pkg =
- SpecificSourcePackage SourcePackage
- { srcpkgPackageId = packageId pkg
- , srcpkgDescription = pkg
- , srcpkgSource = fmap Just location
+ SpecificSourcePackage
+ SourcePackage
+ { srcpkgPackageId = packageId pkg
+ , srcpkgDescription = pkg
+ , srcpkgSource = fmap Just location
, srcpkgDescrOverride = Nothing
}
-
-- | Errors reported upon failing to parse a @.cabal@ file.
---
-data CabalFileParseError = CabalFileParseError
- FilePath -- ^ @.cabal@ file path
- BS.ByteString -- ^ @.cabal@ file contents
- (NonEmpty PError) -- ^ errors
- (Maybe Version) -- ^ We might discover the spec version the package needs
- [PWarning] -- ^ warnings
+data CabalFileParseError
+ = CabalFileParseError
+ FilePath
+ -- ^ @.cabal@ file path
+ BS.ByteString
+ -- ^ @.cabal@ file contents
+ (NonEmpty PError)
+ -- ^ errors
+ (Maybe Version)
+ -- ^ We might discover the spec version the package needs
+ [PWarning]
+ -- ^ warnings
deriving (Typeable)
-- | Manual instance which skips file contents
instance Show CabalFileParseError where
- showsPrec d (CabalFileParseError fp _ es mv ws) = showParen (d > 10)
- $ showString "CabalFileParseError"
- . showChar ' ' . showsPrec 11 fp
- . showChar ' ' . showsPrec 11 ("" :: String)
- . showChar ' ' . showsPrec 11 es
- . showChar ' ' . showsPrec 11 mv
- . showChar ' ' . showsPrec 11 ws
+ showsPrec d (CabalFileParseError fp _ es mv ws) =
+ showParen (d > 10) $
+ showString "CabalFileParseError"
+ . showChar ' '
+ . showsPrec 11 fp
+ . showChar ' '
+ . showsPrec 11 ("" :: String)
+ . showChar ' '
+ . showsPrec 11 es
+ . showChar ' '
+ . showsPrec 11 mv
+ . showChar ' '
+ . showsPrec 11 ws
instance Exception CabalFileParseError
#if MIN_VERSION_base(4,8,0)
@@ -1322,127 +1515,130 @@ instance Exception CabalFileParseError
renderCabalFileParseError :: CabalFileParseError -> String
renderCabalFileParseError (CabalFileParseError filePath contents errors _ warnings) =
- renderParseError filePath contents errors warnings
+ renderParseError filePath contents errors warnings
-- | Wrapper for the @.cabal@ file parser. It reports warnings on higher
-- verbosity levels and throws 'CabalFileParseError' on failure.
---
-readSourcePackageCabalFile :: Verbosity
- -> FilePath
- -> BS.ByteString
- -> IO GenericPackageDescription
+readSourcePackageCabalFile
+ :: Verbosity
+ -> FilePath
+ -> BS.ByteString
+ -> IO GenericPackageDescription
readSourcePackageCabalFile verbosity pkgfilename content =
- case runParseResult (parseGenericPackageDescription content) of
- (warnings, Right pkg) -> do
- unless (null warnings) $
- info verbosity (formatWarnings warnings)
- return pkg
-
- (warnings, Left (mspecVersion, errors)) ->
- throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings
+ case runParseResult (parseGenericPackageDescription content) of
+ (warnings, Right pkg) -> do
+ unless (null warnings) $
+ info verbosity (formatWarnings warnings)
+ return pkg
+ (warnings, Left (mspecVersion, errors)) ->
+ throwIO $ CabalFileParseError pkgfilename content errors mspecVersion warnings
where
formatWarnings warnings =
- "The package description file " ++ pkgfilename
- ++ " has warnings: "
- ++ unlines (map (showPWarning pkgfilename) warnings)
-
+ "The package description file "
+ ++ pkgfilename
+ ++ " has warnings: "
+ ++ unlines (map (showPWarning pkgfilename) warnings)
-- | When looking for a package's @.cabal@ file we can find none, or several,
-- both of which are failures.
---
data CabalFileSearchFailure
- = NoCabalFileFound FilePath
- | MultipleCabalFilesFound FilePath
+ = NoCabalFileFound FilePath
+ | MultipleCabalFilesFound FilePath
deriving (Show, Typeable)
instance Exception CabalFileSearchFailure
-
-- | Find the @.cabal@ file within a tarball file and return it by value.
--
-- Can fail with a 'Tar.FormatError' or 'CabalFileSearchFailure' exception.
---
extractTarballPackageCabalFile :: FilePath -> IO (FilePath, BS.ByteString)
extractTarballPackageCabalFile tarballFile =
- withBinaryFile tarballFile ReadMode $ \hnd -> do
- content <- LBS.hGetContents hnd
- case extractTarballPackageCabalFilePure tarballFile content of
- Left (Left e) -> throwIO e
- Left (Right e) -> throwIO e
- Right (fileName, fileContent) ->
- (,) fileName <$> evaluate (LBS.toStrict fileContent)
-
+ withBinaryFile tarballFile ReadMode $ \hnd -> do
+ content <- LBS.hGetContents hnd
+ case extractTarballPackageCabalFilePure tarballFile content of
+ Left (Left e) -> throwIO e
+ Left (Right e) -> throwIO e
+ Right (fileName, fileContent) ->
+ (,) fileName <$> evaluate (LBS.toStrict fileContent)
-- | Scan through a tar file stream and collect the @.cabal@ file, or fail.
---
-extractTarballPackageCabalFilePure :: FilePath
- -> LBS.ByteString
- -> Either (Either Tar.FormatError
- CabalFileSearchFailure)
- (FilePath, LBS.ByteString)
+extractTarballPackageCabalFilePure
+ :: FilePath
+ -> LBS.ByteString
+ -> Either
+ ( Either
+ Tar.FormatError
+ CabalFileSearchFailure
+ )
+ (FilePath, LBS.ByteString)
extractTarballPackageCabalFilePure tarballFile =
- check
+ check
. accumEntryMap
. Tar.filterEntries isCabalFile
. Tar.read
. GZipUtils.maybeDecompress
where
- accumEntryMap = Tar.foldlEntries
- (\m e -> Map.insert (Tar.entryTarPath e) e m)
- Map.empty
+ accumEntryMap =
+ Tar.foldlEntries
+ (\m e -> Map.insert (Tar.entryTarPath e) e m)
+ Map.empty
check (Left (e, _m)) = Left (Left e)
check (Right m) = case Map.elems m of
- [] -> Left (Right $ NoCabalFileFound tarballFile)
- [file] -> case Tar.entryContent file of
- Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
- _ -> Left (Right $ NoCabalFileFound tarballFile)
- _files -> Left (Right $ MultipleCabalFilesFound tarballFile)
+ [] -> Left (Right $ NoCabalFileFound tarballFile)
+ [file] -> case Tar.entryContent file of
+ Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
+ _ -> Left (Right $ NoCabalFileFound tarballFile)
+ _files -> Left (Right $ MultipleCabalFilesFound tarballFile)
isCabalFile e = case splitPath (Tar.entryPath e) of
- [ _dir, file] -> takeExtension file == ".cabal"
+ [_dir, file] -> takeExtension file == ".cabal"
[".", _dir, file] -> takeExtension file == ".cabal"
- _ -> False
-
+ _ -> False
-- | The name to use for a local file for a remote tarball 'SourceRepo'.
-- This is deterministic based on the remote tarball URI, and is intended
-- to produce non-clashing file names for different tarballs.
---
localFileNameForRemoteTarball :: URI -> FilePath
localFileNameForRemoteTarball uri =
- mangleName uri
- ++ "-" ++ showHex locationHash ""
+ mangleName uri
+ ++ "-"
+ ++ showHex locationHash ""
where
- mangleName = truncateString 10 . dropExtension . dropExtension
- . takeFileName . dropTrailingPathSeparator . uriPath
+ mangleName =
+ truncateString 10
+ . dropExtension
+ . dropExtension
+ . takeFileName
+ . dropTrailingPathSeparator
+ . uriPath
locationHash :: Word
locationHash = fromIntegral (Hashable.hash (uriToString id uri ""))
-
-- | The name to use for a local file or dir for a remote 'SourceRepo'.
-- This is deterministic based on the source repo identity details, and
-- intended to produce non-clashing file names for different repos.
---
localFileNameForRemoteRepo :: SourceRepoList -> FilePath
-localFileNameForRemoteRepo SourceRepositoryPackage {srpType, srpLocation} =
- mangleName srpLocation ++ "-" ++ showHex locationHash ""
+localFileNameForRemoteRepo SourceRepositoryPackage{srpType, srpLocation} =
+ mangleName srpLocation ++ "-" ++ showHex locationHash ""
where
- mangleName = truncateString 10 . dropExtension
- . takeFileName . dropTrailingPathSeparator
+ mangleName =
+ truncateString 10
+ . dropExtension
+ . takeFileName
+ . dropTrailingPathSeparator
-- just the parts that make up the "identity" of the repo
locationHash :: Word
locationHash =
fromIntegral (Hashable.hash (show srpType, srpLocation))
-
-- | Truncate a string, with a visual indication that it is truncated.
truncateString :: Int -> String -> String
-truncateString n s | length s <= n = s
- | otherwise = take (n-1) s ++ "_"
-
+truncateString n s
+ | length s <= n = s
+ | otherwise = take (n - 1) s ++ "_"
-- TODO: add something like this, here or in the project planning
-- Based on the package location, which packages will be built inplace in the
@@ -1451,13 +1647,12 @@ truncateString n s | length s <= n = s
--
-- packageIsLocalToProject :: ProjectPackageLocation -> Bool
-
---------------------------------------------
-- Checking configuration sanity
--
data BadPerPackageCompilerPaths
- = BadPerPackageCompilerPaths [(PackageName, String)]
+ = BadPerPackageCompilerPaths [(PackageName, String)]
#if MIN_VERSION_base(4,8,0)
deriving (Show, Typeable)
#else
@@ -1467,23 +1662,28 @@ instance Show BadPerPackageCompilerPaths where
show = renderBadPerPackageCompilerPaths
#endif
+{- FOURMOLU_DISABLE -}
instance Exception BadPerPackageCompilerPaths where
#if MIN_VERSION_base(4,8,0)
displayException = renderBadPerPackageCompilerPaths
#endif
---TODO: [nice to have] custom exception subclass for Doc rendering, colour etc
+{- FOURMOLU_ENABLE -}
+-- TODO: [nice to have] custom exception subclass for Doc rendering, colour etc
renderBadPerPackageCompilerPaths :: BadPerPackageCompilerPaths -> String
renderBadPerPackageCompilerPaths
(BadPerPackageCompilerPaths ((pkgname, progname) : _)) =
"The path to the compiler program (or programs used by the compiler) "
- ++ "cannot be specified on a per-package basis in the cabal.project file "
- ++ "(i.e. setting the '" ++ progname ++ "-location' for package '"
- ++ prettyShow pkgname ++ "'). All packages have to use the same compiler, so "
- ++ "specify the path in a global 'program-locations' section."
- --TODO: [nice to have] better format control so we can pretty-print the
- -- offending part of the project file. Currently the line wrapping breaks any
- -- formatting.
+ ++ "cannot be specified on a per-package basis in the cabal.project file "
+ ++ "(i.e. setting the '"
+ ++ progname
+ ++ "-location' for package '"
+ ++ prettyShow pkgname
+ ++ "'). All packages have to use the same compiler, so "
+ ++ "specify the path in a global 'program-locations' section."
+-- TODO: [nice to have] better format control so we can pretty-print the
+-- offending part of the project file. Currently the line wrapping breaks any
+-- formatting.
renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths"
-- | The project configuration is not allowed to specify program locations for
@@ -1494,15 +1694,16 @@ renderBadPerPackageCompilerPaths _ = error "renderBadPerPackageCompilerPaths"
-- in principle is not until we've configured the compiler.
--
-- Throws 'BadPerPackageCompilerPaths'
---
-checkBadPerPackageCompilerPaths :: [ConfiguredProgram]
- -> Map PackageName PackageConfig
- -> IO ()
+checkBadPerPackageCompilerPaths
+ :: [ConfiguredProgram]
+ -> Map PackageName PackageConfig
+ -> IO ()
checkBadPerPackageCompilerPaths compilerPrograms packagesConfig =
- case [ (pkgname, progname)
- | let compProgNames = Set.fromList (map programId compilerPrograms)
- , (pkgname, pkgconf) <- Map.toList packagesConfig
- , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))
- , progname `Set.member` compProgNames ] of
- [] -> return ()
- ps -> throwIO (BadPerPackageCompilerPaths ps)
+ case [ (pkgname, progname)
+ | let compProgNames = Set.fromList (map programId compilerPrograms)
+ , (pkgname, pkgconf) <- Map.toList packagesConfig
+ , progname <- Map.keys (getMapLast (packageConfigProgramPaths pkgconf))
+ , progname `Set.member` compProgNames
+ ] of
+ [] -> return ()
+ ps -> throwIO (BadPerPackageCompilerPaths ps)
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
index d86998f1fad4255bd05bae356b99284ec81fa5b0..57a21a7c0d0479b7892d6aafb092f57e1f5d2a3e 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs
@@ -1,127 +1,189 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, DeriveGeneric, ConstraintKinds, FlexibleInstances #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Project configuration, implementation in terms of legacy types.
---
-module Distribution.Client.ProjectConfig.Legacy (
-
- -- Project config skeletons
- ProjectConfigSkeleton,
- parseProjectSkeleton,
- instantiateProjectConfigSkeletonFetchingCompiler,
- instantiateProjectConfigSkeletonWithCompiler,
- singletonProjectConfigSkeleton,
- projectSkeletonImports,
+module Distribution.Client.ProjectConfig.Legacy
+ ( -- Project config skeletons
+ ProjectConfigSkeleton
+ , parseProjectSkeleton
+ , instantiateProjectConfigSkeletonFetchingCompiler
+ , instantiateProjectConfigSkeletonWithCompiler
+ , singletonProjectConfigSkeleton
+ , projectSkeletonImports
-- * Project config in terms of legacy types
- LegacyProjectConfig,
- parseLegacyProjectConfig,
- showLegacyProjectConfig,
+ , LegacyProjectConfig
+ , parseLegacyProjectConfig
+ , showLegacyProjectConfig
-- * Conversion to and from legacy config types
- commandLineFlagsToProjectConfig,
- convertLegacyProjectConfig,
- convertLegacyGlobalConfig,
- convertToLegacyProjectConfig,
+ , commandLineFlagsToProjectConfig
+ , convertLegacyProjectConfig
+ , convertLegacyGlobalConfig
+ , convertToLegacyProjectConfig
-- * Internals, just for tests
- parsePackageLocationTokenQ,
- renderPackageLocationToken
+ , parsePackageLocationTokenQ
+ , renderPackageLocationToken
) where
import Distribution.Client.Compat.Prelude
-import Distribution.Types.Flag (parsecFlagAssignment, FlagName)
+import Distribution.Types.Flag (FlagName, parsecFlagAssignment)
import Distribution.Client.ProjectConfig.Types
+import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..))
+import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..), emptyRemoteRepo)
import Distribution.Client.Types.RepoName (RepoName (..), unRepoName)
-import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..), emptyRemoteRepo)
-import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..))
-import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar, SourceRepoList)
+import Distribution.Client.Types.SourceRepo (SourceRepoList, sourceRepositoryPackageGrammar)
import Distribution.Client.Config
- ( SavedConfig(..), remoteRepoFields, postProcessRepo )
+ ( SavedConfig (..)
+ , postProcessRepo
+ , remoteRepoFields
+ )
import Distribution.Client.CmdInstall.ClientInstallFlags
- ( ClientInstallFlags(..), defaultClientInstallFlags
- , clientInstallOptions )
+ ( ClientInstallFlags (..)
+ , clientInstallOptions
+ , defaultClientInstallFlags
+ )
-import Distribution.Compat.Lens (view, toListOf)
+import Distribution.Compat.Lens (toListOf, view)
import Distribution.Solver.Types.ConstraintSource
+import Distribution.Client.NixStyleOptions (NixStyleFlags (..))
+import Distribution.Client.ProjectFlags (ProjectFlags (..), defaultProjectFlags, projectFlagsOptions)
+import Distribution.Client.Setup
+ ( ConfigExFlags (..)
+ , GlobalFlags (..)
+ , InstallFlags (..)
+ , configureExOptions
+ , defaultConfigExFlags
+ , defaultInstallFlags
+ , globalCommand
+ , installOptions
+ )
import Distribution.FieldGrammar
import Distribution.Package
-import Distribution.Types.SourceRepo (RepoType)
-import Distribution.Types.CondTree
- ( CondTree (..), CondBranch (..), mapTreeConds, traverseCondTreeC, traverseCondTreeV, ignoreConditions )
import Distribution.PackageDescription
- ( dispFlagAssignment, Condition (..), ConfVar (..), FlagAssignment )
+ ( Condition (..)
+ , ConfVar (..)
+ , FlagAssignment
+ , dispFlagAssignment
+ )
import Distribution.PackageDescription.Configuration (simplifyWithSysParams)
import Distribution.Simple.Compiler
- ( OptimisationLevel(..), DebugInfoLevel(..), CompilerInfo(..) )
-import Distribution.Simple.InstallDirs ( CopyDest (NoCopyDest) )
-import Distribution.Simple.Setup
- ( Flag(..), toFlag, fromFlagOrDefault
- , ConfigFlags(..), configureOptions
- , HaddockFlags(..), haddockOptions, defaultHaddockFlags
- , TestFlags(..), testOptions', defaultTestFlags
- , BenchmarkFlags(..), benchmarkOptions', defaultBenchmarkFlags
- , programDbPaths', splitArgs, DumpBuildInfo (NoDumpBuildInfo, DumpBuildInfo)
- , readPackageDb, showPackageDb, installDirsOptions
- )
-import Distribution.Client.NixStyleOptions (NixStyleFlags (..))
-import Distribution.Client.ProjectFlags (ProjectFlags (..), projectFlagsOptions, defaultProjectFlags)
-import Distribution.Client.Setup
- ( GlobalFlags(..), globalCommand
- , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
- , InstallFlags(..), installOptions, defaultInstallFlags )
+ ( CompilerInfo (..)
+ , DebugInfoLevel (..)
+ , OptimisationLevel (..)
+ )
+import Distribution.Simple.InstallDirs (CopyDest (NoCopyDest))
+import Distribution.Simple.LocalBuildInfo
+ ( fromPathTemplate
+ , toPathTemplate
+ )
import Distribution.Simple.Program
- ( programName, knownPrograms )
+ ( knownPrograms
+ , programName
+ )
import Distribution.Simple.Program.Db
- ( ProgramDb, defaultProgramDb )
+ ( ProgramDb
+ , defaultProgramDb
+ )
+import Distribution.Simple.Setup
+ ( BenchmarkFlags (..)
+ , ConfigFlags (..)
+ , DumpBuildInfo (DumpBuildInfo, NoDumpBuildInfo)
+ , Flag (..)
+ , HaddockFlags (..)
+ , TestFlags (..)
+ , benchmarkOptions'
+ , configureOptions
+ , defaultBenchmarkFlags
+ , defaultHaddockFlags
+ , defaultTestFlags
+ , fromFlagOrDefault
+ , haddockOptions
+ , installDirsOptions
+ , programDbPaths'
+ , readPackageDb
+ , showPackageDb
+ , splitArgs
+ , testOptions'
+ , toFlag
+ )
import Distribution.Simple.Utils
- ( lowercase )
+ ( lowercase
+ )
+import Distribution.Types.CondTree
+ ( CondBranch (..)
+ , CondTree (..)
+ , ignoreConditions
+ , mapTreeConds
+ , traverseCondTreeC
+ , traverseCondTreeV
+ )
+import Distribution.Types.SourceRepo (RepoType)
import Distribution.Utils.NubList
- ( toNubList, fromNubList, overNubList )
-import Distribution.Simple.LocalBuildInfo
- ( toPathTemplate, fromPathTemplate )
+ ( fromNubList
+ , overNubList
+ , toNubList
+ )
-import qualified Distribution.Deprecated.ReadP as Parse
-import Distribution.Deprecated.ReadP
- ( ReadP, (+++) )
-import qualified Text.PrettyPrint as Disp
-import Text.PrettyPrint
- ( Doc, ($+$) )
-import qualified Distribution.Deprecated.ParseUtils as ParseUtils
-import Distribution.Deprecated.ParseUtils
- ( ParseResult(..), PError(..), syntaxError, PWarning(..)
- , commaNewLineListFieldParsec, newLineListField, parseTokenQ
- , parseHaskellString, showToken
- , simpleFieldParsec, parseFail
- )
import Distribution.Client.ParseUtils
+import Distribution.Deprecated.ParseUtils
+ ( PError (..)
+ , PWarning (..)
+ , ParseResult (..)
+ , commaNewLineListFieldParsec
+ , newLineListField
+ , parseFail
+ , parseHaskellString
+ , parseTokenQ
+ , showToken
+ , simpleFieldParsec
+ , syntaxError
+ )
+import qualified Distribution.Deprecated.ParseUtils as ParseUtils
+import Distribution.Deprecated.ReadP
+ ( ReadP
+ , (+++)
+ )
+import qualified Distribution.Deprecated.ReadP as Parse
+import Distribution.Parsec (ParsecParser, parsecToken)
import Distribution.Simple.Command
- ( CommandUI(commandOptions), ShowOrParseArgs(..)
- , OptionField(..), option, reqArg' )
+ ( CommandUI (commandOptions)
+ , OptionField (..)
+ , ShowOrParseArgs (..)
+ , option
+ , reqArg'
+ )
+import Distribution.System (Arch, OS)
import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint )
-import Distribution.Parsec (ParsecParser, parsecToken)
-import Distribution.System (OS, Arch)
+ ( PackageVersionConstraint
+ )
+import Text.PrettyPrint
+ ( Doc
+ , ($+$)
+ )
+import qualified Text.PrettyPrint as Disp
+import qualified Data.ByteString.Char8 as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.ByteString.Char8 as BS
import Network.URI (URI (..), parseURI)
import Distribution.Fields.ConfVar (parseConditionConfVarFromClause)
import Distribution.Client.HttpUtils
-import System.FilePath ((</>), isPathSeparator, makeValid, isAbsolute, takeDirectory)
import System.Directory (createDirectoryIfMissing)
-
-
-
+import System.FilePath (isAbsolute, isPathSeparator, makeValid, takeDirectory, (</>))
------------------------------------------------------------------
-- Handle extended project config files with conditionals and imports.
@@ -130,35 +192,35 @@ import System.Directory (createDirectoryIfMissing)
-- | ProjectConfigSkeleton is a tree of conditional blocks and imports wrapping a config. It can be finalized by providing the conditional resolution info
-- and then resolving and downloading the imports
type ProjectConfigSkeleton = CondTree ConfVar [ProjectConfigImport] ProjectConfig
-type ProjectConfigImport = String
+type ProjectConfigImport = String
singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton x = CondNode x mempty mempty
-instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig
+instantiateProjectConfigSkeletonFetchingCompiler :: Monad m => m (OS, Arch, CompilerInfo) -> FlagAssignment -> ProjectConfigSkeleton -> m ProjectConfig
instantiateProjectConfigSkeletonFetchingCompiler fetch flags skel
- | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel)
- | otherwise = do
- (os, arch, impl) <- fetch
- pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
-
+ | null (toListOf traverseCondTreeV skel) = pure $ fst (ignoreConditions skel)
+ | otherwise = do
+ (os, arch, impl) <- fetch
+ pure $ instantiateProjectConfigSkeletonWithCompiler os arch impl flags skel
instantiateProjectConfigSkeletonWithCompiler :: OS -> Arch -> CompilerInfo -> FlagAssignment -> ProjectConfigSkeleton -> ProjectConfig
instantiateProjectConfigSkeletonWithCompiler os arch impl _flags skel = go $ mapTreeConds (fst . simplifyWithSysParams os arch impl) skel
- where
- go :: CondTree
- FlagName
- [ProjectConfigImport]
- ProjectConfig
- -> ProjectConfig
- go (CondNode l _imps ts) =
- let branches = concatMap processBranch ts
- in l <> mconcat branches
- processBranch (CondBranch cnd t mf) = case cnd of
- (Lit True) -> [go t]
- (Lit False) -> maybe ([]) ((:[]) . go) mf
- _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer
+ where
+ go
+ :: CondTree
+ FlagName
+ [ProjectConfigImport]
+ ProjectConfig
+ -> ProjectConfig
+ go (CondNode l _imps ts) =
+ let branches = concatMap processBranch ts
+ in l <> mconcat branches
+ processBranch (CondBranch cnd t mf) = case cnd of
+ (Lit True) -> [go t]
+ (Lit False) -> maybe ([]) ((: []) . go) mf
+ _ -> error $ "unable to process condition: " ++ show cnd -- TODO it would be nice if there were a pretty printer
projectSkeletonImports :: ProjectConfigSkeleton -> [ProjectConfigImport]
projectSkeletonImports = view traverseCondTreeC
@@ -167,77 +229,82 @@ parseProjectSkeleton :: FilePath -> HttpTransport -> Verbosity -> [ProjectConfig
parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (sanityWalkPCS False =<<) <$> liftPR (go []) (ParseUtils.readFields bs)
where
go :: [ParseUtils.Field] -> [ParseUtils.Field] -> IO (ParseResult ProjectConfigSkeleton)
- go acc (x:xs) = case x of
- (ParseUtils.F l "import" importLoc) ->
- if importLoc `elem` seenImports
- then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l)
- else do
- let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc)
- res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc
- rest <- go [] xs
- pure . fmap mconcat . sequence $ [fs, res, rest]
- (ParseUtils.Section l "if" p xs') -> do
- subpcs <- go [] xs'
- let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc)
- (elseClauses, rest) <- parseElseClauses xs
- let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$>
- -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused
- adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")") <*>
- subpcs <*>
- elseClauses
- pure . fmap mconcat . sequence $ [fs, condNode, rest]
- _ -> go (x:acc) xs
+ go acc (x : xs) = case x of
+ (ParseUtils.F l "import" importLoc) ->
+ if importLoc `elem` seenImports
+ then pure . parseFail $ ParseUtils.FromString ("cyclical import of " ++ importLoc) (Just l)
+ else do
+ let fs = fmap (\z -> CondNode z [importLoc] mempty) $ fieldsToConfig (reverse acc)
+ res <- parseProjectSkeleton cacheDir httpTransport verbosity (importLoc : seenImports) importLoc =<< fetchImportConfig importLoc
+ rest <- go [] xs
+ pure . fmap mconcat . sequence $ [fs, res, rest]
+ (ParseUtils.Section l "if" p xs') -> do
+ subpcs <- go [] xs'
+ let fs = fmap singletonProjectConfigSkeleton $ fieldsToConfig (reverse acc)
+ (elseClauses, rest) <- parseElseClauses xs
+ let condNode =
+ (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
+ <$>
+ -- we rewrap as as a section so the readFields lexer of the conditional parser doesn't get confused
+ adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "if(" <> p <> ")")
+ <*> subpcs
+ <*> elseClauses
+ pure . fmap mconcat . sequence $ [fs, condNode, rest]
+ _ -> go (x : acc) xs
go acc [] = pure . fmap singletonProjectConfigSkeleton . fieldsToConfig $ reverse acc
parseElseClauses :: [ParseUtils.Field] -> IO (ParseResult (Maybe ProjectConfigSkeleton), ParseResult ProjectConfigSkeleton)
parseElseClauses x = case x of
- (ParseUtils.Section _l "else" _p xs':xs) -> do
- subpcs <- go [] xs'
- rest <- go [] xs
- pure (Just <$> subpcs, rest)
- (ParseUtils.Section l "elif" p xs':xs) -> do
- subpcs <- go [] xs'
- (elseClauses, rest) <- parseElseClauses xs
- let condNode = (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e]) <$>
- adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else("<> p <> ")") <*>
- subpcs <*>
- elseClauses
- pure (Just <$> condNode, rest)
- _ -> (\r -> (pure Nothing,r)) <$> go [] x
+ (ParseUtils.Section _l "else" _p xs' : xs) -> do
+ subpcs <- go [] xs'
+ rest <- go [] xs
+ pure (Just <$> subpcs, rest)
+ (ParseUtils.Section l "elif" p xs' : xs) -> do
+ subpcs <- go [] xs'
+ (elseClauses, rest) <- parseElseClauses xs
+ let condNode =
+ (\c pcs e -> CondNode mempty mempty [CondBranch c pcs e])
+ <$> adaptParseError l (parseConditionConfVarFromClause . BS.pack $ "else(" <> p <> ")")
+ <*> subpcs
+ <*> elseClauses
+ pure (Just <$> condNode, rest)
+ _ -> (\r -> (pure Nothing, r)) <$> go [] x
fieldsToConfig xs = fmap (addProvenance . convertLegacyProjectConfig) $ parseLegacyProjectConfigFields source xs
- addProvenance x = x {projectConfigProvenance = Set.singleton (Explicit source)}
+ addProvenance x = x{projectConfigProvenance = Set.singleton (Explicit source)}
adaptParseError _ (Right x) = pure x
adaptParseError l (Left e) = parseFail $ ParseUtils.FromString (show e) (Just l)
liftPR :: (a -> IO (ParseResult b)) -> ParseResult a -> IO (ParseResult b)
liftPR f (ParseOk ws x) = addWarnings <$> f x
- where addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x'
- addWarnings x' = x'
+ where
+ addWarnings (ParseOk ws' x') = ParseOk (ws' ++ ws) x'
+ addWarnings x' = x'
liftPR _ (ParseFailed e) = pure $ ParseFailed e
fetchImportConfig :: ProjectConfigImport -> IO BS.ByteString
fetchImportConfig pci = case parseURI pci of
- Just uri -> do
- let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
- createDirectoryIfMissing True cacheDir
- _ <- downloadURI httpTransport verbosity uri fp
- BS.readFile fp
- Nothing -> BS.readFile $
- if isAbsolute pci then pci else takeDirectory source </> pci
+ Just uri -> do
+ let fp = cacheDir </> map (\x -> if isPathSeparator x then '_' else x) (makeValid $ show uri)
+ createDirectoryIfMissing True cacheDir
+ _ <- downloadURI httpTransport verbosity uri fp
+ BS.readFile fp
+ Nothing ->
+ BS.readFile $
+ if isAbsolute pci then pci else takeDirectory source </> pci
modifiesCompiler :: ProjectConfig -> Bool
modifiesCompiler pc = isSet projectConfigHcFlavor || isSet projectConfigHcPath || isSet projectConfigHcPkg
where
- isSet f = f (projectConfigShared pc) /= NoFlag
+ isSet f = f (projectConfigShared pc) /= NoFlag
sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectConfigSkeleton
sanityWalkPCS underConditional t@(CondNode d _c comps)
- | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing
- | otherwise = mapM_ sanityWalkBranch comps >> pure t
+ | underConditional && modifiesCompiler d = parseFail $ ParseUtils.FromString "Cannot set compiler in a conditional clause of a cabal project file" Nothing
+ | otherwise = mapM_ sanityWalkBranch comps >> pure t
- sanityWalkBranch:: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult ()
+ sanityWalkBranch :: CondBranch ConfVar [ProjectConfigImport] ProjectConfig -> ParseResult ()
sanityWalkBranch (CondBranch _c t f) = traverse (sanityWalkPCS True) f >> sanityWalkPCS True t >> pure ()
------------------------------------------------------------------
@@ -252,58 +319,58 @@ parseProjectSkeleton cacheDir httpTransport verbosity seenImports source bs = (s
--
-- Ultimately if\/when this project-based approach becomes the default then we
-- can redefine the parsers directly for the new types.
---
-data LegacyProjectConfig = LegacyProjectConfig {
- legacyPackages :: [String],
- legacyPackagesOptional :: [String],
- legacyPackagesRepo :: [SourceRepoList],
- legacyPackagesNamed :: [PackageVersionConstraint],
-
- legacySharedConfig :: LegacySharedConfig,
- legacyAllConfig :: LegacyPackageConfig,
- legacyLocalConfig :: LegacyPackageConfig,
- legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig
- } deriving (Show, Generic)
+data LegacyProjectConfig = LegacyProjectConfig
+ { legacyPackages :: [String]
+ , legacyPackagesOptional :: [String]
+ , legacyPackagesRepo :: [SourceRepoList]
+ , legacyPackagesNamed :: [PackageVersionConstraint]
+ , legacySharedConfig :: LegacySharedConfig
+ , legacyAllConfig :: LegacyPackageConfig
+ , legacyLocalConfig :: LegacyPackageConfig
+ , legacySpecificConfig :: MapMappend PackageName LegacyPackageConfig
+ }
+ deriving (Show, Generic)
instance Monoid LegacyProjectConfig where
- mempty = gmempty
+ mempty = gmempty
mappend = (<>)
instance Semigroup LegacyProjectConfig where
(<>) = gmappend
-data LegacyPackageConfig = LegacyPackageConfig {
- legacyConfigureFlags :: ConfigFlags,
- legacyInstallPkgFlags :: InstallFlags,
- legacyHaddockFlags :: HaddockFlags,
- legacyTestFlags :: TestFlags,
- legacyBenchmarkFlags :: BenchmarkFlags
- } deriving (Show, Generic)
+data LegacyPackageConfig = LegacyPackageConfig
+ { legacyConfigureFlags :: ConfigFlags
+ , legacyInstallPkgFlags :: InstallFlags
+ , legacyHaddockFlags :: HaddockFlags
+ , legacyTestFlags :: TestFlags
+ , legacyBenchmarkFlags :: BenchmarkFlags
+ }
+ deriving (Show, Generic)
instance Monoid LegacyPackageConfig where
- mempty = gmempty
+ mempty = gmempty
mappend = (<>)
instance Semigroup LegacyPackageConfig where
(<>) = gmappend
-data LegacySharedConfig = LegacySharedConfig {
- legacyGlobalFlags :: GlobalFlags,
- legacyConfigureShFlags :: ConfigFlags,
- legacyConfigureExFlags :: ConfigExFlags,
- legacyInstallFlags :: InstallFlags,
- legacyClientInstallFlags:: ClientInstallFlags,
- legacyProjectFlags :: ProjectFlags
- } deriving (Show, Generic)
+data LegacySharedConfig = LegacySharedConfig
+ { legacyGlobalFlags :: GlobalFlags
+ , legacyConfigureShFlags :: ConfigFlags
+ , legacyConfigureExFlags :: ConfigExFlags
+ , legacyInstallFlags :: InstallFlags
+ , legacyClientInstallFlags :: ClientInstallFlags
+ , legacyProjectFlags :: ProjectFlags
+ }
+ deriving (Show, Generic)
instance Monoid LegacySharedConfig where
- mempty = gmempty
+ mempty = gmempty
mappend = (<>)
instance Semigroup LegacySharedConfig where
(<>) = gmappend
-
------------------------------------------------------------------
-- Converting from and to the legacy types
--
@@ -314,57 +381,74 @@ instance Semigroup LegacySharedConfig where
--
-- At the moment this uses the legacy command line flag types. See
-- 'LegacyProjectConfig' for an explanation.
---
-commandLineFlagsToProjectConfig :: GlobalFlags
- -> NixStyleFlags a
- -> ClientInstallFlags
- -> ProjectConfig
-commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlags =
- mempty {
- projectConfigBuildOnly = convertLegacyBuildOnlyFlags
- globalFlags configFlags
- installFlags clientInstallFlags
- haddockFlags testFlags benchmarkFlags,
- projectConfigShared = convertLegacyAllPackageFlags
- globalFlags configFlags
- configExFlags installFlags projectFlags,
- projectConfigLocalPackages = localConfig,
- projectConfigAllPackages = allConfig
+commandLineFlagsToProjectConfig
+ :: GlobalFlags
+ -> NixStyleFlags a
+ -> ClientInstallFlags
+ -> ProjectConfig
+commandLineFlagsToProjectConfig globalFlags NixStyleFlags{..} clientInstallFlags =
+ mempty
+ { projectConfigBuildOnly =
+ convertLegacyBuildOnlyFlags
+ globalFlags
+ configFlags
+ installFlags
+ clientInstallFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags
+ , projectConfigShared =
+ convertLegacyAllPackageFlags
+ globalFlags
+ configFlags
+ configExFlags
+ installFlags
+ projectFlags
+ , projectConfigLocalPackages = localConfig
+ , projectConfigAllPackages = allConfig
}
- where (localConfig, allConfig) = splitConfig
- (convertLegacyPerPackageFlags
- configFlags installFlags
- haddockFlags testFlags benchmarkFlags)
- -- split the package config (from command line arguments) into
- -- those applied to all packages and those to local only.
- --
- -- for now we will just copy over the ProgramPaths/Extra into
- -- the AllPackages. The LocalPackages do not inherit them from
- -- AllPackages, and as such need to retain them.
- --
- -- The general decision rule for what to put into allConfig
- -- into localConfig is the following:
- --
- -- - anything that is host/toolchain/env specific should be applied
- -- to all packages, as packagesets have to be host/toolchain/env
- -- consistent.
- -- - anything else should be in the local config and could potentially
- -- be lifted into all-packages vial the `package *` cabal.project
- -- section.
- --
- splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)
- splitConfig pc = (pc
- , mempty { packageConfigProgramPaths = packageConfigProgramPaths pc
- , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc
-
- -- Some flags to haddock should be passed to dependencies
- , packageConfigDocumentation = packageConfigDocumentation pc
- , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc
- , packageConfigHaddockHtml = packageConfigHaddockHtml pc
- , packageConfigHaddockInternal = packageConfigHaddockInternal pc
- , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc
- , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc
- })
+ where
+ (localConfig, allConfig) =
+ splitConfig
+ ( convertLegacyPerPackageFlags
+ configFlags
+ installFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags
+ )
+ -- split the package config (from command line arguments) into
+ -- those applied to all packages and those to local only.
+ --
+ -- for now we will just copy over the ProgramPaths/Extra into
+ -- the AllPackages. The LocalPackages do not inherit them from
+ -- AllPackages, and as such need to retain them.
+ --
+ -- The general decision rule for what to put into allConfig
+ -- into localConfig is the following:
+ --
+ -- - anything that is host/toolchain/env specific should be applied
+ -- to all packages, as packagesets have to be host/toolchain/env
+ -- consistent.
+ -- - anything else should be in the local config and could potentially
+ -- be lifted into all-packages vial the `package *` cabal.project
+ -- section.
+ --
+ splitConfig :: PackageConfig -> (PackageConfig, PackageConfig)
+ splitConfig pc =
+ ( pc
+ , mempty
+ { packageConfigProgramPaths = packageConfigProgramPaths pc
+ , packageConfigProgramPathExtra = packageConfigProgramPathExtra pc
+ , -- Some flags to haddock should be passed to dependencies
+ packageConfigDocumentation = packageConfigDocumentation pc
+ , packageConfigHaddockHoogle = packageConfigHaddockHoogle pc
+ , packageConfigHaddockHtml = packageConfigHaddockHtml pc
+ , packageConfigHaddockInternal = packageConfigHaddockInternal pc
+ , packageConfigHaddockQuickJump = packageConfigHaddockQuickJump pc
+ , packageConfigHaddockLinkedSource = packageConfigHaddockLinkedSource pc
+ }
+ )
-- | Convert from the types currently used for the user-wide Cabal config
-- file into the 'ProjectConfig' type.
@@ -373,640 +457,705 @@ commandLineFlagsToProjectConfig globalFlags NixStyleFlags {..} clientInstallFlag
-- config. In particular it does not include packages that are in the project,
-- and it also doesn't support package-specific configuration (only
-- configuration that applies to all packages).
---
convertLegacyGlobalConfig :: SavedConfig -> ProjectConfig
convertLegacyGlobalConfig
- SavedConfig {
- savedGlobalFlags = globalFlags,
- savedInstallFlags = installFlags,
- savedClientInstallFlags= clientInstallFlags,
- savedConfigureFlags = configFlags,
- savedConfigureExFlags = configExFlags,
- savedUserInstallDirs = _,
- savedGlobalInstallDirs = _,
- savedUploadFlags = _,
- savedReportFlags = _,
- savedHaddockFlags = haddockFlags,
- savedTestFlags = testFlags,
- savedBenchmarkFlags = benchmarkFlags,
- savedProjectFlags = projectFlags
+ SavedConfig
+ { savedGlobalFlags = globalFlags
+ , savedInstallFlags = installFlags
+ , savedClientInstallFlags = clientInstallFlags
+ , savedConfigureFlags = configFlags
+ , savedConfigureExFlags = configExFlags
+ , savedUserInstallDirs = _
+ , savedGlobalInstallDirs = _
+ , savedUploadFlags = _
+ , savedReportFlags = _
+ , savedHaddockFlags = haddockFlags
+ , savedTestFlags = testFlags
+ , savedBenchmarkFlags = benchmarkFlags
+ , savedProjectFlags = projectFlags
} =
- mempty {
- projectConfigBuildOnly = configBuildOnly,
- projectConfigShared = configShared,
- projectConfigAllPackages = configAllPackages
- }
- where
- --TODO: [code cleanup] eliminate use of default*Flags here and specify the
- -- defaults in the various resolve functions in terms of the new types.
- configExFlags' = defaultConfigExFlags <> configExFlags
- installFlags' = defaultInstallFlags <> installFlags
- clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags
- haddockFlags' = defaultHaddockFlags <> haddockFlags
- testFlags' = defaultTestFlags <> testFlags
- benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags
- projectFlags' = defaultProjectFlags <> projectFlags
-
- configAllPackages = convertLegacyPerPackageFlags
- configFlags installFlags'
- haddockFlags' testFlags' benchmarkFlags'
- configShared = convertLegacyAllPackageFlags
- globalFlags configFlags
- configExFlags' installFlags' projectFlags'
- configBuildOnly = convertLegacyBuildOnlyFlags
- globalFlags configFlags
- installFlags' clientInstallFlags'
- haddockFlags' testFlags' benchmarkFlags'
-
+ mempty
+ { projectConfigBuildOnly = configBuildOnly
+ , projectConfigShared = configShared
+ , projectConfigAllPackages = configAllPackages
+ }
+ where
+ -- TODO: [code cleanup] eliminate use of default*Flags here and specify the
+ -- defaults in the various resolve functions in terms of the new types.
+ configExFlags' = defaultConfigExFlags <> configExFlags
+ installFlags' = defaultInstallFlags <> installFlags
+ clientInstallFlags' = defaultClientInstallFlags <> clientInstallFlags
+ haddockFlags' = defaultHaddockFlags <> haddockFlags
+ testFlags' = defaultTestFlags <> testFlags
+ benchmarkFlags' = defaultBenchmarkFlags <> benchmarkFlags
+ projectFlags' = defaultProjectFlags <> projectFlags
+
+ configAllPackages =
+ convertLegacyPerPackageFlags
+ configFlags
+ installFlags'
+ haddockFlags'
+ testFlags'
+ benchmarkFlags'
+ configShared =
+ convertLegacyAllPackageFlags
+ globalFlags
+ configFlags
+ configExFlags'
+ installFlags'
+ projectFlags'
+ configBuildOnly =
+ convertLegacyBuildOnlyFlags
+ globalFlags
+ configFlags
+ installFlags'
+ clientInstallFlags'
+ haddockFlags'
+ testFlags'
+ benchmarkFlags'
-- | Convert the project config from the legacy types to the 'ProjectConfig'
-- and associated types. See 'LegacyProjectConfig' for an explanation of the
-- approach.
---
convertLegacyProjectConfig :: LegacyProjectConfig -> ProjectConfig
convertLegacyProjectConfig
- LegacyProjectConfig {
- legacyPackages,
- legacyPackagesOptional,
- legacyPackagesRepo,
- legacyPackagesNamed,
- legacySharedConfig = LegacySharedConfig globalFlags configShFlags
- configExFlags installSharedFlags
- clientInstallFlags projectFlags,
- legacyAllConfig,
- legacyLocalConfig = LegacyPackageConfig configFlags installPerPkgFlags
- haddockFlags testFlags benchmarkFlags,
- legacySpecificConfig
- } =
-
- ProjectConfig {
- projectPackages = legacyPackages,
- projectPackagesOptional = legacyPackagesOptional,
- projectPackagesRepo = legacyPackagesRepo,
- projectPackagesNamed = legacyPackagesNamed,
-
- projectConfigBuildOnly = configBuildOnly,
- projectConfigShared = configPackagesShared,
- projectConfigProvenance = mempty,
- projectConfigAllPackages = configAllPackages,
- projectConfigLocalPackages = configLocalPackages,
- projectConfigSpecificPackage = fmap perPackage legacySpecificConfig
- }
- where
- configAllPackages = convertLegacyPerPackageFlags g i h t b
- where LegacyPackageConfig g i h t b = legacyAllConfig
- configLocalPackages = convertLegacyPerPackageFlags
- configFlags installPerPkgFlags haddockFlags
- testFlags benchmarkFlags
- configPackagesShared= convertLegacyAllPackageFlags
- globalFlags (configFlags <> configShFlags)
- configExFlags installSharedFlags projectFlags
- configBuildOnly = convertLegacyBuildOnlyFlags
- globalFlags configShFlags
- installSharedFlags clientInstallFlags
- haddockFlags testFlags benchmarkFlags
-
- perPackage (LegacyPackageConfig perPkgConfigFlags perPkgInstallFlags
- perPkgHaddockFlags perPkgTestFlags
- perPkgBenchmarkFlags) =
- convertLegacyPerPackageFlags
- perPkgConfigFlags perPkgInstallFlags perPkgHaddockFlags
- perPkgTestFlags perPkgBenchmarkFlags
-
+ LegacyProjectConfig
+ { legacyPackages
+ , legacyPackagesOptional
+ , legacyPackagesRepo
+ , legacyPackagesNamed
+ , legacySharedConfig =
+ LegacySharedConfig
+ globalFlags
+ configShFlags
+ configExFlags
+ installSharedFlags
+ clientInstallFlags
+ projectFlags
+ , legacyAllConfig
+ , legacyLocalConfig =
+ LegacyPackageConfig
+ configFlags
+ installPerPkgFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags
+ , legacySpecificConfig
+ } =
+ ProjectConfig
+ { projectPackages = legacyPackages
+ , projectPackagesOptional = legacyPackagesOptional
+ , projectPackagesRepo = legacyPackagesRepo
+ , projectPackagesNamed = legacyPackagesNamed
+ , projectConfigBuildOnly = configBuildOnly
+ , projectConfigShared = configPackagesShared
+ , projectConfigProvenance = mempty
+ , projectConfigAllPackages = configAllPackages
+ , projectConfigLocalPackages = configLocalPackages
+ , projectConfigSpecificPackage = fmap perPackage legacySpecificConfig
+ }
+ where
+ configAllPackages = convertLegacyPerPackageFlags g i h t b
+ where
+ LegacyPackageConfig g i h t b = legacyAllConfig
+ configLocalPackages =
+ convertLegacyPerPackageFlags
+ configFlags
+ installPerPkgFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags
+ configPackagesShared =
+ convertLegacyAllPackageFlags
+ globalFlags
+ (configFlags <> configShFlags)
+ configExFlags
+ installSharedFlags
+ projectFlags
+ configBuildOnly =
+ convertLegacyBuildOnlyFlags
+ globalFlags
+ configShFlags
+ installSharedFlags
+ clientInstallFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags
+
+ perPackage
+ ( LegacyPackageConfig
+ perPkgConfigFlags
+ perPkgInstallFlags
+ perPkgHaddockFlags
+ perPkgTestFlags
+ perPkgBenchmarkFlags
+ ) =
+ convertLegacyPerPackageFlags
+ perPkgConfigFlags
+ perPkgInstallFlags
+ perPkgHaddockFlags
+ perPkgTestFlags
+ perPkgBenchmarkFlags
-- | Helper used by other conversion functions that returns the
-- 'ProjectConfigShared' subset of the 'ProjectConfig'.
---
convertLegacyAllPackageFlags
- :: GlobalFlags
- -> ConfigFlags
- -> ConfigExFlags
- -> InstallFlags
- -> ProjectFlags
- -> ProjectConfigShared
+ :: GlobalFlags
+ -> ConfigFlags
+ -> ConfigExFlags
+ -> InstallFlags
+ -> ProjectFlags
+ -> ProjectConfigShared
convertLegacyAllPackageFlags globalFlags configFlags configExFlags installFlags projectFlags =
- ProjectConfigShared{..}
+ ProjectConfigShared{..}
where
- GlobalFlags {
- globalConfigFile = projectConfigConfigFile,
- globalRemoteRepos = projectConfigRemoteRepos,
- globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
- globalActiveRepos = projectConfigActiveRepos,
- globalProgPathExtra = projectConfigProgPathExtra,
- globalStoreDir = projectConfigStoreDir
- } = globalFlags
-
- ConfigFlags {
- configDistPref = projectConfigDistDir,
- configHcFlavor = projectConfigHcFlavor,
- configHcPath = projectConfigHcPath,
- configHcPkg = projectConfigHcPkg,
- --configProgramPathExtra = projectConfigProgPathExtra DELETE ME
- configInstallDirs = projectConfigInstallDirs,
- --configUserInstall = projectConfigUserInstall,
- configPackageDBs = projectConfigPackageDBs
- } = configFlags
-
- ConfigExFlags {
- configCabalVersion = projectConfigCabalVersion,
- configExConstraints = projectConfigConstraints,
- configPreferences = projectConfigPreferences,
- configSolver = projectConfigSolver,
- configAllowOlder = projectConfigAllowOlder,
- configAllowNewer = projectConfigAllowNewer,
- configWriteGhcEnvironmentFilesPolicy
- = projectConfigWriteGhcEnvironmentFilesPolicy
- } = configExFlags
-
- InstallFlags {
- installHaddockIndex = projectConfigHaddockIndex,
- --installReinstall = projectConfigReinstall,
- --installAvoidReinstalls = projectConfigAvoidReinstalls,
- --installOverrideReinstall = projectConfigOverrideReinstall,
- installIndexState = projectConfigIndexState,
- installMaxBackjumps = projectConfigMaxBackjumps,
- --installUpgradeDeps = projectConfigUpgradeDeps,
- installReorderGoals = projectConfigReorderGoals,
- installCountConflicts = projectConfigCountConflicts,
- installFineGrainedConflicts = projectConfigFineGrainedConflicts,
- installMinimizeConflictSet = projectConfigMinimizeConflictSet,
- installPerComponent = projectConfigPerComponent,
- installIndependentGoals = projectConfigIndependentGoals,
- installPreferOldest = projectConfigPreferOldest,
- --installShadowPkgs = projectConfigShadowPkgs,
- installStrongFlags = projectConfigStrongFlags,
- installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,
- installOnlyConstrained = projectConfigOnlyConstrained
- } = installFlags
+ GlobalFlags
+ { globalConfigFile = projectConfigConfigFile
+ , globalRemoteRepos = projectConfigRemoteRepos
+ , globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos
+ , globalActiveRepos = projectConfigActiveRepos
+ , globalProgPathExtra = projectConfigProgPathExtra
+ , globalStoreDir = projectConfigStoreDir
+ } = globalFlags
+
+ ConfigFlags
+ { configDistPref = projectConfigDistDir
+ , configHcFlavor = projectConfigHcFlavor
+ , configHcPath = projectConfigHcPath
+ , configHcPkg = projectConfigHcPkg
+ , -- configProgramPathExtra = projectConfigProgPathExtra DELETE ME
+ configInstallDirs = projectConfigInstallDirs
+ , -- configUserInstall = projectConfigUserInstall,
+ configPackageDBs = projectConfigPackageDBs
+ } = configFlags
+
+ ConfigExFlags
+ { configCabalVersion = projectConfigCabalVersion
+ , configExConstraints = projectConfigConstraints
+ , configPreferences = projectConfigPreferences
+ , configSolver = projectConfigSolver
+ , configAllowOlder = projectConfigAllowOlder
+ , configAllowNewer = projectConfigAllowNewer
+ , configWriteGhcEnvironmentFilesPolicy =
+ projectConfigWriteGhcEnvironmentFilesPolicy
+ } = configExFlags
+
+ InstallFlags
+ { installHaddockIndex = projectConfigHaddockIndex
+ , -- installReinstall = projectConfigReinstall,
+ -- installAvoidReinstalls = projectConfigAvoidReinstalls,
+ -- installOverrideReinstall = projectConfigOverrideReinstall,
+ installIndexState = projectConfigIndexState
+ , installMaxBackjumps = projectConfigMaxBackjumps
+ , -- installUpgradeDeps = projectConfigUpgradeDeps,
+ installReorderGoals = projectConfigReorderGoals
+ , installCountConflicts = projectConfigCountConflicts
+ , installFineGrainedConflicts = projectConfigFineGrainedConflicts
+ , installMinimizeConflictSet = projectConfigMinimizeConflictSet
+ , installPerComponent = projectConfigPerComponent
+ , installIndependentGoals = projectConfigIndependentGoals
+ , installPreferOldest = projectConfigPreferOldest
+ , -- installShadowPkgs = projectConfigShadowPkgs,
+ installStrongFlags = projectConfigStrongFlags
+ , installAllowBootLibInstalls = projectConfigAllowBootLibInstalls
+ , installOnlyConstrained = projectConfigOnlyConstrained
+ } = installFlags
ProjectFlags
- { flagProjectDir = projectConfigProjectDir
- , flagProjectFile = projectConfigProjectFile
- , flagIgnoreProject = projectConfigIgnoreProject
- } = projectFlags
+ { flagProjectDir = projectConfigProjectDir
+ , flagProjectFile = projectConfigProjectFile
+ , flagIgnoreProject = projectConfigIgnoreProject
+ } = projectFlags
-- | Helper used by other conversion functions that returns the
-- 'PackageConfig' subset of the 'ProjectConfig'.
---
-convertLegacyPerPackageFlags :: ConfigFlags -> InstallFlags -> HaddockFlags
- -> TestFlags -> BenchmarkFlags -> PackageConfig
-convertLegacyPerPackageFlags configFlags installFlags
- haddockFlags testFlags benchmarkFlags =
+convertLegacyPerPackageFlags
+ :: ConfigFlags
+ -> InstallFlags
+ -> HaddockFlags
+ -> TestFlags
+ -> BenchmarkFlags
+ -> PackageConfig
+convertLegacyPerPackageFlags
+ configFlags
+ installFlags
+ haddockFlags
+ testFlags
+ benchmarkFlags =
PackageConfig{..}
- where
- ConfigFlags {
- configProgramPaths,
- configProgramArgs,
- configProgramPathExtra = packageConfigProgramPathExtra,
- configVanillaLib = packageConfigVanillaLib,
- configProfLib = packageConfigProfLib,
- configSharedLib = packageConfigSharedLib,
- configStaticLib = packageConfigStaticLib,
- configDynExe = packageConfigDynExe,
- configFullyStaticExe = packageConfigFullyStaticExe,
- configProfExe = packageConfigProfExe,
- configProf = packageConfigProf,
- configProfDetail = packageConfigProfDetail,
- configProfLibDetail = packageConfigProfLibDetail,
- configConfigureArgs = packageConfigConfigureArgs,
- configOptimization = packageConfigOptimization,
- configProgPrefix = packageConfigProgPrefix,
- configProgSuffix = packageConfigProgSuffix,
- configGHCiLib = packageConfigGHCiLib,
- configSplitSections = packageConfigSplitSections,
- configSplitObjs = packageConfigSplitObjs,
- configStripExes = packageConfigStripExes,
- configStripLibs = packageConfigStripLibs,
- configExtraLibDirs = packageConfigExtraLibDirs,
- configExtraLibDirsStatic = packageConfigExtraLibDirsStatic,
- configExtraFrameworkDirs = packageConfigExtraFrameworkDirs,
- configExtraIncludeDirs = packageConfigExtraIncludeDirs,
- configConfigurationsFlags = packageConfigFlagAssignment,
- configTests = packageConfigTests,
- configBenchmarks = packageConfigBenchmarks,
- configCoverage = coverage,
- configLibCoverage = libcoverage, --deprecated
- configDebugInfo = packageConfigDebugInfo,
- configDumpBuildInfo = packageConfigDumpBuildInfo,
- configRelocatable = packageConfigRelocatable
- } = configFlags
- packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths)
- packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs)
-
- packageConfigCoverage = coverage <> libcoverage
- --TODO: defer this merging to the resolve phase
-
- InstallFlags {
- installDocumentation = packageConfigDocumentation,
- installRunTests = packageConfigRunTests
- } = installFlags
-
- HaddockFlags {
- haddockHoogle = packageConfigHaddockHoogle,
- haddockHtml = packageConfigHaddockHtml,
- haddockHtmlLocation = packageConfigHaddockHtmlLocation,
- haddockForeignLibs = packageConfigHaddockForeignLibs,
- haddockForHackage = packageConfigHaddockForHackage,
- haddockExecutables = packageConfigHaddockExecutables,
- haddockTestSuites = packageConfigHaddockTestSuites,
- haddockBenchmarks = packageConfigHaddockBenchmarks,
- haddockInternal = packageConfigHaddockInternal,
- haddockCss = packageConfigHaddockCss,
- haddockLinkedSource = packageConfigHaddockLinkedSource,
- haddockQuickJump = packageConfigHaddockQuickJump,
- haddockHscolourCss = packageConfigHaddockHscolourCss,
- haddockContents = packageConfigHaddockContents,
- haddockIndex = packageConfigHaddockIndex,
- haddockBaseUrl = packageConfigHaddockBaseUrl,
- haddockLib = packageConfigHaddockLib,
- haddockOutputDir = packageConfigHaddockOutputDir
- } = haddockFlags
-
- TestFlags {
- testHumanLog = packageConfigTestHumanLog,
- testMachineLog = packageConfigTestMachineLog,
- testShowDetails = packageConfigTestShowDetails,
- testKeepTix = packageConfigTestKeepTix,
- testWrapper = packageConfigTestWrapper,
- testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,
- testOptions = packageConfigTestTestOptions
- } = testFlags
-
- BenchmarkFlags {
- benchmarkOptions = packageConfigBenchmarkOptions
- } = benchmarkFlags
-
+ where
+ ConfigFlags
+ { configProgramPaths
+ , configProgramArgs
+ , configProgramPathExtra = packageConfigProgramPathExtra
+ , configVanillaLib = packageConfigVanillaLib
+ , configProfLib = packageConfigProfLib
+ , configSharedLib = packageConfigSharedLib
+ , configStaticLib = packageConfigStaticLib
+ , configDynExe = packageConfigDynExe
+ , configFullyStaticExe = packageConfigFullyStaticExe
+ , configProfExe = packageConfigProfExe
+ , configProf = packageConfigProf
+ , configProfDetail = packageConfigProfDetail
+ , configProfLibDetail = packageConfigProfLibDetail
+ , configConfigureArgs = packageConfigConfigureArgs
+ , configOptimization = packageConfigOptimization
+ , configProgPrefix = packageConfigProgPrefix
+ , configProgSuffix = packageConfigProgSuffix
+ , configGHCiLib = packageConfigGHCiLib
+ , configSplitSections = packageConfigSplitSections
+ , configSplitObjs = packageConfigSplitObjs
+ , configStripExes = packageConfigStripExes
+ , configStripLibs = packageConfigStripLibs
+ , configExtraLibDirs = packageConfigExtraLibDirs
+ , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic
+ , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs
+ , configExtraIncludeDirs = packageConfigExtraIncludeDirs
+ , configConfigurationsFlags = packageConfigFlagAssignment
+ , configTests = packageConfigTests
+ , configBenchmarks = packageConfigBenchmarks
+ , configCoverage = coverage
+ , configLibCoverage = libcoverage -- deprecated
+ , configDebugInfo = packageConfigDebugInfo
+ , configDumpBuildInfo = packageConfigDumpBuildInfo
+ , configRelocatable = packageConfigRelocatable
+ } = configFlags
+ packageConfigProgramPaths = MapLast (Map.fromList configProgramPaths)
+ packageConfigProgramArgs = MapMappend (Map.fromListWith (++) configProgramArgs)
+
+ packageConfigCoverage = coverage <> libcoverage
+ -- TODO: defer this merging to the resolve phase
+
+ InstallFlags
+ { installDocumentation = packageConfigDocumentation
+ , installRunTests = packageConfigRunTests
+ } = installFlags
+
+ HaddockFlags
+ { haddockHoogle = packageConfigHaddockHoogle
+ , haddockHtml = packageConfigHaddockHtml
+ , haddockHtmlLocation = packageConfigHaddockHtmlLocation
+ , haddockForeignLibs = packageConfigHaddockForeignLibs
+ , haddockForHackage = packageConfigHaddockForHackage
+ , haddockExecutables = packageConfigHaddockExecutables
+ , haddockTestSuites = packageConfigHaddockTestSuites
+ , haddockBenchmarks = packageConfigHaddockBenchmarks
+ , haddockInternal = packageConfigHaddockInternal
+ , haddockCss = packageConfigHaddockCss
+ , haddockLinkedSource = packageConfigHaddockLinkedSource
+ , haddockQuickJump = packageConfigHaddockQuickJump
+ , haddockHscolourCss = packageConfigHaddockHscolourCss
+ , haddockContents = packageConfigHaddockContents
+ , haddockIndex = packageConfigHaddockIndex
+ , haddockBaseUrl = packageConfigHaddockBaseUrl
+ , haddockLib = packageConfigHaddockLib
+ , haddockOutputDir = packageConfigHaddockOutputDir
+ } = haddockFlags
+
+ TestFlags
+ { testHumanLog = packageConfigTestHumanLog
+ , testMachineLog = packageConfigTestMachineLog
+ , testShowDetails = packageConfigTestShowDetails
+ , testKeepTix = packageConfigTestKeepTix
+ , testWrapper = packageConfigTestWrapper
+ , testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites
+ , testOptions = packageConfigTestTestOptions
+ } = testFlags
+
+ BenchmarkFlags
+ { benchmarkOptions = packageConfigBenchmarkOptions
+ } = benchmarkFlags
-- | Helper used by other conversion functions that returns the
-- 'ProjectConfigBuildOnly' subset of the 'ProjectConfig'.
---
-convertLegacyBuildOnlyFlags :: GlobalFlags -> ConfigFlags
- -> InstallFlags -> ClientInstallFlags
- -> HaddockFlags -> TestFlags
- -> BenchmarkFlags
- -> ProjectConfigBuildOnly
-convertLegacyBuildOnlyFlags globalFlags configFlags
- installFlags clientInstallFlags
- haddockFlags _ _ =
+convertLegacyBuildOnlyFlags
+ :: GlobalFlags
+ -> ConfigFlags
+ -> InstallFlags
+ -> ClientInstallFlags
+ -> HaddockFlags
+ -> TestFlags
+ -> BenchmarkFlags
+ -> ProjectConfigBuildOnly
+convertLegacyBuildOnlyFlags
+ globalFlags
+ configFlags
+ installFlags
+ clientInstallFlags
+ haddockFlags
+ _
+ _ =
ProjectConfigBuildOnly{..}
- where
- projectConfigClientInstallFlags = clientInstallFlags
- GlobalFlags {
- globalCacheDir = projectConfigCacheDir,
- globalLogsDir = projectConfigLogsDir,
- globalHttpTransport = projectConfigHttpTransport,
- globalIgnoreExpiry = projectConfigIgnoreExpiry
- } = globalFlags
-
- ConfigFlags {
- configVerbosity = projectConfigVerbosity
- } = configFlags
-
- InstallFlags {
- installDryRun = projectConfigDryRun,
- installOnlyDownload = projectConfigOnlyDownload,
- installOnly = _,
- installOnlyDeps = projectConfigOnlyDeps,
- installRootCmd = _,
- installSummaryFile = projectConfigSummaryFile,
- installLogFile = projectConfigLogFile,
- installBuildReports = projectConfigBuildReports,
- installReportPlanningFailure = projectConfigReportPlanningFailure,
- installSymlinkBinDir = projectConfigSymlinkBinDir,
- installNumJobs = projectConfigNumJobs,
- installKeepGoing = projectConfigKeepGoing,
- installOfflineMode = projectConfigOfflineMode
- } = installFlags
-
- HaddockFlags {
- haddockKeepTempFiles = projectConfigKeepTempFiles --TODO: this ought to live elsewhere
- } = haddockFlags
-
+ where
+ projectConfigClientInstallFlags = clientInstallFlags
+ GlobalFlags
+ { globalCacheDir = projectConfigCacheDir
+ , globalLogsDir = projectConfigLogsDir
+ , globalHttpTransport = projectConfigHttpTransport
+ , globalIgnoreExpiry = projectConfigIgnoreExpiry
+ } = globalFlags
+
+ ConfigFlags
+ { configVerbosity = projectConfigVerbosity
+ } = configFlags
+
+ InstallFlags
+ { installDryRun = projectConfigDryRun
+ , installOnlyDownload = projectConfigOnlyDownload
+ , installOnly = _
+ , installOnlyDeps = projectConfigOnlyDeps
+ , installRootCmd = _
+ , installSummaryFile = projectConfigSummaryFile
+ , installLogFile = projectConfigLogFile
+ , installBuildReports = projectConfigBuildReports
+ , installReportPlanningFailure = projectConfigReportPlanningFailure
+ , installSymlinkBinDir = projectConfigSymlinkBinDir
+ , installNumJobs = projectConfigNumJobs
+ , installKeepGoing = projectConfigKeepGoing
+ , installOfflineMode = projectConfigOfflineMode
+ } = installFlags
+
+ HaddockFlags
+ { haddockKeepTempFiles = projectConfigKeepTempFiles -- TODO: this ought to live elsewhere
+ } = haddockFlags
convertToLegacyProjectConfig :: ProjectConfig -> LegacyProjectConfig
convertToLegacyProjectConfig
- projectConfig@ProjectConfig {
- projectPackages,
- projectPackagesOptional,
- projectPackagesRepo,
- projectPackagesNamed,
- projectConfigAllPackages,
- projectConfigLocalPackages,
- projectConfigSpecificPackage
+ projectConfig@ProjectConfig
+ { projectPackages
+ , projectPackagesOptional
+ , projectPackagesRepo
+ , projectPackagesNamed
+ , projectConfigAllPackages
+ , projectConfigLocalPackages
+ , projectConfigSpecificPackage
} =
- LegacyProjectConfig {
- legacyPackages = projectPackages,
- legacyPackagesOptional = projectPackagesOptional,
- legacyPackagesRepo = projectPackagesRepo,
- legacyPackagesNamed = projectPackagesNamed,
- legacySharedConfig = convertToLegacySharedConfig projectConfig,
- legacyAllConfig = convertToLegacyPerPackageConfig
- projectConfigAllPackages,
- legacyLocalConfig = convertToLegacyAllPackageConfig projectConfig
- <> convertToLegacyPerPackageConfig
- projectConfigLocalPackages,
- legacySpecificConfig = fmap convertToLegacyPerPackageConfig
- projectConfigSpecificPackage
- }
+ LegacyProjectConfig
+ { legacyPackages = projectPackages
+ , legacyPackagesOptional = projectPackagesOptional
+ , legacyPackagesRepo = projectPackagesRepo
+ , legacyPackagesNamed = projectPackagesNamed
+ , legacySharedConfig = convertToLegacySharedConfig projectConfig
+ , legacyAllConfig =
+ convertToLegacyPerPackageConfig
+ projectConfigAllPackages
+ , legacyLocalConfig =
+ convertToLegacyAllPackageConfig projectConfig
+ <> convertToLegacyPerPackageConfig
+ projectConfigLocalPackages
+ , legacySpecificConfig =
+ fmap
+ convertToLegacyPerPackageConfig
+ projectConfigSpecificPackage
+ }
convertToLegacySharedConfig :: ProjectConfig -> LegacySharedConfig
convertToLegacySharedConfig
- ProjectConfig {
- projectConfigBuildOnly = ProjectConfigBuildOnly {..},
- projectConfigShared = ProjectConfigShared {..},
- projectConfigAllPackages = PackageConfig {
- packageConfigDocumentation
- }
+ ProjectConfig
+ { projectConfigBuildOnly = ProjectConfigBuildOnly{..}
+ , projectConfigShared = ProjectConfigShared{..}
+ , projectConfigAllPackages =
+ PackageConfig
+ { packageConfigDocumentation
+ }
} =
-
LegacySharedConfig
- { legacyGlobalFlags = globalFlags
- , legacyConfigureShFlags = configFlags
- , legacyConfigureExFlags = configExFlags
- , legacyInstallFlags = installFlags
+ { legacyGlobalFlags = globalFlags
+ , legacyConfigureShFlags = configFlags
+ , legacyConfigureExFlags = configExFlags
+ , legacyInstallFlags = installFlags
, legacyClientInstallFlags = projectConfigClientInstallFlags
- , legacyProjectFlags = projectFlags
+ , legacyProjectFlags = projectFlags
}
- where
- globalFlags = GlobalFlags {
- globalVersion = mempty,
- globalNumericVersion = mempty,
- globalConfigFile = projectConfigConfigFile,
- globalConstraintsFile = mempty,
- globalRemoteRepos = projectConfigRemoteRepos,
- globalCacheDir = projectConfigCacheDir,
- globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos,
- globalActiveRepos = projectConfigActiveRepos,
- globalLogsDir = projectConfigLogsDir,
- globalIgnoreExpiry = projectConfigIgnoreExpiry,
- globalHttpTransport = projectConfigHttpTransport,
- globalNix = mempty,
- globalStoreDir = projectConfigStoreDir,
- globalProgPathExtra = projectConfigProgPathExtra
- }
-
- configFlags = mempty {
- configVerbosity = projectConfigVerbosity,
- configDistPref = projectConfigDistDir,
- configPackageDBs = projectConfigPackageDBs,
- configInstallDirs = projectConfigInstallDirs
- }
+ where
+ globalFlags =
+ GlobalFlags
+ { globalVersion = mempty
+ , globalNumericVersion = mempty
+ , globalConfigFile = projectConfigConfigFile
+ , globalConstraintsFile = mempty
+ , globalRemoteRepos = projectConfigRemoteRepos
+ , globalCacheDir = projectConfigCacheDir
+ , globalLocalNoIndexRepos = projectConfigLocalNoIndexRepos
+ , globalActiveRepos = projectConfigActiveRepos
+ , globalLogsDir = projectConfigLogsDir
+ , globalIgnoreExpiry = projectConfigIgnoreExpiry
+ , globalHttpTransport = projectConfigHttpTransport
+ , globalNix = mempty
+ , globalStoreDir = projectConfigStoreDir
+ , globalProgPathExtra = projectConfigProgPathExtra
+ }
- configExFlags = ConfigExFlags {
- configCabalVersion = projectConfigCabalVersion,
- configAppend = mempty,
- configBackup = mempty,
- configExConstraints = projectConfigConstraints,
- configPreferences = projectConfigPreferences,
- configSolver = projectConfigSolver,
- configAllowOlder = projectConfigAllowOlder,
- configAllowNewer = projectConfigAllowNewer,
- configWriteGhcEnvironmentFilesPolicy
- = projectConfigWriteGhcEnvironmentFilesPolicy
- }
+ configFlags =
+ mempty
+ { configVerbosity = projectConfigVerbosity
+ , configDistPref = projectConfigDistDir
+ , configPackageDBs = projectConfigPackageDBs
+ , configInstallDirs = projectConfigInstallDirs
+ }
- installFlags = InstallFlags {
- installDocumentation = packageConfigDocumentation,
- installHaddockIndex = projectConfigHaddockIndex,
- installDest = Flag NoCopyDest,
- installDryRun = projectConfigDryRun,
- installOnlyDownload = projectConfigOnlyDownload,
- installReinstall = mempty, --projectConfigReinstall,
- installAvoidReinstalls = mempty, --projectConfigAvoidReinstalls,
- installOverrideReinstall = mempty, --projectConfigOverrideReinstall,
- installMaxBackjumps = projectConfigMaxBackjumps,
- installUpgradeDeps = mempty, --projectConfigUpgradeDeps,
- installReorderGoals = projectConfigReorderGoals,
- installCountConflicts = projectConfigCountConflicts,
- installFineGrainedConflicts = projectConfigFineGrainedConflicts,
- installMinimizeConflictSet = projectConfigMinimizeConflictSet,
- installIndependentGoals = projectConfigIndependentGoals,
- installPreferOldest = projectConfigPreferOldest,
- installShadowPkgs = mempty, --projectConfigShadowPkgs,
- installStrongFlags = projectConfigStrongFlags,
- installAllowBootLibInstalls = projectConfigAllowBootLibInstalls,
- installOnlyConstrained = projectConfigOnlyConstrained,
- installOnly = mempty,
- installOnlyDeps = projectConfigOnlyDeps,
- installIndexState = projectConfigIndexState,
- installRootCmd = mempty, --no longer supported
- installSummaryFile = projectConfigSummaryFile,
- installLogFile = projectConfigLogFile,
- installBuildReports = projectConfigBuildReports,
- installReportPlanningFailure = projectConfigReportPlanningFailure,
- installSymlinkBinDir = projectConfigSymlinkBinDir,
- installPerComponent = projectConfigPerComponent,
- installNumJobs = projectConfigNumJobs,
- installKeepGoing = projectConfigKeepGoing,
- installRunTests = mempty,
- installOfflineMode = projectConfigOfflineMode
- }
+ configExFlags =
+ ConfigExFlags
+ { configCabalVersion = projectConfigCabalVersion
+ , configAppend = mempty
+ , configBackup = mempty
+ , configExConstraints = projectConfigConstraints
+ , configPreferences = projectConfigPreferences
+ , configSolver = projectConfigSolver
+ , configAllowOlder = projectConfigAllowOlder
+ , configAllowNewer = projectConfigAllowNewer
+ , configWriteGhcEnvironmentFilesPolicy =
+ projectConfigWriteGhcEnvironmentFilesPolicy
+ }
- projectFlags = ProjectFlags
- { flagProjectDir = projectConfigProjectDir
- , flagProjectFile = projectConfigProjectFile
- , flagIgnoreProject = projectConfigIgnoreProject
- }
+ installFlags =
+ InstallFlags
+ { installDocumentation = packageConfigDocumentation
+ , installHaddockIndex = projectConfigHaddockIndex
+ , installDest = Flag NoCopyDest
+ , installDryRun = projectConfigDryRun
+ , installOnlyDownload = projectConfigOnlyDownload
+ , installReinstall = mempty -- projectConfigReinstall,
+ , installAvoidReinstalls = mempty -- projectConfigAvoidReinstalls,
+ , installOverrideReinstall = mempty -- projectConfigOverrideReinstall,
+ , installMaxBackjumps = projectConfigMaxBackjumps
+ , installUpgradeDeps = mempty -- projectConfigUpgradeDeps,
+ , installReorderGoals = projectConfigReorderGoals
+ , installCountConflicts = projectConfigCountConflicts
+ , installFineGrainedConflicts = projectConfigFineGrainedConflicts
+ , installMinimizeConflictSet = projectConfigMinimizeConflictSet
+ , installIndependentGoals = projectConfigIndependentGoals
+ , installPreferOldest = projectConfigPreferOldest
+ , installShadowPkgs = mempty -- projectConfigShadowPkgs,
+ , installStrongFlags = projectConfigStrongFlags
+ , installAllowBootLibInstalls = projectConfigAllowBootLibInstalls
+ , installOnlyConstrained = projectConfigOnlyConstrained
+ , installOnly = mempty
+ , installOnlyDeps = projectConfigOnlyDeps
+ , installIndexState = projectConfigIndexState
+ , installRootCmd = mempty -- no longer supported
+ , installSummaryFile = projectConfigSummaryFile
+ , installLogFile = projectConfigLogFile
+ , installBuildReports = projectConfigBuildReports
+ , installReportPlanningFailure = projectConfigReportPlanningFailure
+ , installSymlinkBinDir = projectConfigSymlinkBinDir
+ , installPerComponent = projectConfigPerComponent
+ , installNumJobs = projectConfigNumJobs
+ , installKeepGoing = projectConfigKeepGoing
+ , installRunTests = mempty
+ , installOfflineMode = projectConfigOfflineMode
+ }
+ projectFlags =
+ ProjectFlags
+ { flagProjectDir = projectConfigProjectDir
+ , flagProjectFile = projectConfigProjectFile
+ , flagIgnoreProject = projectConfigIgnoreProject
+ }
convertToLegacyAllPackageConfig :: ProjectConfig -> LegacyPackageConfig
convertToLegacyAllPackageConfig
- ProjectConfig {
- projectConfigBuildOnly = ProjectConfigBuildOnly {..},
- projectConfigShared = ProjectConfigShared {..}
+ ProjectConfig
+ { projectConfigBuildOnly = ProjectConfigBuildOnly{..}
+ , projectConfigShared = ProjectConfigShared{..}
} =
+ LegacyPackageConfig
+ { legacyConfigureFlags = configFlags
+ , legacyInstallPkgFlags = mempty
+ , legacyHaddockFlags = haddockFlags
+ , legacyTestFlags = mempty
+ , legacyBenchmarkFlags = mempty
+ }
+ where
+ configFlags =
+ ConfigFlags
+ { configArgs = mempty
+ , configPrograms_ = mempty
+ , configProgramPaths = mempty
+ , configProgramArgs = mempty
+ , configProgramPathExtra = mempty
+ , configHcFlavor = projectConfigHcFlavor
+ , configHcPath = projectConfigHcPath
+ , configHcPkg = projectConfigHcPkg
+ , configInstantiateWith = mempty
+ , configVanillaLib = mempty
+ , configProfLib = mempty
+ , configSharedLib = mempty
+ , configStaticLib = mempty
+ , configDynExe = mempty
+ , configFullyStaticExe = mempty
+ , configProfExe = mempty
+ , configProf = mempty
+ , configProfDetail = mempty
+ , configProfLibDetail = mempty
+ , configConfigureArgs = mempty
+ , configOptimization = mempty
+ , configProgPrefix = mempty
+ , configProgSuffix = mempty
+ , configInstallDirs = projectConfigInstallDirs
+ , configScratchDir = mempty
+ , configDistPref = mempty
+ , configCabalFilePath = mempty
+ , configVerbosity = mempty
+ , configUserInstall = mempty -- projectConfigUserInstall,
+ , configPackageDBs = mempty
+ , configGHCiLib = mempty
+ , configSplitSections = mempty
+ , configSplitObjs = mempty
+ , configStripExes = mempty
+ , configStripLibs = mempty
+ , configExtraLibDirs = mempty
+ , configExtraLibDirsStatic = mempty
+ , configExtraFrameworkDirs = mempty
+ , configConstraints = mempty
+ , configDependencies = mempty
+ , configExtraIncludeDirs = mempty
+ , configDeterministic = mempty
+ , configIPID = mempty
+ , configCID = mempty
+ , configConfigurationsFlags = mempty
+ , configTests = mempty
+ , configCoverage = mempty -- TODO: don't merge
+ , configLibCoverage = mempty -- TODO: don't merge
+ , configExactConfiguration = mempty
+ , configBenchmarks = mempty
+ , configFlagError = mempty -- TODO: ???
+ , configRelocatable = mempty
+ , configDebugInfo = mempty
+ , configUseResponseFiles = mempty
+ , configDumpBuildInfo = mempty
+ , configAllowDependingOnPrivateLibs = mempty
+ }
- LegacyPackageConfig {
- legacyConfigureFlags = configFlags,
- legacyInstallPkgFlags= mempty,
- legacyHaddockFlags = haddockFlags,
- legacyTestFlags = mempty,
- legacyBenchmarkFlags = mempty
- }
- where
- configFlags = ConfigFlags {
- configArgs = mempty,
- configPrograms_ = mempty,
- configProgramPaths = mempty,
- configProgramArgs = mempty,
- configProgramPathExtra = mempty,
- configHcFlavor = projectConfigHcFlavor,
- configHcPath = projectConfigHcPath,
- configHcPkg = projectConfigHcPkg,
- configInstantiateWith = mempty,
- configVanillaLib = mempty,
- configProfLib = mempty,
- configSharedLib = mempty,
- configStaticLib = mempty,
- configDynExe = mempty,
- configFullyStaticExe = mempty,
- configProfExe = mempty,
- configProf = mempty,
- configProfDetail = mempty,
- configProfLibDetail = mempty,
- configConfigureArgs = mempty,
- configOptimization = mempty,
- configProgPrefix = mempty,
- configProgSuffix = mempty,
- configInstallDirs = projectConfigInstallDirs,
- configScratchDir = mempty,
- configDistPref = mempty,
- configCabalFilePath = mempty,
- configVerbosity = mempty,
- configUserInstall = mempty, --projectConfigUserInstall,
- configPackageDBs = mempty,
- configGHCiLib = mempty,
- configSplitSections = mempty,
- configSplitObjs = mempty,
- configStripExes = mempty,
- configStripLibs = mempty,
- configExtraLibDirs = mempty,
- configExtraLibDirsStatic = mempty,
- configExtraFrameworkDirs = mempty,
- configConstraints = mempty,
- configDependencies = mempty,
- configExtraIncludeDirs = mempty,
- configDeterministic = mempty,
- configIPID = mempty,
- configCID = mempty,
- configConfigurationsFlags = mempty,
- configTests = mempty,
- configCoverage = mempty, --TODO: don't merge
- configLibCoverage = mempty, --TODO: don't merge
- configExactConfiguration = mempty,
- configBenchmarks = mempty,
- configFlagError = mempty, --TODO: ???
- configRelocatable = mempty,
- configDebugInfo = mempty,
- configUseResponseFiles = mempty,
- configDumpBuildInfo = mempty,
- configAllowDependingOnPrivateLibs = mempty
- }
-
- haddockFlags = mempty {
- haddockKeepTempFiles = projectConfigKeepTempFiles
- }
-
+ haddockFlags =
+ mempty
+ { haddockKeepTempFiles = projectConfigKeepTempFiles
+ }
convertToLegacyPerPackageConfig :: PackageConfig -> LegacyPackageConfig
-convertToLegacyPerPackageConfig PackageConfig {..} =
- LegacyPackageConfig {
- legacyConfigureFlags = configFlags,
- legacyInstallPkgFlags = installFlags,
- legacyHaddockFlags = haddockFlags,
- legacyTestFlags = testFlags,
- legacyBenchmarkFlags = benchmarkFlags
+convertToLegacyPerPackageConfig PackageConfig{..} =
+ LegacyPackageConfig
+ { legacyConfigureFlags = configFlags
+ , legacyInstallPkgFlags = installFlags
+ , legacyHaddockFlags = haddockFlags
+ , legacyTestFlags = testFlags
+ , legacyBenchmarkFlags = benchmarkFlags
}
where
- configFlags = ConfigFlags {
- configArgs = mempty,
- configPrograms_ = configPrograms_ mempty,
- configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths),
- configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs),
- configProgramPathExtra = packageConfigProgramPathExtra,
- configHcFlavor = mempty,
- configHcPath = mempty,
- configHcPkg = mempty,
- configInstantiateWith = mempty,
- configVanillaLib = packageConfigVanillaLib,
- configProfLib = packageConfigProfLib,
- configSharedLib = packageConfigSharedLib,
- configStaticLib = packageConfigStaticLib,
- configDynExe = packageConfigDynExe,
- configFullyStaticExe = packageConfigFullyStaticExe,
- configProfExe = packageConfigProfExe,
- configProf = packageConfigProf,
- configProfDetail = packageConfigProfDetail,
- configProfLibDetail = packageConfigProfLibDetail,
- configConfigureArgs = packageConfigConfigureArgs,
- configOptimization = packageConfigOptimization,
- configProgPrefix = packageConfigProgPrefix,
- configProgSuffix = packageConfigProgSuffix,
- configInstallDirs = mempty,
- configScratchDir = mempty,
- configDistPref = mempty,
- configCabalFilePath = mempty,
- configVerbosity = mempty,
- configUserInstall = mempty,
- configPackageDBs = mempty,
- configGHCiLib = packageConfigGHCiLib,
- configSplitSections = packageConfigSplitSections,
- configSplitObjs = packageConfigSplitObjs,
- configStripExes = packageConfigStripExes,
- configStripLibs = packageConfigStripLibs,
- configExtraLibDirs = packageConfigExtraLibDirs,
- configExtraLibDirsStatic = packageConfigExtraLibDirsStatic,
- configExtraFrameworkDirs = packageConfigExtraFrameworkDirs,
- configConstraints = mempty,
- configDependencies = mempty,
- configExtraIncludeDirs = packageConfigExtraIncludeDirs,
- configIPID = mempty,
- configCID = mempty,
- configDeterministic = mempty,
- configConfigurationsFlags = packageConfigFlagAssignment,
- configTests = packageConfigTests,
- configCoverage = packageConfigCoverage, --TODO: don't merge
- configLibCoverage = packageConfigCoverage, --TODO: don't merge
- configExactConfiguration = mempty,
- configBenchmarks = packageConfigBenchmarks,
- configFlagError = mempty, --TODO: ???
- configRelocatable = packageConfigRelocatable,
- configDebugInfo = packageConfigDebugInfo,
- configUseResponseFiles = mempty,
- configDumpBuildInfo = packageConfigDumpBuildInfo,
- configAllowDependingOnPrivateLibs = mempty
- }
+ configFlags =
+ ConfigFlags
+ { configArgs = mempty
+ , configPrograms_ = configPrograms_ mempty
+ , configProgramPaths = Map.toList (getMapLast packageConfigProgramPaths)
+ , configProgramArgs = Map.toList (getMapMappend packageConfigProgramArgs)
+ , configProgramPathExtra = packageConfigProgramPathExtra
+ , configHcFlavor = mempty
+ , configHcPath = mempty
+ , configHcPkg = mempty
+ , configInstantiateWith = mempty
+ , configVanillaLib = packageConfigVanillaLib
+ , configProfLib = packageConfigProfLib
+ , configSharedLib = packageConfigSharedLib
+ , configStaticLib = packageConfigStaticLib
+ , configDynExe = packageConfigDynExe
+ , configFullyStaticExe = packageConfigFullyStaticExe
+ , configProfExe = packageConfigProfExe
+ , configProf = packageConfigProf
+ , configProfDetail = packageConfigProfDetail
+ , configProfLibDetail = packageConfigProfLibDetail
+ , configConfigureArgs = packageConfigConfigureArgs
+ , configOptimization = packageConfigOptimization
+ , configProgPrefix = packageConfigProgPrefix
+ , configProgSuffix = packageConfigProgSuffix
+ , configInstallDirs = mempty
+ , configScratchDir = mempty
+ , configDistPref = mempty
+ , configCabalFilePath = mempty
+ , configVerbosity = mempty
+ , configUserInstall = mempty
+ , configPackageDBs = mempty
+ , configGHCiLib = packageConfigGHCiLib
+ , configSplitSections = packageConfigSplitSections
+ , configSplitObjs = packageConfigSplitObjs
+ , configStripExes = packageConfigStripExes
+ , configStripLibs = packageConfigStripLibs
+ , configExtraLibDirs = packageConfigExtraLibDirs
+ , configExtraLibDirsStatic = packageConfigExtraLibDirsStatic
+ , configExtraFrameworkDirs = packageConfigExtraFrameworkDirs
+ , configConstraints = mempty
+ , configDependencies = mempty
+ , configExtraIncludeDirs = packageConfigExtraIncludeDirs
+ , configIPID = mempty
+ , configCID = mempty
+ , configDeterministic = mempty
+ , configConfigurationsFlags = packageConfigFlagAssignment
+ , configTests = packageConfigTests
+ , configCoverage = packageConfigCoverage -- TODO: don't merge
+ , configLibCoverage = packageConfigCoverage -- TODO: don't merge
+ , configExactConfiguration = mempty
+ , configBenchmarks = packageConfigBenchmarks
+ , configFlagError = mempty -- TODO: ???
+ , configRelocatable = packageConfigRelocatable
+ , configDebugInfo = packageConfigDebugInfo
+ , configUseResponseFiles = mempty
+ , configDumpBuildInfo = packageConfigDumpBuildInfo
+ , configAllowDependingOnPrivateLibs = mempty
+ }
- installFlags = mempty {
- installDocumentation = packageConfigDocumentation,
- installRunTests = packageConfigRunTests
- }
+ installFlags =
+ mempty
+ { installDocumentation = packageConfigDocumentation
+ , installRunTests = packageConfigRunTests
+ }
- haddockFlags = HaddockFlags {
- haddockProgramPaths = mempty,
- haddockProgramArgs = mempty,
- haddockHoogle = packageConfigHaddockHoogle,
- haddockHtml = packageConfigHaddockHtml,
- haddockHtmlLocation = packageConfigHaddockHtmlLocation,
- haddockForHackage = packageConfigHaddockForHackage,
- haddockForeignLibs = packageConfigHaddockForeignLibs,
- haddockExecutables = packageConfigHaddockExecutables,
- haddockTestSuites = packageConfigHaddockTestSuites,
- haddockBenchmarks = packageConfigHaddockBenchmarks,
- haddockInternal = packageConfigHaddockInternal,
- haddockCss = packageConfigHaddockCss,
- haddockLinkedSource = packageConfigHaddockLinkedSource,
- haddockQuickJump = packageConfigHaddockQuickJump,
- haddockHscolourCss = packageConfigHaddockHscolourCss,
- haddockContents = packageConfigHaddockContents,
- haddockDistPref = mempty,
- haddockKeepTempFiles = mempty,
- haddockVerbosity = mempty,
- haddockCabalFilePath = mempty,
- haddockIndex = packageConfigHaddockIndex,
- haddockBaseUrl = packageConfigHaddockBaseUrl,
- haddockLib = packageConfigHaddockLib,
- haddockOutputDir = packageConfigHaddockOutputDir,
- haddockArgs = mempty
- }
+ haddockFlags =
+ HaddockFlags
+ { haddockProgramPaths = mempty
+ , haddockProgramArgs = mempty
+ , haddockHoogle = packageConfigHaddockHoogle
+ , haddockHtml = packageConfigHaddockHtml
+ , haddockHtmlLocation = packageConfigHaddockHtmlLocation
+ , haddockForHackage = packageConfigHaddockForHackage
+ , haddockForeignLibs = packageConfigHaddockForeignLibs
+ , haddockExecutables = packageConfigHaddockExecutables
+ , haddockTestSuites = packageConfigHaddockTestSuites
+ , haddockBenchmarks = packageConfigHaddockBenchmarks
+ , haddockInternal = packageConfigHaddockInternal
+ , haddockCss = packageConfigHaddockCss
+ , haddockLinkedSource = packageConfigHaddockLinkedSource
+ , haddockQuickJump = packageConfigHaddockQuickJump
+ , haddockHscolourCss = packageConfigHaddockHscolourCss
+ , haddockContents = packageConfigHaddockContents
+ , haddockDistPref = mempty
+ , haddockKeepTempFiles = mempty
+ , haddockVerbosity = mempty
+ , haddockCabalFilePath = mempty
+ , haddockIndex = packageConfigHaddockIndex
+ , haddockBaseUrl = packageConfigHaddockBaseUrl
+ , haddockLib = packageConfigHaddockLib
+ , haddockOutputDir = packageConfigHaddockOutputDir
+ , haddockArgs = mempty
+ }
- testFlags = TestFlags {
- testDistPref = mempty,
- testVerbosity = mempty,
- testHumanLog = packageConfigTestHumanLog,
- testMachineLog = packageConfigTestMachineLog,
- testShowDetails = packageConfigTestShowDetails,
- testKeepTix = packageConfigTestKeepTix,
- testWrapper = packageConfigTestWrapper,
- testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites,
- testOptions = packageConfigTestTestOptions
- }
+ testFlags =
+ TestFlags
+ { testDistPref = mempty
+ , testVerbosity = mempty
+ , testHumanLog = packageConfigTestHumanLog
+ , testMachineLog = packageConfigTestMachineLog
+ , testShowDetails = packageConfigTestShowDetails
+ , testKeepTix = packageConfigTestKeepTix
+ , testWrapper = packageConfigTestWrapper
+ , testFailWhenNoTestSuites = packageConfigTestFailWhenNoTestSuites
+ , testOptions = packageConfigTestTestOptions
+ }
- benchmarkFlags = BenchmarkFlags {
- benchmarkDistPref = mempty,
- benchmarkVerbosity = mempty,
- benchmarkOptions = packageConfigBenchmarkOptions
- }
+ benchmarkFlags =
+ BenchmarkFlags
+ { benchmarkDistPref = mempty
+ , benchmarkVerbosity = mempty
+ , benchmarkOptions = packageConfigBenchmarkOptions
+ }
------------------------------------------------
-- Parsing and showing the project config file
@@ -1014,10 +1163,11 @@ convertToLegacyPerPackageConfig PackageConfig {..} =
parseLegacyProjectConfigFields :: FilePath -> [ParseUtils.Field] -> ParseResult LegacyProjectConfig
parseLegacyProjectConfigFields source =
- parseFieldsAndSections (legacyProjectConfigFieldDescrs constraintSrc)
- legacyPackageConfigSectionDescrs
- legacyPackageConfigFGSectionDescrs
- mempty
+ parseFieldsAndSections
+ (legacyProjectConfigFieldDescrs constraintSrc)
+ legacyPackageConfigSectionDescrs
+ legacyPackageConfigFGSectionDescrs
+ mempty
where
constraintSrc = ConstraintSourceProjectConfig source
@@ -1026,347 +1176,442 @@ parseLegacyProjectConfig source bs = parseLegacyProjectConfigFields source =<< P
showLegacyProjectConfig :: LegacyProjectConfig -> String
showLegacyProjectConfig config =
- Disp.render $
- showConfig (legacyProjectConfigFieldDescrs constraintSrc)
- legacyPackageConfigSectionDescrs
- legacyPackageConfigFGSectionDescrs
- config
- $+$
- Disp.text ""
+ Disp.render $
+ showConfig
+ (legacyProjectConfigFieldDescrs constraintSrc)
+ legacyPackageConfigSectionDescrs
+ legacyPackageConfigFGSectionDescrs
+ config
+ $+$ Disp.text ""
where
-- Note: ConstraintSource is unused when pretty-printing. We fake
-- it here to avoid having to pass it on call-sites. It's not great
-- but requires re-work of how we annotate provenance.
constraintSrc = ConstraintSourceProjectConfig "unused"
-
legacyProjectConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacyProjectConfig]
legacyProjectConfigFieldDescrs constraintSrc =
-
- [ newLineListField "packages"
- (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
- legacyPackages
- (\v flags -> flags { legacyPackages = v })
- , newLineListField "optional-packages"
- (Disp.text . renderPackageLocationToken) parsePackageLocationTokenQ
- legacyPackagesOptional
- (\v flags -> flags { legacyPackagesOptional = v })
- , commaNewLineListFieldParsec "extra-packages"
- pretty parsec
- legacyPackagesNamed
- (\v flags -> flags { legacyPackagesNamed = v })
- ]
-
- ++ map (liftField
- legacySharedConfig
- (\flags conf -> conf { legacySharedConfig = flags }))
- (legacySharedConfigFieldDescrs constraintSrc)
-
- ++ map (liftField
- legacyLocalConfig
- (\flags conf -> conf { legacyLocalConfig = flags }))
- legacyPackageConfigFieldDescrs
+ [ newLineListField
+ "packages"
+ (Disp.text . renderPackageLocationToken)
+ parsePackageLocationTokenQ
+ legacyPackages
+ (\v flags -> flags{legacyPackages = v})
+ , newLineListField
+ "optional-packages"
+ (Disp.text . renderPackageLocationToken)
+ parsePackageLocationTokenQ
+ legacyPackagesOptional
+ (\v flags -> flags{legacyPackagesOptional = v})
+ , commaNewLineListFieldParsec
+ "extra-packages"
+ pretty
+ parsec
+ legacyPackagesNamed
+ (\v flags -> flags{legacyPackagesNamed = v})
+ ]
+ ++ map
+ ( liftField
+ legacySharedConfig
+ (\flags conf -> conf{legacySharedConfig = flags})
+ )
+ (legacySharedConfigFieldDescrs constraintSrc)
+ ++ map
+ ( liftField
+ legacyLocalConfig
+ (\flags conf -> conf{legacyLocalConfig = flags})
+ )
+ legacyPackageConfigFieldDescrs
-- | This is a bit tricky since it has to cover globs which have embedded @,@
-- chars. But we don't just want to parse strictly as a glob since we want to
-- allow http urls which don't parse as globs, and possibly some
-- system-dependent file paths. So we parse fairly liberally as a token, but
-- we allow @,@ inside matched @{}@ braces.
---
parsePackageLocationTokenQ :: ReadP r String
-parsePackageLocationTokenQ = parseHaskellString
- Parse.<++ parsePackageLocationToken
+parsePackageLocationTokenQ =
+ parseHaskellString
+ Parse.<++ parsePackageLocationToken
where
parsePackageLocationToken :: ReadP r String
parsePackageLocationToken = fmap fst (Parse.gather outerTerm)
where
- outerTerm = alternateEither1 outerToken (braces innerTerm)
- innerTerm = alternateEither innerToken (braces innerTerm)
- outerToken = Parse.munch1 outerChar >> return ()
- innerToken = Parse.munch1 innerChar >> return ()
+ outerTerm = alternateEither1 outerToken (braces innerTerm)
+ innerTerm = alternateEither innerToken (braces innerTerm)
+ outerToken = Parse.munch1 outerChar >> return ()
+ innerToken = Parse.munch1 innerChar >> return ()
outerChar c = not (isSpace c || c == '{' || c == '}' || c == ',')
innerChar c = not (isSpace c || c == '{' || c == '}')
- braces = Parse.between (Parse.char '{') (Parse.char '}')
+ braces = Parse.between (Parse.char '{') (Parse.char '}')
- alternateEither, alternateEither1,
- alternatePQs, alternate1PQs, alternateQsP, alternate1QsP
- :: ReadP r () -> ReadP r () -> ReadP r ()
+ alternateEither
+ , alternateEither1
+ , alternatePQs
+ , alternate1PQs
+ , alternateQsP
+ , alternate1QsP
+ :: ReadP r () -> ReadP r () -> ReadP r ()
alternateEither1 p q = alternate1PQs p q +++ alternate1QsP q p
- alternateEither p q = alternateEither1 p q +++ return ()
- alternate1PQs p q = p >> alternateQsP q p
- alternatePQs p q = alternate1PQs p q +++ return ()
- alternate1QsP q p = Parse.many1 q >> alternatePQs p q
- alternateQsP q p = alternate1QsP q p +++ return ()
+ alternateEither p q = alternateEither1 p q +++ return ()
+ alternate1PQs p q = p >> alternateQsP q p
+ alternatePQs p q = alternate1PQs p q +++ return ()
+ alternate1QsP q p = Parse.many1 q >> alternatePQs p q
+ alternateQsP q p = alternate1QsP q p +++ return ()
renderPackageLocationToken :: String -> String
-renderPackageLocationToken s | needsQuoting = show s
- | otherwise = s
+renderPackageLocationToken s
+ | needsQuoting = show s
+ | otherwise = s
where
- needsQuoting = not (ok 0 s)
- || s == "." -- . on its own on a line has special meaning
- || take 2 s == "--" -- on its own line is comment syntax
- --TODO: [code cleanup] these "." and "--" escaping issues
- -- ought to be dealt with systematically in ParseUtils.
+ needsQuoting =
+ not (ok 0 s)
+ || s == "." -- . on its own on a line has special meaning
+ || take 2 s == "--" -- on its own line is comment syntax
+ -- TODO: [code cleanup] these "." and "--" escaping issues
+ -- ought to be dealt with systematically in ParseUtils.
ok :: Int -> String -> Bool
- ok n [] = n == 0
- ok _ ('"':_) = False
- ok n ('{':cs) = ok (n+1) cs
- ok n ('}':cs) = ok (n-1) cs
- ok n (',':cs) = (n > 0) && ok n cs
- ok _ (c:_)
+ ok n [] = n == 0
+ ok _ ('"' : _) = False
+ ok n ('{' : cs) = ok (n + 1) cs
+ ok n ('}' : cs) = ok (n - 1) cs
+ ok n (',' : cs) = (n > 0) && ok n cs
+ ok _ (c : _)
| isSpace c = False
- ok n (_ :cs) = ok n cs
-
+ ok n (_ : cs) = ok n cs
legacySharedConfigFieldDescrs :: ConstraintSource -> [FieldDescr LegacySharedConfig]
-legacySharedConfigFieldDescrs constraintSrc = concat
- [ liftFields
- legacyGlobalFlags
- (\flags conf -> conf { legacyGlobalFlags = flags })
- . addFields
- [ newLineListField "extra-prog-path-shared-only"
- showTokenQ parseTokenQ
- (fromNubList . globalProgPathExtra)
- (\v conf -> conf { globalProgPathExtra = toNubList v })
- ]
- . filterFields
- [ "remote-repo-cache"
- , "logs-dir", "store-dir", "ignore-expiry", "http-transport"
- , "active-repositories"
- ]
- . commandOptionsToFields
- $ commandOptions (globalCommand []) ParseArgs
-
- , liftFields
- legacyConfigureShFlags
- (\flags conf -> conf { legacyConfigureShFlags = flags })
- . addFields
- [ commaNewLineListFieldParsec "package-dbs"
- (Disp.text . showPackageDb) (fmap readPackageDb parsecToken)
- configPackageDBs (\v conf -> conf { configPackageDBs = v })
- ]
- . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions)
- . commandOptionsToFields
- $ configureOptions ParseArgs
-
- , liftFields
- legacyConfigureExFlags
- (\flags conf -> conf { legacyConfigureExFlags = flags })
- . addFields
- [ commaNewLineListFieldParsec "constraints"
- (pretty . fst) (fmap (\constraint -> (constraint, constraintSrc)) parsec)
- configExConstraints (\v conf -> conf { configExConstraints = v })
-
- , commaNewLineListFieldParsec "preferences"
- pretty parsec
- configPreferences (\v conf -> conf { configPreferences = v })
-
- , monoidFieldParsec "allow-older"
- (maybe mempty pretty) (fmap Just parsec)
- (fmap unAllowOlder . configAllowOlder)
- (\v conf -> conf { configAllowOlder = fmap AllowOlder v })
-
- , monoidFieldParsec "allow-newer"
- (maybe mempty pretty) (fmap Just parsec)
- (fmap unAllowNewer . configAllowNewer)
- (\v conf -> conf { configAllowNewer = fmap AllowNewer v })
- ]
- . filterFields
- [ "cabal-lib-version", "solver", "write-ghc-environment-files"
- -- not "constraint" or "preference", we use our own plural ones above
- ]
- . commandOptionsToFields
- $ configureExOptions ParseArgs constraintSrc
-
- , liftFields
- legacyInstallFlags
- (\flags conf -> conf { legacyInstallFlags = flags })
- . addFields
- [ newLineListField "build-summary"
- (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
- (fromNubList . installSummaryFile)
- (\v conf -> conf { installSummaryFile = toNubList v })
- ]
- . filterFields
- [ "doc-index-file"
- , "root-cmd", "symlink-bindir"
- , "build-log"
- , "remote-build-reporting", "report-planning-failure"
- , "jobs", "keep-going", "offline", "per-component"
- -- solver flags:
- , "max-backjumps", "reorder-goals", "count-conflicts"
- , "fine-grained-conflicts" , "minimize-conflict-set", "independent-goals", "prefer-oldest"
- , "strong-flags" , "allow-boot-library-installs"
- , "reject-unconstrained-dependencies", "index-state"
- ]
- . commandOptionsToFields
- $ installOptions ParseArgs
-
- , liftFields
- legacyClientInstallFlags
- (\flags conf -> conf { legacyClientInstallFlags = flags })
- . commandOptionsToFields
- $ clientInstallOptions ParseArgs
-
- , liftFields
- legacyProjectFlags
- (\flags conf -> conf { legacyProjectFlags = flags })
- . commandOptionsToFields
- $ projectFlagsOptions ParseArgs
-
- ]
-
+legacySharedConfigFieldDescrs constraintSrc =
+ concat
+ [ liftFields
+ legacyGlobalFlags
+ (\flags conf -> conf{legacyGlobalFlags = flags})
+ . addFields
+ [ newLineListField
+ "extra-prog-path-shared-only"
+ showTokenQ
+ parseTokenQ
+ (fromNubList . globalProgPathExtra)
+ (\v conf -> conf{globalProgPathExtra = toNubList v})
+ ]
+ . filterFields
+ [ "remote-repo-cache"
+ , "logs-dir"
+ , "store-dir"
+ , "ignore-expiry"
+ , "http-transport"
+ , "active-repositories"
+ ]
+ . commandOptionsToFields
+ $ commandOptions (globalCommand []) ParseArgs
+ , liftFields
+ legacyConfigureShFlags
+ (\flags conf -> conf{legacyConfigureShFlags = flags})
+ . addFields
+ [ commaNewLineListFieldParsec
+ "package-dbs"
+ (Disp.text . showPackageDb)
+ (fmap readPackageDb parsecToken)
+ configPackageDBs
+ (\v conf -> conf{configPackageDBs = v})
+ ]
+ . filterFields (["verbose", "builddir"] ++ map optionName installDirsOptions)
+ . commandOptionsToFields
+ $ configureOptions ParseArgs
+ , liftFields
+ legacyConfigureExFlags
+ (\flags conf -> conf{legacyConfigureExFlags = flags})
+ . addFields
+ [ commaNewLineListFieldParsec
+ "constraints"
+ (pretty . fst)
+ (fmap (\constraint -> (constraint, constraintSrc)) parsec)
+ configExConstraints
+ (\v conf -> conf{configExConstraints = v})
+ , commaNewLineListFieldParsec
+ "preferences"
+ pretty
+ parsec
+ configPreferences
+ (\v conf -> conf{configPreferences = v})
+ , monoidFieldParsec
+ "allow-older"
+ (maybe mempty pretty)
+ (fmap Just parsec)
+ (fmap unAllowOlder . configAllowOlder)
+ (\v conf -> conf{configAllowOlder = fmap AllowOlder v})
+ , monoidFieldParsec
+ "allow-newer"
+ (maybe mempty pretty)
+ (fmap Just parsec)
+ (fmap unAllowNewer . configAllowNewer)
+ (\v conf -> conf{configAllowNewer = fmap AllowNewer v})
+ ]
+ . filterFields
+ [ "cabal-lib-version"
+ , "solver"
+ , "write-ghc-environment-files"
+ -- not "constraint" or "preference", we use our own plural ones above
+ ]
+ . commandOptionsToFields
+ $ configureExOptions ParseArgs constraintSrc
+ , liftFields
+ legacyInstallFlags
+ (\flags conf -> conf{legacyInstallFlags = flags})
+ . addFields
+ [ newLineListField
+ "build-summary"
+ (showTokenQ . fromPathTemplate)
+ (fmap toPathTemplate parseTokenQ)
+ (fromNubList . installSummaryFile)
+ (\v conf -> conf{installSummaryFile = toNubList v})
+ ]
+ . filterFields
+ [ "doc-index-file"
+ , "root-cmd"
+ , "symlink-bindir"
+ , "build-log"
+ , "remote-build-reporting"
+ , "report-planning-failure"
+ , "jobs"
+ , "keep-going"
+ , "offline"
+ , "per-component"
+ , -- solver flags:
+ "max-backjumps"
+ , "reorder-goals"
+ , "count-conflicts"
+ , "fine-grained-conflicts"
+ , "minimize-conflict-set"
+ , "independent-goals"
+ , "prefer-oldest"
+ , "strong-flags"
+ , "allow-boot-library-installs"
+ , "reject-unconstrained-dependencies"
+ , "index-state"
+ ]
+ . commandOptionsToFields
+ $ installOptions ParseArgs
+ , liftFields
+ legacyClientInstallFlags
+ (\flags conf -> conf{legacyClientInstallFlags = flags})
+ . commandOptionsToFields
+ $ clientInstallOptions ParseArgs
+ , liftFields
+ legacyProjectFlags
+ (\flags conf -> conf{legacyProjectFlags = flags})
+ . commandOptionsToFields
+ $ projectFlagsOptions ParseArgs
+ ]
legacyPackageConfigFieldDescrs :: [FieldDescr LegacyPackageConfig]
legacyPackageConfigFieldDescrs =
( liftFields
legacyConfigureFlags
- (\flags conf -> conf { legacyConfigureFlags = flags })
- . addFields
- [ newLineListField "extra-include-dirs"
- showTokenQ parseTokenQ
- configExtraIncludeDirs
- (\v conf -> conf { configExtraIncludeDirs = v })
- , newLineListField "extra-lib-dirs"
- showTokenQ parseTokenQ
- configExtraLibDirs
- (\v conf -> conf { configExtraLibDirs = v })
- , newLineListField "extra-lib-dirs-static"
- showTokenQ parseTokenQ
- configExtraLibDirsStatic
- (\v conf -> conf { configExtraLibDirsStatic = v })
- , newLineListField "extra-framework-dirs"
- showTokenQ parseTokenQ
- configExtraFrameworkDirs
- (\v conf -> conf { configExtraFrameworkDirs = v })
- , newLineListField "extra-prog-path"
- showTokenQ parseTokenQ
- (fromNubList . configProgramPathExtra)
- (\v conf -> conf { configProgramPathExtra = toNubList v })
- , newLineListField "configure-options"
- showTokenQ parseTokenQ
- configConfigureArgs
- (\v conf -> conf { configConfigureArgs = v })
- , simpleFieldParsec "flags"
- dispFlagAssignment parsecFlagAssignment
- configConfigurationsFlags
- (\v conf -> conf { configConfigurationsFlags = v })
- , overrideDumpBuildInfo
- ]
- . filterFields
- [ "with-compiler", "with-hc-pkg"
- , "program-prefix", "program-suffix"
- , "library-vanilla", "library-profiling"
- , "shared", "static", "executable-dynamic", "executable-static"
- , "profiling", "executable-profiling"
- , "profiling-detail", "library-profiling-detail"
- , "library-for-ghci", "split-objs", "split-sections"
- , "executable-stripping", "library-stripping"
- , "tests", "benchmarks"
- , "coverage", "library-coverage"
- , "relocatable"
+ (\flags conf -> conf{legacyConfigureFlags = flags})
+ . addFields
+ [ newLineListField
+ "extra-include-dirs"
+ showTokenQ
+ parseTokenQ
+ configExtraIncludeDirs
+ (\v conf -> conf{configExtraIncludeDirs = v})
+ , newLineListField
+ "extra-lib-dirs"
+ showTokenQ
+ parseTokenQ
+ configExtraLibDirs
+ (\v conf -> conf{configExtraLibDirs = v})
+ , newLineListField
+ "extra-lib-dirs-static"
+ showTokenQ
+ parseTokenQ
+ configExtraLibDirsStatic
+ (\v conf -> conf{configExtraLibDirsStatic = v})
+ , newLineListField
+ "extra-framework-dirs"
+ showTokenQ
+ parseTokenQ
+ configExtraFrameworkDirs
+ (\v conf -> conf{configExtraFrameworkDirs = v})
+ , newLineListField
+ "extra-prog-path"
+ showTokenQ
+ parseTokenQ
+ (fromNubList . configProgramPathExtra)
+ (\v conf -> conf{configProgramPathExtra = toNubList v})
+ , newLineListField
+ "configure-options"
+ showTokenQ
+ parseTokenQ
+ configConfigureArgs
+ (\v conf -> conf{configConfigureArgs = v})
+ , simpleFieldParsec
+ "flags"
+ dispFlagAssignment
+ parsecFlagAssignment
+ configConfigurationsFlags
+ (\v conf -> conf{configConfigurationsFlags = v})
+ , overrideDumpBuildInfo
+ ]
+ . filterFields
+ [ "with-compiler"
+ , "with-hc-pkg"
+ , "program-prefix"
+ , "program-suffix"
+ , "library-vanilla"
+ , "library-profiling"
+ , "shared"
+ , "static"
+ , "executable-dynamic"
+ , "executable-static"
+ , "profiling"
+ , "executable-profiling"
+ , "profiling-detail"
+ , "library-profiling-detail"
+ , "library-for-ghci"
+ , "split-objs"
+ , "split-sections"
+ , "executable-stripping"
+ , "library-stripping"
+ , "tests"
+ , "benchmarks"
+ , "coverage"
+ , "library-coverage"
+ , "relocatable"
-- not "extra-include-dirs", "extra-lib-dirs", "extra-framework-dirs"
-- or "extra-prog-path". We use corrected ones above that parse
-- as list fields.
- ]
- . commandOptionsToFields
- ) (configureOptions ParseArgs)
- ++
- liftFields
+ ]
+ . commandOptionsToFields
+ )
+ (configureOptions ParseArgs)
+ ++ liftFields
legacyConfigureFlags
- (\flags conf -> conf { legacyConfigureFlags = flags })
- [ overrideFieldCompiler
- , overrideFieldOptimization
- , overrideFieldDebugInfo
- ]
- ++
- ( liftFields
- legacyInstallPkgFlags
- (\flags conf -> conf { legacyInstallPkgFlags = flags })
- . filterFields
- [ "documentation", "run-tests"
- ]
- . commandOptionsToFields
- ) (installOptions ParseArgs)
- ++
- ( liftFields
- legacyHaddockFlags
- (\flags conf -> conf { legacyHaddockFlags = flags })
- . mapFieldNames
- ("haddock-"++)
- . addFields
- [ simpleFieldParsec "for-hackage"
- -- TODO: turn this into a library function
- (fromFlagOrDefault Disp.empty . fmap pretty) (toFlag <$> parsec <|> pure mempty)
- haddockForHackage (\v conf -> conf { haddockForHackage = v })
- ]
- . filterFields
- [ "hoogle", "html", "html-location"
- , "foreign-libraries"
- , "executables", "tests", "benchmarks", "all", "internal", "css"
- , "hyperlink-source", "quickjump", "hscolour-css"
- , "contents-location", "index-location", "keep-temp-files", "base-url"
- , "lib", "output-dir"
- ]
- . commandOptionsToFields
- ) (haddockOptions ParseArgs)
- ++
- ( liftFields
- legacyTestFlags
- (\flags conf -> conf { legacyTestFlags = flags })
- . mapFieldNames
- prefixTest
- . addFields
- [ newLineListField "test-options"
- (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
- testOptions
- (\v conf -> conf { testOptions = v })
- ]
- . filterFields
- [ "log", "machine-log", "show-details", "keep-tix-files"
- , "fail-when-no-test-suites", "test-wrapper" ]
- . commandOptionsToFields
- ) (testOptions' ParseArgs)
- ++
- ( liftFields
- legacyBenchmarkFlags
- (\flags conf -> conf { legacyBenchmarkFlags = flags })
- . addFields
- [ newLineListField "benchmark-options"
- (showTokenQ . fromPathTemplate) (fmap toPathTemplate parseTokenQ)
- benchmarkOptions
- (\v conf -> conf { benchmarkOptions = v })
+ (\flags conf -> conf{legacyConfigureFlags = flags})
+ [ overrideFieldCompiler
+ , overrideFieldOptimization
+ , overrideFieldDebugInfo
]
- . filterFields
- []
- . commandOptionsToFields
- ) (benchmarkOptions' ParseArgs)
-
+ ++ ( liftFields
+ legacyInstallPkgFlags
+ (\flags conf -> conf{legacyInstallPkgFlags = flags})
+ . filterFields
+ [ "documentation"
+ , "run-tests"
+ ]
+ . commandOptionsToFields
+ )
+ (installOptions ParseArgs)
+ ++ ( liftFields
+ legacyHaddockFlags
+ (\flags conf -> conf{legacyHaddockFlags = flags})
+ . mapFieldNames
+ ("haddock-" ++)
+ . addFields
+ [ simpleFieldParsec
+ "for-hackage"
+ -- TODO: turn this into a library function
+ (fromFlagOrDefault Disp.empty . fmap pretty)
+ (toFlag <$> parsec <|> pure mempty)
+ haddockForHackage
+ (\v conf -> conf{haddockForHackage = v})
+ ]
+ . filterFields
+ [ "hoogle"
+ , "html"
+ , "html-location"
+ , "foreign-libraries"
+ , "executables"
+ , "tests"
+ , "benchmarks"
+ , "all"
+ , "internal"
+ , "css"
+ , "hyperlink-source"
+ , "quickjump"
+ , "hscolour-css"
+ , "contents-location"
+ , "index-location"
+ , "keep-temp-files"
+ , "base-url"
+ , "lib"
+ , "output-dir"
+ ]
+ . commandOptionsToFields
+ )
+ (haddockOptions ParseArgs)
+ ++ ( liftFields
+ legacyTestFlags
+ (\flags conf -> conf{legacyTestFlags = flags})
+ . mapFieldNames
+ prefixTest
+ . addFields
+ [ newLineListField
+ "test-options"
+ (showTokenQ . fromPathTemplate)
+ (fmap toPathTemplate parseTokenQ)
+ testOptions
+ (\v conf -> conf{testOptions = v})
+ ]
+ . filterFields
+ [ "log"
+ , "machine-log"
+ , "show-details"
+ , "keep-tix-files"
+ , "fail-when-no-test-suites"
+ , "test-wrapper"
+ ]
+ . commandOptionsToFields
+ )
+ (testOptions' ParseArgs)
+ ++ ( liftFields
+ legacyBenchmarkFlags
+ (\flags conf -> conf{legacyBenchmarkFlags = flags})
+ . addFields
+ [ newLineListField
+ "benchmark-options"
+ (showTokenQ . fromPathTemplate)
+ (fmap toPathTemplate parseTokenQ)
+ benchmarkOptions
+ (\v conf -> conf{benchmarkOptions = v})
+ ]
+ . filterFields
+ []
+ . commandOptionsToFields
+ )
+ (benchmarkOptions' ParseArgs)
where
overrideFieldCompiler =
- simpleFieldParsec "compiler"
+ simpleFieldParsec
+ "compiler"
(fromFlagOrDefault Disp.empty . fmap pretty)
(toFlag <$> parsec <|> pure mempty)
- configHcFlavor (\v flags -> flags { configHcFlavor = v })
+ configHcFlavor
+ (\v flags -> flags{configHcFlavor = v})
overrideDumpBuildInfo =
- liftField configDumpBuildInfo
- (\v flags -> flags { configDumpBuildInfo = v }) $
- let name = "build-info" in
- FieldDescr name
- (\f -> case f of
- Flag NoDumpBuildInfo -> Disp.text "False"
- Flag DumpBuildInfo -> Disp.text "True"
- _ -> Disp.empty)
- (\line str _ -> case () of
- _ | str == "False" -> ParseOk [] (Flag NoDumpBuildInfo)
- | str == "True" -> ParseOk [] (Flag DumpBuildInfo)
- | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo)
- | lstr == "true" -> ParseOk [caseWarning name] (Flag DumpBuildInfo)
- | otherwise -> ParseFailed (NoParse name line)
- where
- lstr = lowercase str)
+ liftField
+ configDumpBuildInfo
+ (\v flags -> flags{configDumpBuildInfo = v})
+ $ let name = "build-info"
+ in FieldDescr
+ name
+ ( \f -> case f of
+ Flag NoDumpBuildInfo -> Disp.text "False"
+ Flag DumpBuildInfo -> Disp.text "True"
+ _ -> Disp.empty
+ )
+ ( \line str _ -> case () of
+ _
+ | str == "False" -> ParseOk [] (Flag NoDumpBuildInfo)
+ | str == "True" -> ParseOk [] (Flag DumpBuildInfo)
+ | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDumpBuildInfo)
+ | lstr == "true" -> ParseOk [caseWarning name] (Flag DumpBuildInfo)
+ | otherwise -> ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ )
-- TODO: [code cleanup] The following is a hack. The "optimization" and
-- "debug-info" fields are OptArg, and viewAsFieldDescr fails on that.
@@ -1374,224 +1619,256 @@ legacyPackageConfigFieldDescrs =
-- properly in the library.
overrideFieldOptimization =
- liftField configOptimization
- (\v flags -> flags { configOptimization = v }) $
- let name = "optimization" in
- FieldDescr name
- (\f -> case f of
- Flag NoOptimisation -> Disp.text "False"
- Flag NormalOptimisation -> Disp.text "True"
- Flag MaximumOptimisation -> Disp.text "2"
- _ -> Disp.empty)
- (\line str _ -> case () of
- _ | str == "False" -> ParseOk [] (Flag NoOptimisation)
- | str == "True" -> ParseOk [] (Flag NormalOptimisation)
- | str == "0" -> ParseOk [] (Flag NoOptimisation)
- | str == "1" -> ParseOk [] (Flag NormalOptimisation)
- | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
- | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation)
- | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalOptimisation)
- | otherwise -> ParseFailed (NoParse name line)
- where
- lstr = lowercase str)
+ liftField
+ configOptimization
+ (\v flags -> flags{configOptimization = v})
+ $ let name = "optimization"
+ in FieldDescr
+ name
+ ( \f -> case f of
+ Flag NoOptimisation -> Disp.text "False"
+ Flag NormalOptimisation -> Disp.text "True"
+ Flag MaximumOptimisation -> Disp.text "2"
+ _ -> Disp.empty
+ )
+ ( \line str _ -> case () of
+ _
+ | str == "False" -> ParseOk [] (Flag NoOptimisation)
+ | str == "True" -> ParseOk [] (Flag NormalOptimisation)
+ | str == "0" -> ParseOk [] (Flag NoOptimisation)
+ | str == "1" -> ParseOk [] (Flag NormalOptimisation)
+ | str == "2" -> ParseOk [] (Flag MaximumOptimisation)
+ | lstr == "false" -> ParseOk [caseWarning name] (Flag NoOptimisation)
+ | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalOptimisation)
+ | otherwise -> ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ )
overrideFieldDebugInfo =
- liftField configDebugInfo (\v flags -> flags { configDebugInfo = v }) $
- let name = "debug-info" in
- FieldDescr name
- (\f -> case f of
- Flag NoDebugInfo -> Disp.text "False"
- Flag MinimalDebugInfo -> Disp.text "1"
- Flag NormalDebugInfo -> Disp.text "True"
- Flag MaximalDebugInfo -> Disp.text "3"
- _ -> Disp.empty)
- (\line str _ -> case () of
- _ | str == "False" -> ParseOk [] (Flag NoDebugInfo)
- | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
- | str == "0" -> ParseOk [] (Flag NoDebugInfo)
- | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
- | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
- | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
- | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo)
- | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalDebugInfo)
- | otherwise -> ParseFailed (NoParse name line)
- where
- lstr = lowercase str)
-
- caseWarning name = PWarning $
- "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
-
- prefixTest name | "test-" `isPrefixOf` name = name
- | otherwise = "test-" ++ name
-
+ liftField configDebugInfo (\v flags -> flags{configDebugInfo = v}) $
+ let name = "debug-info"
+ in FieldDescr
+ name
+ ( \f -> case f of
+ Flag NoDebugInfo -> Disp.text "False"
+ Flag MinimalDebugInfo -> Disp.text "1"
+ Flag NormalDebugInfo -> Disp.text "True"
+ Flag MaximalDebugInfo -> Disp.text "3"
+ _ -> Disp.empty
+ )
+ ( \line str _ -> case () of
+ _
+ | str == "False" -> ParseOk [] (Flag NoDebugInfo)
+ | str == "True" -> ParseOk [] (Flag NormalDebugInfo)
+ | str == "0" -> ParseOk [] (Flag NoDebugInfo)
+ | str == "1" -> ParseOk [] (Flag MinimalDebugInfo)
+ | str == "2" -> ParseOk [] (Flag NormalDebugInfo)
+ | str == "3" -> ParseOk [] (Flag MaximalDebugInfo)
+ | lstr == "false" -> ParseOk [caseWarning name] (Flag NoDebugInfo)
+ | lstr == "true" -> ParseOk [caseWarning name] (Flag NormalDebugInfo)
+ | otherwise -> ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ )
+
+ caseWarning name =
+ PWarning $
+ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
+
+ prefixTest name
+ | "test-" `isPrefixOf` name = name
+ | otherwise = "test-" ++ name
legacyPackageConfigFGSectionDescrs
- :: ( FieldGrammar c g, Applicative (g SourceRepoList)
- , c (Identity RepoType)
- , c (List NoCommaFSep FilePathNT String)
- , c (NonEmpty' NoCommaFSep Token String)
- )
- => [FGSectionDescr g LegacyProjectConfig]
+ :: ( FieldGrammar c g
+ , Applicative (g SourceRepoList)
+ , c (Identity RepoType)
+ , c (List NoCommaFSep FilePathNT String)
+ , c (NonEmpty' NoCommaFSep Token String)
+ )
+ => [FGSectionDescr g LegacyProjectConfig]
legacyPackageConfigFGSectionDescrs =
- [ packageRepoSectionDescr
- ]
+ [ packageRepoSectionDescr
+ ]
legacyPackageConfigSectionDescrs :: [SectionDescr LegacyProjectConfig]
legacyPackageConfigSectionDescrs =
- [ packageSpecificOptionsSectionDescr
- , liftSection
- legacyLocalConfig
- (\flags conf -> conf { legacyLocalConfig = flags })
- programOptionsSectionDescr
- , liftSection
- legacyLocalConfig
- (\flags conf -> conf { legacyLocalConfig = flags })
- programLocationsSectionDescr
- , liftSection
- legacySharedConfig
- (\flags conf -> conf { legacySharedConfig = flags }) $
- liftSection
+ [ packageSpecificOptionsSectionDescr
+ , liftSection
+ legacyLocalConfig
+ (\flags conf -> conf{legacyLocalConfig = flags})
+ programOptionsSectionDescr
+ , liftSection
+ legacyLocalConfig
+ (\flags conf -> conf{legacyLocalConfig = flags})
+ programLocationsSectionDescr
+ , liftSection
+ legacySharedConfig
+ (\flags conf -> conf{legacySharedConfig = flags})
+ $ liftSection
legacyGlobalFlags
- (\flags conf -> conf { legacyGlobalFlags = flags })
+ (\flags conf -> conf{legacyGlobalFlags = flags})
remoteRepoSectionDescr
- ]
+ ]
packageRepoSectionDescr
- :: ( FieldGrammar c g, Applicative (g SourceRepoList)
- , c (Identity RepoType)
- , c (List NoCommaFSep FilePathNT String)
- , c (NonEmpty' NoCommaFSep Token String)
- )
- => FGSectionDescr g LegacyProjectConfig
-packageRepoSectionDescr = FGSectionDescr
- { fgSectionName = "source-repository-package"
- , fgSectionGrammar = sourceRepositoryPackageGrammar
- , fgSectionGet = map (\x->("", x)) . legacyPackagesRepo
- , fgSectionSet =
+ :: ( FieldGrammar c g
+ , Applicative (g SourceRepoList)
+ , c (Identity RepoType)
+ , c (List NoCommaFSep FilePathNT String)
+ , c (NonEmpty' NoCommaFSep Token String)
+ )
+ => FGSectionDescr g LegacyProjectConfig
+packageRepoSectionDescr =
+ FGSectionDescr
+ { fgSectionName = "source-repository-package"
+ , fgSectionGrammar = sourceRepositoryPackageGrammar
+ , fgSectionGet = map (\x -> ("", x)) . legacyPackagesRepo
+ , fgSectionSet =
\lineno unused pkgrepo projconf -> do
unless (null unused) $
syntaxError lineno "the section 'source-repository-package' takes no arguments"
- return projconf {
- legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]
- }
- }
+ return
+ projconf
+ { legacyPackagesRepo = legacyPackagesRepo projconf ++ [pkgrepo]
+ }
+ }
-- | The definitions of all the fields that can appear in the @package pkgfoo@
-- and @package *@ sections of the @cabal.project@-format files.
---
packageSpecificOptionsFieldDescrs :: [FieldDescr LegacyPackageConfig]
packageSpecificOptionsFieldDescrs =
- legacyPackageConfigFieldDescrs
- ++ programOptionsFieldDescrs
+ legacyPackageConfigFieldDescrs
+ ++ programOptionsFieldDescrs
(configProgramArgs . legacyConfigureFlags)
- (\args pkgconf -> pkgconf {
- legacyConfigureFlags = (legacyConfigureFlags pkgconf) {
- configProgramArgs = args
- }
- }
+ ( \args pkgconf ->
+ pkgconf
+ { legacyConfigureFlags =
+ (legacyConfigureFlags pkgconf)
+ { configProgramArgs = args
+ }
+ }
)
- ++ liftFields
+ ++ liftFields
legacyConfigureFlags
- (\flags pkgconf -> pkgconf {
- legacyConfigureFlags = flags
- }
+ ( \flags pkgconf ->
+ pkgconf
+ { legacyConfigureFlags = flags
+ }
)
programLocationsFieldDescrs
-- | The definition of the @package pkgfoo@ sections of the @cabal.project@-format
-- files. This section is per-package name. The special package @*@ applies to all
-- packages used anywhere by the project, locally or as dependencies.
---
packageSpecificOptionsSectionDescr :: SectionDescr LegacyProjectConfig
packageSpecificOptionsSectionDescr =
- SectionDescr {
- sectionName = "package",
- sectionFields = packageSpecificOptionsFieldDescrs,
- sectionSubsections = [],
- sectionGet = \projconf ->
- [ (prettyShow pkgname, pkgconf)
- | (pkgname, pkgconf) <-
- Map.toList . getMapMappend
- . legacySpecificConfig $ projconf ]
- ++ [ ("*", legacyAllConfig projconf) ],
- sectionSet =
+ SectionDescr
+ { sectionName = "package"
+ , sectionFields = packageSpecificOptionsFieldDescrs
+ , sectionSubsections = []
+ , sectionGet = \projconf ->
+ [ (prettyShow pkgname, pkgconf)
+ | (pkgname, pkgconf) <-
+ Map.toList
+ . getMapMappend
+ . legacySpecificConfig
+ $ projconf
+ ]
+ ++ [("*", legacyAllConfig projconf)]
+ , sectionSet =
\lineno pkgnamestr pkgconf projconf -> case pkgnamestr of
- "*" -> return projconf {
- legacyAllConfig = legacyAllConfig projconf <> pkgconf
- }
- _ -> do
+ "*" ->
+ return
+ projconf
+ { legacyAllConfig = legacyAllConfig projconf <> pkgconf
+ }
+ _ -> do
pkgname <- case simpleParsec pkgnamestr of
Just pkgname -> return pkgname
- Nothing -> syntaxError lineno $
- "a 'package' section requires a package name "
- ++ "as an argument"
- return projconf {
- legacySpecificConfig =
- MapMappend $
- Map.insertWith mappend pkgname pkgconf
- (getMapMappend $ legacySpecificConfig projconf)
- },
- sectionEmpty = mempty
+ Nothing ->
+ syntaxError lineno $
+ "a 'package' section requires a package name "
+ ++ "as an argument"
+ return
+ projconf
+ { legacySpecificConfig =
+ MapMappend $
+ Map.insertWith
+ mappend
+ pkgname
+ pkgconf
+ (getMapMappend $ legacySpecificConfig projconf)
+ }
+ , sectionEmpty = mempty
}
-programOptionsFieldDescrs :: (a -> [(String, [String])])
- -> ([(String, [String])] -> a -> a)
- -> [FieldDescr a]
+programOptionsFieldDescrs
+ :: (a -> [(String, [String])])
+ -> ([(String, [String])] -> a -> a)
+ -> [FieldDescr a]
programOptionsFieldDescrs get' set =
- commandOptionsToFields
- $ programDbOptions
+ commandOptionsToFields $
+ programDbOptions
defaultProgramDb
- ParseArgs get' set
+ ParseArgs
+ get'
+ set
programOptionsSectionDescr :: SectionDescr LegacyPackageConfig
programOptionsSectionDescr =
- SectionDescr {
- sectionName = "program-options",
- sectionFields = programOptionsFieldDescrs
- configProgramArgs
- (\args conf -> conf { configProgramArgs = args }),
- sectionSubsections = [],
- sectionGet = (\x->[("", x)])
- . legacyConfigureFlags,
- sectionSet =
+ SectionDescr
+ { sectionName = "program-options"
+ , sectionFields =
+ programOptionsFieldDescrs
+ configProgramArgs
+ (\args conf -> conf{configProgramArgs = args})
+ , sectionSubsections = []
+ , sectionGet =
+ (\x -> [("", x)])
+ . legacyConfigureFlags
+ , sectionSet =
\lineno unused confflags pkgconf -> do
unless (null unused) $
syntaxError lineno "the section 'program-options' takes no arguments"
- return pkgconf {
- legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
- },
- sectionEmpty = mempty
+ return
+ pkgconf
+ { legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
+ }
+ , sectionEmpty = mempty
}
programLocationsFieldDescrs :: [FieldDescr ConfigFlags]
programLocationsFieldDescrs =
- commandOptionsToFields
- $ programDbPaths'
- (++ "-location")
- defaultProgramDb
- ParseArgs
- configProgramPaths
- (\paths conf -> conf { configProgramPaths = paths })
+ commandOptionsToFields $
+ programDbPaths'
+ (++ "-location")
+ defaultProgramDb
+ ParseArgs
+ configProgramPaths
+ (\paths conf -> conf{configProgramPaths = paths})
programLocationsSectionDescr :: SectionDescr LegacyPackageConfig
programLocationsSectionDescr =
- SectionDescr {
- sectionName = "program-locations",
- sectionFields = programLocationsFieldDescrs,
- sectionSubsections = [],
- sectionGet = (\x->[("", x)])
- . legacyConfigureFlags,
- sectionSet =
+ SectionDescr
+ { sectionName = "program-locations"
+ , sectionFields = programLocationsFieldDescrs
+ , sectionSubsections = []
+ , sectionGet =
+ (\x -> [("", x)])
+ . legacyConfigureFlags
+ , sectionSet =
\lineno unused confflags pkgconf -> do
unless (null unused) $
syntaxError lineno "the section 'program-locations' takes no arguments"
- return pkgconf {
- legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
- },
- sectionEmpty = mempty
+ return
+ pkgconf
+ { legacyConfigureFlags = legacyConfigureFlags pkgconf <> confflags
+ }
+ , sectionEmpty = mempty
}
-
-- | For each known program @PROG@ in 'progDb', produce a @PROG-options@
-- 'OptionField'.
programDbOptions
@@ -1603,55 +1880,71 @@ programDbOptions
programDbOptions progDb showOrParseArgs get' set =
case showOrParseArgs of
-- we don't want a verbose help text list so we just show a generic one:
- ShowArgs -> [programOptions "PROG"]
- ParseArgs -> map (programOptions . programName . fst)
- (knownPrograms progDb)
+ ShowArgs -> [programOptions "PROG"]
+ ParseArgs ->
+ map
+ (programOptions . programName . fst)
+ (knownPrograms progDb)
where
programOptions prog =
- option "" [prog ++ "-options"]
+ option
+ ""
+ [prog ++ "-options"]
("give extra options to " ++ prog)
- get' set
- (reqArg' "OPTS" (\args -> [(prog, splitArgs args)])
- (\progArgs -> [ joinsArgs args
- | (prog', args) <- progArgs, prog==prog' ]))
-
+ get'
+ set
+ ( reqArg'
+ "OPTS"
+ (\args -> [(prog, splitArgs args)])
+ ( \progArgs ->
+ [ joinsArgs args
+ | (prog', args) <- progArgs
+ , prog == prog'
+ ]
+ )
+ )
joinsArgs = unwords . map escape
- escape arg | any isSpace arg = "\"" ++ arg ++ "\""
- | otherwise = arg
-
+ escape arg
+ | any isSpace arg = "\"" ++ arg ++ "\""
+ | otherwise = arg
-- The implementation is slight hack: we parse all as remote repository
-- but if the url schema is file+noindex, we switch to local.
remoteRepoSectionDescr :: SectionDescr GlobalFlags
-remoteRepoSectionDescr = SectionDescr
- { sectionName = "repository"
- , sectionEmpty = emptyRemoteRepo (RepoName "")
- , sectionFields = remoteRepoFields
+remoteRepoSectionDescr =
+ SectionDescr
+ { sectionName = "repository"
+ , sectionEmpty = emptyRemoteRepo (RepoName "")
+ , sectionFields = remoteRepoFields
, sectionSubsections = []
- , sectionGet = getS
- , sectionSet = setS
+ , sectionGet = getS
+ , sectionSet = setS
}
where
getS :: GlobalFlags -> [(String, RemoteRepo)]
getS gf =
- map (\x->(unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))
- ++
- map (\x->(unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))
+ map (\x -> (unRepoName $ remoteRepoName x, x)) (fromNubList (globalRemoteRepos gf))
+ ++ map (\x -> (unRepoName $ localRepoName x, localToRemote x)) (fromNubList (globalLocalNoIndexRepos gf))
setS :: Int -> String -> RemoteRepo -> GlobalFlags -> ParseResult GlobalFlags
setS lineno reponame repo0 conf = do
- repo1 <- postProcessRepo lineno reponame repo0
- case repo1 of
- Left repo -> return conf
- { globalLocalNoIndexRepos = overNubList (++[repo]) (globalLocalNoIndexRepos conf)
- }
- Right repo -> return conf
- { globalRemoteRepos = overNubList (++[repo]) (globalRemoteRepos conf)
- }
+ repo1 <- postProcessRepo lineno reponame repo0
+ case repo1 of
+ Left repo ->
+ return
+ conf
+ { globalLocalNoIndexRepos = overNubList (++ [repo]) (globalLocalNoIndexRepos conf)
+ }
+ Right repo ->
+ return
+ conf
+ { globalRemoteRepos = overNubList (++ [repo]) (globalRemoteRepos conf)
+ }
localToRemote :: LocalRepo -> RemoteRepo
- localToRemote (LocalRepo name path sharedCache) = (emptyRemoteRepo name)
+ localToRemote (LocalRepo name path sharedCache) =
+ (emptyRemoteRepo name)
{ remoteRepoURI = URI "file+noindex:" Nothing path "" (if sharedCache then "#shared-cache" else "")
}
@@ -1662,25 +1955,29 @@ remoteRepoSectionDescr = SectionDescr
-- | Parser combinator for simple fields which uses the field type's
-- 'Monoid' instance for combining multiple occurrences of the field.
monoidFieldParsec
- :: Monoid a => String -> (a -> Doc) -> ParsecParser a
- -> (b -> a) -> (a -> b -> b) -> FieldDescr b
+ :: Monoid a
+ => String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> a)
+ -> (a -> b -> b)
+ -> FieldDescr b
monoidFieldParsec name showF readF get' set =
liftField get' set' $ ParseUtils.fieldParsec name showF readF
where
set' xs b = set (get' b `mappend` xs) b
-
---TODO: [code cleanup] local redefinition that should replace the version in
+-- TODO: [code cleanup] local redefinition that should replace the version in
-- D.ParseUtils called showFilePath. This version escapes "." and "--" which
-- otherwise are special syntax.
showTokenQ :: String -> Doc
-showTokenQ "" = Disp.empty
-showTokenQ x@('-':'-':_) = Disp.text (show x)
-showTokenQ x@('.':[]) = Disp.text (show x)
-showTokenQ x = showToken x
-
+showTokenQ "" = Disp.empty
+showTokenQ x@('-' : '-' : _) = Disp.text (show x)
+showTokenQ x@('.' : []) = Disp.text (show x)
+showTokenQ x = showToken x
-- Handy util
-addFields :: [FieldDescr a]
- -> ([FieldDescr a] -> [FieldDescr a])
+addFields
+ :: [FieldDescr a]
+ -> ([FieldDescr a] -> [FieldDescr a])
addFields = (++)
diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
index 991551b95456f6d27878ffea9afb670f942812f4..f5f7c4f1514d64e13ed1b4142b7118996514536a 100644
--- a/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectConfig/Types.hs
@@ -1,69 +1,94 @@
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Handling project configuration, types.
---
-module Distribution.Client.ProjectConfig.Types (
-
- -- * Types for project config
- ProjectConfig(..),
- ProjectConfigBuildOnly(..),
- ProjectConfigShared(..),
- ProjectConfigProvenance(..),
- PackageConfig(..),
+module Distribution.Client.ProjectConfig.Types
+ ( -- * Types for project config
+ ProjectConfig (..)
+ , ProjectConfigBuildOnly (..)
+ , ProjectConfigShared (..)
+ , ProjectConfigProvenance (..)
+ , PackageConfig (..)
-- * Resolving configuration
- SolverSettings(..),
- BuildTimeSettings(..),
+ , SolverSettings (..)
+ , BuildTimeSettings (..)
-- * Extra useful Monoids
- MapLast(..),
- MapMappend(..),
+ , MapLast (..)
+ , MapMappend (..)
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.Types.Repo ( RemoteRepo, LocalRepo )
-import Distribution.Client.Types.AllowNewer ( AllowNewer(..), AllowOlder(..) )
-import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy ( WriteGhcEnvironmentFilesPolicy )
+import Distribution.Client.BuildReports.Types
+ ( ReportLevel (..)
+ )
import Distribution.Client.Dependency.Types
- ( PreSolver )
+ ( PreSolver
+ )
import Distribution.Client.Targets
- ( UserConstraint )
-import Distribution.Client.BuildReports.Types
- ( ReportLevel(..) )
+ ( UserConstraint
+ )
+import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..))
+import Distribution.Client.Types.Repo (LocalRepo, RemoteRepo)
import Distribution.Client.Types.SourceRepo (SourceRepoList)
+import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (WriteGhcEnvironmentFilesPolicy)
-import Distribution.Client.IndexUtils.IndexState
- ( TotalIndexState )
import Distribution.Client.IndexUtils.ActiveRepos
- ( ActiveRepos )
+ ( ActiveRepos
+ )
+import Distribution.Client.IndexUtils.IndexState
+ ( TotalIndexState
+ )
import Distribution.Client.CmdInstall.ClientInstallFlags
- ( ClientInstallFlags(..) )
+ ( ClientInstallFlags (..)
+ )
-import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.Settings
import Distribution.Package
- ( PackageName, PackageId, UnitId )
-import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint )
-import Distribution.Version
- ( Version )
-import Distribution.System
- ( Platform )
+ ( PackageId
+ , PackageName
+ , UnitId
+ )
import Distribution.PackageDescription
- ( FlagAssignment )
+ ( FlagAssignment
+ )
import Distribution.Simple.Compiler
- ( Compiler, CompilerFlavor, PackageDB
- , OptimisationLevel(..), ProfDetailLevel, DebugInfoLevel(..) )
-import Distribution.Simple.Setup
- ( Flag, HaddockTarget(..), TestShowDetails(..), DumpBuildInfo (..) )
+ ( Compiler
+ , CompilerFlavor
+ , DebugInfoLevel (..)
+ , OptimisationLevel (..)
+ , PackageDB
+ , ProfDetailLevel
+ )
import Distribution.Simple.InstallDirs
- ( PathTemplate, InstallDirs )
+ ( InstallDirs
+ , PathTemplate
+ )
+import Distribution.Simple.Setup
+ ( DumpBuildInfo (..)
+ , Flag
+ , HaddockTarget (..)
+ , TestShowDetails (..)
+ )
+import Distribution.System
+ ( Platform
+ )
+import Distribution.Types.PackageVersionConstraint
+ ( PackageVersionConstraint
+ )
import Distribution.Utils.NubList
- ( NubList )
+ ( NubList
+ )
+import Distribution.Version
+ ( Version
+ )
import qualified Data.Map as Map
@@ -87,223 +112,199 @@ import qualified Data.Map as Map
-- Future directions: multiple profiles, conditionals. If we add these
-- features then the gap between configuration as written in the config file
-- and resolved settings we actually use will become even bigger.
---
-data ProjectConfig
- = ProjectConfig {
-
- -- | Packages in this project, including local dirs, local .cabal files
- -- local and remote tarballs. When these are file globs, they must
- -- match at least one package.
- projectPackages :: [String],
-
- -- | Like 'projectConfigPackageGlobs' but /optional/ in the sense that
- -- file globs are allowed to match nothing. The primary use case for
- -- this is to be able to say @optional-packages: */@ to automagically
- -- pick up deps that we unpack locally without erroring when
- -- there aren't any.
- projectPackagesOptional :: [String],
-
- -- | Packages in this project from remote source repositories.
- projectPackagesRepo :: [SourceRepoList],
-
- -- | Packages in this project from hackage repositories.
- projectPackagesNamed :: [PackageVersionConstraint],
-
- -- See respective types for an explanation of what these
- -- values are about:
- projectConfigBuildOnly :: ProjectConfigBuildOnly,
- projectConfigShared :: ProjectConfigShared,
- projectConfigProvenance :: Set ProjectConfigProvenance,
-
- -- | Configuration to be applied to *all* packages,
- -- whether named in `cabal.project` or not.
- projectConfigAllPackages :: PackageConfig,
-
- -- | Configuration to be applied to *local* packages; i.e.,
- -- any packages which are explicitly named in `cabal.project`.
- projectConfigLocalPackages :: PackageConfig,
- projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
- }
+data ProjectConfig = ProjectConfig
+ { projectPackages :: [String]
+ -- ^ Packages in this project, including local dirs, local .cabal files
+ -- local and remote tarballs. When these are file globs, they must
+ -- match at least one package.
+ , projectPackagesOptional :: [String]
+ -- ^ Like 'projectConfigPackageGlobs' but /optional/ in the sense that
+ -- file globs are allowed to match nothing. The primary use case for
+ -- this is to be able to say @optional-packages: */@ to automagically
+ -- pick up deps that we unpack locally without erroring when
+ -- there aren't any.
+ , projectPackagesRepo :: [SourceRepoList]
+ -- ^ Packages in this project from remote source repositories.
+ , projectPackagesNamed :: [PackageVersionConstraint]
+ -- ^ Packages in this project from hackage repositories.
+ , -- See respective types for an explanation of what these
+ -- values are about:
+ projectConfigBuildOnly :: ProjectConfigBuildOnly
+ , projectConfigShared :: ProjectConfigShared
+ , projectConfigProvenance :: Set ProjectConfigProvenance
+ , projectConfigAllPackages :: PackageConfig
+ -- ^ Configuration to be applied to *all* packages,
+ -- whether named in `cabal.project` or not.
+ , projectConfigLocalPackages :: PackageConfig
+ -- ^ Configuration to be applied to *local* packages; i.e.,
+ -- any packages which are explicitly named in `cabal.project`.
+ , projectConfigSpecificPackage :: MapMappend PackageName PackageConfig
+ }
deriving (Eq, Show, Generic, Typeable)
-- | That part of the project configuration that only affects /how/ we build
-- and not the /value/ of the things we build. This means this information
-- does not need to be tracked for changes since it does not affect the
-- outcome.
---
-data ProjectConfigBuildOnly
- = ProjectConfigBuildOnly {
- projectConfigVerbosity :: Flag Verbosity,
- projectConfigDryRun :: Flag Bool,
- projectConfigOnlyDeps :: Flag Bool,
- projectConfigOnlyDownload :: Flag Bool,
- projectConfigSummaryFile :: NubList PathTemplate,
- projectConfigLogFile :: Flag PathTemplate,
- projectConfigBuildReports :: Flag ReportLevel,
- projectConfigReportPlanningFailure :: Flag Bool,
- projectConfigSymlinkBinDir :: Flag FilePath,
- projectConfigNumJobs :: Flag (Maybe Int),
- projectConfigKeepGoing :: Flag Bool,
- projectConfigOfflineMode :: Flag Bool,
- projectConfigKeepTempFiles :: Flag Bool,
- projectConfigHttpTransport :: Flag String,
- projectConfigIgnoreExpiry :: Flag Bool,
- projectConfigCacheDir :: Flag FilePath,
- projectConfigLogsDir :: Flag FilePath,
- projectConfigClientInstallFlags :: ClientInstallFlags
- }
+data ProjectConfigBuildOnly = ProjectConfigBuildOnly
+ { projectConfigVerbosity :: Flag Verbosity
+ , projectConfigDryRun :: Flag Bool
+ , projectConfigOnlyDeps :: Flag Bool
+ , projectConfigOnlyDownload :: Flag Bool
+ , projectConfigSummaryFile :: NubList PathTemplate
+ , projectConfigLogFile :: Flag PathTemplate
+ , projectConfigBuildReports :: Flag ReportLevel
+ , projectConfigReportPlanningFailure :: Flag Bool
+ , projectConfigSymlinkBinDir :: Flag FilePath
+ , projectConfigNumJobs :: Flag (Maybe Int)
+ , projectConfigKeepGoing :: Flag Bool
+ , projectConfigOfflineMode :: Flag Bool
+ , projectConfigKeepTempFiles :: Flag Bool
+ , projectConfigHttpTransport :: Flag String
+ , projectConfigIgnoreExpiry :: Flag Bool
+ , projectConfigCacheDir :: Flag FilePath
+ , projectConfigLogsDir :: Flag FilePath
+ , projectConfigClientInstallFlags :: ClientInstallFlags
+ }
deriving (Eq, Show, Generic)
-
-- | Project configuration that is shared between all packages in the project.
-- In particular this includes configuration that affects the solver.
---
-data ProjectConfigShared
- = ProjectConfigShared {
- projectConfigDistDir :: Flag FilePath,
- projectConfigConfigFile :: Flag FilePath,
- projectConfigProjectDir :: Flag FilePath,
- projectConfigProjectFile :: Flag FilePath,
- projectConfigIgnoreProject :: Flag Bool,
- projectConfigHcFlavor :: Flag CompilerFlavor,
- projectConfigHcPath :: Flag FilePath,
- projectConfigHcPkg :: Flag FilePath,
- projectConfigHaddockIndex :: Flag PathTemplate,
-
- -- Only makes sense for manual mode, not --local mode
- -- too much control!
- --projectConfigUserInstall :: Flag Bool,
-
- projectConfigInstallDirs :: InstallDirs (Flag PathTemplate),
- projectConfigPackageDBs :: [Maybe PackageDB],
-
- -- configuration used both by the solver and other phases
- projectConfigRemoteRepos :: NubList RemoteRepo, -- ^ Available Hackage servers.
- projectConfigLocalNoIndexRepos :: NubList LocalRepo,
- projectConfigActiveRepos :: Flag ActiveRepos,
- projectConfigIndexState :: Flag TotalIndexState,
- projectConfigStoreDir :: Flag FilePath,
-
- -- solver configuration
- projectConfigConstraints :: [(UserConstraint, ConstraintSource)],
- projectConfigPreferences :: [PackageVersionConstraint],
- projectConfigCabalVersion :: Flag Version, --TODO: [required eventually] unused
- projectConfigSolver :: Flag PreSolver,
- projectConfigAllowOlder :: Maybe AllowOlder,
- projectConfigAllowNewer :: Maybe AllowNewer,
- projectConfigWriteGhcEnvironmentFilesPolicy
- :: Flag WriteGhcEnvironmentFilesPolicy,
- projectConfigMaxBackjumps :: Flag Int,
- projectConfigReorderGoals :: Flag ReorderGoals,
- projectConfigCountConflicts :: Flag CountConflicts,
- projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts,
- projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet,
- projectConfigStrongFlags :: Flag StrongFlags,
- projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls,
- projectConfigOnlyConstrained :: Flag OnlyConstrained,
- projectConfigPerComponent :: Flag Bool,
- projectConfigIndependentGoals :: Flag IndependentGoals,
- projectConfigPreferOldest :: Flag PreferOldest,
-
- projectConfigProgPathExtra :: NubList FilePath
-
- -- More things that only make sense for manual mode, not --local mode
- -- too much control!
- --projectConfigShadowPkgs :: Flag Bool,
- --projectConfigReinstall :: Flag Bool,
- --projectConfigAvoidReinstalls :: Flag Bool,
- --projectConfigOverrideReinstall :: Flag Bool,
- --projectConfigUpgradeDeps :: Flag Bool
- }
+data ProjectConfigShared = ProjectConfigShared
+ { projectConfigDistDir :: Flag FilePath
+ , projectConfigConfigFile :: Flag FilePath
+ , projectConfigProjectDir :: Flag FilePath
+ , projectConfigProjectFile :: Flag FilePath
+ , projectConfigIgnoreProject :: Flag Bool
+ , projectConfigHcFlavor :: Flag CompilerFlavor
+ , projectConfigHcPath :: Flag FilePath
+ , projectConfigHcPkg :: Flag FilePath
+ , projectConfigHaddockIndex :: Flag PathTemplate
+ , -- Only makes sense for manual mode, not --local mode
+ -- too much control!
+ -- projectConfigUserInstall :: Flag Bool,
+
+ projectConfigInstallDirs :: InstallDirs (Flag PathTemplate)
+ , projectConfigPackageDBs :: [Maybe PackageDB]
+ , -- configuration used both by the solver and other phases
+ projectConfigRemoteRepos :: NubList RemoteRepo
+ -- ^ Available Hackage servers.
+ , projectConfigLocalNoIndexRepos :: NubList LocalRepo
+ , projectConfigActiveRepos :: Flag ActiveRepos
+ , projectConfigIndexState :: Flag TotalIndexState
+ , projectConfigStoreDir :: Flag FilePath
+ , -- solver configuration
+ projectConfigConstraints :: [(UserConstraint, ConstraintSource)]
+ , projectConfigPreferences :: [PackageVersionConstraint]
+ , projectConfigCabalVersion :: Flag Version -- TODO: [required eventually] unused
+ , projectConfigSolver :: Flag PreSolver
+ , projectConfigAllowOlder :: Maybe AllowOlder
+ , projectConfigAllowNewer :: Maybe AllowNewer
+ , projectConfigWriteGhcEnvironmentFilesPolicy
+ :: Flag WriteGhcEnvironmentFilesPolicy
+ , projectConfigMaxBackjumps :: Flag Int
+ , projectConfigReorderGoals :: Flag ReorderGoals
+ , projectConfigCountConflicts :: Flag CountConflicts
+ , projectConfigFineGrainedConflicts :: Flag FineGrainedConflicts
+ , projectConfigMinimizeConflictSet :: Flag MinimizeConflictSet
+ , projectConfigStrongFlags :: Flag StrongFlags
+ , projectConfigAllowBootLibInstalls :: Flag AllowBootLibInstalls
+ , projectConfigOnlyConstrained :: Flag OnlyConstrained
+ , projectConfigPerComponent :: Flag Bool
+ , projectConfigIndependentGoals :: Flag IndependentGoals
+ , projectConfigPreferOldest :: Flag PreferOldest
+ , projectConfigProgPathExtra :: NubList FilePath
+ -- More things that only make sense for manual mode, not --local mode
+ -- too much control!
+ -- projectConfigShadowPkgs :: Flag Bool,
+ -- projectConfigReinstall :: Flag Bool,
+ -- projectConfigAvoidReinstalls :: Flag Bool,
+ -- projectConfigOverrideReinstall :: Flag Bool,
+ -- projectConfigUpgradeDeps :: Flag Bool
+ }
deriving (Eq, Show, Generic)
-
-- | Specifies the provenance of project configuration, whether defaults were
-- used or if the configuration was read from an explicit file path.
data ProjectConfigProvenance
-
- -- | The configuration is implicit due to no explicit configuration
- -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig'
- -- for how implicit configuration is determined.
- = Implicit
-
- -- | The path the project configuration was explicitly read from.
- -- | The configuration was explicitly read from the specified 'FilePath'.
- | Explicit FilePath
+ = -- | The configuration is implicit due to no explicit configuration
+ -- being found. See 'Distribution.Client.ProjectConfig.readProjectConfig'
+ -- for how implicit configuration is determined.
+ Implicit
+ | -- | The path the project configuration was explicitly read from.
+ -- | The configuration was explicitly read from the specified 'FilePath'.
+ Explicit FilePath
deriving (Eq, Ord, Show, Generic)
-
-- | Project configuration that is specific to each package, that is where we
-- can in principle have different values for different packages in the same
-- project.
---
-data PackageConfig
- = PackageConfig {
- packageConfigProgramPaths :: MapLast String FilePath,
- packageConfigProgramArgs :: MapMappend String [String],
- packageConfigProgramPathExtra :: NubList FilePath,
- packageConfigFlagAssignment :: FlagAssignment,
- packageConfigVanillaLib :: Flag Bool,
- packageConfigSharedLib :: Flag Bool,
- packageConfigStaticLib :: Flag Bool,
- packageConfigDynExe :: Flag Bool,
- packageConfigFullyStaticExe :: Flag Bool,
- packageConfigProf :: Flag Bool, --TODO: [code cleanup] sort out
- packageConfigProfLib :: Flag Bool, -- this duplication
- packageConfigProfExe :: Flag Bool, -- and consistency
- packageConfigProfDetail :: Flag ProfDetailLevel,
- packageConfigProfLibDetail :: Flag ProfDetailLevel,
- packageConfigConfigureArgs :: [String],
- packageConfigOptimization :: Flag OptimisationLevel,
- packageConfigProgPrefix :: Flag PathTemplate,
- packageConfigProgSuffix :: Flag PathTemplate,
- packageConfigExtraLibDirs :: [FilePath],
- packageConfigExtraLibDirsStatic :: [FilePath],
- packageConfigExtraFrameworkDirs :: [FilePath],
- packageConfigExtraIncludeDirs :: [FilePath],
- packageConfigGHCiLib :: Flag Bool,
- packageConfigSplitSections :: Flag Bool,
- packageConfigSplitObjs :: Flag Bool,
- packageConfigStripExes :: Flag Bool,
- packageConfigStripLibs :: Flag Bool,
- packageConfigTests :: Flag Bool,
- packageConfigBenchmarks :: Flag Bool,
- packageConfigCoverage :: Flag Bool,
- packageConfigRelocatable :: Flag Bool,
- packageConfigDebugInfo :: Flag DebugInfoLevel,
- packageConfigDumpBuildInfo :: Flag DumpBuildInfo,
- packageConfigRunTests :: Flag Bool, --TODO: [required eventually] use this
- packageConfigDocumentation :: Flag Bool, --TODO: [required eventually] use this
- -- Haddock options
- packageConfigHaddockHoogle :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockHtml :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockHtmlLocation :: Flag String, --TODO: [required eventually] use this
- packageConfigHaddockForeignLibs :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockExecutables :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockTestSuites :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockBenchmarks :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockInternal :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockCss :: Flag FilePath, --TODO: [required eventually] use this
- packageConfigHaddockLinkedSource :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockQuickJump :: Flag Bool, --TODO: [required eventually] use this
- packageConfigHaddockHscolourCss :: Flag FilePath, --TODO: [required eventually] use this
- packageConfigHaddockContents :: Flag PathTemplate, --TODO: [required eventually] use this
- packageConfigHaddockIndex :: Flag PathTemplate, --TODO: [required eventually] use this
- packageConfigHaddockBaseUrl :: Flag String, --TODO: [required eventually] use this
- packageConfigHaddockLib :: Flag String, --TODO: [required eventually] use this
- packageConfigHaddockOutputDir :: Flag FilePath, --TODO: [required eventually] use this
- packageConfigHaddockForHackage :: Flag HaddockTarget,
- -- Test options
- packageConfigTestHumanLog :: Flag PathTemplate,
- packageConfigTestMachineLog :: Flag PathTemplate,
- packageConfigTestShowDetails :: Flag TestShowDetails,
- packageConfigTestKeepTix :: Flag Bool,
- packageConfigTestWrapper :: Flag FilePath,
- packageConfigTestFailWhenNoTestSuites :: Flag Bool,
- packageConfigTestTestOptions :: [PathTemplate],
- -- Benchmark options
- packageConfigBenchmarkOptions :: [PathTemplate]
- }
+data PackageConfig = PackageConfig
+ { packageConfigProgramPaths :: MapLast String FilePath
+ , packageConfigProgramArgs :: MapMappend String [String]
+ , packageConfigProgramPathExtra :: NubList FilePath
+ , packageConfigFlagAssignment :: FlagAssignment
+ , packageConfigVanillaLib :: Flag Bool
+ , packageConfigSharedLib :: Flag Bool
+ , packageConfigStaticLib :: Flag Bool
+ , packageConfigDynExe :: Flag Bool
+ , packageConfigFullyStaticExe :: Flag Bool
+ , packageConfigProf :: Flag Bool -- TODO: [code cleanup] sort out
+ , packageConfigProfLib :: Flag Bool -- this duplication
+ , packageConfigProfExe :: Flag Bool -- and consistency
+ , packageConfigProfDetail :: Flag ProfDetailLevel
+ , packageConfigProfLibDetail :: Flag ProfDetailLevel
+ , packageConfigConfigureArgs :: [String]
+ , packageConfigOptimization :: Flag OptimisationLevel
+ , packageConfigProgPrefix :: Flag PathTemplate
+ , packageConfigProgSuffix :: Flag PathTemplate
+ , packageConfigExtraLibDirs :: [FilePath]
+ , packageConfigExtraLibDirsStatic :: [FilePath]
+ , packageConfigExtraFrameworkDirs :: [FilePath]
+ , packageConfigExtraIncludeDirs :: [FilePath]
+ , packageConfigGHCiLib :: Flag Bool
+ , packageConfigSplitSections :: Flag Bool
+ , packageConfigSplitObjs :: Flag Bool
+ , packageConfigStripExes :: Flag Bool
+ , packageConfigStripLibs :: Flag Bool
+ , packageConfigTests :: Flag Bool
+ , packageConfigBenchmarks :: Flag Bool
+ , packageConfigCoverage :: Flag Bool
+ , packageConfigRelocatable :: Flag Bool
+ , packageConfigDebugInfo :: Flag DebugInfoLevel
+ , packageConfigDumpBuildInfo :: Flag DumpBuildInfo
+ , packageConfigRunTests :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigDocumentation :: Flag Bool -- TODO: [required eventually] use this
+ -- Haddock options
+ , packageConfigHaddockHoogle :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockHtml :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockHtmlLocation :: Flag String -- TODO: [required eventually] use this
+ , packageConfigHaddockForeignLibs :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockExecutables :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockTestSuites :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockBenchmarks :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockInternal :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockCss :: Flag FilePath -- TODO: [required eventually] use this
+ , packageConfigHaddockLinkedSource :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockQuickJump :: Flag Bool -- TODO: [required eventually] use this
+ , packageConfigHaddockHscolourCss :: Flag FilePath -- TODO: [required eventually] use this
+ , packageConfigHaddockContents :: Flag PathTemplate -- TODO: [required eventually] use this
+ , packageConfigHaddockIndex :: Flag PathTemplate -- TODO: [required eventually] use this
+ , packageConfigHaddockBaseUrl :: Flag String -- TODO: [required eventually] use this
+ , packageConfigHaddockLib :: Flag String -- TODO: [required eventually] use this
+ , packageConfigHaddockOutputDir :: Flag FilePath -- TODO: [required eventually] use this
+ , packageConfigHaddockForHackage :: Flag HaddockTarget
+ , -- Test options
+ packageConfigTestHumanLog :: Flag PathTemplate
+ , packageConfigTestMachineLog :: Flag PathTemplate
+ , packageConfigTestShowDetails :: Flag TestShowDetails
+ , packageConfigTestKeepTix :: Flag Bool
+ , packageConfigTestWrapper :: Flag FilePath
+ , packageConfigTestFailWhenNoTestSuites :: Flag Bool
+ , packageConfigTestTestOptions :: [PathTemplate]
+ , -- Benchmark options
+ packageConfigBenchmarkOptions :: [PathTemplate]
+ }
deriving (Eq, Show, Generic)
instance Binary ProjectConfig
@@ -320,35 +321,35 @@ instance Structured PackageConfig
-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that takes
-- the last value rather than the first value for overlapping keys.
-newtype MapLast k v = MapLast { getMapLast :: Map k v }
+newtype MapLast k v = MapLast {getMapLast :: Map k v}
deriving (Eq, Show, Functor, Generic, Binary, Typeable)
instance (Structured k, Structured v) => Structured (MapLast k v)
instance Ord k => Monoid (MapLast k v) where
- mempty = MapLast Map.empty
+ mempty = MapLast Map.empty
mappend = (<>)
instance Ord k => Semigroup (MapLast k v) where
MapLast a <> MapLast b = MapLast $ Map.union b a
- -- rather than Map.union which is the normal Map monoid instance
+-- rather than Map.union which is the normal Map monoid instance
-- | Newtype wrapper for 'Map' that provides a 'Monoid' instance that
-- 'mappend's values of overlapping keys rather than taking the first.
-newtype MapMappend k v = MapMappend { getMapMappend :: Map k v }
+newtype MapMappend k v = MapMappend {getMapMappend :: Map k v}
deriving (Eq, Show, Functor, Generic, Binary, Typeable)
instance (Structured k, Structured v) => Structured (MapMappend k v)
instance (Semigroup v, Ord k) => Monoid (MapMappend k v) where
- mempty = MapMappend Map.empty
+ mempty = MapMappend Map.empty
mappend = (<>)
instance (Semigroup v, Ord k) => Semigroup (MapMappend k v) where
MapMappend a <> MapMappend b = MapMappend (Map.unionWith (<>) a b)
- -- rather than Map.union which is the normal Map monoid instance
+-- rather than Map.union which is the normal Map monoid instance
instance Monoid ProjectConfig where
mempty = gmempty
@@ -357,7 +358,6 @@ instance Monoid ProjectConfig where
instance Semigroup ProjectConfig where
(<>) = gmappend
-
instance Monoid ProjectConfigBuildOnly where
mempty = gmempty
mappend = (<>)
@@ -365,7 +365,6 @@ instance Monoid ProjectConfigBuildOnly where
instance Semigroup ProjectConfigBuildOnly where
(<>) = gmappend
-
instance Monoid ProjectConfigShared where
mempty = gmempty
mappend = (<>)
@@ -373,7 +372,6 @@ instance Monoid ProjectConfigShared where
instance Semigroup ProjectConfigShared where
(<>) = gmappend
-
instance Monoid PackageConfig where
mempty = gmempty
mappend = (<>)
@@ -392,45 +390,44 @@ instance Semigroup PackageConfig where
--
-- Use 'resolveSolverSettings' to make one from the project config (by
-- applying defaults etc).
---
-data SolverSettings
- = SolverSettings {
- solverSettingRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers.
- solverSettingLocalNoIndexRepos :: [LocalRepo],
- solverSettingConstraints :: [(UserConstraint, ConstraintSource)],
- solverSettingPreferences :: [PackageVersionConstraint],
- solverSettingFlagAssignment :: FlagAssignment, -- ^ For all local packages
- solverSettingFlagAssignments :: Map PackageName FlagAssignment,
- solverSettingCabalVersion :: Maybe Version, --TODO: [required eventually] unused
- solverSettingSolver :: PreSolver,
- solverSettingAllowOlder :: AllowOlder,
- solverSettingAllowNewer :: AllowNewer,
- solverSettingMaxBackjumps :: Maybe Int,
- solverSettingReorderGoals :: ReorderGoals,
- solverSettingCountConflicts :: CountConflicts,
- solverSettingFineGrainedConflicts :: FineGrainedConflicts,
- solverSettingMinimizeConflictSet :: MinimizeConflictSet,
- solverSettingStrongFlags :: StrongFlags,
- solverSettingAllowBootLibInstalls :: AllowBootLibInstalls,
- solverSettingOnlyConstrained :: OnlyConstrained,
- solverSettingIndexState :: Maybe TotalIndexState,
- solverSettingActiveRepos :: Maybe ActiveRepos,
- solverSettingIndependentGoals :: IndependentGoals,
- solverSettingPreferOldest :: PreferOldest
- -- Things that only make sense for manual mode, not --local mode
- -- too much control!
- --solverSettingShadowPkgs :: Bool,
- --solverSettingReinstall :: Bool,
- --solverSettingAvoidReinstalls :: Bool,
- --solverSettingOverrideReinstall :: Bool,
- --solverSettingUpgradeDeps :: Bool
- }
+data SolverSettings = SolverSettings
+ { solverSettingRemoteRepos :: [RemoteRepo]
+ -- ^ Available Hackage servers.
+ , solverSettingLocalNoIndexRepos :: [LocalRepo]
+ , solverSettingConstraints :: [(UserConstraint, ConstraintSource)]
+ , solverSettingPreferences :: [PackageVersionConstraint]
+ , solverSettingFlagAssignment :: FlagAssignment
+ -- ^ For all local packages
+ , solverSettingFlagAssignments :: Map PackageName FlagAssignment
+ , solverSettingCabalVersion :: Maybe Version -- TODO: [required eventually] unused
+ , solverSettingSolver :: PreSolver
+ , solverSettingAllowOlder :: AllowOlder
+ , solverSettingAllowNewer :: AllowNewer
+ , solverSettingMaxBackjumps :: Maybe Int
+ , solverSettingReorderGoals :: ReorderGoals
+ , solverSettingCountConflicts :: CountConflicts
+ , solverSettingFineGrainedConflicts :: FineGrainedConflicts
+ , solverSettingMinimizeConflictSet :: MinimizeConflictSet
+ , solverSettingStrongFlags :: StrongFlags
+ , solverSettingAllowBootLibInstalls :: AllowBootLibInstalls
+ , solverSettingOnlyConstrained :: OnlyConstrained
+ , solverSettingIndexState :: Maybe TotalIndexState
+ , solverSettingActiveRepos :: Maybe ActiveRepos
+ , solverSettingIndependentGoals :: IndependentGoals
+ , solverSettingPreferOldest :: PreferOldest
+ -- Things that only make sense for manual mode, not --local mode
+ -- too much control!
+ -- solverSettingShadowPkgs :: Bool,
+ -- solverSettingReinstall :: Bool,
+ -- solverSettingAvoidReinstalls :: Bool,
+ -- solverSettingOverrideReinstall :: Bool,
+ -- solverSettingUpgradeDeps :: Bool
+ }
deriving (Eq, Show, Generic, Typeable)
instance Binary SolverSettings
instance Structured SolverSettings
-
-- | Resolved configuration for things that affect how we build and not the
-- value of the things we build. The idea is that this is easier to use than
-- the raw configuration because in the raw configuration everything is
@@ -439,29 +436,32 @@ instance Structured SolverSettings
--
-- Use 'resolveBuildTimeSettings' to make one from the project config (by
-- applying defaults etc).
---
-data BuildTimeSettings
- = BuildTimeSettings {
- buildSettingDryRun :: Bool,
- buildSettingOnlyDeps :: Bool,
- buildSettingOnlyDownload :: Bool,
- buildSettingSummaryFile :: [PathTemplate],
- buildSettingLogFile :: Maybe (Compiler -> Platform
- -> PackageId -> UnitId
- -> FilePath),
- buildSettingLogVerbosity :: Verbosity,
- buildSettingBuildReports :: ReportLevel,
- buildSettingReportPlanningFailure :: Bool,
- buildSettingSymlinkBinDir :: [FilePath],
- buildSettingNumJobs :: Int,
- buildSettingKeepGoing :: Bool,
- buildSettingOfflineMode :: Bool,
- buildSettingKeepTempFiles :: Bool,
- buildSettingRemoteRepos :: [RemoteRepo],
- buildSettingLocalNoIndexRepos :: [LocalRepo],
- buildSettingCacheDir :: FilePath,
- buildSettingHttpTransport :: Maybe String,
- buildSettingIgnoreExpiry :: Bool,
- buildSettingProgPathExtra :: [FilePath],
- buildSettingHaddockOpen :: Bool
- }
+data BuildTimeSettings = BuildTimeSettings
+ { buildSettingDryRun :: Bool
+ , buildSettingOnlyDeps :: Bool
+ , buildSettingOnlyDownload :: Bool
+ , buildSettingSummaryFile :: [PathTemplate]
+ , buildSettingLogFile
+ :: Maybe
+ ( Compiler
+ -> Platform
+ -> PackageId
+ -> UnitId
+ -> FilePath
+ )
+ , buildSettingLogVerbosity :: Verbosity
+ , buildSettingBuildReports :: ReportLevel
+ , buildSettingReportPlanningFailure :: Bool
+ , buildSettingSymlinkBinDir :: [FilePath]
+ , buildSettingNumJobs :: Int
+ , buildSettingKeepGoing :: Bool
+ , buildSettingOfflineMode :: Bool
+ , buildSettingKeepTempFiles :: Bool
+ , buildSettingRemoteRepos :: [RemoteRepo]
+ , buildSettingLocalNoIndexRepos :: [LocalRepo]
+ , buildSettingCacheDir :: FilePath
+ , buildSettingHttpTransport :: Maybe String
+ , buildSettingIgnoreExpiry :: Bool
+ , buildSettingProgPathExtra :: [FilePath]
+ , buildSettingHaddockOpen :: Bool
+ }
diff --git a/cabal-install/src/Distribution/Client/ProjectFlags.hs b/cabal-install/src/Distribution/Client/ProjectFlags.hs
index 8959f60aefc4913a0fe44c92ddc68f8e8e0795f2..a18814a034b1d1bd5392da5e5bb62b280218b1ee 100644
--- a/cabal-install/src/Distribution/Client/ProjectFlags.hs
+++ b/cabal-install/src/Distribution/Client/ProjectFlags.hs
@@ -1,71 +1,85 @@
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-module Distribution.Client.ProjectFlags (
- ProjectFlags(..),
- defaultProjectFlags,
- projectFlagsOptions,
- removeIgnoreProjectOption,
-) where
+
+module Distribution.Client.ProjectFlags
+ ( ProjectFlags (..)
+ , defaultProjectFlags
+ , projectFlagsOptions
+ , removeIgnoreProjectOption
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.ReadE (succeedReadE)
+import Distribution.ReadE (succeedReadE)
import Distribution.Simple.Command
- ( MkOptDescr, OptionField(optionName), ShowOrParseArgs (..), boolOpt', option
- , reqArg )
-import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)
+ ( MkOptDescr
+ , OptionField (optionName)
+ , ShowOrParseArgs (..)
+ , boolOpt'
+ , option
+ , reqArg
+ )
+import Distribution.Simple.Setup (Flag (..), flagToList, flagToMaybe, toFlag, trueArg)
data ProjectFlags = ProjectFlags
- { flagProjectDir :: Flag FilePath
- -- ^ The project directory.
-
- , flagProjectFile :: Flag FilePath
- -- ^ The cabal project file path; defaults to @cabal.project@.
- -- This path, when relative, is relative to the project directory.
- -- The filename portion of the path denotes the cabal project file name, but it also
- -- is the base of auxiliary project files, such as
- -- @cabal.project.local@ and @cabal.project.freeze@ which are also
- -- read and written out in some cases.
- -- If a project directory was not specified, and the path is not found
- -- in the current working directory, we will successively probe
- -- relative to parent directories until this name is found.
-
- , flagIgnoreProject :: Flag Bool
- -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)
- -- The exact interpretation might be slightly different per command.
- }
+ { flagProjectDir :: Flag FilePath
+ -- ^ The project directory.
+ , flagProjectFile :: Flag FilePath
+ -- ^ The cabal project file path; defaults to @cabal.project@.
+ -- This path, when relative, is relative to the project directory.
+ -- The filename portion of the path denotes the cabal project file name, but it also
+ -- is the base of auxiliary project files, such as
+ -- @cabal.project.local@ and @cabal.project.freeze@ which are also
+ -- read and written out in some cases.
+ -- If a project directory was not specified, and the path is not found
+ -- in the current working directory, we will successively probe
+ -- relative to parent directories until this name is found.
+ , flagIgnoreProject :: Flag Bool
+ -- ^ Whether to ignore the local project (i.e. don't search for cabal.project)
+ -- The exact interpretation might be slightly different per command.
+ }
deriving (Show, Generic)
defaultProjectFlags :: ProjectFlags
-defaultProjectFlags = ProjectFlags
- { flagProjectDir = mempty
- , flagProjectFile = mempty
- , flagIgnoreProject = toFlag False
- -- Should we use 'Last' here?
+defaultProjectFlags =
+ ProjectFlags
+ { flagProjectDir = mempty
+ , flagProjectFile = mempty
+ , flagIgnoreProject = toFlag False
+ -- Should we use 'Last' here?
}
projectFlagsOptions :: ShowOrParseArgs -> [OptionField ProjectFlags]
projectFlagsOptions showOrParseArgs =
- [ option [] ["project-dir"]
- "Set the path of the project directory"
- flagProjectDir (\path flags -> flags { flagProjectDir = path })
- (reqArg "DIR" (succeedReadE Flag) flagToList)
- , option [] ["project-file"]
- "Set the path of the cabal.project file (relative to the project directory when relative)"
- flagProjectFile (\pf flags -> flags { flagProjectFile = pf })
- (reqArg "FILE" (succeedReadE Flag) flagToList)
- , option ['z'] ["ignore-project"]
- "Ignore local project configuration (unless --project-dir or --project-file is also set)"
- flagIgnoreProject
- (\v flags -> flags
- { flagIgnoreProject = case v of
- Flag True -> toFlag (flagProjectDir flags == NoFlag && flagProjectFile flags == NoFlag)
- _ -> v
- }
- )
- (yesNoOpt showOrParseArgs)
- ]
+ [ option
+ []
+ ["project-dir"]
+ "Set the path of the project directory"
+ flagProjectDir
+ (\path flags -> flags{flagProjectDir = path})
+ (reqArg "DIR" (succeedReadE Flag) flagToList)
+ , option
+ []
+ ["project-file"]
+ "Set the path of the cabal.project file (relative to the project directory when relative)"
+ flagProjectFile
+ (\pf flags -> flags{flagProjectFile = pf})
+ (reqArg "FILE" (succeedReadE Flag) flagToList)
+ , option
+ ['z']
+ ["ignore-project"]
+ "Ignore local project configuration (unless --project-dir or --project-file is also set)"
+ flagIgnoreProject
+ ( \v flags ->
+ flags
+ { flagIgnoreProject = case v of
+ Flag True -> toFlag (flagProjectDir flags == NoFlag && flagProjectFile flags == NoFlag)
+ _ -> v
+ }
+ )
+ (yesNoOpt showOrParseArgs)
+ ]
-- | As almost all commands use 'ProjectFlags' but not all can honour
-- "ignore-project" flag, provide this utility to remove the flag
@@ -74,12 +88,12 @@ removeIgnoreProjectOption :: [OptionField a] -> [OptionField a]
removeIgnoreProjectOption = filter (\o -> optionName o /= "ignore-project")
instance Monoid ProjectFlags where
- mempty = gmempty
- mappend = (<>)
+ mempty = gmempty
+ mappend = (<>)
instance Semigroup ProjectFlags where
- (<>) = gmappend
+ (<>) = gmappend
yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
yesNoOpt ShowArgs sf lf = trueArg sf lf
-yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
+yesNoOpt _ sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
diff --git a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
index 1adf2ed06a0e6e4712e1e3b7243dd8a99a76730b..4c56d3beeb85858655d2529c9a62af451a5645f6 100644
--- a/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
+++ b/cabal-install/src/Distribution/Client/ProjectOrchestration.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | This module deals with building and incrementally rebuilding a collection
-- of packages. It is what backs the @cabal build@ and @configure@ commands,
@@ -38,323 +40,363 @@
-- first phase. Also, the second phase does not have direct access to any of
-- the input configuration anyway; all the information has to flow via the
-- 'ElaboratedInstallPlan'.
---
-module Distribution.Client.ProjectOrchestration (
- -- * Discovery phase: what is in the project?
- CurrentCommand(..),
- establishProjectBaseContext,
- establishProjectBaseContextWithRoot,
- ProjectBaseContext(..),
- BuildTimeSettings(..),
- commandLineFlagsToProjectConfig,
+module Distribution.Client.ProjectOrchestration
+ ( -- * Discovery phase: what is in the project?
+ CurrentCommand (..)
+ , establishProjectBaseContext
+ , establishProjectBaseContextWithRoot
+ , ProjectBaseContext (..)
+ , BuildTimeSettings (..)
+ , commandLineFlagsToProjectConfig
-- * Pre-build phase: decide what to do.
- withInstallPlan,
- runProjectPreBuildPhase,
- ProjectBuildContext(..),
+ , withInstallPlan
+ , runProjectPreBuildPhase
+ , ProjectBuildContext (..)
-- ** Selecting what targets we mean
- readTargetSelectors,
- reportTargetSelectorProblems,
- resolveTargets,
- TargetsMap,
- allTargetSelectors,
- uniqueTargetSelectors,
- TargetSelector(..),
- TargetImplicitCwd(..),
- PackageId,
- AvailableTarget(..),
- AvailableTargetStatus(..),
- TargetRequested(..),
- ComponentName(..),
- ComponentKind(..),
- ComponentTarget(..),
- SubComponentTarget(..),
- selectComponentTargetBasic,
- distinctTargetComponents,
+ , readTargetSelectors
+ , reportTargetSelectorProblems
+ , resolveTargets
+ , TargetsMap
+ , allTargetSelectors
+ , uniqueTargetSelectors
+ , TargetSelector (..)
+ , TargetImplicitCwd (..)
+ , PackageId
+ , AvailableTarget (..)
+ , AvailableTargetStatus (..)
+ , TargetRequested (..)
+ , ComponentName (..)
+ , ComponentKind (..)
+ , ComponentTarget (..)
+ , SubComponentTarget (..)
+ , selectComponentTargetBasic
+ , distinctTargetComponents
+
-- ** Utils for selecting targets
- filterTargetsKind,
- filterTargetsKindWith,
- selectBuildableTargets,
- selectBuildableTargetsWith,
- selectBuildableTargets',
- selectBuildableTargetsWith',
- forgetTargetsDetail,
+ , filterTargetsKind
+ , filterTargetsKindWith
+ , selectBuildableTargets
+ , selectBuildableTargetsWith
+ , selectBuildableTargets'
+ , selectBuildableTargetsWith'
+ , forgetTargetsDetail
-- ** Adjusting the plan
- pruneInstallPlanToTargets,
- TargetAction(..),
- pruneInstallPlanToDependencies,
- CannotPruneDependencies(..),
- printPlan,
+ , pruneInstallPlanToTargets
+ , TargetAction (..)
+ , pruneInstallPlanToDependencies
+ , CannotPruneDependencies (..)
+ , printPlan
-- * Build phase: now do it.
- runProjectBuildPhase,
+ , runProjectBuildPhase
-- * Post build actions
- runProjectPostBuildPhase,
- dieOnBuildFailures,
+ , runProjectPostBuildPhase
+ , dieOnBuildFailures
-- * Dummy projects
- establishDummyProjectBaseContext,
- establishDummyDistDirLayout,
+ , establishDummyProjectBaseContext
+ , establishDummyDistDirLayout
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Compat.Directory
- ( makeAbsolute )
+ ( makeAbsolute
+ )
+import Prelude ()
-import Distribution.Client.ProjectConfig
-import Distribution.Client.ProjectPlanning
- hiding ( pruneInstallPlanToTargets )
+import Distribution.Client.ProjectBuilding
+import Distribution.Client.ProjectConfig
+import Distribution.Client.ProjectPlanOutput
+import Distribution.Client.ProjectPlanning hiding
+ ( pruneInstallPlanToTargets
+ )
import qualified Distribution.Client.ProjectPlanning as ProjectPlanning
- ( pruneInstallPlanToTargets )
-import Distribution.Client.ProjectPlanning.Types
-import Distribution.Client.ProjectBuilding
-import Distribution.Client.ProjectPlanOutput
-
-import Distribution.Client.TargetProblem
- ( TargetProblem (..) )
-import Distribution.Client.Types
- ( GenericReadyPackage(..), UnresolvedSourcePackage
- , PackageSpecifier(..)
- , SourcePackageDb(..)
- , WriteGhcEnvironmentFilesPolicy(..)
- , PackageLocation(..)
- , DocsResult(..)
- , TestsResult(..) )
-import Distribution.Solver.Types.PackageIndex
- ( lookupPackageName )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.TargetSelector
- ( TargetSelector(..), TargetImplicitCwd(..)
- , ComponentKind(..), componentKind
- , readTargetSelectors, reportTargetSelectorProblems )
-import Distribution.Client.DistDirLayout
+ ( pruneInstallPlanToTargets
+ )
+import Distribution.Client.ProjectPlanning.Types
-import Distribution.Client.BuildReports.Anonymous (cabalInstallID)
+import Distribution.Client.DistDirLayout
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.TargetProblem
+ ( TargetProblem (..)
+ )
+import Distribution.Client.TargetSelector
+ ( ComponentKind (..)
+ , TargetImplicitCwd (..)
+ , TargetSelector (..)
+ , componentKind
+ , readTargetSelectors
+ , reportTargetSelectorProblems
+ )
+import Distribution.Client.Types
+ ( DocsResult (..)
+ , GenericReadyPackage (..)
+ , PackageLocation (..)
+ , PackageSpecifier (..)
+ , SourcePackageDb (..)
+ , TestsResult (..)
+ , UnresolvedSourcePackage
+ , WriteGhcEnvironmentFilesPolicy (..)
+ )
+import Distribution.Solver.Types.PackageIndex
+ ( lookupPackageName
+ )
+
+import Distribution.Client.BuildReports.Anonymous (cabalInstallID)
import qualified Distribution.Client.BuildReports.Anonymous as BuildReports
import qualified Distribution.Client.BuildReports.Storage as BuildReports
- ( storeLocal )
-
-import Distribution.Client.HttpUtils
-import Distribution.Client.Setup hiding (packageName)
-import Distribution.Compiler
- ( CompilerFlavor(GHC) )
-import Distribution.Types.ComponentName
- ( componentNameString )
-import Distribution.Types.InstalledPackageInfo
- ( InstalledPackageInfo )
-import Distribution.Types.UnqualComponentName
- ( UnqualComponentName, packageNameToUnqualComponentName )
-
-import Distribution.Solver.Types.OptionalStanza
-
-import Distribution.Package
-import Distribution.Types.Flag
- ( FlagAssignment, showFlagAssignment, diffFlagAssignment )
-import Distribution.Simple.LocalBuildInfo
- ( ComponentName(..), pkgComponents )
-import Distribution.Simple.Flag
- ( fromFlagOrDefault, flagToMaybe )
+ ( storeLocal
+ )
+
+import Distribution.Client.HttpUtils
+import Distribution.Client.Setup hiding (packageName)
+import Distribution.Compiler
+ ( CompilerFlavor (GHC)
+ )
+import Distribution.Types.ComponentName
+ ( componentNameString
+ )
+import Distribution.Types.InstalledPackageInfo
+ ( InstalledPackageInfo
+ )
+import Distribution.Types.UnqualComponentName
+ ( UnqualComponentName
+ , packageNameToUnqualComponentName
+ )
+
+import Distribution.Solver.Types.OptionalStanza
+
+import Distribution.Package
+import Distribution.Simple.Command (commandShowOptions)
+import Distribution.Simple.Compiler
+ ( OptimisationLevel (..)
+ , compilerCompatVersion
+ , compilerId
+ , compilerInfo
+ , showCompilerId
+ )
+import Distribution.Simple.Configure (computeEffectiveProfiling)
+import Distribution.Simple.Flag
+ ( flagToMaybe
+ , fromFlagOrDefault
+ )
+import Distribution.Simple.LocalBuildInfo
+ ( ComponentName (..)
+ , pkgComponents
+ )
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.Setup as Setup
-import Distribution.Simple.Command (commandShowOptions)
-import Distribution.Simple.Configure (computeEffectiveProfiling)
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import Distribution.Simple.Utils
- ( die', warn, notice, noticeNoWrap, debugNoWrap, createDirectoryIfMissingVerbose, ordNub )
-import Distribution.Verbosity
-import Distribution.Version
- ( mkVersion )
-import Distribution.Simple.Compiler
- ( compilerCompatVersion, showCompilerId, compilerId, compilerInfo
- , OptimisationLevel(..))
-import Distribution.Utils.NubList
- ( fromNubList )
-import Distribution.System
- ( Platform(Platform) )
-
+import Distribution.Simple.Utils
+ ( createDirectoryIfMissingVerbose
+ , debugNoWrap
+ , die'
+ , notice
+ , noticeNoWrap
+ , ordNub
+ , warn
+ )
+import Distribution.System
+ ( Platform (Platform)
+ )
+import Distribution.Types.Flag
+ ( FlagAssignment
+ , diffFlagAssignment
+ , showFlagAssignment
+ )
+import Distribution.Utils.NubList
+ ( fromNubList
+ )
+import Distribution.Verbosity
+import Distribution.Version
+ ( mkVersion
+ )
+
+import Control.Exception (assert)
import qualified Data.List.NonEmpty as NE
-import qualified Data.Set as Set
import qualified Data.Map as Map
-import Control.Exception ( assert )
+import qualified Data.Set as Set
#ifdef MIN_VERSION_unix
import System.Posix.Signals (sigKILL, sigSEGV)
#endif
-
-- | Tracks what command is being executed, because we need to hide this somewhere
-- for cases that need special handling (usually for error reporting).
data CurrentCommand = InstallCommand | HaddockCommand | BuildCommand | ReplCommand | OtherCommand
- deriving (Show, Eq)
+ deriving (Show, Eq)
-- | This holds the context of a project prior to solving: the content of the
-- @cabal.project@ and all the local package @.cabal@ files.
---
-data ProjectBaseContext = ProjectBaseContext {
- distDirLayout :: DistDirLayout,
- cabalDirLayout :: CabalDirLayout,
- projectConfig :: ProjectConfig,
- localPackages :: [PackageSpecifier UnresolvedSourcePackage],
- buildSettings :: BuildTimeSettings,
- currentCommand :: CurrentCommand,
- installedPackages :: Maybe InstalledPackageIndex
- }
+data ProjectBaseContext = ProjectBaseContext
+ { distDirLayout :: DistDirLayout
+ , cabalDirLayout :: CabalDirLayout
+ , projectConfig :: ProjectConfig
+ , localPackages :: [PackageSpecifier UnresolvedSourcePackage]
+ , buildSettings :: BuildTimeSettings
+ , currentCommand :: CurrentCommand
+ , installedPackages :: Maybe InstalledPackageIndex
+ }
establishProjectBaseContext
- :: Verbosity
- -> ProjectConfig
- -> CurrentCommand
- -> IO ProjectBaseContext
+ :: Verbosity
+ -> ProjectConfig
+ -> CurrentCommand
+ -> IO ProjectBaseContext
establishProjectBaseContext verbosity cliConfig currentCommand = do
- projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
- establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand
+ projectRoot <- either throwIO return =<< findProjectRoot verbosity mprojectDir mprojectFile
+ establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand
where
- mprojectDir = Setup.flagToMaybe projectConfigProjectDir
- mprojectFile = Setup.flagToMaybe projectConfigProjectFile
- ProjectConfigShared { projectConfigProjectDir, projectConfigProjectFile } = projectConfigShared cliConfig
+ mprojectDir = Setup.flagToMaybe projectConfigProjectDir
+ mprojectFile = Setup.flagToMaybe projectConfigProjectFile
+ ProjectConfigShared{projectConfigProjectDir, projectConfigProjectFile} = projectConfigShared cliConfig
-- | Like 'establishProjectBaseContext' but doesn't search for project root.
establishProjectBaseContextWithRoot
- :: Verbosity
- -> ProjectConfig
- -> ProjectRoot
- -> CurrentCommand
- -> IO ProjectBaseContext
+ :: Verbosity
+ -> ProjectConfig
+ -> ProjectRoot
+ -> CurrentCommand
+ -> IO ProjectBaseContext
establishProjectBaseContextWithRoot verbosity cliConfig projectRoot currentCommand = do
- let haddockOutputDir = flagToMaybe (packageConfigHaddockOutputDir (projectConfigLocalPackages cliConfig))
- let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir
-
- httpTransport <- configureTransport verbosity
- (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
- (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
-
- (projectConfig, localPackages) <-
- rebuildProjectConfig verbosity
- httpTransport
- distDirLayout
- cliConfig
-
- let ProjectConfigBuildOnly {
- projectConfigLogsDir
+ let haddockOutputDir = flagToMaybe (packageConfigHaddockOutputDir (projectConfigLocalPackages cliConfig))
+ let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory haddockOutputDir
+
+ httpTransport <-
+ configureTransport
+ verbosity
+ (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
+ (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
+
+ (projectConfig, localPackages) <-
+ rebuildProjectConfig
+ verbosity
+ httpTransport
+ distDirLayout
+ cliConfig
+
+ let ProjectConfigBuildOnly
+ { projectConfigLogsDir
} = projectConfigBuildOnly projectConfig
- ProjectConfigShared {
- projectConfigStoreDir
+ ProjectConfigShared
+ { projectConfigStoreDir
} = projectConfigShared projectConfig
- mlogsDir = Setup.flagToMaybe projectConfigLogsDir
- mstoreDir <- sequenceA $ makeAbsolute
- <$> Setup.flagToMaybe projectConfigStoreDir
- cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
-
- let buildSettings = resolveBuildTimeSettings
- verbosity cabalDirLayout
- projectConfig
-
- -- https://github.com/haskell/cabal/issues/6013
- when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $
- warn verbosity "There are no packages or optional-packages in the project"
-
- return ProjectBaseContext {
- distDirLayout,
- cabalDirLayout,
- projectConfig,
- localPackages,
- buildSettings,
- currentCommand,
- installedPackages
- }
+ mlogsDir = Setup.flagToMaybe projectConfigLogsDir
+ mstoreDir <-
+ sequenceA $
+ makeAbsolute
+ <$> Setup.flagToMaybe projectConfigStoreDir
+ cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
+
+ let buildSettings =
+ resolveBuildTimeSettings
+ verbosity
+ cabalDirLayout
+ projectConfig
+
+ -- https://github.com/haskell/cabal/issues/6013
+ when (null (projectPackages projectConfig) && null (projectPackagesOptional projectConfig)) $
+ warn verbosity "There are no packages or optional-packages in the project"
+
+ return
+ ProjectBaseContext
+ { distDirLayout
+ , cabalDirLayout
+ , projectConfig
+ , localPackages
+ , buildSettings
+ , currentCommand
+ , installedPackages
+ }
where
mdistDirectory = Setup.flagToMaybe projectConfigDistDir
- ProjectConfigShared { projectConfigDistDir } = projectConfigShared cliConfig
+ ProjectConfigShared{projectConfigDistDir} = projectConfigShared cliConfig
installedPackages = Nothing
-
-- | This holds the context between the pre-build, build and post-build phases.
---
-data ProjectBuildContext = ProjectBuildContext {
- -- | This is the improved plan, before we select a plan subset based on
- -- the build targets, and before we do the dry-run. So this contains
- -- all packages in the project.
- elaboratedPlanOriginal :: ElaboratedInstallPlan,
-
- -- | This is the 'elaboratedPlanOriginal' after we select a plan subset
- -- and do the dry-run phase to find out what is up-to or out-of date.
- -- This is the plan that will be executed during the build phase. So
- -- this contains only a subset of packages in the project.
- elaboratedPlanToExecute:: ElaboratedInstallPlan,
-
- -- | The part of the install plan that's shared between all packages in
- -- the plan. This does not change between the two plan variants above,
- -- so there is just the one copy.
- elaboratedShared :: ElaboratedSharedConfig,
-
- -- | The result of the dry-run phase. This tells us about each member of
- -- the 'elaboratedPlanToExecute'.
- pkgsBuildStatus :: BuildStatusMap,
-
- -- | The targets selected by @selectPlanSubset@. This is useful eg. in
- -- CmdRun, where we need a valid target to execute.
- targetsMap :: TargetsMap
- }
-
+data ProjectBuildContext = ProjectBuildContext
+ { elaboratedPlanOriginal :: ElaboratedInstallPlan
+ -- ^ This is the improved plan, before we select a plan subset based on
+ -- the build targets, and before we do the dry-run. So this contains
+ -- all packages in the project.
+ , elaboratedPlanToExecute :: ElaboratedInstallPlan
+ -- ^ This is the 'elaboratedPlanOriginal' after we select a plan subset
+ -- and do the dry-run phase to find out what is up-to or out-of date.
+ -- This is the plan that will be executed during the build phase. So
+ -- this contains only a subset of packages in the project.
+ , elaboratedShared :: ElaboratedSharedConfig
+ -- ^ The part of the install plan that's shared between all packages in
+ -- the plan. This does not change between the two plan variants above,
+ -- so there is just the one copy.
+ , pkgsBuildStatus :: BuildStatusMap
+ -- ^ The result of the dry-run phase. This tells us about each member of
+ -- the 'elaboratedPlanToExecute'.
+ , targetsMap :: TargetsMap
+ -- ^ The targets selected by @selectPlanSubset@. This is useful eg. in
+ -- CmdRun, where we need a valid target to execute.
+ }
-- | Pre-build phase: decide what to do.
---
withInstallPlan
- :: Verbosity
- -> ProjectBaseContext
- -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
- -> IO a
+ :: Verbosity
+ -> ProjectBaseContext
+ -> (ElaboratedInstallPlan -> ElaboratedSharedConfig -> IO a)
+ -> IO a
withInstallPlan
- verbosity
- ProjectBaseContext {
- distDirLayout,
- cabalDirLayout,
- projectConfig,
- localPackages,
- installedPackages
+ verbosity
+ ProjectBaseContext
+ { distDirLayout
+ , cabalDirLayout
+ , projectConfig
+ , localPackages
+ , installedPackages
}
- action = do
+ action = do
-- Take the project configuration and make a plan for how to build
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
--
(elaboratedPlan, _, elaboratedShared, _, _) <-
- rebuildInstallPlan verbosity
- distDirLayout cabalDirLayout
- projectConfig
- localPackages
- installedPackages
+ rebuildInstallPlan
+ verbosity
+ distDirLayout
+ cabalDirLayout
+ projectConfig
+ localPackages
+ installedPackages
action elaboratedPlan elaboratedShared
runProjectPreBuildPhase
- :: Verbosity
- -> ProjectBaseContext
- -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
- -> IO ProjectBuildContext
+ :: Verbosity
+ -> ProjectBaseContext
+ -> (ElaboratedInstallPlan -> IO (ElaboratedInstallPlan, TargetsMap))
+ -> IO ProjectBuildContext
runProjectPreBuildPhase
- verbosity
- ProjectBaseContext {
- distDirLayout,
- cabalDirLayout,
- projectConfig,
- localPackages,
- installedPackages
+ verbosity
+ ProjectBaseContext
+ { distDirLayout
+ , cabalDirLayout
+ , projectConfig
+ , localPackages
+ , installedPackages
}
- selectPlanSubset = do
+ selectPlanSubset = do
-- Take the project configuration and make a plan for how to build
-- everything in the project. This is independent of any specific targets
-- the user has asked for.
--
(elaboratedPlan, _, elaboratedShared, _, _) <-
- rebuildInstallPlan verbosity
- distDirLayout cabalDirLayout
- projectConfig
- localPackages
- installedPackages
+ rebuildInstallPlan
+ verbosity
+ distDirLayout
+ cabalDirLayout
+ projectConfig
+ localPackages
+ installedPackages
-- The plan for what to do is represented by an 'ElaboratedInstallPlan'
@@ -366,72 +408,80 @@ runProjectPreBuildPhase
-- Check which packages need rebuilding.
-- This also gives us more accurate reasons for the --dry-run output.
--
- pkgsBuildStatus <- rebuildTargetsDryRun distDirLayout elaboratedShared
- elaboratedPlan'
+ pkgsBuildStatus <-
+ rebuildTargetsDryRun
+ distDirLayout
+ elaboratedShared
+ elaboratedPlan'
-- Improve the plan by marking up-to-date packages as installed.
--
- let elaboratedPlan'' = improveInstallPlanWithUpToDatePackages
- pkgsBuildStatus elaboratedPlan'
+ let elaboratedPlan'' =
+ improveInstallPlanWithUpToDatePackages
+ pkgsBuildStatus
+ elaboratedPlan'
debugNoWrap verbosity (InstallPlan.showInstallPlan elaboratedPlan'')
- return ProjectBuildContext {
- elaboratedPlanOriginal = elaboratedPlan,
- elaboratedPlanToExecute = elaboratedPlan'',
- elaboratedShared,
- pkgsBuildStatus,
- targetsMap = targets
- }
-
+ return
+ ProjectBuildContext
+ { elaboratedPlanOriginal = elaboratedPlan
+ , elaboratedPlanToExecute = elaboratedPlan''
+ , elaboratedShared
+ , pkgsBuildStatus
+ , targetsMap = targets
+ }
-- | Build phase: now do it.
--
-- Execute all or parts of the description of what to do to build or
-- rebuild the various packages needed.
---
-runProjectBuildPhase :: Verbosity
- -> ProjectBaseContext
- -> ProjectBuildContext
- -> IO BuildOutcomes
+runProjectBuildPhase
+ :: Verbosity
+ -> ProjectBaseContext
+ -> ProjectBuildContext
+ -> IO BuildOutcomes
runProjectBuildPhase _ ProjectBaseContext{buildSettings} _
- | buildSettingDryRun buildSettings
- = return Map.empty
-
-runProjectBuildPhase verbosity
- ProjectBaseContext{..} ProjectBuildContext {..} =
+ | buildSettingDryRun buildSettings =
+ return Map.empty
+runProjectBuildPhase
+ verbosity
+ ProjectBaseContext{..}
+ ProjectBuildContext{..} =
fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $
- rebuildTargets verbosity
- projectConfig
- distDirLayout
- (cabalStoreDirLayout cabalDirLayout)
- elaboratedPlanToExecute
- elaboratedShared
- pkgsBuildStatus
- buildSettings
- where
- previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
- previousBuildOutcomes =
- Map.mapMaybe $ \status -> case status of
- BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)
- --TODO: [nice to have] record build failures persistently
- _ -> Nothing
+ rebuildTargets
+ verbosity
+ projectConfig
+ distDirLayout
+ (cabalStoreDirLayout cabalDirLayout)
+ elaboratedPlanToExecute
+ elaboratedShared
+ pkgsBuildStatus
+ buildSettings
+ where
+ previousBuildOutcomes :: BuildStatusMap -> BuildOutcomes
+ previousBuildOutcomes =
+ Map.mapMaybe $ \status -> case status of
+ BuildStatusUpToDate buildSuccess -> Just (Right buildSuccess)
+ -- TODO: [nice to have] record build failures persistently
+ _ -> Nothing
-- | Post-build phase: various administrative tasks
--
-- Update bits of state based on the build outcomes and report any failures.
---
-runProjectPostBuildPhase :: Verbosity
- -> ProjectBaseContext
- -> ProjectBuildContext
- -> BuildOutcomes
- -> IO ()
+runProjectPostBuildPhase
+ :: Verbosity
+ -> ProjectBaseContext
+ -> ProjectBuildContext
+ -> BuildOutcomes
+ -> IO ()
runProjectPostBuildPhase _ ProjectBaseContext{buildSettings} _ _
- | buildSettingDryRun buildSettings
- = return ()
-
-runProjectPostBuildPhase verbosity
- ProjectBaseContext {..} bc@ProjectBuildContext {..}
- buildOutcomes = do
+ | buildSettingDryRun buildSettings =
+ return ()
+runProjectPostBuildPhase
+ verbosity
+ ProjectBaseContext{..}
+ bc@ProjectBuildContext{..}
+ buildOutcomes = do
-- Update other build artefacts
-- TODO: currently none, but could include:
-- - bin symlinks/wrappers
@@ -439,35 +489,38 @@ runProjectPostBuildPhase verbosity
-- - delete stale lib registrations
-- - delete stale package dirs
- postBuildStatus <- updatePostBuildProjectStatus
- verbosity
- distDirLayout
- elaboratedPlanOriginal
- pkgsBuildStatus
- buildOutcomes
+ postBuildStatus <-
+ updatePostBuildProjectStatus
+ verbosity
+ distDirLayout
+ elaboratedPlanOriginal
+ pkgsBuildStatus
+ buildOutcomes
-- Write the .ghc.environment file (if allowed by the env file write policy).
let writeGhcEnvFilesPolicy =
- projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared
- $ projectConfig
+ projectConfigWriteGhcEnvironmentFilesPolicy . projectConfigShared $
+ projectConfig
shouldWriteGhcEnvironment :: Bool
shouldWriteGhcEnvironment =
- case fromFlagOrDefault NeverWriteGhcEnvironmentFiles
- writeGhcEnvFilesPolicy
- of
- AlwaysWriteGhcEnvironmentFiles -> True
- NeverWriteGhcEnvironmentFiles -> False
+ case fromFlagOrDefault
+ NeverWriteGhcEnvironmentFiles
+ writeGhcEnvFilesPolicy of
+ AlwaysWriteGhcEnvironmentFiles -> True
+ NeverWriteGhcEnvironmentFiles -> False
WriteGhcEnvironmentFilesOnlyForGhc844AndNewer ->
- let compiler = pkgConfigCompiler elaboratedShared
+ let compiler = pkgConfigCompiler elaboratedShared
ghcCompatVersion = compilerCompatVersion GHC compiler
- in maybe False (>= mkVersion [8,4,4]) ghcCompatVersion
+ in maybe False (>= mkVersion [8, 4, 4]) ghcCompatVersion
when shouldWriteGhcEnvironment $
- void $ writePlanGhcEnvironment (distProjectRootDirectory distDirLayout)
- elaboratedPlanOriginal
- elaboratedShared
- postBuildStatus
+ void $
+ writePlanGhcEnvironment
+ (distProjectRootDirectory distDirLayout)
+ elaboratedPlanOriginal
+ elaboratedShared
+ postBuildStatus
-- Write the build reports
writeBuildReports buildSettings bc elaboratedPlanToExecute buildOutcomes
@@ -476,22 +529,21 @@ runProjectPostBuildPhase verbosity
-- an exception to terminate the program
dieOnBuildFailures verbosity currentCommand elaboratedPlanToExecute buildOutcomes
- -- Note that it is a deliberate design choice that the 'buildTargets' is
- -- not passed to phase 1, and the various bits of input config is not
- -- passed to phase 2.
- --
- -- We make the install plan without looking at the particular targets the
- -- user asks us to build. The set of available things we can build is
- -- discovered from the env and config and is used to make the install plan.
- -- The targets just tell us which parts of the install plan to execute.
- --
- -- Conversely, executing the plan does not directly depend on any of the
- -- input config. The bits that are needed (or better, the decisions based
- -- on it) all go into the install plan.
-
- -- Notionally, the 'BuildFlags' should be things that do not affect what
- -- we build, just how we do it. These ones of course do
+-- Note that it is a deliberate design choice that the 'buildTargets' is
+-- not passed to phase 1, and the various bits of input config is not
+-- passed to phase 2.
+--
+-- We make the install plan without looking at the particular targets the
+-- user asks us to build. The set of available things we can build is
+-- discovered from the env and config and is used to make the install plan.
+-- The targets just tell us which parts of the install plan to execute.
+--
+-- Conversely, executing the plan does not directly depend on any of the
+-- input config. The bits that are needed (or better, the decisions based
+-- on it) all go into the install plan.
+-- Notionally, the 'BuildFlags' should be things that do not affect what
+-- we build, just how we do it. These ones of course do
------------------------------------------------------------------------------
-- Taking targets into account, selecting what to build
@@ -505,7 +557,6 @@ runProjectPostBuildPhase verbosity
-- matched this target. Typically this is exactly one, but in general it is
-- possible to for different selectors to match the same target. This extra
-- information is primarily to help make helpful error messages.
---
type TargetsMap = Map UnitId [(ComponentTarget, NonEmpty TargetSelector)]
-- | Get all target selectors.
@@ -547,51 +598,62 @@ uniqueTargetSelectors = ordNub . allTargetSelectors
-- checking a user target that refers to a specific component. To help with
-- this commands can use 'selectComponentTargetBasic', either directly or as
-- a basis for their own @selectComponentTarget@ implementation.
---
-resolveTargets :: forall err.
- (forall k. TargetSelector
- -> [AvailableTarget k]
- -> Either (TargetProblem err) [k])
- -> (forall k. SubComponentTarget
- -> AvailableTarget k
- -> Either (TargetProblem err) k )
- -> ElaboratedInstallPlan
- -> Maybe (SourcePackageDb)
- -> [TargetSelector]
- -> Either [TargetProblem err] TargetsMap
-resolveTargets selectPackageTargets selectComponentTarget
- installPlan mPkgDb =
- fmap mkTargetsMap
- . either (Left . toList) Right
- . checkErrors
- . map (\ts -> (,) ts <$> checkTarget ts)
- where
- mkTargetsMap :: [(TargetSelector, [(UnitId, ComponentTarget)])]
- -> TargetsMap
- mkTargetsMap targets =
- Map.map nubComponentTargets
- $ Map.fromListWith (<>)
- [ (uid, [(ct, ts)])
- | (ts, cts) <- targets
- , (uid, ct) <- cts ]
-
- AvailableTargetIndexes{..} = availableTargetIndexes installPlan
-
- checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]
-
- -- We can ask to build any whole package, project-local or a dependency
- checkTarget bt@(TargetPackage _ [pkgid] mkfilter)
- | Just ats <- fmap (maybe id filterTargetsKind mkfilter)
- $ Map.lookup pkgid availableTargetsByPackageId
- = fmap (componentTargets WholeComponent)
- $ selectPackageTargets bt ats
-
- | otherwise
- = Left (TargetProblemNoSuchPackage pkgid)
-
- checkTarget (TargetPackage _ pkgids _)
- = error ("TODO: add support for multiple packages in a directory. Got\n"
- ++ unlines (map prettyShow pkgids))
+resolveTargets
+ :: forall err
+ . ( forall k
+ . TargetSelector
+ -> [AvailableTarget k]
+ -> Either (TargetProblem err) [k]
+ )
+ -> ( forall k
+ . SubComponentTarget
+ -> AvailableTarget k
+ -> Either (TargetProblem err) k
+ )
+ -> ElaboratedInstallPlan
+ -> Maybe (SourcePackageDb)
+ -> [TargetSelector]
+ -> Either [TargetProblem err] TargetsMap
+resolveTargets
+ selectPackageTargets
+ selectComponentTarget
+ installPlan
+ mPkgDb =
+ fmap mkTargetsMap
+ . either (Left . toList) Right
+ . checkErrors
+ . map (\ts -> (,) ts <$> checkTarget ts)
+ where
+ mkTargetsMap
+ :: [(TargetSelector, [(UnitId, ComponentTarget)])]
+ -> TargetsMap
+ mkTargetsMap targets =
+ Map.map nubComponentTargets $
+ Map.fromListWith
+ (<>)
+ [ (uid, [(ct, ts)])
+ | (ts, cts) <- targets
+ , (uid, ct) <- cts
+ ]
+
+ AvailableTargetIndexes{..} = availableTargetIndexes installPlan
+
+ checkTarget :: TargetSelector -> Either (TargetProblem err) [(UnitId, ComponentTarget)]
+
+ -- We can ask to build any whole package, project-local or a dependency
+ checkTarget bt@(TargetPackage _ [pkgid] mkfilter)
+ | Just ats <-
+ fmap (maybe id filterTargetsKind mkfilter) $
+ Map.lookup pkgid availableTargetsByPackageId =
+ fmap (componentTargets WholeComponent) $
+ selectPackageTargets bt ats
+ | otherwise =
+ Left (TargetProblemNoSuchPackage pkgid)
+ checkTarget (TargetPackage _ pkgids _) =
+ error
+ ( "TODO: add support for multiple packages in a directory. Got\n"
+ ++ unlines (map prettyShow pkgids)
+ )
-- For the moment this error cannot happen here, because it gets
-- detected when the package config is being constructed. This case
-- will need handling properly when we do add support.
@@ -600,92 +662,86 @@ resolveTargets selectPackageTargets selectComponentTarget
-- '--cabal-file' option of 'configure' which allows using multiple
-- .cabal files for a single package?
- checkTarget bt@(TargetAllPackages mkfilter) =
+ checkTarget bt@(TargetAllPackages mkfilter) =
fmap (componentTargets WholeComponent)
- . selectPackageTargets bt
- . maybe id filterTargetsKind mkfilter
- . filter availableTargetLocalToProject
- $ concat (Map.elems availableTargetsByPackageId)
-
- checkTarget (TargetComponent pkgid cname subtarget)
- | Just ats <- Map.lookup (pkgid, cname)
- availableTargetsByPackageIdAndComponentName
- = fmap (componentTargets subtarget)
- $ selectComponentTargets subtarget ats
-
- | Map.member pkgid availableTargetsByPackageId
- = Left (TargetProblemNoSuchComponent pkgid cname)
-
- | otherwise
- = Left (TargetProblemNoSuchPackage pkgid)
-
- checkTarget (TargetComponentUnknown pkgname ecname subtarget)
- | Just ats <- case ecname of
- Left ucname ->
- Map.lookup (pkgname, ucname)
- availableTargetsByPackageNameAndUnqualComponentName
- Right cname ->
- Map.lookup (pkgname, cname)
- availableTargetsByPackageNameAndComponentName
- = fmap (componentTargets subtarget)
- $ selectComponentTargets subtarget ats
-
- | Map.member pkgname availableTargetsByPackageName
- = Left (TargetProblemUnknownComponent pkgname ecname)
-
- | otherwise
- = Left (TargetNotInProject pkgname)
-
- checkTarget bt@(TargetPackageNamed pkgname mkfilter)
- | Just ats <- fmap (maybe id filterTargetsKind mkfilter)
- $ Map.lookup pkgname availableTargetsByPackageName
- = fmap (componentTargets WholeComponent)
- . selectPackageTargets bt
- $ ats
-
- | Just SourcePackageDb{ packageIndex } <- mPkgDb
- , let pkg = lookupPackageName packageIndex pkgname
- , not (null pkg)
- = Left (TargetAvailableInIndex pkgname)
-
- | otherwise
- = Left (TargetNotInProject pkgname)
-
- componentTargets :: SubComponentTarget
- -> [(b, ComponentName)]
- -> [(b, ComponentTarget)]
- componentTargets subtarget =
- map (fmap (\cname -> ComponentTarget cname subtarget))
-
- selectComponentTargets :: SubComponentTarget
- -> [AvailableTarget k]
- -> Either (TargetProblem err) [k]
- selectComponentTargets subtarget =
+ . selectPackageTargets bt
+ . maybe id filterTargetsKind mkfilter
+ . filter availableTargetLocalToProject
+ $ concat (Map.elems availableTargetsByPackageId)
+ checkTarget (TargetComponent pkgid cname subtarget)
+ | Just ats <-
+ Map.lookup
+ (pkgid, cname)
+ availableTargetsByPackageIdAndComponentName =
+ fmap (componentTargets subtarget) $
+ selectComponentTargets subtarget ats
+ | Map.member pkgid availableTargetsByPackageId =
+ Left (TargetProblemNoSuchComponent pkgid cname)
+ | otherwise =
+ Left (TargetProblemNoSuchPackage pkgid)
+ checkTarget (TargetComponentUnknown pkgname ecname subtarget)
+ | Just ats <- case ecname of
+ Left ucname ->
+ Map.lookup
+ (pkgname, ucname)
+ availableTargetsByPackageNameAndUnqualComponentName
+ Right cname ->
+ Map.lookup
+ (pkgname, cname)
+ availableTargetsByPackageNameAndComponentName =
+ fmap (componentTargets subtarget) $
+ selectComponentTargets subtarget ats
+ | Map.member pkgname availableTargetsByPackageName =
+ Left (TargetProblemUnknownComponent pkgname ecname)
+ | otherwise =
+ Left (TargetNotInProject pkgname)
+ checkTarget bt@(TargetPackageNamed pkgname mkfilter)
+ | Just ats <-
+ fmap (maybe id filterTargetsKind mkfilter) $
+ Map.lookup pkgname availableTargetsByPackageName =
+ fmap (componentTargets WholeComponent)
+ . selectPackageTargets bt
+ $ ats
+ | Just SourcePackageDb{packageIndex} <- mPkgDb
+ , let pkg = lookupPackageName packageIndex pkgname
+ , not (null pkg) =
+ Left (TargetAvailableInIndex pkgname)
+ | otherwise =
+ Left (TargetNotInProject pkgname)
+
+ componentTargets
+ :: SubComponentTarget
+ -> [(b, ComponentName)]
+ -> [(b, ComponentTarget)]
+ componentTargets subtarget =
+ map (fmap (\cname -> ComponentTarget cname subtarget))
+
+ selectComponentTargets
+ :: SubComponentTarget
+ -> [AvailableTarget k]
+ -> Either (TargetProblem err) [k]
+ selectComponentTargets subtarget =
either (Left . NE.head) Right
- . checkErrors
- . map (selectComponentTarget subtarget)
-
- checkErrors :: [Either e a] -> Either (NonEmpty e) [a]
- checkErrors = (\(es, xs) -> case es of { [] -> Right xs; (e:es') -> Left (e:|es') })
- . partitionEithers
-
-
-data AvailableTargetIndexes = AvailableTargetIndexes {
- availableTargetsByPackageIdAndComponentName
- :: AvailableTargetsMap (PackageId, ComponentName),
-
- availableTargetsByPackageId
- :: AvailableTargetsMap PackageId,
-
- availableTargetsByPackageName
- :: AvailableTargetsMap PackageName,
-
- availableTargetsByPackageNameAndComponentName
- :: AvailableTargetsMap (PackageName, ComponentName),
-
- availableTargetsByPackageNameAndUnqualComponentName
- :: AvailableTargetsMap (PackageName, UnqualComponentName)
- }
+ . checkErrors
+ . map (selectComponentTarget subtarget)
+
+ checkErrors :: [Either e a] -> Either (NonEmpty e) [a]
+ checkErrors =
+ (\(es, xs) -> case es of [] -> Right xs; (e : es') -> Left (e :| es'))
+ . partitionEithers
+
+data AvailableTargetIndexes = AvailableTargetIndexes
+ { availableTargetsByPackageIdAndComponentName
+ :: AvailableTargetsMap (PackageId, ComponentName)
+ , availableTargetsByPackageId
+ :: AvailableTargetsMap PackageId
+ , availableTargetsByPackageName
+ :: AvailableTargetsMap PackageName
+ , availableTargetsByPackageNameAndComponentName
+ :: AvailableTargetsMap (PackageName, ComponentName)
+ , availableTargetsByPackageNameAndUnqualComponentName
+ :: AvailableTargetsMap (PackageName, UnqualComponentName)
+ }
type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]
-- We define a bunch of indexes to help 'resolveTargets' with resolving
@@ -700,50 +756,59 @@ type AvailableTargetsMap k = Map k [AvailableTarget (UnitId, ComponentName)]
availableTargetIndexes :: ElaboratedInstallPlan -> AvailableTargetIndexes
availableTargetIndexes installPlan = AvailableTargetIndexes{..}
where
- availableTargetsByPackageIdAndComponentName ::
- Map (PackageId, ComponentName)
+ availableTargetsByPackageIdAndComponentName
+ :: Map
+ (PackageId, ComponentName)
[AvailableTarget (UnitId, ComponentName)]
availableTargetsByPackageIdAndComponentName =
availableTargets installPlan
- availableTargetsByPackageId ::
- Map PackageId [AvailableTarget (UnitId, ComponentName)]
+ availableTargetsByPackageId
+ :: Map PackageId [AvailableTarget (UnitId, ComponentName)]
availableTargetsByPackageId =
- Map.mapKeysWith
- (++) (\(pkgid, _cname) -> pkgid)
- availableTargetsByPackageIdAndComponentName
- `Map.union` availableTargetsEmptyPackages
+ Map.mapKeysWith
+ (++)
+ (\(pkgid, _cname) -> pkgid)
+ availableTargetsByPackageIdAndComponentName
+ `Map.union` availableTargetsEmptyPackages
- availableTargetsByPackageName ::
- Map PackageName [AvailableTarget (UnitId, ComponentName)]
+ availableTargetsByPackageName
+ :: Map PackageName [AvailableTarget (UnitId, ComponentName)]
availableTargetsByPackageName =
Map.mapKeysWith
- (++) packageName
+ (++)
+ packageName
availableTargetsByPackageId
- availableTargetsByPackageNameAndComponentName ::
- Map (PackageName, ComponentName)
+ availableTargetsByPackageNameAndComponentName
+ :: Map
+ (PackageName, ComponentName)
[AvailableTarget (UnitId, ComponentName)]
availableTargetsByPackageNameAndComponentName =
Map.mapKeysWith
- (++) (\(pkgid, cname) -> (packageName pkgid, cname))
+ (++)
+ (\(pkgid, cname) -> (packageName pkgid, cname))
availableTargetsByPackageIdAndComponentName
- availableTargetsByPackageNameAndUnqualComponentName ::
- Map (PackageName, UnqualComponentName)
+ availableTargetsByPackageNameAndUnqualComponentName
+ :: Map
+ (PackageName, UnqualComponentName)
[AvailableTarget (UnitId, ComponentName)]
availableTargetsByPackageNameAndUnqualComponentName =
Map.mapKeysWith
- (++) (\(pkgid, cname) -> let pname = packageName pkgid
- cname' = unqualComponentName pname cname
- in (pname, cname'))
+ (++)
+ ( \(pkgid, cname) ->
+ let pname = packageName pkgid
+ cname' = unqualComponentName pname cname
+ in (pname, cname')
+ )
availableTargetsByPackageIdAndComponentName
where
- unqualComponentName ::
- PackageName -> ComponentName -> UnqualComponentName
+ unqualComponentName
+ :: PackageName -> ComponentName -> UnqualComponentName
unqualComponentName pkgname =
- fromMaybe (packageNameToUnqualComponentName pkgname)
- . componentNameString
+ fromMaybe (packageNameToUnqualComponentName pkgname)
+ . componentNameString
-- Add in all the empty packages. These do not appear in the
-- availableTargetsByComponent map, since that only contains
@@ -758,44 +823,51 @@ availableTargetIndexes installPlan = AvailableTargetIndexes{..}
| InstallPlan.Configured pkg <- InstallPlan.toList installPlan
, case elabPkgOrComp pkg of
ElabComponent _ -> False
- ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg))
+ ElabPackage _ -> null (pkgComponents (elabPkgDescription pkg))
]
- --TODO: [research required] what if the solution has multiple
- -- versions of this package?
- -- e.g. due to setup deps or due to multiple independent sets
- -- of packages being built (e.g. ghc + ghcjs in a project)
+-- TODO: [research required] what if the solution has multiple
+-- versions of this package?
+-- e.g. due to setup deps or due to multiple independent sets
+-- of packages being built (e.g. ghc + ghcjs in a project)
filterTargetsKind :: ComponentKind -> [AvailableTarget k] -> [AvailableTarget k]
filterTargetsKind ckind = filterTargetsKindWith (== ckind)
-filterTargetsKindWith :: (ComponentKind -> Bool)
- -> [AvailableTarget k] -> [AvailableTarget k]
+filterTargetsKindWith
+ :: (ComponentKind -> Bool)
+ -> [AvailableTarget k]
+ -> [AvailableTarget k]
filterTargetsKindWith p ts =
- [ t | t@(AvailableTarget _ cname _ _) <- ts
- , p (componentKind cname) ]
+ [ t | t@(AvailableTarget _ cname _ _) <- ts, p (componentKind cname)
+ ]
selectBuildableTargets :: [AvailableTarget k] -> [k]
selectBuildableTargets = selectBuildableTargetsWith (const True)
-zipBuildableTargetsWith :: (TargetRequested -> Bool)
- -> [AvailableTarget k] -> [(k, AvailableTarget k)]
+zipBuildableTargetsWith
+ :: (TargetRequested -> Bool)
+ -> [AvailableTarget k]
+ -> [(k, AvailableTarget k)]
zipBuildableTargetsWith p ts =
- [ (k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req ]
+ [(k, t) | t@(AvailableTarget _ _ (TargetBuildable k req) _) <- ts, p req]
-selectBuildableTargetsWith :: (TargetRequested -> Bool)
- -> [AvailableTarget k] -> [k]
+selectBuildableTargetsWith
+ :: (TargetRequested -> Bool)
+ -> [AvailableTarget k]
+ -> [k]
selectBuildableTargetsWith p = map fst . zipBuildableTargetsWith p
selectBuildableTargets' :: [AvailableTarget k] -> ([k], [AvailableTarget ()])
selectBuildableTargets' = selectBuildableTargetsWith' (const True)
-selectBuildableTargetsWith' :: (TargetRequested -> Bool)
- -> [AvailableTarget k] -> ([k], [AvailableTarget ()])
+selectBuildableTargetsWith'
+ :: (TargetRequested -> Bool)
+ -> [AvailableTarget k]
+ -> ([k], [AvailableTarget ()])
selectBuildableTargetsWith' p =
(fmap . map) forgetTargetDetail . unzip . zipBuildableTargetsWith p
-
forgetTargetDetail :: AvailableTarget k -> AvailableTarget ()
forgetTargetDetail = fmap (const ())
@@ -806,39 +878,38 @@ forgetTargetsDetail = map forgetTargetDetail
-- 'resolveTargets', that does the basic checks that the component is
-- buildable and isn't a test suite or benchmark that is disabled. This
-- can also be used to do these basic checks as part of a custom impl that
---
-selectComponentTargetBasic :: SubComponentTarget
- -> AvailableTarget k
- -> Either (TargetProblem a) k
-selectComponentTargetBasic subtarget
- AvailableTarget {
- availableTargetPackageId = pkgid,
- availableTargetComponentName = cname,
- availableTargetStatus
- } =
+selectComponentTargetBasic
+ :: SubComponentTarget
+ -> AvailableTarget k
+ -> Either (TargetProblem a) k
+selectComponentTargetBasic
+ subtarget
+ AvailableTarget
+ { availableTargetPackageId = pkgid
+ , availableTargetComponentName = cname
+ , availableTargetStatus
+ } =
case availableTargetStatus of
TargetDisabledByUser ->
Left (TargetOptionalStanzaDisabledByUser pkgid cname subtarget)
-
TargetDisabledBySolver ->
Left (TargetOptionalStanzaDisabledBySolver pkgid cname subtarget)
-
TargetNotLocal ->
Left (TargetComponentNotProjectLocal pkgid cname subtarget)
-
TargetNotBuildable ->
Left (TargetComponentNotBuildable pkgid cname subtarget)
-
TargetBuildable targetKey _ ->
Right targetKey
-- | Wrapper around 'ProjectPlanning.pruneInstallPlanToTargets' that adjusts
-- for the extra unneeded info in the 'TargetsMap'.
---
-pruneInstallPlanToTargets :: TargetAction -> TargetsMap
- -> ElaboratedInstallPlan -> ElaboratedInstallPlan
+pruneInstallPlanToTargets
+ :: TargetAction
+ -> TargetsMap
+ -> ElaboratedInstallPlan
+ -> ElaboratedInstallPlan
pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =
- assert (Map.size targetsMap > 0) $
+ assert (Map.size targetsMap > 0) $
ProjectPlanning.pruneInstallPlanToTargets
targetActionType
(Map.map (map fst) targetsMap)
@@ -846,13 +917,13 @@ pruneInstallPlanToTargets targetActionType targetsMap elaboratedPlan =
-- | Utility used by repl and run to check if the targets spans multiple
-- components, since those commands do not support multiple components.
---
distinctTargetComponents :: TargetsMap -> Set.Set (UnitId, ComponentName)
distinctTargetComponents targetsMap =
- Set.fromList [ (uid, cname)
- | (uid, cts) <- Map.toList targetsMap
- , (ComponentTarget cname _, _) <- cts ]
-
+ Set.fromList
+ [ (uid, cname)
+ | (uid, cts) <- Map.toList targetsMap
+ , (ComponentTarget cname _, _) <- cts
+ ]
------------------------------------------------------------------------------
-- Displaying what we plan to do
@@ -860,157 +931,179 @@ distinctTargetComponents targetsMap =
-- | Print a user-oriented presentation of the install plan, indicating what
-- will be built.
---
-printPlan :: Verbosity
- -> ProjectBaseContext
- -> ProjectBuildContext
- -> IO ()
-printPlan verbosity
- ProjectBaseContext {
- buildSettings = BuildTimeSettings{buildSettingDryRun},
- projectConfig = ProjectConfig {
- projectConfigAllPackages =
- PackageConfig {packageConfigOptimization = globalOptimization},
- projectConfigLocalPackages =
- PackageConfig {packageConfigOptimization = localOptimization}
- },
- currentCommand
- }
- ProjectBuildContext {
- elaboratedPlanToExecute = elaboratedPlan,
- elaboratedShared,
- pkgsBuildStatus
- }
- | null pkgs && currentCommand == BuildCommand
- = notice verbosity "Up to date"
- | not (null pkgs) = noticeNoWrap verbosity $ unlines $
- (showBuildProfile ++ "In order, the following "
- ++ wouldWill ++ " be built"
- ++ ifNormal " (use -v for more details)" ++ ":")
- : map showPkgAndReason pkgs
- | otherwise = return ()
- where
- pkgs = InstallPlan.executionOrder elaboratedPlan
-
- ifVerbose s | verbosity >= verbose = s
- | otherwise = ""
-
- ifNormal s | verbosity >= verbose = ""
- | otherwise = s
-
- wouldWill | buildSettingDryRun = "would"
- | otherwise = "will"
-
- showPkgAndReason :: ElaboratedReadyPackage -> String
- showPkgAndReason (ReadyPackage elab) = unwords $ filter (not . null) $
- [ " -"
- , if verbosity >= deafening
- then prettyShow (installedUnitId elab)
- else prettyShow (packageId elab)
- , case elabPkgOrComp elab of
- ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg))
- ElabComponent comp ->
- "(" ++ showComp elab comp ++ ")"
- , showFlagAssignment (nonDefaultFlags elab)
- , showConfigureFlags elab
- , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
- in "(" ++ showBuildStatus buildStatus ++ ")"
- ]
-
- showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
- showComp elab comp =
- maybe "custom" prettyShow (compComponentName comp) ++
- if Map.null (elabInstantiatedWith elab)
+printPlan
+ :: Verbosity
+ -> ProjectBaseContext
+ -> ProjectBuildContext
+ -> IO ()
+printPlan
+ verbosity
+ ProjectBaseContext
+ { buildSettings = BuildTimeSettings{buildSettingDryRun}
+ , projectConfig =
+ ProjectConfig
+ { projectConfigAllPackages =
+ PackageConfig{packageConfigOptimization = globalOptimization}
+ , projectConfigLocalPackages =
+ PackageConfig{packageConfigOptimization = localOptimization}
+ }
+ , currentCommand
+ }
+ ProjectBuildContext
+ { elaboratedPlanToExecute = elaboratedPlan
+ , elaboratedShared
+ , pkgsBuildStatus
+ }
+ | null pkgs && currentCommand == BuildCommand =
+ notice verbosity "Up to date"
+ | not (null pkgs) =
+ noticeNoWrap verbosity $
+ unlines $
+ ( showBuildProfile
+ ++ "In order, the following "
+ ++ wouldWill
+ ++ " be built"
+ ++ ifNormal " (use -v for more details)"
+ ++ ":"
+ )
+ : map showPkgAndReason pkgs
+ | otherwise = return ()
+ where
+ pkgs = InstallPlan.executionOrder elaboratedPlan
+
+ ifVerbose s
+ | verbosity >= verbose = s
+ | otherwise = ""
+
+ ifNormal s
+ | verbosity >= verbose = ""
+ | otherwise = s
+
+ wouldWill
+ | buildSettingDryRun = "would"
+ | otherwise = "will"
+
+ showPkgAndReason :: ElaboratedReadyPackage -> String
+ showPkgAndReason (ReadyPackage elab) =
+ unwords $
+ filter (not . null) $
+ [ " -"
+ , if verbosity >= deafening
+ then prettyShow (installedUnitId elab)
+ else prettyShow (packageId elab)
+ , case elabPkgOrComp elab of
+ ElabPackage pkg -> showTargets elab ++ ifVerbose (showStanzas (pkgStanzasEnabled pkg))
+ ElabComponent comp ->
+ "(" ++ showComp elab comp ++ ")"
+ , showFlagAssignment (nonDefaultFlags elab)
+ , showConfigureFlags elab
+ , let buildStatus = pkgsBuildStatus Map.! installedUnitId elab
+ in "(" ++ showBuildStatus buildStatus ++ ")"
+ ]
+
+ showComp :: ElaboratedConfiguredPackage -> ElaboratedComponent -> String
+ showComp elab comp =
+ maybe "custom" prettyShow (compComponentName comp)
+ ++ if Map.null (elabInstantiatedWith elab)
then ""
- else " with " ++
- intercalate ", "
- -- TODO: Abbreviate the UnitIds
- [ prettyShow k ++ "=" ++ prettyShow v
- | (k,v) <- Map.toList (elabInstantiatedWith elab) ]
-
- nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
- nonDefaultFlags elab =
- elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab
-
- showTargets :: ElaboratedConfiguredPackage -> String
- showTargets elab
- | null (elabBuildTargets elab) = ""
- | otherwise
- = "("
- ++ intercalate ", " [ showComponentTarget (packageId elab) t
- | t <- elabBuildTargets elab ]
- ++ ")"
-
- showConfigureFlags :: ElaboratedConfiguredPackage -> String
- showConfigureFlags elab =
- let fullConfigureFlags
- = setupHsConfigureFlags
- (ReadyPackage elab)
- elaboratedShared
- verbosity
- "$builddir"
- -- | Given a default value @x@ for a flag, nub @Flag x@
+ else
+ " with "
+ ++ intercalate
+ ", "
+ -- TODO: Abbreviate the UnitIds
+ [ prettyShow k ++ "=" ++ prettyShow v
+ | (k, v) <- Map.toList (elabInstantiatedWith elab)
+ ]
+
+ nonDefaultFlags :: ElaboratedConfiguredPackage -> FlagAssignment
+ nonDefaultFlags elab =
+ elabFlagAssignment elab `diffFlagAssignment` elabFlagDefaults elab
+
+ showTargets :: ElaboratedConfiguredPackage -> String
+ showTargets elab
+ | null (elabBuildTargets elab) = ""
+ | otherwise =
+ "("
+ ++ intercalate
+ ", "
+ [ showComponentTarget (packageId elab) t
+ | t <- elabBuildTargets elab
+ ]
+ ++ ")"
+
+ showConfigureFlags :: ElaboratedConfiguredPackage -> String
+ showConfigureFlags elab =
+ let fullConfigureFlags =
+ setupHsConfigureFlags
+ (ReadyPackage elab)
+ elaboratedShared
+ verbosity
+ "$builddir"
+ -- \| Given a default value @x@ for a flag, nub @Flag x@
-- into @NoFlag@. This gives us a tidier command line
-- rendering.
nubFlag :: Eq a => a -> Setup.Flag a -> Setup.Flag a
nubFlag x (Setup.Flag x') | x == x' = Setup.NoFlag
- nubFlag _ f = f
+ nubFlag _ f = f
(tryLibProfiling, tryExeProfiling) =
computeEffectiveProfiling fullConfigureFlags
- partialConfigureFlags
- = mempty {
- configProf =
- nubFlag False (configProf fullConfigureFlags),
- configProfExe =
- nubFlag tryExeProfiling (configProfExe fullConfigureFlags),
- configProfLib =
+ partialConfigureFlags =
+ mempty
+ { configProf =
+ nubFlag False (configProf fullConfigureFlags)
+ , configProfExe =
+ nubFlag tryExeProfiling (configProfExe fullConfigureFlags)
+ , configProfLib =
nubFlag tryLibProfiling (configProfLib fullConfigureFlags)
- -- Maybe there are more we can add
- }
- -- Not necessary to "escape" it, it's just for user output
- in unwords . ("":) $
- commandShowOptions
- (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
- partialConfigureFlags
-
- showBuildStatus :: BuildStatus -> String
- showBuildStatus status = case status of
- BuildStatusPreExisting -> "existing package"
- BuildStatusInstalled -> "already installed"
- BuildStatusDownload {} -> "requires download & build"
- BuildStatusUnpack {} -> "requires build"
- BuildStatusRebuild _ rebuild -> case rebuild of
- BuildStatusConfigure
- (MonitoredValueChanged _) -> "configuration changed"
- BuildStatusConfigure mreason -> showMonitorChangedReason mreason
- BuildStatusBuild _ buildreason -> case buildreason of
- BuildReasonDepsRebuilt -> "dependency rebuilt"
- BuildReasonFilesChanged
- mreason -> showMonitorChangedReason mreason
- BuildReasonExtraTargets _ -> "additional components to build"
- BuildReasonEphemeralTargets -> "ephemeral targets"
- BuildStatusUpToDate {} -> "up to date" -- doesn't happen
-
- showMonitorChangedReason :: MonitorChangedReason a -> String
- showMonitorChangedReason (MonitoredFileChanged file) =
- "file " ++ file ++ " changed"
- showMonitorChangedReason (MonitoredValueChanged _) = "value changed"
- showMonitorChangedReason MonitorFirstRun = "first run"
- showMonitorChangedReason MonitorCorruptCache =
- "cannot read state cache"
-
- showBuildProfile :: String
- showBuildProfile = "Build profile: " ++ unwords [
- "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared,
- "-O" ++ (case globalOptimization <> localOptimization of -- if local is not set, read global
- Setup.Flag NoOptimisation -> "0"
- Setup.Flag NormalOptimisation -> "1"
- Setup.Flag MaximumOptimisation -> "2"
- Setup.NoFlag -> "1")]
- ++ "\n"
-
+ -- Maybe there are more we can add
+ }
+ in -- Not necessary to "escape" it, it's just for user output
+ unwords . ("" :) $
+ commandShowOptions
+ (Setup.configureCommand (pkgConfigCompilerProgs elaboratedShared))
+ partialConfigureFlags
+
+ showBuildStatus :: BuildStatus -> String
+ showBuildStatus status = case status of
+ BuildStatusPreExisting -> "existing package"
+ BuildStatusInstalled -> "already installed"
+ BuildStatusDownload{} -> "requires download & build"
+ BuildStatusUnpack{} -> "requires build"
+ BuildStatusRebuild _ rebuild -> case rebuild of
+ BuildStatusConfigure
+ (MonitoredValueChanged _) -> "configuration changed"
+ BuildStatusConfigure mreason -> showMonitorChangedReason mreason
+ BuildStatusBuild _ buildreason -> case buildreason of
+ BuildReasonDepsRebuilt -> "dependency rebuilt"
+ BuildReasonFilesChanged
+ mreason -> showMonitorChangedReason mreason
+ BuildReasonExtraTargets _ -> "additional components to build"
+ BuildReasonEphemeralTargets -> "ephemeral targets"
+ BuildStatusUpToDate{} -> "up to date" -- doesn't happen
+ showMonitorChangedReason :: MonitorChangedReason a -> String
+ showMonitorChangedReason (MonitoredFileChanged file) =
+ "file " ++ file ++ " changed"
+ showMonitorChangedReason (MonitoredValueChanged _) = "value changed"
+ showMonitorChangedReason MonitorFirstRun = "first run"
+ showMonitorChangedReason MonitorCorruptCache =
+ "cannot read state cache"
+
+ showBuildProfile :: String
+ showBuildProfile =
+ "Build profile: "
+ ++ unwords
+ [ "-w " ++ (showCompilerId . pkgConfigCompiler) elaboratedShared
+ , "-O"
+ ++ ( case globalOptimization <> localOptimization of -- if local is not set, read global
+ Setup.Flag NoOptimisation -> "0"
+ Setup.Flag NormalOptimisation -> "1"
+ Setup.Flag MaximumOptimisation -> "2"
+ Setup.NoFlag -> "1"
+ )
+ ]
+ ++ "\n"
writeBuildReports :: BuildTimeSettings -> ProjectBuildContext -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
writeBuildReports settings buildContext plan buildOutcomes = do
@@ -1019,130 +1112,136 @@ writeBuildReports settings buildContext plan buildOutcomes = do
getRepo (RepoTarballPackage r _ _) = Just r
getRepo _ = Nothing
fromPlanPackage (InstallPlan.Configured pkg) (Just result) =
- let installOutcome = case result of
- Left bf -> case buildFailureReason bf of
- GracefulFailure _ -> BuildReports.PlanningFailed
- DependentFailed p -> BuildReports.DependencyFailed p
- DownloadFailed _ -> BuildReports.DownloadFailed
- UnpackFailed _ -> BuildReports.UnpackFailed
- ConfigureFailed _ -> BuildReports.ConfigureFailed
- BuildFailed _ -> BuildReports.BuildFailed
- TestsFailed _ -> BuildReports.TestsFailed
- InstallFailed _ -> BuildReports.InstallFailed
-
- ReplFailed _ -> BuildReports.InstallOk
- HaddocksFailed _ -> BuildReports.InstallOk
- BenchFailed _ -> BuildReports.InstallOk
-
- Right _br -> BuildReports.InstallOk
-
- docsOutcome = case result of
- Left bf -> case buildFailureReason bf of
- HaddocksFailed _ -> BuildReports.Failed
- _ -> BuildReports.NotTried
- Right br -> case buildResultDocs br of
- DocsNotTried -> BuildReports.NotTried
- DocsFailed -> BuildReports.Failed
- DocsOk -> BuildReports.Ok
-
- testsOutcome = case result of
- Left bf -> case buildFailureReason bf of
- TestsFailed _ -> BuildReports.Failed
- _ -> BuildReports.NotTried
- Right br -> case buildResultTests br of
- TestsNotTried -> BuildReports.NotTried
- TestsOk -> BuildReports.Ok
-
- in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map packageId $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?
+ let installOutcome = case result of
+ Left bf -> case buildFailureReason bf of
+ GracefulFailure _ -> BuildReports.PlanningFailed
+ DependentFailed p -> BuildReports.DependencyFailed p
+ DownloadFailed _ -> BuildReports.DownloadFailed
+ UnpackFailed _ -> BuildReports.UnpackFailed
+ ConfigureFailed _ -> BuildReports.ConfigureFailed
+ BuildFailed _ -> BuildReports.BuildFailed
+ TestsFailed _ -> BuildReports.TestsFailed
+ InstallFailed _ -> BuildReports.InstallFailed
+ ReplFailed _ -> BuildReports.InstallOk
+ HaddocksFailed _ -> BuildReports.InstallOk
+ BenchFailed _ -> BuildReports.InstallOk
+ Right _br -> BuildReports.InstallOk
+
+ docsOutcome = case result of
+ Left bf -> case buildFailureReason bf of
+ HaddocksFailed _ -> BuildReports.Failed
+ _ -> BuildReports.NotTried
+ Right br -> case buildResultDocs br of
+ DocsNotTried -> BuildReports.NotTried
+ DocsFailed -> BuildReports.Failed
+ DocsOk -> BuildReports.Ok
+
+ testsOutcome = case result of
+ Left bf -> case buildFailureReason bf of
+ TestsFailed _ -> BuildReports.Failed
+ _ -> BuildReports.NotTried
+ Right br -> case buildResultTests br of
+ TestsNotTried -> BuildReports.NotTried
+ TestsOk -> BuildReports.Ok
+ in Just $ (BuildReports.BuildReport (packageId pkg) os arch (compilerId comp) cabalInstallID (elabFlagAssignment pkg) (map packageId $ elabLibDependencies pkg) installOutcome docsOutcome testsOutcome, getRepo . elabPkgSourceLocation $ pkg) -- TODO handle failure log files?
fromPlanPackage _ _ = Nothing
buildReports = mapMaybe (\x -> fromPlanPackage x (InstallPlan.lookupBuildOutcome x buildOutcomes)) $ InstallPlan.toList plan
+ BuildReports.storeLocal
+ (compilerInfo comp)
+ (buildSettingSummaryFile settings)
+ buildReports
+ plat
- BuildReports.storeLocal (compilerInfo comp)
- (buildSettingSummaryFile settings)
- buildReports
- plat
- -- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1
- -- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle.
+-- Note this doesn't handle the anonymous build reports set by buildSettingBuildReports but those appear to not be used or missed from v1
+-- The usage pattern appears to be that rather than rely on flags to cabal to send build logs to the right place and package them with reports, etc, it is easier to simply capture its output to an appropriate handle.
-- | If there are build failures then report them and throw an exception.
---
-dieOnBuildFailures :: Verbosity -> CurrentCommand
- -> ElaboratedInstallPlan -> BuildOutcomes -> IO ()
+dieOnBuildFailures
+ :: Verbosity
+ -> CurrentCommand
+ -> ElaboratedInstallPlan
+ -> BuildOutcomes
+ -> IO ()
dieOnBuildFailures verbosity currentCommand plan buildOutcomes
| null failures = return ()
-
- | isSimpleCase = exitFailure
-
+ | isSimpleCase = exitFailure
| otherwise = do
-- For failures where we have a build log, print the log plus a header
- sequence_
- [ do notice verbosity $
- '\n' : renderFailureDetail False pkg reason
- ++ "\nBuild log ( " ++ logfile ++ " ):"
- readFile logfile >>= noticeNoWrap verbosity
- | (pkg, ShowBuildSummaryAndLog reason logfile)
- <- failuresClassification
- ]
-
- -- For all failures, print either a short summary (if we showed the
- -- build log) or all details
- dieIfNotHaddockFailure verbosity $ unlines
- [ case failureClassification of
- ShowBuildSummaryAndLog reason _
- | verbosity > normal
- -> renderFailureDetail mentionDepOf pkg reason
-
- | otherwise
- -> renderFailureSummary mentionDepOf pkg reason
- ++ ". See the build log above for details."
-
- ShowBuildSummaryOnly reason ->
- renderFailureDetail mentionDepOf pkg reason
-
- | let mentionDepOf = verbosity <= normal
- , (pkg, failureClassification) <- failuresClassification ]
+ sequence_
+ [ do
+ notice verbosity $
+ '\n'
+ : renderFailureDetail False pkg reason
+ ++ "\nBuild log ( "
+ ++ logfile
+ ++ " ):"
+ readFile logfile >>= noticeNoWrap verbosity
+ | (pkg, ShowBuildSummaryAndLog reason logfile) <-
+ failuresClassification
+ ]
+
+ -- For all failures, print either a short summary (if we showed the
+ -- build log) or all details
+ dieIfNotHaddockFailure verbosity $
+ unlines
+ [ case failureClassification of
+ ShowBuildSummaryAndLog reason _
+ | verbosity > normal ->
+ renderFailureDetail mentionDepOf pkg reason
+ | otherwise ->
+ renderFailureSummary mentionDepOf pkg reason
+ ++ ". See the build log above for details."
+ ShowBuildSummaryOnly reason ->
+ renderFailureDetail mentionDepOf pkg reason
+ | let mentionDepOf = verbosity <= normal
+ , (pkg, failureClassification) <- failuresClassification
+ ]
where
failures :: [(UnitId, BuildFailure)]
- failures = [ (pkgid, failure)
- | (pkgid, Left failure) <- Map.toList buildOutcomes ]
+ failures =
+ [ (pkgid, failure)
+ | (pkgid, Left failure) <- Map.toList buildOutcomes
+ ]
failuresClassification :: [(ElaboratedConfiguredPackage, BuildFailurePresentation)]
failuresClassification =
[ (pkg, classifyBuildFailure failure)
| (pkgid, failure) <- failures
, case buildFailureReason failure of
- DependentFailed {} -> verbosity > normal
- _ -> True
+ DependentFailed{} -> verbosity > normal
+ _ -> True
, InstallPlan.Configured pkg <-
- maybeToList (InstallPlan.lookup plan pkgid)
+ maybeToList (InstallPlan.lookup plan pkgid)
]
dieIfNotHaddockFailure :: Verbosity -> String -> IO ()
dieIfNotHaddockFailure
- | currentCommand == HaddockCommand = die'
+ | currentCommand == HaddockCommand = die'
| all isHaddockFailure failuresClassification = warn
- | otherwise = die'
+ | otherwise = die'
where
isHaddockFailure
- (_, ShowBuildSummaryOnly (HaddocksFailed _) ) = True
+ (_, ShowBuildSummaryOnly (HaddocksFailed _)) = True
isHaddockFailure
(_, ShowBuildSummaryAndLog (HaddocksFailed _) _) = True
isHaddockFailure
- _ = False
-
+ _ = False
classifyBuildFailure :: BuildFailure -> BuildFailurePresentation
- classifyBuildFailure BuildFailure {
- buildFailureReason = reason,
- buildFailureLogFile = mlogfile
- } =
- maybe (ShowBuildSummaryOnly reason)
- (ShowBuildSummaryAndLog reason) $ do
- logfile <- mlogfile
- e <- buildFailureException reason
- ExitFailure 1 <- fromException e
- return logfile
+ classifyBuildFailure
+ BuildFailure
+ { buildFailureReason = reason
+ , buildFailureLogFile = mlogfile
+ } =
+ maybe
+ (ShowBuildSummaryOnly reason)
+ (ShowBuildSummaryAndLog reason)
+ $ do
+ logfile <- mlogfile
+ e <- buildFailureException reason
+ ExitFailure 1 <- fromException e
+ return logfile
-- Special case: we don't want to report anything complicated in the case
-- of just doing build on the current package, since it's clear from
@@ -1158,13 +1257,13 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
isSimpleCase :: Bool
isSimpleCase
| [(pkgid, failure)] <- failures
- , [pkg] <- rootpkgs
+ , [pkg] <- rootpkgs
, installedUnitId pkg == pkgid
, isFailureSelfExplanatory (buildFailureReason failure)
- , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand]
- = True
- | otherwise
- = False
+ , currentCommand `notElem` [InstallCommand, BuildCommand, ReplCommand] =
+ True
+ | otherwise =
+ False
-- NB: if the Setup script segfaulted or was interrupted,
-- we should give more detailed information. So only
@@ -1172,82 +1271,91 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
isFailureSelfExplanatory :: BuildFailureReason -> Bool
isFailureSelfExplanatory (BuildFailed e)
| Just (ExitFailure 1) <- fromException e = True
-
isFailureSelfExplanatory (ConfigureFailed e)
| Just (ExitFailure 1) <- fromException e = True
-
- isFailureSelfExplanatory _ = False
+ isFailureSelfExplanatory _ = False
rootpkgs :: [ElaboratedConfiguredPackage]
rootpkgs =
[ pkg
| InstallPlan.Configured pkg <- InstallPlan.toList plan
- , hasNoDependents pkg ]
+ , hasNoDependents pkg
+ ]
ultimateDeps
:: UnitId
-> [InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage]
ultimateDeps pkgid =
- filter (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
- (InstallPlan.reverseDependencyClosure plan [pkgid])
+ filter
+ (\pkg -> hasNoDependents pkg && installedUnitId pkg /= pkgid)
+ (InstallPlan.reverseDependencyClosure plan [pkgid])
hasNoDependents :: HasUnitId pkg => pkg -> Bool
hasNoDependents = null . InstallPlan.revDirectDeps plan . installedUnitId
renderFailureDetail :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureDetail mentionDepOf pkg reason =
- renderFailureSummary mentionDepOf pkg reason ++ "."
- ++ renderFailureExtraDetail reason
- ++ maybe "" showException (buildFailureException reason)
+ renderFailureSummary mentionDepOf pkg reason
+ ++ "."
+ ++ renderFailureExtraDetail reason
+ ++ maybe "" showException (buildFailureException reason)
renderFailureSummary :: Bool -> ElaboratedConfiguredPackage -> BuildFailureReason -> String
renderFailureSummary mentionDepOf pkg reason =
- case reason of
- DownloadFailed _ -> "Failed to download " ++ pkgstr
- UnpackFailed _ -> "Failed to unpack " ++ pkgstr
- ConfigureFailed _ -> "Failed to build " ++ pkgstr
- BuildFailed _ -> "Failed to build " ++ pkgstr
- ReplFailed _ -> "repl failed for " ++ pkgstr
- HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr
- TestsFailed _ -> "Tests failed for " ++ pkgstr
- BenchFailed _ -> "Benchmarks failed for " ++ pkgstr
- InstallFailed _ -> "Failed to build " ++ pkgstr
- GracefulFailure msg -> msg
- DependentFailed depid
- -> "Failed to build " ++ prettyShow (packageId pkg)
- ++ " because it depends on " ++ prettyShow depid
- ++ " which itself failed to build"
+ case reason of
+ DownloadFailed _ -> "Failed to download " ++ pkgstr
+ UnpackFailed _ -> "Failed to unpack " ++ pkgstr
+ ConfigureFailed _ -> "Failed to build " ++ pkgstr
+ BuildFailed _ -> "Failed to build " ++ pkgstr
+ ReplFailed _ -> "repl failed for " ++ pkgstr
+ HaddocksFailed _ -> "Failed to build documentation for " ++ pkgstr
+ TestsFailed _ -> "Tests failed for " ++ pkgstr
+ BenchFailed _ -> "Benchmarks failed for " ++ pkgstr
+ InstallFailed _ -> "Failed to build " ++ pkgstr
+ GracefulFailure msg -> msg
+ DependentFailed depid ->
+ "Failed to build "
+ ++ prettyShow (packageId pkg)
+ ++ " because it depends on "
+ ++ prettyShow depid
+ ++ " which itself failed to build"
where
- pkgstr = elabConfiguredName verbosity pkg
- ++ if mentionDepOf
- then renderDependencyOf (installedUnitId pkg)
- else ""
+ pkgstr =
+ elabConfiguredName verbosity pkg
+ ++ if mentionDepOf
+ then renderDependencyOf (installedUnitId pkg)
+ else ""
renderFailureExtraDetail :: BuildFailureReason -> String
renderFailureExtraDetail (ConfigureFailed _) =
" The failure occurred during the configure step."
- renderFailureExtraDetail (InstallFailed _) =
+ renderFailureExtraDetail (InstallFailed _) =
" The failure occurred during the final install step."
- renderFailureExtraDetail _ =
+ renderFailureExtraDetail _ =
""
renderDependencyOf :: UnitId -> String
renderDependencyOf pkgid =
case ultimateDeps pkgid of
- [] -> ""
- (p1:[]) ->
+ [] -> ""
+ (p1 : []) ->
" (which is required by " ++ elabPlanPackageName verbosity p1 ++ ")"
- (p1:p2:[]) ->
- " (which is required by " ++ elabPlanPackageName verbosity p1
- ++ " and " ++ elabPlanPackageName verbosity p2 ++ ")"
- (p1:p2:_) ->
- " (which is required by " ++ elabPlanPackageName verbosity p1
- ++ ", " ++ elabPlanPackageName verbosity p2
- ++ " and others)"
-
+ (p1 : p2 : []) ->
+ " (which is required by "
+ ++ elabPlanPackageName verbosity p1
+ ++ " and "
+ ++ elabPlanPackageName verbosity p2
+ ++ ")"
+ (p1 : p2 : _) ->
+ " (which is required by "
+ ++ elabPlanPackageName verbosity p1
+ ++ ", "
+ ++ elabPlanPackageName verbosity p2
+ ++ " and others)"
+
+{- FOURMOLU_DISABLE -}
showException e = case fromException e of
Just (ExitFailure 1) -> ""
-
#ifdef MIN_VERSION_unix
-- Note [Positive "signal" exit code]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1265,52 +1373,53 @@ dieOnBuildFailures verbosity currentCommand plan buildOutcomes
Just (ExitFailure n)
| -n == fromIntegral sigSEGV ->
" The build process segfaulted (i.e. SIGSEGV)."
-
- | n == fromIntegral sigSEGV ->
- " The build process terminated with exit code " ++ show n
- ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."
-
+ | n == fromIntegral sigSEGV ->
+ " The build process terminated with exit code "
+ ++ show n
+ ++ " which may be because some part of it segfaulted. (i.e. SIGSEGV)."
| -n == fromIntegral sigKILL ->
" The build process was killed (i.e. SIGKILL). " ++ explanation
-
- | n == fromIntegral sigKILL ->
- " The build process terminated with exit code " ++ show n
- ++ " which may be because some part of it was killed "
- ++ "(i.e. SIGKILL). " ++ explanation
+ | n == fromIntegral sigKILL ->
+ " The build process terminated with exit code "
+ ++ show n
+ ++ " which may be because some part of it was killed "
+ ++ "(i.e. SIGKILL). "
+ ++ explanation
where
explanation =
"The typical reason for this is that there is not "
- ++ "enough memory available (e.g. the OS killed a process "
- ++ "using lots of memory)."
+ ++ "enough memory available (e.g. the OS killed a process "
+ ++ "using lots of memory)."
#endif
Just (ExitFailure n) ->
" The build process terminated with exit code " ++ show n
-
- _ -> " The exception was:\n "
+ _ ->
+ " The exception was:\n "
#if MIN_VERSION_base(4,8,0)
- ++ displayException e
+ ++ displayException e
#else
- ++ show e
+ ++ show e
#endif
buildFailureException :: BuildFailureReason -> Maybe SomeException
buildFailureException reason =
case reason of
- DownloadFailed e -> Just e
- UnpackFailed e -> Just e
+ DownloadFailed e -> Just e
+ UnpackFailed e -> Just e
ConfigureFailed e -> Just e
- BuildFailed e -> Just e
- ReplFailed e -> Just e
- HaddocksFailed e -> Just e
- TestsFailed e -> Just e
- BenchFailed e -> Just e
- InstallFailed e -> Just e
+ BuildFailed e -> Just e
+ ReplFailed e -> Just e
+ HaddocksFailed e -> Just e
+ TestsFailed e -> Just e
+ BenchFailed e -> Just e
+ InstallFailed e -> Just e
GracefulFailure _ -> Nothing
DependentFailed _ -> Nothing
+{- FOURMOLU_ENABLE -}
-data BuildFailurePresentation =
- ShowBuildSummaryOnly BuildFailureReason
- | ShowBuildSummaryAndLog BuildFailureReason FilePath
+data BuildFailurePresentation
+ = ShowBuildSummaryOnly BuildFailureReason
+ | ShowBuildSummaryAndLog BuildFailureReason FilePath
-------------------------------------------------------------------------------
-- Dummy projects
@@ -1321,54 +1430,58 @@ data BuildFailurePresentation =
establishDummyProjectBaseContext
:: Verbosity
-> ProjectConfig
- -- ^ Project configuration including the global config if needed
+ -- ^ Project configuration including the global config if needed
-> DistDirLayout
- -- ^ Where to put the dist directory
+ -- ^ Where to put the dist directory
-> [PackageSpecifier UnresolvedSourcePackage]
- -- ^ The packages to be included in the project
+ -- ^ The packages to be included in the project
-> CurrentCommand
-> IO ProjectBaseContext
establishDummyProjectBaseContext verbosity projectConfig distDirLayout localPackages currentCommand = do
- let ProjectConfigBuildOnly {
- projectConfigLogsDir
+ let ProjectConfigBuildOnly
+ { projectConfigLogsDir
} = projectConfigBuildOnly projectConfig
- ProjectConfigShared {
- projectConfigStoreDir
+ ProjectConfigShared
+ { projectConfigStoreDir
} = projectConfigShared projectConfig
- mlogsDir = flagToMaybe projectConfigLogsDir
- mstoreDir = flagToMaybe projectConfigStoreDir
-
- cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
-
- let buildSettings :: BuildTimeSettings
- buildSettings = resolveBuildTimeSettings
- verbosity cabalDirLayout
- projectConfig
- installedPackages = Nothing
-
- return ProjectBaseContext {
- distDirLayout,
- cabalDirLayout,
- projectConfig,
- localPackages,
- buildSettings,
- currentCommand,
- installedPackages
- }
+ mlogsDir = flagToMaybe projectConfigLogsDir
+ mstoreDir = flagToMaybe projectConfigStoreDir
+
+ cabalDirLayout <- mkCabalDirLayout mstoreDir mlogsDir
+
+ let buildSettings :: BuildTimeSettings
+ buildSettings =
+ resolveBuildTimeSettings
+ verbosity
+ cabalDirLayout
+ projectConfig
+ installedPackages = Nothing
+
+ return
+ ProjectBaseContext
+ { distDirLayout
+ , cabalDirLayout
+ , projectConfig
+ , localPackages
+ , buildSettings
+ , currentCommand
+ , installedPackages
+ }
establishDummyDistDirLayout :: Verbosity -> ProjectConfig -> FilePath -> IO DistDirLayout
establishDummyDistDirLayout verbosity cliConfig tmpDir = do
- let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
+ let distDirLayout = defaultDistDirLayout projectRoot mdistDirectory Nothing
- -- Create the dist directories
- createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
- createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout
+ -- Create the dist directories
+ createDirectoryIfMissingVerbose verbosity True $ distDirectory distDirLayout
+ createDirectoryIfMissingVerbose verbosity True $ distProjectCacheDirectory distDirLayout
- return distDirLayout
+ return distDirLayout
where
- mdistDirectory = flagToMaybe
- $ projectConfigDistDir
- $ projectConfigShared cliConfig
+ mdistDirectory =
+ flagToMaybe $
+ projectConfigDistDir $
+ projectConfigShared cliConfig
projectRoot = ProjectRootImplicit tmpDir
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
index c9243c310e0c53d846fa015d4d44c8aa37327ead..0cdb512e215de71fa774552f6055704528289a51 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanOutput.hs
@@ -1,29 +1,34 @@
-{-# LANGUAGE BangPatterns, RecordWildCards, NamedFieldPuns,
- DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving,
- ScopedTypeVariables #-}
-
-module Distribution.Client.ProjectPlanOutput (
- -- * Plan output
- writePlanExternalRepresentation,
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Distribution.Client.ProjectPlanOutput
+ ( -- * Plan output
+ writePlanExternalRepresentation
-- * Project status
+
-- | Several outputs rely on having a general overview of
- PostBuildProjectStatus(..),
- updatePostBuildProjectStatus,
- createPackageEnvironment,
- writePlanGhcEnvironment,
- argsEquivalentOfGhcEnvironmentFile,
+ , PostBuildProjectStatus (..)
+ , updatePostBuildProjectStatus
+ , createPackageEnvironment
+ , writePlanGhcEnvironment
+ , argsEquivalentOfGhcEnvironmentFile
) where
-import Distribution.Client.ProjectPlanning.Types
-import Distribution.Client.ProjectBuilding.Types
-import Distribution.Client.DistDirLayout
-import Distribution.Client.Types.Repo (Repo(..), RemoteRepo(..))
-import Distribution.Client.Types.PackageLocation (PackageLocation(..))
-import Distribution.Client.Types.ConfiguredId (confInstId)
-import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))
-import Distribution.Client.HashValue (showHashValue, hashValue)
-import Distribution.Client.Version (cabalInstallVersion)
+import Distribution.Client.DistDirLayout
+import Distribution.Client.HashValue (hashValue, showHashValue)
+import Distribution.Client.ProjectBuilding.Types
+import Distribution.Client.ProjectPlanning.Types
+import Distribution.Client.Types.ConfiguredId (confInstId)
+import Distribution.Client.Types.PackageLocation (PackageLocation (..))
+import Distribution.Client.Types.Repo (RemoteRepo (..), Repo (..))
+import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..))
+import Distribution.Client.Version (cabalInstallVersion)
import qualified Distribution.Client.InstallPlan as InstallPlan
import qualified Distribution.Client.Utils.Json as J
@@ -31,39 +36,52 @@ import qualified Distribution.Simple.InstallDirs as InstallDirs
import qualified Distribution.Solver.Types.ComponentDeps as ComponentDeps
-import Distribution.Package
-import Distribution.System
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-import qualified Distribution.PackageDescription as PD
-import Distribution.Compiler (CompilerFlavor(GHC, GHCJS))
-import Distribution.Simple.Compiler
- ( PackageDBStack, PackageDB(..)
- , compilerVersion, compilerFlavor, showCompilerId
- , compilerId, CompilerId(..), Compiler )
-import Distribution.Simple.GHC
- ( getImplInfo, GhcImplInfo(supportsPkgEnvFiles)
- , GhcEnvironmentFileEntry(..), simpleGhcEnvironmentFile
- , writeGhcEnvironmentFile )
-import Distribution.Simple.BuildPaths
- ( dllExtension, exeExtension, buildInfoPref )
-import qualified Distribution.Compat.Graph as Graph
-import Distribution.Compat.Graph (Graph, Node)
import qualified Distribution.Compat.Binary as Binary
-import Distribution.Simple.Utils
-import Distribution.Types.Version
- ( mkVersion )
-import Distribution.Verbosity
+import Distribution.Compat.Graph (Graph, Node)
+import qualified Distribution.Compat.Graph as Graph
+import Distribution.Compiler (CompilerFlavor (GHC, GHCJS))
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.Package
+import qualified Distribution.PackageDescription as PD
+import Distribution.Simple.BuildPaths
+ ( buildInfoPref
+ , dllExtension
+ , exeExtension
+ )
+import Distribution.Simple.Compiler
+ ( Compiler
+ , CompilerId (..)
+ , PackageDB (..)
+ , PackageDBStack
+ , compilerFlavor
+ , compilerId
+ , compilerVersion
+ , showCompilerId
+ )
+import Distribution.Simple.GHC
+ ( GhcEnvironmentFileEntry (..)
+ , GhcImplInfo (supportsPkgEnvFiles)
+ , getImplInfo
+ , simpleGhcEnvironmentFile
+ , writeGhcEnvironmentFile
+ )
+import Distribution.Simple.Utils
+import Distribution.System
+import Distribution.Types.Version
+ ( mkVersion
+ )
+import Distribution.Verbosity
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
+import qualified Data.ByteString.Builder as BB
+import qualified Data.ByteString.Lazy as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
-import qualified Data.ByteString.Lazy as BS
-import qualified Data.ByteString.Builder as BB
-import System.FilePath
-import System.IO
+import System.FilePath
+import System.IO
import Distribution.Simple.Program.GHC (packageDbArgsDb)
@@ -74,33 +92,36 @@ import Distribution.Simple.Program.GHC (packageDbArgsDb)
-- | Write out a representation of the elaborated install plan.
--
-- This is for the benefit of debugging and external tools like editors.
---
-writePlanExternalRepresentation :: DistDirLayout
- -> ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> IO ()
-writePlanExternalRepresentation distDirLayout elaboratedInstallPlan
- elaboratedSharedConfig =
- writeFileAtomic (distProjectCacheFile distDirLayout "plan.json") $
- BB.toLazyByteString
- . J.encodeToBuilder
+writePlanExternalRepresentation
+ :: DistDirLayout
+ -> ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> IO ()
+writePlanExternalRepresentation
+ distDirLayout
+ elaboratedInstallPlan
+ elaboratedSharedConfig =
+ writeFileAtomic (distProjectCacheFile distDirLayout "plan.json")
+ $ BB.toLazyByteString
+ . J.encodeToBuilder
$ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig
-- | Renders a subset of the elaborated install plan in a semi-stable JSON
-- format.
---
encodePlanAsJson :: DistDirLayout -> ElaboratedInstallPlan -> ElaboratedSharedConfig -> J.Value
encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
- --TODO: [nice to have] include all of the sharedPackageConfig and all of
- -- the parts of the elaboratedInstallPlan
- J.object [ "cabal-version" J..= jdisplay cabalInstallVersion
- , "cabal-lib-version" J..= jdisplay cabalVersion
- , "compiler-id" J..= (J.String . showCompilerId . pkgConfigCompiler)
- elaboratedSharedConfig
- , "os" J..= jdisplay os
- , "arch" J..= jdisplay arch
- , "install-plan" J..= installPlanToJ elaboratedInstallPlan
- ]
+ -- TODO: [nice to have] include all of the sharedPackageConfig and all of
+ -- the parts of the elaboratedInstallPlan
+ J.object
+ [ "cabal-version" J..= jdisplay cabalInstallVersion
+ , "cabal-lib-version" J..= jdisplay cabalVersion
+ , "compiler-id"
+ J..= (J.String . showCompilerId . pkgConfigCompiler)
+ elaboratedSharedConfig
+ , "os" J..= jdisplay os
+ , "arch" J..= jdisplay arch
+ , "install-plan" J..= installPlanToJ elaboratedInstallPlan
+ ]
where
plat :: Platform
plat@(Platform arch os) = pkgConfigPlatform elaboratedSharedConfig
@@ -113,11 +134,11 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
case pkg of
InstallPlan.PreExisting ipi -> installedPackageInfoToJ ipi
InstallPlan.Configured elab -> elaboratedPackageToJ False elab
- InstallPlan.Installed elab -> elaboratedPackageToJ True elab
- -- Note that the plan.json currently only uses the elaborated plan,
- -- not the improved plan. So we will not get the Installed state for
- -- that case, but the code supports it in case we want to use this
- -- later in some use case where we want the status of the build.
+ InstallPlan.Installed elab -> elaboratedPackageToJ True elab
+ -- Note that the plan.json currently only uses the elaborated plan,
+ -- not the improved plan. So we will not get the Installed state for
+ -- that case, but the code supports it in case we want to use this
+ -- later in some use case where we want the status of the build.
installedPackageInfoToJ :: InstalledPackageInfo -> J.Value
installedPackageInfoToJ ipi =
@@ -127,154 +148,181 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
-- So these packages are never local to the project.
--
J.object
- [ "type" J..= J.String "pre-existing"
- , "id" J..= (jdisplay . installedUnitId) ipi
- , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi
+ [ "type" J..= J.String "pre-existing"
+ , "id" J..= (jdisplay . installedUnitId) ipi
+ , "pkg-name" J..= (jdisplay . pkgName . packageId) ipi
, "pkg-version" J..= (jdisplay . pkgVersion . packageId) ipi
- , "depends" J..= map jdisplay (installedDepends ipi)
+ , "depends" J..= map jdisplay (installedDepends ipi)
]
elaboratedPackageToJ :: Bool -> ElaboratedConfiguredPackage -> J.Value
elaboratedPackageToJ isInstalled elab =
J.object $
- [ "type" J..= J.String (if isInstalled then "installed"
- else "configured")
- , "id" J..= (jdisplay . installedUnitId) elab
- , "pkg-name" J..= (jdisplay . pkgName . packageId) elab
+ [ "type"
+ J..= J.String
+ ( if isInstalled
+ then "installed"
+ else "configured"
+ )
+ , "id" J..= (jdisplay . installedUnitId) elab
+ , "pkg-name" J..= (jdisplay . pkgName . packageId) elab
, "pkg-version" J..= (jdisplay . pkgVersion . packageId) elab
- , "flags" J..= J.object [ PD.unFlagName fn J..= v
- | (fn,v) <- PD.unFlagAssignment (elabFlagAssignment elab) ]
- , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))
- , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab)
- ] ++
- [ "pkg-cabal-sha256" J..= J.String (showHashValue hash)
- | Just hash <- [ fmap hashValue (elabPkgDescriptionOverride elab) ] ] ++
- [ "pkg-src-sha256" J..= J.String (showHashValue hash)
- | Just hash <- [elabPkgSourceHash elab] ] ++
- (case elabBuildStyle elab of
- BuildInplaceOnly ->
- ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation]
- BuildAndInstall ->
- -- TODO: install dirs?
- []
- ) ++
- case elabPkgOrComp elab of
- ElabPackage pkg ->
- let components = J.object $
- [ comp2str c J..= (J.object $
- [ "depends" J..= map (jdisplay . confInstId) ldeps
- , "exe-depends" J..= map (jdisplay . confInstId) edeps
- ] ++
- bin_file c)
- | (c,(ldeps,edeps))
- <- ComponentDeps.toList $
- ComponentDeps.zip (pkgLibDependencies pkg)
- (pkgExeDependencies pkg) ]
- in ["components" J..= components]
- ElabComponent comp ->
- ["depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab)
- ,"exe-depends" J..= map jdisplay (elabExeDependencies elab)
- ,"component-name" J..= J.String (comp2str (compSolverName comp))
- ] ++
- bin_file (compSolverName comp)
- where
- -- | Only add build-info file location if the Setup.hs CLI
- -- is recent enough to be able to generate build info files.
- -- Otherwise, write 'null'.
- --
- -- Consumers of `plan.json` can use the nullability of this file location
- -- to indicate that the given component uses `build-type: Custom`
- -- with an old lib:Cabal version.
- buildInfoFileLocation :: J.Pair
- buildInfoFileLocation
- | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0]
- = "build-info" J..= J.Null
- | otherwise
- = "build-info" J..= J.String (buildInfoPref dist_dir)
-
- packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value
- packageLocationToJ pkgloc =
- case pkgloc of
- LocalUnpackedPackage local ->
- J.object [ "type" J..= J.String "local"
- , "path" J..= J.String local
- ]
- LocalTarballPackage local ->
- J.object [ "type" J..= J.String "local-tar"
- , "path" J..= J.String local
- ]
- RemoteTarballPackage uri _ ->
- J.object [ "type" J..= J.String "remote-tar"
- , "uri" J..= J.String (show uri)
- ]
- RepoTarballPackage repo _ _ ->
- J.object [ "type" J..= J.String "repo-tar"
- , "repo" J..= repoToJ repo
- ]
- RemoteSourceRepoPackage srcRepo _ ->
- J.object [ "type" J..= J.String "source-repo"
- , "source-repo" J..= sourceRepoToJ srcRepo
- ]
-
- repoToJ :: Repo -> J.Value
- repoToJ repo =
- case repo of
- RepoLocalNoIndex{..} ->
- J.object [ "type" J..= J.String "local-repo-no-index"
- , "path" J..= J.String repoLocalDir
- ]
- RepoRemote{..} ->
- J.object [ "type" J..= J.String "remote-repo"
- , "uri" J..= J.String (show (remoteRepoURI repoRemote))
- ]
- RepoSecure{..} ->
- J.object [ "type" J..= J.String "secure-repo"
- , "uri" J..= J.String (show (remoteRepoURI repoRemote))
- ]
-
- sourceRepoToJ :: SourceRepoMaybe -> J.Value
- sourceRepoToJ SourceRepositoryPackage{..} =
- J.object $ filter ((/= J.Null) . snd) $
- [ "type" J..= jdisplay srpType
- , "location" J..= J.String srpLocation
- , "branch" J..= fmap J.String srpBranch
- , "tag" J..= fmap J.String srpTag
- , "subdir" J..= fmap J.String srpSubdir
- ]
-
- dist_dir :: FilePath
- dist_dir = distBuildDirectory distDirLayout
- (elabDistDirParams elaboratedSharedConfig elab)
-
- bin_file :: ComponentDeps.Component -> [J.Pair]
- bin_file c = case c of
- ComponentDeps.ComponentExe s -> bin_file' s
- ComponentDeps.ComponentTest s -> bin_file' s
- ComponentDeps.ComponentBench s -> bin_file' s
- ComponentDeps.ComponentFLib s -> flib_file' s
- _ -> []
- bin_file' s =
- ["bin-file" J..= J.String bin]
- where
- bin = if elabBuildStyle elab == BuildInplaceOnly
- then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat
- else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat
-
- flib_file' :: (Pretty a, Show a) => a -> [J.Pair]
- flib_file' s =
- ["bin-file" J..= J.String bin]
- where
- bin = if elabBuildStyle elab == BuildInplaceOnly
- then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat
- else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat
+ , "flags"
+ J..= J.object
+ [ PD.unFlagName fn J..= v
+ | (fn, v) <- PD.unFlagAssignment (elabFlagAssignment elab)
+ ]
+ , "style" J..= J.String (style2str (elabLocalToProject elab) (elabBuildStyle elab))
+ , "pkg-src" J..= packageLocationToJ (elabPkgSourceLocation elab)
+ ]
+ ++ [ "pkg-cabal-sha256" J..= J.String (showHashValue hash)
+ | Just hash <- [fmap hashValue (elabPkgDescriptionOverride elab)]
+ ]
+ ++ [ "pkg-src-sha256" J..= J.String (showHashValue hash)
+ | Just hash <- [elabPkgSourceHash elab]
+ ]
+ ++ ( case elabBuildStyle elab of
+ BuildInplaceOnly ->
+ ["dist-dir" J..= J.String dist_dir] ++ [buildInfoFileLocation]
+ BuildAndInstall ->
+ -- TODO: install dirs?
+ []
+ )
+ ++ case elabPkgOrComp elab of
+ ElabPackage pkg ->
+ let components =
+ J.object $
+ [ comp2str c
+ J..= ( J.object $
+ [ "depends" J..= map (jdisplay . confInstId) ldeps
+ , "exe-depends" J..= map (jdisplay . confInstId) edeps
+ ]
+ ++ bin_file c
+ )
+ | (c, (ldeps, edeps)) <-
+ ComponentDeps.toList $
+ ComponentDeps.zip
+ (pkgLibDependencies pkg)
+ (pkgExeDependencies pkg)
+ ]
+ in ["components" J..= components]
+ ElabComponent comp ->
+ [ "depends" J..= map (jdisplay . confInstId) (elabLibDependencies elab)
+ , "exe-depends" J..= map jdisplay (elabExeDependencies elab)
+ , "component-name" J..= J.String (comp2str (compSolverName comp))
+ ]
+ ++ bin_file (compSolverName comp)
+ where
+ -- \| Only add build-info file location if the Setup.hs CLI
+ -- is recent enough to be able to generate build info files.
+ -- Otherwise, write 'null'.
+ --
+ -- Consumers of `plan.json` can use the nullability of this file location
+ -- to indicate that the given component uses `build-type: Custom`
+ -- with an old lib:Cabal version.
+ buildInfoFileLocation :: J.Pair
+ buildInfoFileLocation
+ | elabSetupScriptCliVersion elab < mkVersion [3, 7, 0, 0] =
+ "build-info" J..= J.Null
+ | otherwise =
+ "build-info" J..= J.String (buildInfoPref dist_dir)
+
+ packageLocationToJ :: PackageLocation (Maybe FilePath) -> J.Value
+ packageLocationToJ pkgloc =
+ case pkgloc of
+ LocalUnpackedPackage local ->
+ J.object
+ [ "type" J..= J.String "local"
+ , "path" J..= J.String local
+ ]
+ LocalTarballPackage local ->
+ J.object
+ [ "type" J..= J.String "local-tar"
+ , "path" J..= J.String local
+ ]
+ RemoteTarballPackage uri _ ->
+ J.object
+ [ "type" J..= J.String "remote-tar"
+ , "uri" J..= J.String (show uri)
+ ]
+ RepoTarballPackage repo _ _ ->
+ J.object
+ [ "type" J..= J.String "repo-tar"
+ , "repo" J..= repoToJ repo
+ ]
+ RemoteSourceRepoPackage srcRepo _ ->
+ J.object
+ [ "type" J..= J.String "source-repo"
+ , "source-repo" J..= sourceRepoToJ srcRepo
+ ]
+
+ repoToJ :: Repo -> J.Value
+ repoToJ repo =
+ case repo of
+ RepoLocalNoIndex{..} ->
+ J.object
+ [ "type" J..= J.String "local-repo-no-index"
+ , "path" J..= J.String repoLocalDir
+ ]
+ RepoRemote{..} ->
+ J.object
+ [ "type" J..= J.String "remote-repo"
+ , "uri" J..= J.String (show (remoteRepoURI repoRemote))
+ ]
+ RepoSecure{..} ->
+ J.object
+ [ "type" J..= J.String "secure-repo"
+ , "uri" J..= J.String (show (remoteRepoURI repoRemote))
+ ]
+
+ sourceRepoToJ :: SourceRepoMaybe -> J.Value
+ sourceRepoToJ SourceRepositoryPackage{..} =
+ J.object $
+ filter ((/= J.Null) . snd) $
+ [ "type" J..= jdisplay srpType
+ , "location" J..= J.String srpLocation
+ , "branch" J..= fmap J.String srpBranch
+ , "tag" J..= fmap J.String srpTag
+ , "subdir" J..= fmap J.String srpSubdir
+ ]
+
+ dist_dir :: FilePath
+ dist_dir =
+ distBuildDirectory
+ distDirLayout
+ (elabDistDirParams elaboratedSharedConfig elab)
+
+ bin_file :: ComponentDeps.Component -> [J.Pair]
+ bin_file c = case c of
+ ComponentDeps.ComponentExe s -> bin_file' s
+ ComponentDeps.ComponentTest s -> bin_file' s
+ ComponentDeps.ComponentBench s -> bin_file' s
+ ComponentDeps.ComponentFLib s -> flib_file' s
+ _ -> []
+ bin_file' s =
+ ["bin-file" J..= J.String bin]
+ where
+ bin =
+ if elabBuildStyle elab == BuildInplaceOnly
+ then dist_dir </> "build" </> prettyShow s </> prettyShow s <.> exeExtension plat
+ else InstallDirs.bindir (elabInstallDirs elab) </> prettyShow s <.> exeExtension plat
+
+ flib_file' :: (Pretty a, Show a) => a -> [J.Pair]
+ flib_file' s =
+ ["bin-file" J..= J.String bin]
+ where
+ bin =
+ if elabBuildStyle elab == BuildInplaceOnly
+ then dist_dir </> "build" </> prettyShow s </> ("lib" ++ prettyShow s) <.> dllExtension plat
+ else InstallDirs.bindir (elabInstallDirs elab) </> ("lib" ++ prettyShow s) <.> dllExtension plat
comp2str :: ComponentDeps.Component -> String
comp2str = prettyShow
style2str :: Bool -> BuildStyle -> String
- style2str True _ = "local"
+ style2str True _ = "local"
style2str False BuildInplaceOnly = "inplace"
- style2str False BuildAndInstall = "global"
+ style2str False BuildAndInstall = "global"
jdisplay :: Pretty a => a -> J.Value
jdisplay = J.String . prettyShow
@@ -400,284 +448,270 @@ encodePlanAsJson distDirLayout elaboratedInstallPlan elaboratedSharedConfig =
-- successfully then they're still out of date -- meeting our definition of
-- invalid.
-
-type PackageIdSet = Set UnitId
+type PackageIdSet = Set UnitId
type PackagesUpToDate = PackageIdSet
-data PostBuildProjectStatus = PostBuildProjectStatus {
-
- -- | Packages that are known to be up to date. These were found to be
- -- up to date before the build, or they have a successful build outcome
- -- afterwards.
- --
- -- This does not include any packages outside of the subset of the plan
- -- that was executed because we did not check those and so don't know
- -- for sure that they're still up to date.
- --
- packagesDefinitelyUpToDate :: PackageIdSet,
-
- -- | Packages that are probably still up to date (and at least not
- -- known to be out of date, and certainly not invalid). This includes
- -- 'packagesDefinitelyUpToDate' plus packages that were up to date
- -- previously and are outside of the subset of the plan that was
- -- executed. It excludes 'packagesOutOfDate'.
- --
- packagesProbablyUpToDate :: PackageIdSet,
-
- -- | Packages that are known to be out of date. These are packages
- -- that were determined to be out of date before the build, and they
- -- do not have a successful build outcome afterwards.
- --
- -- Note that this can sometimes include packages outside of the subset
- -- of the plan that was executed. For example suppose package A and B
- -- depend on C, and A is the target so only A and C are in the subset
- -- to be built. Now suppose C is found to have changed, then both A
- -- and B are out-of-date before the build and since B is outside the
- -- subset to be built then it will remain out of date.
- --
- -- Note also that this is /not/ the inverse of
- -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'.
- -- There are packages where we have no information (ones that were not
- -- in the subset of the plan that was executed).
- --
- packagesOutOfDate :: PackageIdSet,
-
- -- | Packages that depend on libraries that have changed during the
- -- build (either build success or failure).
- --
- -- This corresponds to the fact that libraries and dynamic executables
- -- are invalid once any of the libs they depend on change.
- --
- -- This does include packages that themselves failed (i.e. it is a
- -- superset of 'packagesInvalidByFailedBuild'). It does not include
- -- changes in dependencies on executables (i.e. build tools).
- --
- packagesInvalidByChangedLibDeps :: PackageIdSet,
-
- -- | Packages that themselves failed during the build (i.e. them
- -- directly not a dep).
- --
- -- This corresponds to the fact that static executables are invalid
- -- in unlucky circumstances such as linking failing half way though,
- -- or data file generation failing.
- --
- -- This is a subset of 'packagesInvalidByChangedLibDeps'.
- --
- packagesInvalidByFailedBuild :: PackageIdSet,
-
- -- | A subset of the plan graph, including only dependency-on-library
- -- edges. That is, dependencies /on/ libraries, not dependencies /of/
- -- libraries. This tells us all the libraries that packages link to.
- --
- -- This is here as a convenience, as strictly speaking it's not status
- -- as it's just a function of the original 'ElaboratedInstallPlan'.
- --
- packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage),
-
- -- | As a convenience for 'Set.intersection' with any of the other
- -- 'PackageIdSet's to select only packages that are part of the
- -- project locally (i.e. with a local source dir).
- --
- packagesBuildLocal :: PackageIdSet,
-
- -- | As a convenience for 'Set.intersection' with any of the other
- -- 'PackageIdSet's to select only packages that are being built
- -- in-place within the project (i.e. not destined for the store).
- --
- packagesBuildInplace :: PackageIdSet,
-
- -- | As a convenience for 'Set.intersection' or 'Set.difference' with
- -- any of the other 'PackageIdSet's to select only packages that were
- -- pre-installed or already in the store prior to the build.
- --
- packagesAlreadyInStore :: PackageIdSet
- }
+data PostBuildProjectStatus = PostBuildProjectStatus
+ { packagesDefinitelyUpToDate :: PackageIdSet
+ -- ^ Packages that are known to be up to date. These were found to be
+ -- up to date before the build, or they have a successful build outcome
+ -- afterwards.
+ --
+ -- This does not include any packages outside of the subset of the plan
+ -- that was executed because we did not check those and so don't know
+ -- for sure that they're still up to date.
+ , packagesProbablyUpToDate :: PackageIdSet
+ -- ^ Packages that are probably still up to date (and at least not
+ -- known to be out of date, and certainly not invalid). This includes
+ -- 'packagesDefinitelyUpToDate' plus packages that were up to date
+ -- previously and are outside of the subset of the plan that was
+ -- executed. It excludes 'packagesOutOfDate'.
+ , packagesOutOfDate :: PackageIdSet
+ -- ^ Packages that are known to be out of date. These are packages
+ -- that were determined to be out of date before the build, and they
+ -- do not have a successful build outcome afterwards.
+ --
+ -- Note that this can sometimes include packages outside of the subset
+ -- of the plan that was executed. For example suppose package A and B
+ -- depend on C, and A is the target so only A and C are in the subset
+ -- to be built. Now suppose C is found to have changed, then both A
+ -- and B are out-of-date before the build and since B is outside the
+ -- subset to be built then it will remain out of date.
+ --
+ -- Note also that this is /not/ the inverse of
+ -- 'packagesDefinitelyUpToDate' or 'packagesProbablyUpToDate'.
+ -- There are packages where we have no information (ones that were not
+ -- in the subset of the plan that was executed).
+ , packagesInvalidByChangedLibDeps :: PackageIdSet
+ -- ^ Packages that depend on libraries that have changed during the
+ -- build (either build success or failure).
+ --
+ -- This corresponds to the fact that libraries and dynamic executables
+ -- are invalid once any of the libs they depend on change.
+ --
+ -- This does include packages that themselves failed (i.e. it is a
+ -- superset of 'packagesInvalidByFailedBuild'). It does not include
+ -- changes in dependencies on executables (i.e. build tools).
+ , packagesInvalidByFailedBuild :: PackageIdSet
+ -- ^ Packages that themselves failed during the build (i.e. them
+ -- directly not a dep).
+ --
+ -- This corresponds to the fact that static executables are invalid
+ -- in unlucky circumstances such as linking failing half way though,
+ -- or data file generation failing.
+ --
+ -- This is a subset of 'packagesInvalidByChangedLibDeps'.
+ , packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
+ -- ^ A subset of the plan graph, including only dependency-on-library
+ -- edges. That is, dependencies /on/ libraries, not dependencies /of/
+ -- libraries. This tells us all the libraries that packages link to.
+ --
+ -- This is here as a convenience, as strictly speaking it's not status
+ -- as it's just a function of the original 'ElaboratedInstallPlan'.
+ , packagesBuildLocal :: PackageIdSet
+ -- ^ As a convenience for 'Set.intersection' with any of the other
+ -- 'PackageIdSet's to select only packages that are part of the
+ -- project locally (i.e. with a local source dir).
+ , packagesBuildInplace :: PackageIdSet
+ -- ^ As a convenience for 'Set.intersection' with any of the other
+ -- 'PackageIdSet's to select only packages that are being built
+ -- in-place within the project (i.e. not destined for the store).
+ , packagesAlreadyInStore :: PackageIdSet
+ -- ^ As a convenience for 'Set.intersection' or 'Set.difference' with
+ -- any of the other 'PackageIdSet's to select only packages that were
+ -- pre-installed or already in the store prior to the build.
+ }
-- | Work out which packages are out of date or invalid after a build.
---
-postBuildProjectStatus :: ElaboratedInstallPlan
- -> PackagesUpToDate
- -> BuildStatusMap
- -> BuildOutcomes
- -> PostBuildProjectStatus
-postBuildProjectStatus plan previousPackagesUpToDate
- pkgBuildStatus buildOutcomes =
- PostBuildProjectStatus {
- packagesDefinitelyUpToDate,
- packagesProbablyUpToDate,
- packagesOutOfDate,
- packagesInvalidByChangedLibDeps,
- packagesInvalidByFailedBuild,
- -- convenience stuff
- packagesLibDepGraph,
- packagesBuildLocal,
- packagesBuildInplace,
- packagesAlreadyInStore
- }
- where
- packagesDefinitelyUpToDate =
- packagesUpToDatePreBuild
- `Set.union`
- packagesSuccessfulPostBuild
-
- packagesProbablyUpToDate =
- packagesDefinitelyUpToDate
- `Set.union`
- (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild)
-
- packagesOutOfDate =
- packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild
-
- packagesInvalidByChangedLibDeps =
- packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild
-
- packagesInvalidByFailedBuild =
- packagesFailurePostBuild
-
- -- Note: if any of the intermediate values below turn out to be useful in
- -- their own right then we can simply promote them to the result record
-
- -- The previous set of up-to-date packages will contain bogus package ids
- -- when the solver plan or config contributing to the hash changes.
- -- So keep only the ones where the package id (i.e. hash) is the same.
- previousPackagesUpToDate' =
- Set.intersection
- previousPackagesUpToDate
- (InstallPlan.keysSet plan)
-
- packagesUpToDatePreBuild =
- Set.filter
- (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid))
- -- For packages not in the plan subset we did the dry-run on we don't
- -- know anything about their status, so not known to be /up to date/.
- (InstallPlan.keysSet plan)
-
- packagesOutOfDatePreBuild =
- Set.fromList . map installedUnitId $
- InstallPlan.reverseDependencyClosure plan
- [ ipkgid
- | pkg <- InstallPlan.toList plan
- , let ipkgid = installedUnitId pkg
- , lookupBuildStatusRequiresBuild False ipkgid
- -- For packages not in the plan subset we did the dry-run on we don't
- -- know anything about their status, so not known to be /out of date/.
- ]
-
- packagesSuccessfulPostBuild =
- Set.fromList
- [ ikgid | (ikgid, Right _) <- Map.toList buildOutcomes ]
-
- -- direct failures, not failures due to deps
- packagesFailurePostBuild =
- Set.fromList
- [ ikgid
- | (ikgid, Left failure) <- Map.toList buildOutcomes
- , case buildFailureReason failure of
- DependentFailed _ -> False
- _ -> True
- ]
-
- -- Packages that have a library dependency on a package for which a build
- -- was attempted
- packagesDepOnChangedLib =
- Set.fromList . map Graph.nodeKey $
- fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $
- Graph.revClosure packagesLibDepGraph
- ( Map.keys
- . Map.filter (uncurry buildAttempted)
- $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes
- )
-
- -- The plan graph but only counting dependency-on-library edges
- packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
- packagesLibDepGraph =
- Graph.fromDistinctList
- [ Graph.N pkg (installedUnitId pkg) libdeps
- | pkg <- InstallPlan.toList plan
- , let libdeps = case pkg of
- InstallPlan.PreExisting ipkg -> installedDepends ipkg
- InstallPlan.Configured srcpkg -> elabLibDeps srcpkg
- InstallPlan.Installed srcpkg -> elabLibDeps srcpkg
- ]
+postBuildProjectStatus
+ :: ElaboratedInstallPlan
+ -> PackagesUpToDate
+ -> BuildStatusMap
+ -> BuildOutcomes
+ -> PostBuildProjectStatus
+postBuildProjectStatus
+ plan
+ previousPackagesUpToDate
+ pkgBuildStatus
+ buildOutcomes =
+ PostBuildProjectStatus
+ { packagesDefinitelyUpToDate
+ , packagesProbablyUpToDate
+ , packagesOutOfDate
+ , packagesInvalidByChangedLibDeps
+ , packagesInvalidByFailedBuild
+ , -- convenience stuff
+ packagesLibDepGraph
+ , packagesBuildLocal
+ , packagesBuildInplace
+ , packagesAlreadyInStore
+ }
+ where
+ packagesDefinitelyUpToDate =
+ packagesUpToDatePreBuild
+ `Set.union` packagesSuccessfulPostBuild
+
+ packagesProbablyUpToDate =
+ packagesDefinitelyUpToDate
+ `Set.union` (previousPackagesUpToDate' `Set.difference` packagesOutOfDatePreBuild)
+
+ packagesOutOfDate =
+ packagesOutOfDatePreBuild `Set.difference` packagesSuccessfulPostBuild
+
+ packagesInvalidByChangedLibDeps =
+ packagesDepOnChangedLib `Set.difference` packagesSuccessfulPostBuild
+
+ packagesInvalidByFailedBuild =
+ packagesFailurePostBuild
+
+ -- Note: if any of the intermediate values below turn out to be useful in
+ -- their own right then we can simply promote them to the result record
+
+ -- The previous set of up-to-date packages will contain bogus package ids
+ -- when the solver plan or config contributing to the hash changes.
+ -- So keep only the ones where the package id (i.e. hash) is the same.
+ previousPackagesUpToDate' =
+ Set.intersection
+ previousPackagesUpToDate
+ (InstallPlan.keysSet plan)
+
+ packagesUpToDatePreBuild =
+ Set.filter
+ (\ipkgid -> not (lookupBuildStatusRequiresBuild True ipkgid))
+ -- For packages not in the plan subset we did the dry-run on we don't
+ -- know anything about their status, so not known to be /up to date/.
+ (InstallPlan.keysSet plan)
+
+ packagesOutOfDatePreBuild =
+ Set.fromList . map installedUnitId $
+ InstallPlan.reverseDependencyClosure
+ plan
+ [ ipkgid
+ | pkg <- InstallPlan.toList plan
+ , let ipkgid = installedUnitId pkg
+ , lookupBuildStatusRequiresBuild False ipkgid
+ -- For packages not in the plan subset we did the dry-run on we don't
+ -- know anything about their status, so not known to be /out of date/.
+ ]
+
+ packagesSuccessfulPostBuild =
+ Set.fromList
+ [ikgid | (ikgid, Right _) <- Map.toList buildOutcomes]
+
+ -- direct failures, not failures due to deps
+ packagesFailurePostBuild =
+ Set.fromList
+ [ ikgid
+ | (ikgid, Left failure) <- Map.toList buildOutcomes
+ , case buildFailureReason failure of
+ DependentFailed _ -> False
+ _ -> True
+ ]
- elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]
- elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies
-
- -- Was a build was attempted for this package?
- -- If it doesn't have both a build status and outcome then the answer is no.
- buildAttempted :: BuildStatus -> BuildOutcome -> Bool
- -- And not if it didn't need rebuilding in the first place.
- buildAttempted buildStatus _buildOutcome
- | not (buildStatusRequiresBuild buildStatus)
- = False
-
- -- And not if it was skipped due to a dep failing first.
- buildAttempted _ (Left BuildFailure {buildFailureReason})
- | DependentFailed _ <- buildFailureReason
- = False
-
- -- Otherwise, succeeded or failed, yes the build was tried.
- buildAttempted _ (Left BuildFailure {}) = True
- buildAttempted _ (Right _) = True
-
- lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool
- lookupBuildStatusRequiresBuild def ipkgid =
- case Map.lookup ipkgid pkgBuildStatus of
- Nothing -> def -- Not in the plan subset we did the dry-run on
- Just buildStatus -> buildStatusRequiresBuild buildStatus
-
- packagesBuildLocal :: Set UnitId
- packagesBuildLocal =
- selectPlanPackageIdSet $ \pkg ->
- case pkg of
- InstallPlan.PreExisting _ -> False
- InstallPlan.Installed _ -> False
- InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg
-
- packagesBuildInplace :: Set UnitId
- packagesBuildInplace =
- selectPlanPackageIdSet $ \pkg ->
- case pkg of
- InstallPlan.PreExisting _ -> False
- InstallPlan.Installed _ -> False
- InstallPlan.Configured srcpkg -> elabBuildStyle srcpkg
- == BuildInplaceOnly
- packagesAlreadyInStore :: Set UnitId
- packagesAlreadyInStore =
- selectPlanPackageIdSet $ \pkg ->
- case pkg of
- InstallPlan.PreExisting _ -> True
- InstallPlan.Installed _ -> True
- InstallPlan.Configured _ -> False
-
- selectPlanPackageIdSet
- :: (InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
- -> Bool)
- -> Set UnitId
- selectPlanPackageIdSet p = Map.keysSet
- . Map.filter p
- $ InstallPlan.toMap plan
-
-
-
-updatePostBuildProjectStatus :: Verbosity
- -> DistDirLayout
- -> ElaboratedInstallPlan
- -> BuildStatusMap
- -> BuildOutcomes
- -> IO PostBuildProjectStatus
-updatePostBuildProjectStatus verbosity distDirLayout
- elaboratedInstallPlan
- pkgsBuildStatus buildOutcomes = do
+ -- Packages that have a library dependency on a package for which a build
+ -- was attempted
+ packagesDepOnChangedLib =
+ Set.fromList . map Graph.nodeKey $
+ fromMaybe (error "packagesBuildStatusAfterBuild: broken dep closure") $
+ Graph.revClosure
+ packagesLibDepGraph
+ ( Map.keys
+ . Map.filter (uncurry buildAttempted)
+ $ Map.intersectionWith (,) pkgBuildStatus buildOutcomes
+ )
+
+ -- The plan graph but only counting dependency-on-library edges
+ packagesLibDepGraph :: Graph (Node UnitId ElaboratedPlanPackage)
+ packagesLibDepGraph =
+ Graph.fromDistinctList
+ [ Graph.N pkg (installedUnitId pkg) libdeps
+ | pkg <- InstallPlan.toList plan
+ , let libdeps = case pkg of
+ InstallPlan.PreExisting ipkg -> installedDepends ipkg
+ InstallPlan.Configured srcpkg -> elabLibDeps srcpkg
+ InstallPlan.Installed srcpkg -> elabLibDeps srcpkg
+ ]
+ elabLibDeps :: ElaboratedConfiguredPackage -> [UnitId]
+ elabLibDeps = map (newSimpleUnitId . confInstId) . elabLibDependencies
+
+ -- Was a build was attempted for this package?
+ -- If it doesn't have both a build status and outcome then the answer is no.
+ buildAttempted :: BuildStatus -> BuildOutcome -> Bool
+ -- And not if it didn't need rebuilding in the first place.
+ buildAttempted buildStatus _buildOutcome
+ | not (buildStatusRequiresBuild buildStatus) =
+ False
+ -- And not if it was skipped due to a dep failing first.
+ buildAttempted _ (Left BuildFailure{buildFailureReason})
+ | DependentFailed _ <- buildFailureReason =
+ False
+ -- Otherwise, succeeded or failed, yes the build was tried.
+ buildAttempted _ (Left BuildFailure{}) = True
+ buildAttempted _ (Right _) = True
+
+ lookupBuildStatusRequiresBuild :: Bool -> UnitId -> Bool
+ lookupBuildStatusRequiresBuild def ipkgid =
+ case Map.lookup ipkgid pkgBuildStatus of
+ Nothing -> def -- Not in the plan subset we did the dry-run on
+ Just buildStatus -> buildStatusRequiresBuild buildStatus
+
+ packagesBuildLocal :: Set UnitId
+ packagesBuildLocal =
+ selectPlanPackageIdSet $ \pkg ->
+ case pkg of
+ InstallPlan.PreExisting _ -> False
+ InstallPlan.Installed _ -> False
+ InstallPlan.Configured srcpkg -> elabLocalToProject srcpkg
+
+ packagesBuildInplace :: Set UnitId
+ packagesBuildInplace =
+ selectPlanPackageIdSet $ \pkg ->
+ case pkg of
+ InstallPlan.PreExisting _ -> False
+ InstallPlan.Installed _ -> False
+ InstallPlan.Configured srcpkg ->
+ elabBuildStyle srcpkg
+ == BuildInplaceOnly
+ packagesAlreadyInStore :: Set UnitId
+ packagesAlreadyInStore =
+ selectPlanPackageIdSet $ \pkg ->
+ case pkg of
+ InstallPlan.PreExisting _ -> True
+ InstallPlan.Installed _ -> True
+ InstallPlan.Configured _ -> False
+
+ selectPlanPackageIdSet
+ :: ( InstallPlan.GenericPlanPackage InstalledPackageInfo ElaboratedConfiguredPackage
+ -> Bool
+ )
+ -> Set UnitId
+ selectPlanPackageIdSet p =
+ Map.keysSet
+ . Map.filter p
+ $ InstallPlan.toMap plan
+
+updatePostBuildProjectStatus
+ :: Verbosity
+ -> DistDirLayout
+ -> ElaboratedInstallPlan
+ -> BuildStatusMap
+ -> BuildOutcomes
+ -> IO PostBuildProjectStatus
+updatePostBuildProjectStatus
+ verbosity
+ distDirLayout
+ elaboratedInstallPlan
+ pkgsBuildStatus
+ buildOutcomes = do
-- Read the previous up-to-date set, update it and write it back
- previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout
- let currentBuildStatus@PostBuildProjectStatus{..}
- = postBuildProjectStatus
- elaboratedInstallPlan
- previousUpToDate
- pkgsBuildStatus
- buildOutcomes
+ previousUpToDate <- readPackagesUpToDateCacheFile distDirLayout
+ let currentBuildStatus@PostBuildProjectStatus{..} =
+ postBuildProjectStatus
+ elaboratedInstallPlan
+ previousUpToDate
+ pkgsBuildStatus
+ buildOutcomes
let currentUpToDate = packagesProbablyUpToDate
writePackagesUpToDateCacheFile distDirLayout currentUpToDate
@@ -685,50 +719,59 @@ updatePostBuildProjectStatus verbosity distDirLayout
-- We additionally intersect with the packagesBuildInplace so that
-- we don't show huge numbers of boring packages from the store.
debugNoWrap verbosity $
- "packages definitely up to date: "
- ++ displayPackageIdSet (packagesDefinitelyUpToDate
- `Set.intersection` packagesBuildInplace)
+ "packages definitely up to date: "
+ ++ displayPackageIdSet
+ ( packagesDefinitelyUpToDate
+ `Set.intersection` packagesBuildInplace
+ )
debugNoWrap verbosity $
- "packages previously probably up to date: "
- ++ displayPackageIdSet (previousUpToDate
- `Set.intersection` packagesBuildInplace)
+ "packages previously probably up to date: "
+ ++ displayPackageIdSet
+ ( previousUpToDate
+ `Set.intersection` packagesBuildInplace
+ )
debugNoWrap verbosity $
- "packages now probably up to date: "
- ++ displayPackageIdSet (packagesProbablyUpToDate
- `Set.intersection` packagesBuildInplace)
+ "packages now probably up to date: "
+ ++ displayPackageIdSet
+ ( packagesProbablyUpToDate
+ `Set.intersection` packagesBuildInplace
+ )
debugNoWrap verbosity $
- "packages newly up to date: "
- ++ displayPackageIdSet (packagesDefinitelyUpToDate
- `Set.difference` previousUpToDate
- `Set.intersection` packagesBuildInplace)
+ "packages newly up to date: "
+ ++ displayPackageIdSet
+ ( packagesDefinitelyUpToDate
+ `Set.difference` previousUpToDate
+ `Set.intersection` packagesBuildInplace
+ )
debugNoWrap verbosity $
- "packages out to date: "
- ++ displayPackageIdSet (packagesOutOfDate
- `Set.intersection` packagesBuildInplace)
+ "packages out to date: "
+ ++ displayPackageIdSet
+ ( packagesOutOfDate
+ `Set.intersection` packagesBuildInplace
+ )
debugNoWrap verbosity $
- "packages invalid due to dep change: "
- ++ displayPackageIdSet packagesInvalidByChangedLibDeps
+ "packages invalid due to dep change: "
+ ++ displayPackageIdSet packagesInvalidByChangedLibDeps
debugNoWrap verbosity $
- "packages invalid due to build failure: "
- ++ displayPackageIdSet packagesInvalidByFailedBuild
+ "packages invalid due to build failure: "
+ ++ displayPackageIdSet packagesInvalidByFailedBuild
return currentBuildStatus
- where
- displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList
+ where
+ displayPackageIdSet = intercalate ", " . map prettyShow . Set.toList
-- | Helper for reading the cache file.
--
-- This determines the type and format of the binary cache file.
---
readPackagesUpToDateCacheFile :: DistDirLayout -> IO PackagesUpToDate
readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =
- handleDoesNotExist Set.empty $
+ handleDoesNotExist Set.empty $
handleDecodeFailure $
withBinaryFile (distProjectCacheFile "up-to-date") ReadMode $ \hnd ->
Binary.decodeOrFailIO =<< BS.hGetContents hnd
@@ -738,11 +781,10 @@ readPackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} =
-- | Helper for writing the package up-to-date cache file.
--
-- This determines the type and format of the binary cache file.
---
writePackagesUpToDateCacheFile :: DistDirLayout -> PackagesUpToDate -> IO ()
writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =
- writeFileAtomic (distProjectCacheFile "up-to-date") $
- Binary.encode upToDate
+ writeFileAtomic (distProjectCacheFile "up-to-date") $
+ Binary.encode upToDate
-- | Prepare a package environment that includes all the library dependencies
-- for a plan.
@@ -753,84 +795,96 @@ writePackagesUpToDateCacheFile DistDirLayout{distProjectCacheFile} upToDate =
-- temporarily, in case the compiler wants to learn this information via the
-- filesystem, and returns any environment variable overrides the compiler
-- needs.
-createPackageEnvironment :: Verbosity
- -> FilePath
- -> ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> PostBuildProjectStatus
- -> IO [(String, Maybe String)]
-createPackageEnvironment verbosity
- path
- elaboratedPlan
- elaboratedShared
- buildStatus
- | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC
- = do
- envFileM <- writePlanGhcEnvironment
- path
- elaboratedPlan
- elaboratedShared
- buildStatus
- case envFileM of
- Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)]
- Nothing -> do
- warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail"
- return []
- | otherwise
- = do
- warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"
- return []
+createPackageEnvironment
+ :: Verbosity
+ -> FilePath
+ -> ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> PostBuildProjectStatus
+ -> IO [(String, Maybe String)]
+createPackageEnvironment
+ verbosity
+ path
+ elaboratedPlan
+ elaboratedShared
+ buildStatus
+ | compilerFlavor (pkgConfigCompiler elaboratedShared) == GHC =
+ do
+ envFileM <-
+ writePlanGhcEnvironment
+ path
+ elaboratedPlan
+ elaboratedShared
+ buildStatus
+ case envFileM of
+ Just envFile -> return [("GHC_ENVIRONMENT", Just envFile)]
+ Nothing -> do
+ warn verbosity "the configured version of GHC does not support reading package lists from the environment; commands that need the current project's package database are likely to fail"
+ return []
+ | otherwise =
+ do
+ warn verbosity "package environment configuration is not supported for the currently configured compiler; commands that need the current project's package database are likely to fail"
+ return []
-- Writing .ghc.environment files
--
-writePlanGhcEnvironment :: FilePath
- -> ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> PostBuildProjectStatus
- -> IO (Maybe FilePath)
-writePlanGhcEnvironment path
- elaboratedInstallPlan
- ElaboratedSharedConfig {
- pkgConfigCompiler = compiler,
- pkgConfigPlatform = platform
- }
- postBuildStatus
- | compilerFlavor compiler == GHC
- , supportsPkgEnvFiles (getImplInfo compiler)
- --TODO: check ghcjs compat
- = fmap Just $ writeGhcEnvironmentFile
- path
- platform (compilerVersion compiler)
- (renderGhcEnvironmentFile path
- elaboratedInstallPlan
- postBuildStatus)
- --TODO: [required eventually] support for writing user-wide package
- -- environments, e.g. like a global project, but we would not put the
- -- env file in the home dir, rather it lives under ~/.ghc/
+writePlanGhcEnvironment
+ :: FilePath
+ -> ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> PostBuildProjectStatus
+ -> IO (Maybe FilePath)
+writePlanGhcEnvironment
+ path
+ elaboratedInstallPlan
+ ElaboratedSharedConfig
+ { pkgConfigCompiler = compiler
+ , pkgConfigPlatform = platform
+ }
+ postBuildStatus
+ | compilerFlavor compiler == GHC
+ , supportsPkgEnvFiles (getImplInfo compiler) =
+ -- TODO: check ghcjs compat
+ fmap Just $
+ writeGhcEnvironmentFile
+ path
+ platform
+ (compilerVersion compiler)
+ ( renderGhcEnvironmentFile
+ path
+ elaboratedInstallPlan
+ postBuildStatus
+ )
+-- TODO: [required eventually] support for writing user-wide package
+-- environments, e.g. like a global project, but we would not put the
+-- env file in the home dir, rather it lives under ~/.ghc/
writePlanGhcEnvironment _ _ _ _ = return Nothing
-renderGhcEnvironmentFile :: FilePath
- -> ElaboratedInstallPlan
- -> PostBuildProjectStatus
- -> [GhcEnvironmentFileEntry]
-renderGhcEnvironmentFile projectRootDir elaboratedInstallPlan
- postBuildStatus =
+renderGhcEnvironmentFile
+ :: FilePath
+ -> ElaboratedInstallPlan
+ -> PostBuildProjectStatus
+ -> [GhcEnvironmentFileEntry]
+renderGhcEnvironmentFile
+ projectRootDir
+ elaboratedInstallPlan
+ postBuildStatus =
headerComment
- : simpleGhcEnvironmentFile packageDBs unitIds
- where
- headerComment =
- GhcEnvFileComment
- $ "This is a GHC environment file written by cabal. This means you can\n"
- ++ "run ghc or ghci and get the environment of the project as a whole.\n"
- ++ "But you still need to use cabal repl $target to get the environment\n"
- ++ "of specific components (libs, exes, tests etc) because each one can\n"
- ++ "have its own source dirs, cpp flags etc.\n\n"
- unitIds = selectGhcEnvironmentFileLibraries postBuildStatus
- packageDBs = relativePackageDBPaths projectRootDir $
- selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
-
+ : simpleGhcEnvironmentFile packageDBs unitIds
+ where
+ headerComment =
+ GhcEnvFileComment $
+ "This is a GHC environment file written by cabal. This means you can\n"
+ ++ "run ghc or ghci and get the environment of the project as a whole.\n"
+ ++ "But you still need to use cabal repl $target to get the environment\n"
+ ++ "of specific components (libs, exes, tests etc) because each one can\n"
+ ++ "have its own source dirs, cpp flags etc.\n\n"
+ unitIds = selectGhcEnvironmentFileLibraries postBuildStatus
+ packageDBs =
+ relativePackageDBPaths projectRootDir $
+ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
argsEquivalentOfGhcEnvironmentFile
:: Compiler
@@ -839,10 +893,10 @@ argsEquivalentOfGhcEnvironmentFile
-> PostBuildProjectStatus
-> [String]
argsEquivalentOfGhcEnvironmentFile compiler =
- case compilerId compiler
- of CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc
- CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc
- CompilerId _ _ -> error "Only GHC and GHCJS are supported"
+ case compilerId compiler of
+ CompilerId GHC _ -> argsEquivalentOfGhcEnvironmentFileGhc
+ CompilerId GHCJS _ -> argsEquivalentOfGhcEnvironmentFileGhc
+ CompilerId _ _ -> error "Only GHC and GHCJS are supported"
-- TODO remove this when we drop support for non-.ghc.env ghc
argsEquivalentOfGhcEnvironmentFileGhc
@@ -855,17 +909,17 @@ argsEquivalentOfGhcEnvironmentFileGhc
elaboratedInstallPlan
postBuildStatus =
clearPackageDbStackFlag
- ++ packageDbArgsDb packageDBs
- ++ foldMap packageIdFlag packageIds
- where
- projectRootDir = distProjectRootDirectory distDirLayout
- packageIds = selectGhcEnvironmentFileLibraries postBuildStatus
- packageDBs = relativePackageDBPaths projectRootDir $
- selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
- -- TODO use proper flags? but packageDbArgsDb is private
- clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]
- packageIdFlag uid = ["-package-id", prettyShow uid]
-
+ ++ packageDbArgsDb packageDBs
+ ++ foldMap packageIdFlag packageIds
+ where
+ projectRootDir = distProjectRootDirectory distDirLayout
+ packageIds = selectGhcEnvironmentFileLibraries postBuildStatus
+ packageDBs =
+ relativePackageDBPaths projectRootDir $
+ selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan
+ -- TODO use proper flags? but packageDbArgsDb is private
+ clearPackageDbStackFlag = ["-clear-package-db", "-global-package-db"]
+ packageIdFlag uid = ["-package-id", prettyShow uid]
-- We're producing an environment for users to use in ghci, so of course
-- that means libraries only (can't put exes into the ghc package env!).
@@ -901,62 +955,63 @@ argsEquivalentOfGhcEnvironmentFileGhc
--
selectGhcEnvironmentFileLibraries :: PostBuildProjectStatus -> [UnitId]
selectGhcEnvironmentFileLibraries PostBuildProjectStatus{..} =
- case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of
- Nothing -> error "renderGhcEnvironmentFile: broken dep closure"
- Just nodes -> [ pkgid | Graph.N pkg pkgid _ <- nodes
- , hasUpToDateLib pkg ]
+ case Graph.closure packagesLibDepGraph (Set.toList packagesBuildLocal) of
+ Nothing -> error "renderGhcEnvironmentFile: broken dep closure"
+ Just nodes ->
+ [ pkgid | Graph.N pkg pkgid _ <- nodes, hasUpToDateLib pkg
+ ]
where
hasUpToDateLib planpkg = case planpkg of
-- A pre-existing global lib
- InstallPlan.PreExisting _ -> True
-
+ InstallPlan.PreExisting _ -> True
-- A package in the store. Check it's a lib.
- InstallPlan.Installed pkg -> elabRequiresRegistration pkg
-
+ InstallPlan.Installed pkg -> elabRequiresRegistration pkg
-- A package we were installing this time, either destined for the store
-- or just locally. Check it's a lib and that it is probably up to date.
InstallPlan.Configured pkg ->
- elabRequiresRegistration pkg
- && installedUnitId pkg `Set.member` packagesProbablyUpToDate
-
+ elabRequiresRegistration pkg
+ && installedUnitId pkg `Set.member` packagesProbablyUpToDate
selectGhcEnvironmentFilePackageDbs :: ElaboratedInstallPlan -> PackageDBStack
selectGhcEnvironmentFilePackageDbs elaboratedInstallPlan =
- -- If we have any inplace packages then their package db stack is the
- -- one we should use since it'll include the store + the local db but
- -- it's certainly possible to have no local inplace packages
- -- e.g. just "extra" packages coming from the store.
- case (inplacePackages, sourcePackages) of
- ([], pkgs) -> checkSamePackageDBs pkgs
- (pkgs, _) -> checkSamePackageDBs pkgs
+ -- If we have any inplace packages then their package db stack is the
+ -- one we should use since it'll include the store + the local db but
+ -- it's certainly possible to have no local inplace packages
+ -- e.g. just "extra" packages coming from the store.
+ case (inplacePackages, sourcePackages) of
+ ([], pkgs) -> checkSamePackageDBs pkgs
+ (pkgs, _) -> checkSamePackageDBs pkgs
where
checkSamePackageDBs :: [ElaboratedConfiguredPackage] -> PackageDBStack
checkSamePackageDBs pkgs =
case ordNub (map elabBuildPackageDBStack pkgs) of
[packageDbs] -> packageDbs
- [] -> []
- _ -> error $ "renderGhcEnvironmentFile: packages with "
- ++ "different package db stacks"
- -- This should not happen at the moment but will happen as soon
- -- as we support projects where we build packages with different
- -- compilers, at which point we have to consider how to adapt
- -- this feature, e.g. write out multiple env files, one for each
- -- compiler / project profile.
+ [] -> []
+ _ ->
+ error $
+ "renderGhcEnvironmentFile: packages with "
+ ++ "different package db stacks"
+ -- This should not happen at the moment but will happen as soon
+ -- as we support projects where we build packages with different
+ -- compilers, at which point we have to consider how to adapt
+ -- this feature, e.g. write out multiple env files, one for each
+ -- compiler / project profile.
inplacePackages :: [ElaboratedConfiguredPackage]
inplacePackages =
[ srcpkg
| srcpkg <- sourcePackages
- , elabBuildStyle srcpkg == BuildInplaceOnly ]
+ , elabBuildStyle srcpkg == BuildInplaceOnly
+ ]
sourcePackages :: [ElaboratedConfiguredPackage]
sourcePackages =
[ srcpkg
| pkg <- InstallPlan.toList elaboratedInstallPlan
, srcpkg <- maybeToList $ case pkg of
- InstallPlan.Configured srcpkg -> Just srcpkg
- InstallPlan.Installed srcpkg -> Just srcpkg
- InstallPlan.PreExisting _ -> Nothing
+ InstallPlan.Configured srcpkg -> Just srcpkg
+ InstallPlan.Installed srcpkg -> Just srcpkg
+ InstallPlan.PreExisting _ -> Nothing
]
relativePackageDBPaths :: FilePath -> PackageDBStack -> PackageDBStack
@@ -964,8 +1019,9 @@ relativePackageDBPaths relroot = map (relativePackageDBPath relroot)
relativePackageDBPath :: FilePath -> PackageDB -> PackageDB
relativePackageDBPath relroot pkgdb =
- case pkgdb of
- GlobalPackageDB -> GlobalPackageDB
- UserPackageDB -> UserPackageDB
- SpecificPackageDB path -> SpecificPackageDB relpath
- where relpath = makeRelative relroot path
+ case pkgdb of
+ GlobalPackageDB -> GlobalPackageDB
+ UserPackageDB -> UserPackageDB
+ SpecificPackageDB path -> SpecificPackageDB relpath
+ where
+ relpath = makeRelative relroot path
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning.hs b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
index 06669fb5643fb098c656bc44abebbaf89b50b3d5..e7c383f1322b3e1f34b37476fc4fb60bbf24784e 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning.hs
@@ -1,185 +1,204 @@
-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, RankNTypes #-}
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE NoMonoLocalBinds #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NoMonoLocalBinds #-}
-- | Planning how to build everything in a project.
---
-module Distribution.Client.ProjectPlanning (
- -- * elaborated install plan types
- ElaboratedInstallPlan,
- ElaboratedConfiguredPackage(..),
- ElaboratedPlanPackage,
- ElaboratedSharedConfig(..),
- ElaboratedReadyPackage,
- BuildStyle(..),
- CabalFileText,
+module Distribution.Client.ProjectPlanning
+ ( -- * elaborated install plan types
+ ElaboratedInstallPlan
+ , ElaboratedConfiguredPackage (..)
+ , ElaboratedPlanPackage
+ , ElaboratedSharedConfig (..)
+ , ElaboratedReadyPackage
+ , BuildStyle (..)
+ , CabalFileText
-- * Producing the elaborated install plan
- rebuildProjectConfig,
- rebuildInstallPlan,
+ , rebuildProjectConfig
+ , rebuildInstallPlan
-- * Build targets
- availableTargets,
- AvailableTarget(..),
- AvailableTargetStatus(..),
- TargetRequested(..),
- ComponentTarget(..),
- SubComponentTarget(..),
- showComponentTarget,
- nubComponentTargets,
+ , availableTargets
+ , AvailableTarget (..)
+ , AvailableTargetStatus (..)
+ , TargetRequested (..)
+ , ComponentTarget (..)
+ , SubComponentTarget (..)
+ , showComponentTarget
+ , nubComponentTargets
-- * Selecting a plan subset
- pruneInstallPlanToTargets,
- TargetAction(..),
- pruneInstallPlanToDependencies,
- CannotPruneDependencies(..),
+ , pruneInstallPlanToTargets
+ , TargetAction (..)
+ , pruneInstallPlanToDependencies
+ , CannotPruneDependencies (..)
-- * Utils required for building
- pkgHasEphemeralBuildTargets,
- elabBuildTargetWholeComponents,
- configureCompiler,
+ , pkgHasEphemeralBuildTargets
+ , elabBuildTargetWholeComponents
+ , configureCompiler
-- * Setup.hs CLI flags for building
- setupHsScriptOptions,
- setupHsConfigureFlags,
- setupHsConfigureArgs,
- setupHsBuildFlags,
- setupHsBuildArgs,
- setupHsReplFlags,
- setupHsReplArgs,
- setupHsTestFlags,
- setupHsTestArgs,
- setupHsBenchFlags,
- setupHsBenchArgs,
- setupHsCopyFlags,
- setupHsRegisterFlags,
- setupHsHaddockFlags,
- setupHsHaddockArgs,
-
- packageHashInputs,
+ , setupHsScriptOptions
+ , setupHsConfigureFlags
+ , setupHsConfigureArgs
+ , setupHsBuildFlags
+ , setupHsBuildArgs
+ , setupHsReplFlags
+ , setupHsReplArgs
+ , setupHsTestFlags
+ , setupHsTestArgs
+ , setupHsBenchFlags
+ , setupHsBenchArgs
+ , setupHsCopyFlags
+ , setupHsRegisterFlags
+ , setupHsHaddockFlags
+ , setupHsHaddockArgs
+ , packageHashInputs
-- * Path construction
- binDirectoryFor,
- binDirectories,
- storePackageInstallDirs,
- storePackageInstallDirs'
+ , binDirectoryFor
+ , binDirectories
+ , storePackageInstallDirs
+ , storePackageInstallDirs'
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.HashValue
-import Distribution.Client.HttpUtils
-import Distribution.Client.ProjectPlanning.Types as Ty
-import Distribution.Client.PackageHash
-import Distribution.Client.RebuildMonad
-import Distribution.Client.Store
-import Distribution.Client.ProjectConfig
-import Distribution.Client.ProjectConfig.Legacy
-import Distribution.Client.ProjectPlanOutput
-
-import Distribution.Client.Types
+import Distribution.Client.HashValue
+import Distribution.Client.HttpUtils
+import Distribution.Client.PackageHash
+import Distribution.Client.ProjectConfig
+import Distribution.Client.ProjectConfig.Legacy
+import Distribution.Client.ProjectPlanOutput
+import Distribution.Client.ProjectPlanning.Types as Ty
+import Distribution.Client.RebuildMonad
+import Distribution.Client.Store
+
+import Distribution.Client.Config
+import Distribution.Client.Dependency
+import Distribution.Client.Dependency.Types
+import Distribution.Client.DistDirLayout
+import Distribution.Client.FetchUtils
+import qualified Distribution.Client.IndexUtils as IndexUtils
import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.JobControl
+import Distribution.Client.Setup hiding (cabalVersion, packageName)
+import Distribution.Client.SetupWrapper
import qualified Distribution.Client.SolverInstallPlan as SolverInstallPlan
-import Distribution.Client.Dependency
-import Distribution.Client.Dependency.Types
-import qualified Distribution.Client.IndexUtils as IndexUtils
-import Distribution.Client.Utils (incVersion)
-import Distribution.Client.Targets (userToPackageConstraint)
-import Distribution.Client.DistDirLayout
-import Distribution.Client.SetupWrapper
-import Distribution.Client.JobControl
-import Distribution.Client.FetchUtils
-import Distribution.Client.Config
+import Distribution.Client.Targets (userToPackageConstraint)
+import Distribution.Client.Types
+import Distribution.Client.Utils (incVersion)
+import Distribution.Utils.LogProgress
+import Distribution.Utils.MapAccum
+import Distribution.Utils.NubList
import qualified Hackage.Security.Client as Sec
-import Distribution.Client.Setup hiding (packageName, cabalVersion)
-import Distribution.Utils.NubList
-import Distribution.Utils.LogProgress
-import Distribution.Utils.MapAccum
import qualified Distribution.Client.BuildReports.Storage as BuildReports
- ( storeLocal, fromPlanningFailure )
+ ( fromPlanningFailure
+ , storeLocal
+ )
+import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
-import Distribution.Solver.Types.ConstraintSource
-import Distribution.Solver.Types.LabeledPackageConstraint
-import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PkgConfigDb
-import Distribution.Solver.Types.ResolverPackage
-import Distribution.Solver.Types.SolverId
-import Distribution.Solver.Types.SolverPackage
-import Distribution.Solver.Types.InstSolverPackage
-import Distribution.Solver.Types.SourcePackage
-import Distribution.Solver.Types.Settings
-
-import Distribution.CabalSpecVersion
-import Distribution.ModuleName
-import Distribution.Package
-import Distribution.Types.AnnotatedId
-import Distribution.Types.ComponentName
-import Distribution.Types.DumpBuildInfo
- ( DumpBuildInfo (..) )
-import Distribution.Types.LibraryName
-import Distribution.Types.GivenComponent
- (GivenComponent(..))
-import Distribution.Types.PackageVersionConstraint
-import Distribution.Types.PkgconfigDependency
-import Distribution.Types.UnqualComponentName
-import Distribution.System
+import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.InstSolverPackage
+import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PkgConfigDb
+import Distribution.Solver.Types.ResolverPackage
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SolverId
+import Distribution.Solver.Types.SolverPackage
+import Distribution.Solver.Types.SourcePackage
+
+import Distribution.CabalSpecVersion
+
+-- TODO: [code cleanup] eliminate
+-- TODO: [code cleanup] eliminate
+
+import qualified Distribution.InstalledPackageInfo as IPI
+import Distribution.ModuleName
+import Distribution.Package
import qualified Distribution.PackageDescription as Cabal
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Configuration as PD
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import Distribution.Simple.Compiler
-import qualified Distribution.Simple.GHC as GHC --TODO: [code cleanup] eliminate
-import qualified Distribution.Simple.GHCJS as GHCJS --TODO: [code cleanup] eliminate
-import Distribution.Simple.Program
-import Distribution.Simple.Program.Db
-import Distribution.Simple.Program.Find
-import qualified Distribution.Simple.Setup as Cabal
-import Distribution.Simple.Setup
- (Flag(..), toFlag, flagToMaybe, flagToList, fromFlagOrDefault)
+import Distribution.Simple.Compiler
import qualified Distribution.Simple.Configure as Cabal
-import qualified Distribution.Simple.LocalBuildInfo as Cabal
-import Distribution.Simple.LocalBuildInfo
- ( Component(..), pkgComponents, componentBuildInfo
- , componentName )
+import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.GHCJS as GHCJS
import qualified Distribution.Simple.InstallDirs as InstallDirs
-import qualified Distribution.InstalledPackageInfo as IPI
-
-import Distribution.Backpack.ConfiguredComponent
-import Distribution.Backpack.LinkedComponent
-import Distribution.Backpack.ComponentsGraph
-import Distribution.Backpack.ModuleShape
-import Distribution.Backpack.FullUnitId
-import Distribution.Backpack
-import Distribution.Types.ComponentInclude
-
-import Distribution.Simple.Utils
-import Distribution.Version
-
+import Distribution.Simple.LocalBuildInfo
+ ( Component (..)
+ , componentBuildInfo
+ , componentName
+ , pkgComponents
+ )
+import qualified Distribution.Simple.LocalBuildInfo as Cabal
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import Distribution.Simple.Program
+import Distribution.Simple.Program.Db
+import Distribution.Simple.Program.Find
+import Distribution.Simple.Setup
+ ( Flag (..)
+ , flagToList
+ , flagToMaybe
+ , fromFlagOrDefault
+ , toFlag
+ )
+import qualified Distribution.Simple.Setup as Cabal
+import Distribution.System
+import Distribution.Types.AnnotatedId
+import Distribution.Types.ComponentName
+import Distribution.Types.DumpBuildInfo
+ ( DumpBuildInfo (..)
+ )
+import Distribution.Types.GivenComponent
+ ( GivenComponent (..)
+ )
+import Distribution.Types.LibraryName
+import Distribution.Types.PackageVersionConstraint
+import Distribution.Types.PkgconfigDependency
+import Distribution.Types.UnqualComponentName
+
+import Distribution.Backpack
+import Distribution.Backpack.ComponentsGraph
+import Distribution.Backpack.ConfiguredComponent
+import Distribution.Backpack.FullUnitId
+import Distribution.Backpack.LinkedComponent
+import Distribution.Backpack.ModuleShape
+import Distribution.Types.ComponentInclude
+
+import Distribution.Simple.Utils
+import Distribution.Version
+
+import Distribution.Compat.Graph (IsNode (..))
import qualified Distribution.Compat.Graph as Graph
-import Distribution.Compat.Graph(IsNode(..))
-import Data.Foldable (fold)
-import Text.PrettyPrint (text, hang, quotes, colon, vcat, ($$), fsep, punctuate, comma)
-import qualified Text.PrettyPrint as Disp
+import Control.Exception (assert)
+import Control.Monad (forM, sequence)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.State as State (State, execState, runState, state)
+import Data.Foldable (fold)
+import Data.List (deleteBy, groupBy)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Control.Monad (sequence, forM)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad.State as State (State, execState, runState, state)
-import Control.Exception (assert)
-import Data.List (groupBy, deleteBy)
-import qualified Data.List.NonEmpty as NE
-import System.FilePath
+import System.FilePath
+import Text.PrettyPrint (colon, comma, fsep, hang, punctuate, quotes, text, vcat, ($$))
+import qualified Text.PrettyPrint as Disp
------------------------------------------------------------------------------
+
-- * Elaborated install plan
+
------------------------------------------------------------------------------
-- "Elaborated" -- worked out with great care and nicety of detail;
@@ -203,11 +222,15 @@ import System.FilePath
-- So that means we need a representation of this fully elaborated install
-- plan. The representation consists of two parts:
--
+
-- * A 'ElaboratedInstallPlan'. This is a 'GenericInstallPlan' with a
+
-- representation of source packages that includes a lot more detail about
-- that package's individual configuration
--
+
-- * A 'ElaboratedSharedConfig'. Some package configuration is the same for
+
-- every package in a plan. Rather than duplicate that info every entry in
-- the 'GenericInstallPlan' we keep that separately.
--
@@ -227,104 +250,115 @@ import System.FilePath
-- data ElaboratedConfiguredPackage = ...
-- data BuildStyle =
-
-- | Check that an 'ElaboratedConfiguredPackage' actually makes
-- sense under some 'ElaboratedSharedConfig'.
sanityCheckElaboratedConfiguredPackage
- :: ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
- -> a
- -> a
-sanityCheckElaboratedConfiguredPackage _sharedConfig
- elab@ElaboratedConfiguredPackage{..} =
- (case elabPkgOrComp of
+ :: ElaboratedSharedConfig
+ -> ElaboratedConfiguredPackage
+ -> a
+ -> a
+sanityCheckElaboratedConfiguredPackage
+ _sharedConfig
+ elab@ElaboratedConfiguredPackage{..} =
+ ( case elabPkgOrComp of
ElabPackage pkg -> sanityCheckElaboratedPackage elab pkg
- ElabComponent comp -> sanityCheckElaboratedComponent elab comp)
-
- -- The assertion below fails occasionally for unknown reason
- -- so it was muted until we figure it out, otherwise it severely
- -- hinders our ability to share and test development builds of cabal-install.
- -- Tracking issue: https://github.com/haskell/cabal/issues/6006
- --
- -- either a package is being built inplace, or the
- -- 'installedPackageId' we assigned is consistent with
- -- the 'hashedInstalledPackageId' we would compute from
- -- the elaborated configured package
- -- . assert (elabBuildStyle == BuildInplaceOnly ||
- -- elabComponentId == hashedInstalledPackageId
- -- (packageHashInputs sharedConfig elab))
-
- -- the stanzas explicitly disabled should not be available
- . assert (optStanzaSetNull $
- optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable)
-
- -- either a package is built inplace, or we are not attempting to
- -- build any test suites or benchmarks (we never build these
- -- for remote packages!)
- . assert (elabBuildStyle == BuildInplaceOnly ||
- optStanzaSetNull elabStanzasAvailable)
+ ElabComponent comp -> sanityCheckElaboratedComponent elab comp
+ )
+ -- The assertion below fails occasionally for unknown reason
+ -- so it was muted until we figure it out, otherwise it severely
+ -- hinders our ability to share and test development builds of cabal-install.
+ -- Tracking issue: https://github.com/haskell/cabal/issues/6006
+ --
+ -- either a package is being built inplace, or the
+ -- 'installedPackageId' we assigned is consistent with
+ -- the 'hashedInstalledPackageId' we would compute from
+ -- the elaborated configured package
+ -- . assert (elabBuildStyle == BuildInplaceOnly ||
+ -- elabComponentId == hashedInstalledPackageId
+ -- (packageHashInputs sharedConfig elab))
+
+ -- the stanzas explicitly disabled should not be available
+ . assert
+ ( optStanzaSetNull $
+ optStanzaKeysFilteredByValue (maybe False not) elabStanzasRequested `optStanzaSetIntersection` elabStanzasAvailable
+ )
+ -- either a package is built inplace, or we are not attempting to
+ -- build any test suites or benchmarks (we never build these
+ -- for remote packages!)
+ . assert
+ ( elabBuildStyle == BuildInplaceOnly
+ || optStanzaSetNull elabStanzasAvailable
+ )
sanityCheckElaboratedComponent
- :: ElaboratedConfiguredPackage
- -> ElaboratedComponent
- -> a
- -> a
-sanityCheckElaboratedComponent ElaboratedConfiguredPackage{..}
- ElaboratedComponent{..} =
-
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedComponent
+ -> a
+ -> a
+sanityCheckElaboratedComponent
+ ElaboratedConfiguredPackage{..}
+ ElaboratedComponent{..} =
-- Should not be building bench or test if not inplace.
- assert (elabBuildStyle == BuildInplaceOnly ||
- case compComponentName of
- Nothing -> True
- Just (CLibName _) -> True
- Just (CExeName _) -> True
- -- This is interesting: there's no way to declare a dependency
- -- on a foreign library at the moment, but you may still want
- -- to install these to the store
- Just (CFLibName _) -> True
- Just (CBenchName _) -> False
- Just (CTestName _) -> False)
-
+ assert
+ ( elabBuildStyle == BuildInplaceOnly
+ || case compComponentName of
+ Nothing -> True
+ Just (CLibName _) -> True
+ Just (CExeName _) -> True
+ -- This is interesting: there's no way to declare a dependency
+ -- on a foreign library at the moment, but you may still want
+ -- to install these to the store
+ Just (CFLibName _) -> True
+ Just (CBenchName _) -> False
+ Just (CTestName _) -> False
+ )
sanityCheckElaboratedPackage
- :: ElaboratedConfiguredPackage
- -> ElaboratedPackage
- -> a
- -> a
-sanityCheckElaboratedPackage ElaboratedConfiguredPackage{..}
- ElaboratedPackage{..} =
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedPackage
+ -> a
+ -> a
+sanityCheckElaboratedPackage
+ ElaboratedConfiguredPackage{..}
+ ElaboratedPackage{..} =
-- we should only have enabled stanzas that actually can be built
-- (according to the solver)
assert (pkgStanzasEnabled `optStanzaSetIsSubset` elabStanzasAvailable)
-
- -- the stanzas that the user explicitly requested should be
- -- enabled (by the previous test, they are also available)
- . assert (optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested
- `optStanzaSetIsSubset` pkgStanzasEnabled)
+ -- the stanzas that the user explicitly requested should be
+ -- enabled (by the previous test, they are also available)
+ . assert
+ ( optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested
+ `optStanzaSetIsSubset` pkgStanzasEnabled
+ )
------------------------------------------------------------------------------
+
-- * Deciding what to do: making an 'ElaboratedInstallPlan'
+
------------------------------------------------------------------------------
-- | Return the up-to-date project config and information about the local
-- packages within the project.
---
-rebuildProjectConfig :: Verbosity
- -> HttpTransport
- -> DistDirLayout
- -> ProjectConfig
- -> IO ( ProjectConfig
- , [PackageSpecifier UnresolvedSourcePackage] )
-rebuildProjectConfig verbosity
- httpTransport
- distDirLayout@DistDirLayout {
- distProjectRootDirectory,
- distDirectory,
- distProjectCacheFile,
- distProjectCacheDirectory,
- distProjectFile
- }
- cliConfig = do
+rebuildProjectConfig
+ :: Verbosity
+ -> HttpTransport
+ -> DistDirLayout
+ -> ProjectConfig
+ -> IO
+ ( ProjectConfig
+ , [PackageSpecifier UnresolvedSourcePackage]
+ )
+rebuildProjectConfig
+ verbosity
+ httpTransport
+ distDirLayout@DistDirLayout
+ { distProjectRootDirectory
+ , distDirectory
+ , distProjectCacheFile
+ , distProjectCacheDirectory
+ , distProjectFile
+ }
+ cliConfig = do
progsearchpath <- liftIO $ getSystemSearchPath
@@ -340,101 +374,114 @@ rebuildProjectConfig verbosity
(projectConfig, localPackages) <-
runRebuild distProjectRootDirectory
- $ rerunIfChanged verbosity
- fileMonitorProjectConfig
- fileMonitorProjectConfigKey -- todo check deps too?
- $ do
+ $ rerunIfChanged
+ verbosity
+ fileMonitorProjectConfig
+ fileMonitorProjectConfigKey -- todo check deps too?
+ $ do
liftIO $ info verbosity "Project settings changed, reconfiguring..."
projectConfigSkeleton <- phaseReadProjectConfig
let fetchCompiler = do
- -- have to create the cache directory before configuring the compiler
- liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
- (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
- pure (os, arch, compilerInfo compiler)
+ -- have to create the cache directory before configuring the compiler
+ liftIO $ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
+ (compiler, Platform arch os, _) <- configureCompiler verbosity distDirLayout ((fst $ PD.ignoreConditions projectConfigSkeleton) <> cliConfig)
+ pure (os, arch, compilerInfo compiler)
projectConfig <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectConfigSkeleton
localPackages <- phaseReadLocalPackages (projectConfig <> cliConfig)
return (projectConfig, localPackages)
- info verbosity
- $ unlines
- $ ("this build was affected by the following (project) config files:" :)
- $ [ "- " ++ path
- | Explicit path <- Set.toList $ projectConfigProvenance projectConfig
- ]
+ info verbosity $
+ unlines $
+ ("this build was affected by the following (project) config files:" :) $
+ [ "- " ++ path
+ | Explicit path <- Set.toList $ projectConfigProvenance projectConfig
+ ]
return (projectConfig <> cliConfig, localPackages)
+ where
+ ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile } =
+ projectConfigShared cliConfig
+ PackageConfig { packageConfigProgramPaths, packageConfigProgramPathExtra } =
+ projectConfigLocalPackages cliConfig
+ -- Read the cabal.project (or implicit config) and combine it with
+ -- arguments from the command line
+ --
+ phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton
+ phaseReadProjectConfig = do
+ readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout
- where
-
- ProjectConfigShared { projectConfigHcFlavor, projectConfigHcPath, projectConfigHcPkg, projectConfigIgnoreProject, projectConfigConfigFile } =
- projectConfigShared cliConfig
-
- PackageConfig { packageConfigProgramPaths, packageConfigProgramPathExtra } =
- projectConfigLocalPackages cliConfig
-
- -- Read the cabal.project (or implicit config) and combine it with
- -- arguments from the command line
- --
- phaseReadProjectConfig :: Rebuild ProjectConfigSkeleton
- phaseReadProjectConfig = do
- readProjectConfig verbosity httpTransport projectConfigIgnoreProject projectConfigConfigFile distDirLayout
-
- -- Look for all the cabal packages in the project
- -- some of which may be local src dirs, tarballs etc
- --
- phaseReadLocalPackages :: ProjectConfig
- -> Rebuild [PackageSpecifier UnresolvedSourcePackage]
- phaseReadLocalPackages projectConfig@ProjectConfig {
- projectConfigShared,
- projectConfigBuildOnly
- } = do
-
- pkgLocations <- findProjectPackages distDirLayout projectConfig
- -- Create folder only if findProjectPackages did not throw a
- -- BadPackageLocations exception.
- liftIO $ do
- createDirectoryIfMissingVerbose verbosity True distDirectory
- createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
-
- fetchAndReadSourcePackages verbosity distDirLayout
- projectConfigShared
- projectConfigBuildOnly
- pkgLocations
-
-
-configureCompiler :: Verbosity ->
- DistDirLayout ->
- ProjectConfig ->
- Rebuild (Compiler, Platform, ProgramDb)
-configureCompiler verbosity
- DistDirLayout {
- distProjectCacheFile
- }
- ProjectConfig {
- projectConfigShared = ProjectConfigShared {
- projectConfigHcFlavor,
- projectConfigHcPath,
- projectConfigHcPkg
- },
- projectConfigLocalPackages = PackageConfig {
- packageConfigProgramPaths,
- packageConfigProgramPathExtra
- }
- } = do
- let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler"
-
- progsearchpath <- liftIO $ getSystemSearchPath
- rerunIfChanged verbosity fileMonitorCompiler
- (hcFlavor, hcPath, hcPkg, progsearchpath,
- packageConfigProgramPaths,
- packageConfigProgramPathExtra) $ do
+ -- Look for all the cabal packages in the project
+ -- some of which may be local src dirs, tarballs etc
+ --
+ phaseReadLocalPackages
+ :: ProjectConfig
+ -> Rebuild [PackageSpecifier UnresolvedSourcePackage]
+ phaseReadLocalPackages
+ projectConfig@ProjectConfig
+ { projectConfigShared
+ , projectConfigBuildOnly
+ } = do
+ pkgLocations <- findProjectPackages distDirLayout projectConfig
+ -- Create folder only if findProjectPackages did not throw a
+ -- BadPackageLocations exception.
+ liftIO $ do
+ createDirectoryIfMissingVerbose verbosity True distDirectory
+ createDirectoryIfMissingVerbose verbosity True distProjectCacheDirectory
+
+ fetchAndReadSourcePackages
+ verbosity
+ distDirLayout
+ projectConfigShared
+ projectConfigBuildOnly
+ pkgLocations
+
+configureCompiler
+ :: Verbosity
+ -> DistDirLayout
+ -> ProjectConfig
+ -> Rebuild (Compiler, Platform, ProgramDb)
+configureCompiler
+ verbosity
+ DistDirLayout
+ { distProjectCacheFile
+ }
+ ProjectConfig
+ { projectConfigShared =
+ ProjectConfigShared
+ { projectConfigHcFlavor
+ , projectConfigHcPath
+ , projectConfigHcPkg
+ }
+ , projectConfigLocalPackages =
+ PackageConfig
+ { packageConfigProgramPaths
+ , packageConfigProgramPathExtra
+ }
+ } = do
+ let fileMonitorCompiler = newFileMonitor . distProjectCacheFile $ "compiler"
- liftIO $ info verbosity "Compiler settings changed, reconfiguring..."
- result@(_, _, progdb') <- liftIO $
+ progsearchpath <- liftIO $ getSystemSearchPath
+ rerunIfChanged
+ verbosity
+ fileMonitorCompiler
+ ( hcFlavor
+ , hcPath
+ , hcPkg
+ , progsearchpath
+ , packageConfigProgramPaths
+ , packageConfigProgramPathExtra
+ )
+ $ do
+ liftIO $ info verbosity "Compiler settings changed, reconfiguring..."
+ result@(_, _, progdb') <-
+ liftIO $
Cabal.configCompilerEx
- hcFlavor hcPath hcPkg
- progdb verbosity
+ hcFlavor
+ hcPath
+ hcPkg
+ progdb
+ verbosity
-- Note that we added the user-supplied program locations and args
-- for /all/ programs, not just those for the compiler prog and
@@ -442,21 +489,23 @@ configureCompiler verbosity
-- the compiler will configure (and it does vary between compilers).
-- We do know however that the compiler will only configure the
-- programs it cares about, and those are the ones we monitor here.
- monitorFiles (programsMonitorFiles progdb')
+ monitorFiles (programsMonitorFiles progdb')
- return result
- where
- hcFlavor = flagToMaybe projectConfigHcFlavor
- hcPath = flagToMaybe projectConfigHcPath
- hcPkg = flagToMaybe projectConfigHcPkg
- progdb =
- userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
+ return result
+ where
+ hcFlavor = flagToMaybe projectConfigHcFlavor
+ hcPath = flagToMaybe projectConfigHcPath
+ hcPkg = flagToMaybe projectConfigHcPkg
+ progdb =
+ userSpecifyPaths (Map.toList (getMapLast packageConfigProgramPaths))
. modifyProgramSearchPath
- ([ ProgramSearchPathDir dir
- | dir <- fromNubList packageConfigProgramPathExtra ] ++)
+ ( [ ProgramSearchPathDir dir
+ | dir <- fromNubList packageConfigProgramPathExtra
+ ]
+ ++
+ )
$ defaultProgramDb
-
-- | Return an up-to-date elaborated install plan.
--
-- Two variants of the install plan are returned: with and without packages
@@ -470,233 +519,295 @@ configureCompiler verbosity
-- command needs the source package info to know about flag choices and
-- dependencies of executables and setup scripts.
--
-rebuildInstallPlan :: Verbosity
- -> DistDirLayout -> CabalDirLayout
- -> ProjectConfig
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> Maybe InstalledPackageIndex
- -> IO ( ElaboratedInstallPlan -- with store packages
- , ElaboratedInstallPlan -- with source packages
- , ElaboratedSharedConfig
- , IndexUtils.TotalIndexState
- , IndexUtils.ActiveRepos
- )
- -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@
-rebuildInstallPlan verbosity
- distDirLayout@DistDirLayout {
- distProjectRootDirectory,
- distProjectCacheFile
- }
- CabalDirLayout {
- cabalStoreDirLayout
- } = \projectConfig localPackages mbInstalledPackages ->
+rebuildInstallPlan
+ :: Verbosity
+ -> DistDirLayout
+ -> CabalDirLayout
+ -> ProjectConfig
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> Maybe InstalledPackageIndex
+ -> IO
+ ( ElaboratedInstallPlan -- with store packages
+ , ElaboratedInstallPlan -- with source packages
+ , ElaboratedSharedConfig
+ , IndexUtils.TotalIndexState
+ , IndexUtils.ActiveRepos
+ )
+ -- ^ @(improvedPlan, elaboratedPlan, _, _, _)@
+rebuildInstallPlan
+ verbosity
+ distDirLayout@DistDirLayout
+ { distProjectRootDirectory
+ , distProjectCacheFile
+ }
+ CabalDirLayout
+ { cabalStoreDirLayout
+ } = \projectConfig localPackages mbInstalledPackages ->
runRebuild distProjectRootDirectory $ do
- progsearchpath <- liftIO $ getSystemSearchPath
- let projectConfigMonitored = projectConfig { projectConfigBuildOnly = mempty }
-
- -- The overall improved plan is cached
- rerunIfChanged verbosity fileMonitorImprovedPlan
- -- react to changes in the project config,
- -- the package .cabal files and the path
- (projectConfigMonitored, localPackages, progsearchpath) $ do
-
- -- And so is the elaborated plan that the improved plan based on
- (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-
- rerunIfChanged verbosity fileMonitorElaboratedPlan
- (projectConfigMonitored, localPackages,
- progsearchpath) $ do
-
- compilerEtc <- phaseConfigureCompiler projectConfig
- _ <- phaseConfigurePrograms projectConfig compilerEtc
- (solverPlan, pkgConfigDB, totalIndexState, activeRepos)
- <- phaseRunSolver projectConfig
- compilerEtc
- localPackages
- (fromMaybe mempty mbInstalledPackages)
- (elaboratedPlan,
- elaboratedShared) <- phaseElaboratePlan projectConfig
- compilerEtc pkgConfigDB
- solverPlan
- localPackages
-
- phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
- return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
-
- -- The improved plan changes each time we install something, whereas
- -- the underlying elaborated plan only changes when input config
- -- changes, so it's worth caching them separately.
- improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
-
- return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
-
- where
- fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan"
- fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes"
- fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"
- fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan"
-
- newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b
- newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile
+ progsearchpath <- liftIO $ getSystemSearchPath
+ let projectConfigMonitored = projectConfig{projectConfigBuildOnly = mempty}
+
+ -- The overall improved plan is cached
+ rerunIfChanged
+ verbosity
+ fileMonitorImprovedPlan
+ -- react to changes in the project config,
+ -- the package .cabal files and the path
+ (projectConfigMonitored, localPackages, progsearchpath)
+ $ do
+ -- And so is the elaborated plan that the improved plan based on
+ (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos) <-
+ rerunIfChanged
+ verbosity
+ fileMonitorElaboratedPlan
+ ( projectConfigMonitored
+ , localPackages
+ , progsearchpath
+ )
+ $ do
+ compilerEtc <- phaseConfigureCompiler projectConfig
+ _ <- phaseConfigurePrograms projectConfig compilerEtc
+ (solverPlan, pkgConfigDB, totalIndexState, activeRepos) <-
+ phaseRunSolver
+ projectConfig
+ compilerEtc
+ localPackages
+ (fromMaybe mempty mbInstalledPackages)
+ ( elaboratedPlan
+ , elaboratedShared
+ ) <-
+ phaseElaboratePlan
+ projectConfig
+ compilerEtc
+ pkgConfigDB
+ solverPlan
+ localPackages
+
+ phaseMaintainPlanOutputs elaboratedPlan elaboratedShared
+ return (elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
+
+ -- The improved plan changes each time we install something, whereas
+ -- the underlying elaborated plan only changes when input config
+ -- changes, so it's worth caching them separately.
+ improvedPlan <- phaseImprovePlan elaboratedPlan elaboratedShared
+
+ return (improvedPlan, elaboratedPlan, elaboratedShared, totalIndexState, activeRepos)
+ where
+ fileMonitorSolverPlan = newFileMonitorInCacheDir "solver-plan"
+ fileMonitorSourceHashes = newFileMonitorInCacheDir "source-hashes"
+ fileMonitorElaboratedPlan = newFileMonitorInCacheDir "elaborated-plan"
+ fileMonitorImprovedPlan = newFileMonitorInCacheDir "improved-plan"
+ newFileMonitorInCacheDir :: Eq a => FilePath -> FileMonitor a b
+ newFileMonitorInCacheDir = newFileMonitor . distProjectCacheFile
- -- Configure the compiler we're using.
- --
- -- This is moderately expensive and doesn't change that often so we cache
- -- it independently.
- --
- phaseConfigureCompiler :: ProjectConfig
- -> Rebuild (Compiler, Platform, ProgramDb)
- phaseConfigureCompiler = configureCompiler verbosity distDirLayout
+ -- Configure the compiler we're using.
+ --
+ -- This is moderately expensive and doesn't change that often so we cache
+ -- it independently.
+ --
+ phaseConfigureCompiler
+ :: ProjectConfig
+ -> Rebuild (Compiler, Platform, ProgramDb)
+ phaseConfigureCompiler = configureCompiler verbosity distDirLayout
- -- Configuring other programs.
- --
- -- Having configred the compiler, now we configure all the remaining
- -- programs. This is to check we can find them, and to monitor them for
- -- changes.
- --
- -- TODO: [required eventually] we don't actually do this yet.
- --
- -- We rely on the fact that the previous phase added the program config for
- -- all local packages, but that all the programs configured so far are the
- -- compiler program or related util programs.
- --
- phaseConfigurePrograms :: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
- -> Rebuild ()
- phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do
+ -- Configuring other programs.
+ --
+ -- Having configred the compiler, now we configure all the remaining
+ -- programs. This is to check we can find them, and to monitor them for
+ -- changes.
+ --
+ -- TODO: [required eventually] we don't actually do this yet.
+ --
+ -- We rely on the fact that the previous phase added the program config for
+ -- all local packages, but that all the programs configured so far are the
+ -- compiler program or related util programs.
+ --
+ phaseConfigurePrograms
+ :: ProjectConfig
+ -> (Compiler, Platform, ProgramDb)
+ -> Rebuild ()
+ phaseConfigurePrograms projectConfig (_, _, compilerprogdb) = do
-- Users are allowed to specify program locations independently for
-- each package (e.g. to use a particular version of a pre-processor
-- for some packages). However they cannot do this for the compiler
-- itself as that's just not going to work. So we check for this.
- liftIO $ checkBadPerPackageCompilerPaths
- (configuredPrograms compilerprogdb)
- (getMapMappend (projectConfigSpecificPackage projectConfig))
-
- --TODO: [required eventually] find/configure other programs that the
- -- user specifies.
+ liftIO $
+ checkBadPerPackageCompilerPaths
+ (configuredPrograms compilerprogdb)
+ (getMapMappend (projectConfigSpecificPackage projectConfig))
- --TODO: [required eventually] find/configure all build-tools
- -- but note that some of them may be built as part of the plan.
+ -- TODO: [required eventually] find/configure other programs that the
+ -- user specifies.
+ -- TODO: [required eventually] find/configure all build-tools
+ -- but note that some of them may be built as part of the plan.
- -- Run the solver to get the initial install plan.
- -- This is expensive so we cache it independently.
- --
- phaseRunSolver
+ -- Run the solver to get the initial install plan.
+ -- This is expensive so we cache it independently.
+ --
+ phaseRunSolver
:: ProjectConfig
-> (Compiler, Platform, ProgramDb)
-> [PackageSpecifier UnresolvedSourcePackage]
-> InstalledPackageIndex
-> Rebuild (SolverInstallPlan, PkgConfigDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
- phaseRunSolver projectConfig@ProjectConfig {
- projectConfigShared,
- projectConfigBuildOnly
- }
- (compiler, platform, progdb)
- localPackages
- installedPackages =
- rerunIfChanged verbosity fileMonitorSolverPlan
- (solverSettings,
- localPackages, localPackagesEnabledStanzas,
- compiler, platform, programDbSignature progdb) $ do
-
- installedPkgIndex <- getInstalledPackages verbosity
- compiler progdb platform
- corePackageDbs
- (sourcePkgDb, tis, ar) <- getSourcePackages verbosity withRepoCtx
- (solverSettingIndexState solverSettings)
- (solverSettingActiveRepos solverSettings)
- pkgConfigDB <- getPkgConfigDb verbosity progdb
-
- --TODO: [code cleanup] it'd be better if the Compiler contained the
- -- ConfiguredPrograms that it needs, rather than relying on the progdb
- -- since we don't need to depend on all the programs here, just the
- -- ones relevant for the compiler.
-
- liftIO $ do
- solver <- chooseSolver verbosity
- (solverSettingSolver solverSettings)
- (compilerInfo compiler)
-
- notice verbosity "Resolving dependencies..."
- planOrError <- foldProgress logMsg (pure . Left) (pure . Right) $
- planPackages verbosity compiler platform solver solverSettings
- (installedPackages <> installedPkgIndex) sourcePkgDb pkgConfigDB
- localPackages localPackagesEnabledStanzas
- case planOrError of
- Left msg -> do reportPlanningFailure projectConfig compiler platform localPackages
- die' verbosity msg
- Right plan -> return (plan, pkgConfigDB, tis, ar)
- where
- corePackageDbs :: [PackageDB]
- corePackageDbs = applyPackageDbFlags [GlobalPackageDB]
- (projectConfigPackageDBs projectConfigShared)
-
- withRepoCtx = projectConfigWithSolverRepoContext verbosity
- projectConfigShared
- projectConfigBuildOnly
- solverSettings = resolveSolverSettings projectConfig
- logMsg message rest = debugNoWrap verbosity message >> rest
-
- localPackagesEnabledStanzas =
- Map.fromList
- [ (pkgname, stanzas)
- | pkg <- localPackages
- -- TODO: misnomer: we should separate
- -- builtin/global/inplace/local packages
- -- and packages explicitly mentioned in the project
- --
- , let pkgname = pkgSpecifierTarget pkg
- testsEnabled = lookupLocalPackageConfig
- packageConfigTests
- projectConfig pkgname
- benchmarksEnabled = lookupLocalPackageConfig
- packageConfigBenchmarks
- projectConfig pkgname
- isLocal = isJust (shouldBeLocal pkg)
- stanzas
- | isLocal = Map.fromList $
- [ (TestStanzas, enabled)
- | enabled <- flagToList testsEnabled ] ++
- [ (BenchStanzas , enabled)
- | enabled <- flagToList benchmarksEnabled ]
- | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False) ]
- ]
-
- -- Elaborate the solver's install plan to get a fully detailed plan. This
- -- version of the plan has the final nix-style hashed ids.
- --
- phaseElaboratePlan :: ProjectConfig
- -> (Compiler, Platform, ProgramDb)
- -> PkgConfigDb
- -> SolverInstallPlan
- -> [PackageSpecifier (SourcePackage (PackageLocation loc))]
- -> Rebuild ( ElaboratedInstallPlan
- , ElaboratedSharedConfig )
- phaseElaboratePlan ProjectConfig {
- projectConfigShared,
- projectConfigAllPackages,
- projectConfigLocalPackages,
- projectConfigSpecificPackage,
- projectConfigBuildOnly
- }
- (compiler, platform, progdb) pkgConfigDB
- solverPlan localPackages = do
-
- liftIO $ debug verbosity "Elaborating the install plan..."
-
- sourcePackageHashes <-
- rerunIfChanged verbosity fileMonitorSourceHashes
- (packageLocationsSignature solverPlan) $
- getPackageSourceHashes verbosity withRepoCtx solverPlan
-
- defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
- let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared)
- (elaboratedPlan, elaboratedShared)
- <- liftIO . runLogProgress verbosity $
+ phaseRunSolver
+ projectConfig@ProjectConfig
+ { projectConfigShared
+ , projectConfigBuildOnly
+ }
+ (compiler, platform, progdb)
+ localPackages
+ installedPackages =
+ rerunIfChanged
+ verbosity
+ fileMonitorSolverPlan
+ ( solverSettings
+ , localPackages
+ , localPackagesEnabledStanzas
+ , compiler
+ , platform
+ , programDbSignature progdb
+ )
+ $ do
+ installedPkgIndex <-
+ getInstalledPackages
+ verbosity
+ compiler
+ progdb
+ platform
+ corePackageDbs
+ (sourcePkgDb, tis, ar) <-
+ getSourcePackages
+ verbosity
+ withRepoCtx
+ (solverSettingIndexState solverSettings)
+ (solverSettingActiveRepos solverSettings)
+ pkgConfigDB <- getPkgConfigDb verbosity progdb
+
+ -- TODO: [code cleanup] it'd be better if the Compiler contained the
+ -- ConfiguredPrograms that it needs, rather than relying on the progdb
+ -- since we don't need to depend on all the programs here, just the
+ -- ones relevant for the compiler.
+
+ liftIO $ do
+ solver <-
+ chooseSolver
+ verbosity
+ (solverSettingSolver solverSettings)
+ (compilerInfo compiler)
+
+ notice verbosity "Resolving dependencies..."
+ planOrError <-
+ foldProgress logMsg (pure . Left) (pure . Right) $
+ planPackages
+ verbosity
+ compiler
+ platform
+ solver
+ solverSettings
+ (installedPackages <> installedPkgIndex)
+ sourcePkgDb
+ pkgConfigDB
+ localPackages
+ localPackagesEnabledStanzas
+ case planOrError of
+ Left msg -> do
+ reportPlanningFailure projectConfig compiler platform localPackages
+ die' verbosity msg
+ Right plan -> return (plan, pkgConfigDB, tis, ar)
+ where
+ corePackageDbs :: [PackageDB]
+ corePackageDbs =
+ applyPackageDbFlags
+ [GlobalPackageDB]
+ (projectConfigPackageDBs projectConfigShared)
+
+ withRepoCtx =
+ projectConfigWithSolverRepoContext
+ verbosity
+ projectConfigShared
+ projectConfigBuildOnly
+ solverSettings = resolveSolverSettings projectConfig
+ logMsg message rest = debugNoWrap verbosity message >> rest
+
+ localPackagesEnabledStanzas =
+ Map.fromList
+ [ (pkgname, stanzas)
+ | pkg <- localPackages
+ , -- TODO: misnomer: we should separate
+ -- builtin/global/inplace/local packages
+ -- and packages explicitly mentioned in the project
+ --
+ let pkgname = pkgSpecifierTarget pkg
+ testsEnabled =
+ lookupLocalPackageConfig
+ packageConfigTests
+ projectConfig
+ pkgname
+ benchmarksEnabled =
+ lookupLocalPackageConfig
+ packageConfigBenchmarks
+ projectConfig
+ pkgname
+ isLocal = isJust (shouldBeLocal pkg)
+ stanzas
+ | isLocal =
+ Map.fromList $
+ [ (TestStanzas, enabled)
+ | enabled <- flagToList testsEnabled
+ ]
+ ++ [ (BenchStanzas, enabled)
+ | enabled <- flagToList benchmarksEnabled
+ ]
+ | otherwise = Map.fromList [(TestStanzas, False), (BenchStanzas, False)]
+ ]
+
+ -- Elaborate the solver's install plan to get a fully detailed plan. This
+ -- version of the plan has the final nix-style hashed ids.
+ --
+ phaseElaboratePlan
+ :: ProjectConfig
+ -> (Compiler, Platform, ProgramDb)
+ -> PkgConfigDb
+ -> SolverInstallPlan
+ -> [PackageSpecifier (SourcePackage (PackageLocation loc))]
+ -> Rebuild
+ ( ElaboratedInstallPlan
+ , ElaboratedSharedConfig
+ )
+ phaseElaboratePlan
+ ProjectConfig
+ { projectConfigShared
+ , projectConfigAllPackages
+ , projectConfigLocalPackages
+ , projectConfigSpecificPackage
+ , projectConfigBuildOnly
+ }
+ (compiler, platform, progdb)
+ pkgConfigDB
+ solverPlan
+ localPackages = do
+ liftIO $ debug verbosity "Elaborating the install plan..."
+
+ sourcePackageHashes <-
+ rerunIfChanged
+ verbosity
+ fileMonitorSourceHashes
+ (packageLocationsSignature solverPlan)
+ $ getPackageSourceHashes verbosity withRepoCtx solverPlan
+
+ defaultInstallDirs <- liftIO $ userInstallDirTemplates compiler
+ let installDirs = fmap Cabal.fromFlag $ (fmap Flag defaultInstallDirs) <> (projectConfigInstallDirs projectConfigShared)
+ (elaboratedPlan, elaboratedShared) <-
+ liftIO . runLogProgress verbosity $
elaborateInstallPlan
verbosity
- platform compiler progdb pkgConfigDB
+ platform
+ compiler
+ progdb
+ pkgConfigDB
distDirLayout
cabalStoreDirLayout
solverPlan
@@ -707,132 +818,154 @@ rebuildInstallPlan verbosity
projectConfigAllPackages
projectConfigLocalPackages
(getMapMappend projectConfigSpecificPackage)
- let instantiatedPlan
- = instantiateInstallPlan
+ let instantiatedPlan =
+ instantiateInstallPlan
cabalStoreDirLayout
installDirs
elaboratedShared
elaboratedPlan
- liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)
- return (instantiatedPlan, elaboratedShared)
- where
- withRepoCtx = projectConfigWithSolverRepoContext verbosity
- projectConfigShared
- projectConfigBuildOnly
-
- -- Update the files we maintain that reflect our current build environment.
- -- In particular we maintain a JSON representation of the elaborated
- -- install plan (but not the improved plan since that reflects the state
- -- of the build rather than just the input environment).
- --
- phaseMaintainPlanOutputs :: ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> Rebuild ()
- phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do
+ liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan instantiatedPlan)
+ return (instantiatedPlan, elaboratedShared)
+ where
+ withRepoCtx =
+ projectConfigWithSolverRepoContext
+ verbosity
+ projectConfigShared
+ projectConfigBuildOnly
+
+ -- Update the files we maintain that reflect our current build environment.
+ -- In particular we maintain a JSON representation of the elaborated
+ -- install plan (but not the improved plan since that reflects the state
+ -- of the build rather than just the input environment).
+ --
+ phaseMaintainPlanOutputs
+ :: ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> Rebuild ()
+ phaseMaintainPlanOutputs elaboratedPlan elaboratedShared = liftIO $ do
debug verbosity "Updating plan.json"
writePlanExternalRepresentation
distDirLayout
elaboratedPlan
elaboratedShared
-
- -- Improve the elaborated install plan. The elaborated plan consists
- -- mostly of source packages (with full nix-style hashed ids). Where
- -- corresponding installed packages already exist in the store, replace
- -- them in the plan.
- --
- -- Note that we do monitor the store's package db here, so we will redo
- -- this improvement phase when the db changes -- including as a result of
- -- executing a plan and installing things.
- --
- phaseImprovePlan :: ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> Rebuild ElaboratedInstallPlan
- phaseImprovePlan elaboratedPlan elaboratedShared = do
-
+ -- Improve the elaborated install plan. The elaborated plan consists
+ -- mostly of source packages (with full nix-style hashed ids). Where
+ -- corresponding installed packages already exist in the store, replace
+ -- them in the plan.
+ --
+ -- Note that we do monitor the store's package db here, so we will redo
+ -- this improvement phase when the db changes -- including as a result of
+ -- executing a plan and installing things.
+ --
+ phaseImprovePlan
+ :: ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> Rebuild ElaboratedInstallPlan
+ phaseImprovePlan elaboratedPlan elaboratedShared = do
liftIO $ debug verbosity "Improving the install plan..."
storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid
- let improvedPlan = improveInstallPlanWithInstalledPackages
- storePkgIdSet
- elaboratedPlan
+ let improvedPlan =
+ improveInstallPlanWithInstalledPackages
+ storePkgIdSet
+ elaboratedPlan
liftIO $ debugNoWrap verbosity (InstallPlan.showInstallPlan improvedPlan)
-- TODO: [nice to have] having checked which packages from the store
-- we're using, it may be sensible to sanity check those packages
-- by loading up the compiler package db and checking everything
-- matches up as expected, e.g. no dangling deps, files deleted.
return improvedPlan
- where
- compid = compilerId (pkgConfigCompiler elaboratedShared)
-
+ where
+ compid = compilerId (pkgConfigCompiler elaboratedShared)
-- | If a 'PackageSpecifier' refers to a single package, return Just that
-- package.
-
-
reportPlanningFailure :: ProjectConfig -> Compiler -> Platform -> [PackageSpecifier UnresolvedSourcePackage] -> IO ()
-reportPlanningFailure projectConfig comp platform pkgSpecifiers = when reportFailure $
-
- BuildReports.storeLocal (compilerInfo comp)
- (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig)
- buildReports platform
-
- -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely?
+reportPlanningFailure projectConfig comp platform pkgSpecifiers =
+ when reportFailure $
+ BuildReports.storeLocal
+ (compilerInfo comp)
+ (fromNubList $ projectConfigSummaryFile . projectConfigBuildOnly $ projectConfig)
+ buildReports
+ platform
where
+ -- TODO may want to handle the projectConfigLogFile paramenter here, or just remove it entirely?
+
reportFailure = Cabal.fromFlag . projectConfigReportPlanningFailure . projectConfigBuildOnly $ projectConfig
pkgids = mapMaybe theSpecifiedPackage pkgSpecifiers
- buildReports = BuildReports.fromPlanningFailure platform
- (compilerId comp) pkgids
- -- TODO we may want to get more flag assignments and merge them here?
- (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig)
+ buildReports =
+ BuildReports.fromPlanningFailure
+ platform
+ (compilerId comp)
+ pkgids
+ -- TODO we may want to get more flag assignments and merge them here?
+ (packageConfigFlagAssignment . projectConfigAllPackages $ projectConfig)
theSpecifiedPackage :: Package pkg => PackageSpecifier pkg -> Maybe PackageId
theSpecifiedPackage pkgSpec =
- case pkgSpec of
- NamedPackage name [PackagePropertyVersion version]
- -> PackageIdentifier name <$> trivialRange version
- NamedPackage _ _ -> Nothing
- SpecificSourcePackage pkg -> Just $ packageId pkg
- -- | If a range includes only a single version, return Just that version.
+ case pkgSpec of
+ NamedPackage name [PackagePropertyVersion version] ->
+ PackageIdentifier name <$> trivialRange version
+ NamedPackage _ _ -> Nothing
+ SpecificSourcePackage pkg -> Just $ packageId pkg
+ -- \| If a range includes only a single version, return Just that version.
trivialRange :: VersionRange -> Maybe Version
- trivialRange = foldVersionRange
+ trivialRange =
+ foldVersionRange
Nothing
- Just -- "== v"
+ Just -- "== v"
(\_ -> Nothing)
(\_ -> Nothing)
(\_ _ -> Nothing)
(\_ _ -> Nothing)
-
programsMonitorFiles :: ProgramDb -> [MonitorFilePath]
programsMonitorFiles progdb =
- [ monitor
- | prog <- configuredPrograms progdb
- , monitor <- monitorFileSearchPath (programMonitorFiles prog)
- (programPath prog)
- ]
+ [ monitor
+ | prog <- configuredPrograms progdb
+ , monitor <-
+ monitorFileSearchPath
+ (programMonitorFiles prog)
+ (programPath prog)
+ ]
-- | Select the bits of a 'ProgramDb' to monitor for value changes.
-- Use 'programsMonitorFiles' for the files to monitor.
---
programDbSignature :: ProgramDb -> [ConfiguredProgram]
programDbSignature progdb =
- [ prog { programMonitorFiles = []
- , programOverrideEnv = filter ((/="PATH") . fst)
- (programOverrideEnv prog) }
- | prog <- configuredPrograms progdb ]
-
-getInstalledPackages :: Verbosity
- -> Compiler -> ProgramDb -> Platform
- -> PackageDBStack
- -> Rebuild InstalledPackageIndex
+ [ prog
+ { programMonitorFiles = []
+ , programOverrideEnv =
+ filter
+ ((/= "PATH") . fst)
+ (programOverrideEnv prog)
+ }
+ | prog <- configuredPrograms progdb
+ ]
+
+getInstalledPackages
+ :: Verbosity
+ -> Compiler
+ -> ProgramDb
+ -> Platform
+ -> PackageDBStack
+ -> Rebuild InstalledPackageIndex
getInstalledPackages verbosity compiler progdb platform packagedbs = do
- monitorFiles . map monitorFileOrDirectory
- =<< liftIO (IndexUtils.getInstalledPackagesMonitorFiles
- verbosity compiler
- packagedbs progdb platform)
- liftIO $ IndexUtils.getInstalledPackages
- verbosity compiler
- packagedbs progdb
+ monitorFiles . map monitorFileOrDirectory
+ =<< liftIO
+ ( IndexUtils.getInstalledPackagesMonitorFiles
+ verbosity
+ compiler
+ packagedbs
+ progdb
+ platform
+ )
+ liftIO $
+ IndexUtils.getInstalledPackages
+ verbosity
+ compiler
+ packagedbs
+ progdb
{-
--TODO: [nice to have] use this but for sanity / consistency checking
@@ -852,414 +985,447 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
-}
getSourcePackages
- :: Verbosity
- -> (forall a. (RepoContext -> IO a) -> IO a)
- -> Maybe IndexUtils.TotalIndexState
- -> Maybe IndexUtils.ActiveRepos
- -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
+ :: Verbosity
+ -> (forall a. (RepoContext -> IO a) -> IO a)
+ -> Maybe IndexUtils.TotalIndexState
+ -> Maybe IndexUtils.ActiveRepos
+ -> Rebuild (SourcePackageDb, IndexUtils.TotalIndexState, IndexUtils.ActiveRepos)
getSourcePackages verbosity withRepoCtx idxState activeRepos = do
- (sourcePkgDbWithTIS, repos) <-
- liftIO $
- withRepoCtx $ \repoctx -> do
- sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos
- return (sourcePkgDbWithTIS, repoContextRepos repoctx)
-
- traverse_ needIfExists
- . IndexUtils.getSourcePackagesMonitorFiles
- $ repos
- return sourcePkgDbWithTIS
+ (sourcePkgDbWithTIS, repos) <-
+ liftIO $
+ withRepoCtx $ \repoctx -> do
+ sourcePkgDbWithTIS <- IndexUtils.getSourcePackagesAtIndexState verbosity repoctx idxState activeRepos
+ return (sourcePkgDbWithTIS, repoContextRepos repoctx)
+ traverse_ needIfExists
+ . IndexUtils.getSourcePackagesMonitorFiles
+ $ repos
+ return sourcePkgDbWithTIS
getPkgConfigDb :: Verbosity -> ProgramDb -> Rebuild PkgConfigDb
getPkgConfigDb verbosity progdb = do
- dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb
- -- Just monitor the dirs so we'll notice new .pc files.
- -- Alternatively we could monitor all the .pc files too.
- traverse_ monitorDirectoryStatus dirs
- liftIO $ readPkgConfigDb verbosity progdb
-
+ dirs <- liftIO $ getPkgConfigDbDirs verbosity progdb
+ -- Just monitor the dirs so we'll notice new .pc files.
+ -- Alternatively we could monitor all the .pc files too.
+ traverse_ monitorDirectoryStatus dirs
+ liftIO $ readPkgConfigDb verbosity progdb
-- | Select the config values to monitor for changes package source hashes.
-packageLocationsSignature :: SolverInstallPlan
- -> [(PackageId, PackageLocation (Maybe FilePath))]
+packageLocationsSignature
+ :: SolverInstallPlan
+ -> [(PackageId, PackageLocation (Maybe FilePath))]
packageLocationsSignature solverPlan =
- [ (packageId pkg, srcpkgSource pkg)
- | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})
- <- SolverInstallPlan.toList solverPlan
- ]
-
+ [ (packageId pkg, srcpkgSource pkg)
+ | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <-
+ SolverInstallPlan.toList solverPlan
+ ]
-- | Get the 'HashValue' for all the source packages where we use hashes,
-- and download any packages required to do so.
--
-- Note that we don't get hashes for local unpacked packages.
---
-getPackageSourceHashes :: Verbosity
- -> (forall a. (RepoContext -> IO a) -> IO a)
- -> SolverInstallPlan
- -> Rebuild (Map PackageId PackageSourceHash)
+getPackageSourceHashes
+ :: Verbosity
+ -> (forall a. (RepoContext -> IO a) -> IO a)
+ -> SolverInstallPlan
+ -> Rebuild (Map PackageId PackageSourceHash)
getPackageSourceHashes verbosity withRepoCtx solverPlan = do
+ -- Determine if and where to get the package's source hash from.
+ --
+ let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]
+ allPkgLocations =
+ [ (packageId pkg, srcpkgSource pkg)
+ | SolverInstallPlan.Configured (SolverPackage{solverPkgSource = pkg}) <-
+ SolverInstallPlan.toList solverPlan
+ ]
- -- Determine if and where to get the package's source hash from.
- --
- let allPkgLocations :: [(PackageId, PackageLocation (Maybe FilePath))]
- allPkgLocations =
- [ (packageId pkg, srcpkgSource pkg)
- | SolverInstallPlan.Configured (SolverPackage { solverPkgSource = pkg})
- <- SolverInstallPlan.toList solverPlan ]
-
- -- Tarballs that were local in the first place.
- -- We'll hash these tarball files directly.
- localTarballPkgs :: [(PackageId, FilePath)]
- localTarballPkgs =
- [ (pkgid, tarball)
- | (pkgid, LocalTarballPackage tarball) <- allPkgLocations ]
-
- -- Tarballs from remote URLs. We must have downloaded these already
- -- (since we extracted the .cabal file earlier)
- remoteTarballPkgs =
- [ (pkgid, tarball)
- | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations ]
-
- -- tarballs from source-repository-package stanzas
- sourceRepoTarballPkgs =
- [ (pkgid, tarball)
- | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations ]
-
- -- Tarballs from repositories, either where the repository provides
- -- hashes as part of the repo metadata, or where we will have to
- -- download and hash the tarball.
- repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)]
- repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]
- (repoTarballPkgsWithMetadataUnvalidated,
- repoTarballPkgsWithoutMetadata) =
+ -- Tarballs that were local in the first place.
+ -- We'll hash these tarball files directly.
+ localTarballPkgs :: [(PackageId, FilePath)]
+ localTarballPkgs =
+ [ (pkgid, tarball)
+ | (pkgid, LocalTarballPackage tarball) <- allPkgLocations
+ ]
+
+ -- Tarballs from remote URLs. We must have downloaded these already
+ -- (since we extracted the .cabal file earlier)
+ remoteTarballPkgs =
+ [ (pkgid, tarball)
+ | (pkgid, RemoteTarballPackage _ (Just tarball)) <- allPkgLocations
+ ]
+
+ -- tarballs from source-repository-package stanzas
+ sourceRepoTarballPkgs =
+ [ (pkgid, tarball)
+ | (pkgid, RemoteSourceRepoPackage _ (Just tarball)) <- allPkgLocations
+ ]
+
+ -- Tarballs from repositories, either where the repository provides
+ -- hashes as part of the repo metadata, or where we will have to
+ -- download and hash the tarball.
+ repoTarballPkgsWithMetadataUnvalidated :: [(PackageId, Repo)]
+ repoTarballPkgsWithoutMetadata :: [(PackageId, Repo)]
+ ( repoTarballPkgsWithMetadataUnvalidated
+ , repoTarballPkgsWithoutMetadata
+ ) =
partitionEithers
- [ case repo of
- RepoSecure{} -> Left (pkgid, repo)
- _ -> Right (pkgid, repo)
- | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations ]
-
- (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $
- liftIO $ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $
- \x@(pkg, repo) -> verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of
- True -> return $ Left x
- False -> return $ Right x
-
- -- For tarballs from repos that do not have hashes available we now have
- -- to check if the packages were downloaded already.
- --
- (repoTarballPkgsToDownloadWithNoMeta,
- repoTarballPkgsDownloaded)
- <- fmap partitionEithers $
- liftIO $ sequence
- [ do mtarball <- checkRepoTarballFetched repo pkgid
- case mtarball of
- Nothing -> return (Left (pkgid, repo))
- Just tarball -> return (Right (pkgid, tarball))
- | (pkgid, repo) <- repoTarballPkgsWithoutMetadata ]
-
- let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta
- (hashesFromRepoMetadata,
- repoTarballPkgsNewlyDownloaded) <-
- -- Avoid having to initialise the repository (ie 'withRepoCtx') if we
- -- don't have to. (The main cost is configuring the http client.)
- if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata
- then return (Map.empty, [])
- else liftIO $ withRepoCtx $ \repoctx -> do
+ [ case repo of
+ RepoSecure{} -> Left (pkgid, repo)
+ _ -> Right (pkgid, repo)
+ | (pkgid, RepoTarballPackage repo _ _) <- allPkgLocations
+ ]
- -- For tarballs from repos that do have hashes available as part of the
- -- repo metadata we now load up the index for each repo and retrieve
- -- the hashes for the packages
- --
- hashesFromRepoMetadata <-
- Sec.uncheckClientErrors $ --TODO: [code cleanup] wrap in our own exceptions
- fmap (Map.fromList . concat) $
+ (repoTarballPkgsWithMetadata, repoTarballPkgsToDownloadWithMeta) <- fmap partitionEithers $
+ liftIO $
+ withRepoCtx $ \repoctx -> forM repoTarballPkgsWithMetadataUnvalidated $
+ \x@(pkg, repo) ->
+ verifyFetchedTarball verbosity repoctx repo pkg >>= \b -> case b of
+ True -> return $ Left x
+ False -> return $ Right x
+
+ -- For tarballs from repos that do not have hashes available we now have
+ -- to check if the packages were downloaded already.
+ --
+ ( repoTarballPkgsToDownloadWithNoMeta
+ , repoTarballPkgsDownloaded
+ ) <-
+ fmap partitionEithers $
+ liftIO $
sequence
- -- Reading the repo index is expensive so we group the packages by repo
- [ repoContextWithSecureRepo repoctx repo $ \secureRepo ->
- Sec.withIndex secureRepo $ \repoIndex ->
- sequence
- [ do hash <- Sec.trusted <$> -- strip off Trusted tag
- Sec.indexLookupHash repoIndex pkgid
- -- Note that hackage-security currently uses SHA256
- -- but this API could in principle give us some other
- -- choice in future.
- return (pkgid, hashFromTUF hash)
- | pkgid <- pkgids ]
- | (repo, pkgids) <-
- map (\grp@((_,repo):|_) -> (repo, map fst (NE.toList grp)))
- . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd))
- . sortBy (compare `on` (remoteRepoName . repoRemote . snd))
- $ repoTarballPkgsWithMetadata
+ [ do
+ mtarball <- checkRepoTarballFetched repo pkgid
+ case mtarball of
+ Nothing -> return (Left (pkgid, repo))
+ Just tarball -> return (Right (pkgid, tarball))
+ | (pkgid, repo) <- repoTarballPkgsWithoutMetadata
]
- -- For tarballs from repos that do not have hashes available, download
- -- the ones we previously determined we need.
- --
- repoTarballPkgsNewlyDownloaded <-
- sequence
- [ do tarball <- fetchRepoTarball verbosity repoctx repo pkgid
- return (pkgid, tarball)
- | (pkgid, repo) <- repoTarballPkgsToDownload ]
-
- return (hashesFromRepoMetadata,
- repoTarballPkgsNewlyDownloaded)
+ let repoTarballPkgsToDownload = repoTarballPkgsToDownloadWithMeta ++ repoTarballPkgsToDownloadWithNoMeta
+ ( hashesFromRepoMetadata
+ , repoTarballPkgsNewlyDownloaded
+ ) <-
+ -- Avoid having to initialise the repository (ie 'withRepoCtx') if we
+ -- don't have to. (The main cost is configuring the http client.)
+ if null repoTarballPkgsToDownload && null repoTarballPkgsWithMetadata
+ then return (Map.empty, [])
+ else liftIO $ withRepoCtx $ \repoctx -> do
+ -- For tarballs from repos that do have hashes available as part of the
+ -- repo metadata we now load up the index for each repo and retrieve
+ -- the hashes for the packages
+ --
+ hashesFromRepoMetadata <-
+ Sec.uncheckClientErrors $ -- TODO: [code cleanup] wrap in our own exceptions
+ fmap (Map.fromList . concat) $
+ sequence
+ -- Reading the repo index is expensive so we group the packages by repo
+ [ repoContextWithSecureRepo repoctx repo $ \secureRepo ->
+ Sec.withIndex secureRepo $ \repoIndex ->
+ sequence
+ [ do
+ hash <-
+ Sec.trusted
+ <$> Sec.indexLookupHash repoIndex pkgid -- strip off Trusted tag
+
+ -- Note that hackage-security currently uses SHA256
+ -- but this API could in principle give us some other
+ -- choice in future.
+ return (pkgid, hashFromTUF hash)
+ | pkgid <- pkgids
+ ]
+ | (repo, pkgids) <-
+ map (\grp@((_, repo) :| _) -> (repo, map fst (NE.toList grp)))
+ . NE.groupBy ((==) `on` (remoteRepoName . repoRemote . snd))
+ . sortBy (compare `on` (remoteRepoName . repoRemote . snd))
+ $ repoTarballPkgsWithMetadata
+ ]
+
+ -- For tarballs from repos that do not have hashes available, download
+ -- the ones we previously determined we need.
+ --
+ repoTarballPkgsNewlyDownloaded <-
+ sequence
+ [ do
+ tarball <- fetchRepoTarball verbosity repoctx repo pkgid
+ return (pkgid, tarball)
+ | (pkgid, repo) <- repoTarballPkgsToDownload
+ ]
- -- Hash tarball files for packages where we have to do that. This includes
- -- tarballs that were local in the first place, plus tarballs from repos,
- -- either previously cached or freshly downloaded.
- --
- let allTarballFilePkgs :: [(PackageId, FilePath)]
- allTarballFilePkgs = localTarballPkgs
- ++ remoteTarballPkgs
- ++ sourceRepoTarballPkgs
- ++ repoTarballPkgsDownloaded
- ++ repoTarballPkgsNewlyDownloaded
- hashesFromTarballFiles <- liftIO $
+ return
+ ( hashesFromRepoMetadata
+ , repoTarballPkgsNewlyDownloaded
+ )
+
+ -- Hash tarball files for packages where we have to do that. This includes
+ -- tarballs that were local in the first place, plus tarballs from repos,
+ -- either previously cached or freshly downloaded.
+ --
+ let allTarballFilePkgs :: [(PackageId, FilePath)]
+ allTarballFilePkgs =
+ localTarballPkgs
+ ++ remoteTarballPkgs
+ ++ sourceRepoTarballPkgs
+ ++ repoTarballPkgsDownloaded
+ ++ repoTarballPkgsNewlyDownloaded
+ hashesFromTarballFiles <-
+ liftIO $
fmap Map.fromList $
- sequence
- [ do srchash <- readFileHashValue tarball
- return (pkgid, srchash)
- | (pkgid, tarball) <- allTarballFilePkgs
- ]
- monitorFiles [ monitorFile tarball
- | (_pkgid, tarball) <- allTarballFilePkgs ]
+ sequence
+ [ do
+ srchash <- readFileHashValue tarball
+ return (pkgid, srchash)
+ | (pkgid, tarball) <- allTarballFilePkgs
+ ]
+ monitorFiles
+ [ monitorFile tarball
+ | (_pkgid, tarball) <- allTarballFilePkgs
+ ]
- -- Return the combination
- return $! hashesFromRepoMetadata
- <> hashesFromTarballFiles
+ -- Return the combination
+ return $!
+ hashesFromRepoMetadata
+ <> hashesFromTarballFiles
-- | Append the given package databases to an existing PackageDBStack.
-- A @Nothing@ entry will clear everything before it.
applyPackageDbFlags :: PackageDBStack -> [Maybe PackageDB] -> PackageDBStack
-applyPackageDbFlags dbs' [] = dbs'
-applyPackageDbFlags _ (Nothing:dbs) = applyPackageDbFlags [] dbs
-applyPackageDbFlags dbs' (Just db:dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs
+applyPackageDbFlags dbs' [] = dbs'
+applyPackageDbFlags _ (Nothing : dbs) = applyPackageDbFlags [] dbs
+applyPackageDbFlags dbs' (Just db : dbs) = applyPackageDbFlags (dbs' ++ [db]) dbs
-- ------------------------------------------------------------
+
-- * Installation planning
+
-- ------------------------------------------------------------
-planPackages :: Verbosity
- -> Compiler
- -> Platform
- -> Solver -> SolverSettings
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> PkgConfigDb
- -> [PackageSpecifier UnresolvedSourcePackage]
- -> Map PackageName (Map OptionalStanza Bool)
- -> Progress String String SolverInstallPlan
-planPackages verbosity comp platform solver SolverSettings{..}
- installedPkgIndex sourcePkgDb pkgConfigDB
- localPackages pkgStanzasEnable =
+planPackages
+ :: Verbosity
+ -> Compiler
+ -> Platform
+ -> Solver
+ -> SolverSettings
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> PkgConfigDb
+ -> [PackageSpecifier UnresolvedSourcePackage]
+ -> Map PackageName (Map OptionalStanza Bool)
+ -> Progress String String SolverInstallPlan
+planPackages
+ verbosity
+ comp
+ platform
+ solver
+ SolverSettings{..}
+ installedPkgIndex
+ sourcePkgDb
+ pkgConfigDB
+ localPackages
+ pkgStanzasEnable =
resolveDependencies
- platform (compilerInfo comp)
- pkgConfigDB solver
+ platform
+ (compilerInfo comp)
+ pkgConfigDB
+ solver
resolverParams
-
- where
-
- --TODO: [nice to have] disable multiple instances restriction in
- -- the solver, but then make sure we can cope with that in the
- -- output.
- resolverParams :: DepResolverParams
- resolverParams =
-
+ where
+ -- TODO: [nice to have] disable multiple instances restriction in
+ -- the solver, but then make sure we can cope with that in the
+ -- output.
+ resolverParams :: DepResolverParams
+ resolverParams =
setMaxBackjumps solverSettingMaxBackjumps
-
- . setIndependentGoals solverSettingIndependentGoals
-
- . setReorderGoals solverSettingReorderGoals
-
- . setCountConflicts solverSettingCountConflicts
-
- . setFineGrainedConflicts solverSettingFineGrainedConflicts
-
- . setMinimizeConflictSet solverSettingMinimizeConflictSet
-
- --TODO: [required eventually] should only be configurable for
- --custom installs
- -- . setAvoidReinstalls solverSettingAvoidReinstalls
-
- --TODO: [required eventually] should only be configurable for
- --custom installs
- -- . setShadowPkgs solverSettingShadowPkgs
-
- . setStrongFlags solverSettingStrongFlags
-
- . setAllowBootLibInstalls solverSettingAllowBootLibInstalls
-
- . setOnlyConstrained solverSettingOnlyConstrained
-
- . setSolverVerbosity verbosity
-
- --TODO: [required eventually] decide if we need to prefer
- -- installed for global packages, or prefer latest even for
- -- global packages. Perhaps should be configurable but with a
- -- different name than "upgrade-dependencies".
- . setPreferenceDefault
- (if Cabal.asBool solverSettingPreferOldest
- then PreferAllOldest
- else PreferLatestForSelected)
- {-(if solverSettingUpgradeDeps
- then PreferAllLatest
- else PreferLatestForSelected)-}
-
- . removeLowerBounds solverSettingAllowOlder
- . removeUpperBounds solverSettingAllowNewer
-
- . addDefaultSetupDependencies (defaultSetupDeps comp platform
- . PD.packageDescription
- . srcpkgDescription)
-
- . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint
- . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint
-
- . addPreferences
- -- preferences from the config file or command line
- [ PackageVersionPreference name ver
- | PackageVersionConstraint name ver <- solverSettingPreferences ]
-
- . addConstraints
- -- version constraints from the config file or command line
+ . setIndependentGoals solverSettingIndependentGoals
+ . setReorderGoals solverSettingReorderGoals
+ . setCountConflicts solverSettingCountConflicts
+ . setFineGrainedConflicts solverSettingFineGrainedConflicts
+ . setMinimizeConflictSet solverSettingMinimizeConflictSet
+ -- TODO: [required eventually] should only be configurable for
+ -- custom installs
+ -- . setAvoidReinstalls solverSettingAvoidReinstalls
+
+ -- TODO: [required eventually] should only be configurable for
+ -- custom installs
+ -- . setShadowPkgs solverSettingShadowPkgs
+
+ . setStrongFlags solverSettingStrongFlags
+ . setAllowBootLibInstalls solverSettingAllowBootLibInstalls
+ . setOnlyConstrained solverSettingOnlyConstrained
+ . setSolverVerbosity verbosity
+ -- TODO: [required eventually] decide if we need to prefer
+ -- installed for global packages, or prefer latest even for
+ -- global packages. Perhaps should be configurable but with a
+ -- different name than "upgrade-dependencies".
+ . setPreferenceDefault
+ ( if Cabal.asBool solverSettingPreferOldest
+ then PreferAllOldest
+ else PreferLatestForSelected
+ )
+ {-(if solverSettingUpgradeDeps
+ then PreferAllLatest
+ else PreferLatestForSelected)-}
+
+ . removeLowerBounds solverSettingAllowOlder
+ . removeUpperBounds solverSettingAllowNewer
+ . addDefaultSetupDependencies
+ ( defaultSetupDeps comp platform
+ . PD.packageDescription
+ . srcpkgDescription
+ )
+ . addSetupCabalMinVersionConstraint setupMinCabalVersionConstraint
+ . addSetupCabalMaxVersionConstraint setupMaxCabalVersionConstraint
+ . addPreferences
+ -- preferences from the config file or command line
+ [ PackageVersionPreference name ver
+ | PackageVersionConstraint name ver <- solverSettingPreferences
+ ]
+ . addConstraints
+ -- version constraints from the config file or command line
[ LabeledPackageConstraint (userToPackageConstraint pc) src
- | (pc, src) <- solverSettingConstraints ]
-
- . addPreferences
- -- enable stanza preference unilaterally, regardless if the user asked
- -- accordingly or expressed no preference, to help hint the solver
- [ PackageStanzasPreference pkgname stanzas
- | pkg <- localPackages
- , let pkgname = pkgSpecifierTarget pkg
- stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable
- stanzas = [ stanza | stanza <- [minBound..maxBound]
- , Map.lookup stanza stanzaM /= Just False ]
- , not (null stanzas)
- ]
-
- . addConstraints
- -- enable stanza constraints where the user asked to enable
- [ LabeledPackageConstraint
- (PackageConstraint (scopeToplevel pkgname)
- (PackagePropertyStanzas stanzas))
+ | (pc, src) <- solverSettingConstraints
+ ]
+ . addPreferences
+ -- enable stanza preference unilaterally, regardless if the user asked
+ -- accordingly or expressed no preference, to help hint the solver
+ [ PackageStanzasPreference pkgname stanzas
+ | pkg <- localPackages
+ , let pkgname = pkgSpecifierTarget pkg
+ stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable
+ stanzas =
+ [ stanza | stanza <- [minBound .. maxBound], Map.lookup stanza stanzaM /= Just False
+ ]
+ , not (null stanzas)
+ ]
+ . addConstraints
+ -- enable stanza constraints where the user asked to enable
+ [ LabeledPackageConstraint
+ ( PackageConstraint
+ (scopeToplevel pkgname)
+ (PackagePropertyStanzas stanzas)
+ )
ConstraintSourceConfigFlagOrTarget
- | pkg <- localPackages
- , let pkgname = pkgSpecifierTarget pkg
- stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable
- stanzas = [ stanza | stanza <- [minBound..maxBound]
- , Map.lookup stanza stanzaM == Just True ]
- , not (null stanzas)
- ]
-
- . addConstraints
- --TODO: [nice to have] should have checked at some point that the
- -- package in question actually has these flags.
- [ LabeledPackageConstraint
- (PackageConstraint (scopeToplevel pkgname)
- (PackagePropertyFlags flags))
+ | pkg <- localPackages
+ , let pkgname = pkgSpecifierTarget pkg
+ stanzaM = Map.findWithDefault Map.empty pkgname pkgStanzasEnable
+ stanzas =
+ [ stanza | stanza <- [minBound .. maxBound], Map.lookup stanza stanzaM == Just True
+ ]
+ , not (null stanzas)
+ ]
+ . addConstraints
+ -- TODO: [nice to have] should have checked at some point that the
+ -- package in question actually has these flags.
+ [ LabeledPackageConstraint
+ ( PackageConstraint
+ (scopeToplevel pkgname)
+ (PackagePropertyFlags flags)
+ )
ConstraintSourceConfigFlagOrTarget
- | (pkgname, flags) <- Map.toList solverSettingFlagAssignments ]
-
- . addConstraints
- --TODO: [nice to have] we have user-supplied flags for unspecified
- -- local packages (as well as specific per-package flags). For the
- -- former we just apply all these flags to all local targets which
- -- is silly. We should check if the flags are appropriate.
- [ LabeledPackageConstraint
- (PackageConstraint (scopeToplevel pkgname)
- (PackagePropertyFlags flags))
+ | (pkgname, flags) <- Map.toList solverSettingFlagAssignments
+ ]
+ . addConstraints
+ -- TODO: [nice to have] we have user-supplied flags for unspecified
+ -- local packages (as well as specific per-package flags). For the
+ -- former we just apply all these flags to all local targets which
+ -- is silly. We should check if the flags are appropriate.
+ [ LabeledPackageConstraint
+ ( PackageConstraint
+ (scopeToplevel pkgname)
+ (PackagePropertyFlags flags)
+ )
ConstraintSourceConfigFlagOrTarget
- | let flags = solverSettingFlagAssignment
- , not (PD.nullFlagAssignment flags)
- , pkg <- localPackages
- , let pkgname = pkgSpecifierTarget pkg ]
-
- $ stdResolverParams
-
- stdResolverParams :: DepResolverParams
- stdResolverParams =
- -- Note: we don't use the standardInstallPolicy here, since that uses
- -- its own addDefaultSetupDependencies that is not appropriate for us.
- basicInstallPolicy
- installedPkgIndex sourcePkgDb
- localPackages
-
- -- While we can talk to older Cabal versions (we need to be able to
- -- do so for custom Setup scripts that require older Cabal lib
- -- versions), we have problems talking to some older versions that
- -- don't support certain features.
- --
- -- For example, Cabal-1.16 and older do not know about build targets.
- -- Even worse, 1.18 and older only supported the --constraint flag
- -- with source package ids, not --dependency with installed package
- -- ids. That is bad because we cannot reliably select the right
- -- dependencies in the presence of multiple instances (i.e. the
- -- store). See issue #3932. So we require Cabal 1.20 as a minimum.
- --
- -- Moreover, lib:Cabal generally only supports the interface of
- -- current and past compilers; in fact recent lib:Cabal versions
- -- will warn when they encounter a too new or unknown GHC compiler
- -- version (c.f. #415). To avoid running into unsupported
- -- configurations we encode the compatibility matrix as lower
- -- bounds on lib:Cabal here (effectively corresponding to the
- -- respective major Cabal version bundled with the respective GHC
- -- release).
- --
- -- GHC 9.2 needs Cabal >= 3.6
- -- GHC 9.0 needs Cabal >= 3.4
- -- GHC 8.10 needs Cabal >= 3.2
- -- GHC 8.8 needs Cabal >= 3.0
- -- GHC 8.6 needs Cabal >= 2.4
- -- GHC 8.4 needs Cabal >= 2.2
- -- GHC 8.2 needs Cabal >= 2.0
- -- GHC 8.0 needs Cabal >= 1.24
- -- GHC 7.10 needs Cabal >= 1.22
- --
- -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is
- -- the absolute lower bound)
- --
- -- TODO: long-term, this compatibility matrix should be
- -- stored as a field inside 'Distribution.Compiler.Compiler'
- setupMinCabalVersionConstraint
- | isGHC, compVer >= mkVersion [9,6] = mkVersion [3,10]
- | isGHC, compVer >= mkVersion [9,4] = mkVersion [3,8]
- | isGHC, compVer >= mkVersion [9,2] = mkVersion [3,6]
- | isGHC, compVer >= mkVersion [9,0] = mkVersion [3,4]
- | isGHC, compVer >= mkVersion [8,10] = mkVersion [3,2]
- | isGHC, compVer >= mkVersion [8,8] = mkVersion [3,0]
- | isGHC, compVer >= mkVersion [8,6] = mkVersion [2,4]
- | isGHC, compVer >= mkVersion [8,4] = mkVersion [2,2]
- | isGHC, compVer >= mkVersion [8,2] = mkVersion [2,0]
- | isGHC, compVer >= mkVersion [8,0] = mkVersion [1,24]
- | isGHC, compVer >= mkVersion [7,10] = mkVersion [1,22]
- | otherwise = mkVersion [1,20]
- where
- isGHC = compFlav `elem` [GHC,GHCJS]
- compFlav = compilerFlavor comp
- compVer = compilerVersion comp
+ | let flags = solverSettingFlagAssignment
+ , not (PD.nullFlagAssignment flags)
+ , pkg <- localPackages
+ , let pkgname = pkgSpecifierTarget pkg
+ ]
+ $ stdResolverParams
+
+ stdResolverParams :: DepResolverParams
+ stdResolverParams =
+ -- Note: we don't use the standardInstallPolicy here, since that uses
+ -- its own addDefaultSetupDependencies that is not appropriate for us.
+ basicInstallPolicy
+ installedPkgIndex
+ sourcePkgDb
+ localPackages
+
+ -- While we can talk to older Cabal versions (we need to be able to
+ -- do so for custom Setup scripts that require older Cabal lib
+ -- versions), we have problems talking to some older versions that
+ -- don't support certain features.
+ --
+ -- For example, Cabal-1.16 and older do not know about build targets.
+ -- Even worse, 1.18 and older only supported the --constraint flag
+ -- with source package ids, not --dependency with installed package
+ -- ids. That is bad because we cannot reliably select the right
+ -- dependencies in the presence of multiple instances (i.e. the
+ -- store). See issue #3932. So we require Cabal 1.20 as a minimum.
+ --
+ -- Moreover, lib:Cabal generally only supports the interface of
+ -- current and past compilers; in fact recent lib:Cabal versions
+ -- will warn when they encounter a too new or unknown GHC compiler
+ -- version (c.f. #415). To avoid running into unsupported
+ -- configurations we encode the compatibility matrix as lower
+ -- bounds on lib:Cabal here (effectively corresponding to the
+ -- respective major Cabal version bundled with the respective GHC
+ -- release).
+ --
+ -- GHC 9.2 needs Cabal >= 3.6
+ -- GHC 9.0 needs Cabal >= 3.4
+ -- GHC 8.10 needs Cabal >= 3.2
+ -- GHC 8.8 needs Cabal >= 3.0
+ -- GHC 8.6 needs Cabal >= 2.4
+ -- GHC 8.4 needs Cabal >= 2.2
+ -- GHC 8.2 needs Cabal >= 2.0
+ -- GHC 8.0 needs Cabal >= 1.24
+ -- GHC 7.10 needs Cabal >= 1.22
+ --
+ -- (NB: we don't need to consider older GHCs as Cabal >= 1.20 is
+ -- the absolute lower bound)
+ --
+ -- TODO: long-term, this compatibility matrix should be
+ -- stored as a field inside 'Distribution.Compiler.Compiler'
+ setupMinCabalVersionConstraint
+ | isGHC, compVer >= mkVersion [9, 6] = mkVersion [3, 10]
+ | isGHC, compVer >= mkVersion [9, 4] = mkVersion [3, 8]
+ | isGHC, compVer >= mkVersion [9, 2] = mkVersion [3, 6]
+ | isGHC, compVer >= mkVersion [9, 0] = mkVersion [3, 4]
+ | isGHC, compVer >= mkVersion [8, 10] = mkVersion [3, 2]
+ | isGHC, compVer >= mkVersion [8, 8] = mkVersion [3, 0]
+ | isGHC, compVer >= mkVersion [8, 6] = mkVersion [2, 4]
+ | isGHC, compVer >= mkVersion [8, 4] = mkVersion [2, 2]
+ | isGHC, compVer >= mkVersion [8, 2] = mkVersion [2, 0]
+ | isGHC, compVer >= mkVersion [8, 0] = mkVersion [1, 24]
+ | isGHC, compVer >= mkVersion [7, 10] = mkVersion [1, 22]
+ | otherwise = mkVersion [1, 20]
+ where
+ isGHC = compFlav `elem` [GHC, GHCJS]
+ compFlav = compilerFlavor comp
+ compVer = compilerVersion comp
- -- As we can't predict the future, we also place a global upper
- -- bound on the lib:Cabal version we know how to interact with:
- --
- -- The upper bound is computed by incrementing the current major
- -- version twice in order to allow for the current version, as
- -- well as the next adjacent major version (one of which will not
- -- be released, as only "even major" versions of Cabal are
- -- released to Hackage or bundled with proper GHC releases).
- --
- -- For instance, if the current version of cabal-install is an odd
- -- development version, e.g. Cabal-2.1.0.0, then we impose an
- -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a
- -- stable/release even version, e.g. Cabal-2.2.1.0, the upper
- -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility
- -- when dealing with development snapshots of Cabal and cabal-install.
- --
- setupMaxCabalVersionConstraint =
- alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion
+ -- As we can't predict the future, we also place a global upper
+ -- bound on the lib:Cabal version we know how to interact with:
+ --
+ -- The upper bound is computed by incrementing the current major
+ -- version twice in order to allow for the current version, as
+ -- well as the next adjacent major version (one of which will not
+ -- be released, as only "even major" versions of Cabal are
+ -- released to Hackage or bundled with proper GHC releases).
+ --
+ -- For instance, if the current version of cabal-install is an odd
+ -- development version, e.g. Cabal-2.1.0.0, then we impose an
+ -- upper bound `setup.Cabal < 2.3`; if `cabal-install` is on a
+ -- stable/release even version, e.g. Cabal-2.2.1.0, the upper
+ -- bound is `setup.Cabal < 2.4`. This gives us enough flexibility
+ -- when dealing with development snapshots of Cabal and cabal-install.
+ --
+ setupMaxCabalVersionConstraint =
+ alterVersion (take 2) $ incVersion 1 $ incVersion 1 cabalVersion
------------------------------------------------------------------------------
+
-- * Install plan post-processing
+
------------------------------------------------------------------------------
-- This phase goes from the InstallPlan we get from the solver and has to
@@ -1275,11 +1441,10 @@ planPackages verbosity comp platform solver SolverSettings{..}
-- way to calculate the installed package ids used for the replacement step is
-- from the elaborated configuration for each package.
-
-
-
------------------------------------------------------------------------------
+
-- * Install plan elaboration
+
------------------------------------------------------------------------------
-- Note [SolverId to ConfiguredId]
@@ -1298,7 +1463,9 @@ planPackages verbosity comp platform solver SolverSettings{..}
-- library dependencies on lib-0.2, and executable dependencies on pkg-0.1
-- and alex-0.3 (other components of the package may have different
-- dependencies). Note that I've "lost" the knowledge that I depend
--- *specifically* on the exe1 executable from pkg.
+
+-- * specifically* on the exe1 executable from pkg.
+
--
-- So, we have a this graph of packages, and we need to transform it into
-- a graph of components which we are actually going to build. In particular:
@@ -1353,15 +1520,17 @@ planPackages verbosity comp platform solver SolverSettings{..}
-- like a 'ConfiguredId', in that it incorporates the version choices of its
-- dependencies, but less fine grained.
-
-- | Produce an elaborated install plan using the policy for local builds with
-- a nix-style shared store.
--
-- In theory should be able to make an elaborated install plan with a policy
-- matching that of the classic @cabal install --user@ or @--global@
---
elaborateInstallPlan
- :: Verbosity -> Platform -> Compiler -> ProgramDb -> PkgConfigDb
+ :: Verbosity
+ -> Platform
+ -> Compiler
+ -> ProgramDb
+ -> PkgConfigDb
-> DistDirLayout
-> StoreDirLayout
-> SolverInstallPlan
@@ -1373,759 +1542,879 @@ elaborateInstallPlan
-> PackageConfig
-> Map PackageName PackageConfig
-> LogProgress (ElaboratedInstallPlan, ElaboratedSharedConfig)
-elaborateInstallPlan verbosity platform compiler compilerprogdb pkgConfigDB
- distDirLayout@DistDirLayout{..}
- storeDirLayout@StoreDirLayout{storePackageDBStack}
- solverPlan localPackages
- sourcePackageHashes
- defaultInstallDirs
- sharedPackageConfig
- allPackagesConfig
- localPackagesConfig
- perPackageConfig = do
+elaborateInstallPlan
+ verbosity
+ platform
+ compiler
+ compilerprogdb
+ pkgConfigDB
+ distDirLayout@DistDirLayout{..}
+ storeDirLayout@StoreDirLayout{storePackageDBStack}
+ solverPlan
+ localPackages
+ sourcePackageHashes
+ defaultInstallDirs
+ sharedPackageConfig
+ allPackagesConfig
+ localPackagesConfig
+ perPackageConfig = do
x <- elaboratedInstallPlan
return (x, elaboratedSharedConfig)
- where
- elaboratedSharedConfig =
- ElaboratedSharedConfig {
- pkgConfigPlatform = platform,
- pkgConfigCompiler = compiler,
- pkgConfigCompilerProgs = compilerprogdb,
- pkgConfigReplOptions = mempty
- }
-
- preexistingInstantiatedPkgs :: Map UnitId FullUnitId
- preexistingInstantiatedPkgs =
+ where
+ elaboratedSharedConfig =
+ ElaboratedSharedConfig
+ { pkgConfigPlatform = platform
+ , pkgConfigCompiler = compiler
+ , pkgConfigCompilerProgs = compilerprogdb
+ , pkgConfigReplOptions = mempty
+ }
+
+ preexistingInstantiatedPkgs :: Map UnitId FullUnitId
+ preexistingInstantiatedPkgs =
Map.fromList (mapMaybe f (SolverInstallPlan.toList solverPlan))
- where
- f (SolverInstallPlan.PreExisting inst)
+ where
+ f (SolverInstallPlan.PreExisting inst)
| let ipkg = instSolverPkgIPI inst
- , not (IPI.indefinite ipkg)
- = Just (IPI.installedUnitId ipkg,
- (FullUnitId (IPI.installedComponentId ipkg)
- (Map.fromList (IPI.instantiatedWith ipkg))))
- f _ = Nothing
-
- elaboratedInstallPlan ::
- LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)
- elaboratedInstallPlan =
- flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
- case planpkg of
- SolverInstallPlan.PreExisting pkg ->
- return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]
-
- SolverInstallPlan.Configured pkg ->
- let inplace_doc | shouldBuildInplaceOnly pkg = text "inplace"
- | otherwise = Disp.empty
- in addProgressCtx (text "In the" <+> inplace_doc <+> text "package" <+>
- quotes (pretty (packageId pkg))) $
- map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg
-
- -- NB: We don't INSTANTIATE packages at this point. That's
- -- a post-pass. This makes it simpler to compute dependencies.
- elaborateSolverToComponents
+ , not (IPI.indefinite ipkg) =
+ Just
+ ( IPI.installedUnitId ipkg
+ , ( FullUnitId
+ (IPI.installedComponentId ipkg)
+ (Map.fromList (IPI.instantiatedWith ipkg))
+ )
+ )
+ f _ = Nothing
+
+ elaboratedInstallPlan
+ :: LogProgress (InstallPlan.GenericInstallPlan IPI.InstalledPackageInfo ElaboratedConfiguredPackage)
+ elaboratedInstallPlan =
+ flip InstallPlan.fromSolverInstallPlanWithProgress solverPlan $ \mapDep planpkg ->
+ case planpkg of
+ SolverInstallPlan.PreExisting pkg ->
+ return [InstallPlan.PreExisting (instSolverPkgIPI pkg)]
+ SolverInstallPlan.Configured pkg ->
+ let inplace_doc
+ | shouldBuildInplaceOnly pkg = text "inplace"
+ | otherwise = Disp.empty
+ in addProgressCtx
+ ( text "In the"
+ <+> inplace_doc
+ <+> text "package"
+ <+> quotes (pretty (packageId pkg))
+ )
+ $ map InstallPlan.Configured <$> elaborateSolverToComponents mapDep pkg
+
+ -- NB: We don't INSTANTIATE packages at this point. That's
+ -- a post-pass. This makes it simpler to compute dependencies.
+ elaborateSolverToComponents
:: (SolverId -> [ElaboratedPlanPackage])
-> SolverPackage UnresolvedPkgLoc
-> LogProgress [ElaboratedConfiguredPackage]
- elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0)
- = case mkComponentsGraph (elabEnabledSpec elab0) pd of
- Right g -> do
+ elaborateSolverToComponents mapDep spkg@(SolverPackage _ _ _ deps0 exe_deps0) =
+ case mkComponentsGraph (elabEnabledSpec elab0) pd of
+ Right g -> do
let src_comps = componentsGraphToList g
- infoProgress $ hang (text "Component graph for" <+> pretty pkgid <<>> colon)
- 4 (dispComponentsWithDeps src_comps)
- (_, comps) <- mapAccumM buildComponent
- (Map.empty, Map.empty, Map.empty)
- (map fst src_comps)
+ infoProgress $
+ hang
+ (text "Component graph for" <+> pretty pkgid <<>> colon)
+ 4
+ (dispComponentsWithDeps src_comps)
+ (_, comps) <-
+ mapAccumM
+ buildComponent
+ (Map.empty, Map.empty, Map.empty)
+ (map fst src_comps)
let not_per_component_reasons = why_not_per_component src_comps
if null not_per_component_reasons
- then return comps
- else do checkPerPackageOk comps not_per_component_reasons
- return [elaborateSolverToPackage spkg g $
- comps ++ maybeToList setupComponent]
- Left cns ->
+ then return comps
+ else do
+ checkPerPackageOk comps not_per_component_reasons
+ return
+ [ elaborateSolverToPackage spkg g $
+ comps ++ maybeToList setupComponent
+ ]
+ Left cns ->
dieProgress $
- hang (text "Dependency cycle between the following components:") 4
- (vcat (map (text . componentNameStanza) cns))
- where
- -- You are eligible to per-component build if this list is empty
- why_not_per_component g
- = cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage
- where
- cuz reason = [text reason]
- -- We have to disable per-component for now with
- -- Configure-type scripts in order to prevent parallel
- -- invocation of the same `./configure` script.
- -- See https://github.com/haskell/cabal/issues/4548
- --
- -- Moreover, at this point in time, only non-Custom setup scripts
- -- are supported. Implementing per-component builds with
- -- Custom would require us to create a new 'ElabSetup'
- -- type, and teach all of the code paths how to handle it.
- -- Once you've implemented this, swap it for the code below.
- cuz_buildtype =
+ hang
+ (text "Dependency cycle between the following components:")
+ 4
+ (vcat (map (text . componentNameStanza) cns))
+ where
+ -- You are eligible to per-component build if this list is empty
+ why_not_per_component g =
+ cuz_buildtype ++ cuz_spec ++ cuz_length ++ cuz_flag ++ cuz_coverage
+ where
+ cuz reason = [text reason]
+ -- We have to disable per-component for now with
+ -- Configure-type scripts in order to prevent parallel
+ -- invocation of the same `./configure` script.
+ -- See https://github.com/haskell/cabal/issues/4548
+ --
+ -- Moreover, at this point in time, only non-Custom setup scripts
+ -- are supported. Implementing per-component builds with
+ -- Custom would require us to create a new 'ElabSetup'
+ -- type, and teach all of the code paths how to handle it.
+ -- Once you've implemented this, swap it for the code below.
+ cuz_buildtype =
case PD.buildType (elabPkgDescription elab0) of
- PD.Configure -> cuz "build-type is Configure"
- PD.Custom -> cuz "build-type is Custom"
- _ -> []
- -- cabal-format versions prior to 1.8 have different build-depends semantics
- -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8
- -- see, https://github.com/haskell/cabal/issues/4121
- cuz_spec
+ PD.Configure -> cuz "build-type is Configure"
+ PD.Custom -> cuz "build-type is Custom"
+ _ -> []
+ -- cabal-format versions prior to 1.8 have different build-depends semantics
+ -- for now it's easier to just fallback to legacy-mode when specVersion < 1.8
+ -- see, https://github.com/haskell/cabal/issues/4121
+ cuz_spec
| PD.specVersion pd >= CabalSpecV1_8 = []
| otherwise = cuz "cabal-version is less than 1.8"
- -- In the odd corner case that a package has no components at all
- -- then keep it as a whole package, since otherwise it turns into
- -- 0 component graph nodes and effectively vanishes. We want to
- -- keep it around at least for error reporting purposes.
- cuz_length
+ -- In the odd corner case that a package has no components at all
+ -- then keep it as a whole package, since otherwise it turns into
+ -- 0 component graph nodes and effectively vanishes. We want to
+ -- keep it around at least for error reporting purposes.
+ cuz_length
| length g > 0 = []
- | otherwise = cuz "there are no buildable components"
- -- For ease of testing, we let per-component builds be toggled
- -- at the top level
- cuz_flag
- | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig)
- = []
+ | otherwise = cuz "there are no buildable components"
+ -- For ease of testing, we let per-component builds be toggled
+ -- at the top level
+ cuz_flag
+ | fromFlagOrDefault True (projectConfigPerComponent sharedPackageConfig) =
+ []
| otherwise = cuz "you passed --disable-per-component"
- -- Enabling program coverage introduces odd runtime dependencies
- -- between components.
- cuz_coverage
- | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig)
- = cuz "program coverage is enabled"
+ -- Enabling program coverage introduces odd runtime dependencies
+ -- between components.
+ cuz_coverage
+ | fromFlagOrDefault False (packageConfigCoverage localPackagesConfig) =
+ cuz "program coverage is enabled"
| otherwise = []
- -- | Sometimes a package may make use of features which are only
- -- supported in per-package mode. If this is the case, we should
- -- give an error when this occurs.
- checkPerPackageOk comps reasons = do
+ -- \| Sometimes a package may make use of features which are only
+ -- supported in per-package mode. If this is the case, we should
+ -- give an error when this occurs.
+ checkPerPackageOk comps reasons = do
let is_sublib (CLibName (LSubLibName _)) = True
is_sublib _ = False
when (any (matchElabPkg is_sublib) comps) $
- dieProgress $
- text "Internal libraries only supported with per-component builds." $$
- text "Per-component builds were disabled because" <+>
- fsep (punctuate comma reasons)
- -- TODO: Maybe exclude Backpack too
-
- elab0 = elaborateSolverToCommon spkg
- pkgid = elabPkgSourceId elab0
- pd = elabPkgDescription elab0
-
- -- TODO: This is just a skeleton to get elaborateSolverToPackage
- -- working correctly
- -- TODO: When we actually support building these components, we
- -- have to add dependencies on this from all other components
- setupComponent :: Maybe ElaboratedConfiguredPackage
- setupComponent
- | PD.buildType (elabPkgDescription elab0) == PD.Custom
- = Just elab0 {
- elabModuleShape = emptyModuleShape,
- elabUnitId = notImpl "elabUnitId",
- elabComponentId = notImpl "elabComponentId",
- elabLinkedInstantiatedWith = Map.empty,
- elabInstallDirs = notImpl "elabInstallDirs",
- elabPkgOrComp = ElabComponent (ElaboratedComponent {..})
- }
- | otherwise
- = Nothing
- where
- compSolverName = CD.ComponentSetup
- compComponentName = Nothing
- dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0
- compLibDependencies
- = map configuredId dep_pkgs
- compLinkedLibDependencies = notImpl "compLinkedLibDependencies"
- compOrderLibDependencies = notImpl "compOrderLibDependencies"
- -- Not supported:
- compExeDependencies = []
- compExeDependencyPaths = []
- compPkgConfigDependencies = []
-
- notImpl f =
- error $ "Distribution.Client.ProjectPlanning.setupComponent: " ++
- f ++ " not implemented yet"
-
-
- buildComponent
- :: (ConfiguredComponentMap,
- LinkedComponentMap,
- Map ComponentId FilePath)
+ dieProgress $
+ text "Internal libraries only supported with per-component builds."
+ $$ text "Per-component builds were disabled because"
+ <+> fsep (punctuate comma reasons)
+ -- TODO: Maybe exclude Backpack too
+
+ elab0 = elaborateSolverToCommon spkg
+ pkgid = elabPkgSourceId elab0
+ pd = elabPkgDescription elab0
+
+ -- TODO: This is just a skeleton to get elaborateSolverToPackage
+ -- working correctly
+ -- TODO: When we actually support building these components, we
+ -- have to add dependencies on this from all other components
+ setupComponent :: Maybe ElaboratedConfiguredPackage
+ setupComponent
+ | PD.buildType (elabPkgDescription elab0) == PD.Custom =
+ Just
+ elab0
+ { elabModuleShape = emptyModuleShape
+ , elabUnitId = notImpl "elabUnitId"
+ , elabComponentId = notImpl "elabComponentId"
+ , elabLinkedInstantiatedWith = Map.empty
+ , elabInstallDirs = notImpl "elabInstallDirs"
+ , elabPkgOrComp = ElabComponent (ElaboratedComponent{..})
+ }
+ | otherwise =
+ Nothing
+ where
+ compSolverName = CD.ComponentSetup
+ compComponentName = Nothing
+ dep_pkgs = elaborateLibSolverId mapDep =<< CD.setupDeps deps0
+ compLibDependencies =
+ map configuredId dep_pkgs
+ compLinkedLibDependencies = notImpl "compLinkedLibDependencies"
+ compOrderLibDependencies = notImpl "compOrderLibDependencies"
+ -- Not supported:
+ compExeDependencies = []
+ compExeDependencyPaths = []
+ compPkgConfigDependencies = []
+
+ notImpl f =
+ error $
+ "Distribution.Client.ProjectPlanning.setupComponent: "
+ ++ f
+ ++ " not implemented yet"
+
+ buildComponent
+ :: ( ConfiguredComponentMap
+ , LinkedComponentMap
+ , Map ComponentId FilePath
+ )
-> Cabal.Component
-> LogProgress
- ((ConfiguredComponentMap,
- LinkedComponentMap,
- Map ComponentId FilePath),
- ElaboratedConfiguredPackage)
- buildComponent (cc_map, lc_map, exe_map) comp =
- addProgressCtx (text "In the stanza" <+>
- quotes (text (componentNameStanza cname))) $ do
-
- -- 1. Configure the component, but with a place holder ComponentId.
- cc0 <- toConfiguredComponent
+ ( ( ConfiguredComponentMap
+ , LinkedComponentMap
+ , Map ComponentId FilePath
+ )
+ , ElaboratedConfiguredPackage
+ )
+ buildComponent (cc_map, lc_map, exe_map) comp =
+ addProgressCtx
+ ( text "In the stanza"
+ <+> quotes (text (componentNameStanza cname))
+ )
+ $ do
+ -- 1. Configure the component, but with a place holder ComponentId.
+ cc0 <-
+ toConfiguredComponent
pd
(error "Distribution.Client.ProjectPlanning.cc_cid: filled in later")
(Map.unionWith Map.union external_lib_cc_map cc_map)
(Map.unionWith Map.union external_exe_cc_map cc_map)
comp
-
- -- 2. Read out the dependencies from the ConfiguredComponent cc0
- let compLibDependencies =
- -- Nub because includes can show up multiple times
- ordNub (map (annotatedIdToConfiguredId . ci_ann_id)
- (cc_includes cc0))
- compExeDependencies =
- map annotatedIdToConfiguredId
+ -- 2. Read out the dependencies from the ConfiguredComponent cc0
+ let compLibDependencies =
+ -- Nub because includes can show up multiple times
+ ordNub
+ ( map
+ (annotatedIdToConfiguredId . ci_ann_id)
+ (cc_includes cc0)
+ )
+ compExeDependencies =
+ map
+ annotatedIdToConfiguredId
(cc_exe_deps cc0)
- compExeDependencyPaths =
- [ (annotatedIdToConfiguredId aid', path)
- | aid' <- cc_exe_deps cc0
- , Just paths <- [Map.lookup (ann_id aid') exe_map1]
- , path <- paths ]
- elab_comp = ElaboratedComponent {..}
-
- -- 3. Construct a preliminary ElaboratedConfiguredPackage,
- -- and use this to compute the component ID. Fix up cc_id
- -- correctly.
- let elab1 = elab0 {
- elabPkgOrComp = ElabComponent $ elab_comp
- }
- cid = case elabBuildStyle elab0 of
- BuildInplaceOnly ->
- mkComponentId $
- prettyShow pkgid ++ "-inplace" ++
- (case Cabal.componentNameString cname of
+ compExeDependencyPaths =
+ [ (annotatedIdToConfiguredId aid', path)
+ | aid' <- cc_exe_deps cc0
+ , Just paths <- [Map.lookup (ann_id aid') exe_map1]
+ , path <- paths
+ ]
+ elab_comp = ElaboratedComponent{..}
+
+ -- 3. Construct a preliminary ElaboratedConfiguredPackage,
+ -- and use this to compute the component ID. Fix up cc_id
+ -- correctly.
+ let elab1 =
+ elab0
+ { elabPkgOrComp = ElabComponent $ elab_comp
+ }
+ cid = case elabBuildStyle elab0 of
+ BuildInplaceOnly ->
+ mkComponentId $
+ prettyShow pkgid
+ ++ "-inplace"
+ ++ ( case Cabal.componentNameString cname of
Nothing -> ""
- Just s -> "-" ++ prettyShow s)
- BuildAndInstall ->
- hashedInstalledPackageId
- (packageHashInputs
- elaboratedSharedConfig
- elab1) -- knot tied
- cc = cc0 { cc_ann_id = fmap (const cid) (cc_ann_id cc0) }
- infoProgress $ dispConfiguredComponent cc
-
- -- 4. Perform mix-in linking
- let lookup_uid def_uid =
- case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of
+ Just s -> "-" ++ prettyShow s
+ )
+ BuildAndInstall ->
+ hashedInstalledPackageId
+ ( packageHashInputs
+ elaboratedSharedConfig
+ elab1 -- knot tied
+ )
+ cc = cc0{cc_ann_id = fmap (const cid) (cc_ann_id cc0)}
+ infoProgress $ dispConfiguredComponent cc
+
+ -- 4. Perform mix-in linking
+ let lookup_uid def_uid =
+ case Map.lookup (unDefUnitId def_uid) preexistingInstantiatedPkgs of
Just full -> full
Nothing -> error ("lookup_uid: " ++ prettyShow def_uid)
- lc <- toLinkedComponent verbosity lookup_uid (elabPkgSourceId elab0)
- (Map.union external_lc_map lc_map) cc
- infoProgress $ dispLinkedComponent lc
- -- NB: elab is setup to be the correct form for an
- -- indefinite library, or a definite library with no holes.
- -- We will modify it in 'instantiateInstallPlan' to handle
- -- instantiated packages.
-
- -- 5. Construct the final ElaboratedConfiguredPackage
- let
- elab2 = elab1 {
- elabModuleShape = lc_shape lc,
- elabUnitId = abstractUnitId (lc_uid lc),
- elabComponentId = lc_cid lc,
- elabLinkedInstantiatedWith = Map.fromList (lc_insts lc),
- elabPkgOrComp = ElabComponent $ elab_comp {
- compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc)),
- compOrderLibDependencies =
- ordNub (map (abstractUnitId . ci_id)
- (lc_includes lc ++ lc_sig_includes lc))
+ lc <-
+ toLinkedComponent
+ verbosity
+ lookup_uid
+ (elabPkgSourceId elab0)
+ (Map.union external_lc_map lc_map)
+ cc
+ infoProgress $ dispLinkedComponent lc
+ -- NB: elab is setup to be the correct form for an
+ -- indefinite library, or a definite library with no holes.
+ -- We will modify it in 'instantiateInstallPlan' to handle
+ -- instantiated packages.
+
+ -- 5. Construct the final ElaboratedConfiguredPackage
+ let
+ elab2 =
+ elab1
+ { elabModuleShape = lc_shape lc
+ , elabUnitId = abstractUnitId (lc_uid lc)
+ , elabComponentId = lc_cid lc
+ , elabLinkedInstantiatedWith = Map.fromList (lc_insts lc)
+ , elabPkgOrComp =
+ ElabComponent $
+ elab_comp
+ { compLinkedLibDependencies = ordNub (map ci_id (lc_includes lc))
+ , compOrderLibDependencies =
+ ordNub
+ ( map
+ (abstractUnitId . ci_id)
+ (lc_includes lc ++ lc_sig_includes lc)
+ )
+ }
+ }
+ elab =
+ elab2
+ { elabInstallDirs =
+ computeInstallDirs
+ storeDirLayout
+ defaultInstallDirs
+ elaboratedSharedConfig
+ elab2
}
- }
- elab = elab2 {
- elabInstallDirs = computeInstallDirs
- storeDirLayout
- defaultInstallDirs
- elaboratedSharedConfig
- elab2
- }
- -- 6. Construct the updated local maps
- let cc_map' = extendConfiguredComponentMap cc cc_map
- lc_map' = extendLinkedComponentMap lc lc_map
- exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map
+ -- 6. Construct the updated local maps
+ let cc_map' = extendConfiguredComponentMap cc cc_map
+ lc_map' = extendLinkedComponentMap lc lc_map
+ exe_map' = Map.insert cid (inplace_bin_dir elab) exe_map
- return ((cc_map', lc_map', exe_map'), elab)
- where
- compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"
- compOrderLibDependencies = error "buildComponent: compOrderLibDependencies"
-
- cname = Cabal.componentName comp
- compComponentName = Just cname
- compSolverName = CD.componentNameToComponent cname
-
- -- NB: compLinkedLibDependencies and
- -- compOrderLibDependencies are defined when we define
- -- 'elab'.
- external_lib_dep_sids = CD.select (== compSolverName) deps0
- external_exe_dep_sids = CD.select (== compSolverName) exe_deps0
-
- external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids
-
- -- Combine library and build-tool dependencies, for backwards
- -- compatibility (See issue #5412 and the documentation for
- -- InstallPlan.fromSolverInstallPlan), but prefer the versions
- -- specified as build-tools.
- external_exe_dep_pkgs =
+ return ((cc_map', lc_map', exe_map'), elab)
+ where
+ compLinkedLibDependencies = error "buildComponent: compLinkedLibDependencies"
+ compOrderLibDependencies = error "buildComponent: compOrderLibDependencies"
+
+ cname = Cabal.componentName comp
+ compComponentName = Just cname
+ compSolverName = CD.componentNameToComponent cname
+
+ -- NB: compLinkedLibDependencies and
+ -- compOrderLibDependencies are defined when we define
+ -- 'elab'.
+ external_lib_dep_sids = CD.select (== compSolverName) deps0
+ external_exe_dep_sids = CD.select (== compSolverName) exe_deps0
+
+ external_lib_dep_pkgs = concatMap mapDep external_lib_dep_sids
+
+ -- Combine library and build-tool dependencies, for backwards
+ -- compatibility (See issue #5412 and the documentation for
+ -- InstallPlan.fromSolverInstallPlan), but prefer the versions
+ -- specified as build-tools.
+ external_exe_dep_pkgs =
concatMap mapDep $
- ordNubBy (pkgName . packageId) $
- external_exe_dep_sids ++ external_lib_dep_sids
-
- external_exe_map = Map.fromList $
- [ (getComponentId pkg, paths)
- | pkg <- external_exe_dep_pkgs
- , let paths = planPackageExePaths pkg ]
- exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map
-
- external_lib_cc_map = Map.fromListWith Map.union
- $ map mkCCMapping external_lib_dep_pkgs
- external_exe_cc_map = Map.fromListWith Map.union
- $ map mkCCMapping external_exe_dep_pkgs
- external_lc_map =
- Map.fromList $ map mkShapeMapping $
- external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids
-
- compPkgConfigDependencies =
- [ (pn, fromMaybe (error $ "compPkgConfigDependencies: impossible! "
- ++ prettyShow pn ++ " from "
- ++ prettyShow (elabPkgSourceId elab0))
- (pkgConfigDbPkgVersion pkgConfigDB pn))
- | PkgconfigDependency pn _ <- PD.pkgconfigDepends
- (Cabal.componentBuildInfo comp) ]
-
- inplace_bin_dir elab =
+ ordNubBy (pkgName . packageId) $
+ external_exe_dep_sids ++ external_lib_dep_sids
+
+ external_exe_map =
+ Map.fromList $
+ [ (getComponentId pkg, paths)
+ | pkg <- external_exe_dep_pkgs
+ , let paths = planPackageExePaths pkg
+ ]
+ exe_map1 = Map.union external_exe_map $ fmap (\x -> [x]) exe_map
+
+ external_lib_cc_map =
+ Map.fromListWith Map.union $
+ map mkCCMapping external_lib_dep_pkgs
+ external_exe_cc_map =
+ Map.fromListWith Map.union $
+ map mkCCMapping external_exe_dep_pkgs
+ external_lc_map =
+ Map.fromList $
+ map mkShapeMapping $
+ external_lib_dep_pkgs ++ concatMap mapDep external_exe_dep_sids
+
+ compPkgConfigDependencies =
+ [ ( pn
+ , fromMaybe
+ ( error $
+ "compPkgConfigDependencies: impossible! "
+ ++ prettyShow pn
+ ++ " from "
+ ++ prettyShow (elabPkgSourceId elab0)
+ )
+ (pkgConfigDbPkgVersion pkgConfigDB pn)
+ )
+ | PkgconfigDependency pn _ <-
+ PD.pkgconfigDepends
+ (Cabal.componentBuildInfo comp)
+ ]
+
+ inplace_bin_dir elab =
binDirectoryFor
- distDirLayout
- elaboratedSharedConfig
- elab $
- case Cabal.componentNameString cname of
- Just n -> prettyShow n
- Nothing -> ""
-
-
- -- | Given a 'SolverId' referencing a dependency on a library, return
- -- the 'ElaboratedPlanPackage' corresponding to the library. This
- -- returns at most one result.
- elaborateLibSolverId :: (SolverId -> [ElaboratedPlanPackage])
- -> SolverId -> [ElaboratedPlanPackage]
- elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep
-
- -- | Given an 'ElaboratedPlanPackage', return the paths to where the
- -- executables that this package represents would be installed.
- -- The only case where multiple paths can be returned is the inplace
- -- monolithic package one, since there can be multiple exes and each one
- -- has its own directory.
- planPackageExePaths :: ElaboratedPlanPackage -> [FilePath]
- planPackageExePaths =
+ distDirLayout
+ elaboratedSharedConfig
+ elab
+ $ case Cabal.componentNameString cname of
+ Just n -> prettyShow n
+ Nothing -> ""
+
+ -- \| Given a 'SolverId' referencing a dependency on a library, return
+ -- the 'ElaboratedPlanPackage' corresponding to the library. This
+ -- returns at most one result.
+ elaborateLibSolverId
+ :: (SolverId -> [ElaboratedPlanPackage])
+ -> SolverId
+ -> [ElaboratedPlanPackage]
+ elaborateLibSolverId mapDep = filter (matchPlanPkg (== (CLibName LMainLibName))) . mapDep
+
+ -- \| Given an 'ElaboratedPlanPackage', return the paths to where the
+ -- executables that this package represents would be installed.
+ -- The only case where multiple paths can be returned is the inplace
+ -- monolithic package one, since there can be multiple exes and each one
+ -- has its own directory.
+ planPackageExePaths :: ElaboratedPlanPackage -> [FilePath]
+ planPackageExePaths =
-- Pre-existing executables are assumed to be in PATH
-- already. In fact, this should be impossible.
InstallPlan.foldPlanPackage (const []) $ \elab ->
- let
- executables :: [FilePath]
- executables =
- case elabPkgOrComp elab of
- -- Monolithic mode: all exes of the package
- ElabPackage _ -> unUnqualComponentName . PD.exeName
- <$> PD.executables (elabPkgDescription elab)
- -- Per-component mode: just the selected exe
- ElabComponent comp ->
- case fmap Cabal.componentNameString
- (compComponentName comp) of
- Just (Just n) -> [prettyShow n]
- _ -> [""]
- in
- binDirectoryFor
- distDirLayout
- elaboratedSharedConfig
- elab
- <$> executables
-
- elaborateSolverToPackage :: SolverPackage UnresolvedPkgLoc
- -> ComponentsGraph
- -> [ElaboratedConfiguredPackage]
- -> ElaboratedConfiguredPackage
- elaborateSolverToPackage
- pkg@(SolverPackage (SourcePackage pkgid _gpd _srcloc _descOverride)
- _flags _stanzas _deps0 _exe_deps0)
- compGraph comps =
- -- Knot tying: the final elab includes the
- -- pkgInstalledId, which is calculated by hashing many
- -- of the other fields of the elaboratedPackage.
- elab
- where
- elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg
- elab1 = elab0 {
- elabUnitId = newSimpleUnitId pkgInstalledId,
- elabComponentId = pkgInstalledId,
- elabLinkedInstantiatedWith = Map.empty,
- elabPkgOrComp = ElabPackage $ ElaboratedPackage {..},
- elabModuleShape = modShape
- }
- elab = elab1 {
- elabInstallDirs =
- computeInstallDirs storeDirLayout
- defaultInstallDirs
- elaboratedSharedConfig
- elab1
- }
-
- modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of
- Nothing -> emptyModuleShape
- Just e -> Ty.elabModuleShape e
-
- pkgInstalledId
- | shouldBuildInplaceOnly pkg
- = mkComponentId (prettyShow pkgid ++ "-inplace")
-
- | otherwise
- = assert (isJust elabPkgSourceHash) $
- hashedInstalledPackageId
- (packageHashInputs
- elaboratedSharedConfig
- elab) -- recursive use of elab
-
- -- Need to filter out internal dependencies, because they don't
- -- correspond to anything real anymore.
- isExt confid = confSrcId confid /= pkgid
- filterExt = filter isExt
- filterExt' = filter (isExt . fst)
-
- pkgLibDependencies
- = buildComponentDeps (filterExt . compLibDependencies)
- pkgExeDependencies
- = buildComponentDeps (filterExt . compExeDependencies)
- pkgExeDependencyPaths
- = buildComponentDeps (filterExt' . compExeDependencyPaths)
- -- TODO: Why is this flat?
- pkgPkgConfigDependencies
- = CD.flatDeps $ buildComponentDeps compPkgConfigDependencies
-
- pkgDependsOnSelfLib
- = CD.fromList [ (CD.componentNameToComponent cn, [()])
- | Graph.N _ cn _ <- fromMaybe [] mb_closure ]
- where
- mb_closure = Graph.revClosure compGraph [ k | k <- Graph.keys compGraph, is_lib k ]
- -- NB: the sublib case should not occur, because sub-libraries
- -- are not supported without per-component builds
- is_lib (CLibName _) = True
- is_lib _ = False
-
- buildComponentDeps f
- = CD.fromList [ (compSolverName comp, f comp)
- | ElaboratedConfiguredPackage{
- elabPkgOrComp = ElabComponent comp
- } <- comps
- ]
-
- -- NB: This is not the final setting of 'pkgStanzasEnabled'.
- -- See [Sticky enabled testsuites]; we may enable some extra
- -- stanzas opportunistically when it is cheap to do so.
- --
- -- However, we start off by enabling everything that was
- -- requested, so that we can maintain an invariant that
- -- pkgStanzasEnabled is a superset of elabStanzasRequested
- pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested
-
- elaborateSolverToCommon :: SolverPackage UnresolvedPkgLoc
- -> ElaboratedConfiguredPackage
- elaborateSolverToCommon
- pkg@(SolverPackage (SourcePackage pkgid gdesc srcloc descOverride)
- flags stanzas deps0 _exe_deps0) =
- elaboratedPackage
- where
- elaboratedPackage = ElaboratedConfiguredPackage {..}
-
- -- These get filled in later
- elabUnitId = error "elaborateSolverToCommon: elabUnitId"
- elabComponentId = error "elaborateSolverToCommon: elabComponentId"
- elabInstantiatedWith = Map.empty
- elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith"
- elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp"
- elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs"
- elabModuleShape = error "elaborateSolverToCommon: elabModuleShape"
-
- elabIsCanonical = True
- elabPkgSourceId = pkgid
- elabPkgDescription = case PD.finalizePD
- flags elabEnabledSpec (const True)
- platform (compilerInfo compiler)
- [] gdesc of
- Right (desc, _) -> desc
- Left _ -> error "Failed to finalizePD in elaborateSolverToCommon"
- elabFlagAssignment = flags
- elabFlagDefaults = PD.mkFlagAssignment
- [ (Cabal.flagName flag, Cabal.flagDefault flag)
- | flag <- PD.genPackageFlags gdesc ]
-
- elabEnabledSpec = enableStanzas stanzas
- elabStanzasAvailable = stanzas
-
- elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)
- elabStanzasRequested = optStanzaTabulate $ \o -> case o of
- -- NB: even if a package stanza is requested, if the package
- -- doesn't actually have any of that stanza we omit it from
- -- the request, to ensure that we don't decide that this
- -- package needs to be rebuilt. (It needs to be done here,
- -- because the ElaboratedConfiguredPackage is where we test
- -- whether or not there have been changes.)
- TestStanzas -> listToMaybe [ v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription ]
- BenchStanzas -> listToMaybe [ v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription ]
+ let
+ executables :: [FilePath]
+ executables =
+ case elabPkgOrComp elab of
+ -- Monolithic mode: all exes of the package
+ ElabPackage _ ->
+ unUnqualComponentName . PD.exeName
+ <$> PD.executables (elabPkgDescription elab)
+ -- Per-component mode: just the selected exe
+ ElabComponent comp ->
+ case fmap
+ Cabal.componentNameString
+ (compComponentName comp) of
+ Just (Just n) -> [prettyShow n]
+ _ -> [""]
+ in
+ binDirectoryFor
+ distDirLayout
+ elaboratedSharedConfig
+ elab
+ <$> executables
+
+ elaborateSolverToPackage
+ :: SolverPackage UnresolvedPkgLoc
+ -> ComponentsGraph
+ -> [ElaboratedConfiguredPackage]
+ -> ElaboratedConfiguredPackage
+ elaborateSolverToPackage
+ pkg@( SolverPackage
+ (SourcePackage pkgid _gpd _srcloc _descOverride)
+ _flags
+ _stanzas
+ _deps0
+ _exe_deps0
+ )
+ compGraph
+ comps =
+ -- Knot tying: the final elab includes the
+ -- pkgInstalledId, which is calculated by hashing many
+ -- of the other fields of the elaboratedPackage.
+ elab
where
- tests, benchmarks :: Maybe Bool
- tests = perPkgOptionMaybe pkgid packageConfigTests
- benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks
-
- -- This is a placeholder which will get updated by 'pruneInstallPlanPass1'
- -- and 'pruneInstallPlanPass2'. We can't populate it here
- -- because whether or not tests/benchmarks should be enabled
- -- is heuristically calculated based on whether or not the
- -- dependencies of the test suite have already been installed,
- -- but this function doesn't know what is installed (since
- -- we haven't improved the plan yet), so we do it in another pass.
- -- Check the comments of those functions for more details.
- elabConfigureTargets = []
- elabBuildTargets = []
- elabTestTargets = []
- elabBenchTargets = []
- elabReplTarget = Nothing
- elabHaddockTargets = []
-
- elabBuildHaddocks =
- perPkgOptionFlag pkgid False packageConfigDocumentation
-
- elabPkgSourceLocation = srcloc
- elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes
- elabLocalToProject = isLocalToProject pkg
- elabBuildStyle = if shouldBuildInplaceOnly pkg
- then BuildInplaceOnly else BuildAndInstall
- elabPackageDbs = projectConfigPackageDBs sharedPackageConfig
- elabBuildPackageDBStack = buildAndRegisterDbs
- elabRegisterPackageDBStack = buildAndRegisterDbs
-
- elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription
- elabSetupScriptCliVersion =
- packageSetupScriptSpecVersion
- elabSetupScriptStyle elabPkgDescription libDepGraph deps0
- elabSetupPackageDBStack = buildAndRegisterDbs
-
- elabInplaceBuildPackageDBStack = inplacePackageDbs
- elabInplaceRegisterPackageDBStack = inplacePackageDbs
- elabInplaceSetupPackageDBStack = inplacePackageDbs
-
- buildAndRegisterDbs
- | shouldBuildInplaceOnly pkg = inplacePackageDbs
- | otherwise = corePackageDbs
-
- elabPkgDescriptionOverride = descOverride
-
- elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib --TODO: [required feature]: also needs to be handled recursively
- elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary
- elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib
- elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe
- elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe
- elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib --TODO: [required feature] needs to default to enabled on windows still
-
- elabProfExe = perPkgOptionFlag pkgid False packageConfigProf
- elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary
-
- (elabProfExeDetail,
- elabProfLibDetail) = perPkgOptionLibExeFlag pkgid ProfDetailDefault
- packageConfigProfDetail
- packageConfigProfLibDetail
- elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage
-
- elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization
- elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs
- elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections
- elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs
- elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes
- elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo
- elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo
-
- -- Combine the configured compiler prog settings with the user-supplied
- -- config. For the compiler progs any user-supplied config was taken
- -- into account earlier when configuring the compiler so its ok that
- -- our configured settings for the compiler override the user-supplied
- -- config here.
- elabProgramPaths = Map.fromList
- [ (programId prog, programPath prog)
- | prog <- configuredPrograms compilerprogdb ]
- <> perPkgOptionMapLast pkgid packageConfigProgramPaths
- elabProgramArgs = Map.fromList
- [ (programId prog, args)
- | prog <- configuredPrograms compilerprogdb
- , let args = programOverrideArgs prog
- , not (null args)
- ]
- <> perPkgOptionMapMappend pkgid packageConfigProgramArgs
- elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra
- elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs
- elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs
- elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic
- elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs
- elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs
- elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix
- elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix
-
-
- elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle
- elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml
- elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation
- elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs
- elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage
- elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables
- elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites
- elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks
- elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal
- elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss
- elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource
- elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump
- elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss
- elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents
- elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex
- elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl
- elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib
- elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir
-
- elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog
- elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog
- elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails
- elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix
- elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper
- elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites
- elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions
-
- elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions
-
- perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a
- perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a
- perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a]
-
- perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)
- perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f)
- perPkgOptionList pkgid f = lookupPerPkgOption pkgid f
- perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f)
- perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f)
- perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f)
-
- perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)
- where
- exe = fromFlagOrDefault def bothflag
- lib = fromFlagOrDefault def (bothflag <> libflag)
-
- bothflag = lookupPerPkgOption pkgid fboth
- libflag = lookupPerPkgOption pkgid flib
+ elab0@ElaboratedConfiguredPackage{..} = elaborateSolverToCommon pkg
+ elab1 =
+ elab0
+ { elabUnitId = newSimpleUnitId pkgInstalledId
+ , elabComponentId = pkgInstalledId
+ , elabLinkedInstantiatedWith = Map.empty
+ , elabPkgOrComp = ElabPackage $ ElaboratedPackage{..}
+ , elabModuleShape = modShape
+ }
+ elab =
+ elab1
+ { elabInstallDirs =
+ computeInstallDirs
+ storeDirLayout
+ defaultInstallDirs
+ elaboratedSharedConfig
+ elab1
+ }
- lookupPerPkgOption :: (Package pkg, Monoid m)
- => pkg -> (PackageConfig -> m) -> m
- lookupPerPkgOption pkg f =
+ modShape = case find (matchElabPkg (== (CLibName LMainLibName))) comps of
+ Nothing -> emptyModuleShape
+ Just e -> Ty.elabModuleShape e
+
+ pkgInstalledId
+ | shouldBuildInplaceOnly pkg =
+ mkComponentId (prettyShow pkgid ++ "-inplace")
+ | otherwise =
+ assert (isJust elabPkgSourceHash) $
+ hashedInstalledPackageId
+ ( packageHashInputs
+ elaboratedSharedConfig
+ elab -- recursive use of elab
+ )
+
+ -- Need to filter out internal dependencies, because they don't
+ -- correspond to anything real anymore.
+ isExt confid = confSrcId confid /= pkgid
+ filterExt = filter isExt
+ filterExt' = filter (isExt . fst)
+
+ pkgLibDependencies =
+ buildComponentDeps (filterExt . compLibDependencies)
+ pkgExeDependencies =
+ buildComponentDeps (filterExt . compExeDependencies)
+ pkgExeDependencyPaths =
+ buildComponentDeps (filterExt' . compExeDependencyPaths)
+ -- TODO: Why is this flat?
+ pkgPkgConfigDependencies =
+ CD.flatDeps $ buildComponentDeps compPkgConfigDependencies
+
+ pkgDependsOnSelfLib =
+ CD.fromList
+ [ (CD.componentNameToComponent cn, [()])
+ | Graph.N _ cn _ <- fromMaybe [] mb_closure
+ ]
+ where
+ mb_closure = Graph.revClosure compGraph [k | k <- Graph.keys compGraph, is_lib k]
+ -- NB: the sublib case should not occur, because sub-libraries
+ -- are not supported without per-component builds
+ is_lib (CLibName _) = True
+ is_lib _ = False
+
+ buildComponentDeps f =
+ CD.fromList
+ [ (compSolverName comp, f comp)
+ | ElaboratedConfiguredPackage
+ { elabPkgOrComp = ElabComponent comp
+ } <-
+ comps
+ ]
+
+ -- NB: This is not the final setting of 'pkgStanzasEnabled'.
+ -- See [Sticky enabled testsuites]; we may enable some extra
+ -- stanzas opportunistically when it is cheap to do so.
+ --
+ -- However, we start off by enabling everything that was
+ -- requested, so that we can maintain an invariant that
+ -- pkgStanzasEnabled is a superset of elabStanzasRequested
+ pkgStanzasEnabled = optStanzaKeysFilteredByValue (fromMaybe False) elabStanzasRequested
+
+ elaborateSolverToCommon
+ :: SolverPackage UnresolvedPkgLoc
+ -> ElaboratedConfiguredPackage
+ elaborateSolverToCommon
+ pkg@( SolverPackage
+ (SourcePackage pkgid gdesc srcloc descOverride)
+ flags
+ stanzas
+ deps0
+ _exe_deps0
+ ) =
+ elaboratedPackage
+ where
+ elaboratedPackage = ElaboratedConfiguredPackage{..}
+
+ -- These get filled in later
+ elabUnitId = error "elaborateSolverToCommon: elabUnitId"
+ elabComponentId = error "elaborateSolverToCommon: elabComponentId"
+ elabInstantiatedWith = Map.empty
+ elabLinkedInstantiatedWith = error "elaborateSolverToCommon: elabLinkedInstantiatedWith"
+ elabPkgOrComp = error "elaborateSolverToCommon: elabPkgOrComp"
+ elabInstallDirs = error "elaborateSolverToCommon: elabInstallDirs"
+ elabModuleShape = error "elaborateSolverToCommon: elabModuleShape"
+
+ elabIsCanonical = True
+ elabPkgSourceId = pkgid
+ elabPkgDescription = case PD.finalizePD
+ flags
+ elabEnabledSpec
+ (const True)
+ platform
+ (compilerInfo compiler)
+ []
+ gdesc of
+ Right (desc, _) -> desc
+ Left _ -> error "Failed to finalizePD in elaborateSolverToCommon"
+ elabFlagAssignment = flags
+ elabFlagDefaults =
+ PD.mkFlagAssignment
+ [ (Cabal.flagName flag, Cabal.flagDefault flag)
+ | flag <- PD.genPackageFlags gdesc
+ ]
+
+ elabEnabledSpec = enableStanzas stanzas
+ elabStanzasAvailable = stanzas
+
+ elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)
+ elabStanzasRequested = optStanzaTabulate $ \o -> case o of
+ -- NB: even if a package stanza is requested, if the package
+ -- doesn't actually have any of that stanza we omit it from
+ -- the request, to ensure that we don't decide that this
+ -- package needs to be rebuilt. (It needs to be done here,
+ -- because the ElaboratedConfiguredPackage is where we test
+ -- whether or not there have been changes.)
+ TestStanzas -> listToMaybe [v | v <- maybeToList tests, _ <- PD.testSuites elabPkgDescription]
+ BenchStanzas -> listToMaybe [v | v <- maybeToList benchmarks, _ <- PD.benchmarks elabPkgDescription]
+ where
+ tests, benchmarks :: Maybe Bool
+ tests = perPkgOptionMaybe pkgid packageConfigTests
+ benchmarks = perPkgOptionMaybe pkgid packageConfigBenchmarks
+
+ -- This is a placeholder which will get updated by 'pruneInstallPlanPass1'
+ -- and 'pruneInstallPlanPass2'. We can't populate it here
+ -- because whether or not tests/benchmarks should be enabled
+ -- is heuristically calculated based on whether or not the
+ -- dependencies of the test suite have already been installed,
+ -- but this function doesn't know what is installed (since
+ -- we haven't improved the plan yet), so we do it in another pass.
+ -- Check the comments of those functions for more details.
+ elabConfigureTargets = []
+ elabBuildTargets = []
+ elabTestTargets = []
+ elabBenchTargets = []
+ elabReplTarget = Nothing
+ elabHaddockTargets = []
+
+ elabBuildHaddocks =
+ perPkgOptionFlag pkgid False packageConfigDocumentation
+
+ elabPkgSourceLocation = srcloc
+ elabPkgSourceHash = Map.lookup pkgid sourcePackageHashes
+ elabLocalToProject = isLocalToProject pkg
+ elabBuildStyle =
+ if shouldBuildInplaceOnly pkg
+ then BuildInplaceOnly
+ else BuildAndInstall
+ elabPackageDbs = projectConfigPackageDBs sharedPackageConfig
+ elabBuildPackageDBStack = buildAndRegisterDbs
+ elabRegisterPackageDBStack = buildAndRegisterDbs
+
+ elabSetupScriptStyle = packageSetupScriptStyle elabPkgDescription
+ elabSetupScriptCliVersion =
+ packageSetupScriptSpecVersion
+ elabSetupScriptStyle
+ elabPkgDescription
+ libDepGraph
+ deps0
+ elabSetupPackageDBStack = buildAndRegisterDbs
+
+ elabInplaceBuildPackageDBStack = inplacePackageDbs
+ elabInplaceRegisterPackageDBStack = inplacePackageDbs
+ elabInplaceSetupPackageDBStack = inplacePackageDbs
+
+ buildAndRegisterDbs
+ | shouldBuildInplaceOnly pkg = inplacePackageDbs
+ | otherwise = corePackageDbs
+
+ elabPkgDescriptionOverride = descOverride
+
+ elabVanillaLib = perPkgOptionFlag pkgid True packageConfigVanillaLib -- TODO: [required feature]: also needs to be handled recursively
+ elabSharedLib = pkgid `Set.member` pkgsUseSharedLibrary
+ elabStaticLib = perPkgOptionFlag pkgid False packageConfigStaticLib
+ elabDynExe = perPkgOptionFlag pkgid False packageConfigDynExe
+ elabFullyStaticExe = perPkgOptionFlag pkgid False packageConfigFullyStaticExe
+ elabGHCiLib = perPkgOptionFlag pkgid False packageConfigGHCiLib -- TODO: [required feature] needs to default to enabled on windows still
+ elabProfExe = perPkgOptionFlag pkgid False packageConfigProf
+ elabProfLib = pkgid `Set.member` pkgsUseProfilingLibrary
+
+ ( elabProfExeDetail
+ , elabProfLibDetail
+ ) =
+ perPkgOptionLibExeFlag
+ pkgid
+ ProfDetailDefault
+ packageConfigProfDetail
+ packageConfigProfLibDetail
+ elabCoverage = perPkgOptionFlag pkgid False packageConfigCoverage
+
+ elabOptimization = perPkgOptionFlag pkgid NormalOptimisation packageConfigOptimization
+ elabSplitObjs = perPkgOptionFlag pkgid False packageConfigSplitObjs
+ elabSplitSections = perPkgOptionFlag pkgid False packageConfigSplitSections
+ elabStripLibs = perPkgOptionFlag pkgid False packageConfigStripLibs
+ elabStripExes = perPkgOptionFlag pkgid False packageConfigStripExes
+ elabDebugInfo = perPkgOptionFlag pkgid NoDebugInfo packageConfigDebugInfo
+ elabDumpBuildInfo = perPkgOptionFlag pkgid NoDumpBuildInfo packageConfigDumpBuildInfo
+
+ -- Combine the configured compiler prog settings with the user-supplied
+ -- config. For the compiler progs any user-supplied config was taken
+ -- into account earlier when configuring the compiler so its ok that
+ -- our configured settings for the compiler override the user-supplied
+ -- config here.
+ elabProgramPaths =
+ Map.fromList
+ [ (programId prog, programPath prog)
+ | prog <- configuredPrograms compilerprogdb
+ ]
+ <> perPkgOptionMapLast pkgid packageConfigProgramPaths
+ elabProgramArgs =
+ Map.fromList
+ [ (programId prog, args)
+ | prog <- configuredPrograms compilerprogdb
+ , let args = programOverrideArgs prog
+ , not (null args)
+ ]
+ <> perPkgOptionMapMappend pkgid packageConfigProgramArgs
+ elabProgramPathExtra = perPkgOptionNubList pkgid packageConfigProgramPathExtra
+ elabConfigureScriptArgs = perPkgOptionList pkgid packageConfigConfigureArgs
+ elabExtraLibDirs = perPkgOptionList pkgid packageConfigExtraLibDirs
+ elabExtraLibDirsStatic = perPkgOptionList pkgid packageConfigExtraLibDirsStatic
+ elabExtraFrameworkDirs = perPkgOptionList pkgid packageConfigExtraFrameworkDirs
+ elabExtraIncludeDirs = perPkgOptionList pkgid packageConfigExtraIncludeDirs
+ elabProgPrefix = perPkgOptionMaybe pkgid packageConfigProgPrefix
+ elabProgSuffix = perPkgOptionMaybe pkgid packageConfigProgSuffix
+
+ elabHaddockHoogle = perPkgOptionFlag pkgid False packageConfigHaddockHoogle
+ elabHaddockHtml = perPkgOptionFlag pkgid False packageConfigHaddockHtml
+ elabHaddockHtmlLocation = perPkgOptionMaybe pkgid packageConfigHaddockHtmlLocation
+ elabHaddockForeignLibs = perPkgOptionFlag pkgid False packageConfigHaddockForeignLibs
+ elabHaddockForHackage = perPkgOptionFlag pkgid Cabal.ForDevelopment packageConfigHaddockForHackage
+ elabHaddockExecutables = perPkgOptionFlag pkgid False packageConfigHaddockExecutables
+ elabHaddockTestSuites = perPkgOptionFlag pkgid False packageConfigHaddockTestSuites
+ elabHaddockBenchmarks = perPkgOptionFlag pkgid False packageConfigHaddockBenchmarks
+ elabHaddockInternal = perPkgOptionFlag pkgid False packageConfigHaddockInternal
+ elabHaddockCss = perPkgOptionMaybe pkgid packageConfigHaddockCss
+ elabHaddockLinkedSource = perPkgOptionFlag pkgid False packageConfigHaddockLinkedSource
+ elabHaddockQuickJump = perPkgOptionFlag pkgid False packageConfigHaddockQuickJump
+ elabHaddockHscolourCss = perPkgOptionMaybe pkgid packageConfigHaddockHscolourCss
+ elabHaddockContents = perPkgOptionMaybe pkgid packageConfigHaddockContents
+ elabHaddockIndex = perPkgOptionMaybe pkgid packageConfigHaddockIndex
+ elabHaddockBaseUrl = perPkgOptionMaybe pkgid packageConfigHaddockBaseUrl
+ elabHaddockLib = perPkgOptionMaybe pkgid packageConfigHaddockLib
+ elabHaddockOutputDir = perPkgOptionMaybe pkgid packageConfigHaddockOutputDir
+
+ elabTestMachineLog = perPkgOptionMaybe pkgid packageConfigTestMachineLog
+ elabTestHumanLog = perPkgOptionMaybe pkgid packageConfigTestHumanLog
+ elabTestShowDetails = perPkgOptionMaybe pkgid packageConfigTestShowDetails
+ elabTestKeepTix = perPkgOptionFlag pkgid False packageConfigTestKeepTix
+ elabTestWrapper = perPkgOptionMaybe pkgid packageConfigTestWrapper
+ elabTestFailWhenNoTestSuites = perPkgOptionFlag pkgid False packageConfigTestFailWhenNoTestSuites
+ elabTestTestOptions = perPkgOptionList pkgid packageConfigTestTestOptions
+
+ elabBenchmarkOptions = perPkgOptionList pkgid packageConfigBenchmarkOptions
+
+ perPkgOptionFlag :: PackageId -> a -> (PackageConfig -> Flag a) -> a
+ perPkgOptionMaybe :: PackageId -> (PackageConfig -> Flag a) -> Maybe a
+ perPkgOptionList :: PackageId -> (PackageConfig -> [a]) -> [a]
+
+ perPkgOptionFlag pkgid def f = fromFlagOrDefault def (lookupPerPkgOption pkgid f)
+ perPkgOptionMaybe pkgid f = flagToMaybe (lookupPerPkgOption pkgid f)
+ perPkgOptionList pkgid f = lookupPerPkgOption pkgid f
+ perPkgOptionNubList pkgid f = fromNubList (lookupPerPkgOption pkgid f)
+ perPkgOptionMapLast pkgid f = getMapLast (lookupPerPkgOption pkgid f)
+ perPkgOptionMapMappend pkgid f = getMapMappend (lookupPerPkgOption pkgid f)
+
+ perPkgOptionLibExeFlag pkgid def fboth flib = (exe, lib)
+ where
+ exe = fromFlagOrDefault def bothflag
+ lib = fromFlagOrDefault def (bothflag <> libflag)
+
+ bothflag = lookupPerPkgOption pkgid fboth
+ libflag = lookupPerPkgOption pkgid flib
+
+ lookupPerPkgOption
+ :: (Package pkg, Monoid m)
+ => pkg
+ -> (PackageConfig -> m)
+ -> m
+ lookupPerPkgOption pkg f =
-- This is where we merge the options from the project config that
-- apply to all packages, all project local packages, and to specific
-- named packages
global `mappend` local `mappend` perpkg
- where
- global = f allPackagesConfig
- local | isLocalToProject pkg
- = f localPackagesConfig
- | otherwise
- = mempty
- perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)
-
- inplacePackageDbs = corePackageDbs
- ++ [ distPackageDB (compilerId compiler) ]
-
- corePackageDbs = applyPackageDbFlags (storePackageDBStack (compilerId compiler))
- (projectConfigPackageDBs sharedPackageConfig)
-
- -- For this local build policy, every package that lives in a local source
- -- dir (as opposed to a tarball), or depends on such a package, will be
- -- built inplace into a shared dist dir. Tarball packages that depend on
- -- source dir packages will also get unpacked locally.
- shouldBuildInplaceOnly :: SolverPackage loc -> Bool
- shouldBuildInplaceOnly pkg = Set.member (packageId pkg)
- pkgsToBuildInplaceOnly
-
- pkgsToBuildInplaceOnly :: Set PackageId
- pkgsToBuildInplaceOnly =
- Set.fromList
- $ map packageId
- $ SolverInstallPlan.reverseDependencyClosure
- solverPlan
- (map PlannedId (Set.toList pkgsLocalToProject))
-
- isLocalToProject :: Package pkg => pkg -> Bool
- isLocalToProject pkg = Set.member (packageId pkg)
- pkgsLocalToProject
-
- pkgsLocalToProject :: Set PackageId
- pkgsLocalToProject =
+ where
+ global = f allPackagesConfig
+ local
+ | isLocalToProject pkg =
+ f localPackagesConfig
+ | otherwise =
+ mempty
+ perpkg = maybe mempty f (Map.lookup (packageName pkg) perPackageConfig)
+
+ inplacePackageDbs =
+ corePackageDbs
+ ++ [distPackageDB (compilerId compiler)]
+
+ corePackageDbs =
+ applyPackageDbFlags
+ (storePackageDBStack (compilerId compiler))
+ (projectConfigPackageDBs sharedPackageConfig)
+
+ -- For this local build policy, every package that lives in a local source
+ -- dir (as opposed to a tarball), or depends on such a package, will be
+ -- built inplace into a shared dist dir. Tarball packages that depend on
+ -- source dir packages will also get unpacked locally.
+ shouldBuildInplaceOnly :: SolverPackage loc -> Bool
+ shouldBuildInplaceOnly pkg =
+ Set.member
+ (packageId pkg)
+ pkgsToBuildInplaceOnly
+
+ pkgsToBuildInplaceOnly :: Set PackageId
+ pkgsToBuildInplaceOnly =
+ Set.fromList $
+ map packageId $
+ SolverInstallPlan.reverseDependencyClosure
+ solverPlan
+ (map PlannedId (Set.toList pkgsLocalToProject))
+
+ isLocalToProject :: Package pkg => pkg -> Bool
+ isLocalToProject pkg =
+ Set.member
+ (packageId pkg)
+ pkgsLocalToProject
+
+ pkgsLocalToProject :: Set PackageId
+ pkgsLocalToProject =
Set.fromList (catMaybes (map shouldBeLocal localPackages))
- --TODO: localPackages is a misnomer, it's all project packages
- -- here is where we decide which ones will be local!
+ -- TODO: localPackages is a misnomer, it's all project packages
+ -- here is where we decide which ones will be local!
- pkgsUseSharedLibrary :: Set PackageId
- pkgsUseSharedLibrary =
+ pkgsUseSharedLibrary :: Set PackageId
+ pkgsUseSharedLibrary =
packagesWithLibDepsDownwardClosedProperty needsSharedLib
- where
- needsSharedLib pkg =
- fromMaybe compilerShouldUseSharedLibByDefault
- (liftM2 (||) pkgSharedLib pkgDynExe)
- where
- pkgid = packageId pkg
- pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib
- pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe
-
- --TODO: [code cleanup] move this into the Cabal lib. It's currently open
- -- coded in Distribution.Simple.Configure, but should be made a proper
- -- function of the Compiler or CompilerInfo.
- compilerShouldUseSharedLibByDefault =
- case compilerFlavor compiler of
- GHC -> GHC.isDynamic compiler
- GHCJS -> GHCJS.isDynamic compiler
- _ -> False
-
- pkgsUseProfilingLibrary :: Set PackageId
- pkgsUseProfilingLibrary =
+ where
+ needsSharedLib pkg =
+ fromMaybe
+ compilerShouldUseSharedLibByDefault
+ (liftM2 (||) pkgSharedLib pkgDynExe)
+ where
+ pkgid = packageId pkg
+ pkgSharedLib = perPkgOptionMaybe pkgid packageConfigSharedLib
+ pkgDynExe = perPkgOptionMaybe pkgid packageConfigDynExe
+
+ -- TODO: [code cleanup] move this into the Cabal lib. It's currently open
+ -- coded in Distribution.Simple.Configure, but should be made a proper
+ -- function of the Compiler or CompilerInfo.
+ compilerShouldUseSharedLibByDefault =
+ case compilerFlavor compiler of
+ GHC -> GHC.isDynamic compiler
+ GHCJS -> GHCJS.isDynamic compiler
+ _ -> False
+
+ pkgsUseProfilingLibrary :: Set PackageId
+ pkgsUseProfilingLibrary =
packagesWithLibDepsDownwardClosedProperty needsProfilingLib
- where
- needsProfilingLib pkg =
+ where
+ needsProfilingLib pkg =
fromFlagOrDefault False (profBothFlag <> profLibFlag)
- where
- pkgid = packageId pkg
- profBothFlag = lookupPerPkgOption pkgid packageConfigProf
- profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib
- --TODO: [code cleanup] unused: the old deprecated packageConfigProfExe
-
- libDepGraph = Graph.fromDistinctList $
- map NonSetupLibDepSolverPlanPackage
- (SolverInstallPlan.toList solverPlan)
-
- packagesWithLibDepsDownwardClosedProperty property =
+ where
+ pkgid = packageId pkg
+ profBothFlag = lookupPerPkgOption pkgid packageConfigProf
+ profLibFlag = lookupPerPkgOption pkgid packageConfigProfLib
+ -- TODO: [code cleanup] unused: the old deprecated packageConfigProfExe
+
+ libDepGraph =
+ Graph.fromDistinctList $
+ map
+ NonSetupLibDepSolverPlanPackage
+ (SolverInstallPlan.toList solverPlan)
+
+ packagesWithLibDepsDownwardClosedProperty property =
Set.fromList
- . map packageId
- . fromMaybe []
- $ Graph.closure
- libDepGraph
- [ Graph.nodeKey pkg
- | pkg <- SolverInstallPlan.toList solverPlan
- , property pkg ] -- just the packages that satisfy the property
- --TODO: [nice to have] this does not check the config consistency,
- -- e.g. a package explicitly turning off profiling, but something
- -- depending on it that needs profiling. This really needs a separate
- -- package config validation/resolution pass.
-
- --TODO: [nice to have] config consistency checking:
- -- + profiling libs & exes, exe needs lib, recursive
- -- + shared libs & exes, exe needs lib, recursive
- -- + vanilla libs & exes, exe needs lib, recursive
- -- + ghci or shared lib needed by TH, recursive, ghc version dependent
+ . map packageId
+ . fromMaybe []
+ $ Graph.closure
+ libDepGraph
+ [ Graph.nodeKey pkg
+ | pkg <- SolverInstallPlan.toList solverPlan
+ , property pkg -- just the packages that satisfy the property
+ -- TODO: [nice to have] this does not check the config consistency,
+ -- e.g. a package explicitly turning off profiling, but something
+ -- depending on it that needs profiling. This really needs a separate
+ -- package config validation/resolution pass.
+ ]
+
+-- TODO: [nice to have] config consistency checking:
+-- + profiling libs & exes, exe needs lib, recursive
+-- + shared libs & exes, exe needs lib, recursive
+-- + vanilla libs & exes, exe needs lib, recursive
+-- + ghci or shared lib needed by TH, recursive, ghc version dependent
-- TODO: Drop matchPlanPkg/matchElabPkg in favor of mkCCMapping
shouldBeLocal :: PackageSpecifier (SourcePackage (PackageLocation loc)) -> Maybe PackageId
-shouldBeLocal NamedPackage{} = Nothing
+shouldBeLocal NamedPackage{} = Nothing
shouldBeLocal (SpecificSourcePackage pkg) = case srcpkgSource pkg of
- LocalUnpackedPackage _ -> Just (packageId pkg)
- _ -> Nothing
+ LocalUnpackedPackage _ -> Just (packageId pkg)
+ _ -> Nothing
-- | Given a 'ElaboratedPlanPackage', report if it matches a 'ComponentName'.
matchPlanPkg :: (ComponentName -> Bool) -> ElaboratedPlanPackage -> Bool
@@ -2140,69 +2429,84 @@ ipiComponentName = CLibName . IPI.sourceLibName
-- 'ComponentName'.
matchElabPkg :: (ComponentName -> Bool) -> ElaboratedConfiguredPackage -> Bool
matchElabPkg p elab =
- case elabPkgOrComp elab of
- ElabComponent comp -> maybe False p (compComponentName comp)
- ElabPackage _ ->
- -- So, what should we do here? One possibility is to
- -- unconditionally return 'True', because whatever it is
- -- that we're looking for, it better be in this package.
- -- But this is a bit dodgy if the package doesn't actually
- -- have, e.g., a library. Fortunately, it's not possible
- -- for the build of the library/executables to be toggled
- -- by 'pkgStanzasEnabled', so the only thing we have to
- -- test is if the component in question is *buildable.*
- any (p . componentName)
- (Cabal.pkgBuildableComponents (elabPkgDescription elab))
+ case elabPkgOrComp elab of
+ ElabComponent comp -> maybe False p (compComponentName comp)
+ ElabPackage _ ->
+ -- So, what should we do here? One possibility is to
+ -- unconditionally return 'True', because whatever it is
+ -- that we're looking for, it better be in this package.
+ -- But this is a bit dodgy if the package doesn't actually
+ -- have, e.g., a library. Fortunately, it's not possible
+ -- for the build of the library/executables to be toggled
+ -- by 'pkgStanzasEnabled', so the only thing we have to
+ -- test is if the component in question is *buildable.*
+ any
+ (p . componentName)
+ (Cabal.pkgBuildableComponents (elabPkgDescription elab))
-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'PackageName'
-- and 'ComponentName' to the 'ComponentId' that should be used
-- in this case.
-mkCCMapping :: ElaboratedPlanPackage
- -> (PackageName, Map ComponentName (AnnotatedId ComponentId))
+mkCCMapping
+ :: ElaboratedPlanPackage
+ -> (PackageName, Map ComponentName (AnnotatedId ComponentId))
mkCCMapping =
- InstallPlan.foldPlanPackage
- (\ipkg -> (packageName ipkg,
- Map.singleton (ipiComponentName ipkg)
- -- TODO: libify
- (AnnotatedId {
- ann_id = IPI.installedComponentId ipkg,
- ann_pid = packageId ipkg,
- ann_cname = IPI.sourceComponentName ipkg
- })))
- $ \elab ->
- let mk_aid cn = AnnotatedId {
- ann_id = elabComponentId elab,
- ann_pid = packageId elab,
- ann_cname = cn
- }
- in (packageName elab,
- case elabPkgOrComp elab of
- ElabComponent comp ->
- case compComponentName comp of
- Nothing -> Map.empty
- Just n -> Map.singleton n (mk_aid n)
- ElabPackage _ ->
- Map.fromList $
- map (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn))
- (Cabal.pkgBuildableComponents (elabPkgDescription elab)))
+ InstallPlan.foldPlanPackage
+ ( \ipkg ->
+ ( packageName ipkg
+ , Map.singleton
+ (ipiComponentName ipkg)
+ -- TODO: libify
+ ( AnnotatedId
+ { ann_id = IPI.installedComponentId ipkg
+ , ann_pid = packageId ipkg
+ , ann_cname = IPI.sourceComponentName ipkg
+ }
+ )
+ )
+ )
+ $ \elab ->
+ let mk_aid cn =
+ AnnotatedId
+ { ann_id = elabComponentId elab
+ , ann_pid = packageId elab
+ , ann_cname = cn
+ }
+ in ( packageName elab
+ , case elabPkgOrComp elab of
+ ElabComponent comp ->
+ case compComponentName comp of
+ Nothing -> Map.empty
+ Just n -> Map.singleton n (mk_aid n)
+ ElabPackage _ ->
+ Map.fromList $
+ map
+ (\comp -> let cn = Cabal.componentName comp in (cn, mk_aid cn))
+ (Cabal.pkgBuildableComponents (elabPkgDescription elab))
+ )
-- | Given an 'ElaboratedPlanPackage', generate the mapping from 'ComponentId'
-- to the shape of this package, as per mix-in linking.
-mkShapeMapping :: ElaboratedPlanPackage
- -> (ComponentId, (OpenUnitId, ModuleShape))
+mkShapeMapping
+ :: ElaboratedPlanPackage
+ -> (ComponentId, (OpenUnitId, ModuleShape))
mkShapeMapping dpkg =
- (getComponentId dpkg, (indef_uid, shape))
+ (getComponentId dpkg, (indef_uid, shape))
where
(dcid, shape) =
- InstallPlan.foldPlanPackage
- -- Uses Monad (->)
- (liftM2 (,) IPI.installedComponentId shapeInstalledPackage)
- (liftM2 (,) elabComponentId elabModuleShape)
- dpkg
+ InstallPlan.foldPlanPackage
+ -- Uses Monad (->)
+ (liftM2 (,) IPI.installedComponentId shapeInstalledPackage)
+ (liftM2 (,) elabComponentId elabModuleShape)
+ dpkg
indef_uid =
- IndefFullUnitId dcid
- (Map.fromList [ (req, OpenModuleVar req)
- | req <- Set.toList (modShapeRequires shape)])
+ IndefFullUnitId
+ dcid
+ ( Map.fromList
+ [ (req, OpenModuleVar req)
+ | req <- Set.toList (modShapeRequires shape)
+ ]
+ )
-- | Get the bin\/ directories that a package's executables should reside in.
--
@@ -2220,47 +2524,50 @@ binDirectories layout config package = case elabBuildStyle package of
-- to put any executables in it, that will just clog up the PATH
_ | noExecutables -> []
BuildAndInstall -> [installedBinDirectory package]
- BuildInplaceOnly -> map (root</>) $ case elabPkgOrComp package of
+ BuildInplaceOnly -> map (root </>) $ case elabPkgOrComp package of
ElabComponent comp -> case compSolverName comp of
CD.ComponentExe n -> [prettyShow n]
_ -> []
- ElabPackage _ -> map (prettyShow . PD.exeName)
- . PD.executables
- . elabPkgDescription
- $ package
+ ElabPackage _ ->
+ map (prettyShow . PD.exeName)
+ . PD.executables
+ . elabPkgDescription
+ $ package
where
- noExecutables = null . PD.executables . elabPkgDescription $ package
- root = distBuildDirectory layout (elabDistDirParams config package)
- </> "build"
+ noExecutables = null . PD.executables . elabPkgDescription $ package
+ root =
+ distBuildDirectory layout (elabDistDirParams config package)
+ </> "build"
-- | A newtype for 'SolverInstallPlan.SolverPlanPackage' for which the
-- dependency graph considers only dependencies on libraries which are
-- NOT from setup dependencies. Used to compute the set
-- of packages needed for profiling and dynamic libraries.
-newtype NonSetupLibDepSolverPlanPackage
- = NonSetupLibDepSolverPlanPackage
- { unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage }
+newtype NonSetupLibDepSolverPlanPackage = NonSetupLibDepSolverPlanPackage
+ {unNonSetupLibDepSolverPlanPackage :: SolverInstallPlan.SolverPlanPackage}
instance Package NonSetupLibDepSolverPlanPackage where
- packageId = packageId . unNonSetupLibDepSolverPlanPackage
+ packageId = packageId . unNonSetupLibDepSolverPlanPackage
instance IsNode NonSetupLibDepSolverPlanPackage where
- type Key NonSetupLibDepSolverPlanPackage = SolverId
- nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage
- nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg)
- = ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg)
+ type Key NonSetupLibDepSolverPlanPackage = SolverId
+ nodeKey = nodeKey . unNonSetupLibDepSolverPlanPackage
+ nodeNeighbors (NonSetupLibDepSolverPlanPackage spkg) =
+ ordNub $ CD.nonSetupDeps (resolverPackageLibDeps spkg)
type InstS = Map UnitId ElaboratedPlanPackage
type InstM a = State InstS a
-getComponentId :: ElaboratedPlanPackage
- -> ComponentId
+getComponentId
+ :: ElaboratedPlanPackage
+ -> ComponentId
getComponentId (InstallPlan.PreExisting dipkg) = IPI.installedComponentId dipkg
getComponentId (InstallPlan.Configured elab) = elabComponentId elab
getComponentId (InstallPlan.Installed elab) = elabComponentId elab
-extractElabBuildStyle :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage
- -> BuildStyle
+extractElabBuildStyle
+ :: InstallPlan.GenericPlanPackage ipkg ElaboratedConfiguredPackage
+ -> BuildStyle
extractElabBuildStyle (InstallPlan.Configured elab) = elabBuildStyle elab
extractElabBuildStyle _ = BuildAndInstall
@@ -2310,25 +2617,30 @@ extractElabBuildStyle _ = BuildAndInstall
--
instantiateInstallPlan :: StoreDirLayout -> InstallDirs.InstallDirTemplates -> ElaboratedSharedConfig -> ElaboratedInstallPlan -> ElaboratedInstallPlan
instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
- InstallPlan.new (IndependentGoals False)
- (Graph.fromDistinctList (Map.elems ready_map))
+ InstallPlan.new
+ (IndependentGoals False)
+ (Graph.fromDistinctList (Map.elems ready_map))
where
pkgs = InstallPlan.toList plan
- cmap = Map.fromList [ (getComponentId pkg, pkg) | pkg <- pkgs ]
+ cmap = Map.fromList [(getComponentId pkg, pkg) | pkg <- pkgs]
- instantiateUnitId :: ComponentId -> Map ModuleName (Module, BuildStyle)
- -> InstM (DefUnitId, BuildStyle)
+ instantiateUnitId
+ :: ComponentId
+ -> Map ModuleName (Module, BuildStyle)
+ -> InstM (DefUnitId, BuildStyle)
instantiateUnitId cid insts = state $ \s ->
- case Map.lookup uid s of
- Nothing ->
- -- Knot tied
- -- TODO: I don't think the knot tying actually does
- -- anything useful
- let (r, s') = runState (instantiateComponent uid cid insts)
- (Map.insert uid r s)
- in ((def_uid, extractElabBuildStyle r), Map.insert uid r s')
- Just r -> ((def_uid, extractElabBuildStyle r), s)
+ case Map.lookup uid s of
+ Nothing ->
+ -- Knot tied
+ -- TODO: I don't think the knot tying actually does
+ -- anything useful
+ let (r, s') =
+ runState
+ (instantiateComponent uid cid insts)
+ (Map.insert uid r s)
+ in ((def_uid, extractElabBuildStyle r), Map.insert uid r s')
+ Just r -> ((def_uid, extractElabBuildStyle r), s)
where
def_uid = mkDefUnitId cid (fmap fst insts)
uid = unDefUnitId def_uid
@@ -2336,133 +2648,156 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
-- No need to InplaceT; the inplace-ness is properly computed for
-- the ElaboratedPlanPackage, so that will implicitly pass it on
instantiateComponent
- :: UnitId -> ComponentId -> Map ModuleName (Module, BuildStyle)
- -> InstM ElaboratedPlanPackage
+ :: UnitId
+ -> ComponentId
+ -> Map ModuleName (Module, BuildStyle)
+ -> InstM ElaboratedPlanPackage
instantiateComponent uid cid insts
- | Just planpkg <- Map.lookup cid cmap
- = case planpkg of
- InstallPlan.Configured (elab0@ElaboratedConfiguredPackage
- { elabPkgOrComp = ElabComponent comp }) -> do
- deps <-
- traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)
- let build_style = fold (fmap snd insts)
- let getDep (Module dep_uid _) = [dep_uid]
- elab1 = fixupBuildStyle build_style $ elab0 {
- elabUnitId = uid,
- elabComponentId = cid,
- elabInstantiatedWith = fmap fst insts,
- elabIsCanonical = Map.null (fmap fst insts),
- elabPkgOrComp = ElabComponent comp {
- compOrderLibDependencies =
- (if Map.null insts then [] else [newSimpleUnitId cid]) ++
- ordNub (map unDefUnitId
- (deps ++ concatMap (getDep . fst) (Map.elems insts)))
- }
+ | Just planpkg <- Map.lookup cid cmap =
+ case planpkg of
+ InstallPlan.Configured
+ ( elab0@ElaboratedConfiguredPackage
+ { elabPkgOrComp = ElabComponent comp
}
- elab = elab1 {
- elabInstallDirs = computeInstallDirs storeDirLayout
- defaultInstallDirs
- elaboratedShared
- elab1
- }
- return $ InstallPlan.Configured elab
- _ -> return planpkg
+ ) -> do
+ deps <-
+ traverse (fmap fst . substUnitId insts) (compLinkedLibDependencies comp)
+ let build_style = fold (fmap snd insts)
+ let getDep (Module dep_uid _) = [dep_uid]
+ elab1 =
+ fixupBuildStyle build_style $
+ elab0
+ { elabUnitId = uid
+ , elabComponentId = cid
+ , elabInstantiatedWith = fmap fst insts
+ , elabIsCanonical = Map.null (fmap fst insts)
+ , elabPkgOrComp =
+ ElabComponent
+ comp
+ { compOrderLibDependencies =
+ (if Map.null insts then [] else [newSimpleUnitId cid])
+ ++ ordNub
+ ( map
+ unDefUnitId
+ (deps ++ concatMap (getDep . fst) (Map.elems insts))
+ )
+ }
+ }
+ elab =
+ elab1
+ { elabInstallDirs =
+ computeInstallDirs
+ storeDirLayout
+ defaultInstallDirs
+ elaboratedShared
+ elab1
+ }
+ return $ InstallPlan.Configured elab
+ _ -> return planpkg
| otherwise = error ("instantiateComponent: " ++ prettyShow cid)
substUnitId :: Map ModuleName (Module, BuildStyle) -> OpenUnitId -> InstM (DefUnitId, BuildStyle)
substUnitId _ (DefiniteUnitId uid) =
- -- This COULD actually, secretly, be an inplace package, but in
- -- that case it doesn't matter as it's already been recorded
- -- in the package that depends on this
- return (uid, BuildAndInstall)
+ -- This COULD actually, secretly, be an inplace package, but in
+ -- that case it doesn't matter as it's already been recorded
+ -- in the package that depends on this
+ return (uid, BuildAndInstall)
substUnitId subst (IndefFullUnitId cid insts) = do
- insts' <- substSubst subst insts
- instantiateUnitId cid insts'
+ insts' <- substSubst subst insts
+ instantiateUnitId cid insts'
-- NB: NOT composition
- substSubst :: Map ModuleName (Module, BuildStyle)
- -> Map ModuleName OpenModule
- -> InstM (Map ModuleName (Module, BuildStyle))
+ substSubst
+ :: Map ModuleName (Module, BuildStyle)
+ -> Map ModuleName OpenModule
+ -> InstM (Map ModuleName (Module, BuildStyle))
substSubst subst insts = traverse (substModule subst) insts
substModule :: Map ModuleName (Module, BuildStyle) -> OpenModule -> InstM (Module, BuildStyle)
substModule subst (OpenModuleVar mod_name)
- | Just m <- Map.lookup mod_name subst = return m
- | otherwise = error "substModule: non-closing substitution"
+ | Just m <- Map.lookup mod_name subst = return m
+ | otherwise = error "substModule: non-closing substitution"
substModule subst (OpenModule uid mod_name) = do
- (uid', build_style) <- substUnitId subst uid
- return (Module uid' mod_name, build_style)
+ (uid', build_style) <- substUnitId subst uid
+ return (Module uid' mod_name, build_style)
indefiniteUnitId :: ComponentId -> InstM UnitId
indefiniteUnitId cid = do
- let uid = newSimpleUnitId cid
- r <- indefiniteComponent uid cid
- state $ \s -> (uid, Map.insert uid r s)
+ let uid = newSimpleUnitId cid
+ r <- indefiniteComponent uid cid
+ state $ \s -> (uid, Map.insert uid r s)
indefiniteComponent :: UnitId -> ComponentId -> InstM ElaboratedPlanPackage
indefiniteComponent _uid cid
-- Only need Configured; this phase happens before improvement, so
-- there shouldn't be any Installed packages here.
| Just (InstallPlan.Configured epkg) <- Map.lookup cid cmap
- , ElabComponent elab_comp <- elabPkgOrComp epkg
- = do -- We need to do a little more processing of the includes: some
- -- of them are fully definite even without substitution. We
- -- want to build those too; see #5634.
- --
- -- This code mimics similar code in Distribution.Backpack.ReadyComponent;
- -- however, unlike the conversion from LinkedComponent to
- -- ReadyComponent, this transformation is done *without*
- -- changing the type in question; and what we are simply
- -- doing is enforcing tighter invariants on the data
- -- structure in question. The new invariant is that there
- -- is no IndefFullUnitId in compLinkedLibDependencies that actually
- -- has no holes. We couldn't specify this invariant when
- -- we initially created the ElaboratedPlanPackage because
- -- we have no way of actually reifying the UnitId into a
- -- DefiniteUnitId (that's what substUnitId does!)
- new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->
- if Set.null (openUnitIdFreeHoles uid)
+ , ElabComponent elab_comp <- elabPkgOrComp epkg =
+ do
+ -- We need to do a little more processing of the includes: some
+ -- of them are fully definite even without substitution. We
+ -- want to build those too; see #5634.
+ --
+ -- This code mimics similar code in Distribution.Backpack.ReadyComponent;
+ -- however, unlike the conversion from LinkedComponent to
+ -- ReadyComponent, this transformation is done *without*
+ -- changing the type in question; and what we are simply
+ -- doing is enforcing tighter invariants on the data
+ -- structure in question. The new invariant is that there
+ -- is no IndefFullUnitId in compLinkedLibDependencies that actually
+ -- has no holes. We couldn't specify this invariant when
+ -- we initially created the ElaboratedPlanPackage because
+ -- we have no way of actually reifying the UnitId into a
+ -- DefiniteUnitId (that's what substUnitId does!)
+ new_deps <- for (compLinkedLibDependencies elab_comp) $ \uid ->
+ if Set.null (openUnitIdFreeHoles uid)
then fmap (DefiniteUnitId . fst) (substUnitId Map.empty uid)
else return uid
- -- NB: no fixupBuildStyle needed here, as if the indefinite
- -- component depends on any inplace packages, it itself must
- -- be indefinite! There is no substitution here, we can't
- -- post facto add inplace deps
- return . InstallPlan.Configured $ epkg {
- elabPkgOrComp = ElabComponent elab_comp {
- compLinkedLibDependencies = new_deps,
- -- I think this is right: any new definite unit ids we
- -- minted in the phase above need to be built before us.
- -- Add 'em in. This doesn't remove any old dependencies
- -- on the indefinite package; they're harmless.
- compOrderLibDependencies =
- ordNub $ compOrderLibDependencies elab_comp ++
- [unDefUnitId d | DefiniteUnitId d <- new_deps]
- }
- }
- | Just planpkg <- Map.lookup cid cmap
- = return planpkg
+ -- NB: no fixupBuildStyle needed here, as if the indefinite
+ -- component depends on any inplace packages, it itself must
+ -- be indefinite! There is no substitution here, we can't
+ -- post facto add inplace deps
+ return . InstallPlan.Configured $
+ epkg
+ { elabPkgOrComp =
+ ElabComponent
+ elab_comp
+ { compLinkedLibDependencies = new_deps
+ , -- I think this is right: any new definite unit ids we
+ -- minted in the phase above need to be built before us.
+ -- Add 'em in. This doesn't remove any old dependencies
+ -- on the indefinite package; they're harmless.
+ compOrderLibDependencies =
+ ordNub $
+ compOrderLibDependencies elab_comp
+ ++ [unDefUnitId d | DefiniteUnitId d <- new_deps]
+ }
+ }
+ | Just planpkg <- Map.lookup cid cmap =
+ return planpkg
| otherwise = error ("indefiniteComponent: " ++ prettyShow cid)
fixupBuildStyle BuildAndInstall elab = elab
- fixupBuildStyle _ (elab@ElaboratedConfiguredPackage { elabBuildStyle = BuildInplaceOnly }) = elab
- fixupBuildStyle BuildInplaceOnly elab = elab {
- elabBuildStyle = BuildInplaceOnly,
- elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab,
- elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab,
- elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab
- }
+ fixupBuildStyle _ (elab@ElaboratedConfiguredPackage{elabBuildStyle = BuildInplaceOnly}) = elab
+ fixupBuildStyle BuildInplaceOnly elab =
+ elab
+ { elabBuildStyle = BuildInplaceOnly
+ , elabBuildPackageDBStack = elabInplaceBuildPackageDBStack elab
+ , elabRegisterPackageDBStack = elabInplaceRegisterPackageDBStack elab
+ , elabSetupPackageDBStack = elabInplaceSetupPackageDBStack elab
+ }
ready_map = execState work Map.empty
work = for_ pkgs $ \pkg ->
- case pkg of
- InstallPlan.Configured elab
- | not (Map.null (elabLinkedInstantiatedWith elab))
- -> indefiniteUnitId (elabComponentId elab)
- >> return ()
- _ -> instantiateUnitId (getComponentId pkg) Map.empty
- >> return ()
+ case pkg of
+ InstallPlan.Configured elab
+ | not (Map.null (elabLinkedInstantiatedWith elab)) ->
+ indefiniteUnitId (elabComponentId elab)
+ >> return ()
+ _ ->
+ instantiateUnitId (getComponentId pkg) Map.empty
+ >> return ()
---------------------------
-- Build targets
@@ -2506,35 +2841,39 @@ instantiateInstallPlan storeDirLayout defaultInstallDirs elaboratedShared plan =
-- forcing them to return the @k@ value for the selected targets).
-- In particular 'resolveTargets' makes use of this (with @k@ as
-- @('UnitId', ComponentName')@) to identify the targets thus selected.
---
-data AvailableTarget k = AvailableTarget {
- availableTargetPackageId :: PackageId,
- availableTargetComponentName :: ComponentName,
- availableTargetStatus :: AvailableTargetStatus k,
- availableTargetLocalToProject :: Bool
- }
+data AvailableTarget k = AvailableTarget
+ { availableTargetPackageId :: PackageId
+ , availableTargetComponentName :: ComponentName
+ , availableTargetStatus :: AvailableTargetStatus k
+ , availableTargetLocalToProject :: Bool
+ }
deriving (Eq, Show, Functor)
-- | The status of a an 'AvailableTarget' component. This tells us whether
-- it's actually possible to select this component to be built, and if not
-- why not.
---
-data AvailableTargetStatus k =
- TargetDisabledByUser -- ^ When the user does @tests: False@
- | TargetDisabledBySolver -- ^ When the solver could not enable tests
- | TargetNotBuildable -- ^ When the component has @buildable: False@
- | TargetNotLocal -- ^ When the component is non-core in a non-local package
- | TargetBuildable k TargetRequested -- ^ The target can or should be built
+data AvailableTargetStatus k
+ = -- | When the user does @tests: False@
+ TargetDisabledByUser
+ | -- | When the solver could not enable tests
+ TargetDisabledBySolver
+ | -- | When the component has @buildable: False@
+ TargetNotBuildable
+ | -- | When the component is non-core in a non-local package
+ TargetNotLocal
+ | -- | The target can or should be built
+ TargetBuildable k TargetRequested
deriving (Eq, Ord, Show, Functor)
-- | This tells us whether a target ought to be built by default, or only if
-- specifically requested. The policy is that components like libraries and
-- executables are built by default by @build@, but test suites and benchmarks
-- are not, unless this is overridden in the project configuration.
---
-data TargetRequested =
- TargetRequestedByDefault -- ^ To be built by default
- | TargetNotRequestedByDefault -- ^ Not to be built by default
+data TargetRequested
+ = -- | To be built by default
+ TargetRequestedByDefault
+ | -- | Not to be built by default
+ TargetNotRequestedByDefault
deriving (Eq, Ord, Show)
-- | Given the install plan, produce the set of 'AvailableTarget's for each
@@ -2546,145 +2885,172 @@ data TargetRequested =
-- had a plan that contained two instances of the same version of a package.
-- This approach makes it relatively easy to select all instances\/variants
-- of a component.
---
-availableTargets :: ElaboratedInstallPlan
- -> Map (PackageId, ComponentName)
- [AvailableTarget (UnitId, ComponentName)]
+availableTargets
+ :: ElaboratedInstallPlan
+ -> Map
+ (PackageId, ComponentName)
+ [AvailableTarget (UnitId, ComponentName)]
availableTargets installPlan =
- let rs = [ (pkgid, cname, fake, target)
- | pkg <- InstallPlan.toList installPlan
- , (pkgid, cname, fake, target) <- case pkg of
- InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg
- InstallPlan.Installed elab -> availableSourceTargets elab
- InstallPlan.Configured elab -> availableSourceTargets elab
- ]
- in Map.union
- (Map.fromListWith (++)
+ let rs =
+ [ (pkgid, cname, fake, target)
+ | pkg <- InstallPlan.toList installPlan
+ , (pkgid, cname, fake, target) <- case pkg of
+ InstallPlan.PreExisting ipkg -> availableInstalledTargets ipkg
+ InstallPlan.Installed elab -> availableSourceTargets elab
+ InstallPlan.Configured elab -> availableSourceTargets elab
+ ]
+ in Map.union
+ ( Map.fromListWith
+ (++)
[ ((pkgid, cname), [target])
- | (pkgid, cname, fake, target) <- rs, not fake])
- (Map.fromList
+ | (pkgid, cname, fake, target) <- rs
+ , not fake
+ ]
+ )
+ ( Map.fromList
[ ((pkgid, cname), [target])
- | (pkgid, cname, fake, target) <- rs, fake])
- -- The normal targets mask the fake ones. We get all instances of the
- -- normal ones and only one copy of the fake ones (as there are many
- -- duplicates of the fake ones). See 'availableSourceTargets' below for
- -- more details on this fake stuff is about.
-
-availableInstalledTargets :: IPI.InstalledPackageInfo
- -> [(PackageId, ComponentName, Bool,
- AvailableTarget (UnitId, ComponentName))]
+ | (pkgid, cname, fake, target) <- rs
+ , fake
+ ]
+ )
+
+-- The normal targets mask the fake ones. We get all instances of the
+-- normal ones and only one copy of the fake ones (as there are many
+-- duplicates of the fake ones). See 'availableSourceTargets' below for
+-- more details on this fake stuff is about.
+
+availableInstalledTargets
+ :: IPI.InstalledPackageInfo
+ -> [ ( PackageId
+ , ComponentName
+ , Bool
+ , AvailableTarget (UnitId, ComponentName)
+ )
+ ]
availableInstalledTargets ipkg =
- let unitid = installedUnitId ipkg
- cname = CLibName LMainLibName
- status = TargetBuildable (unitid, cname) TargetRequestedByDefault
- target = AvailableTarget (packageId ipkg) cname status False
- fake = False
- in [(packageId ipkg, cname, fake, target)]
-
-availableSourceTargets :: ElaboratedConfiguredPackage
- -> [(PackageId, ComponentName, Bool,
- AvailableTarget (UnitId, ComponentName))]
+ let unitid = installedUnitId ipkg
+ cname = CLibName LMainLibName
+ status = TargetBuildable (unitid, cname) TargetRequestedByDefault
+ target = AvailableTarget (packageId ipkg) cname status False
+ fake = False
+ in [(packageId ipkg, cname, fake, target)]
+
+availableSourceTargets
+ :: ElaboratedConfiguredPackage
+ -> [ ( PackageId
+ , ComponentName
+ , Bool
+ , AvailableTarget (UnitId, ComponentName)
+ )
+ ]
availableSourceTargets elab =
- -- We have a somewhat awkward problem here. We need to know /all/ the
- -- components from /all/ the packages because these are the things that
- -- users could refer to. Unfortunately, at this stage the elaborated install
- -- plan does /not/ contain all components: some components have already
- -- been deleted because they cannot possibly be built. This is the case
- -- for components that are marked @buildable: False@ in their .cabal files.
- -- (It's not unreasonable that the unbuildable components have been pruned
- -- as the plan invariant is considerably simpler if all nodes can be built)
- --
- -- We can recover the missing components but it's not exactly elegant. For
- -- a graph node corresponding to a component we still have the information
- -- about the package that it came from, and this includes the names of
- -- /all/ the other components in the package. So in principle this lets us
- -- find the names of all components, plus full details of the buildable
- -- components.
- --
- -- Consider for example a package with 3 exe components: foo, bar and baz
- -- where foo and bar are buildable, but baz is not. So the plan contains
- -- nodes for the components foo and bar. Now we look at each of these two
- -- nodes and look at the package they come from and the names of the
- -- components in this package. This will give us the names foo, bar and
- -- baz, twice (once for each of the two buildable components foo and bar).
- --
- -- We refer to these reconstructed missing components as fake targets.
- -- It is an invariant that they are not available to be built.
- --
- -- To produce the final set of targets we put the fake targets in a finite
- -- map (thus eliminating the duplicates) and then we overlay that map with
- -- the normal buildable targets. (This is done above in 'availableTargets'.)
- --
- [ (packageId elab, cname, fake, target)
- | component <- pkgComponents (elabPkgDescription elab)
- , let cname = componentName component
- status = componentAvailableTargetStatus component
- target = AvailableTarget {
- availableTargetPackageId = packageId elab,
- availableTargetComponentName = cname,
- availableTargetStatus = status,
- availableTargetLocalToProject = elabLocalToProject elab
- }
- fake = isFakeTarget cname
-
- -- TODO: The goal of this test is to exclude "instantiated"
- -- packages as available targets. This means that you can't
- -- ask for a particular instantiated component to be built;
- -- it will only get built by a dependency. Perhaps the
- -- correct way to implement this is to run selection
- -- prior to instantiating packages. If you refactor
- -- this, then you can delete this test.
- , elabIsCanonical elab
-
- -- Filter out some bogus parts of the cross product that are never needed
- , case status of
- TargetBuildable{} | fake -> False
- _ -> True
- ]
+ -- We have a somewhat awkward problem here. We need to know /all/ the
+ -- components from /all/ the packages because these are the things that
+ -- users could refer to. Unfortunately, at this stage the elaborated install
+ -- plan does /not/ contain all components: some components have already
+ -- been deleted because they cannot possibly be built. This is the case
+ -- for components that are marked @buildable: False@ in their .cabal files.
+ -- (It's not unreasonable that the unbuildable components have been pruned
+ -- as the plan invariant is considerably simpler if all nodes can be built)
+ --
+ -- We can recover the missing components but it's not exactly elegant. For
+ -- a graph node corresponding to a component we still have the information
+ -- about the package that it came from, and this includes the names of
+ -- /all/ the other components in the package. So in principle this lets us
+ -- find the names of all components, plus full details of the buildable
+ -- components.
+ --
+ -- Consider for example a package with 3 exe components: foo, bar and baz
+ -- where foo and bar are buildable, but baz is not. So the plan contains
+ -- nodes for the components foo and bar. Now we look at each of these two
+ -- nodes and look at the package they come from and the names of the
+ -- components in this package. This will give us the names foo, bar and
+ -- baz, twice (once for each of the two buildable components foo and bar).
+ --
+ -- We refer to these reconstructed missing components as fake targets.
+ -- It is an invariant that they are not available to be built.
+ --
+ -- To produce the final set of targets we put the fake targets in a finite
+ -- map (thus eliminating the duplicates) and then we overlay that map with
+ -- the normal buildable targets. (This is done above in 'availableTargets'.)
+ --
+ [ (packageId elab, cname, fake, target)
+ | component <- pkgComponents (elabPkgDescription elab)
+ , let cname = componentName component
+ status = componentAvailableTargetStatus component
+ target =
+ AvailableTarget
+ { availableTargetPackageId = packageId elab
+ , availableTargetComponentName = cname
+ , availableTargetStatus = status
+ , availableTargetLocalToProject = elabLocalToProject elab
+ }
+ fake = isFakeTarget cname
+ , -- TODO: The goal of this test is to exclude "instantiated"
+ -- packages as available targets. This means that you can't
+ -- ask for a particular instantiated component to be built;
+ -- it will only get built by a dependency. Perhaps the
+ -- correct way to implement this is to run selection
+ -- prior to instantiating packages. If you refactor
+ -- this, then you can delete this test.
+ elabIsCanonical elab
+ , -- Filter out some bogus parts of the cross product that are never needed
+ case status of
+ TargetBuildable{} | fake -> False
+ _ -> True
+ ]
where
isFakeTarget cname =
case elabPkgOrComp elab of
- ElabPackage _ -> False
- ElabComponent elabComponent -> compComponentName elabComponent
- /= Just cname
+ ElabPackage _ -> False
+ ElabComponent elabComponent ->
+ compComponentName elabComponent
+ /= Just cname
componentAvailableTargetStatus
:: Component -> AvailableTargetStatus (UnitId, ComponentName)
componentAvailableTargetStatus component =
- case componentOptionalStanza $ CD.componentNameToComponent cname of
- -- it is not an optional stanza, so a library, exe or foreign lib
- Nothing
- | not buildable -> TargetNotBuildable
- | otherwise -> TargetBuildable (elabUnitId elab, cname)
- TargetRequestedByDefault
-
- -- it is not an optional stanza, so a testsuite or benchmark
- Just stanza ->
- case (optStanzaLookup stanza (elabStanzasRequested elab), -- TODO
- optStanzaSetMember stanza (elabStanzasAvailable elab)) of
- _ | not withinPlan -> TargetNotLocal
- (Just False, _) -> TargetDisabledByUser
- (Nothing, False) -> TargetDisabledBySolver
- _ | not buildable -> TargetNotBuildable
- (Just True, True) -> TargetBuildable (elabUnitId elab, cname)
- TargetRequestedByDefault
- (Nothing, True) -> TargetBuildable (elabUnitId elab, cname)
- TargetNotRequestedByDefault
- (Just True, False) ->
- error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname
+ case componentOptionalStanza $ CD.componentNameToComponent cname of
+ -- it is not an optional stanza, so a library, exe or foreign lib
+ Nothing
+ | not buildable -> TargetNotBuildable
+ | otherwise ->
+ TargetBuildable
+ (elabUnitId elab, cname)
+ TargetRequestedByDefault
+ -- it is not an optional stanza, so a testsuite or benchmark
+ Just stanza ->
+ case ( optStanzaLookup stanza (elabStanzasRequested elab) -- TODO
+ , optStanzaSetMember stanza (elabStanzasAvailable elab)
+ ) of
+ _ | not withinPlan -> TargetNotLocal
+ (Just False, _) -> TargetDisabledByUser
+ (Nothing, False) -> TargetDisabledBySolver
+ _ | not buildable -> TargetNotBuildable
+ (Just True, True) ->
+ TargetBuildable
+ (elabUnitId elab, cname)
+ TargetRequestedByDefault
+ (Nothing, True) ->
+ TargetBuildable
+ (elabUnitId elab, cname)
+ TargetNotRequestedByDefault
+ (Just True, False) ->
+ error $ "componentAvailableTargetStatus: impossible; cname=" ++ prettyShow cname
where
- cname = componentName component
- buildable = PD.buildable (componentBuildInfo component)
- withinPlan = elabLocalToProject elab
- || case elabPkgOrComp elab of
- ElabComponent elabComponent ->
- compComponentName elabComponent == Just cname
- ElabPackage _ ->
- case componentName component of
- CLibName (LMainLibName) -> True
- CExeName _ -> True
- --TODO: what about sub-libs and foreign libs?
- _ -> False
+ cname = componentName component
+ buildable = PD.buildable (componentBuildInfo component)
+ withinPlan =
+ elabLocalToProject elab
+ || case elabPkgOrComp elab of
+ ElabComponent elabComponent ->
+ compComponentName elabComponent == Just cname
+ ElabPackage _ ->
+ case componentName component of
+ CLibName (LMainLibName) -> True
+ CExeName _ -> True
+ -- TODO: what about sub-libs and foreign libs?
+ _ -> False
-- | Merge component targets that overlap each other. Specially when we have
-- multiple targets for the same component and one of them refers to the whole
@@ -2693,78 +3059,80 @@ availableSourceTargets elab =
--
-- We also allow for information associated with each component target, and
-- whenever we targets subsume each other we aggregate their associated info.
---
nubComponentTargets :: [(ComponentTarget, a)] -> [(ComponentTarget, NonEmpty a)]
nubComponentTargets =
- concatMap (wholeComponentOverrides . map snd)
- . groupBy ((==) `on` fst)
- . sortBy (compare `on` fst)
- . map (\t@((ComponentTarget cname _, _)) -> (cname, t))
- . map compatSubComponentTargets
+ concatMap (wholeComponentOverrides . map snd)
+ . groupBy ((==) `on` fst)
+ . sortBy (compare `on` fst)
+ . map (\t@((ComponentTarget cname _, _)) -> (cname, t))
+ . map compatSubComponentTargets
where
-- If we're building the whole component then that the only target all we
-- need, otherwise we can have several targets within the component.
- wholeComponentOverrides :: [(ComponentTarget, a )]
- -> [(ComponentTarget, NonEmpty a)]
+ wholeComponentOverrides
+ :: [(ComponentTarget, a)]
+ -> [(ComponentTarget, NonEmpty a)]
wholeComponentOverrides ts =
- case [ ta | ta@(ComponentTarget _ WholeComponent, _) <- ts ] of
- ((t, x):_) ->
- let
- -- Delete tuple (t, x) from original list to avoid duplicates.
- -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'.
- ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts
- in
- [ (t, x :| map snd ts') ]
- [] -> [ (t, x :| []) | (t,x) <- ts ]
+ case [ta | ta@(ComponentTarget _ WholeComponent, _) <- ts] of
+ ((t, x) : _) ->
+ let
+ -- Delete tuple (t, x) from original list to avoid duplicates.
+ -- Use 'deleteBy', to avoid additional Class constraint on 'nubComponentTargets'.
+ ts' = deleteBy (\(t1, _) (t2, _) -> t1 == t2) (t, x) ts
+ in
+ [(t, x :| map snd ts')]
+ [] -> [(t, x :| []) | (t, x) <- ts]
-- Not all Cabal Setup.hs versions support sub-component targets, so switch
-- them over to the whole component
compatSubComponentTargets :: (ComponentTarget, a) -> (ComponentTarget, a)
compatSubComponentTargets target@(ComponentTarget cname _subtarget, x)
- | not setupHsSupportsSubComponentTargets
- = (ComponentTarget cname WholeComponent, x)
+ | not setupHsSupportsSubComponentTargets =
+ (ComponentTarget cname WholeComponent, x)
| otherwise = target
-- Actually the reality is that no current version of Cabal's Setup.hs
-- build command actually support building specific files or modules.
setupHsSupportsSubComponentTargets = False
- -- TODO: when that changes, adjust this test, e.g.
- -- | pkgSetupScriptCliVersion >= Version [x,y] []
+
+-- TODO: when that changes, adjust this test, e.g.
+-- \| pkgSetupScriptCliVersion >= Version [x,y] []
pkgHasEphemeralBuildTargets :: ElaboratedConfiguredPackage -> Bool
pkgHasEphemeralBuildTargets elab =
- isJust (elabReplTarget elab)
- || (not . null) (elabTestTargets elab)
- || (not . null) (elabBenchTargets elab)
- || (not . null) (elabHaddockTargets elab)
- || (not . null) [ () | ComponentTarget _ subtarget <- elabBuildTargets elab
- , subtarget /= WholeComponent ]
+ isJust (elabReplTarget elab)
+ || (not . null) (elabTestTargets elab)
+ || (not . null) (elabBenchTargets elab)
+ || (not . null) (elabHaddockTargets elab)
+ || (not . null)
+ [ () | ComponentTarget _ subtarget <- elabBuildTargets elab, subtarget /= WholeComponent
+ ]
-- | The components that we'll build all of, meaning that after they're built
-- we can skip building them again (unlike with building just some modules or
-- other files within a component).
---
-elabBuildTargetWholeComponents :: ElaboratedConfiguredPackage
- -> Set ComponentName
+elabBuildTargetWholeComponents
+ :: ElaboratedConfiguredPackage
+ -> Set ComponentName
elabBuildTargetWholeComponents elab =
- Set.fromList
- [ cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab ]
-
-
+ Set.fromList
+ [cname | ComponentTarget cname WholeComponent <- elabBuildTargets elab]
------------------------------------------------------------------------------
+
-- * Install plan pruning
+
------------------------------------------------------------------------------
-- | How 'pruneInstallPlanToTargets' should interpret the per-package
-- 'ComponentTarget's: as build, repl or haddock targets.
---
-data TargetAction = TargetActionConfigure
- | TargetActionBuild
- | TargetActionRepl
- | TargetActionTest
- | TargetActionBench
- | TargetActionHaddock
+data TargetAction
+ = TargetActionConfigure
+ | TargetActionBuild
+ | TargetActionRepl
+ | TargetActionTest
+ | TargetActionBench
+ | TargetActionHaddock
-- | Given a set of per-package\/per-component targets, take the subset of the
-- install plan needed to build those targets. Also, update the package config
@@ -2774,20 +3142,21 @@ data TargetAction = TargetActionConfigure
-- NB: Pruning happens after improvement, which is important because we
-- will prune differently depending on what is already installed (to
-- implement "sticky" test suite enabling behavior).
---
-pruneInstallPlanToTargets :: TargetAction
- -> Map UnitId [ComponentTarget]
- -> ElaboratedInstallPlan -> ElaboratedInstallPlan
+pruneInstallPlanToTargets
+ :: TargetAction
+ -> Map UnitId [ComponentTarget]
+ -> ElaboratedInstallPlan
+ -> ElaboratedInstallPlan
pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan =
- InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
- . Graph.fromDistinctList
+ InstallPlan.new (InstallPlan.planIndepGoals elaboratedPlan)
+ . Graph.fromDistinctList
-- We have to do the pruning in two passes
- . pruneInstallPlanPass2
- . pruneInstallPlanPass1
+ . pruneInstallPlanPass2
+ . pruneInstallPlanPass1
-- Set the targets that will be the roots for pruning
- . setRootTargets targetActionType perPkgTargetsMap
- . InstallPlan.toList
- $ elaboratedPlan
+ . setRootTargets targetActionType perPkgTargetsMap
+ . InstallPlan.toList
+ $ elaboratedPlan
-- | This is a temporary data type, where we temporarily
-- override the graph dependencies of an 'ElaboratedPackage',
@@ -2799,59 +3168,68 @@ pruneInstallPlanToTargets targetActionType perPkgTargetsMap elaboratedPlan =
data PrunedPackage = PrunedPackage ElaboratedConfiguredPackage [UnitId]
instance Package PrunedPackage where
- packageId (PrunedPackage elab _) = packageId elab
+ packageId (PrunedPackage elab _) = packageId elab
instance HasUnitId PrunedPackage where
- installedUnitId = nodeKey
+ installedUnitId = nodeKey
instance IsNode PrunedPackage where
- type Key PrunedPackage = UnitId
- nodeKey (PrunedPackage elab _) = nodeKey elab
- nodeNeighbors (PrunedPackage _ deps) = deps
+ type Key PrunedPackage = UnitId
+ nodeKey (PrunedPackage elab _) = nodeKey elab
+ nodeNeighbors (PrunedPackage _ deps) = deps
fromPrunedPackage :: PrunedPackage -> ElaboratedConfiguredPackage
fromPrunedPackage (PrunedPackage elab _) = elab
-- | Set the build targets based on the user targets (but not rev deps yet).
-- This is required before we can prune anything.
---
-setRootTargets :: TargetAction
- -> Map UnitId [ComponentTarget]
- -> [ElaboratedPlanPackage]
- -> [ElaboratedPlanPackage]
+setRootTargets
+ :: TargetAction
+ -> Map UnitId [ComponentTarget]
+ -> [ElaboratedPlanPackage]
+ -> [ElaboratedPlanPackage]
setRootTargets targetAction perPkgTargetsMap =
- assert (not (Map.null perPkgTargetsMap)) $
+ assert (not (Map.null perPkgTargetsMap)) $
assert (all (not . null) (Map.elems perPkgTargetsMap)) $
-
- map (mapConfiguredPackage setElabBuildTargets)
+ map (mapConfiguredPackage setElabBuildTargets)
where
-- Set the targets we'll build for this package/component. This is just
-- based on the root targets from the user, not targets implied by reverse
-- dependencies. Those comes in the second pass once we know the rev deps.
--
setElabBuildTargets elab =
- case (Map.lookup (installedUnitId elab) perPkgTargetsMap,
- targetAction) of
- (Nothing, _) -> elab
- (Just tgts, TargetActionConfigure) -> elab { elabConfigureTargets = tgts }
- (Just tgts, TargetActionBuild) -> elab { elabBuildTargets = tgts }
- (Just tgts, TargetActionTest) -> elab { elabTestTargets = tgts }
- (Just tgts, TargetActionBench) -> elab { elabBenchTargets = tgts }
- (Just [tgt], TargetActionRepl) -> elab { elabReplTarget = Just tgt
- , elabBuildHaddocks = False }
- (Just tgts, TargetActionHaddock) ->
- foldr setElabHaddockTargets (elab { elabHaddockTargets = tgts
- , elabBuildHaddocks = True }) tgts
- (Just _, TargetActionRepl) ->
+ case ( Map.lookup (installedUnitId elab) perPkgTargetsMap
+ , targetAction
+ ) of
+ (Nothing, _) -> elab
+ (Just tgts, TargetActionConfigure) -> elab{elabConfigureTargets = tgts}
+ (Just tgts, TargetActionBuild) -> elab{elabBuildTargets = tgts}
+ (Just tgts, TargetActionTest) -> elab{elabTestTargets = tgts}
+ (Just tgts, TargetActionBench) -> elab{elabBenchTargets = tgts}
+ (Just [tgt], TargetActionRepl) ->
+ elab
+ { elabReplTarget = Just tgt
+ , elabBuildHaddocks = False
+ }
+ (Just tgts, TargetActionHaddock) ->
+ foldr
+ setElabHaddockTargets
+ ( elab
+ { elabHaddockTargets = tgts
+ , elabBuildHaddocks = True
+ }
+ )
+ tgts
+ (Just _, TargetActionRepl) ->
error "pruneInstallPlanToTargets: multiple repl targets"
setElabHaddockTargets tgt elab
- | isTestComponentTarget tgt = elab { elabHaddockTestSuites = True }
- | isBenchComponentTarget tgt = elab { elabHaddockBenchmarks = True }
- | isForeignLibComponentTarget tgt = elab { elabHaddockForeignLibs = True }
- | isExeComponentTarget tgt = elab { elabHaddockExecutables = True }
- | isSubLibComponentTarget tgt = elab { elabHaddockInternal = True }
- | otherwise = elab
+ | isTestComponentTarget tgt = elab{elabHaddockTestSuites = True}
+ | isBenchComponentTarget tgt = elab{elabHaddockBenchmarks = True}
+ | isForeignLibComponentTarget tgt = elab{elabHaddockForeignLibs = True}
+ | isExeComponentTarget tgt = elab{elabHaddockExecutables = True}
+ | isSubLibComponentTarget tgt = elab{elabHaddockInternal = True}
+ | otherwise = elab
-- | Assuming we have previously set the root build targets (i.e. the user
-- targets but not rev deps yet), the first pruning pass does two things:
@@ -2861,38 +3239,42 @@ setRootTargets targetAction perPkgTargetsMap =
-- * Take the dependency closure using pruned dependencies. We prune deps that
-- are used only by unneeded optional stanzas. These pruned deps are only
-- used for the dependency closure and are not persisted in this pass.
---
-pruneInstallPlanPass1 :: [ElaboratedPlanPackage]
- -> [ElaboratedPlanPackage]
+pruneInstallPlanPass1
+ :: [ElaboratedPlanPackage]
+ -> [ElaboratedPlanPackage]
pruneInstallPlanPass1 pkgs =
- map (mapConfiguredPackage fromPrunedPackage)
- (fromMaybe [] $ Graph.closure graph roots)
+ map
+ (mapConfiguredPackage fromPrunedPackage)
+ (fromMaybe [] $ Graph.closure graph roots)
where
pkgs' = map (mapConfiguredPackage prune) pkgs
graph = Graph.fromDistinctList pkgs'
roots = mapMaybe find_root pkgs'
prune elab = PrunedPackage elab' (pruneOptionalDependencies elab')
- where elab' =
- setDocumentation
- $ addOptionalStanzas elab
+ where
+ elab' =
+ setDocumentation $
+ addOptionalStanzas elab
is_root :: PrunedPackage -> Maybe UnitId
is_root (PrunedPackage elab _) =
- if not $ and [ null (elabConfigureTargets elab)
- , null (elabBuildTargets elab)
- , null (elabTestTargets elab)
- , null (elabBenchTargets elab)
- , isNothing (elabReplTarget elab)
- , null (elabHaddockTargets elab)
- ]
- then Just (installedUnitId elab)
- else Nothing
+ if not $
+ and
+ [ null (elabConfigureTargets elab)
+ , null (elabBuildTargets elab)
+ , null (elabTestTargets elab)
+ , null (elabBenchTargets elab)
+ , isNothing (elabReplTarget elab)
+ , null (elabHaddockTargets elab)
+ ]
+ then Just (installedUnitId elab)
+ else Nothing
find_root (InstallPlan.Configured pkg) = is_root pkg
-- When using the extra-packages stanza we need to
-- look at installed packages as well.
- find_root (InstallPlan.Installed pkg) = is_root pkg
+ find_root (InstallPlan.Installed pkg) = is_root pkg
find_root _ = Nothing
-- Note [Sticky enabled testsuites]
@@ -2914,46 +3296,45 @@ pruneInstallPlanPass1 pkgs =
-- Decide whether or not to enable testsuites and benchmarks.
-- See [Sticky enabled testsuites]
addOptionalStanzas :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage
- addOptionalStanzas elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg } =
- elab {
- elabPkgOrComp = ElabPackage (pkg { pkgStanzasEnabled = stanzas })
+ addOptionalStanzas elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} =
+ elab
+ { elabPkgOrComp = ElabPackage (pkg{pkgStanzasEnabled = stanzas})
}
where
stanzas :: OptionalStanzaSet
- -- By default, we enabled all stanzas requested by the user,
- -- as per elabStanzasRequested, done in
- -- 'elaborateSolverToPackage'
- stanzas = pkgStanzasEnabled pkg
- -- optionalStanzasRequiredByTargets has to be done at
- -- prune-time because it depends on 'elabTestTargets'
- -- et al, which is done by 'setRootTargets' at the
- -- beginning of pruning.
- <> optionalStanzasRequiredByTargets elab
- -- optionalStanzasWithDepsAvailable has to be done at
- -- prune-time because it depends on what packages are
- -- installed, which is not known until after improvement
- -- (pruning is done after improvement)
- <> optionalStanzasWithDepsAvailable availablePkgs elab pkg
+ -- By default, we enabled all stanzas requested by the user,
+ -- as per elabStanzasRequested, done in
+ -- 'elaborateSolverToPackage'
+ stanzas =
+ pkgStanzasEnabled pkg
+ -- optionalStanzasRequiredByTargets has to be done at
+ -- prune-time because it depends on 'elabTestTargets'
+ -- et al, which is done by 'setRootTargets' at the
+ -- beginning of pruning.
+ <> optionalStanzasRequiredByTargets elab
+ -- optionalStanzasWithDepsAvailable has to be done at
+ -- prune-time because it depends on what packages are
+ -- installed, which is not known until after improvement
+ -- (pruning is done after improvement)
+ <> optionalStanzasWithDepsAvailable availablePkgs elab pkg
addOptionalStanzas elab = elab
setDocumentation :: ElaboratedConfiguredPackage -> ElaboratedConfiguredPackage
- setDocumentation elab@ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp } =
- elab {
- elabBuildHaddocks =
+ setDocumentation elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} =
+ elab
+ { elabBuildHaddocks =
elabBuildHaddocks elab && documentationEnabled (compSolverName comp) elab
- }
-
+ }
where
documentationEnabled c =
case c of
- CD.ComponentLib -> const True
+ CD.ComponentLib -> const True
CD.ComponentSubLib _ -> elabHaddockInternal
- CD.ComponentFLib _ -> elabHaddockForeignLibs
- CD.ComponentExe _ -> elabHaddockExecutables
- CD.ComponentTest _ -> elabHaddockTestSuites
- CD.ComponentBench _ -> elabHaddockBenchmarks
- CD.ComponentSetup -> const False
-
+ CD.ComponentFLib _ -> elabHaddockForeignLibs
+ CD.ComponentExe _ -> elabHaddockExecutables
+ CD.ComponentTest _ -> elabHaddockTestSuites
+ CD.ComponentBench _ -> elabHaddockBenchmarks
+ CD.ComponentSetup -> const False
setDocumentation elab = elab
-- Calculate package dependencies but cut out those needed only by
@@ -2963,35 +3344,39 @@ pruneInstallPlanPass1 pkgs =
-- stanzas in the next pass.
--
pruneOptionalDependencies :: ElaboratedConfiguredPackage -> [UnitId]
- pruneOptionalDependencies elab@ElaboratedConfiguredPackage{ elabPkgOrComp = ElabComponent _ }
- = InstallPlan.depends elab -- no pruning
- pruneOptionalDependencies ElaboratedConfiguredPackage{ elabPkgOrComp = ElabPackage pkg }
- = (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)
+ pruneOptionalDependencies elab@ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _} =
+ InstallPlan.depends elab -- no pruning
+ pruneOptionalDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} =
+ (CD.flatDeps . CD.filterDeps keepNeeded) (pkgOrderDependencies pkg)
where
- keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas
+ keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas
keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas
- keepNeeded _ _ = True
+ keepNeeded _ _ = True
stanzas = pkgStanzasEnabled pkg
- optionalStanzasRequiredByTargets :: ElaboratedConfiguredPackage
- -> OptionalStanzaSet
+ optionalStanzasRequiredByTargets
+ :: ElaboratedConfiguredPackage
+ -> OptionalStanzaSet
optionalStanzasRequiredByTargets pkg =
optStanzaSetFromList
[ stanza
- | ComponentTarget cname _ <- elabBuildTargets pkg
- ++ elabTestTargets pkg
- ++ elabBenchTargets pkg
- ++ maybeToList (elabReplTarget pkg)
- ++ elabHaddockTargets pkg
- , stanza <- maybeToList $
- componentOptionalStanza $
- CD.componentNameToComponent cname
+ | ComponentTarget cname _ <-
+ elabBuildTargets pkg
+ ++ elabTestTargets pkg
+ ++ elabBenchTargets pkg
+ ++ maybeToList (elabReplTarget pkg)
+ ++ elabHaddockTargets pkg
+ , stanza <-
+ maybeToList $
+ componentOptionalStanza $
+ CD.componentNameToComponent cname
]
availablePkgs =
Set.fromList
[ installedUnitId pkg
- | InstallPlan.PreExisting pkg <- pkgs ]
+ | InstallPlan.PreExisting pkg <- pkgs
+ ]
-- | Given a set of already installed packages @availablePkgs@,
-- determine the set of available optional stanzas from @pkg@
@@ -2999,32 +3384,38 @@ pruneInstallPlanPass1 pkgs =
-- to implement "sticky" testsuites, where once we have installed
-- all of the deps needed for the test suite, we go ahead and
-- enable it always.
-optionalStanzasWithDepsAvailable :: Set UnitId
- -> ElaboratedConfiguredPackage
- -> ElaboratedPackage
- -> OptionalStanzaSet
+optionalStanzasWithDepsAvailable
+ :: Set UnitId
+ -> ElaboratedConfiguredPackage
+ -> ElaboratedPackage
+ -> OptionalStanzaSet
optionalStanzasWithDepsAvailable availablePkgs elab pkg =
- optStanzaSetFromList
- [ stanza
- | stanza <- optStanzaSetToList (elabStanzasAvailable elab)
- , let deps :: [UnitId]
- deps = CD.select (optionalStanzaDeps stanza)
- -- TODO: probably need to select other
- -- dep types too eventually
- (pkgOrderDependencies pkg)
- , all (`Set.member` availablePkgs) deps
- ]
+ optStanzaSetFromList
+ [ stanza
+ | stanza <- optStanzaSetToList (elabStanzasAvailable elab)
+ , let deps :: [UnitId]
+ deps =
+ CD.select
+ (optionalStanzaDeps stanza)
+ -- TODO: probably need to select other
+ -- dep types too eventually
+ (pkgOrderDependencies pkg)
+ , all (`Set.member` availablePkgs) deps
+ ]
where
- optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True
+ optionalStanzaDeps TestStanzas (CD.ComponentTest _) = True
optionalStanzaDeps BenchStanzas (CD.ComponentBench _) = True
- optionalStanzaDeps _ _ = False
-
+ optionalStanzaDeps _ _ = False
-- The second pass does three things:
--
+
-- * A second go at deciding which optional stanzas to enable.
+
-- * Prune the dependencies based on the final choice of optional stanzas.
+
-- * Extend the targets within each package to build, now we know the reverse
+
-- dependencies, ie we know which libs are needed as deps by other packages.
--
-- Achieving sticky behaviour with enabling\/disabling optional stanzas is
@@ -3047,31 +3438,35 @@ optionalStanzasWithDepsAvailable availablePkgs elab pkg =
-- first or second pass) doesn't mean that we build all (or even any) of them.
-- That depends on which targets we picked in the first pass.
--
-pruneInstallPlanPass2 :: [ElaboratedPlanPackage]
- -> [ElaboratedPlanPackage]
+pruneInstallPlanPass2
+ :: [ElaboratedPlanPackage]
+ -> [ElaboratedPlanPackage]
pruneInstallPlanPass2 pkgs =
- map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs
+ map (mapConfiguredPackage setStanzasDepsAndTargets) pkgs
where
setStanzasDepsAndTargets elab =
- elab {
- elabBuildTargets = ordNub
- $ elabBuildTargets elab
- ++ libTargetsRequiredForRevDeps
- ++ exeTargetsRequiredForRevDeps,
- elabPkgOrComp =
+ elab
+ { elabBuildTargets =
+ ordNub $
+ elabBuildTargets elab
+ ++ libTargetsRequiredForRevDeps
+ ++ exeTargetsRequiredForRevDeps
+ , elabPkgOrComp =
case elabPkgOrComp elab of
ElabPackage pkg ->
- let stanzas = pkgStanzasEnabled pkg
- <> optionalStanzasWithDepsAvailable availablePkgs elab pkg
- keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas
+ let stanzas =
+ pkgStanzasEnabled pkg
+ <> optionalStanzasWithDepsAvailable availablePkgs elab pkg
+ keepNeeded (CD.ComponentTest _) _ = TestStanzas `optStanzaSetMember` stanzas
keepNeeded (CD.ComponentBench _) _ = BenchStanzas `optStanzaSetMember` stanzas
- keepNeeded _ _ = True
- in ElabPackage $ pkg {
- pkgStanzasEnabled = stanzas,
- pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg),
- pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg),
- pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg)
- }
+ keepNeeded _ _ = True
+ in ElabPackage $
+ pkg
+ { pkgStanzasEnabled = stanzas
+ , pkgLibDependencies = CD.filterDeps keepNeeded (pkgLibDependencies pkg)
+ , pkgExeDependencies = CD.filterDeps keepNeeded (pkgExeDependencies pkg)
+ , pkgExeDependencyPaths = CD.filterDeps keepNeeded (pkgExeDependencyPaths pkg)
+ }
r@(ElabComponent _) -> r
}
where
@@ -3082,32 +3477,39 @@ pruneInstallPlanPass2 pkgs =
exeTargetsRequiredForRevDeps =
-- TODO: allow requesting executable with different name
-- than package name
- [ ComponentTarget (Cabal.CExeName
- $ packageNameToUnqualComponentName
- $ packageName $ elabPkgSourceId elab)
- WholeComponent
+ [ ComponentTarget
+ ( Cabal.CExeName $
+ packageNameToUnqualComponentName $
+ packageName $
+ elabPkgSourceId elab
+ )
+ WholeComponent
| installedUnitId elab `Set.member` hasReverseExeDeps
]
-
availablePkgs :: Set UnitId
availablePkgs = Set.fromList (map installedUnitId pkgs)
hasReverseLibDeps :: Set UnitId
hasReverseLibDeps =
- Set.fromList [ depid
- | InstallPlan.Configured pkg <- pkgs
- , depid <- elabOrderLibDependencies pkg ]
+ Set.fromList
+ [ depid
+ | InstallPlan.Configured pkg <- pkgs
+ , depid <- elabOrderLibDependencies pkg
+ ]
hasReverseExeDeps :: Set UnitId
hasReverseExeDeps =
- Set.fromList [ depid
- | InstallPlan.Configured pkg <- pkgs
- , depid <- elabOrderExeDependencies pkg ]
+ Set.fromList
+ [ depid
+ | InstallPlan.Configured pkg <- pkgs
+ , depid <- elabOrderExeDependencies pkg
+ ]
-mapConfiguredPackage :: (srcpkg -> srcpkg')
- -> InstallPlan.GenericPlanPackage ipkg srcpkg
- -> InstallPlan.GenericPlanPackage ipkg srcpkg'
+mapConfiguredPackage
+ :: (srcpkg -> srcpkg')
+ -> InstallPlan.GenericPlanPackage ipkg srcpkg
+ -> InstallPlan.GenericPlanPackage ipkg srcpkg'
mapConfiguredPackage f (InstallPlan.Configured pkg) =
InstallPlan.Configured (f pkg)
mapConfiguredPackage f (InstallPlan.Installed pkg) =
@@ -3122,40 +3524,46 @@ mapConfiguredPackage _ (InstallPlan.PreExisting pkg) =
-- | Try to remove the given targets from the install plan.
--
-- This is not always possible.
---
-pruneInstallPlanToDependencies :: Set UnitId
- -> ElaboratedInstallPlan
- -> Either CannotPruneDependencies
- ElaboratedInstallPlan
+pruneInstallPlanToDependencies
+ :: Set UnitId
+ -> ElaboratedInstallPlan
+ -> Either
+ CannotPruneDependencies
+ ElaboratedInstallPlan
pruneInstallPlanToDependencies pkgTargets installPlan =
- assert (all (isJust . InstallPlan.lookup installPlan)
- (Set.toList pkgTargets)) $
-
- fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
- . checkBrokenDeps
- . Graph.fromDistinctList
- . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)
- . InstallPlan.toList
- $ installPlan
- where
- -- Our strategy is to remove the packages we don't want and then check
- -- if the remaining graph is broken or not, ie any packages with dangling
- -- dependencies. If there are then we cannot prune the given targets.
- checkBrokenDeps :: Graph.Graph ElaboratedPlanPackage
- -> Either CannotPruneDependencies
- (Graph.Graph ElaboratedPlanPackage)
- checkBrokenDeps graph =
- case Graph.broken graph of
- [] -> Right graph
- brokenPackages ->
- Left $ CannotPruneDependencies
- [ (pkg, missingDeps)
- | (pkg, missingDepIds) <- brokenPackages
- , let missingDeps = mapMaybe lookupDep missingDepIds
- ]
- where
- -- lookup in the original unpruned graph
- lookupDep = InstallPlan.lookup installPlan
+ assert
+ ( all
+ (isJust . InstallPlan.lookup installPlan)
+ (Set.toList pkgTargets)
+ )
+ $ fmap (InstallPlan.new (InstallPlan.planIndepGoals installPlan))
+ . checkBrokenDeps
+ . Graph.fromDistinctList
+ . filter (\pkg -> installedUnitId pkg `Set.notMember` pkgTargets)
+ . InstallPlan.toList
+ $ installPlan
+ where
+ -- Our strategy is to remove the packages we don't want and then check
+ -- if the remaining graph is broken or not, ie any packages with dangling
+ -- dependencies. If there are then we cannot prune the given targets.
+ checkBrokenDeps
+ :: Graph.Graph ElaboratedPlanPackage
+ -> Either
+ CannotPruneDependencies
+ (Graph.Graph ElaboratedPlanPackage)
+ checkBrokenDeps graph =
+ case Graph.broken graph of
+ [] -> Right graph
+ brokenPackages ->
+ Left $
+ CannotPruneDependencies
+ [ (pkg, missingDeps)
+ | (pkg, missingDepIds) <- brokenPackages
+ , let missingDeps = mapMaybe lookupDep missingDepIds
+ ]
+ where
+ -- lookup in the original unpruned graph
+ lookupDep = InstallPlan.lookup installPlan
-- | It is not always possible to prune to only the dependencies of a set of
-- targets. It may be the case that removing a package leaves something else
@@ -3163,13 +3571,14 @@ pruneInstallPlanToDependencies pkgTargets installPlan =
--
-- This lists all the packages that would be broken, and their dependencies
-- that would be missing if we did prune.
---
-newtype CannotPruneDependencies =
- CannotPruneDependencies [(ElaboratedPlanPackage,
- [ElaboratedPlanPackage])]
+newtype CannotPruneDependencies
+ = CannotPruneDependencies
+ [ ( ElaboratedPlanPackage
+ , [ElaboratedPlanPackage]
+ )
+ ]
deriving (Show)
-
---------------------------
-- Setup.hs script policy
--
@@ -3200,33 +3609,31 @@ newtype CannotPruneDependencies =
-- data SetupScriptStyle = ... -- see ProjectPlanning.Types
-- | Work out the 'SetupScriptStyle' given the package description.
---
packageSetupScriptStyle :: PD.PackageDescription -> SetupScriptStyle
packageSetupScriptStyle pkg
| buildType == PD.Custom
, Just setupbi <- PD.setupBuildInfo pkg -- does have a custom-setup stanza
- , not (PD.defaultSetupDepends setupbi) -- but not one we added internally
- = SetupCustomExplicitDeps
-
+ , not (PD.defaultSetupDepends setupbi) -- but not one we added internally
+ =
+ SetupCustomExplicitDeps
| buildType == PD.Custom
, Just setupbi <- PD.setupBuildInfo pkg -- we get this case post-solver as
- , PD.defaultSetupDepends setupbi -- the solver fills in the deps
- = SetupCustomImplicitDeps
-
+ , PD.defaultSetupDepends setupbi -- the solver fills in the deps
+ =
+ SetupCustomImplicitDeps
| buildType == PD.Custom
- , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver
- = SetupCustomImplicitDeps
-
+ , Nothing <- PD.setupBuildInfo pkg -- we get this case pre-solver
+ =
+ SetupCustomImplicitDeps
-- here we should fail.
- | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against
- = SetupNonCustomExternalLib
-
- | otherwise
- = SetupNonCustomInternalLib
+ | PD.specVersion pkg > cabalSpecLatest -- one cabal-install is built against
+ =
+ SetupNonCustomExternalLib
+ | otherwise =
+ SetupNonCustomInternalLib
where
buildType = PD.buildType pkg
-
-- | Part of our Setup.hs handling policy is implemented by getting the solver
-- to work out setup dependencies for packages. The solver already handles
-- packages that explicitly specify setup dependencies, but we can also tell
@@ -3245,56 +3652,61 @@ packageSetupScriptStyle pkg
-- Note in addition to adding default setup deps, we also use
-- 'addSetupCabalMinVersionConstraint' (in 'planPackages') to require
-- @Cabal >= 1.20@ for Setup scripts.
---
-defaultSetupDeps :: Compiler -> Platform
- -> PD.PackageDescription
- -> Maybe [Dependency]
+defaultSetupDeps
+ :: Compiler
+ -> Platform
+ -> PD.PackageDescription
+ -> Maybe [Dependency]
defaultSetupDeps compiler platform pkg =
- case packageSetupScriptStyle pkg of
-
- -- For packages with build type custom that do not specify explicit
- -- setup dependencies, we add a dependency on Cabal and a number
- -- of other packages.
- SetupCustomImplicitDeps ->
- Just $
+ case packageSetupScriptStyle pkg of
+ -- For packages with build type custom that do not specify explicit
+ -- setup dependencies, we add a dependency on Cabal and a number
+ -- of other packages.
+ SetupCustomImplicitDeps ->
+ Just $
[ Dependency depPkgname anyVersion mainLibSet
- | depPkgname <- legacyCustomSetupPkgs compiler platform ] ++
+ | depPkgname <- legacyCustomSetupPkgs compiler platform
+ ]
+ ++ [ Dependency cabalPkgname cabalConstraint mainLibSet
+ | packageName pkg /= cabalPkgname
+ ]
+ where
+ -- The Cabal dep is slightly special:
+ -- \* We omit the dep for the Cabal lib itself, since it bootstraps.
+ -- \* We constrain it to be < 1.25
+ --
+ -- Note: we also add a global constraint to require Cabal >= 1.20
+ -- for Setup scripts (see use addSetupCabalMinVersionConstraint).
+ --
+ cabalConstraint =
+ orLaterVersion (csvToVersion (PD.specVersion pkg))
+ `intersectVersionRanges` earlierVersion cabalCompatMaxVer
+ -- The idea here is that at some point we will make significant
+ -- breaking changes to the Cabal API that Setup.hs scripts use.
+ -- So for old custom Setup scripts that do not specify explicit
+ -- constraints, we constrain them to use a compatible Cabal version.
+ cabalCompatMaxVer = mkVersion [1, 25]
+
+ -- For other build types (like Simple) if we still need to compile an
+ -- external Setup.hs, it'll be one of the simple ones that only depends
+ -- on Cabal and base.
+ SetupNonCustomExternalLib ->
+ Just
[ Dependency cabalPkgname cabalConstraint mainLibSet
- | packageName pkg /= cabalPkgname ]
- where
- -- The Cabal dep is slightly special:
- -- * We omit the dep for the Cabal lib itself, since it bootstraps.
- -- * We constrain it to be < 1.25
- --
- -- Note: we also add a global constraint to require Cabal >= 1.20
- -- for Setup scripts (see use addSetupCabalMinVersionConstraint).
- --
- cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg))
- `intersectVersionRanges`
- earlierVersion cabalCompatMaxVer
- -- The idea here is that at some point we will make significant
- -- breaking changes to the Cabal API that Setup.hs scripts use.
- -- So for old custom Setup scripts that do not specify explicit
- -- constraints, we constrain them to use a compatible Cabal version.
- cabalCompatMaxVer = mkVersion [1,25]
-
- -- For other build types (like Simple) if we still need to compile an
- -- external Setup.hs, it'll be one of the simple ones that only depends
- -- on Cabal and base.
- SetupNonCustomExternalLib ->
- Just [ Dependency cabalPkgname cabalConstraint mainLibSet
- , Dependency basePkgname anyVersion mainLibSet]
- where
- cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg))
-
- -- The internal setup wrapper method has no deps at all.
- SetupNonCustomInternalLib -> Just []
-
- -- This case gets ruled out by the caller, planPackages, see the note
- -- above in the SetupCustomImplicitDeps case.
- SetupCustomExplicitDeps ->
- error $ "defaultSetupDeps: called for a package with explicit "
- ++ "setup deps: " ++ prettyShow (packageId pkg)
+ , Dependency basePkgname anyVersion mainLibSet
+ ]
+ where
+ cabalConstraint = orLaterVersion (csvToVersion (PD.specVersion pkg))
+
+ -- The internal setup wrapper method has no deps at all.
+ SetupNonCustomInternalLib -> Just []
+ -- This case gets ruled out by the caller, planPackages, see the note
+ -- above in the SetupCustomImplicitDeps case.
+ SetupCustomExplicitDeps ->
+ error $
+ "defaultSetupDeps: called for a package with explicit "
+ ++ "setup deps: "
+ ++ prettyShow (packageId pkg)
where
-- we require one less
--
@@ -3308,58 +3720,65 @@ defaultSetupDeps compiler platform pkg =
-- This depends somewhat on the 'SetupScriptStyle' but most cases are a result
-- of what the solver picked for us, based on the explicit setup deps or the
-- ones added implicitly by 'defaultSetupDeps'.
---
-packageSetupScriptSpecVersion :: SetupScriptStyle
- -> PD.PackageDescription
- -> Graph.Graph NonSetupLibDepSolverPlanPackage
- -> ComponentDeps [SolverId]
- -> Version
-
+packageSetupScriptSpecVersion
+ :: SetupScriptStyle
+ -> PD.PackageDescription
+ -> Graph.Graph NonSetupLibDepSolverPlanPackage
+ -> ComponentDeps [SolverId]
+ -> Version
-- We're going to be using the internal Cabal library, so the spec version of
-- that is simply the version of the Cabal library that cabal-install has been
-- built with.
packageSetupScriptSpecVersion SetupNonCustomInternalLib _ _ _ =
- cabalVersion
-
+ cabalVersion
-- If we happen to be building the Cabal lib itself then because that
-- bootstraps itself then we use the version of the lib we're building.
packageSetupScriptSpecVersion SetupCustomImplicitDeps pkg _ _
- | packageName pkg == cabalPkgname
- = packageVersion pkg
-
+ | packageName pkg == cabalPkgname =
+ packageVersion pkg
-- In all other cases we have a look at what version of the Cabal lib the
-- solver picked. Or if it didn't depend on Cabal at all (which is very rare)
-- then we look at the .cabal file to see what spec version it declares.
packageSetupScriptSpecVersion _ pkg libDepGraph deps =
- case find ((cabalPkgname ==) . packageName) setupLibDeps of
- Just dep -> packageVersion dep
- Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg))
+ case find ((cabalPkgname ==) . packageName) setupLibDeps of
+ Just dep -> packageVersion dep
+ Nothing -> mkVersion (cabalSpecMinimumLibraryVersion (PD.specVersion pkg))
where
- setupLibDeps = map packageId $ fromMaybe [] $
- Graph.closure libDepGraph (CD.setupDeps deps)
-
+ setupLibDeps =
+ map packageId $
+ fromMaybe [] $
+ Graph.closure libDepGraph (CD.setupDeps deps)
cabalPkgname, basePkgname :: PackageName
cabalPkgname = mkPackageName "Cabal"
-basePkgname = mkPackageName "base"
-
+basePkgname = mkPackageName "base"
legacyCustomSetupPkgs :: Compiler -> Platform -> [PackageName]
legacyCustomSetupPkgs compiler (Platform _ os) =
- map mkPackageName $
- [ "array", "base", "binary", "bytestring", "containers"
- , "deepseq", "directory", "filepath", "pretty"
- , "process", "time", "transformers" ]
- ++ [ "Win32" | os == Windows ]
- ++ [ "unix" | os /= Windows ]
- ++ [ "ghc-prim" | isGHC ]
- ++ [ "template-haskell" | isGHC ]
- ++ [ "old-time" | notGHC710 ]
+ map mkPackageName $
+ [ "array"
+ , "base"
+ , "binary"
+ , "bytestring"
+ , "containers"
+ , "deepseq"
+ , "directory"
+ , "filepath"
+ , "pretty"
+ , "process"
+ , "time"
+ , "transformers"
+ ]
+ ++ ["Win32" | os == Windows]
+ ++ ["unix" | os /= Windows]
+ ++ ["ghc-prim" | isGHC]
+ ++ ["template-haskell" | isGHC]
+ ++ ["old-time" | notGHC710]
where
isGHC = compilerCompatFlavor GHC compiler
notGHC710 = case compilerCompatVersion GHC compiler of
- Nothing -> False
- Just v -> v <= mkVersion [7,9]
+ Nothing -> False
+ Just v -> v <= mkVersion [7, 9]
-- The other aspects of our Setup.hs policy lives here where we decide on
-- the 'SetupScriptOptions'.
@@ -3371,436 +3790,473 @@ legacyCustomSetupPkgs compiler (Platform _ os) =
-- be tricky since we would have to allow the Setup access to all the packages
-- in the store and local dbs.
-setupHsScriptOptions :: ElaboratedReadyPackage
- -> ElaboratedInstallPlan
- -> ElaboratedSharedConfig
- -> DistDirLayout
- -> FilePath
- -> FilePath
- -> Bool
- -> Lock
- -> SetupScriptOptions
+setupHsScriptOptions
+ :: ElaboratedReadyPackage
+ -> ElaboratedInstallPlan
+ -> ElaboratedSharedConfig
+ -> DistDirLayout
+ -> FilePath
+ -> FilePath
+ -> Bool
+ -> Lock
+ -> SetupScriptOptions
-- TODO: Fix this so custom is a separate component. Custom can ALWAYS
-- be a separate component!!!
-setupHsScriptOptions (ReadyPackage elab@ElaboratedConfiguredPackage{..})
- plan ElaboratedSharedConfig{..} distdir srcdir builddir
- isParallelBuild cacheLock =
- SetupScriptOptions {
- useCabalVersion = thisVersion elabSetupScriptCliVersion,
- useCabalSpecVersion = Just elabSetupScriptCliVersion,
- useCompiler = Just pkgConfigCompiler,
- usePlatform = Just pkgConfigPlatform,
- usePackageDB = elabSetupPackageDBStack,
- usePackageIndex = Nothing,
- useDependencies = [ (uid, srcid)
- | ConfiguredId srcid (Just (CLibName LMainLibName)) uid
- <- elabSetupDependencies elab ],
- useDependenciesExclusive = True,
- useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps,
- useProgramDb = pkgConfigCompilerProgs,
- useDistPref = builddir,
- useLoggingHandle = Nothing, -- this gets set later
- useWorkingDir = Just srcdir,
- useExtraPathEnv = elabExeDependencyPaths elab,
- useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan,
- useWin32CleanHack = False, --TODO: [required eventually]
- forceExternalSetupMethod = isParallelBuild,
- setupCacheLock = Just cacheLock,
- isInteractive = False
- }
-
+setupHsScriptOptions
+ (ReadyPackage elab@ElaboratedConfiguredPackage{..})
+ plan
+ ElaboratedSharedConfig{..}
+ distdir
+ srcdir
+ builddir
+ isParallelBuild
+ cacheLock =
+ SetupScriptOptions
+ { useCabalVersion = thisVersion elabSetupScriptCliVersion
+ , useCabalSpecVersion = Just elabSetupScriptCliVersion
+ , useCompiler = Just pkgConfigCompiler
+ , usePlatform = Just pkgConfigPlatform
+ , usePackageDB = elabSetupPackageDBStack
+ , usePackageIndex = Nothing
+ , useDependencies =
+ [ (uid, srcid)
+ | ConfiguredId srcid (Just (CLibName LMainLibName)) uid <-
+ elabSetupDependencies elab
+ ]
+ , useDependenciesExclusive = True
+ , useVersionMacros = elabSetupScriptStyle == SetupCustomExplicitDeps
+ , useProgramDb = pkgConfigCompilerProgs
+ , useDistPref = builddir
+ , useLoggingHandle = Nothing -- this gets set later
+ , useWorkingDir = Just srcdir
+ , useExtraPathEnv = elabExeDependencyPaths elab
+ , useExtraEnvOverrides = dataDirsEnvironmentForPlan distdir plan
+ , useWin32CleanHack = False -- TODO: [required eventually]
+ , forceExternalSetupMethod = isParallelBuild
+ , setupCacheLock = Just cacheLock
+ , isInteractive = False
+ }
-- | To be used for the input for elaborateInstallPlan.
--
-- TODO: [code cleanup] make InstallDirs.defaultInstallDirs pure.
---
-userInstallDirTemplates :: Compiler
- -> IO InstallDirs.InstallDirTemplates
+userInstallDirTemplates
+ :: Compiler
+ -> IO InstallDirs.InstallDirTemplates
userInstallDirTemplates compiler = do
- InstallDirs.defaultInstallDirs
- (compilerFlavor compiler)
- True -- user install
- False -- unused
-
-storePackageInstallDirs :: StoreDirLayout
- -> CompilerId
- -> InstalledPackageId
- -> InstallDirs.InstallDirs FilePath
+ InstallDirs.defaultInstallDirs
+ (compilerFlavor compiler)
+ True -- user install
+ False -- unused
+
+storePackageInstallDirs
+ :: StoreDirLayout
+ -> CompilerId
+ -> InstalledPackageId
+ -> InstallDirs.InstallDirs FilePath
storePackageInstallDirs storeDirLayout compid ipkgid =
storePackageInstallDirs' storeDirLayout compid $ newSimpleUnitId ipkgid
-storePackageInstallDirs' :: StoreDirLayout
- -> CompilerId
- -> UnitId
- -> InstallDirs.InstallDirs FilePath
-storePackageInstallDirs' StoreDirLayout{ storePackageDirectory
- , storeDirectory }
- compid unitid =
- InstallDirs.InstallDirs {..}
- where
- store = storeDirectory compid
- prefix = storePackageDirectory compid unitid
- bindir = prefix </> "bin"
- libdir = prefix </> "lib"
- libsubdir = ""
- -- Note: on macOS, we place libraries into
- -- @store/lib@ to work around the load
- -- command size limit of macOSs mach-o linker.
- -- See also @PackageHash.hashedInstalledPackageIdVeryShort@
- dynlibdir | buildOS == OSX = store </> "lib"
- | otherwise = libdir
- flibdir = libdir
- libexecdir = prefix </> "libexec"
- libexecsubdir= ""
- includedir = libdir </> "include"
- datadir = prefix </> "share"
- datasubdir = ""
- docdir = datadir </> "doc"
- mandir = datadir </> "man"
- htmldir = docdir </> "html"
- haddockdir = htmldir
- sysconfdir = prefix </> "etc"
-
-
-computeInstallDirs :: StoreDirLayout
- -> InstallDirs.InstallDirTemplates
- -> ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
- -> InstallDirs.InstallDirs FilePath
-computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
- | elabBuildStyle elab == BuildInplaceOnly
- -- use the ordinary default install dirs
- = (InstallDirs.absoluteInstallDirs
- (elabPkgSourceId elab)
- (elabUnitId elab)
- (compilerInfo (pkgConfigCompiler elaboratedShared))
- InstallDirs.NoCopyDest
- (pkgConfigPlatform elaboratedShared)
- defaultInstallDirs) {
-
- -- absoluteInstallDirs sets these as 'undefined' but we have
- -- to use them as "Setup.hs configure" args
- InstallDirs.libsubdir = "",
- InstallDirs.libexecsubdir = "",
- InstallDirs.datasubdir = ""
+storePackageInstallDirs'
+ :: StoreDirLayout
+ -> CompilerId
+ -> UnitId
+ -> InstallDirs.InstallDirs FilePath
+storePackageInstallDirs'
+ StoreDirLayout
+ { storePackageDirectory
+ , storeDirectory
}
-
- | otherwise
- -- use special simplified install dirs
- = storePackageInstallDirs'
- storeDirLayout
- (compilerId (pkgConfigCompiler elaboratedShared))
- (elabUnitId elab)
-
-
---TODO: [code cleanup] perhaps reorder this code
+ compid
+ unitid =
+ InstallDirs.InstallDirs{..}
+ where
+ store = storeDirectory compid
+ prefix = storePackageDirectory compid unitid
+ bindir = prefix </> "bin"
+ libdir = prefix </> "lib"
+ libsubdir = ""
+ -- Note: on macOS, we place libraries into
+ -- @store/lib@ to work around the load
+ -- command size limit of macOSs mach-o linker.
+ -- See also @PackageHash.hashedInstalledPackageIdVeryShort@
+ dynlibdir
+ | buildOS == OSX = store </> "lib"
+ | otherwise = libdir
+ flibdir = libdir
+ libexecdir = prefix </> "libexec"
+ libexecsubdir = ""
+ includedir = libdir </> "include"
+ datadir = prefix </> "share"
+ datasubdir = ""
+ docdir = datadir </> "doc"
+ mandir = datadir </> "man"
+ htmldir = docdir </> "html"
+ haddockdir = htmldir
+ sysconfdir = prefix </> "etc"
+
+computeInstallDirs
+ :: StoreDirLayout
+ -> InstallDirs.InstallDirTemplates
+ -> ElaboratedSharedConfig
+ -> ElaboratedConfiguredPackage
+ -> InstallDirs.InstallDirs FilePath
+computeInstallDirs storeDirLayout defaultInstallDirs elaboratedShared elab
+ | elabBuildStyle elab == BuildInplaceOnly =
+ -- use the ordinary default install dirs
+ ( InstallDirs.absoluteInstallDirs
+ (elabPkgSourceId elab)
+ (elabUnitId elab)
+ (compilerInfo (pkgConfigCompiler elaboratedShared))
+ InstallDirs.NoCopyDest
+ (pkgConfigPlatform elaboratedShared)
+ defaultInstallDirs
+ )
+ { -- absoluteInstallDirs sets these as 'undefined' but we have
+ -- to use them as "Setup.hs configure" args
+ InstallDirs.libsubdir = ""
+ , InstallDirs.libexecsubdir = ""
+ , InstallDirs.datasubdir = ""
+ }
+ | otherwise =
+ -- use special simplified install dirs
+ storePackageInstallDirs'
+ storeDirLayout
+ (compilerId (pkgConfigCompiler elaboratedShared))
+ (elabUnitId elab)
+
+-- TODO: [code cleanup] perhaps reorder this code
-- based on the ElaboratedInstallPlan + ElaboratedSharedConfig,
-- make the various Setup.hs {configure,build,copy} flags
-
-setupHsConfigureFlags :: ElaboratedReadyPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> Cabal.ConfigFlags
-setupHsConfigureFlags (ReadyPackage elab@ElaboratedConfiguredPackage{..})
- sharedConfig@ElaboratedSharedConfig{..}
- verbosity builddir =
- sanityCheckElaboratedConfiguredPackage sharedConfig elab
- (Cabal.ConfigFlags {..})
- where
- configArgs = mempty -- unused, passed via args
- configDistPref = toFlag builddir
- configCabalFilePath = mempty
- configVerbosity = toFlag verbosity
-
- configInstantiateWith = Map.toList elabInstantiatedWith
-
- configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese
- configIPID = case elabPkgOrComp of
- ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg))
- ElabComponent _ -> mempty
- configCID = case elabPkgOrComp of
- ElabPackage _ -> mempty
- ElabComponent _ -> toFlag elabComponentId
-
- configProgramPaths = Map.toList elabProgramPaths
- configProgramArgs
- | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True
- -- workaround for <https://github.com/haskell/cabal/issues/4010>
- --
- -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.
- -- custom Setup.hs scripts calling out to GHC even when going via
- -- @runProgram ghcProgram@, as e.g. happy does in its
- -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>
- -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)
- --
- -- So for now, let's pass the rather harmless and idempotent
- -- `-hide-all-packages` flag to all invocations (which has
- -- the benefit that every GHC invocation starts with a
- -- consistently well-defined clean slate) until we find a
- -- better way.
- = Map.toList $
- Map.insertWith (++) "ghc" ["-hide-all-packages"]
- elabProgramArgs
- configProgramPathExtra = toNubList elabProgramPathExtra
- configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler)
- configHcPath = mempty -- we use configProgramPaths instead
- configHcPkg = mempty -- we use configProgramPaths instead
-
- configVanillaLib = toFlag elabVanillaLib
- configSharedLib = toFlag elabSharedLib
- configStaticLib = toFlag elabStaticLib
-
- configDynExe = toFlag elabDynExe
- configFullyStaticExe = toFlag elabFullyStaticExe
- configGHCiLib = toFlag elabGHCiLib
- configProfExe = mempty
- configProfLib = toFlag elabProfLib
- configProf = toFlag elabProfExe
-
- -- configProfDetail is for exe+lib, but overridden by configProfLibDetail
- -- so we specify both so we can specify independently
- configProfDetail = toFlag elabProfExeDetail
- configProfLibDetail = toFlag elabProfLibDetail
-
- configCoverage = toFlag elabCoverage
- configLibCoverage = mempty
-
- configOptimization = toFlag elabOptimization
- configSplitSections = toFlag elabSplitSections
- configSplitObjs = toFlag elabSplitObjs
- configStripExes = toFlag elabStripExes
- configStripLibs = toFlag elabStripLibs
- configDebugInfo = toFlag elabDebugInfo
- configDumpBuildInfo = toFlag elabDumpBuildInfo
-
- configConfigurationsFlags = elabFlagAssignment
- configConfigureArgs = elabConfigureScriptArgs
- configExtraLibDirs = elabExtraLibDirs
- configExtraLibDirsStatic = elabExtraLibDirsStatic
- configExtraFrameworkDirs = elabExtraFrameworkDirs
- configExtraIncludeDirs = elabExtraIncludeDirs
- configProgPrefix = maybe mempty toFlag elabProgPrefix
- configProgSuffix = maybe mempty toFlag elabProgSuffix
-
- configInstallDirs = fmap (toFlag . InstallDirs.toPathTemplate)
- elabInstallDirs
-
- -- we only use configDependencies, unless we're talking to an old Cabal
- -- in which case we use configConstraints
- -- NB: This does NOT use InstallPlan.depends, which includes executable
- -- dependencies which should NOT be fed in here (also you don't have
- -- enough info anyway)
- configDependencies = [ GivenComponent
- (packageName srcid)
- ln
- cid
- | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab
- , let ln = case mb_cn
- of Just (CLibName lname) -> lname
- Just _ -> error "non-library dependency"
- Nothing -> LMainLibName
- ]
- configConstraints =
+setupHsConfigureFlags
+ :: ElaboratedReadyPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> Cabal.ConfigFlags
+setupHsConfigureFlags
+ (ReadyPackage elab@ElaboratedConfiguredPackage{..})
+ sharedConfig@ElaboratedSharedConfig{..}
+ verbosity
+ builddir =
+ sanityCheckElaboratedConfiguredPackage
+ sharedConfig
+ elab
+ (Cabal.ConfigFlags{..})
+ where
+ configArgs = mempty -- unused, passed via args
+ configDistPref = toFlag builddir
+ configCabalFilePath = mempty
+ configVerbosity = toFlag verbosity
+
+ configInstantiateWith = Map.toList elabInstantiatedWith
+
+ configDeterministic = mempty -- doesn't matter, configIPID/configCID overridese
+ configIPID = case elabPkgOrComp of
+ ElabPackage pkg -> toFlag (prettyShow (pkgInstalledId pkg))
+ ElabComponent _ -> mempty
+ configCID = case elabPkgOrComp of
+ ElabPackage _ -> mempty
+ ElabComponent _ -> toFlag elabComponentId
+
+ configProgramPaths = Map.toList elabProgramPaths
+ configProgramArgs
+ | {- elabSetupScriptCliVersion < mkVersion [1,24,3] -} True =
+ -- workaround for <https://github.com/haskell/cabal/issues/4010>
+ --
+ -- It turns out, that even with Cabal 2.0, there's still cases such as e.g.
+ -- custom Setup.hs scripts calling out to GHC even when going via
+ -- @runProgram ghcProgram@, as e.g. happy does in its
+ -- <http://hackage.haskell.org/package/happy-1.19.5/src/Setup.lhs>
+ -- (see also <https://github.com/haskell/cabal/pull/4433#issuecomment-299396099>)
+ --
+ -- So for now, let's pass the rather harmless and idempotent
+ -- `-hide-all-packages` flag to all invocations (which has
+ -- the benefit that every GHC invocation starts with a
+ -- consistently well-defined clean slate) until we find a
+ -- better way.
+ Map.toList $
+ Map.insertWith
+ (++)
+ "ghc"
+ ["-hide-all-packages"]
+ elabProgramArgs
+ configProgramPathExtra = toNubList elabProgramPathExtra
+ configHcFlavor = toFlag (compilerFlavor pkgConfigCompiler)
+ configHcPath = mempty -- we use configProgramPaths instead
+ configHcPkg = mempty -- we use configProgramPaths instead
+ configVanillaLib = toFlag elabVanillaLib
+ configSharedLib = toFlag elabSharedLib
+ configStaticLib = toFlag elabStaticLib
+
+ configDynExe = toFlag elabDynExe
+ configFullyStaticExe = toFlag elabFullyStaticExe
+ configGHCiLib = toFlag elabGHCiLib
+ configProfExe = mempty
+ configProfLib = toFlag elabProfLib
+ configProf = toFlag elabProfExe
+
+ -- configProfDetail is for exe+lib, but overridden by configProfLibDetail
+ -- so we specify both so we can specify independently
+ configProfDetail = toFlag elabProfExeDetail
+ configProfLibDetail = toFlag elabProfLibDetail
+
+ configCoverage = toFlag elabCoverage
+ configLibCoverage = mempty
+
+ configOptimization = toFlag elabOptimization
+ configSplitSections = toFlag elabSplitSections
+ configSplitObjs = toFlag elabSplitObjs
+ configStripExes = toFlag elabStripExes
+ configStripLibs = toFlag elabStripLibs
+ configDebugInfo = toFlag elabDebugInfo
+ configDumpBuildInfo = toFlag elabDumpBuildInfo
+
+ configConfigurationsFlags = elabFlagAssignment
+ configConfigureArgs = elabConfigureScriptArgs
+ configExtraLibDirs = elabExtraLibDirs
+ configExtraLibDirsStatic = elabExtraLibDirsStatic
+ configExtraFrameworkDirs = elabExtraFrameworkDirs
+ configExtraIncludeDirs = elabExtraIncludeDirs
+ configProgPrefix = maybe mempty toFlag elabProgPrefix
+ configProgSuffix = maybe mempty toFlag elabProgSuffix
+
+ configInstallDirs =
+ fmap
+ (toFlag . InstallDirs.toPathTemplate)
+ elabInstallDirs
+
+ -- we only use configDependencies, unless we're talking to an old Cabal
+ -- in which case we use configConstraints
+ -- NB: This does NOT use InstallPlan.depends, which includes executable
+ -- dependencies which should NOT be fed in here (also you don't have
+ -- enough info anyway)
+ configDependencies =
+ [ GivenComponent
+ (packageName srcid)
+ ln
+ cid
+ | ConfiguredId srcid mb_cn cid <- elabLibDependencies elab
+ , let ln = case mb_cn of
+ Just (CLibName lname) -> lname
+ Just _ -> error "non-library dependency"
+ Nothing -> LMainLibName
+ ]
+ configConstraints =
case elabPkgOrComp of
- ElabPackage _ ->
- [ thisPackageVersionConstraint srcid
- | ConfiguredId srcid _ _uid <- elabLibDependencies elab ]
- ElabComponent _ -> []
-
-
- -- explicitly clear, then our package db stack
- -- TODO: [required eventually] have to do this differently for older Cabal versions
- configPackageDBs = Nothing : map Just elabBuildPackageDBStack
-
- configTests = case elabPkgOrComp of
- ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)
- ElabComponent _ -> mempty
- configBenchmarks = case elabPkgOrComp of
- ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)
- ElabComponent _ -> mempty
-
- configExactConfiguration = toFlag True
- configFlagError = mempty --TODO: [research required] appears not to be implemented
- configRelocatable = mempty --TODO: [research required] ???
- configScratchDir = mempty -- never use
- configUserInstall = mempty -- don't rely on defaults
- configPrograms_ = mempty -- never use, shouldn't exist
- configUseResponseFiles = mempty
- configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler
-
-setupHsConfigureArgs :: ElaboratedConfiguredPackage
- -> [String]
-setupHsConfigureArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ }) = []
-setupHsConfigureArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }) =
- [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)]
+ ElabPackage _ ->
+ [ thisPackageVersionConstraint srcid
+ | ConfiguredId srcid _ _uid <- elabLibDependencies elab
+ ]
+ ElabComponent _ -> []
+
+ -- explicitly clear, then our package db stack
+ -- TODO: [required eventually] have to do this differently for older Cabal versions
+ configPackageDBs = Nothing : map Just elabBuildPackageDBStack
+
+ configTests = case elabPkgOrComp of
+ ElabPackage pkg -> toFlag (TestStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)
+ ElabComponent _ -> mempty
+ configBenchmarks = case elabPkgOrComp of
+ ElabPackage pkg -> toFlag (BenchStanzas `optStanzaSetMember` pkgStanzasEnabled pkg)
+ ElabComponent _ -> mempty
+
+ configExactConfiguration = toFlag True
+ configFlagError = mempty -- TODO: [research required] appears not to be implemented
+ configRelocatable = mempty -- TODO: [research required] ???
+ configScratchDir = mempty -- never use
+ configUserInstall = mempty -- don't rely on defaults
+ configPrograms_ = mempty -- never use, shouldn't exist
+ configUseResponseFiles = mempty
+ configAllowDependingOnPrivateLibs = Flag $ not $ libraryVisibilitySupported pkgConfigCompiler
+
+setupHsConfigureArgs
+ :: ElaboratedConfiguredPackage
+ -> [String]
+setupHsConfigureArgs (ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _}) = []
+setupHsConfigureArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp}) =
+ [showComponentTarget (packageId elab) (ComponentTarget cname WholeComponent)]
where
- cname = fromMaybe (error "setupHsConfigureArgs: trying to configure setup")
- (compComponentName comp)
-
-setupHsBuildFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> Cabal.BuildFlags
+ cname =
+ fromMaybe
+ (error "setupHsConfigureArgs: trying to configure setup")
+ (compComponentName comp)
+
+setupHsBuildFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> Cabal.BuildFlags
setupHsBuildFlags _ _ verbosity builddir =
- Cabal.BuildFlags {
- buildProgramPaths = mempty, --unused, set at configure time
- buildProgramArgs = mempty, --unused, set at configure time
- buildVerbosity = toFlag verbosity,
- buildDistPref = toFlag builddir,
- buildNumJobs = mempty, --TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),
- buildArgs = mempty, -- unused, passed via args not flags
- buildCabalFilePath= mempty
+ Cabal.BuildFlags
+ { buildProgramPaths = mempty -- unused, set at configure time
+ , buildProgramArgs = mempty -- unused, set at configure time
+ , buildVerbosity = toFlag verbosity
+ , buildDistPref = toFlag builddir
+ , buildNumJobs = mempty -- TODO: [nice to have] sometimes want to use toFlag (Just numBuildJobs),
+ , buildArgs = mempty -- unused, passed via args not flags
+ , buildCabalFilePath = mempty
}
-
setupHsBuildArgs :: ElaboratedConfiguredPackage -> [String]
-setupHsBuildArgs elab@(ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage _ })
- -- Fix for #3335, don't pass build arguments if it's not supported
- | elabSetupScriptCliVersion elab >= mkVersion [1,17]
- = map (showComponentTarget (packageId elab)) (elabBuildTargets elab)
- | otherwise
- = []
-setupHsBuildArgs (ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent _ })
- = []
-
-
-setupHsTestFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> Cabal.TestFlags
-setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.TestFlags
- { testDistPref = toFlag builddir
- , testVerbosity = toFlag verbosity
- , testMachineLog = maybe mempty toFlag elabTestMachineLog
- , testHumanLog = maybe mempty toFlag elabTestHumanLog
+setupHsBuildArgs elab@(ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage _})
+ -- Fix for #3335, don't pass build arguments if it's not supported
+ | elabSetupScriptCliVersion elab >= mkVersion [1, 17] =
+ map (showComponentTarget (packageId elab)) (elabBuildTargets elab)
+ | otherwise =
+ []
+setupHsBuildArgs (ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent _}) =
+ []
+
+setupHsTestFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> Cabal.TestFlags
+setupHsTestFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir =
+ Cabal.TestFlags
+ { testDistPref = toFlag builddir
+ , testVerbosity = toFlag verbosity
+ , testMachineLog = maybe mempty toFlag elabTestMachineLog
+ , testHumanLog = maybe mempty toFlag elabTestHumanLog
, testShowDetails = maybe (Flag Cabal.Always) toFlag elabTestShowDetails
- , testKeepTix = toFlag elabTestKeepTix
- , testWrapper = maybe mempty toFlag elabTestWrapper
+ , testKeepTix = toFlag elabTestKeepTix
+ , testWrapper = maybe mempty toFlag elabTestWrapper
, testFailWhenNoTestSuites = toFlag elabTestFailWhenNoTestSuites
- , testOptions = elabTestTestOptions
+ , testOptions = elabTestTestOptions
}
setupHsTestArgs :: ElaboratedConfiguredPackage -> [String]
-- TODO: Does the issue #3335 affects test as well
setupHsTestArgs elab =
- mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab)
-
+ mapMaybe (showTestComponentTarget (packageId elab)) (elabTestTargets elab)
-setupHsBenchFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> Cabal.BenchmarkFlags
-setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir = Cabal.BenchmarkFlags
- { benchmarkDistPref = toFlag builddir
+setupHsBenchFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> Cabal.BenchmarkFlags
+setupHsBenchFlags (ElaboratedConfiguredPackage{..}) _ verbosity builddir =
+ Cabal.BenchmarkFlags
+ { benchmarkDistPref = toFlag builddir
, benchmarkVerbosity = toFlag verbosity
- , benchmarkOptions = elabBenchmarkOptions
+ , benchmarkOptions = elabBenchmarkOptions
}
setupHsBenchArgs :: ElaboratedConfiguredPackage -> [String]
setupHsBenchArgs elab =
- mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab)
+ mapMaybe (showBenchComponentTarget (packageId elab)) (elabBenchTargets elab)
-
-setupHsReplFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> Cabal.ReplFlags
+setupHsReplFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> Cabal.ReplFlags
setupHsReplFlags _ sharedConfig verbosity builddir =
- Cabal.ReplFlags {
- replProgramPaths = mempty, --unused, set at configure time
- replProgramArgs = mempty, --unused, set at configure time
- replVerbosity = toFlag verbosity,
- replDistPref = toFlag builddir,
- replReload = mempty, --only used as callback from repl
- replReplOptions = pkgConfigReplOptions sharedConfig --runtime override for repl flags
+ Cabal.ReplFlags
+ { replProgramPaths = mempty -- unused, set at configure time
+ , replProgramArgs = mempty -- unused, set at configure time
+ , replVerbosity = toFlag verbosity
+ , replDistPref = toFlag builddir
+ , replReload = mempty -- only used as callback from repl
+ , replReplOptions = pkgConfigReplOptions sharedConfig -- runtime override for repl flags
}
-
setupHsReplArgs :: ElaboratedConfiguredPackage -> [String]
setupHsReplArgs elab =
- maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab)
- --TODO: should be able to give multiple modules in one component
+ maybe [] (\t -> [showComponentTarget (packageId elab) t]) (elabReplTarget elab)
+-- TODO: should be able to give multiple modules in one component
-setupHsCopyFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> FilePath
- -> Cabal.CopyFlags
+setupHsCopyFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> FilePath
+ -> Cabal.CopyFlags
setupHsCopyFlags _ _ verbosity builddir destdir =
- Cabal.CopyFlags {
- copyArgs = [], -- TODO: could use this to only copy what we enabled
- copyDest = toFlag (InstallDirs.CopyTo destdir),
- copyDistPref = toFlag builddir,
- copyVerbosity = toFlag verbosity,
- copyCabalFilePath = mempty
+ Cabal.CopyFlags
+ { copyArgs = [] -- TODO: could use this to only copy what we enabled
+ , copyDest = toFlag (InstallDirs.CopyTo destdir)
+ , copyDistPref = toFlag builddir
+ , copyVerbosity = toFlag verbosity
+ , copyCabalFilePath = mempty
}
-setupHsRegisterFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> FilePath
- -> Cabal.RegisterFlags
-setupHsRegisterFlags ElaboratedConfiguredPackage{..} _
- verbosity builddir pkgConfFile =
- Cabal.RegisterFlags {
- regPackageDB = mempty, -- misfeature
- regGenScript = mempty, -- never use
- regGenPkgConf = toFlag (Just pkgConfFile),
- regInPlace = case elabBuildStyle of
- BuildInplaceOnly -> toFlag True
- _ -> toFlag False,
- regPrintId = mempty, -- never use
- regDistPref = toFlag builddir,
- regArgs = [],
- regVerbosity = toFlag verbosity,
- regCabalFilePath = mempty
- }
+setupHsRegisterFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> FilePath
+ -> Cabal.RegisterFlags
+setupHsRegisterFlags
+ ElaboratedConfiguredPackage{..}
+ _
+ verbosity
+ builddir
+ pkgConfFile =
+ Cabal.RegisterFlags
+ { regPackageDB = mempty -- misfeature
+ , regGenScript = mempty -- never use
+ , regGenPkgConf = toFlag (Just pkgConfFile)
+ , regInPlace = case elabBuildStyle of
+ BuildInplaceOnly -> toFlag True
+ _ -> toFlag False
+ , regPrintId = mempty -- never use
+ , regDistPref = toFlag builddir
+ , regArgs = []
+ , regVerbosity = toFlag verbosity
+ , regCabalFilePath = mempty
+ }
-setupHsHaddockFlags :: ElaboratedConfiguredPackage
- -> ElaboratedSharedConfig
- -> Verbosity
- -> FilePath
- -> Cabal.HaddockFlags
+setupHsHaddockFlags
+ :: ElaboratedConfiguredPackage
+ -> ElaboratedSharedConfig
+ -> Verbosity
+ -> FilePath
+ -> Cabal.HaddockFlags
setupHsHaddockFlags (ElaboratedConfiguredPackage{..}) (ElaboratedSharedConfig{..}) verbosity builddir =
- Cabal.HaddockFlags {
- haddockProgramPaths =
+ Cabal.HaddockFlags
+ { haddockProgramPaths =
case lookupProgram haddockProgram pkgConfigCompilerProgs of
- Nothing -> mempty
- Just prg -> [( programName haddockProgram
- , locationPath (programLocation prg) )],
- haddockProgramArgs = mempty, --unused, set at configure time
- haddockHoogle = toFlag elabHaddockHoogle,
- haddockHtml = toFlag elabHaddockHtml,
- haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation,
- haddockForHackage = toFlag elabHaddockForHackage,
- haddockForeignLibs = toFlag elabHaddockForeignLibs,
- haddockExecutables = toFlag elabHaddockExecutables,
- haddockTestSuites = toFlag elabHaddockTestSuites,
- haddockBenchmarks = toFlag elabHaddockBenchmarks,
- haddockInternal = toFlag elabHaddockInternal,
- haddockCss = maybe mempty toFlag elabHaddockCss,
- haddockLinkedSource = toFlag elabHaddockLinkedSource,
- haddockQuickJump = toFlag elabHaddockQuickJump,
- haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss,
- haddockContents = maybe mempty toFlag elabHaddockContents,
- haddockDistPref = toFlag builddir,
- haddockKeepTempFiles = mempty, --TODO: from build settings
- haddockVerbosity = toFlag verbosity,
- haddockCabalFilePath = mempty,
- haddockIndex = maybe mempty toFlag elabHaddockIndex,
- haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl,
- haddockLib = maybe mempty toFlag elabHaddockLib,
- haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir,
- haddockArgs = mempty
+ Nothing -> mempty
+ Just prg ->
+ [
+ ( programName haddockProgram
+ , locationPath (programLocation prg)
+ )
+ ]
+ , haddockProgramArgs = mempty -- unused, set at configure time
+ , haddockHoogle = toFlag elabHaddockHoogle
+ , haddockHtml = toFlag elabHaddockHtml
+ , haddockHtmlLocation = maybe mempty toFlag elabHaddockHtmlLocation
+ , haddockForHackage = toFlag elabHaddockForHackage
+ , haddockForeignLibs = toFlag elabHaddockForeignLibs
+ , haddockExecutables = toFlag elabHaddockExecutables
+ , haddockTestSuites = toFlag elabHaddockTestSuites
+ , haddockBenchmarks = toFlag elabHaddockBenchmarks
+ , haddockInternal = toFlag elabHaddockInternal
+ , haddockCss = maybe mempty toFlag elabHaddockCss
+ , haddockLinkedSource = toFlag elabHaddockLinkedSource
+ , haddockQuickJump = toFlag elabHaddockQuickJump
+ , haddockHscolourCss = maybe mempty toFlag elabHaddockHscolourCss
+ , haddockContents = maybe mempty toFlag elabHaddockContents
+ , haddockDistPref = toFlag builddir
+ , haddockKeepTempFiles = mempty -- TODO: from build settings
+ , haddockVerbosity = toFlag verbosity
+ , haddockCabalFilePath = mempty
+ , haddockIndex = maybe mempty toFlag elabHaddockIndex
+ , haddockBaseUrl = maybe mempty toFlag elabHaddockBaseUrl
+ , haddockLib = maybe mempty toFlag elabHaddockLib
+ , haddockOutputDir = maybe mempty toFlag elabHaddockOutputDir
+ , haddockArgs = mempty
}
setupHsHaddockArgs :: ElaboratedConfiguredPackage -> [String]
@@ -3820,7 +4276,9 @@ setupHsTestFlags _ _ verbosity builddir =
-}
------------------------------------------------------------------------------
+
-- * Sharing installed packages
+
------------------------------------------------------------------------------
--
@@ -3861,103 +4319,112 @@ setupHsTestFlags _ _ verbosity builddir =
-- TODO: [required eventually] for safety of concurrent installs, we must make sure we register but
-- not replace installed packages with ghc-pkg.
-packageHashInputs :: ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
- -> PackageHashInputs
packageHashInputs
- pkgshared
- elab@(ElaboratedConfiguredPackage {
- elabPkgSourceHash = Just srchash
- }) =
- PackageHashInputs {
- pkgHashPkgId = packageId elab,
- pkgHashComponent =
- case elabPkgOrComp elab of
- ElabPackage _ -> Nothing
- ElabComponent comp -> Just (compSolverName comp),
- pkgHashSourceHash = srchash,
- pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab),
- pkgHashDirectDeps =
- case elabPkgOrComp elab of
- ElabPackage (ElaboratedPackage{..}) ->
- Set.fromList $
- [ confInstId dep
- | dep <- CD.select relevantDeps pkgLibDependencies ] ++
- [ confInstId dep
- | dep <- CD.select relevantDeps pkgExeDependencies ]
- ElabComponent comp ->
- Set.fromList (map confInstId (compLibDependencies comp
- ++ compExeDependencies comp)),
- pkgHashOtherConfig = packageHashConfigInputs pkgshared elab
- }
- where
- -- Obviously the main deps are relevant
- relevantDeps CD.ComponentLib = True
- relevantDeps (CD.ComponentSubLib _) = True
- relevantDeps (CD.ComponentFLib _) = True
- relevantDeps (CD.ComponentExe _) = True
- -- Setup deps can affect the Setup.hs behaviour and thus what is built
- relevantDeps CD.ComponentSetup = True
- -- However testsuites and benchmarks do not get installed and should not
- -- affect the result, so we do not include them.
- relevantDeps (CD.ComponentTest _) = False
- relevantDeps (CD.ComponentBench _) = False
-
+ :: ElaboratedSharedConfig
+ -> ElaboratedConfiguredPackage
+ -> PackageHashInputs
+packageHashInputs
+ pkgshared
+ elab@( ElaboratedConfiguredPackage
+ { elabPkgSourceHash = Just srchash
+ }
+ ) =
+ PackageHashInputs
+ { pkgHashPkgId = packageId elab
+ , pkgHashComponent =
+ case elabPkgOrComp elab of
+ ElabPackage _ -> Nothing
+ ElabComponent comp -> Just (compSolverName comp)
+ , pkgHashSourceHash = srchash
+ , pkgHashPkgConfigDeps = Set.fromList (elabPkgConfigDependencies elab)
+ , pkgHashDirectDeps =
+ case elabPkgOrComp elab of
+ ElabPackage (ElaboratedPackage{..}) ->
+ Set.fromList $
+ [ confInstId dep
+ | dep <- CD.select relevantDeps pkgLibDependencies
+ ]
+ ++ [ confInstId dep
+ | dep <- CD.select relevantDeps pkgExeDependencies
+ ]
+ ElabComponent comp ->
+ Set.fromList
+ ( map
+ confInstId
+ ( compLibDependencies comp
+ ++ compExeDependencies comp
+ )
+ )
+ , pkgHashOtherConfig = packageHashConfigInputs pkgshared elab
+ }
+ where
+ -- Obviously the main deps are relevant
+ relevantDeps CD.ComponentLib = True
+ relevantDeps (CD.ComponentSubLib _) = True
+ relevantDeps (CD.ComponentFLib _) = True
+ relevantDeps (CD.ComponentExe _) = True
+ -- Setup deps can affect the Setup.hs behaviour and thus what is built
+ relevantDeps CD.ComponentSetup = True
+ -- However testsuites and benchmarks do not get installed and should not
+ -- affect the result, so we do not include them.
+ relevantDeps (CD.ComponentTest _) = False
+ relevantDeps (CD.ComponentBench _) = False
packageHashInputs _ pkg =
- error $ "packageHashInputs: only for packages with source hashes. "
- ++ prettyShow (packageId pkg)
+ error $
+ "packageHashInputs: only for packages with source hashes. "
+ ++ prettyShow (packageId pkg)
-packageHashConfigInputs :: ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
- -> PackageHashConfigInputs
+packageHashConfigInputs
+ :: ElaboratedSharedConfig
+ -> ElaboratedConfiguredPackage
+ -> PackageHashConfigInputs
packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =
- PackageHashConfigInputs {
- pkgHashCompilerId = compilerId pkgConfigCompiler,
- pkgHashPlatform = pkgConfigPlatform,
- pkgHashFlagAssignment = elabFlagAssignment,
- pkgHashConfigureScriptArgs = elabConfigureScriptArgs,
- pkgHashVanillaLib = elabVanillaLib,
- pkgHashSharedLib = elabSharedLib,
- pkgHashDynExe = elabDynExe,
- pkgHashFullyStaticExe = elabFullyStaticExe,
- pkgHashGHCiLib = elabGHCiLib,
- pkgHashProfLib = elabProfLib,
- pkgHashProfExe = elabProfExe,
- pkgHashProfLibDetail = elabProfLibDetail,
- pkgHashProfExeDetail = elabProfExeDetail,
- pkgHashCoverage = elabCoverage,
- pkgHashOptimization = elabOptimization,
- pkgHashSplitSections = elabSplitSections,
- pkgHashSplitObjs = elabSplitObjs,
- pkgHashStripLibs = elabStripLibs,
- pkgHashStripExes = elabStripExes,
- pkgHashDebugInfo = elabDebugInfo,
- pkgHashProgramArgs = elabProgramArgs,
- pkgHashExtraLibDirs = elabExtraLibDirs,
- pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic,
- pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs,
- pkgHashExtraIncludeDirs = elabExtraIncludeDirs,
- pkgHashProgPrefix = elabProgPrefix,
- pkgHashProgSuffix = elabProgSuffix,
- pkgHashPackageDbs = elabPackageDbs,
-
- pkgHashDocumentation = elabBuildHaddocks,
- pkgHashHaddockHoogle = elabHaddockHoogle,
- pkgHashHaddockHtml = elabHaddockHtml,
- pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation,
- pkgHashHaddockForeignLibs = elabHaddockForeignLibs,
- pkgHashHaddockExecutables = elabHaddockExecutables,
- pkgHashHaddockTestSuites = elabHaddockTestSuites,
- pkgHashHaddockBenchmarks = elabHaddockBenchmarks,
- pkgHashHaddockInternal = elabHaddockInternal,
- pkgHashHaddockCss = elabHaddockCss,
- pkgHashHaddockLinkedSource = elabHaddockLinkedSource,
- pkgHashHaddockQuickJump = elabHaddockQuickJump,
- pkgHashHaddockContents = elabHaddockContents,
- pkgHashHaddockIndex = elabHaddockIndex,
- pkgHashHaddockBaseUrl = elabHaddockBaseUrl,
- pkgHashHaddockLib = elabHaddockLib,
- pkgHashHaddockOutputDir = elabHaddockOutputDir
+ PackageHashConfigInputs
+ { pkgHashCompilerId = compilerId pkgConfigCompiler
+ , pkgHashPlatform = pkgConfigPlatform
+ , pkgHashFlagAssignment = elabFlagAssignment
+ , pkgHashConfigureScriptArgs = elabConfigureScriptArgs
+ , pkgHashVanillaLib = elabVanillaLib
+ , pkgHashSharedLib = elabSharedLib
+ , pkgHashDynExe = elabDynExe
+ , pkgHashFullyStaticExe = elabFullyStaticExe
+ , pkgHashGHCiLib = elabGHCiLib
+ , pkgHashProfLib = elabProfLib
+ , pkgHashProfExe = elabProfExe
+ , pkgHashProfLibDetail = elabProfLibDetail
+ , pkgHashProfExeDetail = elabProfExeDetail
+ , pkgHashCoverage = elabCoverage
+ , pkgHashOptimization = elabOptimization
+ , pkgHashSplitSections = elabSplitSections
+ , pkgHashSplitObjs = elabSplitObjs
+ , pkgHashStripLibs = elabStripLibs
+ , pkgHashStripExes = elabStripExes
+ , pkgHashDebugInfo = elabDebugInfo
+ , pkgHashProgramArgs = elabProgramArgs
+ , pkgHashExtraLibDirs = elabExtraLibDirs
+ , pkgHashExtraLibDirsStatic = elabExtraLibDirsStatic
+ , pkgHashExtraFrameworkDirs = elabExtraFrameworkDirs
+ , pkgHashExtraIncludeDirs = elabExtraIncludeDirs
+ , pkgHashProgPrefix = elabProgPrefix
+ , pkgHashProgSuffix = elabProgSuffix
+ , pkgHashPackageDbs = elabPackageDbs
+ , pkgHashDocumentation = elabBuildHaddocks
+ , pkgHashHaddockHoogle = elabHaddockHoogle
+ , pkgHashHaddockHtml = elabHaddockHtml
+ , pkgHashHaddockHtmlLocation = elabHaddockHtmlLocation
+ , pkgHashHaddockForeignLibs = elabHaddockForeignLibs
+ , pkgHashHaddockExecutables = elabHaddockExecutables
+ , pkgHashHaddockTestSuites = elabHaddockTestSuites
+ , pkgHashHaddockBenchmarks = elabHaddockBenchmarks
+ , pkgHashHaddockInternal = elabHaddockInternal
+ , pkgHashHaddockCss = elabHaddockCss
+ , pkgHashHaddockLinkedSource = elabHaddockLinkedSource
+ , pkgHashHaddockQuickJump = elabHaddockQuickJump
+ , pkgHashHaddockContents = elabHaddockContents
+ , pkgHashHaddockIndex = elabHaddockIndex
+ , pkgHashHaddockBaseUrl = elabHaddockBaseUrl
+ , pkgHashHaddockLib = elabHaddockLib
+ , pkgHashHaddockOutputDir = elabHaddockOutputDir
}
where
ElaboratedConfiguredPackage{..} = normaliseConfiguredPackage shared pkg
@@ -3965,22 +4432,22 @@ packageHashConfigInputs shared@ElaboratedSharedConfig{..} pkg =
-- | Given the 'InstalledPackageIndex' for a nix-style package store, and an
-- 'ElaboratedInstallPlan', replace configured source packages by installed
-- packages from the store whenever they exist.
---
-improveInstallPlanWithInstalledPackages :: Set UnitId
- -> ElaboratedInstallPlan
- -> ElaboratedInstallPlan
+improveInstallPlanWithInstalledPackages
+ :: Set UnitId
+ -> ElaboratedInstallPlan
+ -> ElaboratedInstallPlan
improveInstallPlanWithInstalledPackages installedPkgIdSet =
- InstallPlan.installed canPackageBeImproved
+ InstallPlan.installed canPackageBeImproved
where
canPackageBeImproved pkg =
installedUnitId pkg `Set.member` installedPkgIdSet
- --TODO: sanity checks:
- -- * the installed package must have the expected deps etc
- -- * the installed package must not be broken, valid dep closure
- --TODO: decide what to do if we encounter broken installed packages,
- -- since overwriting is never safe.
+-- TODO: sanity checks:
+-- \* the installed package must have the expected deps etc
+-- \* the installed package must not be broken, valid dep closure
+-- TODO: decide what to do if we encounter broken installed packages,
+-- since overwriting is never safe.
-- Path construction
------
@@ -4012,6 +4479,6 @@ inplaceBinRoot
-> ElaboratedSharedConfig
-> ElaboratedConfiguredPackage
-> FilePath
-inplaceBinRoot layout config package
- = distBuildDirectory layout (elabDistDirParams config package)
- </> "build"
+inplaceBinRoot layout config package =
+ distBuildDirectory layout (elabDistDirParams config package)
+ </> "build"
diff --git a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
index 694b429c23af09f1e0c8a98cec0095f7f6d8df26..7855a80683ee3a8268072d0f5b1282a0794ca575 100644
--- a/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
+++ b/cabal-install/src/Distribution/Client/ProjectPlanning/Types.hs
@@ -1,115 +1,118 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}
-- | Types used while planning how to build everything in a project.
--
-- Primarily this is the 'ElaboratedInstallPlan'.
---
-module Distribution.Client.ProjectPlanning.Types (
- SolverInstallPlan,
+module Distribution.Client.ProjectPlanning.Types
+ ( SolverInstallPlan
-- * Elaborated install plan types
- ElaboratedInstallPlan,
- normaliseConfiguredPackage,
- ElaboratedConfiguredPackage(..),
-
- elabDistDirParams,
- elabExeDependencyPaths,
- elabLibDependencies,
- elabOrderLibDependencies,
- elabExeDependencies,
- elabOrderExeDependencies,
- elabSetupDependencies,
- elabPkgConfigDependencies,
- elabInplaceDependencyBuildCacheFiles,
- elabRequiresRegistration,
- dataDirsEnvironmentForPlan,
-
- elabPlanPackageName,
- elabConfiguredName,
- elabComponentName,
-
- ElaboratedPackageOrComponent(..),
- ElaboratedComponent(..),
- ElaboratedPackage(..),
- pkgOrderDependencies,
- ElaboratedPlanPackage,
- ElaboratedSharedConfig(..),
- ElaboratedReadyPackage,
- BuildStyle(..),
- CabalFileText,
+ , ElaboratedInstallPlan
+ , normaliseConfiguredPackage
+ , ElaboratedConfiguredPackage (..)
+ , elabDistDirParams
+ , elabExeDependencyPaths
+ , elabLibDependencies
+ , elabOrderLibDependencies
+ , elabExeDependencies
+ , elabOrderExeDependencies
+ , elabSetupDependencies
+ , elabPkgConfigDependencies
+ , elabInplaceDependencyBuildCacheFiles
+ , elabRequiresRegistration
+ , dataDirsEnvironmentForPlan
+ , elabPlanPackageName
+ , elabConfiguredName
+ , elabComponentName
+ , ElaboratedPackageOrComponent (..)
+ , ElaboratedComponent (..)
+ , ElaboratedPackage (..)
+ , pkgOrderDependencies
+ , ElaboratedPlanPackage
+ , ElaboratedSharedConfig (..)
+ , ElaboratedReadyPackage
+ , BuildStyle (..)
+ , CabalFileText
-- * Build targets
- ComponentTarget(..),
- showComponentTarget,
- showTestComponentTarget,
- showBenchComponentTarget,
- SubComponentTarget(..),
-
- isSubLibComponentTarget,
- isForeignLibComponentTarget,
- isExeComponentTarget,
- isTestComponentTarget,
- isBenchComponentTarget,
-
- componentOptionalStanza,
+ , ComponentTarget (..)
+ , showComponentTarget
+ , showTestComponentTarget
+ , showBenchComponentTarget
+ , SubComponentTarget (..)
+ , isSubLibComponentTarget
+ , isForeignLibComponentTarget
+ , isExeComponentTarget
+ , isTestComponentTarget
+ , isBenchComponentTarget
+ , componentOptionalStanza
-- * Setup script
- SetupScriptStyle(..),
+ , SetupScriptStyle (..)
) where
-import Distribution.Client.Compat.Prelude
-import Prelude ()
+import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.TargetSelector
- ( SubComponentTarget(..) )
-import Distribution.Client.PackageHash
+import Distribution.Client.PackageHash
+import Distribution.Client.TargetSelector
+ ( SubComponentTarget (..)
+ )
-import Distribution.Client.Types
+import Distribution.Client.DistDirLayout
+import Distribution.Client.InstallPlan
+ ( GenericInstallPlan
+ , GenericPlanPackage (..)
+ )
import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan
- ( GenericInstallPlan, GenericPlanPackage(..) )
-import Distribution.Client.SolverInstallPlan
- ( SolverInstallPlan )
-import Distribution.Client.DistDirLayout
-
-import Distribution.Backpack
-import Distribution.Backpack.ModuleShape
-
-import Distribution.Verbosity (normal)
-import Distribution.Types.ComponentRequestedSpec
-import Distribution.Types.PkgconfigVersion
-import Distribution.Types.PackageDescription (PackageDescription(..))
-import Distribution.Package
-import Distribution.System
+import Distribution.Client.SolverInstallPlan
+ ( SolverInstallPlan
+ )
+import Distribution.Client.Types
+
+import Distribution.Backpack
+import Distribution.Backpack.ModuleShape
+
+import Distribution.InstalledPackageInfo (InstalledPackageInfo)
+import Distribution.ModuleName (ModuleName)
+import Distribution.Package
import qualified Distribution.PackageDescription as Cabal
-import Distribution.InstalledPackageInfo (InstalledPackageInfo)
-import Distribution.Simple.Compiler
-import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)
+import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)
import qualified Distribution.Simple.BuildTarget as Cabal
-import Distribution.Simple.Program
-import Distribution.ModuleName (ModuleName)
-import Distribution.Simple.LocalBuildInfo
- ( ComponentName(..), LibraryName(..) )
+import Distribution.Simple.Compiler
+import Distribution.Simple.InstallDirs (PathTemplate)
import qualified Distribution.Simple.InstallDirs as InstallDirs
-import Distribution.Simple.InstallDirs (PathTemplate)
-import Distribution.Simple.Setup
- ( HaddockTarget, TestShowDetails, DumpBuildInfo (..), ReplOptions )
-import Distribution.Version
-
+import Distribution.Simple.LocalBuildInfo
+ ( ComponentName (..)
+ , LibraryName (..)
+ )
+import Distribution.Simple.Program
+import Distribution.Simple.Setup
+ ( DumpBuildInfo (..)
+ , HaddockTarget
+ , ReplOptions
+ , TestShowDetails
+ )
+import Distribution.System
+import Distribution.Types.ComponentRequestedSpec
+import Distribution.Types.PackageDescription (PackageDescription (..))
+import Distribution.Types.PkgconfigVersion
+import Distribution.Verbosity (normal)
+import Distribution.Version
+
+import Distribution.Compat.Graph (IsNode (..))
+import Distribution.Simple.Utils (ordNub)
+import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
-import Distribution.Solver.Types.OptionalStanza
-import Distribution.Compat.Graph (IsNode(..))
-import Distribution.Simple.Utils (ordNub)
+import Distribution.Solver.Types.OptionalStanza
-import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Map as Map
import qualified Data.Monoid as Mon
-import System.FilePath ((</>))
-
+import System.FilePath ((</>))
-- | The combination of an elaborated install plan plus a
-- 'ElaboratedSharedConfig' contains all the details necessary to be able
@@ -117,234 +120,206 @@ import System.FilePath ((</>))
--
-- It does not include dynamic elements such as resources (such as http
-- connections).
---
-type ElaboratedInstallPlan
- = GenericInstallPlan InstalledPackageInfo
- ElaboratedConfiguredPackage
+type ElaboratedInstallPlan =
+ GenericInstallPlan
+ InstalledPackageInfo
+ ElaboratedConfiguredPackage
-type ElaboratedPlanPackage
- = GenericPlanPackage InstalledPackageInfo
- ElaboratedConfiguredPackage
+type ElaboratedPlanPackage =
+ GenericPlanPackage
+ InstalledPackageInfo
+ ElaboratedConfiguredPackage
-- | User-friendly display string for an 'ElaboratedPlanPackage'.
elabPlanPackageName :: Verbosity -> ElaboratedPlanPackage -> String
elabPlanPackageName verbosity (PreExisting ipkg)
- | verbosity <= normal = prettyShow (packageName ipkg)
- | otherwise = prettyShow (installedUnitId ipkg)
-elabPlanPackageName verbosity (Configured elab)
- = elabConfiguredName verbosity elab
-elabPlanPackageName verbosity (Installed elab)
- = elabConfiguredName verbosity elab
-
---TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle
+ | verbosity <= normal = prettyShow (packageName ipkg)
+ | otherwise = prettyShow (installedUnitId ipkg)
+elabPlanPackageName verbosity (Configured elab) =
+ elabConfiguredName verbosity elab
+elabPlanPackageName verbosity (Installed elab) =
+ elabConfiguredName verbosity elab
+
+-- TODO: [code cleanup] decide if we really need this, there's not much in it, and in principle
-- even platform and compiler could be different if we're building things
-- like a server + client with ghc + ghcjs
-data ElaboratedSharedConfig
- = ElaboratedSharedConfig {
-
- pkgConfigPlatform :: Platform,
- pkgConfigCompiler :: Compiler, --TODO: [code cleanup] replace with CompilerInfo
- -- | The programs that the compiler configured (e.g. for GHC, the progs
- -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are
- -- used.
- pkgConfigCompilerProgs :: ProgramDb,
- pkgConfigReplOptions :: ReplOptions
- }
+data ElaboratedSharedConfig = ElaboratedSharedConfig
+ { pkgConfigPlatform :: Platform
+ , pkgConfigCompiler :: Compiler -- TODO: [code cleanup] replace with CompilerInfo
+ , pkgConfigCompilerProgs :: ProgramDb
+ -- ^ The programs that the compiler configured (e.g. for GHC, the progs
+ -- ghc & ghc-pkg). Once constructed, only the 'configuredPrograms' are
+ -- used.
+ , pkgConfigReplOptions :: ReplOptions
+ }
deriving (Show, Generic, Typeable)
- --TODO: [code cleanup] no Eq instance
+
+-- TODO: [code cleanup] no Eq instance
instance Binary ElaboratedSharedConfig
instance Structured ElaboratedSharedConfig
-data ElaboratedConfiguredPackage
- = ElaboratedConfiguredPackage {
- -- | The 'UnitId' which uniquely identifies this item in a build plan
- elabUnitId :: UnitId,
-
- elabComponentId :: ComponentId,
- elabInstantiatedWith :: Map ModuleName Module,
- elabLinkedInstantiatedWith :: Map ModuleName OpenModule,
-
- -- | This is true if this is an indefinite package, or this is a
- -- package with no signatures. (Notably, it's not true for instantiated
- -- packages.) The motivation for this is if you ask to build
- -- @foo-indef@, this probably means that you want to typecheck
- -- it, NOT that you want to rebuild all of the various
- -- instantiations of it.
- elabIsCanonical :: Bool,
-
- -- | The 'PackageId' of the originating package
- elabPkgSourceId :: PackageId,
-
- -- | Shape of the package/component, for Backpack.
- elabModuleShape :: ModuleShape,
-
- -- | A total flag assignment for the package.
- -- TODO: Actually this can be per-component if we drop
- -- all flags that don't affect a component.
- elabFlagAssignment :: Cabal.FlagAssignment,
-
- -- | The original default flag assignment, used only for reporting.
- elabFlagDefaults :: Cabal.FlagAssignment,
-
- elabPkgDescription :: Cabal.PackageDescription,
-
- -- | Where the package comes from, e.g. tarball, local dir etc. This
- -- is not the same as where it may be unpacked to for the build.
- elabPkgSourceLocation :: PackageLocation (Maybe FilePath),
-
- -- | The hash of the source, e.g. the tarball. We don't have this for
- -- local source dir packages.
- elabPkgSourceHash :: Maybe PackageSourceHash,
-
- -- | Is this package one of the ones specified by location in the
- -- project file? (As opposed to a dependency, or a named package pulled
- -- in)
- elabLocalToProject :: Bool,
-
- -- | Are we going to build and install this package to the store, or are
- -- we going to build it and register it locally.
- elabBuildStyle :: BuildStyle,
-
- -- | Another way of phrasing 'pkgStanzasAvailable'.
- elabEnabledSpec :: ComponentRequestedSpec,
-
- -- | Which optional stanzas (ie testsuites, benchmarks) can be built.
- -- This means the solver produced a plan that has them available.
- -- This doesn't necessary mean we build them by default.
- elabStanzasAvailable :: OptionalStanzaSet,
-
- -- | Which optional stanzas the user explicitly asked to enable or
- -- to disable. This tells us which ones we build by default, and
- -- helps with error messages when the user asks to build something
- -- they explicitly disabled.
- --
- -- TODO: The 'Bool' here should be refined into an ADT with three
- -- cases: NotRequested, ExplicitlyRequested and
- -- ImplicitlyRequested. A stanza is explicitly requested if
- -- the user asked, for this *specific* package, that the stanza
- -- be enabled; it's implicitly requested if the user asked for
- -- all global packages to have this stanza enabled. The
- -- difference between an explicit and implicit request is
- -- error reporting behavior: if a user asks for tests to be
- -- enabled for a specific package that doesn't have any tests,
- -- we should warn them about it, but we shouldn't complain
- -- that a user enabled tests globally, and some local packages
- -- just happen not to have any tests. (But perhaps we should
- -- warn if ALL local packages don't have any tests.)
- elabStanzasRequested :: OptionalStanzaMap (Maybe Bool),
-
- elabPackageDbs :: [Maybe PackageDB],
- elabSetupPackageDBStack :: PackageDBStack,
- elabBuildPackageDBStack :: PackageDBStack,
- elabRegisterPackageDBStack :: PackageDBStack,
-
- elabInplaceSetupPackageDBStack :: PackageDBStack,
- elabInplaceBuildPackageDBStack :: PackageDBStack,
- elabInplaceRegisterPackageDBStack :: PackageDBStack,
-
- elabPkgDescriptionOverride :: Maybe CabalFileText,
-
- -- TODO: make per-component variants of these flags
- elabVanillaLib :: Bool,
- elabSharedLib :: Bool,
- elabStaticLib :: Bool,
- elabDynExe :: Bool,
- elabFullyStaticExe :: Bool,
- elabGHCiLib :: Bool,
- elabProfLib :: Bool,
- elabProfExe :: Bool,
- elabProfLibDetail :: ProfDetailLevel,
- elabProfExeDetail :: ProfDetailLevel,
- elabCoverage :: Bool,
- elabOptimization :: OptimisationLevel,
- elabSplitObjs :: Bool,
- elabSplitSections :: Bool,
- elabStripLibs :: Bool,
- elabStripExes :: Bool,
- elabDebugInfo :: DebugInfoLevel,
- elabDumpBuildInfo :: DumpBuildInfo,
-
- elabProgramPaths :: Map String FilePath,
- elabProgramArgs :: Map String [String],
- elabProgramPathExtra :: [FilePath],
- elabConfigureScriptArgs :: [String],
- elabExtraLibDirs :: [FilePath],
- elabExtraLibDirsStatic :: [FilePath],
- elabExtraFrameworkDirs :: [FilePath],
- elabExtraIncludeDirs :: [FilePath],
- elabProgPrefix :: Maybe PathTemplate,
- elabProgSuffix :: Maybe PathTemplate,
-
- elabInstallDirs :: InstallDirs.InstallDirs FilePath,
-
- elabHaddockHoogle :: Bool,
- elabHaddockHtml :: Bool,
- elabHaddockHtmlLocation :: Maybe String,
- elabHaddockForeignLibs :: Bool,
- elabHaddockForHackage :: HaddockTarget,
- elabHaddockExecutables :: Bool,
- elabHaddockTestSuites :: Bool,
- elabHaddockBenchmarks :: Bool,
- elabHaddockInternal :: Bool,
- elabHaddockCss :: Maybe FilePath,
- elabHaddockLinkedSource :: Bool,
- elabHaddockQuickJump :: Bool,
- elabHaddockHscolourCss :: Maybe FilePath,
- elabHaddockContents :: Maybe PathTemplate,
- elabHaddockIndex :: Maybe PathTemplate,
- elabHaddockBaseUrl :: Maybe String,
- elabHaddockLib :: Maybe String,
- elabHaddockOutputDir :: Maybe FilePath,
-
- elabTestMachineLog :: Maybe PathTemplate,
- elabTestHumanLog :: Maybe PathTemplate,
- elabTestShowDetails :: Maybe TestShowDetails,
- elabTestKeepTix :: Bool,
- elabTestWrapper :: Maybe FilePath,
- elabTestFailWhenNoTestSuites :: Bool,
- elabTestTestOptions :: [PathTemplate],
-
- elabBenchmarkOptions :: [PathTemplate],
-
- -- Setup.hs related things:
-
- -- | One of four modes for how we build and interact with the Setup.hs
- -- script, based on whether it's a build-type Custom, with or without
- -- explicit deps and the cabal spec version the .cabal file needs.
- elabSetupScriptStyle :: SetupScriptStyle,
-
- -- | The version of the Cabal command line interface that we are using
- -- for this package. This is typically the version of the Cabal lib
- -- that the Setup.hs is built against.
- --
- -- TODO: We might want to turn this into a enum,
- -- yet different enum than 'CabalSpecVersion'.
- elabSetupScriptCliVersion :: Version,
-
- -- Build time related:
- elabConfigureTargets :: [ComponentTarget],
- elabBuildTargets :: [ComponentTarget],
- elabTestTargets :: [ComponentTarget],
- elabBenchTargets :: [ComponentTarget],
- elabReplTarget :: Maybe ComponentTarget,
- elabHaddockTargets :: [ComponentTarget],
-
- elabBuildHaddocks :: Bool,
-
- --pkgSourceDir ? -- currently passed in later because they can use temp locations
- --pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc
-
- -- | Component/package specific information
- elabPkgOrComp :: ElaboratedPackageOrComponent
- }
+data ElaboratedConfiguredPackage = ElaboratedConfiguredPackage
+ { elabUnitId :: UnitId
+ -- ^ The 'UnitId' which uniquely identifies this item in a build plan
+ , elabComponentId :: ComponentId
+ , elabInstantiatedWith :: Map ModuleName Module
+ , elabLinkedInstantiatedWith :: Map ModuleName OpenModule
+ , elabIsCanonical :: Bool
+ -- ^ This is true if this is an indefinite package, or this is a
+ -- package with no signatures. (Notably, it's not true for instantiated
+ -- packages.) The motivation for this is if you ask to build
+ -- @foo-indef@, this probably means that you want to typecheck
+ -- it, NOT that you want to rebuild all of the various
+ -- instantiations of it.
+ , elabPkgSourceId :: PackageId
+ -- ^ The 'PackageId' of the originating package
+ , elabModuleShape :: ModuleShape
+ -- ^ Shape of the package/component, for Backpack.
+ , elabFlagAssignment :: Cabal.FlagAssignment
+ -- ^ A total flag assignment for the package.
+ -- TODO: Actually this can be per-component if we drop
+ -- all flags that don't affect a component.
+ , elabFlagDefaults :: Cabal.FlagAssignment
+ -- ^ The original default flag assignment, used only for reporting.
+ , elabPkgDescription :: Cabal.PackageDescription
+ , elabPkgSourceLocation :: PackageLocation (Maybe FilePath)
+ -- ^ Where the package comes from, e.g. tarball, local dir etc. This
+ -- is not the same as where it may be unpacked to for the build.
+ , elabPkgSourceHash :: Maybe PackageSourceHash
+ -- ^ The hash of the source, e.g. the tarball. We don't have this for
+ -- local source dir packages.
+ , elabLocalToProject :: Bool
+ -- ^ Is this package one of the ones specified by location in the
+ -- project file? (As opposed to a dependency, or a named package pulled
+ -- in)
+ , elabBuildStyle :: BuildStyle
+ -- ^ Are we going to build and install this package to the store, or are
+ -- we going to build it and register it locally.
+ , elabEnabledSpec :: ComponentRequestedSpec
+ -- ^ Another way of phrasing 'pkgStanzasAvailable'.
+ , elabStanzasAvailable :: OptionalStanzaSet
+ -- ^ Which optional stanzas (ie testsuites, benchmarks) can be built.
+ -- This means the solver produced a plan that has them available.
+ -- This doesn't necessary mean we build them by default.
+ , elabStanzasRequested :: OptionalStanzaMap (Maybe Bool)
+ -- ^ Which optional stanzas the user explicitly asked to enable or
+ -- to disable. This tells us which ones we build by default, and
+ -- helps with error messages when the user asks to build something
+ -- they explicitly disabled.
+ --
+ -- TODO: The 'Bool' here should be refined into an ADT with three
+ -- cases: NotRequested, ExplicitlyRequested and
+ -- ImplicitlyRequested. A stanza is explicitly requested if
+ -- the user asked, for this *specific* package, that the stanza
+ -- be enabled; it's implicitly requested if the user asked for
+ -- all global packages to have this stanza enabled. The
+ -- difference between an explicit and implicit request is
+ -- error reporting behavior: if a user asks for tests to be
+ -- enabled for a specific package that doesn't have any tests,
+ -- we should warn them about it, but we shouldn't complain
+ -- that a user enabled tests globally, and some local packages
+ -- just happen not to have any tests. (But perhaps we should
+ -- warn if ALL local packages don't have any tests.)
+ , elabPackageDbs :: [Maybe PackageDB]
+ , elabSetupPackageDBStack :: PackageDBStack
+ , elabBuildPackageDBStack :: PackageDBStack
+ , elabRegisterPackageDBStack :: PackageDBStack
+ , elabInplaceSetupPackageDBStack :: PackageDBStack
+ , elabInplaceBuildPackageDBStack :: PackageDBStack
+ , elabInplaceRegisterPackageDBStack :: PackageDBStack
+ , elabPkgDescriptionOverride :: Maybe CabalFileText
+ , -- TODO: make per-component variants of these flags
+ elabVanillaLib :: Bool
+ , elabSharedLib :: Bool
+ , elabStaticLib :: Bool
+ , elabDynExe :: Bool
+ , elabFullyStaticExe :: Bool
+ , elabGHCiLib :: Bool
+ , elabProfLib :: Bool
+ , elabProfExe :: Bool
+ , elabProfLibDetail :: ProfDetailLevel
+ , elabProfExeDetail :: ProfDetailLevel
+ , elabCoverage :: Bool
+ , elabOptimization :: OptimisationLevel
+ , elabSplitObjs :: Bool
+ , elabSplitSections :: Bool
+ , elabStripLibs :: Bool
+ , elabStripExes :: Bool
+ , elabDebugInfo :: DebugInfoLevel
+ , elabDumpBuildInfo :: DumpBuildInfo
+ , elabProgramPaths :: Map String FilePath
+ , elabProgramArgs :: Map String [String]
+ , elabProgramPathExtra :: [FilePath]
+ , elabConfigureScriptArgs :: [String]
+ , elabExtraLibDirs :: [FilePath]
+ , elabExtraLibDirsStatic :: [FilePath]
+ , elabExtraFrameworkDirs :: [FilePath]
+ , elabExtraIncludeDirs :: [FilePath]
+ , elabProgPrefix :: Maybe PathTemplate
+ , elabProgSuffix :: Maybe PathTemplate
+ , elabInstallDirs :: InstallDirs.InstallDirs FilePath
+ , elabHaddockHoogle :: Bool
+ , elabHaddockHtml :: Bool
+ , elabHaddockHtmlLocation :: Maybe String
+ , elabHaddockForeignLibs :: Bool
+ , elabHaddockForHackage :: HaddockTarget
+ , elabHaddockExecutables :: Bool
+ , elabHaddockTestSuites :: Bool
+ , elabHaddockBenchmarks :: Bool
+ , elabHaddockInternal :: Bool
+ , elabHaddockCss :: Maybe FilePath
+ , elabHaddockLinkedSource :: Bool
+ , elabHaddockQuickJump :: Bool
+ , elabHaddockHscolourCss :: Maybe FilePath
+ , elabHaddockContents :: Maybe PathTemplate
+ , elabHaddockIndex :: Maybe PathTemplate
+ , elabHaddockBaseUrl :: Maybe String
+ , elabHaddockLib :: Maybe String
+ , elabHaddockOutputDir :: Maybe FilePath
+ , elabTestMachineLog :: Maybe PathTemplate
+ , elabTestHumanLog :: Maybe PathTemplate
+ , elabTestShowDetails :: Maybe TestShowDetails
+ , elabTestKeepTix :: Bool
+ , elabTestWrapper :: Maybe FilePath
+ , elabTestFailWhenNoTestSuites :: Bool
+ , elabTestTestOptions :: [PathTemplate]
+ , elabBenchmarkOptions :: [PathTemplate]
+ , -- Setup.hs related things:
+
+ elabSetupScriptStyle :: SetupScriptStyle
+ -- ^ One of four modes for how we build and interact with the Setup.hs
+ -- script, based on whether it's a build-type Custom, with or without
+ -- explicit deps and the cabal spec version the .cabal file needs.
+ , elabSetupScriptCliVersion :: Version
+ -- ^ The version of the Cabal command line interface that we are using
+ -- for this package. This is typically the version of the Cabal lib
+ -- that the Setup.hs is built against.
+ --
+ -- TODO: We might want to turn this into a enum,
+ -- yet different enum than 'CabalSpecVersion'.
+ , -- Build time related:
+ elabConfigureTargets :: [ComponentTarget]
+ , elabBuildTargets :: [ComponentTarget]
+ , elabTestTargets :: [ComponentTarget]
+ , elabBenchTargets :: [ComponentTarget]
+ , elabReplTarget :: Maybe ComponentTarget
+ , elabHaddockTargets :: [ComponentTarget]
+ , elabBuildHaddocks :: Bool
+ , -- pkgSourceDir ? -- currently passed in later because they can use temp locations
+ -- pkgBuildDir ? -- but could in principle still have it here, with optional instr to use temp loc
+
+ elabPkgOrComp :: ElaboratedPackageOrComponent
+ -- ^ Component/package specific information
+ }
deriving (Eq, Show, Generic, Typeable)
-normaliseConfiguredPackage :: ElaboratedSharedConfig
- -> ElaboratedConfiguredPackage
- -> ElaboratedConfiguredPackage
+normaliseConfiguredPackage
+ :: ElaboratedSharedConfig
+ -> ElaboratedConfiguredPackage
+ -> ElaboratedConfiguredPackage
normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =
- pkg { elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg) }
+ pkg{elabProgramArgs = Map.mapMaybeWithKey lookupFilter (elabProgramArgs pkg)}
where
knownProgramDb = addKnownPrograms builtinPrograms pkgConfigCompilerProgs
@@ -357,8 +332,8 @@ normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =
lookupFilter :: String -> [String] -> Maybe [String]
lookupFilter n args = removeEmpty $ case lookupKnownProgram n knownProgramDb of
- Just p -> programNormaliseArgs p (getVersion p) pkgDesc args
- Nothing -> args
+ Just p -> programNormaliseArgs p (getVersion p) pkgDesc args
+ Nothing -> args
getVersion :: Program -> Maybe Version
getVersion p = lookupProgram p knownProgramDb >>= programVersion
@@ -366,50 +341,57 @@ normaliseConfiguredPackage ElaboratedSharedConfig{pkgConfigCompilerProgs} pkg =
-- | The package/component contains/is a library and so must be registered
elabRequiresRegistration :: ElaboratedConfiguredPackage -> Bool
elabRequiresRegistration elab =
- case elabPkgOrComp elab of
- ElabComponent comp ->
- case compComponentName comp of
- Just cn -> is_lib cn && build_target
- _ -> False
- ElabPackage pkg ->
- -- Tricky! Not only do we have to test if the user selected
- -- a library as a build target, we also have to test if
- -- the library was TRANSITIVELY depended upon, since we will
- -- also require a register in this case.
- --
- -- NB: It would have been far nicer to just unconditionally
- -- register in all cases, but some Custom Setups will fall
- -- over if you try to do that, ESPECIALLY if there actually is
- -- a library but they hadn't built it.
- --
- -- However, as the case of `cpphs-1.20.8` has shown in
- -- #5379, in cases when a monolithic package gets
- -- installed due to its executable components
- -- (i.e. exe:cpphs) into the store we *have* to register
- -- if there's a buildable public library (i.e. lib:cpphs)
- -- that was built and installed into the same store folder
- -- as otherwise this will cause build failures once a
- -- target actually depends on lib:cpphs.
- build_target || (elabBuildStyle elab == BuildAndInstall &&
- Cabal.hasPublicLib (elabPkgDescription elab))
- -- the next sub-condition below is currently redundant
- -- (see discussion in #5604 for more details), but it's
- -- being kept intentionally here as a safeguard because if
- -- internal libraries ever start working with
- -- non-per-component builds this condition won't be
- -- redundant anymore.
- || any (depends_on_lib pkg) (elabBuildTargets elab)
+ case elabPkgOrComp elab of
+ ElabComponent comp ->
+ case compComponentName comp of
+ Just cn -> is_lib cn && build_target
+ _ -> False
+ ElabPackage pkg ->
+ -- Tricky! Not only do we have to test if the user selected
+ -- a library as a build target, we also have to test if
+ -- the library was TRANSITIVELY depended upon, since we will
+ -- also require a register in this case.
+ --
+ -- NB: It would have been far nicer to just unconditionally
+ -- register in all cases, but some Custom Setups will fall
+ -- over if you try to do that, ESPECIALLY if there actually is
+ -- a library but they hadn't built it.
+ --
+ -- However, as the case of `cpphs-1.20.8` has shown in
+ -- #5379, in cases when a monolithic package gets
+ -- installed due to its executable components
+ -- (i.e. exe:cpphs) into the store we *have* to register
+ -- if there's a buildable public library (i.e. lib:cpphs)
+ -- that was built and installed into the same store folder
+ -- as otherwise this will cause build failures once a
+ -- target actually depends on lib:cpphs.
+ build_target
+ || ( elabBuildStyle elab == BuildAndInstall
+ && Cabal.hasPublicLib (elabPkgDescription elab)
+ )
+ -- the next sub-condition below is currently redundant
+ -- (see discussion in #5604 for more details), but it's
+ -- being kept intentionally here as a safeguard because if
+ -- internal libraries ever start working with
+ -- non-per-component builds this condition won't be
+ -- redundant anymore.
+ || any (depends_on_lib pkg) (elabBuildTargets elab)
where
depends_on_lib pkg (ComponentTarget cn _) =
- not (null (CD.select (== CD.componentNameToComponent cn)
- (pkgDependsOnSelfLib pkg)))
+ not
+ ( null
+ ( CD.select
+ (== CD.componentNameToComponent cn)
+ (pkgDependsOnSelfLib pkg)
+ )
+ )
build_target =
- if not (null (elabBuildTargets elab))
- then any is_lib_target (elabBuildTargets elab)
- -- Empty build targets mean we build /everything/;
- -- that means we have to look more carefully to see
- -- if there is anything to register
- else Cabal.hasLibs (elabPkgDescription elab)
+ if not (null (elabBuildTargets elab))
+ then any is_lib_target (elabBuildTargets elab)
+ else -- Empty build targets mean we build /everything/;
+ -- that means we have to look more carefully to see
+ -- if there is anything to register
+ Cabal.hasLibs (elabPkgDescription elab)
-- NB: this means we DO NOT reregister if you just built a
-- single file
is_lib_target (ComponentTarget cn WholeComponent) = is_lib cn
@@ -420,14 +402,18 @@ elabRequiresRegistration elab =
-- | Construct the environment needed for the data files to work.
-- This consists of a separate @*_datadir@ variable for each
-- inplace package in the plan.
-dataDirsEnvironmentForPlan :: DistDirLayout
- -> ElaboratedInstallPlan
- -> [(String, Maybe FilePath)]
-dataDirsEnvironmentForPlan distDirLayout = catMaybes
- . fmap (InstallPlan.foldPlanPackage
- (const Nothing)
- (dataDirEnvVarForPackage distDirLayout))
- . InstallPlan.toList
+dataDirsEnvironmentForPlan
+ :: DistDirLayout
+ -> ElaboratedInstallPlan
+ -> [(String, Maybe FilePath)]
+dataDirsEnvironmentForPlan distDirLayout =
+ catMaybes
+ . fmap
+ ( InstallPlan.foldPlanPackage
+ (const Nothing)
+ (dataDirEnvVarForPackage distDirLayout)
+ )
+ . InstallPlan.toList
-- | Construct an environment variable that points
-- the package's datadir to its correct location.
@@ -436,16 +422,20 @@ dataDirsEnvironmentForPlan distDirLayout = catMaybes
-- for inplace packages.
-- * 'Nothing' for packages installed in the store (the path was
-- already included in the package at install/build time).
-dataDirEnvVarForPackage :: DistDirLayout
- -> ElaboratedConfiguredPackage
- -> Maybe (String, Maybe FilePath)
+dataDirEnvVarForPackage
+ :: DistDirLayout
+ -> ElaboratedConfiguredPackage
+ -> Maybe (String, Maybe FilePath)
dataDirEnvVarForPackage distDirLayout pkg =
- case elabBuildStyle pkg
- of BuildAndInstall -> Nothing
- BuildInplaceOnly -> Just
- ( pkgPathEnvVar (elabPkgDescription pkg) "datadir"
- , Just $ srcPath (elabPkgSourceLocation pkg)
- </> dataDir (elabPkgDescription pkg))
+ case elabBuildStyle pkg of
+ BuildAndInstall -> Nothing
+ BuildInplaceOnly ->
+ Just
+ ( pkgPathEnvVar (elabPkgDescription pkg) "datadir"
+ , Just $
+ srcPath (elabPkgSourceLocation pkg)
+ </> dataDir (elabPkgDescription pkg)
+ )
where
srcPath (LocalUnpackedPackage path) = path
srcPath (LocalTarballPackage _path) = unpackedPath
@@ -453,8 +443,9 @@ dataDirEnvVarForPackage distDirLayout pkg =
srcPath (RepoTarballPackage _repo _packageId _localTar) = unpackedPath
srcPath (RemoteSourceRepoPackage _sourceRepo (Just localCheckout)) = localCheckout
-- TODO: see https://github.com/haskell/cabal/wiki/Potential-Refactors#unresolvedpkgloc
- srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) = error
- "calling dataDirEnvVarForPackage on a not-downloaded repo is an error"
+ srcPath (RemoteSourceRepoPackage _sourceRepo Nothing) =
+ error
+ "calling dataDirEnvVarForPackage on a not-downloaded repo is an error"
unpackedPath =
distUnpackedSrcDirectory distDirLayout $ elabPkgSourceId pkg
@@ -469,16 +460,16 @@ instance HasUnitId ElaboratedConfiguredPackage where
installedUnitId = elabUnitId
instance IsNode ElaboratedConfiguredPackage where
- type Key ElaboratedConfiguredPackage = UnitId
- nodeKey = elabUnitId
- nodeNeighbors = elabOrderDependencies
+ type Key ElaboratedConfiguredPackage = UnitId
+ nodeKey = elabUnitId
+ nodeNeighbors = elabOrderDependencies
instance Binary ElaboratedConfiguredPackage
instance Structured ElaboratedConfiguredPackage
data ElaboratedPackageOrComponent
- = ElabPackage ElaboratedPackage
- | ElabComponent ElaboratedComponent
+ = ElabPackage ElaboratedPackage
+ | ElabComponent ElaboratedComponent
deriving (Eq, Show, Generic)
instance Binary ElaboratedPackageOrComponent
@@ -486,36 +477,38 @@ instance Structured ElaboratedPackageOrComponent
elabComponentName :: ElaboratedConfiguredPackage -> Maybe ComponentName
elabComponentName elab =
- case elabPkgOrComp elab of
- ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this
- ElabComponent comp -> compComponentName comp
+ case elabPkgOrComp elab of
+ ElabPackage _ -> Just $ CLibName LMainLibName -- there could be more, but default this
+ ElabComponent comp -> compComponentName comp
-- | A user-friendly descriptor for an 'ElaboratedConfiguredPackage'.
elabConfiguredName :: Verbosity -> ElaboratedConfiguredPackage -> String
elabConfiguredName verbosity elab
- | verbosity <= normal
- = (case elabPkgOrComp elab of
- ElabPackage _ -> ""
- ElabComponent comp ->
+ | verbosity <= normal =
+ ( case elabPkgOrComp elab of
+ ElabPackage _ -> ""
+ ElabComponent comp ->
case compComponentName comp of
- Nothing -> "setup from "
- Just (CLibName LMainLibName) -> ""
- Just cname -> prettyShow cname ++ " from ")
- ++ prettyShow (packageId elab)
- | otherwise
- = prettyShow (elabUnitId elab)
+ Nothing -> "setup from "
+ Just (CLibName LMainLibName) -> ""
+ Just cname -> prettyShow cname ++ " from "
+ )
+ ++ prettyShow (packageId elab)
+ | otherwise =
+ prettyShow (elabUnitId elab)
elabDistDirParams :: ElaboratedSharedConfig -> ElaboratedConfiguredPackage -> DistDirParams
-elabDistDirParams shared elab = DistDirParams {
- distParamUnitId = installedUnitId elab,
- distParamComponentId = elabComponentId elab,
- distParamPackageId = elabPkgSourceId elab,
- distParamComponentName = case elabPkgOrComp elab of
- ElabComponent comp -> compComponentName comp
- ElabPackage _ -> Nothing,
- distParamCompilerId = compilerId (pkgConfigCompiler shared),
- distParamPlatform = pkgConfigPlatform shared,
- distParamOptimization = elabOptimization elab
+elabDistDirParams shared elab =
+ DistDirParams
+ { distParamUnitId = installedUnitId elab
+ , distParamComponentId = elabComponentId elab
+ , distParamPackageId = elabPkgSourceId elab
+ , distParamComponentName = case elabPkgOrComp elab of
+ ElabComponent comp -> compComponentName comp
+ ElabPackage _ -> Nothing
+ , distParamCompilerId = compilerId (pkgConfigCompiler shared)
+ , distParamPlatform = pkgConfigPlatform shared
+ , distParamOptimization = elabOptimization elab
}
-- | The full set of dependencies which dictate what order we
@@ -529,44 +522,46 @@ elabDistDirParams shared elab = DistDirParams {
-- NB: this method DOES include setup deps.
elabOrderDependencies :: ElaboratedConfiguredPackage -> [UnitId]
elabOrderDependencies elab =
- case elabPkgOrComp elab of
- -- Important not to have duplicates: otherwise InstallPlan gets
- -- confused.
- ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))
- ElabComponent comp -> compOrderDependencies comp
+ case elabPkgOrComp elab of
+ -- Important not to have duplicates: otherwise InstallPlan gets
+ -- confused.
+ ElabPackage pkg -> ordNub (CD.flatDeps (pkgOrderDependencies pkg))
+ ElabComponent comp -> compOrderDependencies comp
-- | Like 'elabOrderDependencies', but only returns dependencies on
-- libraries.
elabOrderLibDependencies :: ElaboratedConfiguredPackage -> [UnitId]
elabOrderLibDependencies elab =
- case elabPkgOrComp elab of
- ElabPackage pkg -> map (newSimpleUnitId . confInstId) $
- ordNub $ CD.flatDeps (pkgLibDependencies pkg)
- ElabComponent comp -> compOrderLibDependencies comp
+ case elabPkgOrComp elab of
+ ElabPackage pkg ->
+ map (newSimpleUnitId . confInstId) $
+ ordNub $
+ CD.flatDeps (pkgLibDependencies pkg)
+ ElabComponent comp -> compOrderLibDependencies comp
-- | The library dependencies (i.e., the libraries we depend on, NOT
-- the dependencies of the library), NOT including setup dependencies.
-- These are passed to the @Setup@ script via @--dependency@.
elabLibDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]
elabLibDependencies elab =
- case elabPkgOrComp elab of
- ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg))
- ElabComponent comp -> compLibDependencies comp
+ case elabPkgOrComp elab of
+ ElabPackage pkg -> ordNub (CD.nonSetupDeps (pkgLibDependencies pkg))
+ ElabComponent comp -> compLibDependencies comp
-- | Like 'elabOrderDependencies', but only returns dependencies on
-- executables. (This coincides with 'elabExeDependencies'.)
elabOrderExeDependencies :: ElaboratedConfiguredPackage -> [UnitId]
elabOrderExeDependencies =
- map newSimpleUnitId . elabExeDependencies
+ map newSimpleUnitId . elabExeDependencies
-- | The executable dependencies (i.e., the executables we depend on);
-- these are the executables we must add to the PATH before we invoke
-- the setup script.
elabExeDependencies :: ElaboratedConfiguredPackage -> [ComponentId]
elabExeDependencies elab = map confInstId $
- case elabPkgOrComp elab of
- ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg)
- ElabComponent comp -> compExeDependencies comp
+ case elabPkgOrComp elab of
+ ElabPackage pkg -> CD.nonSetupDeps (pkgExeDependencies pkg)
+ ElabComponent comp -> compExeDependencies comp
-- | This returns the paths of all the executables we depend on; we
-- must add these paths to PATH before invoking the setup script.
@@ -574,26 +569,26 @@ elabExeDependencies elab = map confInstId $
-- actually want to build something.)
elabExeDependencyPaths :: ElaboratedConfiguredPackage -> [FilePath]
elabExeDependencyPaths elab =
- case elabPkgOrComp elab of
- ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg)
- ElabComponent comp -> map snd (compExeDependencyPaths comp)
+ case elabPkgOrComp elab of
+ ElabPackage pkg -> map snd $ CD.nonSetupDeps (pkgExeDependencyPaths pkg)
+ ElabComponent comp -> map snd (compExeDependencyPaths comp)
-- | The setup dependencies (the library dependencies of the setup executable;
-- note that it is not legal for setup scripts to have executable
-- dependencies at the moment.)
elabSetupDependencies :: ElaboratedConfiguredPackage -> [ConfiguredId]
elabSetupDependencies elab =
- case elabPkgOrComp elab of
- ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg)
- -- TODO: Custom setups not supported for components yet. When
- -- they are, need to do this differently
- ElabComponent _ -> []
+ case elabPkgOrComp elab of
+ ElabPackage pkg -> CD.setupDeps (pkgLibDependencies pkg)
+ -- TODO: Custom setups not supported for components yet. When
+ -- they are, need to do this differently
+ ElabComponent _ -> []
elabPkgConfigDependencies :: ElaboratedConfiguredPackage -> [(PkgconfigName, Maybe PkgconfigVersion)]
-elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabPackage pkg }
- = pkgPkgConfigDependencies pkg
-elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComponent comp }
- = compPkgConfigDependencies comp
+elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabPackage pkg} =
+ pkgPkgConfigDependencies pkg
+elabPkgConfigDependencies ElaboratedConfiguredPackage{elabPkgOrComp = ElabComponent comp} =
+ compPkgConfigDependencies comp
-- | The cache files of all our inplace dependencies which,
-- when updated, require us to rebuild. See #4202 for
@@ -616,17 +611,17 @@ elabPkgConfigDependencies ElaboratedConfiguredPackage { elabPkgOrComp = ElabComp
-- here will never work if we want to implement unchanging
-- rebuilds.
elabInplaceDependencyBuildCacheFiles
- :: DistDirLayout
- -> ElaboratedSharedConfig
- -> ElaboratedInstallPlan
- -> ElaboratedConfiguredPackage
- -> [FilePath]
+ :: DistDirLayout
+ -> ElaboratedSharedConfig
+ -> ElaboratedInstallPlan
+ -> ElaboratedConfiguredPackage
+ -> [FilePath]
elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab =
- go =<< InstallPlan.directDeps plan (nodeKey root_elab)
+ go =<< InstallPlan.directDeps plan (nodeKey root_elab)
where
go = InstallPlan.foldPlanPackage (const []) $ \elab -> do
- guard (elabBuildStyle elab == BuildInplaceOnly)
- return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build"
+ guard (elabBuildStyle elab == BuildInplaceOnly)
+ return $ distPackageCacheFile layout (elabDistDirParams sconf elab) "build"
-- | Some extra metadata associated with an
-- 'ElaboratedConfiguredPackage' which indicates that the "package"
@@ -635,42 +630,41 @@ elabInplaceDependencyBuildCacheFiles layout sconf plan root_elab =
-- package work items and component work items, but I've structured
-- it this way to minimize change to the existing code (which I
-- don't feel qualified to rewrite.)
-data ElaboratedComponent
- = ElaboratedComponent {
- -- | The name of the component to be built according to the solver
- compSolverName :: CD.Component,
- -- | The name of the component to be built. Nothing if
- -- it's a setup dep.
- compComponentName :: Maybe ComponentName,
- -- | The *external* library dependencies of this component. We
- -- pass this to the configure script.
- compLibDependencies :: [ConfiguredId],
- -- | In a component prior to instantiation, this list specifies
- -- the 'OpenUnitId's which, after instantiation, are the
- -- actual dependencies of this package. Note that this does
- -- NOT include signature packages, which do not turn into real
- -- ordering dependencies when we instantiate. This is intended to be
- -- a purely temporary field, to carry some information to the
- -- instantiation phase. It's more precise than
- -- 'compLibDependencies', and also stores information about internal
- -- dependencies.
- compLinkedLibDependencies :: [OpenUnitId],
- -- | The executable dependencies of this component (including
- -- internal executables).
- compExeDependencies :: [ConfiguredId],
- -- | The @pkg-config@ dependencies of the component
- compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)],
- -- | The paths all our executable dependencies will be installed
- -- to once they are installed.
- compExeDependencyPaths :: [(ConfiguredId, FilePath)],
- -- | The UnitIds of the libraries (identifying elaborated packages/
- -- components) that must be built before this project. This
- -- is used purely for ordering purposes. It can contain both
- -- references to definite and indefinite packages; an indefinite
- -- UnitId indicates that we must typecheck that indefinite package
- -- before we can build this one.
- compOrderLibDependencies :: [UnitId]
- }
+data ElaboratedComponent = ElaboratedComponent
+ { compSolverName :: CD.Component
+ -- ^ The name of the component to be built according to the solver
+ , compComponentName :: Maybe ComponentName
+ -- ^ The name of the component to be built. Nothing if
+ -- it's a setup dep.
+ , compLibDependencies :: [ConfiguredId]
+ -- ^ The *external* library dependencies of this component. We
+ -- pass this to the configure script.
+ , compLinkedLibDependencies :: [OpenUnitId]
+ -- ^ In a component prior to instantiation, this list specifies
+ -- the 'OpenUnitId's which, after instantiation, are the
+ -- actual dependencies of this package. Note that this does
+ -- NOT include signature packages, which do not turn into real
+ -- ordering dependencies when we instantiate. This is intended to be
+ -- a purely temporary field, to carry some information to the
+ -- instantiation phase. It's more precise than
+ -- 'compLibDependencies', and also stores information about internal
+ -- dependencies.
+ , compExeDependencies :: [ConfiguredId]
+ -- ^ The executable dependencies of this component (including
+ -- internal executables).
+ , compPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)]
+ -- ^ The @pkg-config@ dependencies of the component
+ , compExeDependencyPaths :: [(ConfiguredId, FilePath)]
+ -- ^ The paths all our executable dependencies will be installed
+ -- to once they are installed.
+ , compOrderLibDependencies :: [UnitId]
+ -- ^ The UnitIds of the libraries (identifying elaborated packages/
+ -- components) that must be built before this project. This
+ -- is used purely for ordering purposes. It can contain both
+ -- references to definite and indefinite packages; an indefinite
+ -- UnitId indicates that we must typecheck that indefinite package
+ -- before we can build this one.
+ }
deriving (Eq, Show, Generic)
instance Binary ElaboratedComponent
@@ -679,47 +673,35 @@ instance Structured ElaboratedComponent
-- | See 'elabOrderDependencies'.
compOrderDependencies :: ElaboratedComponent -> [UnitId]
compOrderDependencies comp =
- compOrderLibDependencies comp
- ++ compOrderExeDependencies comp
+ compOrderLibDependencies comp
+ ++ compOrderExeDependencies comp
-- | See 'elabOrderExeDependencies'.
compOrderExeDependencies :: ElaboratedComponent -> [UnitId]
compOrderExeDependencies = map (newSimpleUnitId . confInstId) . compExeDependencies
-data ElaboratedPackage
- = ElaboratedPackage {
- pkgInstalledId :: InstalledPackageId,
-
- -- | The exact dependencies (on other plan packages)
- --
- pkgLibDependencies :: ComponentDeps [ConfiguredId],
-
- -- | Components which depend (transitively) on an internally
- -- defined library. These are used by 'elabRequiresRegistration',
- -- to determine if a user-requested build is going to need
- -- a library registration
- --
- pkgDependsOnSelfLib :: ComponentDeps [()],
-
- -- | Dependencies on executable packages.
- --
- pkgExeDependencies :: ComponentDeps [ConfiguredId],
-
- -- | Paths where executable dependencies live.
- --
- pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)],
-
- -- | Dependencies on @pkg-config@ packages.
- -- NB: this is NOT per-component (although it could be)
- -- because Cabal library does not track per-component
- -- pkg-config depends; it always does them all at once.
- --
- pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)],
-
- -- | Which optional stanzas (ie testsuites, benchmarks) will actually
- -- be enabled during the package configure step.
- pkgStanzasEnabled :: OptionalStanzaSet
- }
+data ElaboratedPackage = ElaboratedPackage
+ { pkgInstalledId :: InstalledPackageId
+ , pkgLibDependencies :: ComponentDeps [ConfiguredId]
+ -- ^ The exact dependencies (on other plan packages)
+ , pkgDependsOnSelfLib :: ComponentDeps [()]
+ -- ^ Components which depend (transitively) on an internally
+ -- defined library. These are used by 'elabRequiresRegistration',
+ -- to determine if a user-requested build is going to need
+ -- a library registration
+ , pkgExeDependencies :: ComponentDeps [ConfiguredId]
+ -- ^ Dependencies on executable packages.
+ , pkgExeDependencyPaths :: ComponentDeps [(ConfiguredId, FilePath)]
+ -- ^ Paths where executable dependencies live.
+ , pkgPkgConfigDependencies :: [(PkgconfigName, Maybe PkgconfigVersion)]
+ -- ^ Dependencies on @pkg-config@ packages.
+ -- NB: this is NOT per-component (although it could be)
+ -- because Cabal library does not track per-component
+ -- pkg-config depends; it always does them all at once.
+ , pkgStanzasEnabled :: OptionalStanzaSet
+ -- ^ Which optional stanzas (ie testsuites, benchmarks) will actually
+ -- be enabled during the package configure step.
+ }
deriving (Eq, Show, Generic)
instance Binary ElaboratedPackage
@@ -729,53 +711,48 @@ instance Structured ElaboratedPackage
-- which can be useful in some circumstances.
pkgOrderDependencies :: ElaboratedPackage -> ComponentDeps [UnitId]
pkgOrderDependencies pkg =
- fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg) `Mon.mappend`
- fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg)
+ fmap (map (newSimpleUnitId . confInstId)) (pkgLibDependencies pkg)
+ `Mon.mappend` fmap (map (newSimpleUnitId . confInstId)) (pkgExeDependencies pkg)
-- | This is used in the install plan to indicate how the package will be
-- built.
---
-data BuildStyle =
- -- | The classic approach where the package is built, then the files
+data BuildStyle
+ = -- | The classic approach where the package is built, then the files
-- installed into some location and the result registered in a package db.
--
-- If the package came from a tarball then it's built in a temp dir and
-- the results discarded.
BuildAndInstall
-
- -- | The package is built, but the files are not installed anywhere,
+ | -- | The package is built, but the files are not installed anywhere,
-- rather the build dir is kept and the package is registered inplace.
--
-- Such packages can still subsequently be installed.
--
-- Typically 'BuildAndInstall' packages will only depend on other
-- 'BuildAndInstall' style packages and not on 'BuildInplaceOnly' ones.
- --
- | BuildInplaceOnly
+ BuildInplaceOnly
deriving (Eq, Show, Generic)
instance Binary BuildStyle
instance Structured BuildStyle
instance Semigroup BuildStyle where
- BuildInplaceOnly <> _ = BuildInplaceOnly
- _ <> BuildInplaceOnly = BuildInplaceOnly
- _ <> _ = BuildAndInstall
+ BuildInplaceOnly <> _ = BuildInplaceOnly
+ _ <> BuildInplaceOnly = BuildInplaceOnly
+ _ <> _ = BuildAndInstall
instance Monoid BuildStyle where
- mempty = BuildAndInstall
- mappend = (<>)
+ mempty = BuildAndInstall
+ mappend = (<>)
type CabalFileText = LBS.ByteString
type ElaboratedReadyPackage = GenericReadyPackage ElaboratedConfiguredPackage
-
---------------------------
-- Build targets
--
-- | Specific targets within a package or component to act on e.g. to build,
-- haddock or open a repl.
---
data ComponentTarget = ComponentTarget ComponentName SubComponentTarget
deriving (Eq, Ord, Show, Generic)
@@ -786,14 +763,14 @@ instance Structured ComponentTarget
-- to a Cabal Setup script.
showComponentTarget :: PackageId -> ComponentTarget -> String
showComponentTarget pkgid =
- Cabal.showBuildTarget pkgid . toBuildTarget
+ Cabal.showBuildTarget pkgid . toBuildTarget
where
toBuildTarget :: ComponentTarget -> Cabal.BuildTarget
toBuildTarget (ComponentTarget cname subtarget) =
case subtarget of
- WholeComponent -> Cabal.BuildTargetComponent cname
- ModuleTarget mname -> Cabal.BuildTargetModule cname mname
- FileTarget fname -> Cabal.BuildTargetFile cname fname
+ WholeComponent -> Cabal.BuildTargetComponent cname
+ ModuleTarget mname -> Cabal.BuildTargetModule cname mname
+ FileTarget fname -> Cabal.BuildTargetFile cname fname
showTestComponentTarget :: PackageId -> ComponentTarget -> Maybe String
showTestComponentTarget _ (ComponentTarget (CTestName n) _) = Just $ prettyShow n
@@ -801,7 +778,7 @@ showTestComponentTarget _ _ = Nothing
isTestComponentTarget :: ComponentTarget -> Bool
isTestComponentTarget (ComponentTarget (CTestName _) _) = True
-isTestComponentTarget _ = False
+isTestComponentTarget _ = False
showBenchComponentTarget :: PackageId -> ComponentTarget -> Maybe String
showBenchComponentTarget _ (ComponentTarget (CBenchName n) _) = Just $ prettyShow n
@@ -809,24 +786,24 @@ showBenchComponentTarget _ _ = Nothing
isBenchComponentTarget :: ComponentTarget -> Bool
isBenchComponentTarget (ComponentTarget (CBenchName _) _) = True
-isBenchComponentTarget _ = False
+isBenchComponentTarget _ = False
isForeignLibComponentTarget :: ComponentTarget -> Bool
isForeignLibComponentTarget (ComponentTarget (CFLibName _) _) = True
-isForeignLibComponentTarget _ = False
+isForeignLibComponentTarget _ = False
isExeComponentTarget :: ComponentTarget -> Bool
-isExeComponentTarget (ComponentTarget (CExeName _) _ ) = True
-isExeComponentTarget _ = False
+isExeComponentTarget (ComponentTarget (CExeName _) _) = True
+isExeComponentTarget _ = False
isSubLibComponentTarget :: ComponentTarget -> Bool
isSubLibComponentTarget (ComponentTarget (CLibName (LSubLibName _)) _) = True
-isSubLibComponentTarget _ = False
+isSubLibComponentTarget _ = False
componentOptionalStanza :: CD.Component -> Maybe OptionalStanza
-componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas
+componentOptionalStanza (CD.ComponentTest _) = Just TestStanzas
componentOptionalStanza (CD.ComponentBench _) = Just BenchStanzas
-componentOptionalStanza _ = Nothing
+componentOptionalStanza _ = Nothing
---------------------------
-- Setup.hs script policy
@@ -848,11 +825,11 @@ componentOptionalStanza _ = Nothing
-- while in case 4 we can use the internal library API. In case 3 we also have
-- to build an external Setup.hs script because the package needs a later
-- Cabal lib version than we can support internally.
---
-data SetupScriptStyle = SetupCustomExplicitDeps
- | SetupCustomImplicitDeps
- | SetupNonCustomExternalLib
- | SetupNonCustomInternalLib
+data SetupScriptStyle
+ = SetupCustomExplicitDeps
+ | SetupCustomImplicitDeps
+ | SetupNonCustomExternalLib
+ | SetupNonCustomInternalLib
deriving (Eq, Show, Generic, Typeable)
instance Binary SetupScriptStyle
diff --git a/cabal-install/src/Distribution/Client/RebuildMonad.hs b/cabal-install/src/Distribution/Client/RebuildMonad.hs
index f7b169f418f20794b07042c70cdb4cd24f4e7961..89378922d6660bd5177641c7cfe0afd22b9725d7 100644
--- a/cabal-install/src/Distribution/Client/RebuildMonad.hs
+++ b/cabal-install/src/Distribution/Client/RebuildMonad.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- | An abstraction for re-running actions if values or files have changed.
--
@@ -7,56 +9,56 @@
--
-- It's a convenient interface to the "Distribution.Client.FileMonitor"
-- functions.
---
-module Distribution.Client.RebuildMonad (
- -- * Rebuild monad
- Rebuild,
- runRebuild,
- execRebuild,
- askRoot,
+module Distribution.Client.RebuildMonad
+ ( -- * Rebuild monad
+ Rebuild
+ , runRebuild
+ , execRebuild
+ , askRoot
-- * Setting up file monitoring
- monitorFiles,
- MonitorFilePath,
- monitorFile,
- monitorFileHashed,
- monitorNonExistentFile,
- monitorDirectory,
- monitorNonExistentDirectory,
- monitorDirectoryExistence,
- monitorFileOrDirectory,
- monitorFileSearchPath,
- monitorFileHashedSearchPath,
+ , monitorFiles
+ , MonitorFilePath
+ , monitorFile
+ , monitorFileHashed
+ , monitorNonExistentFile
+ , monitorDirectory
+ , monitorNonExistentDirectory
+ , monitorDirectoryExistence
+ , monitorFileOrDirectory
+ , monitorFileSearchPath
+ , monitorFileHashedSearchPath
+
-- ** Monitoring file globs
- monitorFileGlob,
- monitorFileGlobExistence,
- FilePathGlob(..),
- FilePathRoot(..),
- FilePathGlobRel(..),
- GlobPiece(..),
+ , monitorFileGlob
+ , monitorFileGlobExistence
+ , FilePathGlob (..)
+ , FilePathRoot (..)
+ , FilePathGlobRel (..)
+ , GlobPiece (..)
-- * Using a file monitor
- FileMonitor(..),
- newFileMonitor,
- rerunIfChanged,
+ , FileMonitor (..)
+ , newFileMonitor
+ , rerunIfChanged
-- * Utils
- delayInitSharedResource,
- delayInitSharedResources,
- matchFileGlob,
- getDirectoryContentsMonitored,
- createDirectoryMonitored,
- monitorDirectoryStatus,
- doesFileExistMonitored,
- need,
- needIfExists,
- findFileWithExtensionMonitored,
- findFirstFileMonitored,
- findFileMonitored,
+ , delayInitSharedResource
+ , delayInitSharedResources
+ , matchFileGlob
+ , getDirectoryContentsMonitored
+ , createDirectoryMonitored
+ , monitorDirectoryStatus
+ , doesFileExistMonitored
+ , need
+ , needIfExists
+ , findFileWithExtensionMonitored
+ , findFirstFileMonitored
+ , findFileMonitored
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Distribution.Client.FileMonitor
import Distribution.Client.Glob hiding (matchFileGlob)
@@ -64,18 +66,16 @@ import qualified Distribution.Client.Glob as Glob (matchFileGlob)
import Distribution.Simple.Utils (debug)
-import qualified Data.Map.Strict as Map
-import Control.Monad.State as State
+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)
import Control.Monad.Reader as Reader
-import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
-import System.FilePath
+import Control.Monad.State as State
+import qualified Data.Map.Strict as Map
import System.Directory
-
+import System.FilePath
-- | A monad layered on top of 'IO' to help with re-running actions when the
-- input files and values they depend on change. The crucial operations are
-- 'rerunIfChanged' and 'monitorFiles'.
---
newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)
deriving (Functor, Applicative, Monad, MonadIO)
@@ -86,9 +86,8 @@ newtype Rebuild a = Rebuild (ReaderT FilePath (StateT [MonitorFilePath] IO) a)
--
-- Relative paths are interpreted as relative to an implicit root, ultimately
-- passed in to 'runRebuild'.
---
monitorFiles :: [MonitorFilePath] -> Rebuild ()
-monitorFiles filespecs = Rebuild (State.modify (filespecs++))
+monitorFiles filespecs = Rebuild (State.modify (filespecs ++))
-- | Run a 'Rebuild' IO action.
unRebuild :: FilePath -> Rebuild a -> IO (a, [MonitorFilePath])
@@ -114,40 +113,51 @@ askRoot = Rebuild Reader.ask
-- The result is still in the 'Rebuild' monad, so these can be nested.
--
-- Do not share 'FileMonitor's between different uses of 'rerunIfChanged'.
---
-rerunIfChanged :: (Binary a, Structured a, Binary b, Structured b)
- => Verbosity
- -> FileMonitor a b
- -> a
- -> Rebuild b
- -> Rebuild b
+rerunIfChanged
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => Verbosity
+ -> FileMonitor a b
+ -> a
+ -> Rebuild b
+ -> Rebuild b
rerunIfChanged verbosity monitor key action = do
- rootDir <- askRoot
- changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
- case changed of
- MonitorUnchanged result files -> do
- liftIO $ debug verbosity $ "File monitor '" ++ monitorName
- ++ "' unchanged."
- monitorFiles files
- return result
-
- MonitorChanged reason -> do
- liftIO $ debug verbosity $ "File monitor '" ++ monitorName
- ++ "' changed: " ++ showReason reason
- startTime <- liftIO $ beginUpdateFileMonitor
- (result, files) <- liftIO $ unRebuild rootDir action
- liftIO $ updateFileMonitor monitor rootDir
- (Just startTime) files key result
- monitorFiles files
- return result
+ rootDir <- askRoot
+ changed <- liftIO $ checkFileMonitorChanged monitor rootDir key
+ case changed of
+ MonitorUnchanged result files -> do
+ liftIO $
+ debug verbosity $
+ "File monitor '"
+ ++ monitorName
+ ++ "' unchanged."
+ monitorFiles files
+ return result
+ MonitorChanged reason -> do
+ liftIO $
+ debug verbosity $
+ "File monitor '"
+ ++ monitorName
+ ++ "' changed: "
+ ++ showReason reason
+ startTime <- liftIO $ beginUpdateFileMonitor
+ (result, files) <- liftIO $ unRebuild rootDir action
+ liftIO $
+ updateFileMonitor
+ monitor
+ rootDir
+ (Just startTime)
+ files
+ key
+ result
+ monitorFiles files
+ return result
where
monitorName = takeFileName (fileMonitorCacheFile monitor)
showReason (MonitoredFileChanged file) = "file " ++ file
- showReason (MonitoredValueChanged _) = "monitor value changed"
- showReason MonitorFirstRun = "first run"
- showReason MonitorCorruptCache = "invalid cache file"
-
+ showReason (MonitoredValueChanged _) = "monitor value changed"
+ showReason MonitorFirstRun = "first run"
+ showReason MonitorCorruptCache = "invalid cache file"
-- | When using 'rerunIfChanged' for each element of a list of actions, it is
-- sometimes the case that each action needs to make use of some resource. e.g.
@@ -176,22 +186,20 @@ rerunIfChanged verbosity monitor key action = do
-- > resource <- getResource
-- > ... -- use the resource
-- > | ... ]
---
delayInitSharedResource :: forall a. IO a -> Rebuild (Rebuild a)
delayInitSharedResource action = do
- var <- liftIO (newMVar Nothing)
- return (liftIO (getOrInitResource var))
+ var <- liftIO (newMVar Nothing)
+ return (liftIO (getOrInitResource var))
where
getOrInitResource :: MVar (Maybe a) -> IO a
getOrInitResource var =
modifyMVar var $ \mx ->
case mx of
- Just x -> return (Just x, x)
+ Just x -> return (Just x, x)
Nothing -> do
x <- action
return (Just x, x)
-
-- | Much like 'delayInitSharedResource' but for a keyed set of resources.
--
-- > getResource <- delayInitSharedResource mkResource
@@ -200,69 +208,72 @@ delayInitSharedResource action = do
-- > resource <- getResource key
-- > ... -- use the resource
-- > | ... ]
---
-delayInitSharedResources :: forall k v. Ord k
- => (k -> IO v)
- -> Rebuild (k -> Rebuild v)
+delayInitSharedResources
+ :: forall k v
+ . Ord k
+ => (k -> IO v)
+ -> Rebuild (k -> Rebuild v)
delayInitSharedResources action = do
- var <- liftIO (newMVar Map.empty)
- return (liftIO . getOrInitResource var)
+ var <- liftIO (newMVar Map.empty)
+ return (liftIO . getOrInitResource var)
where
getOrInitResource :: MVar (Map k v) -> k -> IO v
getOrInitResource var k =
modifyMVar var $ \m ->
case Map.lookup k m of
- Just x -> return (m, x)
+ Just x -> return (m, x)
Nothing -> do
x <- action k
let !m' = Map.insert k x m
return (m', x)
-
-- | Utility to match a file glob against the file system, starting from a
-- given root directory. The results are all relative to the given root.
--
-- Since this operates in the 'Rebuild' monad, it also monitors the given glob
-- for changes.
---
matchFileGlob :: FilePathGlob -> Rebuild [FilePath]
matchFileGlob glob = do
- root <- askRoot
- monitorFiles [monitorFileGlobExistence glob]
- liftIO $ Glob.matchFileGlob root glob
+ root <- askRoot
+ monitorFiles [monitorFileGlobExistence glob]
+ liftIO $ Glob.matchFileGlob root glob
getDirectoryContentsMonitored :: FilePath -> Rebuild [FilePath]
getDirectoryContentsMonitored dir = do
- exists <- monitorDirectoryStatus dir
- if exists
- then liftIO $ getDirectoryContents dir
- else return []
+ exists <- monitorDirectoryStatus dir
+ if exists
+ then liftIO $ getDirectoryContents dir
+ else return []
createDirectoryMonitored :: Bool -> FilePath -> Rebuild ()
createDirectoryMonitored createParents dir = do
- monitorFiles [monitorDirectoryExistence dir]
- liftIO $ createDirectoryIfMissing createParents dir
+ monitorFiles [monitorDirectoryExistence dir]
+ liftIO $ createDirectoryIfMissing createParents dir
-- | Monitor a directory as in 'monitorDirectory' if it currently exists or
-- as 'monitorNonExistentDirectory' if it does not.
monitorDirectoryStatus :: FilePath -> Rebuild Bool
monitorDirectoryStatus dir = do
- exists <- liftIO $ doesDirectoryExist dir
- monitorFiles [if exists
- then monitorDirectory dir
- else monitorNonExistentDirectory dir]
- return exists
+ exists <- liftIO $ doesDirectoryExist dir
+ monitorFiles
+ [ if exists
+ then monitorDirectory dir
+ else monitorNonExistentDirectory dir
+ ]
+ return exists
-- | Like 'doesFileExist', but in the 'Rebuild' monad. This does
-- NOT track the contents of 'FilePath'; use 'need' in that case.
doesFileExistMonitored :: FilePath -> Rebuild Bool
doesFileExistMonitored f = do
- root <- askRoot
- exists <- liftIO $ doesFileExist (root </> f)
- monitorFiles [if exists
- then monitorFileExistence f
- else monitorNonExistentFile f]
- return exists
+ root <- askRoot
+ exists <- liftIO $ doesFileExist (root </> f)
+ monitorFiles
+ [ if exists
+ then monitorFileExistence f
+ else monitorNonExistentFile f
+ ]
+ return exists
-- | Monitor a single file
need :: FilePath -> Rebuild ()
@@ -275,37 +286,45 @@ need f = monitorFiles [monitorFileHashed f]
-- need'ed a non-existent file).
needIfExists :: FilePath -> Rebuild ()
needIfExists f = do
- root <- askRoot
- exists <- liftIO $ doesFileExist (root </> f)
- monitorFiles [if exists
- then monitorFileHashed f
- else monitorNonExistentFile f]
+ root <- askRoot
+ exists <- liftIO $ doesFileExist (root </> f)
+ monitorFiles
+ [ if exists
+ then monitorFileHashed f
+ else monitorNonExistentFile f
+ ]
-- | Like 'findFileWithExtension', but in the 'Rebuild' monad.
findFileWithExtensionMonitored
- :: [String]
- -> [FilePath]
- -> FilePath
- -> Rebuild (Maybe FilePath)
+ :: [String]
+ -> [FilePath]
+ -> FilePath
+ -> Rebuild (Maybe FilePath)
findFileWithExtensionMonitored extensions searchPath baseName =
- findFirstFileMonitored id
+ findFirstFileMonitored
+ id
[ path </> baseName <.> ext
| path <- nub searchPath
- , ext <- nub extensions ]
+ , ext <- nub extensions
+ ]
-- | Like 'findFirstFile', but in the 'Rebuild' monad.
findFirstFileMonitored :: forall a. (a -> FilePath) -> [a] -> Rebuild (Maybe a)
findFirstFileMonitored file = findFirst
- where findFirst :: [a] -> Rebuild (Maybe a)
- findFirst [] = return Nothing
- findFirst (x:xs) = do exists <- doesFileExistMonitored (file x)
- if exists
- then return (Just x)
- else findFirst xs
+ where
+ findFirst :: [a] -> Rebuild (Maybe a)
+ findFirst [] = return Nothing
+ findFirst (x : xs) = do
+ exists <- doesFileExistMonitored (file x)
+ if exists
+ then return (Just x)
+ else findFirst xs
-- | Like 'findFile', but in the 'Rebuild' monad.
findFileMonitored :: [FilePath] -> FilePath -> Rebuild (Maybe FilePath)
findFileMonitored searchPath fileName =
- findFirstFileMonitored id
+ findFirstFileMonitored
+ id
[ path </> fileName
- | path <- nub searchPath]
+ | path <- nub searchPath
+ ]
diff --git a/cabal-install/src/Distribution/Client/Reconfigure.hs b/cabal-install/src/Distribution/Client/Reconfigure.hs
index 1c015274f4a47a5e39c69302225727bd8f83168b..a5ba2a0853329f5d157778ac69076baf5323370b 100644
--- a/cabal-install/src/Distribution/Client/Reconfigure.hs
+++ b/cabal-install/src/Distribution/Client/Reconfigure.hs
@@ -1,31 +1,39 @@
-module Distribution.Client.Reconfigure ( Check(..), reconfigure ) where
+module Distribution.Client.Reconfigure (Check (..), reconfigure) where
import Distribution.Client.Compat.Prelude
-import Data.Monoid ( Any(..) )
-import System.Directory ( doesFileExist )
+import Data.Monoid (Any (..))
+import System.Directory (doesFileExist)
-import Distribution.Simple.Configure ( localBuildInfoFile )
-import Distribution.Simple.Setup ( Flag, flagToMaybe, toFlag )
+import Distribution.Simple.Configure (localBuildInfoFile)
+import Distribution.Simple.Setup (Flag, flagToMaybe, toFlag)
import Distribution.Simple.Utils
- ( existsAndIsMoreRecentThan, defaultPackageDesc, info )
-
-import Distribution.Client.Config ( SavedConfig(..) )
-import Distribution.Client.Configure ( readConfigFlags )
-import Distribution.Client.Nix ( findNixExpr, inNixShell, nixInstantiate )
-import Distribution.Client.Sandbox ( findSavedDistPref, updateInstallDirs )
+ ( defaultPackageDesc
+ , existsAndIsMoreRecentThan
+ , info
+ )
+
+import Distribution.Client.Config (SavedConfig (..))
+import Distribution.Client.Configure (readConfigFlags)
+import Distribution.Client.Nix (findNixExpr, inNixShell, nixInstantiate)
+import Distribution.Client.Sandbox (findSavedDistPref, updateInstallDirs)
import Distribution.Client.Sandbox.PackageEnvironment
- ( userPackageEnvironmentFile )
+ ( userPackageEnvironmentFile
+ )
import Distribution.Client.Setup
- ( ConfigFlags(..), ConfigExFlags, GlobalFlags(..) )
+ ( ConfigExFlags
+ , ConfigFlags (..)
+ , GlobalFlags (..)
+ )
-- | @Check@ represents a function to check some condition on type @a@. The
-- returned 'Any' is 'True' if any part of the condition failed.
-newtype Check a = Check {
- runCheck :: Any -- Did any previous check fail?
- -> a -- value returned by previous checks
- -> IO (Any, a) -- Did this check fail? What value is returned?
-}
+newtype Check a = Check
+ { runCheck
+ :: Any -- Did any previous check fail?
+ -> a -- value returned by previous checks
+ -> IO (Any, a) -- Did this check fail? What value is returned?
+ }
instance Semigroup (Check a) where
(<>) c d = Check $ \any0 a0 -> do
@@ -37,7 +45,6 @@ instance Monoid (Check a) where
mempty = Check $ \_ a -> return (mempty, a)
mappend = (<>)
-
-- | Re-configure the package in the current directory if needed. Deciding
-- when to reconfigure and with which options is convoluted:
--
@@ -70,19 +77,21 @@ instance Monoid (Check a) where
-- a previous configuration exists.
reconfigure
:: ((ConfigFlags, ConfigExFlags) -> [String] -> GlobalFlags -> IO ())
- -- ^ configure action
+ -- ^ configure action
-> Verbosity
- -- ^ Verbosity setting
+ -- ^ Verbosity setting
-> FilePath
- -- ^ \"dist\" prefix
+ -- ^ \"dist\" prefix
-> Flag (Maybe Int)
- -- ^ -j flag for reinstalling add-source deps.
+ -- ^ -j flag for reinstalling add-source deps.
-> Check (ConfigFlags, ConfigExFlags)
- -- ^ Check that the required flags are set.
- -- If they are not set, provide a message explaining the
- -- reason for reconfiguration.
- -> [String] -- ^ Extra arguments
- -> GlobalFlags -- ^ Global flags
+ -- ^ Check that the required flags are set.
+ -- If they are not set, provide a message explaining the
+ -- reason for reconfiguration.
+ -> [String]
+ -- ^ Extra arguments
+ -> GlobalFlags
+ -- ^ Global flags
-> SavedConfig
-> IO SavedConfig
reconfigure
@@ -93,97 +102,98 @@ reconfigure
check
extraArgs
globalFlags
- config
- = do
-
- savedFlags@(_, _) <- readConfigFlags dist
-
- useNix <- fmap isJust (findNixExpr globalFlags config)
- alreadyInNixShell <- inNixShell
-
- if useNix && not alreadyInNixShell
- then do
-
- -- If we are using Nix, we must reinstantiate the derivation outside
- -- the shell. Eventually, the caller will invoke 'nixShell' which will
- -- rerun cabal inside the shell. That will bring us back to 'reconfigure',
- -- but inside the shell we'll take the second branch, below.
-
- -- This seems to have a problem: won't 'configureAction' call 'nixShell'
- -- yet again, spawning an infinite tree of subprocesses?
- -- No, because 'nixShell' doesn't spawn a new process if it is already
- -- running in a Nix shell.
-
- nixInstantiate verbosity dist False globalFlags config
- return config
-
- else do
-
- let checks :: Check (ConfigFlags, ConfigExFlags)
- checks =
- checkVerb
- <> checkDist
- <> checkOutdated
- <> check
- (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags
-
- let config' :: SavedConfig
- config' = updateInstallDirs (configUserInstall configFlags) config
-
- when frc $ configureAction flags extraArgs globalFlags
- return config'
-
- where
-
- -- Changing the verbosity does not require reconfiguration, but the new
- -- verbosity should be used if reconfiguring.
- checkVerb :: Check (ConfigFlags, b)
- checkVerb = Check $ \_ (configFlags, configExFlags) -> do
- let configFlags' :: ConfigFlags
- configFlags' = configFlags { configVerbosity = toFlag verbosity}
- return (mempty, (configFlags', configExFlags))
-
- -- Reconfiguration is required if @--build-dir@ changes.
- checkDist :: Check (ConfigFlags, b)
- checkDist = Check $ \_ (configFlags, configExFlags) -> do
- -- Always set the chosen @--build-dir@ before saving the flags,
- -- or bad things could happen.
- savedDist <- findSavedDistPref config (configDistPref configFlags)
- let distChanged :: Bool
- distChanged = dist /= savedDist
- when distChanged $ info verbosity "build directory changed"
- let configFlags' :: ConfigFlags
- configFlags' = configFlags { configDistPref = toFlag dist }
- return (Any distChanged, (configFlags', configExFlags))
-
- checkOutdated :: Check (ConfigFlags, b)
- checkOutdated = Check $ \_ flags@(configFlags, _) -> do
- let buildConfig :: FilePath
- buildConfig = localBuildInfoFile dist
-
- -- Has the package ever been configured? If not, reconfiguration is
- -- required.
- configured <- doesFileExist buildConfig
- unless configured $ info verbosity "package has never been configured"
-
- -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need
- -- to force reconfigure. Note that it's possible to use @cabal.config@
- -- even without sandboxes.
- userPackageEnvironmentFileModified <-
- existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig
- when userPackageEnvironmentFileModified $
- info verbosity ("user package environment file ('"
- ++ userPackageEnvironmentFile ++ "') was modified")
-
- -- Is the configuration older than the package description?
- descrFile <- maybe (defaultPackageDesc verbosity) return
- (flagToMaybe (configCabalFilePath configFlags))
- outdated <- existsAndIsMoreRecentThan descrFile buildConfig
- when outdated $ info verbosity (descrFile ++ " was changed")
-
- let failed :: Any
- failed =
- Any outdated
- <> Any userPackageEnvironmentFileModified
- <> Any (not configured)
- return (failed, flags)
+ config =
+ do
+ savedFlags@(_, _) <- readConfigFlags dist
+
+ useNix <- fmap isJust (findNixExpr globalFlags config)
+ alreadyInNixShell <- inNixShell
+
+ if useNix && not alreadyInNixShell
+ then do
+ -- If we are using Nix, we must reinstantiate the derivation outside
+ -- the shell. Eventually, the caller will invoke 'nixShell' which will
+ -- rerun cabal inside the shell. That will bring us back to 'reconfigure',
+ -- but inside the shell we'll take the second branch, below.
+
+ -- This seems to have a problem: won't 'configureAction' call 'nixShell'
+ -- yet again, spawning an infinite tree of subprocesses?
+ -- No, because 'nixShell' doesn't spawn a new process if it is already
+ -- running in a Nix shell.
+
+ nixInstantiate verbosity dist False globalFlags config
+ return config
+ else do
+ let checks :: Check (ConfigFlags, ConfigExFlags)
+ checks =
+ checkVerb
+ <> checkDist
+ <> checkOutdated
+ <> check
+ (Any frc, flags@(configFlags, _)) <- runCheck checks mempty savedFlags
+
+ let config' :: SavedConfig
+ config' = updateInstallDirs (configUserInstall configFlags) config
+
+ when frc $ configureAction flags extraArgs globalFlags
+ return config'
+ where
+ -- Changing the verbosity does not require reconfiguration, but the new
+ -- verbosity should be used if reconfiguring.
+ checkVerb :: Check (ConfigFlags, b)
+ checkVerb = Check $ \_ (configFlags, configExFlags) -> do
+ let configFlags' :: ConfigFlags
+ configFlags' = configFlags{configVerbosity = toFlag verbosity}
+ return (mempty, (configFlags', configExFlags))
+
+ -- Reconfiguration is required if @--build-dir@ changes.
+ checkDist :: Check (ConfigFlags, b)
+ checkDist = Check $ \_ (configFlags, configExFlags) -> do
+ -- Always set the chosen @--build-dir@ before saving the flags,
+ -- or bad things could happen.
+ savedDist <- findSavedDistPref config (configDistPref configFlags)
+ let distChanged :: Bool
+ distChanged = dist /= savedDist
+ when distChanged $ info verbosity "build directory changed"
+ let configFlags' :: ConfigFlags
+ configFlags' = configFlags{configDistPref = toFlag dist}
+ return (Any distChanged, (configFlags', configExFlags))
+
+ checkOutdated :: Check (ConfigFlags, b)
+ checkOutdated = Check $ \_ flags@(configFlags, _) -> do
+ let buildConfig :: FilePath
+ buildConfig = localBuildInfoFile dist
+
+ -- Has the package ever been configured? If not, reconfiguration is
+ -- required.
+ configured <- doesFileExist buildConfig
+ unless configured $ info verbosity "package has never been configured"
+
+ -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need
+ -- to force reconfigure. Note that it's possible to use @cabal.config@
+ -- even without sandboxes.
+ userPackageEnvironmentFileModified <-
+ existsAndIsMoreRecentThan userPackageEnvironmentFile buildConfig
+ when userPackageEnvironmentFileModified $
+ info
+ verbosity
+ ( "user package environment file ('"
+ ++ userPackageEnvironmentFile
+ ++ "') was modified"
+ )
+
+ -- Is the configuration older than the package description?
+ descrFile <-
+ maybe
+ (defaultPackageDesc verbosity)
+ return
+ (flagToMaybe (configCabalFilePath configFlags))
+ outdated <- existsAndIsMoreRecentThan descrFile buildConfig
+ when outdated $ info verbosity (descrFile ++ " was changed")
+
+ let failed :: Any
+ failed =
+ Any outdated
+ <> Any userPackageEnvironmentFileModified
+ <> Any (not configured)
+ return (failed, flags)
diff --git a/cabal-install/src/Distribution/Client/Run.hs b/cabal-install/src/Distribution/Client/Run.hs
index 47025ff849a9db5d6652c36ce3fadb83f7cc0f74..0da937dcf94e23df1056b576b687050fdef302cb 100644
--- a/cabal-install/src/Distribution/Client/Run.hs
+++ b/cabal-install/src/Distribution/Client/Run.hs
@@ -1,141 +1,172 @@
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Run
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- Implementation of the 'run' command.
------------------------------------------------------------------------------
-
-module Distribution.Client.Run ( run, splitRunArgs )
- where
+module Distribution.Client.Run (run, splitRunArgs)
+where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Types.TargetInfo (targetCLBI)
import Distribution.Types.LocalBuildInfo (componentNameTargets')
+import Distribution.Types.TargetInfo (targetCLBI)
-import Distribution.Client.Utils (tryCanonicalizePath)
+import Distribution.Client.Utils (tryCanonicalizePath)
-import Distribution.Types.UnqualComponentName
-import Distribution.PackageDescription (Executable (..),
- TestSuite(..),
- Benchmark(..),
- PackageDescription (..),
- BuildInfo(buildable))
-import Distribution.Simple.Compiler (compilerFlavor, CompilerFlavor(..))
+import Distribution.PackageDescription
+ ( Benchmark (..)
+ , BuildInfo (buildable)
+ , Executable (..)
+ , PackageDescription (..)
+ , TestSuite (..)
+ )
import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)
-import Distribution.Simple.BuildPaths (exeExtension)
-import Distribution.Simple.LocalBuildInfo (ComponentName (..),
- LocalBuildInfo (..),
- depLibraryPaths)
-import Distribution.Simple.Utils (die', notice, warn,
- rawSystemExitWithEnv,
- addLibraryPath)
-import Distribution.System (Platform (..))
+import Distribution.Simple.BuildPaths (exeExtension)
+import Distribution.Simple.Compiler (CompilerFlavor (..), compilerFlavor)
+import Distribution.Simple.LocalBuildInfo
+ ( ComponentName (..)
+ , LocalBuildInfo (..)
+ , depLibraryPaths
+ )
+import Distribution.Simple.Utils
+ ( addLibraryPath
+ , die'
+ , notice
+ , rawSystemExitWithEnv
+ , warn
+ )
+import Distribution.System (Platform (..))
+import Distribution.Types.UnqualComponentName
import qualified Distribution.Simple.GHCJS as GHCJS
-import System.Directory (getCurrentDirectory)
-import Distribution.Compat.Environment (getEnvironment)
-import System.FilePath ((<.>), (</>))
-
+import Distribution.Compat.Environment (getEnvironment)
+import System.Directory (getCurrentDirectory)
+import System.FilePath ((<.>), (</>))
-- | Return the executable to run and any extra arguments that should be
-- forwarded to it. Die in case of error.
-splitRunArgs :: Verbosity -> LocalBuildInfo -> [String]
- -> IO (Executable, [String])
+splitRunArgs
+ :: Verbosity
+ -> LocalBuildInfo
+ -> [String]
+ -> IO (Executable, [String])
splitRunArgs verbosity lbi args =
case whichExecutable of -- Either err (wasManuallyChosen, exe, paramsRest)
- Left err -> do
+ Left err -> do
warn verbosity `traverse_` maybeWarning -- If there is a warning, print it.
die' verbosity err
- Right (True, exe, xs) -> return (exe, xs)
+ Right (True, exe, xs) -> return (exe, xs)
Right (False, exe, xs) -> do
- let addition = " Interpreting all parameters to `run` as a parameter to"
- ++ " the default executable."
+ let addition =
+ " Interpreting all parameters to `run` as a parameter to"
+ ++ " the default executable."
-- If there is a warning, print it together with the addition.
- warn verbosity `traverse_` fmap (++addition) maybeWarning
+ warn verbosity `traverse_` fmap (++ addition) maybeWarning
return (exe, xs)
where
pkg_descr = localPkgDescr lbi
- whichExecutable :: Either String -- Error string.
- ( Bool -- If it was manually chosen.
- , Executable -- The executable.
- , [String] -- The remaining parameters.
- )
+ whichExecutable
+ :: Either
+ String -- Error string.
+ ( Bool -- If it was manually chosen.
+ , Executable -- The executable.
+ , [String] -- The remaining parameters.
+ )
whichExecutable = case (enabledExes, args) of
- ([] , _) -> Left "Couldn't find any enabled executables."
- ([exe], []) -> return (False, exe, [])
- ([exe], (x:xs))
+ ([], _) -> Left "Couldn't find any enabled executables."
+ ([exe], []) -> return (False, exe, [])
+ ([exe], (x : xs))
| x == unUnqualComponentName (exeName exe) -> return (True, exe, xs)
- | otherwise -> return (False, exe, args)
- (_ , []) -> Left
- $ "This package contains multiple executables. "
- ++ "You must pass the executable name as the first argument "
- ++ "to 'cabal run'."
- (_ , (x:xs)) ->
+ | otherwise -> return (False, exe, args)
+ (_, []) ->
+ Left $
+ "This package contains multiple executables. "
+ ++ "You must pass the executable name as the first argument "
+ ++ "to 'cabal run'."
+ (_, (x : xs)) ->
case find (\exe -> unUnqualComponentName (exeName exe) == x) enabledExes of
- Nothing -> Left $ "No executable named '" ++ x ++ "'."
+ Nothing -> Left $ "No executable named '" ++ x ++ "'."
Just exe -> return (True, exe, xs)
where
enabledExes = filter (buildable . buildInfo) (executables pkg_descr)
maybeWarning :: Maybe String
maybeWarning = case args of
- [] -> Nothing
- (x:_) -> lookup (mkUnqualComponentName x) components
+ [] -> Nothing
+ (x : _) -> lookup (mkUnqualComponentName x) components
where
components :: [(UnqualComponentName, String)] -- Component name, message.
components =
[ (name, "The executable '" ++ prettyShow name ++ "' is disabled.")
| e <- executables pkg_descr
- , not . buildable . buildInfo $ e, let name = exeName e]
-
- ++ [ (name, "There is a test-suite '" ++ prettyShow name ++ "',"
- ++ " but the `run` command is only for executables.")
- | t <- testSuites pkg_descr
- , let name = testName t]
-
- ++ [ (name, "There is a benchmark '" ++ prettyShow name ++ "',"
- ++ " but the `run` command is only for executables.")
- | b <- benchmarks pkg_descr
- , let name = benchmarkName b]
+ , not . buildable . buildInfo $ e
+ , let name = exeName e
+ ]
+ ++ [ ( name
+ , "There is a test-suite '"
+ ++ prettyShow name
+ ++ "',"
+ ++ " but the `run` command is only for executables."
+ )
+ | t <- testSuites pkg_descr
+ , let name = testName t
+ ]
+ ++ [ ( name
+ , "There is a benchmark '"
+ ++ prettyShow name
+ ++ "',"
+ ++ " but the `run` command is only for executables."
+ )
+ | b <- benchmarks pkg_descr
+ , let name = benchmarkName b
+ ]
-- | Run a given executable.
run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()
run verbosity lbi exe exeArgs = do
curDir <- getCurrentDirectory
- let buildPref = buildDir lbi
- pkg_descr = localPkgDescr lbi
- dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",
- curDir </> dataDir pkg_descr)
+ let buildPref = buildDir lbi
+ pkg_descr = localPkgDescr lbi
+ dataDirEnvVar =
+ ( pkgPathEnvVar pkg_descr "datadir"
+ , curDir </> dataDir pkg_descr
+ )
(path, runArgs) <-
let exeName' = prettyShow $ exeName exe
- in case compilerFlavor (compiler lbi) of
- GHCJS -> do
- let (script, cmd, cmdArgs) =
- GHCJS.runCmd (withPrograms lbi)
- (buildPref </> exeName' </> exeName')
- script' <- tryCanonicalizePath script
- return (cmd, cmdArgs ++ [script'])
- _ -> do
- p <- tryCanonicalizePath $
- buildPref </> exeName' </> (exeName' <.> exeExtension (hostPlatform lbi))
- return (p, [])
+ in case compilerFlavor (compiler lbi) of
+ GHCJS -> do
+ let (script, cmd, cmdArgs) =
+ GHCJS.runCmd
+ (withPrograms lbi)
+ (buildPref </> exeName' </> exeName')
+ script' <- tryCanonicalizePath script
+ return (cmd, cmdArgs ++ [script'])
+ _ -> do
+ p <-
+ tryCanonicalizePath $
+ buildPref </> exeName' </> (exeName' <.> exeExtension (hostPlatform lbi))
+ return (p, [])
- env <- (dataDirEnvVar:) <$> getEnvironment
+ env <- (dataDirEnvVar :) <$> getEnvironment
-- Add (DY)LD_LIBRARY_PATH if needed
- env' <- if withDynExe lbi
- then do let (Platform _ os) = hostPlatform lbi
- clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of
- [target] -> return (targetCLBI target)
- [] -> die' verbosity "run: Could not find executable in LocalBuildInfo"
- _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo"
- paths <- depLibraryPaths True False lbi clbi
- return (addLibraryPath os paths env)
- else return env
+ env' <-
+ if withDynExe lbi
+ then do
+ let (Platform _ os) = hostPlatform lbi
+ clbi <- case componentNameTargets' pkg_descr lbi (CExeName (exeName exe)) of
+ [target] -> return (targetCLBI target)
+ [] -> die' verbosity "run: Could not find executable in LocalBuildInfo"
+ _ -> die' verbosity "run: Found multiple matching exes in LocalBuildInfo"
+ paths <- depLibraryPaths True False lbi clbi
+ return (addLibraryPath os paths env)
+ else return env
notice verbosity $ "Running " ++ prettyShow (exeName exe) ++ "..."
- rawSystemExitWithEnv verbosity path (runArgs++exeArgs) env'
+ rawSystemExitWithEnv verbosity path (runArgs ++ exeArgs) env'
diff --git a/cabal-install/src/Distribution/Client/Sandbox.hs b/cabal-install/src/Distribution/Client/Sandbox.hs
index df672aa1b8fd3a031e3fc791451bbeb08b34d49e..82e7492a02b0fe5b31fbcfdab4546e4f345c3fc9 100644
--- a/cabal-install/src/Distribution/Client/Sandbox.hs
+++ b/cabal-install/src/Distribution/Client/Sandbox.hs
@@ -1,85 +1,105 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Sandbox
-- Maintainer : cabal-devel@haskell.org
-- Portability : portable
--
-- UI for the sandboxing functionality.
------------------------------------------------------------------------------
-
-module Distribution.Client.Sandbox (
- loadConfigOrSandboxConfig,
- findSavedDistPref,
-
- updateInstallDirs,
-
- getPersistOrConfigCompiler
+module Distribution.Client.Sandbox
+ ( loadConfigOrSandboxConfig
+ , findSavedDistPref
+ , updateInstallDirs
+ , getPersistOrConfigCompiler
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.Setup
- ( ConfigFlags(..), GlobalFlags(..), configCompilerAux' )
import Distribution.Client.Config
- ( SavedConfig(..), defaultUserInstall, loadConfig )
+ ( SavedConfig (..)
+ , defaultUserInstall
+ , loadConfig
+ )
+import Distribution.Client.Setup
+ ( ConfigFlags (..)
+ , GlobalFlags (..)
+ , configCompilerAux'
+ )
import Distribution.Client.Sandbox.PackageEnvironment
- ( PackageEnvironmentType(..)
+ ( PackageEnvironmentType (..)
, classifyPackageEnvironment
, loadUserConfig
)
import Distribution.Client.SetupWrapper
- ( SetupScriptOptions(..), defaultSetupScriptOptions )
-import Distribution.Simple.Compiler ( Compiler(..) )
-import Distribution.Simple.Configure ( maybeGetPersistBuildConfig
- , findDistPrefOrDefault
- , findDistPref )
+ ( SetupScriptOptions (..)
+ , defaultSetupScriptOptions
+ )
+import Distribution.Simple.Compiler (Compiler (..))
+import Distribution.Simple.Configure
+ ( findDistPref
+ , findDistPrefOrDefault
+ , maybeGetPersistBuildConfig
+ )
import qualified Distribution.Simple.LocalBuildInfo as LocalBuildInfo
-import Distribution.Simple.Program ( ProgramDb )
-import Distribution.Simple.Setup ( Flag(..)
- , fromFlagOrDefault, flagToMaybe )
-import Distribution.System ( Platform )
-
-import System.Directory ( getCurrentDirectory )
+import Distribution.Simple.Program (ProgramDb)
+import Distribution.Simple.Setup
+ ( Flag (..)
+ , flagToMaybe
+ , fromFlagOrDefault
+ )
+import Distribution.System (Platform)
+import System.Directory (getCurrentDirectory)
-- * Basic sandbox functions.
+
--
updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig
-updateInstallDirs userInstallFlag savedConfig = savedConfig
- { savedConfigureFlags = configureFlags
- { configInstallDirs = installDirs
- }
+updateInstallDirs userInstallFlag savedConfig =
+ savedConfig
+ { savedConfigureFlags =
+ configureFlags
+ { configInstallDirs = installDirs
+ }
}
where
configureFlags = savedConfigureFlags savedConfig
userInstallDirs = savedUserInstallDirs savedConfig
globalInstallDirs = savedGlobalInstallDirs savedConfig
- installDirs | userInstall = userInstallDirs
- | otherwise = globalInstallDirs
- userInstall = fromFlagOrDefault defaultUserInstall
- (configUserInstall configureFlags `mappend` userInstallFlag)
+ installDirs
+ | userInstall = userInstallDirs
+ | otherwise = globalInstallDirs
+ userInstall =
+ fromFlagOrDefault
+ defaultUserInstall
+ (configUserInstall configureFlags `mappend` userInstallFlag)
-- | Check which type of package environment we're in and return a
-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates
-- whether we're working in a sandbox.
-loadConfigOrSandboxConfig :: Verbosity
- -> GlobalFlags -- ^ For @--config-file@ and
- -- @--sandbox-config-file@.
- -> IO SavedConfig
+loadConfigOrSandboxConfig
+ :: Verbosity
+ -> GlobalFlags
+ -- ^ For @--config-file@ and
+ -- @--sandbox-config-file@.
+ -> IO SavedConfig
loadConfigOrSandboxConfig verbosity globalFlags = do
- let configFileFlag = globalConfigFile globalFlags
+ let configFileFlag = globalConfigFile globalFlags
- pkgEnvDir <- getCurrentDirectory
+ pkgEnvDir <- getCurrentDirectory
pkgEnvType <- classifyPackageEnvironment pkgEnvDir
case pkgEnvType of
-- Only @cabal.config@ is present.
- UserPackageEnvironment -> do
+ UserPackageEnvironment -> do
config <- loadConfig verbosity configFileFlag
userConfig <- loadUserConfig verbosity pkgEnvDir Nothing
let config' = config `mappend` userConfig
@@ -98,10 +118,11 @@ loadConfigOrSandboxConfig verbosity globalFlags = do
-- | Return the saved \"dist/\" prefix, or the default prefix.
findSavedDistPref :: SavedConfig -> Flag FilePath -> IO FilePath
findSavedDistPref config flagDistPref = do
- let defDistPref = useDistPref defaultSetupScriptOptions
- flagDistPref' = configDistPref (savedConfigureFlags config)
- `mappend` flagDistPref
- findDistPref defDistPref flagDistPref'
+ let defDistPref = useDistPref defaultSetupScriptOptions
+ flagDistPref' =
+ configDistPref (savedConfigureFlags config)
+ `mappend` flagDistPref
+ findDistPref defDistPref flagDistPref'
-- Utils (transitionary)
--
@@ -109,14 +130,17 @@ findSavedDistPref config flagDistPref = do
-- | Try to read the most recently configured compiler from the
-- 'localBuildInfoFile', falling back on 'configCompilerAuxEx' if it
-- cannot be read.
-getPersistOrConfigCompiler :: ConfigFlags
- -> IO (Compiler, Platform, ProgramDb)
+getPersistOrConfigCompiler
+ :: ConfigFlags
+ -> IO (Compiler, Platform, ProgramDb)
getPersistOrConfigCompiler configFlags = do
distPref <- findDistPrefOrDefault (configDistPref configFlags)
mlbi <- maybeGetPersistBuildConfig distPref
case mlbi of
- Nothing -> do configCompilerAux' configFlags
- Just lbi -> return ( LocalBuildInfo.compiler lbi
- , LocalBuildInfo.hostPlatform lbi
- , LocalBuildInfo.withPrograms lbi
- )
+ Nothing -> do configCompilerAux' configFlags
+ Just lbi ->
+ return
+ ( LocalBuildInfo.compiler lbi
+ , LocalBuildInfo.hostPlatform lbi
+ , LocalBuildInfo.withPrograms lbi
+ )
diff --git a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs
index 0d13cda1093719ef2f10bc7dc452c7434fc3adba..3033356493f1d3c554984cae920699db701122a9 100644
--- a/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs
+++ b/cabal-install/src/Distribution/Client/Sandbox/PackageEnvironment.hs
@@ -1,6 +1,9 @@
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Sandbox.PackageEnvironment
-- Maintainer : cabal-devel@haskell.org
@@ -8,63 +11,75 @@
--
-- Utilities for working with the package environment file. Patterned after
-- Distribution.Client.Config.
------------------------------------------------------------------------------
-
-module Distribution.Client.Sandbox.PackageEnvironment (
- PackageEnvironment(..)
- , PackageEnvironmentType(..)
+module Distribution.Client.Sandbox.PackageEnvironment
+ ( PackageEnvironment (..)
+ , PackageEnvironmentType (..)
, classifyPackageEnvironment
, readPackageEnvironmentFile
, showPackageEnvironment
, showPackageEnvironmentWithComments
, loadUserConfig
-
, userPackageEnvironmentFile
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.Config ( SavedConfig(..)
- , configFieldDescriptions
- , haddockFlagsFields
- , installDirsFields, withProgramsFields
- , withProgramOptionsFields
- )
-import Distribution.Client.ParseUtils ( parseFields, ppFields, ppSection )
-import Distribution.Client.Setup ( ConfigExFlags(..)
- )
-import Distribution.Client.Targets ( userConstraintPackageName )
-import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate )
-import Distribution.Simple.Setup ( Flag(..)
- , ConfigFlags(..), HaddockFlags(..)
- )
-import Distribution.Simple.Utils ( warn, debug )
+import Distribution.Client.Config
+ ( SavedConfig (..)
+ , configFieldDescriptions
+ , haddockFlagsFields
+ , installDirsFields
+ , withProgramOptionsFields
+ , withProgramsFields
+ )
+import Distribution.Client.ParseUtils (parseFields, ppFields, ppSection)
+import Distribution.Client.Setup
+ ( ConfigExFlags (..)
+ )
+import Distribution.Client.Targets (userConstraintPackageName)
+import Distribution.Deprecated.ParseUtils
+ ( FieldDescr (..)
+ , ParseResult (..)
+ , commaListFieldParsec
+ , commaNewLineListFieldParsec
+ , liftField
+ , lineNo
+ , locatedErrorMsg
+ , readFields
+ , showPWarning
+ , syntaxError
+ , warning
+ )
+import Distribution.Simple.InstallDirs (InstallDirs (..), PathTemplate)
+import Distribution.Simple.Setup
+ ( ConfigFlags (..)
+ , Flag (..)
+ , HaddockFlags (..)
+ )
+import Distribution.Simple.Utils (debug, warn)
import Distribution.Solver.Types.ConstraintSource
-import Distribution.Deprecated.ParseUtils ( FieldDescr(..), ParseResult(..)
- , commaListFieldParsec, commaNewLineListFieldParsec
- , liftField, lineNo, locatedErrorMsg
- , readFields
- , showPWarning
- , syntaxError, warning )
-import System.Directory ( doesFileExist )
-import System.FilePath ( (</>) )
-import System.IO.Error ( isDoesNotExistError )
-import Text.PrettyPrint ( ($+$) )
+import System.Directory (doesFileExist)
+import System.FilePath ((</>))
+import System.IO.Error (isDoesNotExistError)
+import Text.PrettyPrint (($+$))
import qualified Data.ByteString as BS
-import qualified Text.PrettyPrint as Disp
-import qualified Distribution.Deprecated.ParseUtils as ParseUtils ( Field(..) )
+import qualified Distribution.Deprecated.ParseUtils as ParseUtils (Field (..))
+import qualified Text.PrettyPrint as Disp
--
+
-- * Configuration saved in the package environment file
+
--
-- TODO: would be nice to remove duplication between
-- D.C.Sandbox.PackageEnvironment and D.C.Config.
-data PackageEnvironment = PackageEnvironment {
- pkgEnvSavedConfig :: SavedConfig
-} deriving Generic
+data PackageEnvironment = PackageEnvironment
+ { pkgEnvSavedConfig :: SavedConfig
+ }
+ deriving (Generic)
instance Monoid PackageEnvironment where
mempty = gmempty
@@ -80,108 +95,144 @@ userPackageEnvironmentFile = "cabal.config"
-- | Type of the current package environment.
data PackageEnvironmentType
- = UserPackageEnvironment -- ^ './cabal.config'
- | AmbientPackageEnvironment -- ^ '~/.config/cabal/config'
+ = -- | './cabal.config'
+ UserPackageEnvironment
+ | -- | '~/.config/cabal/config'
+ AmbientPackageEnvironment
-- | Is there a 'cabal.config' in this directory?
classifyPackageEnvironment :: FilePath -> IO PackageEnvironmentType
classifyPackageEnvironment pkgEnvDir = do
- isUser <- configExists userPackageEnvironmentFile
- return (classify isUser)
+ isUser <- configExists userPackageEnvironmentFile
+ return (classify isUser)
where
- configExists fname = doesFileExist (pkgEnvDir </> fname)
+ configExists fname = doesFileExist (pkgEnvDir </> fname)
classify :: Bool -> PackageEnvironmentType
- classify True = UserPackageEnvironment
- classify False = AmbientPackageEnvironment
-
+ classify True = UserPackageEnvironment
+ classify False = AmbientPackageEnvironment
-- | Load the user package environment if it exists (the optional "cabal.config"
-- file). If it does not exist locally, attempt to load an optional global one.
-userPackageEnvironment :: Verbosity -> FilePath -> Maybe FilePath
- -> IO PackageEnvironment
+userPackageEnvironment
+ :: Verbosity
+ -> FilePath
+ -> Maybe FilePath
+ -> IO PackageEnvironment
userPackageEnvironment verbosity pkgEnvDir globalConfigLocation = do
- let path = pkgEnvDir </> userPackageEnvironmentFile
- minp <- readPackageEnvironmentFile (ConstraintSourceUserConfig path)
- mempty path
- case (minp, globalConfigLocation) of
- (Just parseRes, _) -> processConfigParse path parseRes
- (_, Just globalLoc) -> do
- minp' <- readPackageEnvironmentFile (ConstraintSourceUserConfig globalLoc)
- mempty globalLoc
- maybe (warn verbosity ("no constraints file found at " ++ globalLoc)
- >> return mempty)
- (processConfigParse globalLoc)
- minp'
- _ -> do
- debug verbosity ("no user package environment file found at " ++ pkgEnvDir)
- return mempty
+ let path = pkgEnvDir </> userPackageEnvironmentFile
+ minp <-
+ readPackageEnvironmentFile
+ (ConstraintSourceUserConfig path)
+ mempty
+ path
+ case (minp, globalConfigLocation) of
+ (Just parseRes, _) -> processConfigParse path parseRes
+ (_, Just globalLoc) -> do
+ minp' <-
+ readPackageEnvironmentFile
+ (ConstraintSourceUserConfig globalLoc)
+ mempty
+ globalLoc
+ maybe
+ ( warn verbosity ("no constraints file found at " ++ globalLoc)
+ >> return mempty
+ )
+ (processConfigParse globalLoc)
+ minp'
+ _ -> do
+ debug verbosity ("no user package environment file found at " ++ pkgEnvDir)
+ return mempty
where
processConfigParse path (ParseOk warns parseResult) = do
- unless (null warns) $ warn verbosity $
- unlines (map (showPWarning path) warns)
+ unless (null warns) $
+ warn verbosity $
+ unlines (map (showPWarning path) warns)
return parseResult
processConfigParse path (ParseFailed err) = do
let (line, msg) = locatedErrorMsg err
- warn verbosity $ "Error parsing package environment file " ++ path
- ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
+ warn verbosity $
+ "Error parsing package environment file "
+ ++ path
+ ++ maybe "" (\n -> ":" ++ show n) line
+ ++ ":\n"
+ ++ msg
return mempty
-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.
loadUserConfig :: Verbosity -> FilePath -> Maybe FilePath -> IO SavedConfig
loadUserConfig verbosity pkgEnvDir globalConfigLocation =
- fmap pkgEnvSavedConfig $
+ fmap pkgEnvSavedConfig $
userPackageEnvironment verbosity pkgEnvDir globalConfigLocation
-
-
-- | Descriptions of all fields in the package environment file.
pkgEnvFieldDescrs :: ConstraintSource -> [FieldDescr PackageEnvironment]
pkgEnvFieldDescrs src =
- [ commaNewLineListFieldParsec "constraints"
- (pretty . fst) ((\pc -> (pc, src)) `fmap` parsec)
- (sortConstraints . configExConstraints
- . savedConfigureExFlags . pkgEnvSavedConfig)
- (\v pkgEnv -> updateConfigureExFlags pkgEnv
- (\flags -> flags { configExConstraints = v }))
-
- , commaListFieldParsec "preferences"
- pretty parsec
- (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)
- (\v pkgEnv -> updateConfigureExFlags pkgEnv
- (\flags -> flags { configPreferences = v }))
+ [ commaNewLineListFieldParsec
+ "constraints"
+ (pretty . fst)
+ ((\pc -> (pc, src)) `fmap` parsec)
+ ( sortConstraints
+ . configExConstraints
+ . savedConfigureExFlags
+ . pkgEnvSavedConfig
+ )
+ ( \v pkgEnv ->
+ updateConfigureExFlags
+ pkgEnv
+ (\flags -> flags{configExConstraints = v})
+ )
+ , commaListFieldParsec
+ "preferences"
+ pretty
+ parsec
+ (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)
+ ( \v pkgEnv ->
+ updateConfigureExFlags
+ pkgEnv
+ (\flags -> flags{configPreferences = v})
+ )
]
- ++ map toPkgEnv configFieldDescriptions'
+ ++ map toPkgEnv configFieldDescriptions'
where
configFieldDescriptions' :: [FieldDescr SavedConfig]
- configFieldDescriptions' = filter
- (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
- (configFieldDescriptions src)
+ configFieldDescriptions' =
+ filter
+ (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")
+ (configFieldDescriptions src)
toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment
toPkgEnv fieldDescr =
- liftField pkgEnvSavedConfig
- (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})
- fieldDescr
-
- updateConfigureExFlags :: PackageEnvironment
- -> (ConfigExFlags -> ConfigExFlags)
- -> PackageEnvironment
- updateConfigureExFlags pkgEnv f = pkgEnv {
- pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {
- savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig
- $ pkgEnv
- }
- }
+ liftField
+ pkgEnvSavedConfig
+ (\savedConfig pkgEnv -> pkgEnv{pkgEnvSavedConfig = savedConfig})
+ fieldDescr
+
+ updateConfigureExFlags
+ :: PackageEnvironment
+ -> (ConfigExFlags -> ConfigExFlags)
+ -> PackageEnvironment
+ updateConfigureExFlags pkgEnv f =
+ pkgEnv
+ { pkgEnvSavedConfig =
+ (pkgEnvSavedConfig pkgEnv)
+ { savedConfigureExFlags =
+ f . savedConfigureExFlags . pkgEnvSavedConfig $
+ pkgEnv
+ }
+ }
sortConstraints = sortBy (comparing $ userConstraintPackageName . fst)
-- | Read the package environment file.
-readPackageEnvironmentFile :: ConstraintSource -> PackageEnvironment -> FilePath
- -> IO (Maybe (ParseResult PackageEnvironment))
+readPackageEnvironmentFile
+ :: ConstraintSource
+ -> PackageEnvironment
+ -> FilePath
+ -> IO (Maybe (ParseResult PackageEnvironment))
readPackageEnvironmentFile src initial file =
handleNotExists $
- fmap (Just . parsePackageEnvironment src initial) (BS.readFile file)
+ fmap (Just . parsePackageEnvironment src initial) (BS.readFile file)
where
handleNotExists action = catchIO action $ \ioe ->
if isDoesNotExistError ioe
@@ -189,82 +240,102 @@ readPackageEnvironmentFile src initial file =
else ioError ioe
-- | Parse the package environment file.
-parsePackageEnvironment :: ConstraintSource -> PackageEnvironment -> BS.ByteString
- -> ParseResult PackageEnvironment
+parsePackageEnvironment
+ :: ConstraintSource
+ -> PackageEnvironment
+ -> BS.ByteString
+ -> ParseResult PackageEnvironment
parsePackageEnvironment src initial str = do
fields <- readFields str
let (knownSections, others) = partition isKnownSection fields
pkgEnv <- parse others
- let config = pkgEnvSavedConfig pkgEnv
+ let config = pkgEnvSavedConfig pkgEnv
installDirs0 = savedUserInstallDirs config
(haddockFlags, installDirs, paths, args) <-
- foldM parseSections
- (savedHaddockFlags config, installDirs0, [], [])
- knownSections
- return pkgEnv {
- pkgEnvSavedConfig = config {
- savedConfigureFlags = (savedConfigureFlags config) {
- configProgramPaths = paths,
- configProgramArgs = args
- },
- savedHaddockFlags = haddockFlags,
- savedUserInstallDirs = installDirs,
- savedGlobalInstallDirs = installDirs
- }
- }
-
+ foldM
+ parseSections
+ (savedHaddockFlags config, installDirs0, [], [])
+ knownSections
+ return
+ pkgEnv
+ { pkgEnvSavedConfig =
+ config
+ { savedConfigureFlags =
+ (savedConfigureFlags config)
+ { configProgramPaths = paths
+ , configProgramArgs = args
+ }
+ , savedHaddockFlags = haddockFlags
+ , savedUserInstallDirs = installDirs
+ , savedGlobalInstallDirs = installDirs
+ }
+ }
where
isKnownSection :: ParseUtils.Field -> Bool
- isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
- isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
- isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
+ isKnownSection (ParseUtils.Section _ "haddock" _ _) = True
+ isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
+ isKnownSection (ParseUtils.Section _ "program-locations" _ _) = True
isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True
- isKnownSection _ = False
+ isKnownSection _ = False
parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment
parse = parseFields (pkgEnvFieldDescrs src) initial
- parseSections :: SectionsAccum -> ParseUtils.Field
- -> ParseResult SectionsAccum
- parseSections accum@(h,d,p,a)
- (ParseUtils.Section _ "haddock" name fs)
- | name == "" = do h' <- parseFields haddockFlagsFields h fs
- return (h', d, p, a)
- | otherwise = do
- warning "The 'haddock' section should be unnamed"
- return accum
- parseSections (h,d,p,a)
- (ParseUtils.Section line "install-dirs" name fs)
- | name == "" = do d' <- parseFields installDirsFields d fs
- return (h, d',p,a)
- | otherwise =
- syntaxError line $
- "Named 'install-dirs' section: '" ++ name
- ++ "'. Note that named 'install-dirs' sections are not allowed in the '"
- ++ userPackageEnvironmentFile ++ "' file."
- parseSections accum@(h, d,p,a)
- (ParseUtils.Section _ "program-locations" name fs)
- | name == "" = do p' <- parseFields withProgramsFields p fs
- return (h, d, p', a)
- | otherwise = do
- warning "The 'program-locations' section should be unnamed"
- return accum
- parseSections accum@(h, d, p, a)
- (ParseUtils.Section _ "program-default-options" name fs)
- | name == "" = do a' <- parseFields withProgramOptionsFields a fs
- return (h, d, p, a')
- | otherwise = do
- warning "The 'program-default-options' section should be unnamed"
- return accum
+ parseSections
+ :: SectionsAccum
+ -> ParseUtils.Field
+ -> ParseResult SectionsAccum
+ parseSections
+ accum@(h, d, p, a)
+ (ParseUtils.Section _ "haddock" name fs)
+ | name == "" = do
+ h' <- parseFields haddockFlagsFields h fs
+ return (h', d, p, a)
+ | otherwise = do
+ warning "The 'haddock' section should be unnamed"
+ return accum
+ parseSections
+ (h, d, p, a)
+ (ParseUtils.Section line "install-dirs" name fs)
+ | name == "" = do
+ d' <- parseFields installDirsFields d fs
+ return (h, d', p, a)
+ | otherwise =
+ syntaxError line $
+ "Named 'install-dirs' section: '"
+ ++ name
+ ++ "'. Note that named 'install-dirs' sections are not allowed in the '"
+ ++ userPackageEnvironmentFile
+ ++ "' file."
+ parseSections
+ accum@(h, d, p, a)
+ (ParseUtils.Section _ "program-locations" name fs)
+ | name == "" = do
+ p' <- parseFields withProgramsFields p fs
+ return (h, d, p', a)
+ | otherwise = do
+ warning "The 'program-locations' section should be unnamed"
+ return accum
+ parseSections
+ accum@(h, d, p, a)
+ (ParseUtils.Section _ "program-default-options" name fs)
+ | name == "" = do
+ a' <- parseFields withProgramOptionsFields a fs
+ return (h, d, p, a')
+ | otherwise = do
+ warning "The 'program-default-options' section should be unnamed"
+ return accum
parseSections accum f = do
warning $ "Unrecognized stanza on line " ++ show (lineNo f)
return accum
-- | Accumulator type for 'parseSections'.
-type SectionsAccum = (HaddockFlags, InstallDirs (Flag PathTemplate)
- , [(String, FilePath)], [(String, [String])])
-
-
+type SectionsAccum =
+ ( HaddockFlags
+ , InstallDirs (Flag PathTemplate)
+ , [(String, FilePath)]
+ , [(String, [String])]
+ )
-- | Pretty-print the package environment.
showPackageEnvironment :: PackageEnvironment -> String
@@ -272,14 +343,22 @@ showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEn
-- | Pretty-print the package environment with default values for empty fields
-- commented out (just like the default Cabal config file).
-showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)
- -> PackageEnvironment
- -> String
-showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $
- ppFields (pkgEnvFieldDescrs ConstraintSourceUnknown)
- mdefPkgEnv pkgEnv
- $+$ Disp.text ""
- $+$ ppSection "install-dirs" "" installDirsFields
- (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)
+showPackageEnvironmentWithComments
+ :: (Maybe PackageEnvironment)
+ -> PackageEnvironment
+ -> String
+showPackageEnvironmentWithComments mdefPkgEnv pkgEnv =
+ Disp.render $
+ ppFields
+ (pkgEnvFieldDescrs ConstraintSourceUnknown)
+ mdefPkgEnv
+ pkgEnv
+ $+$ Disp.text ""
+ $+$ ppSection
+ "install-dirs"
+ ""
+ installDirsFields
+ (fmap installDirsSection mdefPkgEnv)
+ (installDirsSection pkgEnv)
where
installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig
diff --git a/cabal-install/src/Distribution/Client/SavedFlags.hs b/cabal-install/src/Distribution/Client/SavedFlags.hs
index 4b14836035851ec2e2894ce1a110c4ee646feca4..1a598a58fd7d861c5bd7ef4244baa83ae9d6a7b7 100644
--- a/cabal-install/src/Distribution/Client/SavedFlags.hs
+++ b/cabal-install/src/Distribution/Client/SavedFlags.hs
@@ -1,30 +1,34 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Distribution.Client.SavedFlags
- ( readCommandFlags, writeCommandFlags
- , readSavedArgs, writeSavedArgs
- ) where
+ ( readCommandFlags
+ , writeCommandFlags
+ , readSavedArgs
+ , writeSavedArgs
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Simple.Command
-import Distribution.Simple.UserHooks ( Args )
+import Distribution.Simple.UserHooks (Args)
import Distribution.Simple.Utils
- ( createDirectoryIfMissingVerbose, unintersperse )
+ ( createDirectoryIfMissingVerbose
+ , unintersperse
+ )
import Distribution.Verbosity
-import System.Directory ( doesFileExist )
-import System.FilePath ( takeDirectory )
-
+import System.Directory (doesFileExist)
+import System.FilePath (takeDirectory)
writeSavedArgs :: Verbosity -> FilePath -> [String] -> IO ()
writeSavedArgs verbosity path args = do
createDirectoryIfMissingVerbose
- (lessVerbose verbosity) True (takeDirectory path)
+ (lessVerbose verbosity)
+ True
+ (takeDirectory path)
writeFile path (intercalate "\0" args)
-
-- | Write command-line flags to a file, separated by null characters. This
-- format is also suitable for the @xargs -0@ command. Using the null
-- character also avoids the problem of escaping newlines or spaces,
@@ -34,15 +38,13 @@ writeCommandFlags :: Verbosity -> FilePath -> CommandUI flags -> flags -> IO ()
writeCommandFlags verbosity path command flags =
writeSavedArgs verbosity path (commandShowOptions command flags)
-
readSavedArgs :: FilePath -> IO (Maybe [String])
readSavedArgs path = do
exists <- doesFileExist path
if exists
- then fmap (Just . unintersperse '\0') (readFile path)
+ then fmap (Just . unintersperse '\0') (readFile path)
else return Nothing
-
-- | Read command-line arguments, separated by null characters, from a file.
-- Returns the default flags if the file does not exist.
readCommandFlags :: FilePath -> CommandUI flags -> IO flags
@@ -56,26 +58,29 @@ readCommandFlags path command = do
return (mkFlags (commandDefaultFlags command))
-- -----------------------------------------------------------------------------
+
-- * Exceptions
+
-- -----------------------------------------------------------------------------
data SavedArgsError
- = SavedArgsErrorHelp Args
- | SavedArgsErrorList Args
- | SavedArgsErrorOther Args [String]
+ = SavedArgsErrorHelp Args
+ | SavedArgsErrorList Args
+ | SavedArgsErrorOther Args [String]
deriving (Typeable)
instance Show SavedArgsError where
show (SavedArgsErrorHelp args) =
"unexpected flag '--help', saved command line was:\n"
- ++ intercalate " " args
+ ++ intercalate " " args
show (SavedArgsErrorList args) =
"unexpected flag '--list-options', saved command line was:\n"
- ++ intercalate " " args
+ ++ intercalate " " args
show (SavedArgsErrorOther args errs) =
"saved command line was:\n"
- ++ intercalate " " args ++ "\n"
- ++ "encountered errors:\n"
- ++ intercalate "\n" errs
+ ++ intercalate " " args
+ ++ "\n"
+ ++ "encountered errors:\n"
+ ++ intercalate "\n" errs
instance Exception SavedArgsError
diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs
index db377c8f10a649d9e0e9fe2f1a7e5bb3516982fc..849669e11023eadaf2f1479146ace3a2f01a46fe 100644
--- a/cabal-install/src/Distribution/Client/ScriptUtils.hs
+++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs
@@ -4,109 +4,183 @@
{-# LANGUAGE RecordWildCards #-}
-- | Utilities to help commands with scripts
---
-module Distribution.Client.ScriptUtils (
- getScriptHash, getScriptCacheDirectory, ensureScriptCacheDirectory,
- withContextAndSelectors, AcceptNoTargets(..), TargetContext(..),
- updateContextAndWriteProjectFile, updateContextAndWriteProjectFile',
- fakeProjectSourcePackage, lSrcpkgDescription
+module Distribution.Client.ScriptUtils
+ ( getScriptHash
+ , getScriptCacheDirectory
+ , ensureScriptCacheDirectory
+ , withContextAndSelectors
+ , AcceptNoTargets (..)
+ , TargetContext (..)
+ , updateContextAndWriteProjectFile
+ , updateContextAndWriteProjectFile'
+ , fakeProjectSourcePackage
+ , lSrcpkgDescription
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude hiding (toList)
+import Prelude ()
import Distribution.Compat.Lens
import qualified Distribution.Types.Lens as L
import Distribution.CabalSpecVersion
- ( CabalSpecVersion (..), cabalSpecLatest)
-import Distribution.Client.ProjectOrchestration
+ ( CabalSpecVersion (..)
+ , cabalSpecLatest
+ )
import Distribution.Client.Config
- ( defaultScriptBuildsDir )
+ ( defaultScriptBuildsDir
+ )
import Distribution.Client.DistDirLayout
- ( DistDirLayout(..) )
+ ( DistDirLayout (..)
+ )
import Distribution.Client.HashValue
- ( hashValue, showHashValue )
+ ( hashValue
+ , showHashValue
+ )
import Distribution.Client.HttpUtils
- ( HttpTransport, configureTransport )
+ ( HttpTransport
+ , configureTransport
+ )
import Distribution.Client.NixStyleOptions
- ( NixStyleFlags (..) )
+ ( NixStyleFlags (..)
+ )
import Distribution.Client.ProjectConfig
- ( ProjectConfig(..), ProjectConfigShared(..)
- , reportParseResult, withProjectOrGlobalConfig
- , projectConfigHttpTransport )
+ ( ProjectConfig (..)
+ , ProjectConfigShared (..)
+ , projectConfigHttpTransport
+ , reportParseResult
+ , withProjectOrGlobalConfig
+ )
import Distribution.Client.ProjectConfig.Legacy
- ( ProjectConfigSkeleton
- , parseProjectSkeleton, instantiateProjectConfigSkeletonFetchingCompiler )
+ ( ProjectConfigSkeleton
+ , instantiateProjectConfigSkeletonFetchingCompiler
+ , parseProjectSkeleton
+ )
import Distribution.Client.ProjectFlags
- ( flagIgnoreProject )
+ ( flagIgnoreProject
+ )
+import Distribution.Client.ProjectOrchestration
+import Distribution.Client.ProjectPlanning
+ ( configureCompiler
+ )
import Distribution.Client.RebuildMonad
- ( runRebuild )
+ ( runRebuild
+ )
import Distribution.Client.Setup
- ( ConfigFlags(..), GlobalFlags(..) )
+ ( ConfigFlags (..)
+ , GlobalFlags (..)
+ )
import Distribution.Client.TargetSelector
- ( TargetSelectorProblem(..), TargetString(..) )
+ ( TargetSelectorProblem (..)
+ , TargetString (..)
+ )
import Distribution.Client.Types
- ( PackageLocation(..), PackageSpecifier(..), UnresolvedSourcePackage )
+ ( PackageLocation (..)
+ , PackageSpecifier (..)
+ , UnresolvedSourcePackage
+ )
import Distribution.FieldGrammar
- ( parseFieldGrammar, takeFields )
+ ( parseFieldGrammar
+ , takeFields
+ )
import Distribution.Fields
- ( ParseResult, parseFatalFailure, readFields )
+ ( ParseResult
+ , parseFatalFailure
+ , readFields
+ )
import Distribution.PackageDescription
- ( ignoreConditions )
+ ( ignoreConditions
+ )
import Distribution.PackageDescription.FieldGrammar
- ( executableFieldGrammar )
+ ( executableFieldGrammar
+ )
import Distribution.PackageDescription.PrettyPrint
- ( showGenericPackageDescription )
+ ( showGenericPackageDescription
+ )
import Distribution.Parsec
- ( Position(..) )
+ ( Position (..)
+ )
+import qualified Distribution.SPDX.License as SPDX
+import Distribution.Simple.Compiler
+ ( compilerInfo
+ )
import Distribution.Simple.Flag
- ( fromFlagOrDefault, flagToMaybe )
+ ( flagToMaybe
+ , fromFlagOrDefault
+ )
import Distribution.Simple.PackageDescription
- ( parseString )
+ ( parseString
+ )
import Distribution.Simple.Setup
- ( Flag(..) )
-import Distribution.Simple.Compiler
- ( compilerInfo )
+ ( Flag (..)
+ )
import Distribution.Simple.Utils
- ( createDirectoryIfMissingVerbose, createTempDirectory, die', handleDoesNotExist, readUTF8File, warn, writeUTF8File )
-import qualified Distribution.SPDX.License as SPDX
+ ( createDirectoryIfMissingVerbose
+ , createTempDirectory
+ , die'
+ , handleDoesNotExist
+ , readUTF8File
+ , warn
+ , writeUTF8File
+ )
import Distribution.Solver.Types.SourcePackage as SP
- ( SourcePackage(..) )
+ ( SourcePackage (..)
+ )
import Distribution.System
- ( Platform(..) )
+ ( Platform (..)
+ )
import Distribution.Types.BuildInfo
- ( BuildInfo(..) )
+ ( BuildInfo (..)
+ )
import Distribution.Types.CondTree
- ( CondTree(..) )
+ ( CondTree (..)
+ )
import Distribution.Types.Executable
- ( Executable(..) )
+ ( Executable (..)
+ )
import Distribution.Types.GenericPackageDescription as GPD
- ( GenericPackageDescription(..), emptyGenericPackageDescription )
+ ( GenericPackageDescription (..)
+ , emptyGenericPackageDescription
+ )
import Distribution.Types.PackageDescription
- ( PackageDescription(..), emptyPackageDescription )
+ ( PackageDescription (..)
+ , emptyPackageDescription
+ )
import Distribution.Types.PackageName.Magic
- ( fakePackageCabalFileName, fakePackageId )
+ ( fakePackageCabalFileName
+ , fakePackageId
+ )
import Distribution.Utils.NubList
- ( fromNubList )
-import Distribution.Client.ProjectPlanning
- ( configureCompiler )
+ ( fromNubList
+ )
import Distribution.Verbosity
- ( normal )
+ ( normal
+ )
import Language.Haskell.Extension
- ( Language(..) )
+ ( Language (..)
+ )
import Control.Concurrent.MVar
- ( newEmptyMVar, putMVar, tryTakeMVar )
+ ( newEmptyMVar
+ , putMVar
+ , tryTakeMVar
+ )
import Control.Exception
- ( bracket )
+ ( bracket
+ )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ()
import qualified Data.Set as S
import System.Directory
- ( canonicalizePath, doesFileExist, getTemporaryDirectory, removeDirectoryRecursive )
+ ( canonicalizePath
+ , doesFileExist
+ , getTemporaryDirectory
+ , removeDirectoryRecursive
+ )
import System.FilePath
- ( (</>), takeFileName )
+ ( takeFileName
+ , (</>)
+ )
import qualified Text.Parsec as P
-- A note on multi-module script support #6787:
@@ -146,17 +220,21 @@ ensureScriptCacheDirectory verbosity script = do
-- | What your command should do when no targets are found.
data AcceptNoTargets
- = RejectNoTargets -- ^ die on 'TargetSelectorNoTargetsInProject'
- | AcceptNoTargets -- ^ return a default 'TargetSelector'
+ = -- | die on 'TargetSelectorNoTargetsInProject'
+ RejectNoTargets
+ | -- | return a default 'TargetSelector'
+ AcceptNoTargets
deriving (Eq, Show)
-- | Information about the context in which we found the 'TargetSelector's.
data TargetContext
- = ProjectContext -- ^ The target selectors are part of a project.
- | GlobalContext -- ^ The target selectors are from the global context.
- | ScriptContext FilePath Executable
- -- ^ The target selectors refer to a script. Contains the path to the script and
- -- the executable metadata parsed from the script
+ = -- | The target selectors are part of a project.
+ ProjectContext
+ | -- | The target selectors are from the global context.
+ GlobalContext
+ | -- | The target selectors refer to a script. Contains the path to the script and
+ -- the executable metadata parsed from the script
+ ScriptContext FilePath Executable
deriving (Eq, Show)
-- | Determine whether the targets represent regular targets or a script
@@ -166,40 +244,47 @@ data TargetContext
-- In the case that the context refers to a temporary directory,
-- delete it after the action finishes.
withContextAndSelectors
- :: AcceptNoTargets -- ^ What your command should do when no targets are found.
- -> Maybe ComponentKind -- ^ A target filter
- -> NixStyleFlags a -- ^ Command line flags
- -> [String] -- ^ Target strings or a script and args.
- -> GlobalFlags -- ^ Global flags.
- -> CurrentCommand -- ^ Current Command (usually for error reporting).
+ :: AcceptNoTargets
+ -- ^ What your command should do when no targets are found.
+ -> Maybe ComponentKind
+ -- ^ A target filter
+ -> NixStyleFlags a
+ -- ^ Command line flags
+ -> [String]
+ -- ^ Target strings or a script and args.
+ -> GlobalFlags
+ -- ^ Global flags.
+ -> CurrentCommand
+ -- ^ Current Command (usually for error reporting).
-> (TargetContext -> ProjectBaseContext -> [TargetSelector] -> IO b)
-- ^ The body of your command action.
-> IO b
-withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings globalFlags cmd act
- = withTemporaryTempDirectory $ \mkTmpDir -> do
+withContextAndSelectors noTargets kind flags@NixStyleFlags{..} targetStrings globalFlags cmd act =
+ withTemporaryTempDirectory $ \mkTmpDir -> do
(tc, ctx) <- withProjectOrGlobalConfig verbosity ignoreProject globalConfigFlag with (without mkTmpDir)
(tc', ctx', sels) <- case targetStrings of
-- Only script targets may contain spaces and or end with ':'.
-- Trying to readTargetSelectors such a target leads to a parse error.
[target] | any (\c -> isSpace c) target || ":" `isSuffixOf` target -> do
- scriptOrError target [TargetSelectorNoScript $ TargetString1 target]
- _ -> do
+ scriptOrError target [TargetSelectorNoScript $ TargetString1 target]
+ _ -> do
-- In the case where a selector is both a valid target and script, assume it is a target,
-- because you can disambiguate the script with "./script"
readTargetSelectors (localPackages ctx) kind targetStrings >>= \case
- Left err@(TargetSelectorNoTargetsInProject:_)
+ Left err@(TargetSelectorNoTargetsInProject : _)
| [] <- targetStrings
- , AcceptNoTargets <- noTargets -> return (tc, ctx, defaultTarget)
- | (script:_) <- targetStrings -> scriptOrError script err
- Left err@(TargetSelectorNoSuch t _:_)
- | TargetString1 script <- t -> scriptOrError script err
- Left err@(TargetSelectorExpected t _ _:_)
- | TargetString1 script <- t -> scriptOrError script err
- Left err@(MatchingInternalError _ _ _:_) -- Handle ':' in middle of script name.
- | [script] <- targetStrings -> scriptOrError script err
- Left err -> reportTargetSelectorProblems verbosity err
- Right sels -> return (tc, ctx, sels)
+ , AcceptNoTargets <- noTargets ->
+ return (tc, ctx, defaultTarget)
+ | (script : _) <- targetStrings -> scriptOrError script err
+ Left err@(TargetSelectorNoSuch t _ : _)
+ | TargetString1 script <- t -> scriptOrError script err
+ Left err@(TargetSelectorExpected t _ _ : _)
+ | TargetString1 script <- t -> scriptOrError script err
+ Left err@(MatchingInternalError _ _ _ : _) -- Handle ':' in middle of script name.
+ | [script] <- targetStrings -> scriptOrError script err
+ Left err -> reportTargetSelectorProblems verbosity err
+ Right sels -> return (tc, ctx, sels)
act tc' ctx' sels
where
@@ -218,34 +303,36 @@ withContextAndSelectors noTargets kind flags@NixStyleFlags {..} targetStrings gl
return (GlobalContext, ctx)
scriptOrError script err = do
exists <- doesFileExist script
- if exists then do
- -- In the script case we always want a dummy context even when ignoreProject is False
- let mkCacheDir = ensureScriptCacheDirectory verbosity script
- (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir)
-
- let projectRoot = distProjectRootDirectory $ distDirLayout ctx
- writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script
+ if exists
+ then do
+ -- In the script case we always want a dummy context even when ignoreProject is False
+ let mkCacheDir = ensureScriptCacheDirectory verbosity script
+ (_, ctx) <- withProjectOrGlobalConfig verbosity (Flag True) globalConfigFlag with (without mkCacheDir)
- scriptContents <- BS.readFile script
- executable <- readExecutableBlockFromScript verbosity scriptContents
+ let projectRoot = distProjectRootDirectory $ distDirLayout ctx
+ writeFile (projectRoot </> "scriptlocation") =<< canonicalizePath script
+ scriptContents <- BS.readFile script
+ executable <- readExecutableBlockFromScript verbosity scriptContents
- httpTransport <- configureTransport verbosity
- (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
- (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
+ httpTransport <-
+ configureTransport
+ verbosity
+ (fromNubList . projectConfigProgPathExtra $ projectConfigShared cliConfig)
+ (flagToMaybe . projectConfigHttpTransport $ projectConfigBuildOnly cliConfig)
- projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents
+ projectCfgSkeleton <- readProjectBlockFromScript verbosity httpTransport (distDirLayout ctx) (takeFileName script) scriptContents
- let fetchCompiler = do
- (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
- pure (os, arch, compilerInfo compiler)
+ let fetchCompiler = do
+ (compiler, Platform arch os, _) <- runRebuild (distProjectRootDirectory . distDirLayout $ ctx) $ configureCompiler verbosity (distDirLayout ctx) ((fst $ ignoreConditions projectCfgSkeleton) <> projectConfig ctx)
+ pure (os, arch, compilerInfo compiler)
- projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton
+ projectCfg <- instantiateProjectConfigSkeletonFetchingCompiler fetchCompiler mempty projectCfgSkeleton
- let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just
- ctx' = ctx & lProjectConfig %~ (<> projectCfg)
- return (ScriptContext script executable', ctx', defaultTarget)
- else reportTargetSelectorProblems verbosity err
+ let executable' = executable & L.buildInfo . L.defaultLanguage %~ maybe (Just Haskell2010) Just
+ ctx' = ctx & lProjectConfig %~ (<> projectCfg)
+ return (ScriptContext script executable', ctx', defaultTarget)
+ else reportTargetSelectorProblems verbosity err
withTemporaryTempDirectory :: (IO FilePath -> IO a) -> IO a
withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rmTmp m) act
@@ -263,18 +350,20 @@ withTemporaryTempDirectory act = newEmptyMVar >>= \m -> bracket (getMkTmp m) (rm
-- | Add the 'SourcePackage' to the context and use it to write a .cabal file.
updateContextAndWriteProjectFile' :: ProjectBaseContext -> SourcePackage (PackageLocation (Maybe FilePath)) -> IO ProjectBaseContext
updateContextAndWriteProjectFile' ctx srcPkg = do
- let projectRoot = distProjectRootDirectory $ distDirLayout ctx
- packageFile = projectRoot </> fakePackageCabalFileName
- contents = showGenericPackageDescription (srcpkgDescription srcPkg)
+ let projectRoot = distProjectRootDirectory $ distDirLayout ctx
+ packageFile = projectRoot </> fakePackageCabalFileName
+ contents = showGenericPackageDescription (srcpkgDescription srcPkg)
writePackageFile = writeUTF8File packageFile contents
-- TODO This is here to prevent reconfiguration of cached repl packages.
-- It's worth investigating why it's needed in the first place.
packageFileExists <- doesFileExist packageFile
- if packageFileExists then do
- cached <- force <$> readUTF8File packageFile
- when (cached /= contents)
- writePackageFile
- else writePackageFile
+ if packageFileExists
+ then do
+ cached <- force <$> readUTF8File packageFile
+ when
+ (cached /= contents)
+ writePackageFile
+ else writePackageFile
return (ctx & lLocalPackages %~ (++ [SpecificSourcePackage srcPkg]))
-- | Add add the executable metadata to the context and write a .cabal file.
@@ -287,26 +376,30 @@ updateContextAndWriteProjectFile ctx scriptPath scriptExecutable = do
-- Replace characters which aren't allowed in the executable component name with '_'
-- Prefix with "cabal-script-" to make it clear to end users that the name may be mangled
scriptExeName = "cabal-script-" ++ map censor (takeFileName scriptPath)
- censor c | c `S.member` ccNamecore = c
- | otherwise = '_'
-
- sourcePackage = fakeProjectSourcePackage projectRoot
- & lSrcpkgDescription . L.condExecutables
- .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])]
- executable = scriptExecutable
- & L.modulePath .~ absScript
+ censor c
+ | c `S.member` ccNamecore = c
+ | otherwise = '_'
+
+ sourcePackage =
+ fakeProjectSourcePackage projectRoot
+ & lSrcpkgDescription . L.condExecutables
+ .~ [(fromString scriptExeName, CondNode executable (targetBuildDepends $ buildInfo executable) [])]
+ executable =
+ scriptExecutable
+ & L.modulePath .~ absScript
updateContextAndWriteProjectFile' ctx sourcePackage
parseScriptBlock :: BS.ByteString -> ParseResult Executable
parseScriptBlock str =
- case readFields str of
- Right fs -> do
- let (fields, _) = takeFields fs
- parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")
- Left perr -> parseFatalFailure pos (show perr) where
- ppos = P.errorPos perr
- pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
+ case readFields str of
+ Right fs -> do
+ let (fields, _) = takeFields fs
+ parseFieldGrammar cabalSpecLatest fields (executableFieldGrammar "script")
+ Left perr -> parseFatalFailure pos (show perr)
+ where
+ ppos = P.errorPos perr
+ pos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
readScriptBlock :: Verbosity -> BS.ByteString -> IO Executable
readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block"
@@ -321,11 +414,11 @@ readScriptBlock verbosity = parseString parseScriptBlock verbosity "script block
-- Return the metadata.
readExecutableBlockFromScript :: Verbosity -> BS.ByteString -> IO Executable
readExecutableBlockFromScript verbosity str = do
- str' <- case extractScriptBlock "cabal" str of
- Left e -> die' verbosity $ "Failed extracting script block: " ++ e
- Right x -> return x
- when (BS.all isSpace str') $ warn verbosity "Empty script block"
- readScriptBlock verbosity str'
+ str' <- case extractScriptBlock "cabal" str of
+ Left e -> die' verbosity $ "Failed extracting script block: " ++ e
+ Right x -> return x
+ when (BS.all isSpace str') $ warn verbosity "Empty script block"
+ readScriptBlock verbosity str'
-- | Extract the first encountered project metadata block started and
-- terminated by the below tokens.
@@ -337,10 +430,11 @@ readExecutableBlockFromScript verbosity str = do
-- Return the metadata.
readProjectBlockFromScript :: Verbosity -> HttpTransport -> DistDirLayout -> String -> BS.ByteString -> IO ProjectConfigSkeleton
readProjectBlockFromScript verbosity httpTransport DistDirLayout{distDownloadSrcDirectory} scriptName str = do
- case extractScriptBlock "project" str of
- Left _ -> return mempty
- Right x -> reportParseResult verbosity "script" scriptName
- =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x
+ case extractScriptBlock "project" str of
+ Left _ -> return mempty
+ Right x ->
+ reportParseResult verbosity "script" scriptName
+ =<< parseProjectSkeleton distDownloadSrcDirectory httpTransport verbosity [] scriptName x
-- | Extract the first encountered script metadata block started end
-- terminated by the tokens
@@ -358,63 +452,68 @@ extractScriptBlock :: BS.ByteString -> BS.ByteString -> Either String BS.ByteStr
extractScriptBlock header str = goPre (BS.lines str)
where
isStartMarker = (== startMarker) . stripTrailSpace
- isEndMarker = (== endMarker) . stripTrailSpace
+ isEndMarker = (== endMarker) . stripTrailSpace
stripTrailSpace = fst . BS.spanEnd isSpace
-- before start marker
goPre ls = case dropWhile (not . isStartMarker) ls of
- [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"
- (_:ls') -> goBody [] ls'
+ [] -> Left $ "`" ++ BS.unpack startMarker ++ "` start marker not found"
+ (_ : ls') -> goBody [] ls'
goBody _ [] = Left $ "`" ++ BS.unpack endMarker ++ "` end marker not found"
- goBody acc (l:ls)
+ goBody acc (l : ls)
| isEndMarker l = Right $! BS.unlines $ reverse acc
- | otherwise = goBody (l:acc) ls
+ | otherwise = goBody (l : acc) ls
startMarker, endMarker :: BS.ByteString
startMarker = "{- " <> header <> ":"
- endMarker = "-}"
+ endMarker = "-}"
-- | The base for making a 'SourcePackage' for a fake project.
-- It needs a 'Distribution.Types.Library.Library' or 'Executable' depending on the command.
fakeProjectSourcePackage :: FilePath -> SourcePackage (PackageLocation loc)
fakeProjectSourcePackage projectRoot = sourcePackage
where
- sourcePackage = SourcePackage
- { srcpkgPackageId = fakePackageId
- , srcpkgDescription = genericPackageDescription
- , srcpkgSource = LocalUnpackedPackage projectRoot
- , srcpkgDescrOverride = Nothing
- }
- genericPackageDescription = emptyGenericPackageDescription
- { GPD.packageDescription = packageDescription }
- packageDescription = emptyPackageDescription
- { package = fakePackageId
- , specVersion = CabalSpecV2_2
- , licenseRaw = Left SPDX.NONE
- }
+ sourcePackage =
+ SourcePackage
+ { srcpkgPackageId = fakePackageId
+ , srcpkgDescription = genericPackageDescription
+ , srcpkgSource = LocalUnpackedPackage projectRoot
+ , srcpkgDescrOverride = Nothing
+ }
+ genericPackageDescription =
+ emptyGenericPackageDescription
+ { GPD.packageDescription = packageDescription
+ }
+ packageDescription =
+ emptyPackageDescription
+ { package = fakePackageId
+ , specVersion = CabalSpecV2_2
+ , licenseRaw = Left SPDX.NONE
+ }
-- Lenses
+
-- | A lens for the 'srcpkgDescription' field of 'SourcePackage'
lSrcpkgDescription :: Lens' (SourcePackage loc) GenericPackageDescription
-lSrcpkgDescription f s = fmap (\x -> s { srcpkgDescription = x }) (f (srcpkgDescription s))
-{-# inline lSrcpkgDescription #-}
+lSrcpkgDescription f s = fmap (\x -> s{srcpkgDescription = x}) (f (srcpkgDescription s))
+{-# INLINE lSrcpkgDescription #-}
lLocalPackages :: Lens' ProjectBaseContext [PackageSpecifier UnresolvedSourcePackage]
-lLocalPackages f s = fmap (\x -> s { localPackages = x }) (f (localPackages s))
-{-# inline lLocalPackages #-}
+lLocalPackages f s = fmap (\x -> s{localPackages = x}) (f (localPackages s))
+{-# INLINE lLocalPackages #-}
lProjectConfig :: Lens' ProjectBaseContext ProjectConfig
-lProjectConfig f s = fmap (\x -> s { projectConfig = x }) (f (projectConfig s))
-{-# inline lProjectConfig #-}
+lProjectConfig f s = fmap (\x -> s{projectConfig = x}) (f (projectConfig s))
+{-# INLINE lProjectConfig #-}
-- Character classes
-- Transcribed from "templates/Lexer.x"
ccSpace, ccCtrlchar, ccPrintable, ccSymbol', ccParen, ccNamecore :: Set Char
-ccSpace = S.fromList " "
-ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f]
+ccSpace = S.fromList " "
+ccCtrlchar = S.fromList $ [chr 0x0 .. chr 0x1f] ++ [chr 0x7f]
ccPrintable = S.fromList [chr 0x0 .. chr 0xff] S.\\ ccCtrlchar
-ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~"
-ccParen = S.fromList "()[]"
-ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol']
+ccSymbol' = S.fromList ",=<>+*&|!$%^@#?/\\~"
+ccParen = S.fromList "()[]"
+ccNamecore = ccPrintable S.\\ S.unions [ccSpace, S.fromList ":\"{}", ccParen, ccSymbol']
diff --git a/cabal-install/src/Distribution/Client/Security/DNS.hs b/cabal-install/src/Distribution/Client/Security/DNS.hs
index 05f422636c69dd476e7c8bc07c85eb2b231ce938..b989a8524517f74b3e8a629c2dbcd8b3a77facb9 100644
--- a/cabal-install/src/Distribution/Client/Security/DNS.hs
+++ b/cabal-install/src/Distribution/Client/Security/DNS.hs
@@ -1,14 +1,14 @@
{-# LANGUAGE CPP #-}
module Distribution.Client.Security.DNS
- ( queryBootstrapMirrors
- ) where
+ ( queryBootstrapMirrors
+ ) where
-import Prelude ()
-import Distribution.Client.Compat.Prelude
-import Network.URI (URI(..), URIAuth(..), parseURI)
import Control.Exception (try)
+import Distribution.Client.Compat.Prelude
import Distribution.Simple.Utils
+import Network.URI (URI (..), URIAuth (..), parseURI)
+import Prelude ()
#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
import Network.DNS (queryTXT, Name(..), CharStr(..))
@@ -42,7 +42,6 @@ import Distribution.Simple.Program
-- @hackage.haskell.org@ DNS entry, so an the additional
-- @_mirrors.hackage.haskell.org@ DNS entry in the same SOA doesn't
-- constitute a significant new attack vector anyway.
---
queryBootstrapMirrors :: Verbosity -> URI -> IO [URI]
#if defined(MIN_VERSION_resolv) || defined(MIN_VERSION_windns)
@@ -176,17 +175,17 @@ isUrlBase s
-- | Split a TXT string into key and value according to RFC1464.
-- Returns 'Nothing' if parsing fails.
-splitRfc1464 :: String -> Maybe (String,String)
+splitRfc1464 :: String -> Maybe (String, String)
splitRfc1464 = go ""
where
go _ [] = Nothing
- go acc ('`':c:cs) = go (c:acc) cs
- go acc ('=':cs) = go2 (reverse acc) "" cs
- go acc (c:cs)
+ go acc ('`' : c : cs) = go (c : acc) cs
+ go acc ('=' : cs) = go2 (reverse acc) "" cs
+ go acc (c : cs)
| isSpace c = go acc cs
- | otherwise = go (c:acc) cs
+ | otherwise = go (c : acc) cs
- go2 k acc [] = Just (k,reverse acc)
- go2 _ _ ['`'] = Nothing
- go2 k acc ('`':c:cs) = go2 k (c:acc) cs
- go2 k acc (c:cs) = go2 k (c:acc) cs
+ go2 k acc [] = Just (k, reverse acc)
+ go2 _ _ ['`'] = Nothing
+ go2 k acc ('`' : c : cs) = go2 k (c : acc) cs
+ go2 k acc (c : cs) = go2 k (c : acc) cs
diff --git a/cabal-install/src/Distribution/Client/Security/HTTP.hs b/cabal-install/src/Distribution/Client/Security/HTTP.hs
index 27fef66b9299ca034a701f65a13f41e6c48ca648..f433c61ab2166fc7b36af59634588ad61b5aae51 100644
--- a/cabal-install/src/Distribution/Client/Security/HTTP.hs
+++ b/cabal-install/src/Distribution/Client/Security/HTTP.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
+
-- | Implementation of 'HttpLib' using cabal-install's own 'HttpTransport'
module Distribution.Client.Security.HTTP (HttpLib, transportAdapter) where
@@ -12,24 +13,33 @@ import Distribution.Solver.Compat.Prelude
import Prelude ()
-- stdlibs
-import System.Directory
- ( getTemporaryDirectory )
-import Network.URI
- ( URI )
+
import qualified Data.ByteString.Lazy as BS.L
-import qualified Network.HTTP as HTTP
+import qualified Network.HTTP as HTTP
+import Network.URI
+ ( URI
+ )
+import System.Directory
+ ( getTemporaryDirectory
+ )
-- Cabal/cabal-install
-import Distribution.Verbosity
- ( Verbosity )
+
import Distribution.Client.HttpUtils
- ( HttpTransport(..), HttpCode )
+ ( HttpCode
+ , HttpTransport (..)
+ )
import Distribution.Client.Utils
- ( withTempFileName )
+ ( withTempFileName
+ )
+import Distribution.Verbosity
+ ( Verbosity
+ )
-- hackage-security
-import Hackage.Security.Client.Repository.HttpLib (HttpLib (..))
+
import qualified Hackage.Security.Client as HC
+import Hackage.Security.Client.Repository.HttpLib (HttpLib (..))
import qualified Hackage.Security.Client.Repository.HttpLib as HC
import qualified Hackage.Security.Util.Checked as HC
import qualified Hackage.Security.Util.Pretty as HC
@@ -57,53 +67,61 @@ import qualified Hackage.Security.Util.Pretty as HC
-- insist on a minimum download rate (potential security attack).
-- Fixing it however would require changing the 'HttpTransport'.
transportAdapter :: Verbosity -> IO HttpTransport -> HttpLib
-transportAdapter verbosity getTransport = HttpLib{
- httpGet = \headers uri callback -> do
- transport <- getTransport
- httpGetImpl verbosity transport headers uri callback
+transportAdapter verbosity getTransport =
+ HttpLib
+ { httpGet = \headers uri callback -> do
+ transport <- getTransport
+ httpGetImpl verbosity transport headers uri callback
, httpGetRange = \headers uri range callback -> do
- transport <- getTransport
- getRange verbosity transport headers uri range callback
+ transport <- getTransport
+ getRange verbosity transport headers uri range callback
}
httpGetImpl
- :: HC.Throws HC.SomeRemoteError
- => Verbosity
- -> HttpTransport
- -> [HC.HttpRequestHeader] -> URI
- -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
- -> IO a
+ :: HC.Throws HC.SomeRemoteError
+ => Verbosity
+ -> HttpTransport
+ -> [HC.HttpRequestHeader]
+ -> URI
+ -> ([HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
+ -> IO a
httpGetImpl verbosity transport reqHeaders uri callback = wrapCustomEx $ do
get' verbosity transport reqHeaders uri Nothing $ \code respHeaders br ->
case code of
200 -> callback respHeaders br
- _ -> HC.throwChecked $ UnexpectedResponse uri code
-
-getRange :: HC.Throws HC.SomeRemoteError
- => Verbosity
- -> HttpTransport
- -> [HC.HttpRequestHeader] -> URI -> (Int, Int)
- -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
- -> IO a
+ _ -> HC.throwChecked $ UnexpectedResponse uri code
+
+getRange
+ :: HC.Throws HC.SomeRemoteError
+ => Verbosity
+ -> HttpTransport
+ -> [HC.HttpRequestHeader]
+ -> URI
+ -> (Int, Int)
+ -> (HC.HttpStatus -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
+ -> IO a
getRange verbosity transport reqHeaders uri range callback = wrapCustomEx $ do
get' verbosity transport reqHeaders uri (Just range) $ \code respHeaders br ->
case code of
- 200 -> callback HC.HttpStatus200OK respHeaders br
- 206 -> callback HC.HttpStatus206PartialContent respHeaders br
- _ -> HC.throwChecked $ UnexpectedResponse uri code
+ 200 -> callback HC.HttpStatus200OK respHeaders br
+ 206 -> callback HC.HttpStatus206PartialContent respHeaders br
+ _ -> HC.throwChecked $ UnexpectedResponse uri code
-- | Internal generalization of 'get' and 'getRange'
-get' :: Verbosity
- -> HttpTransport
- -> [HC.HttpRequestHeader] -> URI -> Maybe (Int, Int)
- -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
- -> IO a
+get'
+ :: Verbosity
+ -> HttpTransport
+ -> [HC.HttpRequestHeader]
+ -> URI
+ -> Maybe (Int, Int)
+ -> (HttpCode -> [HC.HttpResponseHeader] -> HC.BodyReader -> IO a)
+ -> IO a
get' verbosity transport reqHeaders uri mRange callback = do
- tempDir <- getTemporaryDirectory
- withTempFileName tempDir "transportAdapterGet" $ \temp -> do
- (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'
- br <- HC.bodyReaderFromBS =<< BS.L.readFile temp
- callback code [HC.HttpResponseAcceptRangesBytes] br
+ tempDir <- getTemporaryDirectory
+ withTempFileName tempDir "transportAdapterGet" $ \temp -> do
+ (code, _etag) <- getHttp transport verbosity uri Nothing temp reqHeaders'
+ br <- HC.bodyReaderFromBS =<< BS.L.readFile temp
+ callback code [HC.HttpResponseAcceptRangesBytes] br
where
reqHeaders' = mkReqHeaders reqHeaders mRange
@@ -119,22 +137,23 @@ mkRangeHeader from to = HTTP.Header HTTP.HdrRange rangeHeader
rangeHeader = "bytes=" ++ show from ++ "-" ++ show (to - 1)
mkReqHeaders :: [HC.HttpRequestHeader] -> Maybe (Int, Int) -> [HTTP.Header]
-mkReqHeaders reqHeaders mRange' = concat [
- tr [] reqHeaders
+mkReqHeaders reqHeaders mRange' =
+ concat
+ [ tr [] reqHeaders
, [mkRangeHeader fr to | Just (fr, to) <- [mRange]]
]
where
-- guard against malformed range headers.
mRange = case mRange' of
- Just (fr, to) | fr >= to -> Nothing
- _ -> mRange'
+ Just (fr, to) | fr >= to -> Nothing
+ _ -> mRange'
tr :: [(HTTP.HeaderName, [String])] -> [HC.HttpRequestHeader] -> [HTTP.Header]
tr acc [] =
concatMap finalize acc
- tr acc (HC.HttpRequestMaxAge0:os) =
+ tr acc (HC.HttpRequestMaxAge0 : os) =
tr (insert HTTP.HdrCacheControl ["max-age=0"] acc) os
- tr acc (HC.HttpRequestNoTransform:os) =
+ tr acc (HC.HttpRequestNoTransform : os) =
tr (insert HTTP.HdrCacheControl ["no-transform"] acc) os
-- Some headers are comma-separated, others need multiple headers for
@@ -149,10 +168,12 @@ mkReqHeaders reqHeaders mRange' = concat [
-- modify the first matching element
modifyAssocList :: Eq a => a -> (b -> b) -> [(a, b)] -> [(a, b)]
- modifyAssocList a f = go where
- go [] = []
- go (p@(a', b) : xs) | a == a' = (a', f b) : xs
- | otherwise = p : go xs
+ modifyAssocList a f = go
+ where
+ go [] = []
+ go (p@(a', b) : xs)
+ | a == a' = (a', f b) : xs
+ | otherwise = p : go xs
{-------------------------------------------------------------------------------
Custom exceptions
@@ -162,8 +183,11 @@ data UnexpectedResponse = UnexpectedResponse URI Int
deriving (Typeable)
instance HC.Pretty UnexpectedResponse where
- pretty (UnexpectedResponse uri code) = "Unexpected response " ++ show code
- ++ " for " ++ show uri
+ pretty (UnexpectedResponse uri code) =
+ "Unexpected response "
+ ++ show code
+ ++ " for "
+ ++ show uri
#if MIN_VERSION_base(4,8,0)
deriving instance Show UnexpectedResponse
@@ -173,12 +197,16 @@ instance Show UnexpectedResponse where show = HC.pretty
instance Exception UnexpectedResponse
#endif
-wrapCustomEx :: ( ( HC.Throws UnexpectedResponse
- , HC.Throws IOException
- ) => IO a)
- -> (HC.Throws HC.SomeRemoteError => IO a)
-wrapCustomEx act = HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex)
- $ HC.handleChecked (\(ex :: IOException) -> go ex)
- $ act
+wrapCustomEx
+ :: ( ( HC.Throws UnexpectedResponse
+ , HC.Throws IOException
+ )
+ => IO a
+ )
+ -> (HC.Throws HC.SomeRemoteError => IO a)
+wrapCustomEx act =
+ HC.handleChecked (\(ex :: UnexpectedResponse) -> go ex) $
+ HC.handleChecked (\(ex :: IOException) -> go ex) $
+ act
where
go ex = HC.throwChecked (HC.SomeRemoteError ex)
diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs
index 0ef63452a40e6fe77c7e0cbe35c4018f0c71c24e..f119b967d260157228fcbdf908944e4a4e6f5c34 100644
--- a/cabal-install/src/Distribution/Client/Setup.hs
+++ b/cabal-install/src/Distribution/Client/Setup.hs
@@ -1,9 +1,13 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Setup
-- Copyright : (c) David Himmelstrup 2005
@@ -12,382 +16,521 @@
-- Maintainer : lemmih@gmail.com
-- Stability : provisional
-- Portability : portable
---
---
------------------------------------------------------------------------------
module Distribution.Client.Setup
- ( globalCommand, GlobalFlags(..), defaultGlobalFlags
- , RepoContext(..), withRepoContext
- , configureCommand, ConfigFlags(..), configureOptions, filterConfigureFlags
- , configPackageDB', configCompilerAux'
- , configureExCommand, ConfigExFlags(..), defaultConfigExFlags
- , buildCommand, BuildFlags(..)
- , filterTestFlags
- , replCommand, testCommand, benchmarkCommand, testOptions, benchmarkOptions
- , configureExOptions, reconfigureCommand
- , installCommand, InstallFlags(..), installOptions, defaultInstallFlags
- , filterHaddockArgs, filterHaddockFlags, haddockOptions
- , defaultSolver, defaultMaxBackjumps
- , listCommand, ListFlags(..), listNeedsCompiler
- ,UpdateFlags(..), defaultUpdateFlags
- , infoCommand, InfoFlags(..)
- , fetchCommand, FetchFlags(..)
- , freezeCommand, FreezeFlags(..)
- , genBoundsCommand
- , getCommand, unpackCommand, GetFlags(..)
- , checkCommand
- , formatCommand
- , uploadCommand, UploadFlags(..), IsCandidate(..)
- , reportCommand, ReportFlags(..)
- , runCommand
- , initCommand, initOptions, IT.InitFlags(..)
- , actAsSetupCommand, ActAsSetupFlags(..)
- , userConfigCommand, UserConfigFlags(..)
- , manpageCommand
- , haddockCommand
- , cleanCommand
- , copyCommand
- , registerCommand
-
- , liftOptions
- , yesNoOpt
- ) where
+ ( globalCommand
+ , GlobalFlags (..)
+ , defaultGlobalFlags
+ , RepoContext (..)
+ , withRepoContext
+ , configureCommand
+ , ConfigFlags (..)
+ , configureOptions
+ , filterConfigureFlags
+ , configPackageDB'
+ , configCompilerAux'
+ , configureExCommand
+ , ConfigExFlags (..)
+ , defaultConfigExFlags
+ , buildCommand
+ , BuildFlags (..)
+ , filterTestFlags
+ , replCommand
+ , testCommand
+ , benchmarkCommand
+ , testOptions
+ , benchmarkOptions
+ , configureExOptions
+ , reconfigureCommand
+ , installCommand
+ , InstallFlags (..)
+ , installOptions
+ , defaultInstallFlags
+ , filterHaddockArgs
+ , filterHaddockFlags
+ , haddockOptions
+ , defaultSolver
+ , defaultMaxBackjumps
+ , listCommand
+ , ListFlags (..)
+ , listNeedsCompiler
+ , UpdateFlags (..)
+ , defaultUpdateFlags
+ , infoCommand
+ , InfoFlags (..)
+ , fetchCommand
+ , FetchFlags (..)
+ , freezeCommand
+ , FreezeFlags (..)
+ , genBoundsCommand
+ , getCommand
+ , unpackCommand
+ , GetFlags (..)
+ , checkCommand
+ , formatCommand
+ , uploadCommand
+ , UploadFlags (..)
+ , IsCandidate (..)
+ , reportCommand
+ , ReportFlags (..)
+ , runCommand
+ , initCommand
+ , initOptions
+ , IT.InitFlags (..)
+ , actAsSetupCommand
+ , ActAsSetupFlags (..)
+ , userConfigCommand
+ , UserConfigFlags (..)
+ , manpageCommand
+ , haddockCommand
+ , cleanCommand
+ , copyCommand
+ , registerCommand
+ , liftOptions
+ , yesNoOpt
+ ) where
-import Prelude ()
import Distribution.Client.Compat.Prelude hiding (get)
+import Prelude ()
-import Distribution.Client.Types.Credentials (Username (..), Password (..))
-import Distribution.Client.Types.Repo (RemoteRepo(..), LocalRepo (..))
-import Distribution.Client.Types.AllowNewer (AllowNewer(..), AllowOlder(..), RelaxDeps(..))
+import Distribution.Client.Types.AllowNewer (AllowNewer (..), AllowOlder (..), RelaxDeps (..))
+import Distribution.Client.Types.Credentials (Password (..), Username (..))
+import Distribution.Client.Types.Repo (LocalRepo (..), RemoteRepo (..))
import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
import Distribution.Client.BuildReports.Types
- ( ReportLevel(..) )
+ ( ReportLevel (..)
+ )
import Distribution.Client.Dependency.Types
- ( PreSolver(..) )
+ ( PreSolver (..)
+ )
import Distribution.Client.IndexUtils.ActiveRepos
- ( ActiveRepos )
+ ( ActiveRepos
+ )
import Distribution.Client.IndexUtils.IndexState
- ( TotalIndexState, headTotalIndexState )
-import qualified Distribution.Client.Init.Types as IT
+ ( TotalIndexState
+ , headTotalIndexState
+ )
import qualified Distribution.Client.Init.Defaults as IT
+import qualified Distribution.Client.Init.Types as IT
import Distribution.Client.Targets
- ( UserConstraint, readUserConstraint )
+ ( UserConstraint
+ , readUserConstraint
+ )
import Distribution.Utils.NubList
- ( NubList, toNubList, fromNubList)
+ ( NubList
+ , fromNubList
+ , toNubList
+ )
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.Settings
-import Distribution.Simple.Compiler ( Compiler, PackageDB, PackageDBStack )
-import Distribution.Simple.Program (ProgramDb, defaultProgramDb)
+import Distribution.Client.GlobalFlags
+ ( GlobalFlags (..)
+ , RepoContext (..)
+ , defaultGlobalFlags
+ , withRepoContext
+ )
+import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
+import qualified Distribution.Compat.CharParsing as P
+import Distribution.FieldGrammar.Newtypes (SpecVersion (..))
+import Distribution.PackageDescription
+ ( BuildType (..)
+ , Dependency
+ , LibraryName (..)
+ , RepoKind (..)
+ )
+import Distribution.Parsec
+ ( parsecCommaList
+ )
+import Distribution.ReadE
+ ( ReadE (..)
+ , parsecToReadE
+ , parsecToReadEErr
+ , succeedReadE
+ , unexpectMsgString
+ )
import Distribution.Simple.Command hiding (boolOpt, boolOpt')
import qualified Distribution.Simple.Command as Command
+import Distribution.Simple.Compiler (Compiler, PackageDB, PackageDBStack)
import Distribution.Simple.Configure
- ( configCompilerAuxEx, interpretPackageDbFlags, computeEffectiveProfiling )
-import qualified Distribution.Simple.Setup as Cabal
+ ( computeEffectiveProfiling
+ , configCompilerAuxEx
+ , interpretPackageDbFlags
+ )
import Distribution.Simple.Flag
- ( Flag(..), toFlag, flagToMaybe, flagToList, maybeToFlag
- , flagElim, fromFlagOrDefault
- )
-import Distribution.Simple.Setup
- ( ConfigFlags(..), BuildFlags(..), ReplFlags
- , TestFlags, BenchmarkFlags
- , HaddockFlags(..)
- , CleanFlags(..)
- , CopyFlags(..), RegisterFlags(..)
- , readPackageDbList, showPackageDbList
- , BooleanFlag(..), optionVerbosity
- , boolOpt, boolOpt', trueArg, falseArg
- , optionNumJobs )
+ ( Flag (..)
+ , flagElim
+ , flagToList
+ , flagToMaybe
+ , fromFlagOrDefault
+ , maybeToFlag
+ , toFlag
+ )
import Distribution.Simple.InstallDirs
- ( PathTemplate, InstallDirs(..)
- , toPathTemplate, fromPathTemplate, combinePathTemplate )
-import Distribution.Version
- ( Version, mkVersion )
+ ( InstallDirs (..)
+ , PathTemplate
+ , combinePathTemplate
+ , fromPathTemplate
+ , toPathTemplate
+ )
+import Distribution.Simple.Program (ProgramDb, defaultProgramDb)
+import Distribution.Simple.Setup
+ ( BenchmarkFlags
+ , BooleanFlag (..)
+ , BuildFlags (..)
+ , CleanFlags (..)
+ , ConfigFlags (..)
+ , CopyFlags (..)
+ , HaddockFlags (..)
+ , RegisterFlags (..)
+ , ReplFlags
+ , TestFlags
+ , boolOpt
+ , boolOpt'
+ , falseArg
+ , optionNumJobs
+ , optionVerbosity
+ , readPackageDbList
+ , showPackageDbList
+ , trueArg
+ )
+import qualified Distribution.Simple.Setup as Cabal
+import Distribution.Simple.Utils
+ ( wrapText
+ )
+import Distribution.System (Platform)
import Distribution.Types.GivenComponent
- ( GivenComponent(..) )
+ ( GivenComponent (..)
+ )
import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint(..) )
+ ( PackageVersionConstraint (..)
+ )
import Distribution.Types.UnqualComponentName
- ( unqualComponentNameToPackageName )
-import Distribution.PackageDescription
- ( BuildType(..), RepoKind(..), LibraryName(..), Dependency )
-import Distribution.System ( Platform )
-import Distribution.ReadE
- ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString )
-import qualified Distribution.Compat.CharParsing as P
+ ( unqualComponentNameToPackageName
+ )
import Distribution.Verbosity
- ( lessVerbose, normal, verboseNoFlags, verboseNoTimestamp )
-import Distribution.Simple.Utils
- ( wrapText )
-import Distribution.Client.GlobalFlags
- ( GlobalFlags(..), defaultGlobalFlags
- , RepoContext(..), withRepoContext
- )
-import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
-import Distribution.FieldGrammar.Newtypes (SpecVersion (..))
-import Distribution.Parsec
- ( parsecCommaList )
+ ( lessVerbose
+ , normal
+ , verboseNoFlags
+ , verboseNoTimestamp
+ )
+import Distribution.Version
+ ( Version
+ , mkVersion
+ )
import Data.List
- ( deleteFirstsBy )
+ ( deleteFirstsBy
+ )
import System.FilePath
- ( (</>) )
+ ( (</>)
+ )
globalCommand :: [Command action] -> CommandUI GlobalFlags
-globalCommand commands = CommandUI {
- commandName = "",
- commandSynopsis =
- "Command line interface to the Haskell Cabal infrastructure.",
- commandUsage = \pname ->
- "See http://www.haskell.org/cabal/ for more information.\n"
- ++ "\n"
- ++ "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n",
- commandDescription = Just $ \pname ->
- let
- commands' = commands ++ [commandAddAction helpCommandUI undefined]
- cmdDescs = getNormalCommandDescriptions commands'
- -- if new commands are added, we want them to appear even if they
- -- are not included in the custom listing below. Thus, we calculate
- -- the `otherCmds` list and append it under the `other` category.
- -- Alternatively, a new testcase could be added that ensures that
- -- the set of commands listed here is equal to the set of commands
- -- that are actually available.
- otherCmds = deleteFirstsBy (==) (map fst cmdDescs)
- [ "help"
- , "update"
- , "install"
- , "fetch"
- , "list"
- , "info"
- , "user-config"
- , "get"
- , "unpack"
- , "init"
- , "configure"
- , "build"
- , "clean"
- , "run"
- , "repl"
- , "test"
- , "bench"
- , "check"
- , "sdist"
- , "upload"
- , "report"
- , "freeze"
- , "gen-bounds"
- , "outdated"
- , "haddock"
- , "hscolour"
- , "exec"
- , "new-build"
- , "new-configure"
- , "new-repl"
- , "new-freeze"
- , "new-run"
- , "new-test"
- , "new-bench"
- , "new-haddock"
- , "new-exec"
- , "new-update"
- , "new-install"
- , "new-clean"
- , "new-sdist"
- , "list-bin"
- -- v1 commands, stateful style
- , "v1-build"
- , "v1-configure"
- , "v1-repl"
- , "v1-freeze"
- , "v1-run"
- , "v1-test"
- , "v1-bench"
- , "v1-haddock"
- , "v1-exec"
- , "v1-update"
- , "v1-install"
- , "v1-clean"
- , "v1-sdist"
- , "v1-doctest"
- , "v1-copy"
- , "v1-register"
- , "v1-reconfigure"
- -- v2 commands, nix-style
- , "v2-build"
- , "v2-configure"
- , "v2-repl"
- , "v2-freeze"
- , "v2-run"
- , "v2-test"
- , "v2-bench"
- , "v2-haddock"
- , "v2-exec"
- , "v2-update"
- , "v2-install"
- , "v2-clean"
- , "v2-sdist"
- ]
- maxlen = maximum $ [length name | (name, _) <- cmdDescs]
- align str = str ++ replicate (maxlen - length str) ' '
- startGroup n = " ["++n++"]"
- par = ""
- addCmd n = case lookup n cmdDescs of
- Nothing -> ""
- Just d -> " " ++ align n ++ " " ++ d
- in
- "Commands:\n"
- ++ unlines (
- [ startGroup "global"
- , addCmd "user-config"
- , addCmd "help"
- , par
- , startGroup "package database"
- , addCmd "update"
- , addCmd "list"
- , addCmd "info"
- , par
- , startGroup "initialization and download"
- , addCmd "init"
- , addCmd "fetch"
- , addCmd "get"
- , par
- , startGroup "project configuration"
- , addCmd "configure"
- , addCmd "freeze"
- , addCmd "gen-bounds"
- , addCmd "outdated"
- , par
- , startGroup "project building and installing"
- , addCmd "build"
- , addCmd "install"
- , addCmd "haddock"
- , addCmd "haddock-project"
- , addCmd "clean"
- , par
- , startGroup "running and testing"
- , addCmd "list-bin"
- , addCmd "repl"
- , addCmd "run"
- , addCmd "bench"
- , addCmd "test"
- , addCmd "exec"
- , par
- , startGroup "sanity checks and shipping"
- , addCmd "check"
- , addCmd "sdist"
- , addCmd "upload"
- , addCmd "report"
- , par
- , startGroup "deprecated"
- , addCmd "unpack"
- , addCmd "hscolour"
- , par
- , startGroup "new-style projects (forwards-compatible aliases)"
- , addCmd "v2-build"
- , addCmd "v2-configure"
- , addCmd "v2-repl"
- , addCmd "v2-run"
- , addCmd "v2-test"
- , addCmd "v2-bench"
- , addCmd "v2-freeze"
- , addCmd "v2-haddock"
- , addCmd "v2-exec"
- , addCmd "v2-update"
- , addCmd "v2-install"
- , addCmd "v2-clean"
- , addCmd "v2-sdist"
- , par
- , startGroup "legacy command aliases"
- , addCmd "v1-build"
- , addCmd "v1-configure"
- , addCmd "v1-repl"
- , addCmd "v1-run"
- , addCmd "v1-test"
- , addCmd "v1-bench"
- , addCmd "v1-freeze"
- , addCmd "v1-haddock"
- , addCmd "v1-install"
- , addCmd "v1-clean"
- , addCmd "v1-copy"
- , addCmd "v1-register"
- , addCmd "v1-reconfigure"
- ] ++ if null otherCmds then [] else par
- :startGroup "other"
- :[addCmd n | n <- otherCmds])
- ++ "\n"
- ++ "For more information about a command use:\n"
- ++ " " ++ pname ++ " COMMAND --help\n"
- ++ "or " ++ pname ++ " help COMMAND\n"
- ++ "\n"
- ++ "To install Cabal packages from hackage use:\n"
- ++ " " ++ pname ++ " install foo [--dry-run]\n"
- ++ "\n"
- ++ "Occasionally you need to update the list of available packages:\n"
- ++ " " ++ pname ++ " update\n",
- commandNotes = Nothing,
- commandDefaultFlags = mempty,
- commandOptions = args
- }
+globalCommand commands =
+ CommandUI
+ { commandName = ""
+ , commandSynopsis =
+ "Command line interface to the Haskell Cabal infrastructure."
+ , commandUsage = \pname ->
+ "See http://www.haskell.org/cabal/ for more information.\n"
+ ++ "\n"
+ ++ "Usage: "
+ ++ pname
+ ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n"
+ , commandDescription = Just $ \pname ->
+ let
+ commands' = commands ++ [commandAddAction helpCommandUI undefined]
+ cmdDescs = getNormalCommandDescriptions commands'
+ -- if new commands are added, we want them to appear even if they
+ -- are not included in the custom listing below. Thus, we calculate
+ -- the `otherCmds` list and append it under the `other` category.
+ -- Alternatively, a new testcase could be added that ensures that
+ -- the set of commands listed here is equal to the set of commands
+ -- that are actually available.
+ otherCmds =
+ deleteFirstsBy
+ (==)
+ (map fst cmdDescs)
+ [ "help"
+ , "update"
+ , "install"
+ , "fetch"
+ , "list"
+ , "info"
+ , "user-config"
+ , "get"
+ , "unpack"
+ , "init"
+ , "configure"
+ , "build"
+ , "clean"
+ , "run"
+ , "repl"
+ , "test"
+ , "bench"
+ , "check"
+ , "sdist"
+ , "upload"
+ , "report"
+ , "freeze"
+ , "gen-bounds"
+ , "outdated"
+ , "haddock"
+ , "hscolour"
+ , "exec"
+ , "new-build"
+ , "new-configure"
+ , "new-repl"
+ , "new-freeze"
+ , "new-run"
+ , "new-test"
+ , "new-bench"
+ , "new-haddock"
+ , "new-exec"
+ , "new-update"
+ , "new-install"
+ , "new-clean"
+ , "new-sdist"
+ , "list-bin"
+ , -- v1 commands, stateful style
+ "v1-build"
+ , "v1-configure"
+ , "v1-repl"
+ , "v1-freeze"
+ , "v1-run"
+ , "v1-test"
+ , "v1-bench"
+ , "v1-haddock"
+ , "v1-exec"
+ , "v1-update"
+ , "v1-install"
+ , "v1-clean"
+ , "v1-sdist"
+ , "v1-doctest"
+ , "v1-copy"
+ , "v1-register"
+ , "v1-reconfigure"
+ , -- v2 commands, nix-style
+ "v2-build"
+ , "v2-configure"
+ , "v2-repl"
+ , "v2-freeze"
+ , "v2-run"
+ , "v2-test"
+ , "v2-bench"
+ , "v2-haddock"
+ , "v2-exec"
+ , "v2-update"
+ , "v2-install"
+ , "v2-clean"
+ , "v2-sdist"
+ ]
+ maxlen = maximum $ [length name | (name, _) <- cmdDescs]
+ align str = str ++ replicate (maxlen - length str) ' '
+ startGroup n = " [" ++ n ++ "]"
+ par = ""
+ addCmd n = case lookup n cmdDescs of
+ Nothing -> ""
+ Just d -> " " ++ align n ++ " " ++ d
+ in
+ "Commands:\n"
+ ++ unlines
+ ( [ startGroup "global"
+ , addCmd "user-config"
+ , addCmd "help"
+ , par
+ , startGroup "package database"
+ , addCmd "update"
+ , addCmd "list"
+ , addCmd "info"
+ , par
+ , startGroup "initialization and download"
+ , addCmd "init"
+ , addCmd "fetch"
+ , addCmd "get"
+ , par
+ , startGroup "project configuration"
+ , addCmd "configure"
+ , addCmd "freeze"
+ , addCmd "gen-bounds"
+ , addCmd "outdated"
+ , par
+ , startGroup "project building and installing"
+ , addCmd "build"
+ , addCmd "install"
+ , addCmd "haddock"
+ , addCmd "haddock-project"
+ , addCmd "clean"
+ , par
+ , startGroup "running and testing"
+ , addCmd "list-bin"
+ , addCmd "repl"
+ , addCmd "run"
+ , addCmd "bench"
+ , addCmd "test"
+ , addCmd "exec"
+ , par
+ , startGroup "sanity checks and shipping"
+ , addCmd "check"
+ , addCmd "sdist"
+ , addCmd "upload"
+ , addCmd "report"
+ , par
+ , startGroup "deprecated"
+ , addCmd "unpack"
+ , addCmd "hscolour"
+ , par
+ , startGroup "new-style projects (forwards-compatible aliases)"
+ , addCmd "v2-build"
+ , addCmd "v2-configure"
+ , addCmd "v2-repl"
+ , addCmd "v2-run"
+ , addCmd "v2-test"
+ , addCmd "v2-bench"
+ , addCmd "v2-freeze"
+ , addCmd "v2-haddock"
+ , addCmd "v2-exec"
+ , addCmd "v2-update"
+ , addCmd "v2-install"
+ , addCmd "v2-clean"
+ , addCmd "v2-sdist"
+ , par
+ , startGroup "legacy command aliases"
+ , addCmd "v1-build"
+ , addCmd "v1-configure"
+ , addCmd "v1-repl"
+ , addCmd "v1-run"
+ , addCmd "v1-test"
+ , addCmd "v1-bench"
+ , addCmd "v1-freeze"
+ , addCmd "v1-haddock"
+ , addCmd "v1-install"
+ , addCmd "v1-clean"
+ , addCmd "v1-copy"
+ , addCmd "v1-register"
+ , addCmd "v1-reconfigure"
+ ]
+ ++ if null otherCmds
+ then []
+ else
+ par
+ : startGroup "other"
+ : [addCmd n | n <- otherCmds]
+ )
+ ++ "\n"
+ ++ "For more information about a command use:\n"
+ ++ " "
+ ++ pname
+ ++ " COMMAND --help\n"
+ ++ "or "
+ ++ pname
+ ++ " help COMMAND\n"
+ ++ "\n"
+ ++ "To install Cabal packages from hackage use:\n"
+ ++ " "
+ ++ pname
+ ++ " install foo [--dry-run]\n"
+ ++ "\n"
+ ++ "Occasionally you need to update the list of available packages:\n"
+ ++ " "
+ ++ pname
+ ++ " update\n"
+ , commandNotes = Nothing
+ , commandDefaultFlags = mempty
+ , commandOptions = args
+ }
where
args :: ShowOrParseArgs -> [OptionField GlobalFlags]
- args ShowArgs = argsShown
+ args ShowArgs = argsShown
args ParseArgs = argsShown ++ argsNotShown
-- arguments we want to show in the help
argsShown :: [OptionField GlobalFlags]
- argsShown = [
- option ['V'] ["version"]
- "Print version information"
- globalVersion (\v flags -> flags { globalVersion = v })
- trueArg
-
- ,option [] ["numeric-version"]
- "Print just the version number"
- globalNumericVersion (\v flags -> flags { globalNumericVersion = v })
- trueArg
-
- ,option [] ["config-file"]
- "Set an alternate location for the config file"
- globalConfigFile (\v flags -> flags { globalConfigFile = v })
- (reqArgFlag "FILE")
-
- ,option [] ["ignore-expiry"]
- "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
- globalIgnoreExpiry (\v flags -> flags { globalIgnoreExpiry = v })
- trueArg
-
- ,option [] ["http-transport"]
- "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
- globalHttpTransport (\v flags -> flags { globalHttpTransport = v })
- (reqArgFlag "HttpTransport")
-
- ,multiOption "nix"
- globalNix (\v flags -> flags { globalNix = v })
- [
- optArg' "(True or False)" (maybeToFlag . (readMaybe =<<)) (\case
- Flag True -> [Just "enable"]
- Flag False -> [Just "disable"]
- NoFlag -> []) "" ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr
- "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)",
- noArg (Flag True) [] ["enable-nix"]
- "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists",
- noArg (Flag False) [] ["disable-nix"]
- "Disable Nix integration"
- ]
-
- ,option [] ["store-dir", "storedir"]
- "The location of the build store"
- globalStoreDir (\v flags -> flags { globalStoreDir = v })
- (reqArgFlag "DIR")
-
- , option [] ["active-repositories"]
- "The active package repositories (set to ':none' to disable all repositories)"
- globalActiveRepos (\v flags -> flags { globalActiveRepos = v })
- (reqArg "REPOS" (parsecToReadE (\err -> "Error parsing active-repositories: " ++ err)
- (toFlag `fmap` parsec))
- (map prettyShow . flagToList))
+ argsShown =
+ [ option
+ ['V']
+ ["version"]
+ "Print version information"
+ globalVersion
+ (\v flags -> flags{globalVersion = v})
+ trueArg
+ , option
+ []
+ ["numeric-version"]
+ "Print just the version number"
+ globalNumericVersion
+ (\v flags -> flags{globalNumericVersion = v})
+ trueArg
+ , option
+ []
+ ["config-file"]
+ "Set an alternate location for the config file"
+ globalConfigFile
+ (\v flags -> flags{globalConfigFile = v})
+ (reqArgFlag "FILE")
+ , option
+ []
+ ["ignore-expiry"]
+ "Ignore expiry dates on signed metadata (use only in exceptional circumstances)"
+ globalIgnoreExpiry
+ (\v flags -> flags{globalIgnoreExpiry = v})
+ trueArg
+ , option
+ []
+ ["http-transport"]
+ "Set a transport for http(s) requests. Accepts 'curl', 'wget', 'powershell', and 'plain-http'. (default: 'curl')"
+ globalHttpTransport
+ (\v flags -> flags{globalHttpTransport = v})
+ (reqArgFlag "HttpTransport")
+ , multiOption
+ "nix"
+ globalNix
+ (\v flags -> flags{globalNix = v})
+ [ optArg'
+ "(True or False)"
+ (maybeToFlag . (readMaybe =<<))
+ ( \case
+ Flag True -> [Just "enable"]
+ Flag False -> [Just "disable"]
+ NoFlag -> []
+ )
+ ""
+ ["nix"] -- Must be empty because we need to return PP.empty from viewAsFieldDescr
+ "Nix integration: run commands through nix-shell if a 'shell.nix' file exists (default is False)"
+ , noArg
+ (Flag True)
+ []
+ ["enable-nix"]
+ "Enable Nix integration: run commands through nix-shell if a 'shell.nix' file exists"
+ , noArg
+ (Flag False)
+ []
+ ["disable-nix"]
+ "Disable Nix integration"
+ ]
+ , option
+ []
+ ["store-dir", "storedir"]
+ "The location of the build store"
+ globalStoreDir
+ (\v flags -> flags{globalStoreDir = v})
+ (reqArgFlag "DIR")
+ , option
+ []
+ ["active-repositories"]
+ "The active package repositories (set to ':none' to disable all repositories)"
+ globalActiveRepos
+ (\v flags -> flags{globalActiveRepos = v})
+ ( reqArg
+ "REPOS"
+ ( parsecToReadE
+ (\err -> "Error parsing active-repositories: " ++ err)
+ (toFlag `fmap` parsec)
+ )
+ (map prettyShow . flagToList)
+ )
]
-- arguments we don't want shown in the help
@@ -395,62 +538,81 @@ globalCommand commands = CommandUI {
-- the global logs directory was only used in v1, while in v2 we have specific project config logs dirs
-- default-user-config is support for a relatively obscure workflow for v1-freeze.
argsNotShown :: [OptionField GlobalFlags]
- argsNotShown = [
- option [] ["remote-repo"]
- "The name and url for a remote repository"
- globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })
- (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList))
-
- ,option [] ["local-no-index-repo"]
- "The name and a path for a local no-index repository"
- globalLocalNoIndexRepos (\v flags -> flags { globalLocalNoIndexRepos = v })
- (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList))
-
- ,option [] ["remote-repo-cache"]
- "The location where downloads from all remote repos are cached"
- globalCacheDir (\v flags -> flags { globalCacheDir = v })
- (reqArgFlag "DIR")
-
- ,option [] ["logs-dir", "logsdir"]
- "The location to put log files"
- globalLogsDir (\v flags -> flags { globalLogsDir = v })
- (reqArgFlag "DIR")
-
- ,option [] ["default-user-config"]
- "Set a location for a cabal.config file for projects without their own cabal.config freeze file."
- globalConstraintsFile (\v flags -> flags {globalConstraintsFile = v})
- (reqArgFlag "FILE")
+ argsNotShown =
+ [ option
+ []
+ ["remote-repo"]
+ "The name and url for a remote repository"
+ globalRemoteRepos
+ (\v flags -> flags{globalRemoteRepos = v})
+ (reqArg' "NAME:URL" (toNubList . maybeToList . readRemoteRepo) (map showRemoteRepo . fromNubList))
+ , option
+ []
+ ["local-no-index-repo"]
+ "The name and a path for a local no-index repository"
+ globalLocalNoIndexRepos
+ (\v flags -> flags{globalLocalNoIndexRepos = v})
+ (reqArg' "NAME:PATH" (toNubList . maybeToList . readLocalRepo) (map showLocalRepo . fromNubList))
+ , option
+ []
+ ["remote-repo-cache"]
+ "The location where downloads from all remote repos are cached"
+ globalCacheDir
+ (\v flags -> flags{globalCacheDir = v})
+ (reqArgFlag "DIR")
+ , option
+ []
+ ["logs-dir", "logsdir"]
+ "The location to put log files"
+ globalLogsDir
+ (\v flags -> flags{globalLogsDir = v})
+ (reqArgFlag "DIR")
+ , option
+ []
+ ["default-user-config"]
+ "Set a location for a cabal.config file for projects without their own cabal.config freeze file."
+ globalConstraintsFile
+ (\v flags -> flags{globalConstraintsFile = v})
+ (reqArgFlag "FILE")
]
-- ------------------------------------------------------------
+
-- * Config flags
+
-- ------------------------------------------------------------
configureCommand :: CommandUI ConfigFlags
-configureCommand = c
- { commandName = "configure"
- , commandDefaultFlags = mempty
- , commandDescription = Just $ \_ -> wrapText $
- "Configure how the package is built by setting "
- ++ "package (and other) flags.\n"
- ++ "\n"
- ++ "The configuration affects several other commands, "
- ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n"
- , commandUsage = \pname ->
- "Usage: " ++ pname ++ " v1-configure [FLAGS]\n"
- , commandNotes = Just $ \pname ->
- (Cabal.programFlagsDescription defaultProgramDb ++ "\n")
- ++ "Examples:\n"
- ++ " " ++ pname ++ " v1-configure\n"
- ++ " Configure with defaults;\n"
- ++ " " ++ pname ++ " v1-configure --enable-tests -fcustomflag\n"
- ++ " Configure building package including tests,\n"
- ++ " with some package-specific flag.\n"
- }
- where
- c = Cabal.configureCommand defaultProgramDb
+configureCommand =
+ c
+ { commandName = "configure"
+ , commandDefaultFlags = mempty
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Configure how the package is built by setting "
+ ++ "package (and other) flags.\n"
+ ++ "\n"
+ ++ "The configuration affects several other commands, "
+ ++ "including v1-build, v1-test, v1-bench, v1-run, v1-repl.\n"
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " v1-configure [FLAGS]\n"
+ , commandNotes = Just $ \pname ->
+ (Cabal.programFlagsDescription defaultProgramDb ++ "\n")
+ ++ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v1-configure\n"
+ ++ " Configure with defaults;\n"
+ ++ " "
+ ++ pname
+ ++ " v1-configure --enable-tests -fcustomflag\n"
+ ++ " Configure building package including tests,\n"
+ ++ " with some package-specific flag.\n"
+ }
+ where
+ c = Cabal.configureCommand defaultProgramDb
-configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]
+configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags]
configureOptions = commandOptions configureCommand
-- | Given some 'ConfigFlags' for the version of Cabal that
@@ -465,285 +627,363 @@ filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags
filterConfigureFlags flags cabalLibVersion
-- NB: we expect the latest version to be the most common case,
-- so test it first.
- | cabalLibVersion >= mkVersion [3,7,0] = flags_latest
+ | cabalLibVersion >= mkVersion [3, 7, 0] = flags_latest
-- The naming convention is that flags_version gives flags with
-- all flags *introduced* in version eliminated.
-- It is NOT the latest version of Cabal library that
-- these flags work for; version of introduction is a more
-- natural metric.
- | cabalLibVersion < mkVersion [1,3,10] = flags_1_3_10
- | cabalLibVersion < mkVersion [1,10,0] = flags_1_10_0
- | cabalLibVersion < mkVersion [1,12,0] = flags_1_12_0
- | cabalLibVersion < mkVersion [1,14,0] = flags_1_14_0
- | cabalLibVersion < mkVersion [1,18,0] = flags_1_18_0
- | cabalLibVersion < mkVersion [1,19,1] = flags_1_19_1
- | cabalLibVersion < mkVersion [1,19,2] = flags_1_19_2
- | cabalLibVersion < mkVersion [1,21,1] = flags_1_21_1
- | cabalLibVersion < mkVersion [1,22,0] = flags_1_22_0
- | cabalLibVersion < mkVersion [1,22,1] = flags_1_22_1
- | cabalLibVersion < mkVersion [1,23,0] = flags_1_23_0
- | cabalLibVersion < mkVersion [1,25,0] = flags_1_25_0
- | cabalLibVersion < mkVersion [2,1,0] = flags_2_1_0
- | cabalLibVersion < mkVersion [2,5,0] = flags_2_5_0
- | cabalLibVersion < mkVersion [3,7,0] = flags_3_7_0
+ | cabalLibVersion < mkVersion [1, 3, 10] = flags_1_3_10
+ | cabalLibVersion < mkVersion [1, 10, 0] = flags_1_10_0
+ | cabalLibVersion < mkVersion [1, 12, 0] = flags_1_12_0
+ | cabalLibVersion < mkVersion [1, 14, 0] = flags_1_14_0
+ | cabalLibVersion < mkVersion [1, 18, 0] = flags_1_18_0
+ | cabalLibVersion < mkVersion [1, 19, 1] = flags_1_19_1
+ | cabalLibVersion < mkVersion [1, 19, 2] = flags_1_19_2
+ | cabalLibVersion < mkVersion [1, 21, 1] = flags_1_21_1
+ | cabalLibVersion < mkVersion [1, 22, 0] = flags_1_22_0
+ | cabalLibVersion < mkVersion [1, 22, 1] = flags_1_22_1
+ | cabalLibVersion < mkVersion [1, 23, 0] = flags_1_23_0
+ | cabalLibVersion < mkVersion [1, 25, 0] = flags_1_25_0
+ | cabalLibVersion < mkVersion [2, 1, 0] = flags_2_1_0
+ | cabalLibVersion < mkVersion [2, 5, 0] = flags_2_5_0
+ | cabalLibVersion < mkVersion [3, 7, 0] = flags_3_7_0
| otherwise = error "the impossible just happened" -- see first guard
where
- flags_latest = flags {
- -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
- -- Note: this is not in the wrong place. configConstraints gets
- -- repopulated in flags_1_19_1 but it needs to be set to empty for
- -- newer versions first.
- configConstraints = []
- }
-
- flags_3_7_0 = flags_latest {
- -- Cabal < 3.7 does not know about --extra-lib-dirs-static
- configExtraLibDirsStatic = [],
-
- -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info'
- configDumpBuildInfo = NoFlag
- }
-
- flags_2_5_0 = flags_3_7_0 {
- -- Cabal < 2.5 does not understand --dependency=pkg:component=cid
- -- (public sublibraries), so we convert it to the legacy
- -- --dependency=pkg_or_internal_component=cid
- configDependencies =
- let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) =
- Just $ GivenComponent
- (unqualComponentNameToPackageName cn)
- LMainLibName
- cid
- convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =
- Just $ GivenComponent pn LMainLibName cid
- in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags
- -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.
- , configAllowDependingOnPrivateLibs = NoFlag
- -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.
- , configFullyStaticExe = NoFlag
- }
-
- flags_2_1_0 = flags_2_5_0 {
- -- Cabal < 2.1 doesn't know about -v +timestamp modifier
- configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest)
- -- Cabal < 2.1 doesn't know about --<enable|disable>-static
- , configStaticLib = NoFlag
- , configSplitSections = NoFlag
- }
-
- flags_1_25_0 = flags_2_1_0 {
- -- Cabal < 1.25.0 doesn't know about --dynlibdir.
- configInstallDirs = configInstallDirs_1_25_0,
- -- Cabal < 1.25 doesn't have extended verbosity syntax
- configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0),
- -- Cabal < 1.25 doesn't support --deterministic
- configDeterministic = mempty
- }
- configInstallDirs_1_25_0 = let dirs = configInstallDirs flags in
- dirs { dynlibdir = NoFlag
- , libexecsubdir = NoFlag
- , libexecdir = maybeToFlag $
- combinePathTemplate <$> flagToMaybe (libexecdir dirs)
- <*> flagToMaybe (libexecsubdir dirs)
- }
+ flags_latest =
+ flags
+ { -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.
+ -- Note: this is not in the wrong place. configConstraints gets
+ -- repopulated in flags_1_19_1 but it needs to be set to empty for
+ -- newer versions first.
+ configConstraints = []
+ }
+
+ flags_3_7_0 =
+ flags_latest
+ { -- Cabal < 3.7 does not know about --extra-lib-dirs-static
+ configExtraLibDirsStatic = []
+ , -- Cabal < 3.7 does not understand '--enable-build-info' or '--disable-build-info'
+ configDumpBuildInfo = NoFlag
+ }
+
+ flags_2_5_0 =
+ flags_3_7_0
+ { -- Cabal < 2.5 does not understand --dependency=pkg:component=cid
+ -- (public sublibraries), so we convert it to the legacy
+ -- --dependency=pkg_or_internal_component=cid
+ configDependencies =
+ let convertToLegacyInternalDep (GivenComponent _ (LSubLibName cn) cid) =
+ Just $
+ GivenComponent
+ (unqualComponentNameToPackageName cn)
+ LMainLibName
+ cid
+ convertToLegacyInternalDep (GivenComponent pn LMainLibName cid) =
+ Just $ GivenComponent pn LMainLibName cid
+ in catMaybes $ convertToLegacyInternalDep <$> configDependencies flags
+ , -- Cabal < 2.5 doesn't know about '--allow-depending-on-private-libs'.
+ configAllowDependingOnPrivateLibs = NoFlag
+ , -- Cabal < 2.5 doesn't know about '--enable/disable-executable-static'.
+ configFullyStaticExe = NoFlag
+ }
+
+ flags_2_1_0 =
+ flags_2_5_0
+ { -- Cabal < 2.1 doesn't know about -v +timestamp modifier
+ configVerbosity = fmap verboseNoTimestamp (configVerbosity flags_latest)
+ , -- Cabal < 2.1 doesn't know about --<enable|disable>-static
+ configStaticLib = NoFlag
+ , configSplitSections = NoFlag
+ }
+
+ flags_1_25_0 =
+ flags_2_1_0
+ { -- Cabal < 1.25.0 doesn't know about --dynlibdir.
+ configInstallDirs = configInstallDirs_1_25_0
+ , -- Cabal < 1.25 doesn't have extended verbosity syntax
+ configVerbosity = fmap verboseNoFlags (configVerbosity flags_2_1_0)
+ , -- Cabal < 1.25 doesn't support --deterministic
+ configDeterministic = mempty
+ }
+ configInstallDirs_1_25_0 =
+ let dirs = configInstallDirs flags
+ in dirs
+ { dynlibdir = NoFlag
+ , libexecsubdir = NoFlag
+ , libexecdir =
+ maybeToFlag $
+ combinePathTemplate
+ <$> flagToMaybe (libexecdir dirs)
+ <*> flagToMaybe (libexecsubdir dirs)
+ }
-- Cabal < 1.23 doesn't know about '--profiling-detail'.
-- Cabal < 1.23 has a hacked up version of 'enable-profiling'
-- which we shouldn't use.
(tryLibProfiling, tryExeProfiling) = computeEffectiveProfiling flags
- flags_1_23_0 = flags_1_25_0 { configProfDetail = NoFlag
- , configProfLibDetail = NoFlag
- , configIPID = NoFlag
- , configProf = NoFlag
- , configProfExe = Flag tryExeProfiling
- , configProfLib = Flag tryLibProfiling
- }
+ flags_1_23_0 =
+ flags_1_25_0
+ { configProfDetail = NoFlag
+ , configProfLibDetail = NoFlag
+ , configIPID = NoFlag
+ , configProf = NoFlag
+ , configProfExe = Flag tryExeProfiling
+ , configProfLib = Flag tryLibProfiling
+ }
-- Cabal == 1.22.0.* had a discontinuity (see #5946 or e9a8d48a3adce34d)
-- due to temporary amnesia of the --*-executable-profiling flags
- flags_1_22_1 = flags_1_23_0 { configDebugInfo = NoFlag
- , configProfExe = NoFlag
- }
+ flags_1_22_1 =
+ flags_1_23_0
+ { configDebugInfo = NoFlag
+ , configProfExe = NoFlag
+ }
-- Cabal < 1.22 doesn't know about '--disable-debug-info'.
- flags_1_22_0 = flags_1_23_0 { configDebugInfo = NoFlag }
+ flags_1_22_0 = flags_1_23_0{configDebugInfo = NoFlag}
-- Cabal < 1.21.1 doesn't know about 'disable-relocatable'
-- Cabal < 1.21.1 doesn't know about 'enable-profiling'
-- (but we already dealt with it in flags_1_23_0)
flags_1_21_1 =
- flags_1_22_0 { configRelocatable = NoFlag
- , configCoverage = NoFlag
- , configLibCoverage = configCoverage flags
- }
+ flags_1_22_0
+ { configRelocatable = NoFlag
+ , configCoverage = NoFlag
+ , configLibCoverage = configCoverage flags
+ }
-- Cabal < 1.19.2 doesn't know about '--exact-configuration' and
-- '--enable-library-stripping'.
- flags_1_19_2 = flags_1_21_1 { configExactConfiguration = NoFlag
- , configStripLibs = NoFlag }
+ flags_1_19_2 =
+ flags_1_21_1
+ { configExactConfiguration = NoFlag
+ , configStripLibs = NoFlag
+ }
-- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.
- flags_1_19_1 = flags_1_19_2 { configDependencies = []
- , configConstraints = configConstraints flags }
+ flags_1_19_1 =
+ flags_1_19_2
+ { configDependencies = []
+ , configConstraints = configConstraints flags
+ }
-- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.
- flags_1_18_0 = flags_1_19_1 { configProgramPathExtra = toNubList []
- , configInstallDirs = configInstallDirs_1_18_0}
- configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1) { sysconfdir = NoFlag }
+ flags_1_18_0 =
+ flags_1_19_1
+ { configProgramPathExtra = toNubList []
+ , configInstallDirs = configInstallDirs_1_18_0
+ }
+ configInstallDirs_1_18_0 = (configInstallDirs flags_1_19_1){sysconfdir = NoFlag}
-- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.
- flags_1_14_0 = flags_1_18_0 { configBenchmarks = NoFlag }
+ flags_1_14_0 = flags_1_18_0{configBenchmarks = NoFlag}
-- Cabal < 1.12.0 doesn't know about '--enable/disable-executable-dynamic'
-- and '--enable/disable-library-coverage'.
- flags_1_12_0 = flags_1_14_0 { configLibCoverage = NoFlag
- , configDynExe = NoFlag }
+ flags_1_12_0 =
+ flags_1_14_0
+ { configLibCoverage = NoFlag
+ , configDynExe = NoFlag
+ }
-- Cabal < 1.10.0 doesn't know about '--disable-tests'.
- flags_1_10_0 = flags_1_12_0 { configTests = NoFlag }
+ flags_1_10_0 = flags_1_12_0{configTests = NoFlag}
-- Cabal < 1.3.10 does not grok the '--constraints' flag.
- flags_1_3_10 = flags_1_10_0 { configConstraints = [] }
+ flags_1_3_10 = flags_1_10_0{configConstraints = []}
-- | Get the package database settings from 'ConfigFlags', accounting for
-- @--package-db@ and @--user@ flags.
configPackageDB' :: ConfigFlags -> PackageDBStack
configPackageDB' cfg =
- interpretPackageDbFlags userInstall (configPackageDBs cfg)
+ interpretPackageDbFlags userInstall (configPackageDBs cfg)
where
userInstall = Cabal.fromFlagOrDefault True (configUserInstall cfg)
-- | Configure the compiler, but reduce verbosity during this step.
configCompilerAux' :: ConfigFlags -> IO (Compiler, Platform, ProgramDb)
configCompilerAux' configFlags =
- configCompilerAuxEx configFlags
- --FIXME: make configCompilerAux use a sensible verbosity
- { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
+ configCompilerAuxEx
+ configFlags
+ { -- FIXME: make configCompilerAux use a sensible verbosity
+ configVerbosity = fmap lessVerbose (configVerbosity configFlags)
+ }
-- ------------------------------------------------------------
+
-- * Config extra flags
+
-- ------------------------------------------------------------
-- | cabal configure takes some extra flags beyond runghc Setup configure
---
-data ConfigExFlags = ConfigExFlags {
- configCabalVersion :: Flag Version,
- configAppend :: Flag Bool,
- configBackup :: Flag Bool,
- configExConstraints :: [(UserConstraint, ConstraintSource)],
- configPreferences :: [PackageVersionConstraint],
- configSolver :: Flag PreSolver,
- configAllowNewer :: Maybe AllowNewer,
- configAllowOlder :: Maybe AllowOlder,
- configWriteGhcEnvironmentFilesPolicy
+data ConfigExFlags = ConfigExFlags
+ { configCabalVersion :: Flag Version
+ , configAppend :: Flag Bool
+ , configBackup :: Flag Bool
+ , configExConstraints :: [(UserConstraint, ConstraintSource)]
+ , configPreferences :: [PackageVersionConstraint]
+ , configSolver :: Flag PreSolver
+ , configAllowNewer :: Maybe AllowNewer
+ , configAllowOlder :: Maybe AllowOlder
+ , configWriteGhcEnvironmentFilesPolicy
:: Flag WriteGhcEnvironmentFilesPolicy
}
deriving (Eq, Show, Generic)
defaultConfigExFlags :: ConfigExFlags
-defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
+defaultConfigExFlags = mempty{configSolver = Flag defaultSolver}
configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
-configureExCommand = configureCommand {
- commandDefaultFlags = (mempty, defaultConfigExFlags),
- commandOptions = \showOrParseArgs ->
- liftOptions fst setFst
- (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])
- . optionName) $ configureOptions showOrParseArgs)
- ++ liftOptions snd setSnd
- (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
- }
+configureExCommand =
+ configureCommand
+ { commandDefaultFlags = (mempty, defaultConfigExFlags)
+ , commandOptions = \showOrParseArgs ->
+ liftOptions
+ fst
+ setFst
+ ( filter
+ ( (`notElem` ["constraint", "dependency", "exact-configuration"])
+ . optionName
+ )
+ $ configureOptions showOrParseArgs
+ )
+ ++ liftOptions
+ snd
+ setSnd
+ (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
+ }
where
- setFst a (_,b) = (a,b)
- setSnd b (a,_) = (a,b)
+ setFst a (_, b) = (a, b)
+ setSnd b (a, _) = (a, b)
-configureExOptions :: ShowOrParseArgs
- -> ConstraintSource
- -> [OptionField ConfigExFlags]
+configureExOptions
+ :: ShowOrParseArgs
+ -> ConstraintSource
+ -> [OptionField ConfigExFlags]
configureExOptions _showOrParseArgs src =
- [ option [] ["cabal-lib-version"]
- ("Select which version of the Cabal lib to use to build packages "
- ++ "(useful for testing).")
- configCabalVersion (\v flags -> flags { configCabalVersion = v })
- (reqArg "VERSION" (parsecToReadE ("Cannot parse cabal lib version: "++)
- (fmap toFlag parsec))
- (map prettyShow. flagToList))
- , option "" ["append"]
+ [ option
+ []
+ ["cabal-lib-version"]
+ ( "Select which version of the Cabal lib to use to build packages "
+ ++ "(useful for testing)."
+ )
+ configCabalVersion
+ (\v flags -> flags{configCabalVersion = v})
+ ( reqArg
+ "VERSION"
+ ( parsecToReadE
+ ("Cannot parse cabal lib version: " ++)
+ (fmap toFlag parsec)
+ )
+ (map prettyShow . flagToList)
+ )
+ , option
+ ""
+ ["append"]
"appending the new config to the old config file"
- configAppend (\v flags -> flags { configAppend = v })
+ configAppend
+ (\v flags -> flags{configAppend = v})
(boolOpt [] [])
- , option "" ["backup"]
+ , option
+ ""
+ ["backup"]
"the backup of the config file before any alterations"
- configBackup (\v flags -> flags { configBackup = v })
+ configBackup
+ (\v flags -> flags{configBackup = v})
(boolOpt [] [])
- , option "c" ["constraint"]
+ , option
+ "c"
+ ["constraint"]
"Specify constraints on a package (version, installed/source, flags)"
- configExConstraints (\v flags -> flags { configExConstraints = v })
- (reqArg "CONSTRAINT"
- ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
- (map $ prettyShow . fst))
-
- , option [] ["preference"]
+ configExConstraints
+ (\v flags -> flags{configExConstraints = v})
+ ( reqArg
+ "CONSTRAINT"
+ ((\x -> [(x, src)]) `fmap` ReadE readUserConstraint)
+ (map $ prettyShow . fst)
+ )
+ , option
+ []
+ ["preference"]
"Specify preferences (soft constraints) on the version of a package"
- configPreferences (\v flags -> flags { configPreferences = v })
- (reqArg "CONSTRAINT"
- (parsecToReadE (const "dependency expected")
- (fmap (\x -> [x]) parsec))
- (map prettyShow))
-
- , optionSolver configSolver (\v flags -> flags { configSolver = v })
-
- , option [] ["allow-older"]
- ("Ignore lower bounds in all dependencies or DEPS")
- (fmap unAllowOlder . configAllowOlder)
- (\v flags -> flags { configAllowOlder = fmap AllowOlder v})
- (optArg "DEPS"
- (parsecToReadEErr unexpectMsgString relaxDepsParser)
- (Just RelaxDepsAll) relaxDepsPrinter)
-
- , option [] ["allow-newer"]
- ("Ignore upper bounds in all dependencies or DEPS")
- (fmap unAllowNewer . configAllowNewer)
- (\v flags -> flags { configAllowNewer = fmap AllowNewer v})
- (optArg "DEPS"
- (parsecToReadEErr unexpectMsgString relaxDepsParser)
- (Just RelaxDepsAll) relaxDepsPrinter)
-
- , option [] ["write-ghc-environment-files"]
- ("Whether to create a .ghc.environment file after a successful build"
- ++ " (v2-build only)")
- configWriteGhcEnvironmentFilesPolicy
- (\v flags -> flags { configWriteGhcEnvironmentFilesPolicy = v})
- (reqArg "always|never|ghc8.4.4+"
- writeGhcEnvironmentFilesPolicyParser
- writeGhcEnvironmentFilesPolicyPrinter)
+ configPreferences
+ (\v flags -> flags{configPreferences = v})
+ ( reqArg
+ "CONSTRAINT"
+ ( parsecToReadE
+ (const "dependency expected")
+ (fmap (\x -> [x]) parsec)
+ )
+ (map prettyShow)
+ )
+ , optionSolver configSolver (\v flags -> flags{configSolver = v})
+ , option
+ []
+ ["allow-older"]
+ ("Ignore lower bounds in all dependencies or DEPS")
+ (fmap unAllowOlder . configAllowOlder)
+ (\v flags -> flags{configAllowOlder = fmap AllowOlder v})
+ ( optArg
+ "DEPS"
+ (parsecToReadEErr unexpectMsgString relaxDepsParser)
+ (Just RelaxDepsAll)
+ relaxDepsPrinter
+ )
+ , option
+ []
+ ["allow-newer"]
+ ("Ignore upper bounds in all dependencies or DEPS")
+ (fmap unAllowNewer . configAllowNewer)
+ (\v flags -> flags{configAllowNewer = fmap AllowNewer v})
+ ( optArg
+ "DEPS"
+ (parsecToReadEErr unexpectMsgString relaxDepsParser)
+ (Just RelaxDepsAll)
+ relaxDepsPrinter
+ )
+ , option
+ []
+ ["write-ghc-environment-files"]
+ ( "Whether to create a .ghc.environment file after a successful build"
+ ++ " (v2-build only)"
+ )
+ configWriteGhcEnvironmentFilesPolicy
+ (\v flags -> flags{configWriteGhcEnvironmentFilesPolicy = v})
+ ( reqArg
+ "always|never|ghc8.4.4+"
+ writeGhcEnvironmentFilesPolicyParser
+ writeGhcEnvironmentFilesPolicyPrinter
+ )
]
-
writeGhcEnvironmentFilesPolicyParser :: ReadE (Flag WriteGhcEnvironmentFilesPolicy)
writeGhcEnvironmentFilesPolicyParser = ReadE $ \case
- "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles
- "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles
+ "always" -> Right $ Flag AlwaysWriteGhcEnvironmentFiles
+ "never" -> Right $ Flag NeverWriteGhcEnvironmentFiles
"ghc8.4.4+" -> Right $ Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer
- policy -> Left $ "Cannot parse the GHC environment file write policy '"
- <> policy <> "'"
+ policy ->
+ Left $
+ "Cannot parse the GHC environment file write policy '"
+ <> policy
+ <> "'"
writeGhcEnvironmentFilesPolicyPrinter
:: Flag WriteGhcEnvironmentFilesPolicy -> [String]
writeGhcEnvironmentFilesPolicyPrinter = \case
- (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"]
- (Flag NeverWriteGhcEnvironmentFiles) -> ["never"]
+ (Flag AlwaysWriteGhcEnvironmentFiles) -> ["always"]
+ (Flag NeverWriteGhcEnvironmentFiles) -> ["never"]
(Flag WriteGhcEnvironmentFilesOnlyForGhc844AndNewer) -> ["ghc8.4.4+"]
- NoFlag -> []
-
+ NoFlag -> []
relaxDepsParser :: CabalParsing m => m (Maybe RelaxDeps)
relaxDepsParser = do
rs <- P.sepBy parsec (P.char ',')
if null rs
- then fail $ "empty argument list is not allowed. "
- ++ "Note: use --allow-newer without the equals sign to permit all "
- ++ "packages to use newer versions."
+ then
+ fail $
+ "empty argument list is not allowed. "
+ ++ "Note: use --allow-newer without the equals sign to permit all "
+ ++ "packages to use newer versions."
else return . Just . RelaxDepsSome . toList $ rs
relaxDepsPrinter :: (Maybe RelaxDeps) -> [Maybe String]
-relaxDepsPrinter Nothing = []
-relaxDepsPrinter (Just RelaxDepsAll) = [Nothing]
+relaxDepsPrinter Nothing = []
+relaxDepsPrinter (Just RelaxDepsAll) = [Nothing]
relaxDepsPrinter (Just (RelaxDepsSome pkgs)) = map (Just . prettyShow) $ pkgs
-
instance Monoid ConfigExFlags where
mempty = gmempty
mappend = (<>)
@@ -752,55 +992,73 @@ instance Semigroup ConfigExFlags where
(<>) = gmappend
reconfigureCommand :: CommandUI (ConfigFlags, ConfigExFlags)
-reconfigureCommand
- = configureExCommand
- { commandName = "reconfigure"
- , commandSynopsis = "Reconfigure the package if necessary."
- , commandDescription = Just $ \pname -> wrapText $
- "Run `configure` with the most recently used flags, or append FLAGS "
- ++ "to the most recently used configuration. "
- ++ "Accepts the same flags as `" ++ pname ++ " v1-configure'. "
- ++ "If the package has never been configured, the default flags are "
- ++ "used."
- , commandNotes = Just $ \pname ->
+reconfigureCommand =
+ configureExCommand
+ { commandName = "reconfigure"
+ , commandSynopsis = "Reconfigure the package if necessary."
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "Run `configure` with the most recently used flags, or append FLAGS "
+ ++ "to the most recently used configuration. "
+ ++ "Accepts the same flags as `"
+ ++ pname
+ ++ " v1-configure'. "
+ ++ "If the package has never been configured, the default flags are "
+ ++ "used."
+ , commandNotes = Just $ \pname ->
"Examples:\n"
- ++ " " ++ pname ++ " v1-reconfigure\n"
- ++ " Configure with the most recently used flags.\n"
- ++ " " ++ pname ++ " v1-reconfigure -w PATH\n"
- ++ " Reconfigure with the most recently used flags,\n"
- ++ " but use the compiler at PATH.\n\n"
- , commandUsage = usageAlternatives "v1-reconfigure" [ "[FLAGS]" ]
+ ++ " "
+ ++ pname
+ ++ " v1-reconfigure\n"
+ ++ " Configure with the most recently used flags.\n"
+ ++ " "
+ ++ pname
+ ++ " v1-reconfigure -w PATH\n"
+ ++ " Reconfigure with the most recently used flags,\n"
+ ++ " but use the compiler at PATH.\n\n"
+ , commandUsage = usageAlternatives "v1-reconfigure" ["[FLAGS]"]
, commandDefaultFlags = mempty
}
-- ------------------------------------------------------------
+
-- * Build flags
+
-- ------------------------------------------------------------
buildCommand :: CommandUI BuildFlags
-buildCommand = parent {
- commandName = "build",
- commandDescription = Just $ \_ -> wrapText $
- "Components encompass executables, tests, and benchmarks.\n"
- ++ "\n"
- ++ "Affected by configuration options, see `v1-configure`.\n",
- commandDefaultFlags = commandDefaultFlags parent,
- commandUsage = usageAlternatives "v1-build" $
- [ "[FLAGS]", "COMPONENTS [FLAGS]" ],
- commandOptions = commandOptions parent
- , commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " v1-build "
- ++ " All the components in the package\n"
- ++ " " ++ pname ++ " v1-build foo "
- ++ " A component (i.e. lib, exe, test suite)\n\n"
- ++ Cabal.programFlagsDescription defaultProgramDb
- }
+buildCommand =
+ parent
+ { commandName = "build"
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Components encompass executables, tests, and benchmarks.\n"
+ ++ "\n"
+ ++ "Affected by configuration options, see `v1-configure`.\n"
+ , commandDefaultFlags = commandDefaultFlags parent
+ , commandUsage =
+ usageAlternatives "v1-build" $
+ ["[FLAGS]", "COMPONENTS [FLAGS]"]
+ , commandOptions = commandOptions parent
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v1-build "
+ ++ " All the components in the package\n"
+ ++ " "
+ ++ pname
+ ++ " v1-build foo "
+ ++ " A component (i.e. lib, exe, test suite)\n\n"
+ ++ Cabal.programFlagsDescription defaultProgramDb
+ }
where
parent = Cabal.buildCommand defaultProgramDb
-- ------------------------------------------------------------
+
-- * Test flags
+
-- ------------------------------------------------------------
-- | Given some 'TestFlags' for the version of Cabal that
@@ -815,491 +1073,617 @@ filterTestFlags :: TestFlags -> Version -> TestFlags
filterTestFlags flags cabalLibVersion
-- NB: we expect the latest version to be the most common case,
-- so test it first.
- | cabalLibVersion >= mkVersion [3,0,0] = flags_latest
+ | cabalLibVersion >= mkVersion [3, 0, 0] = flags_latest
-- The naming convention is that flags_version gives flags with
-- all flags *introduced* in version eliminated.
-- It is NOT the latest version of Cabal library that
-- these flags work for; version of introduction is a more
-- natural metric.
- | cabalLibVersion < mkVersion [3,0,0] = flags_3_0_0
+ | cabalLibVersion < mkVersion [3, 0, 0] = flags_3_0_0
| otherwise = error "the impossible just happened" -- see first guard
where
flags_latest = flags
- flags_3_0_0 = flags_latest {
- -- Cabal < 3.0 doesn't know about --test-wrapper
- Cabal.testWrapper = NoFlag
- }
+ flags_3_0_0 =
+ flags_latest
+ { -- Cabal < 3.0 doesn't know about --test-wrapper
+ Cabal.testWrapper = NoFlag
+ }
-- ------------------------------------------------------------
+
-- * Repl command
+
-- ------------------------------------------------------------
replCommand :: CommandUI ReplFlags
-replCommand = parent {
- commandName = "repl",
- commandDescription = Just $ \pname -> wrapText $
- "If the current directory contains no package, ignores COMPONENT "
- ++ "parameters and opens an interactive interpreter session;\n"
- ++ "\n"
- ++ "Otherwise, (re)configures with the given or default flags, and "
- ++ "loads the interpreter with the relevant modules. For executables, "
- ++ "tests and benchmarks, loads the main module (and its "
- ++ "dependencies); for libraries all exposed/other modules.\n"
- ++ "\n"
- ++ "The default component is the library itself, or the executable "
- ++ "if that is the only component.\n"
- ++ "\n"
- ++ "Support for loading specific modules is planned but not "
- ++ "implemented yet. For certain scenarios, `" ++ pname
- ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will "
- ++ "not (re)configure and you will have to specify the location of "
- ++ "other modules, if required.\n",
- commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n",
- commandDefaultFlags = commandDefaultFlags parent,
- commandOptions = commandOptions parent,
- commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " v1-repl "
- ++ " The first component in the package\n"
- ++ " " ++ pname ++ " v1-repl foo "
- ++ " A named component (i.e. lib, exe, test suite)\n"
- ++ " " ++ pname ++ " v1-repl --ghc-options=\"-lstdc++\""
- ++ " Specifying flags for interpreter\n"
- }
+replCommand =
+ parent
+ { commandName = "repl"
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "If the current directory contains no package, ignores COMPONENT "
+ ++ "parameters and opens an interactive interpreter session;\n"
+ ++ "\n"
+ ++ "Otherwise, (re)configures with the given or default flags, and "
+ ++ "loads the interpreter with the relevant modules. For executables, "
+ ++ "tests and benchmarks, loads the main module (and its "
+ ++ "dependencies); for libraries all exposed/other modules.\n"
+ ++ "\n"
+ ++ "The default component is the library itself, or the executable "
+ ++ "if that is the only component.\n"
+ ++ "\n"
+ ++ "Support for loading specific modules is planned but not "
+ ++ "implemented yet. For certain scenarios, `"
+ ++ pname
+ ++ " v1-exec -- ghci :l Foo` may be used instead. Note that `v1-exec` will "
+ ++ "not (re)configure and you will have to specify the location of "
+ ++ "other modules, if required.\n"
+ , commandUsage = \pname -> "Usage: " ++ pname ++ " v1-repl [COMPONENT] [FLAGS]\n"
+ , commandDefaultFlags = commandDefaultFlags parent
+ , commandOptions = commandOptions parent
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v1-repl "
+ ++ " The first component in the package\n"
+ ++ " "
+ ++ pname
+ ++ " v1-repl foo "
+ ++ " A named component (i.e. lib, exe, test suite)\n"
+ ++ " "
+ ++ pname
+ ++ " v1-repl --ghc-options=\"-lstdc++\""
+ ++ " Specifying flags for interpreter\n"
+ }
where
parent = Cabal.replCommand defaultProgramDb
-- ------------------------------------------------------------
+
-- * Test command
+
-- ------------------------------------------------------------
testCommand :: CommandUI (BuildFlags, TestFlags)
-testCommand = parent {
- commandName = "test",
- commandDescription = Just $ \pname -> wrapText $
- "If necessary (re)configures with `--enable-tests` flag and builds"
- ++ " the test suite.\n"
- ++ "\n"
- ++ "Remember that the tests' dependencies must be installed if there"
- ++ " are additional ones; e.g. with `" ++ pname
- ++ " v1-install --only-dependencies --enable-tests`.\n"
- ++ "\n"
- ++ "By defining UserHooks in a custom Setup.hs, the package can"
- ++ " define actions to be executed before and after running tests.\n",
- commandUsage = usageAlternatives "v1-test"
- [ "[FLAGS]", "TESTCOMPONENTS [FLAGS]" ],
- commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),
- commandOptions =
- \showOrParseArgs -> liftOptions get1 set1
- (Cabal.buildOptions progDb showOrParseArgs)
- ++
- liftOptions get2 set2
- (commandOptions parent showOrParseArgs)
- }
+testCommand =
+ parent
+ { commandName = "test"
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "If necessary (re)configures with `--enable-tests` flag and builds"
+ ++ " the test suite.\n"
+ ++ "\n"
+ ++ "Remember that the tests' dependencies must be installed if there"
+ ++ " are additional ones; e.g. with `"
+ ++ pname
+ ++ " v1-install --only-dependencies --enable-tests`.\n"
+ ++ "\n"
+ ++ "By defining UserHooks in a custom Setup.hs, the package can"
+ ++ " define actions to be executed before and after running tests.\n"
+ , commandUsage =
+ usageAlternatives
+ "v1-test"
+ ["[FLAGS]", "TESTCOMPONENTS [FLAGS]"]
+ , commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent)
+ , commandOptions =
+ \showOrParseArgs ->
+ liftOptions
+ get1
+ set1
+ (Cabal.buildOptions progDb showOrParseArgs)
+ ++ liftOptions
+ get2
+ set2
+ (commandOptions parent showOrParseArgs)
+ }
where
- get1 (a,_) = a; set1 a (_,b) = (a,b)
- get2 (_,b) = b; set2 b (a,_) = (a,b)
+ get1 (a, _) = a
+ set1 a (_, b) = (a, b)
+ get2 (_, b) = b
+ set2 b (a, _) = (a, b)
parent = Cabal.testCommand
progDb = defaultProgramDb
-- ------------------------------------------------------------
+
-- * Bench command
+
-- ------------------------------------------------------------
benchmarkCommand :: CommandUI (BuildFlags, BenchmarkFlags)
-benchmarkCommand = parent {
- commandName = "bench",
- commandUsage = usageAlternatives "v1-bench"
- [ "[FLAGS]", "BENCHCOMPONENTS [FLAGS]" ],
- commandDescription = Just $ \pname -> wrapText $
- "If necessary (re)configures with `--enable-benchmarks` flag and"
- ++ " builds the benchmarks.\n"
- ++ "\n"
- ++ "Remember that the benchmarks' dependencies must be installed if"
- ++ " there are additional ones; e.g. with `" ++ pname
- ++ " v1-install --only-dependencies --enable-benchmarks`.\n"
- ++ "\n"
- ++ "By defining UserHooks in a custom Setup.hs, the package can"
- ++ " define actions to be executed before and after running"
- ++ " benchmarks.\n",
- commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent),
- commandOptions =
- \showOrParseArgs -> liftOptions get1 set1
- (Cabal.buildOptions progDb showOrParseArgs)
- ++
- liftOptions get2 set2
- (commandOptions parent showOrParseArgs)
- }
+benchmarkCommand =
+ parent
+ { commandName = "bench"
+ , commandUsage =
+ usageAlternatives
+ "v1-bench"
+ ["[FLAGS]", "BENCHCOMPONENTS [FLAGS]"]
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "If necessary (re)configures with `--enable-benchmarks` flag and"
+ ++ " builds the benchmarks.\n"
+ ++ "\n"
+ ++ "Remember that the benchmarks' dependencies must be installed if"
+ ++ " there are additional ones; e.g. with `"
+ ++ pname
+ ++ " v1-install --only-dependencies --enable-benchmarks`.\n"
+ ++ "\n"
+ ++ "By defining UserHooks in a custom Setup.hs, the package can"
+ ++ " define actions to be executed before and after running"
+ ++ " benchmarks.\n"
+ , commandDefaultFlags = (Cabal.defaultBuildFlags, commandDefaultFlags parent)
+ , commandOptions =
+ \showOrParseArgs ->
+ liftOptions
+ get1
+ set1
+ (Cabal.buildOptions progDb showOrParseArgs)
+ ++ liftOptions
+ get2
+ set2
+ (commandOptions parent showOrParseArgs)
+ }
where
- get1 (a,_) = a; set1 a (_,b) = (a,b)
- get2 (_,b) = b; set2 b (a,_) = (a,b)
+ get1 (a, _) = a
+ set1 a (_, b) = (a, b)
+ get2 (_, b) = b
+ set2 b (a, _) = (a, b)
parent = Cabal.benchmarkCommand
progDb = defaultProgramDb
-- ------------------------------------------------------------
+
-- * Fetch command
+
-- ------------------------------------------------------------
-data FetchFlags = FetchFlags {
--- fetchOutput :: Flag FilePath,
- fetchDeps :: Flag Bool,
- fetchDryRun :: Flag Bool,
- fetchSolver :: Flag PreSolver,
- fetchMaxBackjumps :: Flag Int,
- fetchReorderGoals :: Flag ReorderGoals,
- fetchCountConflicts :: Flag CountConflicts,
- fetchFineGrainedConflicts :: Flag FineGrainedConflicts,
- fetchMinimizeConflictSet :: Flag MinimizeConflictSet,
- fetchIndependentGoals :: Flag IndependentGoals,
- fetchPreferOldest :: Flag PreferOldest,
- fetchShadowPkgs :: Flag ShadowPkgs,
- fetchStrongFlags :: Flag StrongFlags,
- fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls,
- fetchOnlyConstrained :: Flag OnlyConstrained,
- fetchTests :: Flag Bool,
- fetchBenchmarks :: Flag Bool,
- fetchVerbosity :: Flag Verbosity
- }
+data FetchFlags = FetchFlags
+ { -- fetchOutput :: Flag FilePath,
+ fetchDeps :: Flag Bool
+ , fetchDryRun :: Flag Bool
+ , fetchSolver :: Flag PreSolver
+ , fetchMaxBackjumps :: Flag Int
+ , fetchReorderGoals :: Flag ReorderGoals
+ , fetchCountConflicts :: Flag CountConflicts
+ , fetchFineGrainedConflicts :: Flag FineGrainedConflicts
+ , fetchMinimizeConflictSet :: Flag MinimizeConflictSet
+ , fetchIndependentGoals :: Flag IndependentGoals
+ , fetchPreferOldest :: Flag PreferOldest
+ , fetchShadowPkgs :: Flag ShadowPkgs
+ , fetchStrongFlags :: Flag StrongFlags
+ , fetchAllowBootLibInstalls :: Flag AllowBootLibInstalls
+ , fetchOnlyConstrained :: Flag OnlyConstrained
+ , fetchTests :: Flag Bool
+ , fetchBenchmarks :: Flag Bool
+ , fetchVerbosity :: Flag Verbosity
+ }
defaultFetchFlags :: FetchFlags
-defaultFetchFlags = FetchFlags {
--- fetchOutput = mempty,
- fetchDeps = toFlag True,
- fetchDryRun = toFlag False,
- fetchSolver = Flag defaultSolver,
- fetchMaxBackjumps = Flag defaultMaxBackjumps,
- fetchReorderGoals = Flag (ReorderGoals False),
- fetchCountConflicts = Flag (CountConflicts True),
- fetchFineGrainedConflicts = Flag (FineGrainedConflicts True),
- fetchMinimizeConflictSet = Flag (MinimizeConflictSet False),
- fetchIndependentGoals = Flag (IndependentGoals False),
- fetchPreferOldest = Flag (PreferOldest False),
- fetchShadowPkgs = Flag (ShadowPkgs False),
- fetchStrongFlags = Flag (StrongFlags False),
- fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False),
- fetchOnlyConstrained = Flag OnlyConstrainedNone,
- fetchTests = toFlag False,
- fetchBenchmarks = toFlag False,
- fetchVerbosity = toFlag normal
- }
+defaultFetchFlags =
+ FetchFlags
+ { -- fetchOutput = mempty,
+ fetchDeps = toFlag True
+ , fetchDryRun = toFlag False
+ , fetchSolver = Flag defaultSolver
+ , fetchMaxBackjumps = Flag defaultMaxBackjumps
+ , fetchReorderGoals = Flag (ReorderGoals False)
+ , fetchCountConflicts = Flag (CountConflicts True)
+ , fetchFineGrainedConflicts = Flag (FineGrainedConflicts True)
+ , fetchMinimizeConflictSet = Flag (MinimizeConflictSet False)
+ , fetchIndependentGoals = Flag (IndependentGoals False)
+ , fetchPreferOldest = Flag (PreferOldest False)
+ , fetchShadowPkgs = Flag (ShadowPkgs False)
+ , fetchStrongFlags = Flag (StrongFlags False)
+ , fetchAllowBootLibInstalls = Flag (AllowBootLibInstalls False)
+ , fetchOnlyConstrained = Flag OnlyConstrainedNone
+ , fetchTests = toFlag False
+ , fetchBenchmarks = toFlag False
+ , fetchVerbosity = toFlag normal
+ }
fetchCommand :: CommandUI FetchFlags
-fetchCommand = CommandUI {
- commandName = "fetch",
- commandSynopsis = "Downloads packages for later installation.",
- commandUsage = usageAlternatives "fetch" [ "[FLAGS] PACKAGES"
- ],
- commandDescription = Just $ \_ ->
- "Note that it currently is not possible to fetch the dependencies for a\n"
- ++ "package in the current directory.\n",
- commandNotes = Nothing,
- commandDefaultFlags = defaultFetchFlags,
- commandOptions = \ showOrParseArgs -> [
- optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })
-
--- , option "o" ["output"]
--- "Put the package(s) somewhere specific rather than the usual cache."
--- fetchOutput (\v flags -> flags { fetchOutput = v })
--- (reqArgFlag "PATH")
-
- , option [] ["dependencies", "deps"]
- "Resolve and fetch dependencies (default)"
- fetchDeps (\v flags -> flags { fetchDeps = v })
- trueArg
-
- , option [] ["no-dependencies", "no-deps"]
- "Ignore dependencies"
- fetchDeps (\v flags -> flags { fetchDeps = v })
- falseArg
-
- , option [] ["dry-run"]
- "Do not install anything, only print what would be installed."
- fetchDryRun (\v flags -> flags { fetchDryRun = v })
- trueArg
-
- , option "" ["tests"]
- "dependency checking and compilation for test suites listed in the package description file."
- fetchTests (\v flags -> flags { fetchTests = v })
- (boolOpt [] [])
-
- , option "" ["benchmarks"]
- "dependency checking and compilation for benchmarks listed in the package description file."
- fetchBenchmarks (\v flags -> flags { fetchBenchmarks = v })
- (boolOpt [] [])
-
- ] ++
-
- optionSolver fetchSolver (\v flags -> flags { fetchSolver = v }) :
- optionSolverFlags showOrParseArgs
- fetchMaxBackjumps (\v flags -> flags { fetchMaxBackjumps = v })
- fetchReorderGoals (\v flags -> flags { fetchReorderGoals = v })
- fetchCountConflicts (\v flags -> flags { fetchCountConflicts = v })
- fetchFineGrainedConflicts (\v flags -> flags { fetchFineGrainedConflicts = v })
- fetchMinimizeConflictSet (\v flags -> flags { fetchMinimizeConflictSet = v })
- fetchIndependentGoals (\v flags -> flags { fetchIndependentGoals = v })
- fetchPreferOldest (\v flags -> flags { fetchPreferOldest = v })
- fetchShadowPkgs (\v flags -> flags { fetchShadowPkgs = v })
- fetchStrongFlags (\v flags -> flags { fetchStrongFlags = v })
- fetchAllowBootLibInstalls (\v flags -> flags { fetchAllowBootLibInstalls = v })
- fetchOnlyConstrained (\v flags -> flags { fetchOnlyConstrained = v })
-
- }
+fetchCommand =
+ CommandUI
+ { commandName = "fetch"
+ , commandSynopsis = "Downloads packages for later installation."
+ , commandUsage =
+ usageAlternatives
+ "fetch"
+ [ "[FLAGS] PACKAGES"
+ ]
+ , commandDescription = Just $ \_ ->
+ "Note that it currently is not possible to fetch the dependencies for a\n"
+ ++ "package in the current directory.\n"
+ , commandNotes = Nothing
+ , commandDefaultFlags = defaultFetchFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity fetchVerbosity (\v flags -> flags{fetchVerbosity = v})
+ , -- , option "o" ["output"]
+ -- "Put the package(s) somewhere specific rather than the usual cache."
+ -- fetchOutput (\v flags -> flags { fetchOutput = v })
+ -- (reqArgFlag "PATH")
+
+ option
+ []
+ ["dependencies", "deps"]
+ "Resolve and fetch dependencies (default)"
+ fetchDeps
+ (\v flags -> flags{fetchDeps = v})
+ trueArg
+ , option
+ []
+ ["no-dependencies", "no-deps"]
+ "Ignore dependencies"
+ fetchDeps
+ (\v flags -> flags{fetchDeps = v})
+ falseArg
+ , option
+ []
+ ["dry-run"]
+ "Do not install anything, only print what would be installed."
+ fetchDryRun
+ (\v flags -> flags{fetchDryRun = v})
+ trueArg
+ , option
+ ""
+ ["tests"]
+ "dependency checking and compilation for test suites listed in the package description file."
+ fetchTests
+ (\v flags -> flags{fetchTests = v})
+ (boolOpt [] [])
+ , option
+ ""
+ ["benchmarks"]
+ "dependency checking and compilation for benchmarks listed in the package description file."
+ fetchBenchmarks
+ (\v flags -> flags{fetchBenchmarks = v})
+ (boolOpt [] [])
+ ]
+ ++ optionSolver fetchSolver (\v flags -> flags{fetchSolver = v})
+ : optionSolverFlags
+ showOrParseArgs
+ fetchMaxBackjumps
+ (\v flags -> flags{fetchMaxBackjumps = v})
+ fetchReorderGoals
+ (\v flags -> flags{fetchReorderGoals = v})
+ fetchCountConflicts
+ (\v flags -> flags{fetchCountConflicts = v})
+ fetchFineGrainedConflicts
+ (\v flags -> flags{fetchFineGrainedConflicts = v})
+ fetchMinimizeConflictSet
+ (\v flags -> flags{fetchMinimizeConflictSet = v})
+ fetchIndependentGoals
+ (\v flags -> flags{fetchIndependentGoals = v})
+ fetchPreferOldest
+ (\v flags -> flags{fetchPreferOldest = v})
+ fetchShadowPkgs
+ (\v flags -> flags{fetchShadowPkgs = v})
+ fetchStrongFlags
+ (\v flags -> flags{fetchStrongFlags = v})
+ fetchAllowBootLibInstalls
+ (\v flags -> flags{fetchAllowBootLibInstalls = v})
+ fetchOnlyConstrained
+ (\v flags -> flags{fetchOnlyConstrained = v})
+ }
-- ------------------------------------------------------------
+
-- * Freeze command
+
-- ------------------------------------------------------------
-data FreezeFlags = FreezeFlags {
- freezeDryRun :: Flag Bool,
- freezeTests :: Flag Bool,
- freezeBenchmarks :: Flag Bool,
- freezeSolver :: Flag PreSolver,
- freezeMaxBackjumps :: Flag Int,
- freezeReorderGoals :: Flag ReorderGoals,
- freezeCountConflicts :: Flag CountConflicts,
- freezeFineGrainedConflicts :: Flag FineGrainedConflicts,
- freezeMinimizeConflictSet :: Flag MinimizeConflictSet,
- freezeIndependentGoals :: Flag IndependentGoals,
- freezePreferOldest :: Flag PreferOldest,
- freezeShadowPkgs :: Flag ShadowPkgs,
- freezeStrongFlags :: Flag StrongFlags,
- freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls,
- freezeOnlyConstrained :: Flag OnlyConstrained,
- freezeVerbosity :: Flag Verbosity
- }
+data FreezeFlags = FreezeFlags
+ { freezeDryRun :: Flag Bool
+ , freezeTests :: Flag Bool
+ , freezeBenchmarks :: Flag Bool
+ , freezeSolver :: Flag PreSolver
+ , freezeMaxBackjumps :: Flag Int
+ , freezeReorderGoals :: Flag ReorderGoals
+ , freezeCountConflicts :: Flag CountConflicts
+ , freezeFineGrainedConflicts :: Flag FineGrainedConflicts
+ , freezeMinimizeConflictSet :: Flag MinimizeConflictSet
+ , freezeIndependentGoals :: Flag IndependentGoals
+ , freezePreferOldest :: Flag PreferOldest
+ , freezeShadowPkgs :: Flag ShadowPkgs
+ , freezeStrongFlags :: Flag StrongFlags
+ , freezeAllowBootLibInstalls :: Flag AllowBootLibInstalls
+ , freezeOnlyConstrained :: Flag OnlyConstrained
+ , freezeVerbosity :: Flag Verbosity
+ }
defaultFreezeFlags :: FreezeFlags
-defaultFreezeFlags = FreezeFlags {
- freezeDryRun = toFlag False,
- freezeTests = toFlag False,
- freezeBenchmarks = toFlag False,
- freezeSolver = Flag defaultSolver,
- freezeMaxBackjumps = Flag defaultMaxBackjumps,
- freezeReorderGoals = Flag (ReorderGoals False),
- freezeCountConflicts = Flag (CountConflicts True),
- freezeFineGrainedConflicts = Flag (FineGrainedConflicts True),
- freezeMinimizeConflictSet = Flag (MinimizeConflictSet False),
- freezeIndependentGoals = Flag (IndependentGoals False),
- freezePreferOldest = Flag (PreferOldest False),
- freezeShadowPkgs = Flag (ShadowPkgs False),
- freezeStrongFlags = Flag (StrongFlags False),
- freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False),
- freezeOnlyConstrained = Flag OnlyConstrainedNone,
- freezeVerbosity = toFlag normal
- }
+defaultFreezeFlags =
+ FreezeFlags
+ { freezeDryRun = toFlag False
+ , freezeTests = toFlag False
+ , freezeBenchmarks = toFlag False
+ , freezeSolver = Flag defaultSolver
+ , freezeMaxBackjumps = Flag defaultMaxBackjumps
+ , freezeReorderGoals = Flag (ReorderGoals False)
+ , freezeCountConflicts = Flag (CountConflicts True)
+ , freezeFineGrainedConflicts = Flag (FineGrainedConflicts True)
+ , freezeMinimizeConflictSet = Flag (MinimizeConflictSet False)
+ , freezeIndependentGoals = Flag (IndependentGoals False)
+ , freezePreferOldest = Flag (PreferOldest False)
+ , freezeShadowPkgs = Flag (ShadowPkgs False)
+ , freezeStrongFlags = Flag (StrongFlags False)
+ , freezeAllowBootLibInstalls = Flag (AllowBootLibInstalls False)
+ , freezeOnlyConstrained = Flag OnlyConstrainedNone
+ , freezeVerbosity = toFlag normal
+ }
freezeCommand :: CommandUI FreezeFlags
-freezeCommand = CommandUI {
- commandName = "freeze",
- commandSynopsis = "Freeze dependencies.",
- commandDescription = Just $ \_ -> wrapText $
- "Calculates a valid set of dependencies and their exact versions. "
- ++ "If successful, saves the result to the file `cabal.config`.\n"
- ++ "\n"
- ++ "The package versions specified in `cabal.config` will be used for "
- ++ "any future installs.\n"
- ++ "\n"
- ++ "An existing `cabal.config` is ignored and overwritten.\n",
- commandNotes = Nothing,
- commandUsage = usageFlags "freeze",
- commandDefaultFlags = defaultFreezeFlags,
- commandOptions = \ showOrParseArgs -> [
- optionVerbosity freezeVerbosity
- (\v flags -> flags { freezeVerbosity = v })
-
- , option [] ["dry-run"]
- "Do not freeze anything, only print what would be frozen"
- freezeDryRun (\v flags -> flags { freezeDryRun = v })
- trueArg
-
- , option [] ["tests"]
- ("freezing of the dependencies of any tests suites "
- ++ "in the package description file.")
- freezeTests (\v flags -> flags { freezeTests = v })
- (boolOpt [] [])
-
- , option [] ["benchmarks"]
- ("freezing of the dependencies of any benchmarks suites "
- ++ "in the package description file.")
- freezeBenchmarks (\v flags -> flags { freezeBenchmarks = v })
- (boolOpt [] [])
-
- ] ++
-
- optionSolver
- freezeSolver (\v flags -> flags { freezeSolver = v }):
- optionSolverFlags showOrParseArgs
- freezeMaxBackjumps (\v flags -> flags { freezeMaxBackjumps = v })
- freezeReorderGoals (\v flags -> flags { freezeReorderGoals = v })
- freezeCountConflicts (\v flags -> flags { freezeCountConflicts = v })
- freezeFineGrainedConflicts (\v flags -> flags { freezeFineGrainedConflicts = v })
- freezeMinimizeConflictSet (\v flags -> flags { freezeMinimizeConflictSet = v })
- freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })
- freezePreferOldest (\v flags -> flags { freezePreferOldest = v })
- freezeShadowPkgs (\v flags -> flags { freezeShadowPkgs = v })
- freezeStrongFlags (\v flags -> flags { freezeStrongFlags = v })
- freezeAllowBootLibInstalls (\v flags -> flags { freezeAllowBootLibInstalls = v })
- freezeOnlyConstrained (\v flags -> flags { freezeOnlyConstrained = v })
-
- }
+freezeCommand =
+ CommandUI
+ { commandName = "freeze"
+ , commandSynopsis = "Freeze dependencies."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Calculates a valid set of dependencies and their exact versions. "
+ ++ "If successful, saves the result to the file `cabal.config`.\n"
+ ++ "\n"
+ ++ "The package versions specified in `cabal.config` will be used for "
+ ++ "any future installs.\n"
+ ++ "\n"
+ ++ "An existing `cabal.config` is ignored and overwritten.\n"
+ , commandNotes = Nothing
+ , commandUsage = usageFlags "freeze"
+ , commandDefaultFlags = defaultFreezeFlags
+ , commandOptions = \showOrParseArgs ->
+ [ optionVerbosity
+ freezeVerbosity
+ (\v flags -> flags{freezeVerbosity = v})
+ , option
+ []
+ ["dry-run"]
+ "Do not freeze anything, only print what would be frozen"
+ freezeDryRun
+ (\v flags -> flags{freezeDryRun = v})
+ trueArg
+ , option
+ []
+ ["tests"]
+ ( "freezing of the dependencies of any tests suites "
+ ++ "in the package description file."
+ )
+ freezeTests
+ (\v flags -> flags{freezeTests = v})
+ (boolOpt [] [])
+ , option
+ []
+ ["benchmarks"]
+ ( "freezing of the dependencies of any benchmarks suites "
+ ++ "in the package description file."
+ )
+ freezeBenchmarks
+ (\v flags -> flags{freezeBenchmarks = v})
+ (boolOpt [] [])
+ ]
+ ++ optionSolver
+ freezeSolver
+ (\v flags -> flags{freezeSolver = v})
+ : optionSolverFlags
+ showOrParseArgs
+ freezeMaxBackjumps
+ (\v flags -> flags{freezeMaxBackjumps = v})
+ freezeReorderGoals
+ (\v flags -> flags{freezeReorderGoals = v})
+ freezeCountConflicts
+ (\v flags -> flags{freezeCountConflicts = v})
+ freezeFineGrainedConflicts
+ (\v flags -> flags{freezeFineGrainedConflicts = v})
+ freezeMinimizeConflictSet
+ (\v flags -> flags{freezeMinimizeConflictSet = v})
+ freezeIndependentGoals
+ (\v flags -> flags{freezeIndependentGoals = v})
+ freezePreferOldest
+ (\v flags -> flags{freezePreferOldest = v})
+ freezeShadowPkgs
+ (\v flags -> flags{freezeShadowPkgs = v})
+ freezeStrongFlags
+ (\v flags -> flags{freezeStrongFlags = v})
+ freezeAllowBootLibInstalls
+ (\v flags -> flags{freezeAllowBootLibInstalls = v})
+ freezeOnlyConstrained
+ (\v flags -> flags{freezeOnlyConstrained = v})
+ }
-- ------------------------------------------------------------
+
-- * 'gen-bounds' command
+
-- ------------------------------------------------------------
genBoundsCommand :: CommandUI FreezeFlags
-genBoundsCommand = CommandUI {
- commandName = "gen-bounds",
- commandSynopsis = "Generate dependency bounds.",
- commandDescription = Just $ \_ -> wrapText $
- "Generates bounds for all dependencies that do not currently have them. "
- ++ "Generated bounds are printed to stdout. "
- ++ "You can then paste them into your .cabal file.\n"
- ++ "\n",
- commandNotes = Nothing,
- commandUsage = usageFlags "gen-bounds",
- commandDefaultFlags = defaultFreezeFlags,
- commandOptions = \ _ -> [
- optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })
- ]
- }
+genBoundsCommand =
+ CommandUI
+ { commandName = "gen-bounds"
+ , commandSynopsis = "Generate dependency bounds."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Generates bounds for all dependencies that do not currently have them. "
+ ++ "Generated bounds are printed to stdout. "
+ ++ "You can then paste them into your .cabal file.\n"
+ ++ "\n"
+ , commandNotes = Nothing
+ , commandUsage = usageFlags "gen-bounds"
+ , commandDefaultFlags = defaultFreezeFlags
+ , commandOptions = \_ ->
+ [ optionVerbosity freezeVerbosity (\v flags -> flags{freezeVerbosity = v})
+ ]
+ }
-- ------------------------------------------------------------
+
-- * Update command
+
-- ------------------------------------------------------------
-data UpdateFlags
- = UpdateFlags {
- updateVerbosity :: Flag Verbosity,
- updateIndexState :: Flag TotalIndexState
- } deriving Generic
+data UpdateFlags = UpdateFlags
+ { updateVerbosity :: Flag Verbosity
+ , updateIndexState :: Flag TotalIndexState
+ }
+ deriving (Generic)
defaultUpdateFlags :: UpdateFlags
-defaultUpdateFlags
- = UpdateFlags {
- updateVerbosity = toFlag normal,
- updateIndexState = toFlag headTotalIndexState
+defaultUpdateFlags =
+ UpdateFlags
+ { updateVerbosity = toFlag normal
+ , updateIndexState = toFlag headTotalIndexState
}
-- ------------------------------------------------------------
+
-- * Other commands
+
-- ------------------------------------------------------------
cleanCommand :: CommandUI CleanFlags
-cleanCommand = Cabal.cleanCommand
- { commandUsage = \pname ->
- "Usage: " ++ pname ++ " v1-clean [FLAGS]\n"
- }
+cleanCommand =
+ Cabal.cleanCommand
+ { commandUsage = \pname ->
+ "Usage: " ++ pname ++ " v1-clean [FLAGS]\n"
+ }
-checkCommand :: CommandUI (Flag Verbosity)
-checkCommand = CommandUI {
- commandName = "check",
- commandSynopsis = "Check the package for common mistakes.",
- commandDescription = Just $ \_ -> wrapText $
- "Expects a .cabal package file in the current directory.\n"
- ++ "\n"
- ++ "The checks correspond to the requirements to packages on Hackage. "
- ++ "If no errors and warnings are reported, Hackage should accept the "
- ++ "package. If errors are present, `check` exits with 1 and Hackage "
- ++ "will refuse the package.\n",
- commandNotes = Nothing,
- commandUsage = usageFlags "check",
- commandDefaultFlags = toFlag normal,
- commandOptions = \_ -> [optionVerbosity id const]
- }
+checkCommand :: CommandUI (Flag Verbosity)
+checkCommand =
+ CommandUI
+ { commandName = "check"
+ , commandSynopsis = "Check the package for common mistakes."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Expects a .cabal package file in the current directory.\n"
+ ++ "\n"
+ ++ "The checks correspond to the requirements to packages on Hackage. "
+ ++ "If no errors and warnings are reported, Hackage should accept the "
+ ++ "package. If errors are present, `check` exits with 1 and Hackage "
+ ++ "will refuse the package.\n"
+ , commandNotes = Nothing
+ , commandUsage = usageFlags "check"
+ , commandDefaultFlags = toFlag normal
+ , commandOptions = \_ -> [optionVerbosity id const]
+ }
-formatCommand :: CommandUI (Flag Verbosity)
-formatCommand = CommandUI {
- commandName = "format",
- commandSynopsis = "Reformat the .cabal file using the standard style.",
- commandDescription = Nothing,
- commandNotes = Nothing,
- commandUsage = usageAlternatives "format" ["[FILE]"],
- commandDefaultFlags = toFlag normal,
- commandOptions = \_ -> []
- }
+formatCommand :: CommandUI (Flag Verbosity)
+formatCommand =
+ CommandUI
+ { commandName = "format"
+ , commandSynopsis = "Reformat the .cabal file using the standard style."
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = usageAlternatives "format" ["[FILE]"]
+ , commandDefaultFlags = toFlag normal
+ , commandOptions = \_ -> []
+ }
manpageCommand :: CommandUI ManpageFlags
-manpageCommand = CommandUI {
- commandName = "man",
- commandSynopsis = "Outputs manpage source.",
- commandDescription = Just $ \_ ->
- "Output manpage source to STDOUT.\n",
- commandNotes = Nothing,
- commandUsage = usageFlags "man",
- commandDefaultFlags = defaultManpageFlags,
- commandOptions = manpageOptions
- }
+manpageCommand =
+ CommandUI
+ { commandName = "man"
+ , commandSynopsis = "Outputs manpage source."
+ , commandDescription = Just $ \_ ->
+ "Output manpage source to STDOUT.\n"
+ , commandNotes = Nothing
+ , commandUsage = usageFlags "man"
+ , commandDefaultFlags = defaultManpageFlags
+ , commandOptions = manpageOptions
+ }
runCommand :: CommandUI BuildFlags
-runCommand = CommandUI {
- commandName = "run",
- commandSynopsis = "Builds and runs an executable.",
- commandDescription = Just $ \pname -> wrapText $
- "Builds and then runs the specified executable. If no executable is "
- ++ "specified, but the package contains just one executable, that one "
- ++ "is built and executed.\n"
- ++ "\n"
- ++ "Use `" ++ pname ++ " v1-test --show-details=streaming` to run a "
- ++ "test-suite and get its full output.\n",
- commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " v1-run\n"
- ++ " Run the only executable in the current package;\n"
- ++ " " ++ pname ++ " v1-run foo -- --fooflag\n"
- ++ " Works similar to `./foo --fooflag`.\n",
- commandUsage = usageAlternatives "v1-run"
- ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"],
- commandDefaultFlags = mempty,
- commandOptions = commandOptions parent
- }
+runCommand =
+ CommandUI
+ { commandName = "run"
+ , commandSynopsis = "Builds and runs an executable."
+ , commandDescription = Just $ \pname ->
+ wrapText $
+ "Builds and then runs the specified executable. If no executable is "
+ ++ "specified, but the package contains just one executable, that one "
+ ++ "is built and executed.\n"
+ ++ "\n"
+ ++ "Use `"
+ ++ pname
+ ++ " v1-test --show-details=streaming` to run a "
+ ++ "test-suite and get its full output.\n"
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v1-run\n"
+ ++ " Run the only executable in the current package;\n"
+ ++ " "
+ ++ pname
+ ++ " v1-run foo -- --fooflag\n"
+ ++ " Works similar to `./foo --fooflag`.\n"
+ , commandUsage =
+ usageAlternatives
+ "v1-run"
+ ["[FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]"]
+ , commandDefaultFlags = mempty
+ , commandOptions = commandOptions parent
+ }
where
parent = Cabal.buildCommand defaultProgramDb
-- ------------------------------------------------------------
+
-- * Report flags
+
-- ------------------------------------------------------------
-data ReportFlags = ReportFlags {
- reportUsername :: Flag Username,
- reportPassword :: Flag Password,
- reportVerbosity :: Flag Verbosity
- } deriving Generic
+data ReportFlags = ReportFlags
+ { reportUsername :: Flag Username
+ , reportPassword :: Flag Password
+ , reportVerbosity :: Flag Verbosity
+ }
+ deriving (Generic)
defaultReportFlags :: ReportFlags
-defaultReportFlags = ReportFlags {
- reportUsername = mempty,
- reportPassword = mempty,
- reportVerbosity = toFlag normal
- }
+defaultReportFlags =
+ ReportFlags
+ { reportUsername = mempty
+ , reportPassword = mempty
+ , reportVerbosity = toFlag normal
+ }
reportCommand :: CommandUI ReportFlags
-reportCommand = CommandUI {
- commandName = "report",
- commandSynopsis = "Upload build reports to a remote server.",
- commandDescription = Nothing,
- commandNotes = Just $ \_ ->
- "You can store your Hackage login in the ~/.config/cabal/config file\n",
- commandUsage = usageAlternatives "report" ["[FLAGS]"],
- commandDefaultFlags = defaultReportFlags,
- commandOptions = \_ ->
- [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })
-
- ,option ['u'] ["username"]
- "Hackage username."
- reportUsername (\v flags -> flags { reportUsername = v })
- (reqArg' "USERNAME" (toFlag . Username)
- (flagToList . fmap unUsername))
-
- ,option ['p'] ["password"]
- "Hackage password."
- reportPassword (\v flags -> flags { reportPassword = v })
- (reqArg' "PASSWORD" (toFlag . Password)
- (flagToList . fmap unPassword))
- ]
- }
+reportCommand =
+ CommandUI
+ { commandName = "report"
+ , commandSynopsis = "Upload build reports to a remote server."
+ , commandDescription = Nothing
+ , commandNotes = Just $ \_ ->
+ "You can store your Hackage login in the ~/.config/cabal/config file\n"
+ , commandUsage = usageAlternatives "report" ["[FLAGS]"]
+ , commandDefaultFlags = defaultReportFlags
+ , commandOptions = \_ ->
+ [ optionVerbosity reportVerbosity (\v flags -> flags{reportVerbosity = v})
+ , option
+ ['u']
+ ["username"]
+ "Hackage username."
+ reportUsername
+ (\v flags -> flags{reportUsername = v})
+ ( reqArg'
+ "USERNAME"
+ (toFlag . Username)
+ (flagToList . fmap unUsername)
+ )
+ , option
+ ['p']
+ ["password"]
+ "Hackage password."
+ reportPassword
+ (\v flags -> flags{reportPassword = v})
+ ( reqArg'
+ "PASSWORD"
+ (toFlag . Password)
+ (flagToList . fmap unPassword)
+ )
+ ]
+ }
instance Monoid ReportFlags where
mempty = gmempty
@@ -1309,85 +1693,116 @@ instance Semigroup ReportFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * Get flags
+
-- ------------------------------------------------------------
-data GetFlags = GetFlags {
- getDestDir :: Flag FilePath,
- getOnlyPkgDescr :: Flag Bool,
- getPristine :: Flag Bool,
- getIndexState :: Flag TotalIndexState,
- getActiveRepos :: Flag ActiveRepos,
- getSourceRepository :: Flag (Maybe RepoKind),
- getVerbosity :: Flag Verbosity
- } deriving Generic
+data GetFlags = GetFlags
+ { getDestDir :: Flag FilePath
+ , getOnlyPkgDescr :: Flag Bool
+ , getPristine :: Flag Bool
+ , getIndexState :: Flag TotalIndexState
+ , getActiveRepos :: Flag ActiveRepos
+ , getSourceRepository :: Flag (Maybe RepoKind)
+ , getVerbosity :: Flag Verbosity
+ }
+ deriving (Generic)
defaultGetFlags :: GetFlags
-defaultGetFlags = GetFlags {
- getDestDir = mempty,
- getOnlyPkgDescr = mempty,
- getPristine = mempty,
- getIndexState = mempty,
- getActiveRepos = mempty,
- getSourceRepository = mempty,
- getVerbosity = toFlag normal
- }
+defaultGetFlags =
+ GetFlags
+ { getDestDir = mempty
+ , getOnlyPkgDescr = mempty
+ , getPristine = mempty
+ , getIndexState = mempty
+ , getActiveRepos = mempty
+ , getSourceRepository = mempty
+ , getVerbosity = toFlag normal
+ }
getCommand :: CommandUI GetFlags
-getCommand = CommandUI {
- commandName = "get",
- commandSynopsis = "Download/Extract a package's source code (repository).",
- commandDescription = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand,
- commandNotes = Just $ \pname -> unlines $ notesOfGetCommand "get" pname,
- commandUsage = usagePackages "get",
- commandDefaultFlags = defaultGetFlags,
- commandOptions = \_ -> [
- optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })
-
- ,option "d" ["destdir"]
- "Where to place the package source, defaults to the current directory."
- getDestDir (\v flags -> flags { getDestDir = v })
- (reqArgFlag "PATH")
-
- ,option "s" ["source-repository"]
- "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
- getSourceRepository (\v flags -> flags { getSourceRepository = v })
- (optArg "[head|this|...]" (parsecToReadE (const "invalid source-repository")
- (fmap (toFlag . Just) parsec))
- (Flag Nothing)
- (map (fmap show) . flagToList))
-
- , option [] ["index-state"]
- ("Use source package index state as it existed at a previous time. " ++
- "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++
- "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). " ++
- "This determines which package versions are available as well as " ++
- ".cabal file revision is selected (unless --pristine is used).")
- getIndexState (\v flags -> flags { getIndexState = v })
- (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++
- "unix-timestamps (e.g. '@1474732068'), " ++
- "a ISO8601 UTC timestamp " ++
- "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option [] ["only-package-description"]
- "Unpack only the package description file."
- getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v })
- trueArg
-
- , option [] ["package-description-only"]
- "A synonym for --only-package-description."
- getOnlyPkgDescr (\v flags -> flags { getOnlyPkgDescr = v })
- trueArg
-
- , option [] ["pristine"]
- ("Unpack the original pristine tarball, rather than updating the "
- ++ ".cabal file with the latest revision from the package archive.")
- getPristine (\v flags -> flags { getPristine = v })
- trueArg
- ]
- }
+getCommand =
+ CommandUI
+ { commandName = "get"
+ , commandSynopsis = "Download/Extract a package's source code (repository)."
+ , commandDescription = Just $ \_ -> wrapText $ unlines descriptionOfGetCommand
+ , commandNotes = Just $ \pname -> unlines $ notesOfGetCommand "get" pname
+ , commandUsage = usagePackages "get"
+ , commandDefaultFlags = defaultGetFlags
+ , commandOptions = \_ ->
+ [ optionVerbosity getVerbosity (\v flags -> flags{getVerbosity = v})
+ , option
+ "d"
+ ["destdir"]
+ "Where to place the package source, defaults to the current directory."
+ getDestDir
+ (\v flags -> flags{getDestDir = v})
+ (reqArgFlag "PATH")
+ , option
+ "s"
+ ["source-repository"]
+ "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."
+ getSourceRepository
+ (\v flags -> flags{getSourceRepository = v})
+ ( optArg
+ "[head|this|...]"
+ ( parsecToReadE
+ (const "invalid source-repository")
+ (fmap (toFlag . Just) parsec)
+ )
+ (Flag Nothing)
+ (map (fmap show) . flagToList)
+ )
+ , option
+ []
+ ["index-state"]
+ ( "Use source package index state as it existed at a previous time. "
+ ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps "
+ ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD'). "
+ ++ "This determines which package versions are available as well as "
+ ++ ".cabal file revision is selected (unless --pristine is used)."
+ )
+ getIndexState
+ (\v flags -> flags{getIndexState = v})
+ ( reqArg
+ "STATE"
+ ( parsecToReadE
+ ( const $
+ "index-state must be a "
+ ++ "unix-timestamps (e.g. '@1474732068'), "
+ ++ "a ISO8601 UTC timestamp "
+ ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'"
+ )
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ []
+ ["only-package-description"]
+ "Unpack only the package description file."
+ getOnlyPkgDescr
+ (\v flags -> flags{getOnlyPkgDescr = v})
+ trueArg
+ , option
+ []
+ ["package-description-only"]
+ "A synonym for --only-package-description."
+ getOnlyPkgDescr
+ (\v flags -> flags{getOnlyPkgDescr = v})
+ trueArg
+ , option
+ []
+ ["pristine"]
+ ( "Unpack the original pristine tarball, rather than updating the "
+ ++ ".cabal file with the latest revision from the package archive."
+ )
+ getPristine
+ (\v flags -> flags{getPristine = v})
+ trueArg
+ ]
+ }
-- | List of lines describing command @get@.
descriptionOfGetCommand :: [String]
@@ -1399,28 +1814,33 @@ descriptionOfGetCommand =
-- | Notes for the command @get@.
notesOfGetCommand
- :: String -- ^ Either @"get"@ or @"unpack"@.
- -> String -- ^ E.g. @"cabal"@.
- -> [String] -- ^ List of lines.
+ :: String
+ -- ^ Either @"get"@ or @"unpack"@.
+ -> String
+ -- ^ E.g. @"cabal"@.
+ -> [String]
+ -- ^ List of lines.
notesOfGetCommand cmd pname =
[ "Examples:"
- , " " ++ unwords [ pname, cmd, "hlint" ]
+ , " " ++ unwords [pname, cmd, "hlint"]
, " Download the latest stable version of hlint;"
- , " " ++ unwords [ pname, cmd, "lens --source-repository=head" ]
+ , " " ++ unwords [pname, cmd, "lens --source-repository=head"]
, " Download the source repository of lens (i.e. git clone from github)."
]
-- 'cabal unpack' is a deprecated alias for 'cabal get'.
unpackCommand :: CommandUI GetFlags
-unpackCommand = getCommand
- { commandName = "unpack"
- , commandSynopsis = synopsis
- , commandNotes = Just $ \ pname -> unlines $
- notesOfGetCommand "unpack" pname
- , commandUsage = usagePackages "unpack"
- }
+unpackCommand =
+ getCommand
+ { commandName = "unpack"
+ , commandSynopsis = synopsis
+ , commandNotes = Just $ \pname ->
+ unlines $
+ notesOfGetCommand "unpack" pname
+ , commandUsage = usagePackages "unpack"
+ }
where
- synopsis = "Deprecated alias for 'get'."
+ synopsis = "Deprecated alias for 'get'."
instance Monoid GetFlags where
mempty = gmempty
@@ -1430,86 +1850,109 @@ instance Semigroup GetFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * List flags
+
-- ------------------------------------------------------------
data ListFlags = ListFlags
- { listInstalled :: Flag Bool
- , listSimpleOutput :: Flag Bool
- , listCaseInsensitive :: Flag Bool
- , listVerbosity :: Flag Verbosity
- , listPackageDBs :: [Maybe PackageDB]
- , listHcPath :: Flag FilePath
- }
- deriving Generic
+ { listInstalled :: Flag Bool
+ , listSimpleOutput :: Flag Bool
+ , listCaseInsensitive :: Flag Bool
+ , listVerbosity :: Flag Verbosity
+ , listPackageDBs :: [Maybe PackageDB]
+ , listHcPath :: Flag FilePath
+ }
+ deriving (Generic)
defaultListFlags :: ListFlags
-defaultListFlags = ListFlags
- { listInstalled = Flag False
- , listSimpleOutput = Flag False
+defaultListFlags =
+ ListFlags
+ { listInstalled = Flag False
+ , listSimpleOutput = Flag False
, listCaseInsensitive = Flag True
- , listVerbosity = toFlag normal
- , listPackageDBs = []
- , listHcPath = mempty
+ , listVerbosity = toFlag normal
+ , listPackageDBs = []
+ , listHcPath = mempty
}
-listCommand :: CommandUI ListFlags
-listCommand = CommandUI {
- commandName = "list",
- commandSynopsis = "List packages matching a search string.",
- commandDescription = Just $ \_ -> wrapText $
- "List all packages, or all packages matching one of the search"
- ++ " strings.\n"
- ++ "\n"
- ++ "Use the package database specified with --package-db. "
- ++ "If not specified, use the user package database.\n",
- commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " list pandoc\n"
- ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n",
- commandUsage = usageAlternatives "list" [ "[FLAGS]"
- , "[FLAGS] STRINGS"],
- commandDefaultFlags = defaultListFlags,
- commandOptions = const listOptions
- }
+listCommand :: CommandUI ListFlags
+listCommand =
+ CommandUI
+ { commandName = "list"
+ , commandSynopsis = "List packages matching a search string."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "List all packages, or all packages matching one of the search"
+ ++ " strings.\n"
+ ++ "\n"
+ ++ "Use the package database specified with --package-db. "
+ ++ "If not specified, use the user package database.\n"
+ , commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " list pandoc\n"
+ ++ " Will find pandoc, pandoc-citeproc, pandoc-lens, ...\n"
+ , commandUsage =
+ usageAlternatives
+ "list"
+ [ "[FLAGS]"
+ , "[FLAGS] STRINGS"
+ ]
+ , commandDefaultFlags = defaultListFlags
+ , commandOptions = const listOptions
+ }
listOptions :: [OptionField ListFlags]
listOptions =
- [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
-
- , option [] ["installed"]
- "Only print installed packages"
- listInstalled (\v flags -> flags { listInstalled = v })
- trueArg
-
- , option [] ["simple-output"]
- "Print in a easy-to-parse format"
- listSimpleOutput (\v flags -> flags { listSimpleOutput = v })
- trueArg
- , option ['i'] ["ignore-case"]
- "Ignore case distinctions"
- listCaseInsensitive (\v flags -> flags { listCaseInsensitive = v })
- (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"]))
-
- , option "" ["package-db"]
- ( "Append the given package database to the list of package"
- ++ " databases used (to satisfy dependencies and register into)."
- ++ " May be a specific file, 'global' or 'user'. The initial list"
- ++ " is ['global'], ['global', 'user'],"
- ++ " depending on context. Use 'clear' to reset the list to empty."
- ++ " See the user guide for details.")
- listPackageDBs (\v flags -> flags { listPackageDBs = v })
+ [ optionVerbosity listVerbosity (\v flags -> flags{listVerbosity = v})
+ , option
+ []
+ ["installed"]
+ "Only print installed packages"
+ listInstalled
+ (\v flags -> flags{listInstalled = v})
+ trueArg
+ , option
+ []
+ ["simple-output"]
+ "Print in a easy-to-parse format"
+ listSimpleOutput
+ (\v flags -> flags{listSimpleOutput = v})
+ trueArg
+ , option
+ ['i']
+ ["ignore-case"]
+ "Ignore case distinctions"
+ listCaseInsensitive
+ (\v flags -> flags{listCaseInsensitive = v})
+ (boolOpt' (['i'], ["ignore-case"]) (['I'], ["strict-case"]))
+ , option
+ ""
+ ["package-db"]
+ ( "Append the given package database to the list of package"
+ ++ " databases used (to satisfy dependencies and register into)."
+ ++ " May be a specific file, 'global' or 'user'. The initial list"
+ ++ " is ['global'], ['global', 'user'],"
+ ++ " depending on context. Use 'clear' to reset the list to empty."
+ ++ " See the user guide for details."
+ )
+ listPackageDBs
+ (\v flags -> flags{listPackageDBs = v})
(reqArg' "DB" readPackageDbList showPackageDbList)
-
- , option "w" ["with-compiler"]
+ , option
+ "w"
+ ["with-compiler"]
"give the path to a particular compiler"
- listHcPath (\v flags -> flags { listHcPath = v })
+ listHcPath
+ (\v flags -> flags{listHcPath = v})
(reqArgFlag "PATH")
- ]
+ ]
listNeedsCompiler :: ListFlags -> Bool
listNeedsCompiler f =
- flagElim False (const True) (listHcPath f)
+ flagElim False (const True) (listHcPath f)
|| fromFlagOrDefault False (listInstalled f)
instance Monoid ListFlags where
@@ -1520,45 +1963,53 @@ instance Semigroup ListFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * Info flags
--- ------------------------------------------------------------
-data InfoFlags = InfoFlags {
- infoVerbosity :: Flag Verbosity,
- infoPackageDBs :: [Maybe PackageDB]
- } deriving Generic
+-- ------------------------------------------------------------
-defaultInfoFlags :: InfoFlags
-defaultInfoFlags = InfoFlags {
- infoVerbosity = toFlag normal,
- infoPackageDBs = []
+data InfoFlags = InfoFlags
+ { infoVerbosity :: Flag Verbosity
+ , infoPackageDBs :: [Maybe PackageDB]
}
+ deriving (Generic)
-infoCommand :: CommandUI InfoFlags
-infoCommand = CommandUI {
- commandName = "info",
- commandSynopsis = "Display detailed information about a particular package.",
- commandDescription = Just $ \_ -> wrapText $
- "Use the package database specified with --package-db. "
- ++ "If not specified, use the user package database.\n",
- commandNotes = Nothing,
- commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"],
- commandDefaultFlags = defaultInfoFlags,
- commandOptions = \_ -> [
- optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })
-
- , option "" ["package-db"]
- ( "Append the given package database to the list of package"
- ++ " databases used (to satisfy dependencies and register into)."
- ++ " May be a specific file, 'global' or 'user'. The initial list"
- ++ " is ['global'], ['global', 'user'],"
- ++ " depending on context. Use 'clear' to reset the list to empty."
- ++ " See the user guide for details.")
- infoPackageDBs (\v flags -> flags { infoPackageDBs = v })
- (reqArg' "DB" readPackageDbList showPackageDbList)
+defaultInfoFlags :: InfoFlags
+defaultInfoFlags =
+ InfoFlags
+ { infoVerbosity = toFlag normal
+ , infoPackageDBs = []
+ }
+infoCommand :: CommandUI InfoFlags
+infoCommand =
+ CommandUI
+ { commandName = "info"
+ , commandSynopsis = "Display detailed information about a particular package."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Use the package database specified with --package-db. "
+ ++ "If not specified, use the user package database.\n"
+ , commandNotes = Nothing
+ , commandUsage = usageAlternatives "info" ["[FLAGS] PACKAGES"]
+ , commandDefaultFlags = defaultInfoFlags
+ , commandOptions = \_ ->
+ [ optionVerbosity infoVerbosity (\v flags -> flags{infoVerbosity = v})
+ , option
+ ""
+ ["package-db"]
+ ( "Append the given package database to the list of package"
+ ++ " databases used (to satisfy dependencies and register into)."
+ ++ " May be a specific file, 'global' or 'user'. The initial list"
+ ++ " is ['global'], ['global', 'user'],"
+ ++ " depending on context. Use 'clear' to reset the list to empty."
+ ++ " See the user guide for details."
+ )
+ infoPackageDBs
+ (\v flags -> flags{infoPackageDBs = v})
+ (reqArg' "DB" readPackageDbList showPackageDbList)
]
- }
+ }
instance Monoid InfoFlags where
mempty = gmempty
@@ -1568,93 +2019,100 @@ instance Semigroup InfoFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * Install flags
+
-- ------------------------------------------------------------
-- | Install takes the same flags as configure along with a few extras.
---
-data InstallFlags = InstallFlags {
- installDocumentation :: Flag Bool,
- installHaddockIndex :: Flag PathTemplate,
- installDest :: Flag Cabal.CopyDest,
- installDryRun :: Flag Bool,
- installOnlyDownload :: Flag Bool,
- installMaxBackjumps :: Flag Int,
- installReorderGoals :: Flag ReorderGoals,
- installCountConflicts :: Flag CountConflicts,
- installFineGrainedConflicts :: Flag FineGrainedConflicts,
- installMinimizeConflictSet :: Flag MinimizeConflictSet,
- installIndependentGoals :: Flag IndependentGoals,
- installPreferOldest :: Flag PreferOldest,
- installShadowPkgs :: Flag ShadowPkgs,
- installStrongFlags :: Flag StrongFlags,
- installAllowBootLibInstalls :: Flag AllowBootLibInstalls,
- installOnlyConstrained :: Flag OnlyConstrained,
- installReinstall :: Flag Bool,
- installAvoidReinstalls :: Flag AvoidReinstalls,
- installOverrideReinstall :: Flag Bool,
- installUpgradeDeps :: Flag Bool,
- installOnly :: Flag Bool,
- installOnlyDeps :: Flag Bool,
- installIndexState :: Flag TotalIndexState,
- installRootCmd :: Flag String,
- installSummaryFile :: NubList PathTemplate,
- installLogFile :: Flag PathTemplate,
- installBuildReports :: Flag ReportLevel,
- installReportPlanningFailure :: Flag Bool,
- -- Note: symlink-bindir is no longer used by v2-install and can be removed
+data InstallFlags = InstallFlags
+ { installDocumentation :: Flag Bool
+ , installHaddockIndex :: Flag PathTemplate
+ , installDest :: Flag Cabal.CopyDest
+ , installDryRun :: Flag Bool
+ , installOnlyDownload :: Flag Bool
+ , installMaxBackjumps :: Flag Int
+ , installReorderGoals :: Flag ReorderGoals
+ , installCountConflicts :: Flag CountConflicts
+ , installFineGrainedConflicts :: Flag FineGrainedConflicts
+ , installMinimizeConflictSet :: Flag MinimizeConflictSet
+ , installIndependentGoals :: Flag IndependentGoals
+ , installPreferOldest :: Flag PreferOldest
+ , installShadowPkgs :: Flag ShadowPkgs
+ , installStrongFlags :: Flag StrongFlags
+ , installAllowBootLibInstalls :: Flag AllowBootLibInstalls
+ , installOnlyConstrained :: Flag OnlyConstrained
+ , installReinstall :: Flag Bool
+ , installAvoidReinstalls :: Flag AvoidReinstalls
+ , installOverrideReinstall :: Flag Bool
+ , installUpgradeDeps :: Flag Bool
+ , installOnly :: Flag Bool
+ , installOnlyDeps :: Flag Bool
+ , installIndexState :: Flag TotalIndexState
+ , installRootCmd :: Flag String
+ , installSummaryFile :: NubList PathTemplate
+ , installLogFile :: Flag PathTemplate
+ , installBuildReports :: Flag ReportLevel
+ , installReportPlanningFailure :: Flag Bool
+ , -- Note: symlink-bindir is no longer used by v2-install and can be removed
-- when removing v1 commands
- installSymlinkBinDir :: Flag FilePath,
- installPerComponent :: Flag Bool,
- installNumJobs :: Flag (Maybe Int),
- installKeepGoing :: Flag Bool,
- installRunTests :: Flag Bool,
- installOfflineMode :: Flag Bool
+ installSymlinkBinDir :: Flag FilePath
+ , installPerComponent :: Flag Bool
+ , installNumJobs :: Flag (Maybe Int)
+ , installKeepGoing :: Flag Bool
+ , installRunTests :: Flag Bool
+ , installOfflineMode :: Flag Bool
}
deriving (Eq, Show, Generic)
instance Binary InstallFlags
defaultInstallFlags :: InstallFlags
-defaultInstallFlags = InstallFlags {
- installDocumentation = Flag False,
- installHaddockIndex = Flag docIndexFile,
- installDest = Flag Cabal.NoCopyDest,
- installDryRun = Flag False,
- installOnlyDownload = Flag False,
- installMaxBackjumps = Flag defaultMaxBackjumps,
- installReorderGoals = Flag (ReorderGoals False),
- installCountConflicts = Flag (CountConflicts True),
- installFineGrainedConflicts = Flag (FineGrainedConflicts True),
- installMinimizeConflictSet = Flag (MinimizeConflictSet False),
- installIndependentGoals= Flag (IndependentGoals False),
- installPreferOldest = Flag (PreferOldest False),
- installShadowPkgs = Flag (ShadowPkgs False),
- installStrongFlags = Flag (StrongFlags False),
- installAllowBootLibInstalls = Flag (AllowBootLibInstalls False),
- installOnlyConstrained = Flag OnlyConstrainedNone,
- installReinstall = Flag False,
- installAvoidReinstalls = Flag (AvoidReinstalls False),
- installOverrideReinstall = Flag False,
- installUpgradeDeps = Flag False,
- installOnly = Flag False,
- installOnlyDeps = Flag False,
- installIndexState = mempty,
- installRootCmd = mempty,
- installSummaryFile = mempty,
- installLogFile = mempty,
- installBuildReports = Flag NoReports,
- installReportPlanningFailure = Flag False,
- installSymlinkBinDir = mempty,
- installPerComponent = Flag True,
- installNumJobs = mempty,
- installKeepGoing = Flag False,
- installRunTests = mempty,
- installOfflineMode = Flag False
- }
+defaultInstallFlags =
+ InstallFlags
+ { installDocumentation = Flag False
+ , installHaddockIndex = Flag docIndexFile
+ , installDest = Flag Cabal.NoCopyDest
+ , installDryRun = Flag False
+ , installOnlyDownload = Flag False
+ , installMaxBackjumps = Flag defaultMaxBackjumps
+ , installReorderGoals = Flag (ReorderGoals False)
+ , installCountConflicts = Flag (CountConflicts True)
+ , installFineGrainedConflicts = Flag (FineGrainedConflicts True)
+ , installMinimizeConflictSet = Flag (MinimizeConflictSet False)
+ , installIndependentGoals = Flag (IndependentGoals False)
+ , installPreferOldest = Flag (PreferOldest False)
+ , installShadowPkgs = Flag (ShadowPkgs False)
+ , installStrongFlags = Flag (StrongFlags False)
+ , installAllowBootLibInstalls = Flag (AllowBootLibInstalls False)
+ , installOnlyConstrained = Flag OnlyConstrainedNone
+ , installReinstall = Flag False
+ , installAvoidReinstalls = Flag (AvoidReinstalls False)
+ , installOverrideReinstall = Flag False
+ , installUpgradeDeps = Flag False
+ , installOnly = Flag False
+ , installOnlyDeps = Flag False
+ , installIndexState = mempty
+ , installRootCmd = mempty
+ , installSummaryFile = mempty
+ , installLogFile = mempty
+ , installBuildReports = Flag NoReports
+ , installReportPlanningFailure = Flag False
+ , installSymlinkBinDir = mempty
+ , installPerComponent = Flag True
+ , installNumJobs = mempty
+ , installKeepGoing = Flag False
+ , installRunTests = mempty
+ , installOfflineMode = Flag False
+ }
where
- docIndexFile = toPathTemplate ("$datadir" </> "doc"
- </> "$arch-$os-$compiler" </> "index.html")
+ docIndexFile =
+ toPathTemplate
+ ( "$datadir"
+ </> "doc"
+ </> "$arch-$os-$compiler"
+ </> "index.html"
+ )
defaultMaxBackjumps :: Int
defaultMaxBackjumps = 4000
@@ -1665,91 +2123,135 @@ defaultSolver = AlwaysModular
allSolvers :: String
allSolvers = intercalate ", " (map prettyShow ([minBound .. maxBound] :: [PreSolver]))
-installCommand :: CommandUI ( ConfigFlags, ConfigExFlags, InstallFlags
- , HaddockFlags, TestFlags, BenchmarkFlags
- )
-installCommand = CommandUI {
- commandName = "install",
- commandSynopsis = "Install packages.",
- commandUsage = usageAlternatives "v1-install" [ "[FLAGS]"
- , "[FLAGS] PACKAGES"
- ],
- commandDescription = Just $ \_ -> wrapText $
- "Installs one or more packages. By default, the installed package"
- ++ " will be registered in the user's package database."
- ++ "\n"
- ++ "If PACKAGES are specified, downloads and installs those packages."
- ++ " Otherwise, install the package in the current directory (and/or its"
- ++ " dependencies) (there must be exactly one .cabal file in the current"
- ++ " directory).\n"
- ++ "\n"
- ++ "The flags to `v1-install` are saved and"
- ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for"
- ++ " `v1-configure` for a list of commands being affected.\n"
- ++ "\n"
- ++ "Installed executables will by default"
- ++ " be put into `~/.local/bin/`."
- ++ " If you want installed executable to be available globally, make"
- ++ " sure that the PATH environment variable contains that directory.\n"
- ++ "\n",
- commandNotes = Just $ \pname ->
- ( case commandNotes
- $ Cabal.configureCommand defaultProgramDb
- of Just desc -> desc pname ++ "\n"
- Nothing -> ""
+installCommand
+ :: CommandUI
+ ( ConfigFlags
+ , ConfigExFlags
+ , InstallFlags
+ , HaddockFlags
+ , TestFlags
+ , BenchmarkFlags
+ )
+installCommand =
+ CommandUI
+ { commandName = "install"
+ , commandSynopsis = "Install packages."
+ , commandUsage =
+ usageAlternatives
+ "v1-install"
+ [ "[FLAGS]"
+ , "[FLAGS] PACKAGES"
+ ]
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Installs one or more packages. By default, the installed package"
+ ++ " will be registered in the user's package database."
+ ++ "\n"
+ ++ "If PACKAGES are specified, downloads and installs those packages."
+ ++ " Otherwise, install the package in the current directory (and/or its"
+ ++ " dependencies) (there must be exactly one .cabal file in the current"
+ ++ " directory).\n"
+ ++ "\n"
+ ++ "The flags to `v1-install` are saved and"
+ ++ " affect future commands such as `v1-build` and `v1-repl`. See the help for"
+ ++ " `v1-configure` for a list of commands being affected.\n"
+ ++ "\n"
+ ++ "Installed executables will by default"
+ ++ " be put into `~/.local/bin/`."
+ ++ " If you want installed executable to be available globally, make"
+ ++ " sure that the PATH environment variable contains that directory.\n"
+ ++ "\n"
+ , commandNotes = Just $ \pname ->
+ ( case commandNotes $
+ Cabal.configureCommand defaultProgramDb of
+ Just desc -> desc pname ++ "\n"
+ Nothing -> ""
)
- ++ "Examples:\n"
- ++ " " ++ pname ++ " v1-install "
- ++ " Package in the current directory\n"
- ++ " " ++ pname ++ " v1-install foo "
- ++ " Package from the hackage server\n"
- ++ " " ++ pname ++ " v1-install foo-1.0 "
- ++ " Specific version of a package\n"
- ++ " " ++ pname ++ " v1-install 'foo < 2' "
- ++ " Constrained package version\n"
- ++ " " ++ pname ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"
- ++ " " ++ (map (const ' ') pname)
- ++ " "
- ++ " Change installation destination\n",
- commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty),
- commandOptions = \showOrParseArgs ->
- liftOptions get1 set1
- -- Note: [Hidden Flags]
- -- hide "constraint", "dependency", and
- -- "exact-configuration" from the configure options.
- (filter ((`notElem` ["constraint", "dependency"
- , "exact-configuration"])
- . optionName) $
- configureOptions showOrParseArgs)
- ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
- ++ liftOptions get3 set3
- -- hide "target-package-db" flag from the
- -- install options.
- (filter ((`notElem` ["target-package-db"])
- . optionName) $
- installOptions showOrParseArgs)
- ++ liftOptions get4 set4 (haddockOptions showOrParseArgs)
- ++ liftOptions get5 set5 (testOptions showOrParseArgs)
- ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs)
- }
+ ++ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v1-install "
+ ++ " Package in the current directory\n"
+ ++ " "
+ ++ pname
+ ++ " v1-install foo "
+ ++ " Package from the hackage server\n"
+ ++ " "
+ ++ pname
+ ++ " v1-install foo-1.0 "
+ ++ " Specific version of a package\n"
+ ++ " "
+ ++ pname
+ ++ " v1-install 'foo < 2' "
+ ++ " Constrained package version\n"
+ ++ " "
+ ++ pname
+ ++ " v1-install haddock --bindir=$HOME/hask-bin/ --datadir=$HOME/hask-data/\n"
+ ++ " "
+ ++ (map (const ' ') pname)
+ ++ " "
+ ++ " Change installation destination\n"
+ , commandDefaultFlags = (mempty, mempty, mempty, mempty, mempty, mempty)
+ , commandOptions = \showOrParseArgs ->
+ liftOptions
+ get1
+ set1
+ -- Note: [Hidden Flags]
+ -- hide "constraint", "dependency", and
+ -- "exact-configuration" from the configure options.
+ ( filter
+ ( ( `notElem`
+ [ "constraint"
+ , "dependency"
+ , "exact-configuration"
+ ]
+ )
+ . optionName
+ )
+ $ configureOptions showOrParseArgs
+ )
+ ++ liftOptions get2 set2 (configureExOptions showOrParseArgs ConstraintSourceCommandlineFlag)
+ ++ liftOptions
+ get3
+ set3
+ -- hide "target-package-db" flag from the
+ -- install options.
+ ( filter
+ ( (`notElem` ["target-package-db"])
+ . optionName
+ )
+ $ installOptions showOrParseArgs
+ )
+ ++ liftOptions get4 set4 (haddockOptions showOrParseArgs)
+ ++ liftOptions get5 set5 (testOptions showOrParseArgs)
+ ++ liftOptions get6 set6 (benchmarkOptions showOrParseArgs)
+ }
where
- get1 (a,_,_,_,_,_) = a; set1 a (_,b,c,d,e,f) = (a,b,c,d,e,f)
- get2 (_,b,_,_,_,_) = b; set2 b (a,_,c,d,e,f) = (a,b,c,d,e,f)
- get3 (_,_,c,_,_,_) = c; set3 c (a,b,_,d,e,f) = (a,b,c,d,e,f)
- get4 (_,_,_,d,_,_) = d; set4 d (a,b,c,_,e,f) = (a,b,c,d,e,f)
- get5 (_,_,_,_,e,_) = e; set5 e (a,b,c,d,_,f) = (a,b,c,d,e,f)
- get6 (_,_,_,_,_,f) = f; set6 f (a,b,c,d,e,_) = (a,b,c,d,e,f)
+ get1 (a, _, _, _, _, _) = a
+ set1 a (_, b, c, d, e, f) = (a, b, c, d, e, f)
+ get2 (_, b, _, _, _, _) = b
+ set2 b (a, _, c, d, e, f) = (a, b, c, d, e, f)
+ get3 (_, _, c, _, _, _) = c
+ set3 c (a, b, _, d, e, f) = (a, b, c, d, e, f)
+ get4 (_, _, _, d, _, _) = d
+ set4 d (a, b, c, _, e, f) = (a, b, c, d, e, f)
+ get5 (_, _, _, _, e, _) = e
+ set5 e (a, b, c, d, _, f) = (a, b, c, d, e, f)
+ get6 (_, _, _, _, _, f) = f
+ set6 f (a, b, c, d, e, _) = (a, b, c, d, e, f)
haddockCommand :: CommandUI HaddockFlags
-haddockCommand = Cabal.haddockCommand
- { commandUsage = usageAlternatives "v1-haddock" $
- [ "[FLAGS]", "COMPONENTS [FLAGS]" ]
- }
+haddockCommand =
+ Cabal.haddockCommand
+ { commandUsage =
+ usageAlternatives "v1-haddock" $
+ ["[FLAGS]", "COMPONENTS [FLAGS]"]
+ }
filterHaddockArgs :: [String] -> Version -> [String]
filterHaddockArgs args cabalLibVersion
- | cabalLibVersion >= mkVersion [2,3,0] = args_latest
- | cabalLibVersion < mkVersion [2,3,0] = args_2_3_0
+ | cabalLibVersion >= mkVersion [2, 3, 0] = args_latest
+ | cabalLibVersion < mkVersion [2, 3, 0] = args_2_3_0
| otherwise = args_latest
where
args_latest = args
@@ -1759,216 +2261,336 @@ filterHaddockArgs args cabalLibVersion
filterHaddockFlags :: HaddockFlags -> Version -> HaddockFlags
filterHaddockFlags flags cabalLibVersion
- | cabalLibVersion >= mkVersion [2,3,0] = flags_latest
- | cabalLibVersion < mkVersion [2,3,0] = flags_2_3_0
+ | cabalLibVersion >= mkVersion [2, 3, 0] = flags_latest
+ | cabalLibVersion < mkVersion [2, 3, 0] = flags_2_3_0
| otherwise = flags_latest
where
flags_latest = flags
- flags_2_3_0 = flags_latest {
- -- Cabal < 2.3 doesn't know about per-component haddock
- haddockArgs = []
- }
+ flags_2_3_0 =
+ flags_latest
+ { -- Cabal < 2.3 doesn't know about per-component haddock
+ haddockArgs = []
+ }
haddockOptions :: ShowOrParseArgs -> [OptionField HaddockFlags]
-haddockOptions showOrParseArgs
- = [ opt { optionName = "haddock-" ++ name,
- optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
- | descr <- optionDescr opt] }
- | opt <- commandOptions Cabal.haddockCommand showOrParseArgs
- , let name = optionName opt
- , name `elem` ["hoogle", "html", "html-location"
- ,"executables", "tests", "benchmarks", "all", "internal", "css"
- ,"hyperlink-source", "quickjump", "hscolour-css"
- ,"contents-location", "use-index", "for-hackage", "base-url", "lib", "output-dir"]
- ]
+haddockOptions showOrParseArgs =
+ [ opt
+ { optionName = "haddock-" ++ name
+ , optionDescr =
+ [ fmapOptFlags (\(_, lflags) -> ([], map ("haddock-" ++) lflags)) descr
+ | descr <- optionDescr opt
+ ]
+ }
+ | opt <- commandOptions Cabal.haddockCommand showOrParseArgs
+ , let name = optionName opt
+ , name
+ `elem` [ "hoogle"
+ , "html"
+ , "html-location"
+ , "executables"
+ , "tests"
+ , "benchmarks"
+ , "all"
+ , "internal"
+ , "css"
+ , "hyperlink-source"
+ , "quickjump"
+ , "hscolour-css"
+ , "contents-location"
+ , "use-index"
+ , "for-hackage"
+ , "base-url"
+ , "lib"
+ , "output-dir"
+ ]
+ ]
testOptions :: ShowOrParseArgs -> [OptionField TestFlags]
-testOptions showOrParseArgs
- = [ opt { optionName = prefixTest name,
- optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr
- | descr <- optionDescr opt] }
- | opt <- commandOptions Cabal.testCommand showOrParseArgs
- , let name = optionName opt
- , name `elem` ["log", "machine-log", "show-details", "keep-tix-files"
- ,"fail-when-no-test-suites", "test-options", "test-option"
- ,"test-wrapper"]
- ]
+testOptions showOrParseArgs =
+ [ opt
+ { optionName = prefixTest name
+ , optionDescr =
+ [ fmapOptFlags (\(_, lflags) -> ([], map prefixTest lflags)) descr
+ | descr <- optionDescr opt
+ ]
+ }
+ | opt <- commandOptions Cabal.testCommand showOrParseArgs
+ , let name = optionName opt
+ , name
+ `elem` [ "log"
+ , "machine-log"
+ , "show-details"
+ , "keep-tix-files"
+ , "fail-when-no-test-suites"
+ , "test-options"
+ , "test-option"
+ , "test-wrapper"
+ ]
+ ]
where
- prefixTest name | "test-" `isPrefixOf` name = name
- | otherwise = "test-" ++ name
+ prefixTest name
+ | "test-" `isPrefixOf` name = name
+ | otherwise = "test-" ++ name
benchmarkOptions :: ShowOrParseArgs -> [OptionField BenchmarkFlags]
-benchmarkOptions showOrParseArgs
- = [ opt { optionName = prefixBenchmark name,
- optionDescr = [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr
- | descr <- optionDescr opt] }
- | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs
- , let name = optionName opt
- , name `elem` ["benchmark-options", "benchmark-option"]
- ]
+benchmarkOptions showOrParseArgs =
+ [ opt
+ { optionName = prefixBenchmark name
+ , optionDescr =
+ [ fmapOptFlags (\(_, lflags) -> ([], map prefixBenchmark lflags)) descr
+ | descr <- optionDescr opt
+ ]
+ }
+ | opt <- commandOptions Cabal.benchmarkCommand showOrParseArgs
+ , let name = optionName opt
+ , name `elem` ["benchmark-options", "benchmark-option"]
+ ]
where
- prefixBenchmark name | "benchmark-" `isPrefixOf` name = name
- | otherwise = "benchmark-" ++ name
+ prefixBenchmark name
+ | "benchmark-" `isPrefixOf` name = name
+ | otherwise = "benchmark-" ++ name
fmapOptFlags :: (OptFlags -> OptFlags) -> OptDescr a -> OptDescr a
-fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w
-fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w
-fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]
+fmapOptFlags modify (ReqArg d f p r w) = ReqArg d (modify f) p r w
+fmapOptFlags modify (OptArg d f p r i w) = OptArg d (modify f) p r i w
+fmapOptFlags modify (ChoiceOpt xs) = ChoiceOpt [(d, modify f, i, w) | (d, f, i, w) <- xs]
fmapOptFlags modify (BoolOpt d f1 f2 r w) = BoolOpt d (modify f1) (modify f2) r w
-installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]
+installOptions :: ShowOrParseArgs -> [OptionField InstallFlags]
installOptions showOrParseArgs =
- [ option "" ["documentation"]
- "building of documentation"
- installDocumentation (\v flags -> flags { installDocumentation = v })
- (boolOpt [] [])
-
- , option [] ["doc-index-file"]
- "A central index of haddock API documentation (template cannot use $pkgid)"
- installHaddockIndex (\v flags -> flags { installHaddockIndex = v })
- (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
- (flagToList . fmap fromPathTemplate))
-
- , option [] ["dry-run"]
- "Do not install anything, only print what would be installed."
- installDryRun (\v flags -> flags { installDryRun = v })
- trueArg
-
- , option [] ["only-download"]
- "Do not build anything, only fetch the packages."
- installOnlyDownload (\v flags -> flags { installOnlyDownload = v })
- trueArg
-
- , option "" ["target-package-db"]
- "package database to install into. Required when using ${pkgroot} prefix."
- installDest (\v flags -> flags { installDest = v })
- (reqArg "DATABASE" (succeedReadE (Flag . Cabal.CopyToDb))
- (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> []))
- ] ++
-
- optionSolverFlags showOrParseArgs
- installMaxBackjumps (\v flags -> flags { installMaxBackjumps = v })
- installReorderGoals (\v flags -> flags { installReorderGoals = v })
- installCountConflicts (\v flags -> flags { installCountConflicts = v })
- installFineGrainedConflicts (\v flags -> flags { installFineGrainedConflicts = v })
- installMinimizeConflictSet (\v flags -> flags { installMinimizeConflictSet = v })
- installIndependentGoals (\v flags -> flags { installIndependentGoals = v })
- installPreferOldest (\v flags -> flags { installPreferOldest = v })
- installShadowPkgs (\v flags -> flags { installShadowPkgs = v })
- installStrongFlags (\v flags -> flags { installStrongFlags = v })
- installAllowBootLibInstalls (\v flags -> flags { installAllowBootLibInstalls = v })
- installOnlyConstrained (\v flags -> flags { installOnlyConstrained = v }) ++
-
- [ option [] ["reinstall"]
+ [ option
+ ""
+ ["documentation"]
+ "building of documentation"
+ installDocumentation
+ (\v flags -> flags{installDocumentation = v})
+ (boolOpt [] [])
+ , option
+ []
+ ["doc-index-file"]
+ "A central index of haddock API documentation (template cannot use $pkgid)"
+ installHaddockIndex
+ (\v flags -> flags{installHaddockIndex = v})
+ ( reqArg'
+ "TEMPLATE"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate)
+ )
+ , option
+ []
+ ["dry-run"]
+ "Do not install anything, only print what would be installed."
+ installDryRun
+ (\v flags -> flags{installDryRun = v})
+ trueArg
+ , option
+ []
+ ["only-download"]
+ "Do not build anything, only fetch the packages."
+ installOnlyDownload
+ (\v flags -> flags{installOnlyDownload = v})
+ trueArg
+ , option
+ ""
+ ["target-package-db"]
+ "package database to install into. Required when using ${pkgroot} prefix."
+ installDest
+ (\v flags -> flags{installDest = v})
+ ( reqArg
+ "DATABASE"
+ (succeedReadE (Flag . Cabal.CopyToDb))
+ (\f -> case f of Flag (Cabal.CopyToDb p) -> [p]; _ -> [])
+ )
+ ]
+ ++ optionSolverFlags
+ showOrParseArgs
+ installMaxBackjumps
+ (\v flags -> flags{installMaxBackjumps = v})
+ installReorderGoals
+ (\v flags -> flags{installReorderGoals = v})
+ installCountConflicts
+ (\v flags -> flags{installCountConflicts = v})
+ installFineGrainedConflicts
+ (\v flags -> flags{installFineGrainedConflicts = v})
+ installMinimizeConflictSet
+ (\v flags -> flags{installMinimizeConflictSet = v})
+ installIndependentGoals
+ (\v flags -> flags{installIndependentGoals = v})
+ installPreferOldest
+ (\v flags -> flags{installPreferOldest = v})
+ installShadowPkgs
+ (\v flags -> flags{installShadowPkgs = v})
+ installStrongFlags
+ (\v flags -> flags{installStrongFlags = v})
+ installAllowBootLibInstalls
+ (\v flags -> flags{installAllowBootLibInstalls = v})
+ installOnlyConstrained
+ (\v flags -> flags{installOnlyConstrained = v})
+ ++ [ option
+ []
+ ["reinstall"]
"Install even if it means installing the same version again."
- installReinstall (\v flags -> flags { installReinstall = v })
+ installReinstall
+ (\v flags -> flags{installReinstall = v})
(yesNoOpt showOrParseArgs)
-
- , option [] ["avoid-reinstalls"]
+ , option
+ []
+ ["avoid-reinstalls"]
"Do not select versions that would destructively overwrite installed packages."
(fmap asBool . installAvoidReinstalls)
- (\v flags -> flags { installAvoidReinstalls = fmap AvoidReinstalls v })
+ (\v flags -> flags{installAvoidReinstalls = fmap AvoidReinstalls v})
(yesNoOpt showOrParseArgs)
-
- , option [] ["force-reinstalls"]
+ , option
+ []
+ ["force-reinstalls"]
"Reinstall packages even if they will most likely break other installed packages."
- installOverrideReinstall (\v flags -> flags { installOverrideReinstall = v })
+ installOverrideReinstall
+ (\v flags -> flags{installOverrideReinstall = v})
(yesNoOpt showOrParseArgs)
-
- , option [] ["upgrade-dependencies"]
+ , option
+ []
+ ["upgrade-dependencies"]
"Pick the latest version for all dependencies, rather than trying to pick an installed version."
- installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })
+ installUpgradeDeps
+ (\v flags -> flags{installUpgradeDeps = v})
(yesNoOpt showOrParseArgs)
-
- , option [] ["only-dependencies"]
+ , option
+ []
+ ["only-dependencies"]
"Install only the dependencies necessary to build the given packages"
- installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
+ installOnlyDeps
+ (\v flags -> flags{installOnlyDeps = v})
(yesNoOpt showOrParseArgs)
-
- , option [] ["dependencies-only"]
+ , option
+ []
+ ["dependencies-only"]
"A synonym for --only-dependencies"
- installOnlyDeps (\v flags -> flags { installOnlyDeps = v })
+ installOnlyDeps
+ (\v flags -> flags{installOnlyDeps = v})
(yesNoOpt showOrParseArgs)
-
- , option [] ["index-state"]
- ("Use source package index state as it existed at a previous time. " ++
- "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps " ++
- "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD').")
- installIndexState (\v flags -> flags { installIndexState = v })
- (reqArg "STATE" (parsecToReadE (const $ "index-state must be a " ++
- "unix-timestamps (e.g. '@1474732068'), " ++
- "a ISO8601 UTC timestamp " ++
- "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'")
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option [] ["root-cmd"]
+ , option
+ []
+ ["index-state"]
+ ( "Use source package index state as it existed at a previous time. "
+ ++ "Accepts unix-timestamps (e.g. '@1474732068'), ISO8601 UTC timestamps "
+ ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD' (default: 'HEAD')."
+ )
+ installIndexState
+ (\v flags -> flags{installIndexState = v})
+ ( reqArg
+ "STATE"
+ ( parsecToReadE
+ ( const $
+ "index-state must be a "
+ ++ "unix-timestamps (e.g. '@1474732068'), "
+ ++ "a ISO8601 UTC timestamp "
+ ++ "(e.g. '2016-09-24T17:47:48Z'), or 'HEAD'"
+ )
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ []
+ ["root-cmd"]
"(No longer supported, do not use.)"
- installRootCmd (\v flags -> flags { installRootCmd = v })
+ installRootCmd
+ (\v flags -> flags{installRootCmd = v})
(reqArg' "COMMAND" toFlag flagToList)
-
- , option [] ["symlink-bindir"]
+ , option
+ []
+ ["symlink-bindir"]
"Add symlinks to installed executables into this directory."
- installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })
- (reqArgFlag "DIR")
-
- , option [] ["build-summary"]
+ installSymlinkBinDir
+ (\v flags -> flags{installSymlinkBinDir = v})
+ (reqArgFlag "DIR")
+ , option
+ []
+ ["build-summary"]
"Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"
- installSummaryFile (\v flags -> flags { installSummaryFile = v })
+ installSummaryFile
+ (\v flags -> flags{installSummaryFile = v})
(reqArg' "TEMPLATE" (\x -> toNubList [toPathTemplate x]) (map fromPathTemplate . fromNubList))
-
- , option [] ["build-log"]
+ , option
+ []
+ ["build-log"]
"Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"
- installLogFile (\v flags -> flags { installLogFile = v })
- (reqArg' "TEMPLATE" (toFlag.toPathTemplate)
- (flagToList . fmap fromPathTemplate))
-
- , option [] ["remote-build-reporting"]
+ installLogFile
+ (\v flags -> flags{installLogFile = v})
+ ( reqArg'
+ "TEMPLATE"
+ (toFlag . toPathTemplate)
+ (flagToList . fmap fromPathTemplate)
+ )
+ , option
+ []
+ ["remote-build-reporting"]
"Generate build reports to send to a remote server (none, anonymous or detailed)."
- installBuildReports (\v flags -> flags { installBuildReports = v })
- (reqArg "LEVEL" (parsecToReadE (const $ "report level must be 'none', "
- ++ "'anonymous' or 'detailed'")
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option [] ["report-planning-failure"]
+ installBuildReports
+ (\v flags -> flags{installBuildReports = v})
+ ( reqArg
+ "LEVEL"
+ ( parsecToReadE
+ ( const $
+ "report level must be 'none', "
+ ++ "'anonymous' or 'detailed'"
+ )
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ []
+ ["report-planning-failure"]
"Generate build reports when the dependency solver fails. This is used by the Hackage build bot."
- installReportPlanningFailure (\v flags -> flags { installReportPlanningFailure = v })
+ installReportPlanningFailure
+ (\v flags -> flags{installReportPlanningFailure = v})
trueArg
-
- , option "" ["per-component"]
+ , option
+ ""
+ ["per-component"]
"Per-component builds when possible"
- installPerComponent (\v flags -> flags { installPerComponent = v })
+ installPerComponent
+ (\v flags -> flags{installPerComponent = v})
(boolOpt [] [])
-
- , option [] ["run-tests"]
+ , option
+ []
+ ["run-tests"]
"Run package test suites during installation."
- installRunTests (\v flags -> flags { installRunTests = v })
+ installRunTests
+ (\v flags -> flags{installRunTests = v})
trueArg
-
- , optionNumJobs
- installNumJobs (\v flags -> flags { installNumJobs = v })
-
- , option [] ["keep-going"]
+ , optionNumJobs
+ installNumJobs
+ (\v flags -> flags{installNumJobs = v})
+ , option
+ []
+ ["keep-going"]
"After a build failure, continue to build other unaffected packages."
- installKeepGoing (\v flags -> flags { installKeepGoing = v })
+ installKeepGoing
+ (\v flags -> flags{installKeepGoing = v})
trueArg
-
- , option [] ["offline"]
+ , option
+ []
+ ["offline"]
"Don't download packages from the Internet."
- installOfflineMode (\v flags -> flags { installOfflineMode = v })
+ installOfflineMode
+ (\v flags -> flags{installOfflineMode = v})
(yesNoOpt showOrParseArgs)
-
- ] ++ case showOrParseArgs of -- TODO: remove when "cabal install"
- -- avoids
- ParseArgs ->
- [ option [] ["only"]
- "Only installs the package in the current directory."
- installOnly (\v flags -> flags { installOnly = v })
- trueArg ]
- _ -> []
-
+ ]
+ ++ case showOrParseArgs of -- TODO: remove when "cabal install"
+ -- avoids
+ ParseArgs ->
+ [ option
+ []
+ ["only"]
+ "Only installs the package in the current directory."
+ installOnly
+ (\v flags -> flags{installOnly = v})
+ trueArg
+ ]
+ _ -> []
instance Monoid InstallFlags where
mempty = gmempty
@@ -1978,78 +2600,101 @@ instance Semigroup InstallFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * Upload flags
+
-- ------------------------------------------------------------
-- | Is this a candidate package or a package to be published?
data IsCandidate = IsCandidate | IsPublished
- deriving Eq
-
-data UploadFlags = UploadFlags {
- uploadCandidate :: Flag IsCandidate,
- uploadDoc :: Flag Bool,
- uploadUsername :: Flag Username,
- uploadPassword :: Flag Password,
- uploadPasswordCmd :: Flag [String],
- uploadVerbosity :: Flag Verbosity
- } deriving Generic
+ deriving (Eq)
+
+data UploadFlags = UploadFlags
+ { uploadCandidate :: Flag IsCandidate
+ , uploadDoc :: Flag Bool
+ , uploadUsername :: Flag Username
+ , uploadPassword :: Flag Password
+ , uploadPasswordCmd :: Flag [String]
+ , uploadVerbosity :: Flag Verbosity
+ }
+ deriving (Generic)
defaultUploadFlags :: UploadFlags
-defaultUploadFlags = UploadFlags {
- uploadCandidate = toFlag IsCandidate,
- uploadDoc = toFlag False,
- uploadUsername = mempty,
- uploadPassword = mempty,
- uploadPasswordCmd = mempty,
- uploadVerbosity = toFlag normal
- }
+defaultUploadFlags =
+ UploadFlags
+ { uploadCandidate = toFlag IsCandidate
+ , uploadDoc = toFlag False
+ , uploadUsername = mempty
+ , uploadPassword = mempty
+ , uploadPasswordCmd = mempty
+ , uploadVerbosity = toFlag normal
+ }
uploadCommand :: CommandUI UploadFlags
-uploadCommand = CommandUI {
- commandName = "upload",
- commandSynopsis = "Uploads source packages or documentation to Hackage.",
- commandDescription = Nothing,
- commandNotes = Just $ \_ ->
- "You can store your Hackage login in the ~/.config/cabal/config file\n"
- ++ relevantConfigValuesText ["username", "password", "password-command"],
- commandUsage = \pname ->
- "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n",
- commandDefaultFlags = defaultUploadFlags,
- commandOptions = \_ ->
- [optionVerbosity uploadVerbosity
- (\v flags -> flags { uploadVerbosity = v })
-
- ,option [] ["publish"]
- "Publish the package instead of uploading it as a candidate."
- uploadCandidate (\v flags -> flags { uploadCandidate = v })
- (noArg (Flag IsPublished))
-
- ,option ['d'] ["documentation"]
- ("Upload documentation instead of a source package. "
- ++ "By default, this uploads documentation for a package candidate. "
- ++ "To upload documentation for "
- ++ "a published package, combine with --publish.")
- uploadDoc (\v flags -> flags { uploadDoc = v })
- trueArg
-
- ,option ['u'] ["username"]
- "Hackage username."
- uploadUsername (\v flags -> flags { uploadUsername = v })
- (reqArg' "USERNAME" (toFlag . Username)
- (flagToList . fmap unUsername))
-
- ,option ['p'] ["password"]
- "Hackage password."
- uploadPassword (\v flags -> flags { uploadPassword = v })
- (reqArg' "PASSWORD" (toFlag . Password)
- (flagToList . fmap unPassword))
-
- ,option ['P'] ["password-command"]
- "Command to get Hackage password."
- uploadPasswordCmd (\v flags -> flags { uploadPasswordCmd = v })
- (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe))
- ]
- }
+uploadCommand =
+ CommandUI
+ { commandName = "upload"
+ , commandSynopsis = "Uploads source packages or documentation to Hackage."
+ , commandDescription = Nothing
+ , commandNotes = Just $ \_ ->
+ "You can store your Hackage login in the ~/.config/cabal/config file\n"
+ ++ relevantConfigValuesText ["username", "password", "password-command"]
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " upload [FLAGS] TARFILES\n"
+ , commandDefaultFlags = defaultUploadFlags
+ , commandOptions = \_ ->
+ [ optionVerbosity
+ uploadVerbosity
+ (\v flags -> flags{uploadVerbosity = v})
+ , option
+ []
+ ["publish"]
+ "Publish the package instead of uploading it as a candidate."
+ uploadCandidate
+ (\v flags -> flags{uploadCandidate = v})
+ (noArg (Flag IsPublished))
+ , option
+ ['d']
+ ["documentation"]
+ ( "Upload documentation instead of a source package. "
+ ++ "By default, this uploads documentation for a package candidate. "
+ ++ "To upload documentation for "
+ ++ "a published package, combine with --publish."
+ )
+ uploadDoc
+ (\v flags -> flags{uploadDoc = v})
+ trueArg
+ , option
+ ['u']
+ ["username"]
+ "Hackage username."
+ uploadUsername
+ (\v flags -> flags{uploadUsername = v})
+ ( reqArg'
+ "USERNAME"
+ (toFlag . Username)
+ (flagToList . fmap unUsername)
+ )
+ , option
+ ['p']
+ ["password"]
+ "Hackage password."
+ uploadPassword
+ (\v flags -> flags{uploadPassword = v})
+ ( reqArg'
+ "PASSWORD"
+ (toFlag . Password)
+ (flagToList . fmap unPassword)
+ )
+ , option
+ ['P']
+ ["password-command"]
+ "Command to get Hackage password."
+ uploadPasswordCmd
+ (\v flags -> flags{uploadPasswordCmd = v})
+ (reqArg' "PASSWORD" (Flag . words) (fromMaybe [] . flagToMaybe))
+ ]
+ }
instance Monoid UploadFlags where
mempty = gmempty
@@ -2059,230 +2704,366 @@ instance Semigroup UploadFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * Init flags
+
-- ------------------------------------------------------------
initCommand :: CommandUI IT.InitFlags
-initCommand = CommandUI {
- commandName = "init",
- commandSynopsis = "Create a new cabal package.",
- commandDescription = Just $ \_ -> wrapText $
- "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n"
- ++ "\n"
- ++ "Calling init with no arguments runs interactive mode, "
- ++ "which will try to guess as much as possible and prompt you for the rest.\n"
- ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, "
- ++ "which will let you specify the options via flags and will use the defaults for the rest.\n"
- ++ "It is also possible to call init with a single argument, which denotes the project's desired "
- ++ "root directory.\n",
- commandNotes = Nothing,
- commandUsage = \pname ->
- "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n",
- commandDefaultFlags = IT.defaultInitFlags,
- commandOptions = initOptions
- }
+initCommand =
+ CommandUI
+ { commandName = "init"
+ , commandSynopsis = "Create a new cabal package."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "Create a .cabal, CHANGELOG.md, minimal initial Haskell code and optionally a LICENSE file.\n"
+ ++ "\n"
+ ++ "Calling init with no arguments runs interactive mode, "
+ ++ "which will try to guess as much as possible and prompt you for the rest.\n"
+ ++ "Non-interactive mode can be invoked by the -n/--non-interactive flag, "
+ ++ "which will let you specify the options via flags and will use the defaults for the rest.\n"
+ ++ "It is also possible to call init with a single argument, which denotes the project's desired "
+ ++ "root directory.\n"
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " init [PROJECT ROOT] [FLAGS]\n"
+ , commandDefaultFlags = IT.defaultInitFlags
+ , commandOptions = initOptions
+ }
initOptions :: ShowOrParseArgs -> [OptionField IT.InitFlags]
initOptions _ =
- [ option ['i'] ["interactive"]
- "interactive mode."
- IT.interactive (\v flags -> flags { IT.interactive = v })
- (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"]))
-
- , option ['q'] ["quiet"]
- "Do not generate log messages to stdout."
- IT.quiet (\v flags -> flags { IT.quiet = v })
- trueArg
-
- , option [] ["no-comments"]
- "Do not generate explanatory comments in the .cabal file."
- IT.noComments (\v flags -> flags { IT.noComments = v })
- trueArg
-
- , option ['m'] ["minimal"]
- "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments."
- IT.minimal (\v flags -> flags { IT.minimal = v })
- trueArg
-
- , option [] ["overwrite"]
- "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."
- IT.overwrite (\v flags -> flags { IT.overwrite = v })
- trueArg
-
- , option [] ["package-dir", "packagedir"]
- "Root directory of the package (default = current directory)."
- IT.packageDir (\v flags -> flags { IT.packageDir = v })
- (reqArgFlag "DIRECTORY")
-
- , option ['p'] ["package-name"]
- "Name of the Cabal package to create."
- IT.packageName (\v flags -> flags { IT.packageName = v })
- (reqArg "PACKAGE" (parsecToReadE ("Cannot parse package name: "++)
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option [] ["version"]
- "Initial version of the package."
- IT.version (\v flags -> flags { IT.version = v })
- (reqArg "VERSION" (parsecToReadE ("Cannot parse package version: "++)
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option [] ["cabal-version"]
- "Version of the Cabal specification."
- IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })
- (reqArg "CABALSPECVERSION" (parsecToReadE ("Cannot parse Cabal specification version: "++)
- (fmap (toFlag . getSpecVersion) parsec))
- (flagToList . fmap (prettyShow . SpecVersion)))
-
- , option ['l'] ["license"]
- "Project license."
- IT.license (\v flags -> flags { IT.license = v })
- (reqArg "LICENSE" (parsecToReadE ("Cannot parse license: "++)
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option ['a'] ["author"]
- "Name of the project's author."
- IT.author (\v flags -> flags { IT.author = v })
- (reqArgFlag "NAME")
-
- , option ['e'] ["email"]
- "Email address of the maintainer."
- IT.email (\v flags -> flags { IT.email = v })
- (reqArgFlag "EMAIL")
-
- , option ['u'] ["homepage"]
- "Project homepage and/or repository."
- IT.homepage (\v flags -> flags { IT.homepage = v })
- (reqArgFlag "URL")
-
- , option ['s'] ["synopsis"]
- "Short project synopsis."
- IT.synopsis (\v flags -> flags { IT.synopsis = v })
- (reqArgFlag "TEXT")
-
- , option ['c'] ["category"]
- "Project category."
- IT.category (\v flags -> flags { IT.category = v })
- (reqArgFlag "CATEGORY")
-
- , option ['x'] ["extra-source-file"]
- "Extra source file to be distributed with tarball."
- IT.extraSrc
- (\v flags -> flags { IT.extraSrc = mergeListFlag (IT.extraSrc flags) v })
- (reqArg' "FILE" (Flag . (:[]))
- (fromFlagOrDefault []))
- , option [] ["extra-doc-file"]
- "Extra doc file to be distributed with tarball."
- IT.extraDoc
- (\v flags -> flags { IT.extraDoc = mergeListFlag (IT.extraDoc flags) v })
- (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault []))
-
- , option [] ["lib", "is-library"]
- "Build a library."
- IT.packageType (\v flags -> flags { IT.packageType = v })
- (noArg (Flag IT.Library))
-
- , option [] ["exe", "is-executable"]
- "Build an executable."
- IT.packageType
- (\v flags -> flags { IT.packageType = v })
- (noArg (Flag IT.Executable))
-
- , option [] ["libandexe", "is-libandexe"]
- "Build a library and an executable."
- IT.packageType
- (\v flags -> flags { IT.packageType = v })
- (noArg (Flag IT.LibraryAndExecutable))
-
- , option [] ["tests"]
- "Generate a test suite, standalone or for a library."
- IT.initializeTestSuite
- (\v flags -> flags { IT.initializeTestSuite = v })
- trueArg
-
- , option [] ["test-dir"]
- "Directory containing tests."
- IT.testDirs (\v flags ->
- flags { IT.testDirs = mergeListFlag (IT.testDirs flags) v })
- (reqArg' "DIR" (Flag . (:[]))
- (fromFlagOrDefault []))
-
- , option [] ["simple"]
- "Create a simple project with sensible defaults."
- IT.simpleProject
- (\v flags -> flags { IT.simpleProject = v })
- trueArg
-
- , option [] ["main-is"]
- "Specify the main module."
- IT.mainIs
- (\v flags -> flags { IT.mainIs = v })
- (reqArgFlag "FILE")
-
- , option [] ["language"]
- "Specify the default language."
- IT.language
- (\v flags -> flags { IT.language = v })
- (reqArg "LANGUAGE" (parsecToReadE ("Cannot parse language: "++)
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- , option ['o'] ["expose-module"]
- "Export a module from the package."
- IT.exposedModules
- (\v flags -> flags { IT.exposedModules =
- mergeListFlag (IT.exposedModules flags) v})
- (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++)
- (Flag . (:[]) <$> parsec))
- (flagElim [] (fmap prettyShow)))
-
- , option [] ["extension"]
- "Use a LANGUAGE extension (in the other-extensions field)."
- IT.otherExts
- (\v flags -> flags { IT.otherExts =
- mergeListFlag (IT.otherExts flags) v })
- (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++)
- (Flag . (:[]) <$> parsec))
- (flagElim [] (fmap prettyShow)))
-
- , option ['d'] ["dependency"]
- "Package dependencies. Permits comma separated list of dependencies."
- IT.dependencies
- (\v flags -> flags { IT.dependencies =
- mergeListFlag (IT.dependencies flags) v })
- (reqArg "DEPENDENCIES" (fmap Flag dependenciesReadE)
- (fmap prettyShow . fromFlagOrDefault []))
-
- , option [] ["application-dir"]
- "Directory containing package application executable."
- IT.applicationDirs (\v flags -> flags { IT.applicationDirs =
- mergeListFlag (IT.applicationDirs flags) v})
- (reqArg' "DIR" (Flag . (:[]))
- (fromFlagOrDefault []))
-
- , option [] ["source-dir", "sourcedir"]
- "Directory containing package library source."
- IT.sourceDirs (\v flags -> flags { IT.sourceDirs =
- mergeListFlag (IT.sourceDirs flags) v })
- (reqArg' "DIR" (Flag. (:[]))
- (fromFlagOrDefault []))
-
- , option [] ["build-tool"]
- "Required external build tool."
- IT.buildTools (\v flags -> flags { IT.buildTools =
- mergeListFlag (IT.buildTools flags) v })
- (reqArg' "TOOL" (Flag . (:[]))
- (fromFlagOrDefault []))
-
- , option "w" ["with-compiler"]
- "give the path to a particular compiler. For 'init', this flag is used \
- \to set the bounds inferred for the 'base' package."
- IT.initHcPath (\v flags -> flags { IT.initHcPath = v })
- (reqArgFlag "PATH")
-
- , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })
+ [ option
+ ['i']
+ ["interactive"]
+ "interactive mode."
+ IT.interactive
+ (\v flags -> flags{IT.interactive = v})
+ (boolOpt' (['i'], ["interactive"]) (['n'], ["non-interactive"]))
+ , option
+ ['q']
+ ["quiet"]
+ "Do not generate log messages to stdout."
+ IT.quiet
+ (\v flags -> flags{IT.quiet = v})
+ trueArg
+ , option
+ []
+ ["no-comments"]
+ "Do not generate explanatory comments in the .cabal file."
+ IT.noComments
+ (\v flags -> flags{IT.noComments = v})
+ trueArg
+ , option
+ ['m']
+ ["minimal"]
+ "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments."
+ IT.minimal
+ (\v flags -> flags{IT.minimal = v})
+ trueArg
+ , option
+ []
+ ["overwrite"]
+ "Overwrite any existing .cabal, LICENSE, or Setup.hs files without warning."
+ IT.overwrite
+ (\v flags -> flags{IT.overwrite = v})
+ trueArg
+ , option
+ []
+ ["package-dir", "packagedir"]
+ "Root directory of the package (default = current directory)."
+ IT.packageDir
+ (\v flags -> flags{IT.packageDir = v})
+ (reqArgFlag "DIRECTORY")
+ , option
+ ['p']
+ ["package-name"]
+ "Name of the Cabal package to create."
+ IT.packageName
+ (\v flags -> flags{IT.packageName = v})
+ ( reqArg
+ "PACKAGE"
+ ( parsecToReadE
+ ("Cannot parse package name: " ++)
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ []
+ ["version"]
+ "Initial version of the package."
+ IT.version
+ (\v flags -> flags{IT.version = v})
+ ( reqArg
+ "VERSION"
+ ( parsecToReadE
+ ("Cannot parse package version: " ++)
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ []
+ ["cabal-version"]
+ "Version of the Cabal specification."
+ IT.cabalVersion
+ (\v flags -> flags{IT.cabalVersion = v})
+ ( reqArg
+ "CABALSPECVERSION"
+ ( parsecToReadE
+ ("Cannot parse Cabal specification version: " ++)
+ (fmap (toFlag . getSpecVersion) parsec)
+ )
+ (flagToList . fmap (prettyShow . SpecVersion))
+ )
+ , option
+ ['l']
+ ["license"]
+ "Project license."
+ IT.license
+ (\v flags -> flags{IT.license = v})
+ ( reqArg
+ "LICENSE"
+ ( parsecToReadE
+ ("Cannot parse license: " ++)
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ ['a']
+ ["author"]
+ "Name of the project's author."
+ IT.author
+ (\v flags -> flags{IT.author = v})
+ (reqArgFlag "NAME")
+ , option
+ ['e']
+ ["email"]
+ "Email address of the maintainer."
+ IT.email
+ (\v flags -> flags{IT.email = v})
+ (reqArgFlag "EMAIL")
+ , option
+ ['u']
+ ["homepage"]
+ "Project homepage and/or repository."
+ IT.homepage
+ (\v flags -> flags{IT.homepage = v})
+ (reqArgFlag "URL")
+ , option
+ ['s']
+ ["synopsis"]
+ "Short project synopsis."
+ IT.synopsis
+ (\v flags -> flags{IT.synopsis = v})
+ (reqArgFlag "TEXT")
+ , option
+ ['c']
+ ["category"]
+ "Project category."
+ IT.category
+ (\v flags -> flags{IT.category = v})
+ (reqArgFlag "CATEGORY")
+ , option
+ ['x']
+ ["extra-source-file"]
+ "Extra source file to be distributed with tarball."
+ IT.extraSrc
+ (\v flags -> flags{IT.extraSrc = mergeListFlag (IT.extraSrc flags) v})
+ ( reqArg'
+ "FILE"
+ (Flag . (: []))
+ (fromFlagOrDefault [])
+ )
+ , option
+ []
+ ["extra-doc-file"]
+ "Extra doc file to be distributed with tarball."
+ IT.extraDoc
+ (\v flags -> flags{IT.extraDoc = mergeListFlag (IT.extraDoc flags) v})
+ (reqArg' "FILE" (Flag . (: [])) (fromFlagOrDefault []))
+ , option
+ []
+ ["lib", "is-library"]
+ "Build a library."
+ IT.packageType
+ (\v flags -> flags{IT.packageType = v})
+ (noArg (Flag IT.Library))
+ , option
+ []
+ ["exe", "is-executable"]
+ "Build an executable."
+ IT.packageType
+ (\v flags -> flags{IT.packageType = v})
+ (noArg (Flag IT.Executable))
+ , option
+ []
+ ["libandexe", "is-libandexe"]
+ "Build a library and an executable."
+ IT.packageType
+ (\v flags -> flags{IT.packageType = v})
+ (noArg (Flag IT.LibraryAndExecutable))
+ , option
+ []
+ ["tests"]
+ "Generate a test suite, standalone or for a library."
+ IT.initializeTestSuite
+ (\v flags -> flags{IT.initializeTestSuite = v})
+ trueArg
+ , option
+ []
+ ["test-dir"]
+ "Directory containing tests."
+ IT.testDirs
+ ( \v flags ->
+ flags{IT.testDirs = mergeListFlag (IT.testDirs flags) v}
+ )
+ ( reqArg'
+ "DIR"
+ (Flag . (: []))
+ (fromFlagOrDefault [])
+ )
+ , option
+ []
+ ["simple"]
+ "Create a simple project with sensible defaults."
+ IT.simpleProject
+ (\v flags -> flags{IT.simpleProject = v})
+ trueArg
+ , option
+ []
+ ["main-is"]
+ "Specify the main module."
+ IT.mainIs
+ (\v flags -> flags{IT.mainIs = v})
+ (reqArgFlag "FILE")
+ , option
+ []
+ ["language"]
+ "Specify the default language."
+ IT.language
+ (\v flags -> flags{IT.language = v})
+ ( reqArg
+ "LANGUAGE"
+ ( parsecToReadE
+ ("Cannot parse language: " ++)
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ , option
+ ['o']
+ ["expose-module"]
+ "Export a module from the package."
+ IT.exposedModules
+ ( \v flags ->
+ flags
+ { IT.exposedModules =
+ mergeListFlag (IT.exposedModules flags) v
+ }
+ )
+ ( reqArg
+ "MODULE"
+ ( parsecToReadE
+ ("Cannot parse module name: " ++)
+ (Flag . (: []) <$> parsec)
+ )
+ (flagElim [] (fmap prettyShow))
+ )
+ , option
+ []
+ ["extension"]
+ "Use a LANGUAGE extension (in the other-extensions field)."
+ IT.otherExts
+ ( \v flags ->
+ flags
+ { IT.otherExts =
+ mergeListFlag (IT.otherExts flags) v
+ }
+ )
+ ( reqArg
+ "EXTENSION"
+ ( parsecToReadE
+ ("Cannot parse extension: " ++)
+ (Flag . (: []) <$> parsec)
+ )
+ (flagElim [] (fmap prettyShow))
+ )
+ , option
+ ['d']
+ ["dependency"]
+ "Package dependencies. Permits comma separated list of dependencies."
+ IT.dependencies
+ ( \v flags ->
+ flags
+ { IT.dependencies =
+ mergeListFlag (IT.dependencies flags) v
+ }
+ )
+ ( reqArg
+ "DEPENDENCIES"
+ (fmap Flag dependenciesReadE)
+ (fmap prettyShow . fromFlagOrDefault [])
+ )
+ , option
+ []
+ ["application-dir"]
+ "Directory containing package application executable."
+ IT.applicationDirs
+ ( \v flags ->
+ flags
+ { IT.applicationDirs =
+ mergeListFlag (IT.applicationDirs flags) v
+ }
+ )
+ ( reqArg'
+ "DIR"
+ (Flag . (: []))
+ (fromFlagOrDefault [])
+ )
+ , option
+ []
+ ["source-dir", "sourcedir"]
+ "Directory containing package library source."
+ IT.sourceDirs
+ ( \v flags ->
+ flags
+ { IT.sourceDirs =
+ mergeListFlag (IT.sourceDirs flags) v
+ }
+ )
+ ( reqArg'
+ "DIR"
+ (Flag . (: []))
+ (fromFlagOrDefault [])
+ )
+ , option
+ []
+ ["build-tool"]
+ "Required external build tool."
+ IT.buildTools
+ ( \v flags ->
+ flags
+ { IT.buildTools =
+ mergeListFlag (IT.buildTools flags) v
+ }
+ )
+ ( reqArg'
+ "TOOL"
+ (Flag . (: []))
+ (fromFlagOrDefault [])
+ )
+ , option
+ "w"
+ ["with-compiler"]
+ "give the path to a particular compiler. For 'init', this flag is used \
+ \to set the bounds inferred for the 'base' package."
+ IT.initHcPath
+ (\v flags -> flags{IT.initHcPath = v})
+ (reqArgFlag "PATH")
+ , optionVerbosity IT.initVerbosity (\v flags -> flags{IT.initVerbosity = v})
]
where
dependenciesReadE :: ReadE [Dependency]
@@ -2296,58 +3077,81 @@ initOptions _ =
Flag $ concat (flagToList currentFlags ++ flagToList v)
-- ------------------------------------------------------------
+
-- * Copy and Register
+
-- ------------------------------------------------------------
copyCommand :: CommandUI CopyFlags
-copyCommand = Cabal.copyCommand
- { commandNotes = Just $ \pname ->
- "Examples:\n"
- ++ " " ++ pname ++ " v1-copy "
- ++ " All the components in the package\n"
- ++ " " ++ pname ++ " v1-copy foo "
- ++ " A component (i.e. lib, exe, test suite)"
- , commandUsage = usageAlternatives "v1-copy" $
- [ "[FLAGS]"
- , "COMPONENTS [FLAGS]"
- ]
- }
+copyCommand =
+ Cabal.copyCommand
+ { commandNotes = Just $ \pname ->
+ "Examples:\n"
+ ++ " "
+ ++ pname
+ ++ " v1-copy "
+ ++ " All the components in the package\n"
+ ++ " "
+ ++ pname
+ ++ " v1-copy foo "
+ ++ " A component (i.e. lib, exe, test suite)"
+ , commandUsage =
+ usageAlternatives "v1-copy" $
+ [ "[FLAGS]"
+ , "COMPONENTS [FLAGS]"
+ ]
+ }
registerCommand :: CommandUI RegisterFlags
-registerCommand = Cabal.registerCommand
- { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n" }
+registerCommand =
+ Cabal.registerCommand
+ { commandUsage = \pname -> "Usage: " ++ pname ++ " v1-register [FLAGS]\n"
+ }
-- ------------------------------------------------------------
+
-- * ActAsSetup flags
+
-- ------------------------------------------------------------
-data ActAsSetupFlags = ActAsSetupFlags {
- actAsSetupBuildType :: Flag BuildType
-} deriving Generic
+data ActAsSetupFlags = ActAsSetupFlags
+ { actAsSetupBuildType :: Flag BuildType
+ }
+ deriving (Generic)
defaultActAsSetupFlags :: ActAsSetupFlags
-defaultActAsSetupFlags = ActAsSetupFlags {
- actAsSetupBuildType = toFlag Simple
-}
+defaultActAsSetupFlags =
+ ActAsSetupFlags
+ { actAsSetupBuildType = toFlag Simple
+ }
actAsSetupCommand :: CommandUI ActAsSetupFlags
-actAsSetupCommand = CommandUI {
- commandName = "act-as-setup",
- commandSynopsis = "Run as-if this was a Setup.hs",
- commandDescription = Nothing,
- commandNotes = Nothing,
- commandUsage = \pname ->
- "Usage: " ++ pname ++ " act-as-setup\n",
- commandDefaultFlags = defaultActAsSetupFlags,
- commandOptions = \_ ->
- [option "" ["build-type"]
- "Use the given build type."
- actAsSetupBuildType (\v flags -> flags { actAsSetupBuildType = v })
- (reqArg "BUILD-TYPE" (parsecToReadE ("Cannot parse build type: "++)
- (fmap toFlag parsec))
- (map prettyShow . flagToList))
- ]
-}
+actAsSetupCommand =
+ CommandUI
+ { commandName = "act-as-setup"
+ , commandSynopsis = "Run as-if this was a Setup.hs"
+ , commandDescription = Nothing
+ , commandNotes = Nothing
+ , commandUsage = \pname ->
+ "Usage: " ++ pname ++ " act-as-setup\n"
+ , commandDefaultFlags = defaultActAsSetupFlags
+ , commandOptions = \_ ->
+ [ option
+ ""
+ ["build-type"]
+ "Use the given build type."
+ actAsSetupBuildType
+ (\v flags -> flags{actAsSetupBuildType = v})
+ ( reqArg
+ "BUILD-TYPE"
+ ( parsecToReadE
+ ("Cannot parse build type: " ++)
+ (fmap toFlag parsec)
+ )
+ (map prettyShow . flagToList)
+ )
+ ]
+ }
instance Monoid ActAsSetupFlags where
mempty = gmempty
@@ -2357,182 +3161,274 @@ instance Semigroup ActAsSetupFlags where
(<>) = gmappend
-- ------------------------------------------------------------
+
-- * UserConfig flags
+
-- ------------------------------------------------------------
-data UserConfigFlags = UserConfigFlags {
- userConfigVerbosity :: Flag Verbosity,
- userConfigForce :: Flag Bool,
- userConfigAppendLines :: Flag [String]
- } deriving Generic
+data UserConfigFlags = UserConfigFlags
+ { userConfigVerbosity :: Flag Verbosity
+ , userConfigForce :: Flag Bool
+ , userConfigAppendLines :: Flag [String]
+ }
+ deriving (Generic)
instance Monoid UserConfigFlags where
- mempty = UserConfigFlags {
- userConfigVerbosity = toFlag normal,
- userConfigForce = toFlag False,
- userConfigAppendLines = toFlag []
- }
+ mempty =
+ UserConfigFlags
+ { userConfigVerbosity = toFlag normal
+ , userConfigForce = toFlag False
+ , userConfigAppendLines = toFlag []
+ }
mappend = (<>)
instance Semigroup UserConfigFlags where
(<>) = gmappend
userConfigCommand :: CommandUI UserConfigFlags
-userConfigCommand = CommandUI {
- commandName = "user-config",
- commandSynopsis = "Display and update the user's global cabal configuration.",
- commandDescription = Just $ \_ -> wrapText $
- "When upgrading cabal, the set of configuration keys and their default"
- ++ " values may change. This command provides means to merge the existing"
- ++ " config in ~/.config/cabal/config"
- ++ " (i.e. all bindings that are actually defined and not commented out)"
- ++ " and the default config of the new version.\n"
- ++ "\n"
- ++ "init: Creates a new config file at either ~/.config/cabal/config or as"
- ++ " specified by --config-file, if given. An existing file won't be "
- ++ " overwritten unless -f or --force is given.\n"
- ++ "diff: Shows a pseudo-diff of the user's ~/.config/cabal/config file and"
- ++ " the default configuration that would be created by cabal if the"
- ++ " config file did not exist.\n"
- ++ "update: Applies the pseudo-diff to the configuration that would be"
- ++ " created by default, and write the result back to ~/.config/cabal/config.",
-
- commandNotes = Nothing,
- commandUsage = usageAlternatives "user-config" ["init", "diff", "update"],
- commandDefaultFlags = mempty,
- commandOptions = \ _ -> [
- optionVerbosity userConfigVerbosity (\v flags -> flags { userConfigVerbosity = v })
- , option ['f'] ["force"]
- "Overwrite the config file if it already exists."
- userConfigForce (\v flags -> flags { userConfigForce = v })
- trueArg
- , option ['a'] ["augment"]
- "Additional setting to augment the config file (replacing a previous setting if it existed)."
- userConfigAppendLines (\v flags -> flags
- {userConfigAppendLines =
- Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)})
- (reqArg' "CONFIGLINE" (Flag . (:[])) (fromMaybe [] . flagToMaybe))
- ]
- }
-
+userConfigCommand =
+ CommandUI
+ { commandName = "user-config"
+ , commandSynopsis = "Display and update the user's global cabal configuration."
+ , commandDescription = Just $ \_ ->
+ wrapText $
+ "When upgrading cabal, the set of configuration keys and their default"
+ ++ " values may change. This command provides means to merge the existing"
+ ++ " config in ~/.config/cabal/config"
+ ++ " (i.e. all bindings that are actually defined and not commented out)"
+ ++ " and the default config of the new version.\n"
+ ++ "\n"
+ ++ "init: Creates a new config file at either ~/.config/cabal/config or as"
+ ++ " specified by --config-file, if given. An existing file won't be "
+ ++ " overwritten unless -f or --force is given.\n"
+ ++ "diff: Shows a pseudo-diff of the user's ~/.config/cabal/config file and"
+ ++ " the default configuration that would be created by cabal if the"
+ ++ " config file did not exist.\n"
+ ++ "update: Applies the pseudo-diff to the configuration that would be"
+ ++ " created by default, and write the result back to ~/.config/cabal/config."
+ , commandNotes = Nothing
+ , commandUsage = usageAlternatives "user-config" ["init", "diff", "update"]
+ , commandDefaultFlags = mempty
+ , commandOptions = \_ ->
+ [ optionVerbosity userConfigVerbosity (\v flags -> flags{userConfigVerbosity = v})
+ , option
+ ['f']
+ ["force"]
+ "Overwrite the config file if it already exists."
+ userConfigForce
+ (\v flags -> flags{userConfigForce = v})
+ trueArg
+ , option
+ ['a']
+ ["augment"]
+ "Additional setting to augment the config file (replacing a previous setting if it existed)."
+ userConfigAppendLines
+ ( \v flags ->
+ flags
+ { userConfigAppendLines =
+ Flag $ concat (flagToList (userConfigAppendLines flags) ++ flagToList v)
+ }
+ )
+ (reqArg' "CONFIGLINE" (Flag . (: [])) (fromMaybe [] . flagToMaybe))
+ ]
+ }
-- ------------------------------------------------------------
+
-- * GetOpt Utils
+
-- ------------------------------------------------------------
-reqArgFlag :: ArgPlaceHolder ->
- MkOptDescr (b -> Flag String) (Flag String -> b -> b) b
+reqArgFlag
+ :: ArgPlaceHolder
+ -> MkOptDescr (b -> Flag String) (Flag String -> b -> b) b
reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList
-liftOptions :: (b -> a) -> (a -> b -> b)
- -> [OptionField a] -> [OptionField b]
+liftOptions
+ :: (b -> a)
+ -> (a -> b -> b)
+ -> [OptionField a]
+ -> [OptionField b]
liftOptions get set = map (liftOption get set)
yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b
yesNoOpt ShowArgs sf lf = trueArg sf lf
-yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
+yesNoOpt _ sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf
-optionSolver :: (flags -> Flag PreSolver)
- -> (Flag PreSolver -> flags -> flags)
- -> OptionField flags
+optionSolver
+ :: (flags -> Flag PreSolver)
+ -> (Flag PreSolver -> flags -> flags)
+ -> OptionField flags
optionSolver get set =
- option [] ["solver"]
+ option
+ []
+ ["solver"]
("Select dependency solver to use (default: " ++ prettyShow defaultSolver ++ "). Choices: " ++ allSolvers ++ ".")
- get set
- (reqArg "SOLVER" (parsecToReadE (const $ "solver must be one of: " ++ allSolvers)
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
-optionSolverFlags :: ShowOrParseArgs
- -> (flags -> Flag Int ) -> (Flag Int -> flags -> flags)
- -> (flags -> Flag ReorderGoals) -> (Flag ReorderGoals -> flags -> flags)
- -> (flags -> Flag CountConflicts) -> (Flag CountConflicts -> flags -> flags)
- -> (flags -> Flag FineGrainedConflicts) -> (Flag FineGrainedConflicts -> flags -> flags)
- -> (flags -> Flag MinimizeConflictSet) -> (Flag MinimizeConflictSet -> flags -> flags)
- -> (flags -> Flag IndependentGoals) -> (Flag IndependentGoals -> flags -> flags)
- -> (flags -> Flag PreferOldest) -> (Flag PreferOldest -> flags -> flags)
- -> (flags -> Flag ShadowPkgs) -> (Flag ShadowPkgs -> flags -> flags)
- -> (flags -> Flag StrongFlags) -> (Flag StrongFlags -> flags -> flags)
- -> (flags -> Flag AllowBootLibInstalls) -> (Flag AllowBootLibInstalls -> flags -> flags)
- -> (flags -> Flag OnlyConstrained) -> (Flag OnlyConstrained -> flags -> flags)
- -> [OptionField flags]
-optionSolverFlags showOrParseArgs getmbj setmbj getrg setrg getcc setcc
- getfgc setfgc getmc setmc getig setig getpo setpo getsip setsip
- getstrfl setstrfl getib setib getoc setoc =
- [ option [] ["max-backjumps"]
- ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
- getmbj setmbj
- (reqArg "NUM" (parsecToReadE ("Cannot parse number: "++) (fmap toFlag P.signedIntegral))
- (map show . flagToList))
- , option [] ["reorder-goals"]
- "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
- (fmap asBool . getrg)
- (setrg . fmap ReorderGoals)
- (yesNoOpt showOrParseArgs)
- , option [] ["count-conflicts"]
- "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)."
- (fmap asBool . getcc)
- (setcc . fmap CountConflicts)
- (yesNoOpt showOrParseArgs)
- , option [] ["fine-grained-conflicts"]
- "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)."
- (fmap asBool . getfgc)
- (setfgc . fmap FineGrainedConflicts)
- (yesNoOpt showOrParseArgs)
- , option [] ["minimize-conflict-set"]
- ("When there is no solution, try to improve the error message by finding "
- ++ "a minimal conflict set (default: false). May increase run time "
- ++ "significantly.")
- (fmap asBool . getmc)
- (setmc . fmap MinimizeConflictSet)
- (yesNoOpt showOrParseArgs)
- , option [] ["independent-goals"]
- "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."
- (fmap asBool . getig)
- (setig . fmap IndependentGoals)
- (yesNoOpt showOrParseArgs)
- , option [] ["prefer-oldest"]
- "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section."
- (fmap asBool . getpo)
- (setpo . fmap PreferOldest)
- (yesNoOpt showOrParseArgs)
- , option [] ["shadow-installed-packages"]
- "If multiple package instances of the same version are installed, treat all but one as shadowed."
- (fmap asBool . getsip)
- (setsip . fmap ShadowPkgs)
- (yesNoOpt showOrParseArgs)
- , option [] ["strong-flags"]
- "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."
- (fmap asBool . getstrfl)
- (setstrfl . fmap StrongFlags)
- (yesNoOpt showOrParseArgs)
- , option [] ["allow-boot-library-installs"]
- "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell."
- (fmap asBool . getib)
- (setib . fmap AllowBootLibInstalls)
- (yesNoOpt showOrParseArgs)
- , option [] ["reject-unconstrained-dependencies"]
- "Require these packages to have constraints on them if they are to be selected (default: none)."
- getoc
- setoc
- (reqArg "none|all"
- (parsecToReadE
- (const "reject-unconstrained-dependencies must be 'none' or 'all'")
- (toFlag `fmap` parsec))
- (flagToList . fmap prettyShow))
-
- ]
+ get
+ set
+ ( reqArg
+ "SOLVER"
+ ( parsecToReadE
+ (const $ "solver must be one of: " ++ allSolvers)
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+
+optionSolverFlags
+ :: ShowOrParseArgs
+ -> (flags -> Flag Int)
+ -> (Flag Int -> flags -> flags)
+ -> (flags -> Flag ReorderGoals)
+ -> (Flag ReorderGoals -> flags -> flags)
+ -> (flags -> Flag CountConflicts)
+ -> (Flag CountConflicts -> flags -> flags)
+ -> (flags -> Flag FineGrainedConflicts)
+ -> (Flag FineGrainedConflicts -> flags -> flags)
+ -> (flags -> Flag MinimizeConflictSet)
+ -> (Flag MinimizeConflictSet -> flags -> flags)
+ -> (flags -> Flag IndependentGoals)
+ -> (Flag IndependentGoals -> flags -> flags)
+ -> (flags -> Flag PreferOldest)
+ -> (Flag PreferOldest -> flags -> flags)
+ -> (flags -> Flag ShadowPkgs)
+ -> (Flag ShadowPkgs -> flags -> flags)
+ -> (flags -> Flag StrongFlags)
+ -> (Flag StrongFlags -> flags -> flags)
+ -> (flags -> Flag AllowBootLibInstalls)
+ -> (Flag AllowBootLibInstalls -> flags -> flags)
+ -> (flags -> Flag OnlyConstrained)
+ -> (Flag OnlyConstrained -> flags -> flags)
+ -> [OptionField flags]
+optionSolverFlags
+ showOrParseArgs
+ getmbj
+ setmbj
+ getrg
+ setrg
+ getcc
+ setcc
+ getfgc
+ setfgc
+ getmc
+ setmc
+ getig
+ setig
+ getpo
+ setpo
+ getsip
+ setsip
+ getstrfl
+ setstrfl
+ getib
+ setib
+ getoc
+ setoc =
+ [ option
+ []
+ ["max-backjumps"]
+ ("Maximum number of backjumps allowed while solving (default: " ++ show defaultMaxBackjumps ++ "). Use a negative number to enable unlimited backtracking. Use 0 to disable backtracking completely.")
+ getmbj
+ setmbj
+ ( reqArg
+ "NUM"
+ (parsecToReadE ("Cannot parse number: " ++) (fmap toFlag P.signedIntegral))
+ (map show . flagToList)
+ )
+ , option
+ []
+ ["reorder-goals"]
+ "Try to reorder goals according to certain heuristics. Slows things down on average, but may make backtracking faster for some packages."
+ (fmap asBool . getrg)
+ (setrg . fmap ReorderGoals)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["count-conflicts"]
+ "Try to speed up solving by preferring goals that are involved in a lot of conflicts (default)."
+ (fmap asBool . getcc)
+ (setcc . fmap CountConflicts)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["fine-grained-conflicts"]
+ "Skip a version of a package if it does not resolve the conflicts encountered in the last version, as a solver optimization (default)."
+ (fmap asBool . getfgc)
+ (setfgc . fmap FineGrainedConflicts)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["minimize-conflict-set"]
+ ( "When there is no solution, try to improve the error message by finding "
+ ++ "a minimal conflict set (default: false). May increase run time "
+ ++ "significantly."
+ )
+ (fmap asBool . getmc)
+ (setmc . fmap MinimizeConflictSet)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["independent-goals"]
+ "Treat several goals on the command line as independent. If several goals depend on the same package, different versions can be chosen."
+ (fmap asBool . getig)
+ (setig . fmap IndependentGoals)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["prefer-oldest"]
+ "Prefer the oldest (instead of the latest) versions of packages available. Useful to determine lower bounds in the build-depends section."
+ (fmap asBool . getpo)
+ (setpo . fmap PreferOldest)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["shadow-installed-packages"]
+ "If multiple package instances of the same version are installed, treat all but one as shadowed."
+ (fmap asBool . getsip)
+ (setsip . fmap ShadowPkgs)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["strong-flags"]
+ "Do not defer flag choices (this used to be the default in cabal-install <= 1.20)."
+ (fmap asBool . getstrfl)
+ (setstrfl . fmap StrongFlags)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["allow-boot-library-installs"]
+ "Allow cabal to install base, ghc-prim, integer-simple, integer-gmp, and template-haskell."
+ (fmap asBool . getib)
+ (setib . fmap AllowBootLibInstalls)
+ (yesNoOpt showOrParseArgs)
+ , option
+ []
+ ["reject-unconstrained-dependencies"]
+ "Require these packages to have constraints on them if they are to be selected (default: none)."
+ getoc
+ setoc
+ ( reqArg
+ "none|all"
+ ( parsecToReadE
+ (const "reject-unconstrained-dependencies must be 'none' or 'all'")
+ (toFlag `fmap` parsec)
+ )
+ (flagToList . fmap prettyShow)
+ )
+ ]
usagePackages :: String -> String -> String
usagePackages name pname =
- "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"
+ "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n"
usageFlags :: String -> String -> String
usageFlags name pname =
"Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"
-- ------------------------------------------------------------
+
-- * Repo helpers
+
-- ------------------------------------------------------------
showRemoteRepo :: RemoteRepo -> String
@@ -2548,10 +3444,12 @@ readLocalRepo :: String -> Maybe LocalRepo
readLocalRepo = simpleParsec
-- ------------------------------------------------------------
+
-- * Helpers for Documentation
+
-- ------------------------------------------------------------
relevantConfigValuesText :: [String] -> String
relevantConfigValuesText vs =
- "Relevant global configuration keys:\n"
- ++ concat [" " ++ v ++ "\n" |v <- vs]
+ "Relevant global configuration keys:\n"
+ ++ concat [" " ++ v ++ "\n" | v <- vs]
diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs
index e4885ed07c639639200aeb2a805145725f7cbdf2..f48f37ae50bc1d3d6cbd7c17dbf4cce994a5c938 100644
--- a/cabal-install/src/Distribution/Client/SetupWrapper.hs
+++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs
@@ -1,7 +1,10 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
+{- FOURMOLU_DISABLE -}
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.SetupWrapper
-- Copyright : (c) The University of Glasgow 2006,
@@ -16,104 +19,168 @@
-- 'Custom', and the current version of Cabal is acceptable, this performs
-- setup actions directly. Otherwise it builds the setup script and
-- runs it with the given arguments.
-
-module Distribution.Client.SetupWrapper (
- getSetup, runSetup, runSetupCommand, setupWrapper,
- SetupScriptOptions(..),
- defaultSetupScriptOptions,
+module Distribution.Client.SetupWrapper
+ ( getSetup
+ , runSetup
+ , runSetupCommand
+ , setupWrapper
+ , SetupScriptOptions (..)
+ , defaultSetupScriptOptions
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
+import qualified Distribution.Backpack as Backpack
import Distribution.CabalSpecVersion (cabalSpecMinimumLibraryVersion)
+import Distribution.Compiler
+ ( CompilerFlavor (GHC, GHCJS)
+ , buildCompilerId
+ )
import qualified Distribution.Make as Make
-import qualified Distribution.Simple as Simple
-import Distribution.Version
- ( Version, mkVersion, versionNumbers, VersionRange, anyVersion
- , intersectVersionRanges, orLaterVersion
- , withinRange )
-import qualified Distribution.Backpack as Backpack
import Distribution.Package
- ( newSimpleUnitId, unsafeMkDefUnitId, ComponentId
- , PackageId, mkPackageName
- , PackageIdentifier(..), packageVersion, packageName )
+ ( ComponentId
+ , PackageId
+ , PackageIdentifier (..)
+ , mkPackageName
+ , newSimpleUnitId
+ , packageName
+ , packageVersion
+ , unsafeMkDefUnitId
+ )
import Distribution.PackageDescription
- ( GenericPackageDescription(packageDescription)
- , PackageDescription(..), specVersion, buildType
- , BuildType(..) )
-import Distribution.Types.ModuleRenaming (defaultRenaming)
-import Distribution.Simple.Configure
- ( configCompilerEx )
-import Distribution.Compiler
- ( buildCompilerId, CompilerFlavor(GHC, GHCJS) )
+ ( BuildType (..)
+ , GenericPackageDescription (packageDescription)
+ , PackageDescription (..)
+ , buildType
+ , specVersion
+ )
+import qualified Distribution.Simple as Simple
+import Distribution.Simple.Build.Macros
+ ( generatePackageVersionMacros
+ )
+import Distribution.Simple.BuildPaths
+ ( defaultDistPref
+ , exeExtension
+ )
import Distribution.Simple.Compiler
- ( Compiler(compilerId), compilerFlavor, PackageDB(..), PackageDBStack )
+ ( Compiler (compilerId)
+ , PackageDB (..)
+ , PackageDBStack
+ , compilerFlavor
+ )
+import Distribution.Simple.Configure
+ ( configCompilerEx
+ )
import Distribution.Simple.PackageDescription
- ( readGenericPackageDescription )
+ ( readGenericPackageDescription
+ )
import Distribution.Simple.PreProcess
- ( runSimplePreProcessor, ppUnlit )
-import Distribution.Simple.Build.Macros
- ( generatePackageVersionMacros )
+ ( ppUnlit
+ , runSimplePreProcessor
+ )
import Distribution.Simple.Program
- ( ProgramDb, emptyProgramDb
- , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram
- , ghcjsProgram )
+ ( ProgramDb
+ , emptyProgramDb
+ , getDbProgramOutput
+ , getProgramSearchPath
+ , ghcProgram
+ , ghcjsProgram
+ , runDbProgram
+ )
import Distribution.Simple.Program.Find
- ( programSearchPathAsPATHVar
- , ProgramSearchPathEntry(ProgramSearchPathDir) )
+ ( ProgramSearchPathEntry (ProgramSearchPathDir)
+ , programSearchPathAsPATHVar
+ )
import Distribution.Simple.Program.Run
- ( getEffectiveEnvironment )
+ ( getEffectiveEnvironment
+ )
import qualified Distribution.Simple.Program.Strip as Strip
-import Distribution.Simple.BuildPaths
- ( defaultDistPref, exeExtension )
+import Distribution.Types.ModuleRenaming (defaultRenaming)
+import Distribution.Version
+ ( Version
+ , VersionRange
+ , anyVersion
+ , intersectVersionRanges
+ , mkVersion
+ , orLaterVersion
+ , versionNumbers
+ , withinRange
+ )
-import Distribution.Simple.Command
- ( CommandUI(..), commandShowOptions )
-import Distribution.Simple.Program.GHC
- ( GhcMode(..), GhcOptions(..), renderGhcOptions )
-import qualified Distribution.Simple.PackageIndex as PackageIndex
-import Distribution.Simple.PackageIndex (InstalledPackageIndex)
-import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.Client.Types
import Distribution.Client.Config
- ( defaultCacheDir )
+ ( defaultCacheDir
+ )
import Distribution.Client.IndexUtils
- ( getInstalledPackages )
+ ( getInstalledPackages
+ )
import Distribution.Client.JobControl
- ( Lock, criticalSection )
-import Distribution.Simple.Setup
- ( Flag(..) )
-import Distribution.Utils.Generic
- ( safeHead )
-import Distribution.Simple.Utils
- ( die', debug, info, infoNoWrap, maybeExit
- , cabalVersion, tryFindPackageDesc, rawSystemProc
- , createDirectoryIfMissingVerbose, installExecutableFile
- , copyFileVerbose, rewriteFileEx, rewriteFileLBS )
+ ( Lock
+ , criticalSection
+ )
+import Distribution.Client.Types
import Distribution.Client.Utils
- ( inDir, tryCanonicalizePath, withExtraPathEnv
- , existsAndIsMoreRecentThan, moreRecentFile, withEnv, withEnvOverrides
+ ( existsAndIsMoreRecentThan
+ , inDir
#ifdef mingw32_HOST_OS
- , canonicalizePathNoThrow
+ , canonicalizePathNoThrow
#endif
- )
+ , moreRecentFile
+ , tryCanonicalizePath
+ , withEnv
+ , withEnvOverrides
+ , withExtraPathEnv
+ )
+import qualified Distribution.InstalledPackageInfo as IPI
+import Distribution.Simple.Command
+ ( CommandUI (..)
+ , commandShowOptions
+ )
+import Distribution.Simple.PackageIndex (InstalledPackageIndex)
+import qualified Distribution.Simple.PackageIndex as PackageIndex
+import Distribution.Simple.Program.GHC
+ ( GhcMode (..)
+ , GhcOptions (..)
+ , renderGhcOptions
+ )
+import Distribution.Simple.Setup
+ ( Flag (..)
+ )
+import Distribution.Simple.Utils
+ ( cabalVersion
+ , copyFileVerbose
+ , createDirectoryIfMissingVerbose
+ , debug
+ , die'
+ , info
+ , infoNoWrap
+ , installExecutableFile
+ , maybeExit
+ , rawSystemProc
+ , rewriteFileEx
+ , rewriteFileLBS
+ , tryFindPackageDesc
+ )
+import Distribution.Utils.Generic
+ ( safeHead
+ )
+import Distribution.Compat.Stack
import Distribution.ReadE
-import Distribution.System ( Platform(..), buildPlatform )
+import Distribution.System (Platform (..), buildPlatform)
import Distribution.Utils.NubList
- ( toNubListR )
+ ( toNubListR
+ )
import Distribution.Verbosity
-import Distribution.Compat.Stack
-import System.Directory ( doesFileExist )
-import System.FilePath ( (</>), (<.>) )
-import System.IO ( Handle, hPutStr )
+import Data.List (foldl1')
+import Distribution.Client.Compat.ExecutablePath (getExecutablePath)
import Distribution.Compat.Process (proc)
-import System.Process ( StdStream(..) )
+import System.Directory (doesFileExist)
+import System.FilePath ((<.>), (</>))
+import System.IO (Handle, hPutStr)
+import System.Process (StdStream (..))
import qualified System.Process as Process
-import Data.List ( foldl1' )
-import Distribution.Client.Compat.ExecutablePath ( getExecutablePath )
import qualified Data.ByteString.Lazy as BS
@@ -129,22 +196,24 @@ import qualified System.Win32 as Win32
-- | @Setup@ encapsulates the outcome of configuring a setup method to build a
-- particular package.
-data Setup = Setup { setupMethod :: SetupMethod
- , setupScriptOptions :: SetupScriptOptions
- , setupVersion :: Version
- , setupBuildType :: BuildType
- , setupPackage :: PackageDescription
- }
+data Setup = Setup
+ { setupMethod :: SetupMethod
+ , setupScriptOptions :: SetupScriptOptions
+ , setupVersion :: Version
+ , setupBuildType :: BuildType
+ , setupPackage :: PackageDescription
+ }
-- | @SetupMethod@ represents one of the methods used to run Cabal commands.
-data SetupMethod = InternalMethod
- -- ^ run Cabal commands through \"cabal\" in the
- -- current process
- | SelfExecMethod
- -- ^ run Cabal commands through \"cabal\" as a
- -- child process
- | ExternalMethod FilePath
- -- ^ run Cabal commands through a custom \"Setup\" executable
+data SetupMethod
+ = -- | run Cabal commands through \"cabal\" in the
+ -- current process
+ InternalMethod
+ | -- | run Cabal commands through \"cabal\" as a
+ -- child process
+ SelfExecMethod
+ | -- | run Cabal commands through a custom \"Setup\" executable
+ ExternalMethod FilePath
-- TODO: The 'setupWrapper' and 'SetupScriptOptions' should be split into two
-- parts: one that has no policy and just does as it's told with all the
@@ -157,71 +226,63 @@ data SetupMethod = InternalMethod
-- | @SetupScriptOptions@ are options used to configure and run 'Setup', as
-- opposed to options given to the Cabal command at runtime.
-data SetupScriptOptions = SetupScriptOptions {
- -- | The version of the Cabal library to use (if 'useDependenciesExclusive'
- -- is not set). A suitable version of the Cabal library must be installed
- -- (or for some build-types be the one cabal-install was built with).
- --
- -- The version found also determines the version of the Cabal specification
- -- that we us for talking to the Setup.hs, unless overridden by
- -- 'useCabalSpecVersion'.
- --
- useCabalVersion :: VersionRange,
-
- -- | This is the version of the Cabal specification that we believe that
- -- this package uses. This affects the semantics and in particular the
- -- Setup command line interface.
- --
- -- This is similar to 'useCabalVersion' but instead of probing the system
- -- for a version of the /Cabal library/ you just say exactly which version
- -- of the /spec/ we will use. Using this also avoid adding the Cabal
- -- library as an additional dependency, so add it to 'useDependencies'
- -- if needed.
- --
- useCabalSpecVersion :: Maybe Version,
- useCompiler :: Maybe Compiler,
- usePlatform :: Maybe Platform,
- usePackageDB :: PackageDBStack,
- usePackageIndex :: Maybe InstalledPackageIndex,
- useProgramDb :: ProgramDb,
- useDistPref :: FilePath,
- useLoggingHandle :: Maybe Handle,
- useWorkingDir :: Maybe FilePath,
- -- | Extra things to add to PATH when invoking the setup script.
- useExtraPathEnv :: [FilePath],
- -- | Extra environment variables paired with overrides, where
- --
- -- * @'Just' v@ means \"set the environment variable's value to @v@\".
- -- * 'Nothing' means \"unset the environment variable\".
- useExtraEnvOverrides :: [(String, Maybe FilePath)],
- forceExternalSetupMethod :: Bool,
-
- -- | List of dependencies to use when building Setup.hs.
- useDependencies :: [(ComponentId, PackageId)],
-
- -- | Is the list of setup dependencies exclusive?
- --
- -- When this is @False@, if we compile the Setup.hs script we do so with the
- -- list in 'useDependencies' but all other packages in the environment are
- -- also visible. A suitable version of @Cabal@ library (see
- -- 'useCabalVersion') is also added to the list of dependencies, unless
- -- 'useDependencies' already contains a Cabal dependency.
- --
- -- When @True@, only the 'useDependencies' packages are used, with other
- -- packages in the environment hidden.
- --
- -- This feature is here to support the setup stanza in .cabal files that
- -- specifies explicit (and exclusive) dependencies, as well as the old
- -- style with no dependencies.
- useDependenciesExclusive :: Bool,
-
- -- | Should we build the Setup.hs with CPP version macros available?
- -- We turn this on when we have a setup stanza in .cabal that declares
- -- explicit setup dependencies.
- --
- useVersionMacros :: Bool,
-
- -- Used only by 'cabal clean' on Windows.
+data SetupScriptOptions = SetupScriptOptions
+ { useCabalVersion :: VersionRange
+ -- ^ The version of the Cabal library to use (if 'useDependenciesExclusive'
+ -- is not set). A suitable version of the Cabal library must be installed
+ -- (or for some build-types be the one cabal-install was built with).
+ --
+ -- The version found also determines the version of the Cabal specification
+ -- that we us for talking to the Setup.hs, unless overridden by
+ -- 'useCabalSpecVersion'.
+ , useCabalSpecVersion :: Maybe Version
+ -- ^ This is the version of the Cabal specification that we believe that
+ -- this package uses. This affects the semantics and in particular the
+ -- Setup command line interface.
+ --
+ -- This is similar to 'useCabalVersion' but instead of probing the system
+ -- for a version of the /Cabal library/ you just say exactly which version
+ -- of the /spec/ we will use. Using this also avoid adding the Cabal
+ -- library as an additional dependency, so add it to 'useDependencies'
+ -- if needed.
+ , useCompiler :: Maybe Compiler
+ , usePlatform :: Maybe Platform
+ , usePackageDB :: PackageDBStack
+ , usePackageIndex :: Maybe InstalledPackageIndex
+ , useProgramDb :: ProgramDb
+ , useDistPref :: FilePath
+ , useLoggingHandle :: Maybe Handle
+ , useWorkingDir :: Maybe FilePath
+ , useExtraPathEnv :: [FilePath]
+ -- ^ Extra things to add to PATH when invoking the setup script.
+ , useExtraEnvOverrides :: [(String, Maybe FilePath)]
+ -- ^ Extra environment variables paired with overrides, where
+ --
+ -- * @'Just' v@ means \"set the environment variable's value to @v@\".
+ -- * 'Nothing' means \"unset the environment variable\".
+ , forceExternalSetupMethod :: Bool
+ , useDependencies :: [(ComponentId, PackageId)]
+ -- ^ List of dependencies to use when building Setup.hs.
+ , useDependenciesExclusive :: Bool
+ -- ^ Is the list of setup dependencies exclusive?
+ --
+ -- When this is @False@, if we compile the Setup.hs script we do so with the
+ -- list in 'useDependencies' but all other packages in the environment are
+ -- also visible. A suitable version of @Cabal@ library (see
+ -- 'useCabalVersion') is also added to the list of dependencies, unless
+ -- 'useDependencies' already contains a Cabal dependency.
+ --
+ -- When @True@, only the 'useDependencies' packages are used, with other
+ -- packages in the environment hidden.
+ --
+ -- This feature is here to support the setup stanza in .cabal files that
+ -- specifies explicit (and exclusive) dependencies, as well as the old
+ -- style with no dependencies.
+ , useVersionMacros :: Bool
+ -- ^ Should we build the Setup.hs with CPP version macros available?
+ -- We turn this on when we have a setup stanza in .cabal that declares
+ -- explicit setup dependencies.
+ , -- Used only by 'cabal clean' on Windows.
--
-- Note: win32 clean hack
-------------------------
@@ -230,9 +291,8 @@ data SetupScriptOptions = SetupScriptOptions {
-- unlike on Linux). So we have to move the setup exe out of the way first
-- and then delete it manually. This applies only to the external setup
-- method.
- useWin32CleanHack :: Bool,
-
- -- Used only when calling setupWrapper from parallel code to serialise
+ useWin32CleanHack :: Bool
+ , -- Used only when calling setupWrapper from parallel code to serialise
-- access to the setup cache; should be Nothing otherwise.
--
-- Note: setup exe cache
@@ -244,96 +304,105 @@ data SetupScriptOptions = SetupScriptOptions {
-- version) combination the cache holds a compiled setup script
-- executable. This only affects the Simple build type; for the Custom,
-- Configure and Make build types we always compile the setup script anew.
- setupCacheLock :: Maybe Lock,
-
- -- | Is the task we are going to run an interactive foreground task,
- -- or an non-interactive background task? Based on this flag we
- -- decide whether or not to delegate ctrl+c to the spawned task
- isInteractive :: Bool
+ setupCacheLock :: Maybe Lock
+ , isInteractive :: Bool
+ -- ^ Is the task we are going to run an interactive foreground task,
+ -- or an non-interactive background task? Based on this flag we
+ -- decide whether or not to delegate ctrl+c to the spawned task
}
defaultSetupScriptOptions :: SetupScriptOptions
-defaultSetupScriptOptions = SetupScriptOptions {
- useCabalVersion = anyVersion,
- useCabalSpecVersion = Nothing,
- useCompiler = Nothing,
- usePlatform = Nothing,
- usePackageDB = [GlobalPackageDB, UserPackageDB],
- usePackageIndex = Nothing,
- useDependencies = [],
- useDependenciesExclusive = False,
- useVersionMacros = False,
- useProgramDb = emptyProgramDb,
- useDistPref = defaultDistPref,
- useLoggingHandle = Nothing,
- useWorkingDir = Nothing,
- useExtraPathEnv = [],
- useExtraEnvOverrides = [],
- useWin32CleanHack = False,
- forceExternalSetupMethod = False,
- setupCacheLock = Nothing,
- isInteractive = False
- }
+defaultSetupScriptOptions =
+ SetupScriptOptions
+ { useCabalVersion = anyVersion
+ , useCabalSpecVersion = Nothing
+ , useCompiler = Nothing
+ , usePlatform = Nothing
+ , usePackageDB = [GlobalPackageDB, UserPackageDB]
+ , usePackageIndex = Nothing
+ , useDependencies = []
+ , useDependenciesExclusive = False
+ , useVersionMacros = False
+ , useProgramDb = emptyProgramDb
+ , useDistPref = defaultDistPref
+ , useLoggingHandle = Nothing
+ , useWorkingDir = Nothing
+ , useExtraPathEnv = []
+ , useExtraEnvOverrides = []
+ , useWin32CleanHack = False
+ , forceExternalSetupMethod = False
+ , setupCacheLock = Nothing
+ , isInteractive = False
+ }
workingDir :: SetupScriptOptions -> FilePath
workingDir options =
case fromMaybe "" (useWorkingDir options) of
- [] -> "."
+ [] -> "."
dir -> dir
-- | A @SetupRunner@ implements a 'SetupMethod'.
-type SetupRunner = Verbosity
- -> SetupScriptOptions
- -> BuildType
- -> [String]
- -> IO ()
+type SetupRunner =
+ Verbosity
+ -> SetupScriptOptions
+ -> BuildType
+ -> [String]
+ -> IO ()
-- | Prepare to build a package by configuring a 'SetupMethod'. The returned
-- 'Setup' object identifies the method. The 'SetupScriptOptions' may be changed
-- during the configuration process; the final values are given by
-- 'setupScriptOptions'.
-getSetup :: Verbosity
- -> SetupScriptOptions
- -> Maybe PackageDescription
- -> IO Setup
+getSetup
+ :: Verbosity
+ -> SetupScriptOptions
+ -> Maybe PackageDescription
+ -> IO Setup
getSetup verbosity options mpkg = do
pkg <- maybe getPkg return mpkg
- let options' = options {
- useCabalVersion = intersectVersionRanges
- (useCabalVersion options)
- (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))
- }
- buildType' = buildType pkg
+ let options' =
+ options
+ { useCabalVersion =
+ intersectVersionRanges
+ (useCabalVersion options)
+ (orLaterVersion (mkVersion (cabalSpecMinimumLibraryVersion (specVersion pkg))))
+ }
+ buildType' = buildType pkg
(version, method, options'') <-
getSetupMethod verbosity options' pkg buildType'
- return Setup { setupMethod = method
- , setupScriptOptions = options''
- , setupVersion = version
- , setupBuildType = buildType'
- , setupPackage = pkg
- }
+ return
+ Setup
+ { setupMethod = method
+ , setupScriptOptions = options''
+ , setupVersion = version
+ , setupBuildType = buildType'
+ , setupPackage = pkg
+ }
where
- getPkg = tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options))
- >>= readGenericPackageDescription verbosity
- >>= return . packageDescription
+ getPkg =
+ tryFindPackageDesc verbosity (fromMaybe "." (useWorkingDir options))
+ >>= readGenericPackageDescription verbosity
+ >>= return . packageDescription
-- | Decide if we're going to be able to do a direct internal call to the
-- entry point in the Cabal library or if we're going to have to compile
-- and execute an external Setup.hs script.
---
getSetupMethod
- :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType
+ :: Verbosity
+ -> SetupScriptOptions
+ -> PackageDescription
+ -> BuildType
-> IO (Version, SetupMethod, SetupScriptOptions)
getSetupMethod verbosity options pkg buildType'
| buildType' == Custom
- || maybe False (cabalVersion /=) (useCabalSpecVersion options)
- || not (cabalVersion `withinRange` useCabalVersion options) =
- getExternalSetupMethod verbosity options pkg buildType'
+ || maybe False (cabalVersion /=) (useCabalSpecVersion options)
+ || not (cabalVersion `withinRange` useCabalVersion options) =
+ getExternalSetupMethod verbosity options pkg buildType'
| isJust (useLoggingHandle options)
- -- Forcing is done to use an external process e.g. due to parallel
- -- build concerns.
- || forceExternalSetupMethod options =
- return (cabalVersion, SelfExecMethod, options)
+ -- Forcing is done to use an external process e.g. due to parallel
+ -- build concerns.
+ || forceExternalSetupMethod options =
+ return (cabalVersion, SelfExecMethod, options)
| otherwise = return (cabalVersion, InternalMethod, options)
runSetupMethod :: WithCallStack (SetupMethod -> SetupRunner)
@@ -342,9 +411,12 @@ runSetupMethod (ExternalMethod path) = externalSetupMethod path
runSetupMethod SelfExecMethod = selfExecSetupMethod
-- | Run a configured 'Setup' with specific arguments.
-runSetup :: Verbosity -> Setup
- -> [String] -- ^ command-line arguments
- -> IO ()
+runSetup
+ :: Verbosity
+ -> Setup
+ -> [String]
+ -- ^ command-line arguments
+ -> IO ()
runSetup verbosity setup args0 = do
let method = setupMethod setup
options = setupScriptOptions setup
@@ -352,9 +424,13 @@ runSetup verbosity setup args0 = do
args = verbosityHack (setupVersion setup) args0
when (verbosity >= deafening {- avoid test if not debug -} && args /= args0) $
infoNoWrap verbose $
- "Applied verbosity hack:\n" ++
- " Before: " ++ show args0 ++ "\n" ++
- " After: " ++ show args ++ "\n"
+ "Applied verbosity hack:\n"
+ ++ " Before: "
+ ++ show args0
+ ++ "\n"
+ ++ " After: "
+ ++ show args
+ ++ "\n"
runSetupMethod method verbosity options bt args
-- | This is a horrible hack to make sure passing fancy verbosity
@@ -363,66 +439,82 @@ runSetup verbosity setup args0 = do
-- verbosity applies to ALL commands.
verbosityHack :: Version -> [String] -> [String]
verbosityHack ver args0
- | ver >= mkVersion [2,1] = args0
- | otherwise = go args0
+ | ver >= mkVersion [2, 1] = args0
+ | otherwise = go args0
where
- go (('-':'v':rest) : args)
- | Just rest' <- munch rest = ("-v" ++ rest') : go args
- go (('-':'-':'v':'e':'r':'b':'o':'s':'e':'=':rest) : args)
- | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args
+ go (('-' : 'v' : rest) : args)
+ | Just rest' <- munch rest = ("-v" ++ rest') : go args
+ go (('-' : '-' : 'v' : 'e' : 'r' : 'b' : 'o' : 's' : 'e' : '=' : rest) : args)
+ | Just rest' <- munch rest = ("--verbose=" ++ rest') : go args
go ("--verbose" : rest : args)
- | Just rest' <- munch rest = "--verbose" : rest' : go args
+ | Just rest' <- munch rest = "--verbose" : rest' : go args
go rest@("--" : _) = rest
- go (arg:args) = arg : go args
+ go (arg : args) = arg : go args
go [] = []
munch rest =
- case runReadE flagToVerbosity rest of
- Right v
- | ver < mkVersion [2,0], verboseHasFlags v
+ case runReadE flagToVerbosity rest of
+ Right v
+ | ver < mkVersion [2, 0]
+ , verboseHasFlags v ->
-- We could preserve the prefix, but since we're assuming
-- it's Cabal's verbosity flag, we can assume that
-- any format is OK
- -> Just (showForCabal (verboseNoFlags v))
- | ver < mkVersion [2,1], isVerboseTimestamp v
+ Just (showForCabal (verboseNoFlags v))
+ | ver < mkVersion [2, 1]
+ , isVerboseTimestamp v ->
-- +timestamp wasn't yet available in Cabal-2.0.0
- -> Just (showForCabal (verboseNoTimestamp v))
- _ -> Nothing
+ Just (showForCabal (verboseNoTimestamp v))
+ _ -> Nothing
-- | Run a command through a configured 'Setup'.
-runSetupCommand :: Verbosity -> Setup
- -> CommandUI flags -- ^ command definition
- -> flags -- ^ command flags
- -> [String] -- ^ extra command-line arguments
- -> IO ()
+runSetupCommand
+ :: Verbosity
+ -> Setup
+ -> CommandUI flags
+ -- ^ command definition
+ -> flags
+ -- ^ command flags
+ -> [String]
+ -- ^ extra command-line arguments
+ -> IO ()
runSetupCommand verbosity setup cmd flags extraArgs = do
let args = commandName cmd : commandShowOptions cmd flags ++ extraArgs
runSetup verbosity setup args
-- | Configure a 'Setup' and run a command in one step. The command flags
-- may depend on the Cabal library version in use.
-setupWrapper :: Verbosity
- -> SetupScriptOptions
- -> Maybe PackageDescription
- -> CommandUI flags
- -> (Version -> flags)
- -- ^ produce command flags given the Cabal library version
- -> (Version -> [String])
- -> IO ()
+setupWrapper
+ :: Verbosity
+ -> SetupScriptOptions
+ -> Maybe PackageDescription
+ -> CommandUI flags
+ -> (Version -> flags)
+ -- ^ produce command flags given the Cabal library version
+ -> (Version -> [String])
+ -> IO ()
setupWrapper verbosity options mpkg cmd flags extraArgs = do
setup <- getSetup verbosity options mpkg
- runSetupCommand verbosity setup
- cmd (flags $ setupVersion setup)
- (extraArgs $ setupVersion setup)
+ runSetupCommand
+ verbosity
+ setup
+ cmd
+ (flags $ setupVersion setup)
+ (extraArgs $ setupVersion setup)
-- ------------------------------------------------------------
+
-- * Internal SetupMethod
+
-- ------------------------------------------------------------
internalSetupMethod :: SetupRunner
internalSetupMethod verbosity options bt args = do
- info verbosity $ "Using internal setup method with build-type " ++ show bt
- ++ " and args:\n " ++ show args
+ info verbosity $
+ "Using internal setup method with build-type "
+ ++ show bt
+ ++ " and args:\n "
+ ++ show args
inDir (useWorkingDir options) $ do
withEnv "HASKELL_DIST_DIR" (useDistPref options) $
withExtraPathEnv (useExtraPathEnv options) $
@@ -430,65 +522,86 @@ internalSetupMethod verbosity options bt args = do
buildTypeAction bt args
buildTypeAction :: BuildType -> ([String] -> IO ())
-buildTypeAction Simple = Simple.defaultMainArgs
-buildTypeAction Configure = Simple.defaultMainWithHooksArgs
- Simple.autoconfUserHooks
-buildTypeAction Make = Make.defaultMainArgs
-buildTypeAction Custom = error "buildTypeAction Custom"
+buildTypeAction Simple = Simple.defaultMainArgs
+buildTypeAction Configure =
+ Simple.defaultMainWithHooksArgs
+ Simple.autoconfUserHooks
+buildTypeAction Make = Make.defaultMainArgs
+buildTypeAction Custom = error "buildTypeAction Custom"
invoke :: Verbosity -> FilePath -> [String] -> SetupScriptOptions -> IO ()
invoke verbosity path args options = do
info verbosity $ unwords (path : args)
case useLoggingHandle options of
- Nothing -> return ()
+ Nothing -> return ()
Just logHandle -> info verbosity $ "Redirecting build log to " ++ show logHandle
- searchpath <- programSearchPathAsPATHVar
- (map ProgramSearchPathDir (useExtraPathEnv options) ++
- getProgramSearchPath (useProgramDb options))
- env <- getEffectiveEnvironment $
- [ ("PATH", Just searchpath)
- , ("HASKELL_DIST_DIR", Just (useDistPref options))
- ] ++ useExtraEnvOverrides options
+ searchpath <-
+ programSearchPathAsPATHVar
+ ( map ProgramSearchPathDir (useExtraPathEnv options)
+ ++ getProgramSearchPath (useProgramDb options)
+ )
+ env <-
+ getEffectiveEnvironment $
+ [ ("PATH", Just searchpath)
+ , ("HASKELL_DIST_DIR", Just (useDistPref options))
+ ]
+ ++ useExtraEnvOverrides options
let loggingHandle = case useLoggingHandle options of
- Nothing -> Inherit
- Just hdl -> UseHandle hdl
- cp = (proc path args) { Process.cwd = useWorkingDir options
- , Process.env = env
- , Process.std_out = loggingHandle
- , Process.std_err = loggingHandle
- , Process.delegate_ctlc = isInteractive options
- }
+ Nothing -> Inherit
+ Just hdl -> UseHandle hdl
+ cp =
+ (proc path args)
+ { Process.cwd = useWorkingDir options
+ , Process.env = env
+ , Process.std_out = loggingHandle
+ , Process.std_err = loggingHandle
+ , Process.delegate_ctlc = isInteractive options
+ }
maybeExit $ rawSystemProc verbosity cp
-- ------------------------------------------------------------
+
-- * Self-Exec SetupMethod
+
-- ------------------------------------------------------------
selfExecSetupMethod :: SetupRunner
selfExecSetupMethod verbosity options bt args0 = do
- let args = ["act-as-setup",
- "--build-type=" ++ prettyShow bt,
- "--"] ++ args0
- info verbosity $ "Using self-exec internal setup method with build-type "
- ++ show bt ++ " and args:\n " ++ show args
+ let args =
+ [ "act-as-setup"
+ , "--build-type=" ++ prettyShow bt
+ , "--"
+ ]
+ ++ args0
+ info verbosity $
+ "Using self-exec internal setup method with build-type "
+ ++ show bt
+ ++ " and args:\n "
+ ++ show args
path <- getExecutablePath
invoke verbosity path args options
-- ------------------------------------------------------------
+
-- * External SetupMethod
+
-- ------------------------------------------------------------
externalSetupMethod :: WithCallStack (FilePath -> SetupRunner)
externalSetupMethod path verbosity options _ args =
#ifndef mingw32_HOST_OS
- invoke verbosity path args options
+ invoke
+ verbosity
+ path
+ args
+ options
#else
- -- See 'Note: win32 clean hack' above.
- if useWin32CleanHack options
- then invokeWithWin32CleanHack path
- else invoke' path
+ -- See 'Note: win32 clean hack' above.
+ if useWin32CleanHack options
+ then invokeWithWin32CleanHack path
+ else invoke' path
where
invoke' p = invoke verbosity p args options
@@ -496,9 +609,10 @@ externalSetupMethod path verbosity options _ args =
info verbosity $ "Using the Win32 clean hack."
-- Recursively removes the temp dir on exit.
withTempDirectory verbosity (workingDir options) "cabal-tmp" $ \tmpDir ->
- bracket (moveOutOfTheWay tmpDir origPath)
- (\tmpPath -> maybeRestore origPath tmpPath)
- (\tmpPath -> invoke' tmpPath)
+ bracket
+ (moveOutOfTheWay tmpDir origPath)
+ (\tmpPath -> maybeRestore origPath tmpPath)
+ (\tmpPath -> invoke' tmpPath)
moveOutOfTheWay tmpDir origPath = do
let tmpPath = tmpDir </> "setup" <.> exeExtension buildPlatform
@@ -511,23 +625,36 @@ externalSetupMethod path verbosity options _ args =
-- 'setup clean' didn't complete, 'dist/setup' still exists.
when origPathDirExists $
Win32.moveFile tmpPath origPath
+
#endif
getExternalSetupMethod
- :: Verbosity -> SetupScriptOptions -> PackageDescription -> BuildType
+ :: Verbosity
+ -> SetupScriptOptions
+ -> PackageDescription
+ -> BuildType
-> IO (Version, SetupMethod, SetupScriptOptions)
getExternalSetupMethod verbosity options pkg bt = do
debug verbosity $ "Using external setup method with build-type " ++ show bt
- debug verbosity $ "Using explicit dependencies: "
- ++ show (useDependenciesExclusive options)
+ debug verbosity $
+ "Using explicit dependencies: "
+ ++ show (useDependenciesExclusive options)
createDirectoryIfMissingVerbose verbosity True setupDir
(cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse
debug verbosity $ "Using Cabal library version " ++ prettyShow cabalLibVersion
- path <- if useCachedSetupExecutable
- then getCachedSetupExecutable options'
- cabalLibVersion mCabalLibInstalledPkgId
- else compileSetupExecutable options'
- cabalLibVersion mCabalLibInstalledPkgId False
+ path <-
+ if useCachedSetupExecutable
+ then
+ getCachedSetupExecutable
+ options'
+ cabalLibVersion
+ mCabalLibInstalledPkgId
+ else
+ compileSetupExecutable
+ options'
+ cabalLibVersion
+ mCabalLibInstalledPkgId
+ False
-- Since useWorkingDir can change the relative path, the path argument must
-- be turned into an absolute path. On some systems, runProcess' will take
@@ -539,337 +666,431 @@ getExternalSetupMethod verbosity options pkg bt = do
#ifdef mingw32_HOST_OS
-- setupProgFile may not exist if we're using a cached program
setupProgFile' <- canonicalizePathNoThrow setupProgFile
- let win32CleanHackNeeded = (useWin32CleanHack options)
- -- Skip when a cached setup script is used.
- && setupProgFile' `equalFilePath` path'
+ let win32CleanHackNeeded =
+ (useWin32CleanHack options)
+ -- Skip when a cached setup script is used.
+ && setupProgFile' `equalFilePath` path'
#else
let win32CleanHackNeeded = False
#endif
- let options'' = options' { useWin32CleanHack = win32CleanHackNeeded }
+ let options'' = options'{useWin32CleanHack = win32CleanHackNeeded}
return (cabalLibVersion, ExternalMethod path', options'')
-
where
- setupDir = workingDir options </> useDistPref options </> "setup"
- setupVersionFile = setupDir </> "setup" <.> "version"
- setupHs = setupDir </> "setup" <.> "hs"
- setupProgFile = setupDir </> "setup" <.> exeExtension buildPlatform
- platform = fromMaybe buildPlatform (usePlatform options)
-
- useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)
-
- maybeGetInstalledPackages :: SetupScriptOptions -> Compiler
- -> ProgramDb -> IO InstalledPackageIndex
- maybeGetInstalledPackages options' comp progdb =
- case usePackageIndex options' of
- Just index -> return index
- Nothing -> getInstalledPackages verbosity
- comp (usePackageDB options') progdb
-
- -- Choose the version of Cabal to use if the setup script has a dependency on
- -- Cabal, and possibly update the setup script options. The version also
- -- determines how to filter the flags to Setup.
- --
- -- We first check whether the dependency solver has specified a Cabal version.
- -- If it has, we use the solver's version without looking at the installed
- -- package index (See issue #3436). Otherwise, we pick the Cabal version by
- -- checking 'useCabalSpecVersion', then the saved version, and finally the
- -- versions available in the index.
- --
- -- The version chosen here must match the one used in 'compileSetupExecutable'
- -- (See issue #3433).
- cabalLibVersionToUse :: IO (Version, Maybe ComponentId
- ,SetupScriptOptions)
- cabalLibVersionToUse =
- case find (isCabalPkgId . snd) (useDependencies options) of
- Just (unitId, pkgId) -> do
- let version = pkgVersion pkgId
- updateSetupScript version bt
- writeSetupVersionFile version
- return (version, Just unitId, options)
- Nothing ->
- case useCabalSpecVersion options of
- Just version -> do
- updateSetupScript version bt
- writeSetupVersionFile version
- return (version, Nothing, options)
- Nothing -> do
- savedVer <- savedVersion
- case savedVer of
- Just version | version `withinRange` useCabalVersion options
- -> do updateSetupScript version bt
- -- Does the previously compiled setup executable
- -- still exist and is it up-to date?
- useExisting <- canUseExistingSetup version
- if useExisting
- then return (version, Nothing, options)
- else installedVersion
- _ -> installedVersion
- where
- -- This check duplicates the checks in 'getCachedSetupExecutable' /
- -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice
- -- because the selected Cabal version may change as a result of this
- -- check.
- canUseExistingSetup :: Version -> IO Bool
- canUseExistingSetup version =
- if useCachedSetupExecutable
- then do
- (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version
- doesFileExist cachedSetupProgFile
- else
- (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs
- <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile
-
- writeSetupVersionFile :: Version -> IO ()
- writeSetupVersionFile version =
+ setupDir = workingDir options </> useDistPref options </> "setup"
+ setupVersionFile = setupDir </> "setup" <.> "version"
+ setupHs = setupDir </> "setup" <.> "hs"
+ setupProgFile = setupDir </> "setup" <.> exeExtension buildPlatform
+ platform = fromMaybe buildPlatform (usePlatform options)
+
+ useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)
+
+ maybeGetInstalledPackages
+ :: SetupScriptOptions
+ -> Compiler
+ -> ProgramDb
+ -> IO InstalledPackageIndex
+ maybeGetInstalledPackages options' comp progdb =
+ case usePackageIndex options' of
+ Just index -> return index
+ Nothing ->
+ getInstalledPackages
+ verbosity
+ comp
+ (usePackageDB options')
+ progdb
+
+ -- Choose the version of Cabal to use if the setup script has a dependency on
+ -- Cabal, and possibly update the setup script options. The version also
+ -- determines how to filter the flags to Setup.
+ --
+ -- We first check whether the dependency solver has specified a Cabal version.
+ -- If it has, we use the solver's version without looking at the installed
+ -- package index (See issue #3436). Otherwise, we pick the Cabal version by
+ -- checking 'useCabalSpecVersion', then the saved version, and finally the
+ -- versions available in the index.
+ --
+ -- The version chosen here must match the one used in 'compileSetupExecutable'
+ -- (See issue #3433).
+ cabalLibVersionToUse
+ :: IO
+ ( Version
+ , Maybe ComponentId
+ , SetupScriptOptions
+ )
+ cabalLibVersionToUse =
+ case find (isCabalPkgId . snd) (useDependencies options) of
+ Just (unitId, pkgId) -> do
+ let version = pkgVersion pkgId
+ updateSetupScript version bt
+ writeSetupVersionFile version
+ return (version, Just unitId, options)
+ Nothing ->
+ case useCabalSpecVersion options of
+ Just version -> do
+ updateSetupScript version bt
+ writeSetupVersionFile version
+ return (version, Nothing, options)
+ Nothing -> do
+ savedVer <- savedVersion
+ case savedVer of
+ Just version | version `withinRange` useCabalVersion options ->
+ do
+ updateSetupScript version bt
+ -- Does the previously compiled setup executable
+ -- still exist and is it up-to date?
+ useExisting <- canUseExistingSetup version
+ if useExisting
+ then return (version, Nothing, options)
+ else installedVersion
+ _ -> installedVersion
+ where
+ -- This check duplicates the checks in 'getCachedSetupExecutable' /
+ -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice
+ -- because the selected Cabal version may change as a result of this
+ -- check.
+ canUseExistingSetup :: Version -> IO Bool
+ canUseExistingSetup version =
+ if useCachedSetupExecutable
+ then do
+ (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version
+ doesFileExist cachedSetupProgFile
+ else
+ (&&)
+ <$> setupProgFile `existsAndIsMoreRecentThan` setupHs
+ <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile
+
+ writeSetupVersionFile :: Version -> IO ()
+ writeSetupVersionFile version =
writeFile setupVersionFile (show version ++ "\n")
- installedVersion :: IO (Version, Maybe InstalledPackageId
- ,SetupScriptOptions)
- installedVersion = do
- (comp, progdb, options') <- configureCompiler options
- (version, mipkgid, options'') <- installedCabalVersion options'
- comp progdb
- updateSetupScript version bt
- writeSetupVersionFile version
- return (version, mipkgid, options'')
-
- savedVersion :: IO (Maybe Version)
- savedVersion = do
- versionString <- readFile setupVersionFile `catchIO` \_ -> return ""
- case reads versionString of
- [(version,s)] | all isSpace s -> return (Just version)
- _ -> return Nothing
-
- -- | Update a Setup.hs script, creating it if necessary.
- updateSetupScript :: Version -> BuildType -> IO ()
- updateSetupScript _ Custom = do
- useHs <- doesFileExist customSetupHs
- useLhs <- doesFileExist customSetupLhs
- unless (useHs || useLhs) $ die' verbosity
- "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."
- let src = (if useHs then customSetupHs else customSetupLhs)
- srcNewer <- src `moreRecentFile` setupHs
- when srcNewer $ if useHs
- then copyFileVerbose verbosity src setupHs
- else runSimplePreProcessor ppUnlit src setupHs verbosity
- where
- customSetupHs = workingDir options </> "Setup.hs"
- customSetupLhs = workingDir options </> "Setup.lhs"
-
- updateSetupScript cabalLibVersion _ =
- rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion)
-
- buildTypeScript :: Version -> BS.ByteString
- buildTypeScript cabalLibVersion = case bt of
- Simple -> "import Distribution.Simple; main = defaultMain\n"
- Configure | cabalLibVersion >= mkVersion [1,3,10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"
- | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"
- Make -> "import Distribution.Make; main = defaultMain\n"
- Custom -> error "buildTypeScript Custom"
-
- installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramDb
- -> IO (Version, Maybe InstalledPackageId
- ,SetupScriptOptions)
- installedCabalVersion options' _ _ | packageName pkg == mkPackageName "Cabal"
- && bt == Custom =
- return (packageVersion pkg, Nothing, options')
- installedCabalVersion options' compiler progdb = do
- index <- maybeGetInstalledPackages options' compiler progdb
- let cabalDepName = mkPackageName "Cabal"
- cabalDepVersion = useCabalVersion options'
- options'' = options' { usePackageIndex = Just index }
- case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of
- [] -> die' verbosity $ "The package '" ++ prettyShow (packageName pkg)
- ++ "' requires Cabal library version "
- ++ prettyShow (useCabalVersion options)
- ++ " but no suitable version is installed."
- pkgs -> let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs
- err = error "Distribution.Client.installedCabalVersion: empty version list"
- in return (packageVersion ipkginfo
- ,Just . IPI.installedComponentId $ ipkginfo, options'')
-
- bestVersion :: (a -> Version) -> [a] -> a
- bestVersion f = firstMaximumBy (comparing (preference . f))
- where
- -- Like maximumBy, but picks the first maximum element instead of the
- -- last. In general, we expect the preferred version to go first in the
- -- list. For the default case, this has the effect of choosing the version
- -- installed in the user package DB instead of the global one. See #1463.
- --
- -- Note: firstMaximumBy could be written as just
- -- `maximumBy cmp . reverse`, but the problem is that the behaviour of
- -- maximumBy is not fully specified in the case when there is not a single
- -- greatest element.
- firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a
- firstMaximumBy _ [] =
- error "Distribution.Client.firstMaximumBy: empty list"
- firstMaximumBy cmp xs = foldl1' maxBy xs
- where
- maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; }
-
- preference version = (sameVersion, sameMajorVersion
- ,stableVersion, latestVersion)
- where
- sameVersion = version == cabalVersion
- sameMajorVersion = majorVersion version == majorVersion cabalVersion
- majorVersion = take 2 . versionNumbers
- stableVersion = case versionNumbers version of
- (_:x:_) -> even x
- _ -> False
- latestVersion = version
-
- configureCompiler :: SetupScriptOptions
- -> IO (Compiler, ProgramDb, SetupScriptOptions)
- configureCompiler options' = do
- (comp, progdb) <- case useCompiler options' of
- Just comp -> return (comp, useProgramDb options')
- Nothing -> do (comp, _, progdb) <-
- configCompilerEx (Just GHC) Nothing Nothing
- (useProgramDb options') verbosity
- return (comp, progdb)
- -- Whenever we need to call configureCompiler, we also need to access the
- -- package index, so let's cache it in SetupScriptOptions.
- index <- maybeGetInstalledPackages options' comp progdb
- return (comp, progdb, options' { useCompiler = Just comp,
- usePackageIndex = Just index,
- useProgramDb = progdb })
-
- -- | Path to the setup exe cache directory and path to the cached setup
- -- executable.
- cachedSetupDirAndProg :: SetupScriptOptions -> Version
- -> IO (FilePath, FilePath)
- cachedSetupDirAndProg options' cabalLibVersion = do
- cacheDir <- defaultCacheDir
- let setupCacheDir = cacheDir </> "setup-exe-cache"
- cachedSetupProgFile = setupCacheDir
- </> ("setup-" ++ buildTypeString ++ "-"
- ++ cabalVersionString ++ "-"
- ++ platformString ++ "-"
- ++ compilerVersionString)
- <.> exeExtension buildPlatform
- return (setupCacheDir, cachedSetupProgFile)
+ installedVersion
+ :: IO
+ ( Version
+ , Maybe InstalledPackageId
+ , SetupScriptOptions
+ )
+ installedVersion = do
+ (comp, progdb, options') <- configureCompiler options
+ (version, mipkgid, options'') <-
+ installedCabalVersion
+ options'
+ comp
+ progdb
+ updateSetupScript version bt
+ writeSetupVersionFile version
+ return (version, mipkgid, options'')
+
+ savedVersion :: IO (Maybe Version)
+ savedVersion = do
+ versionString <- readFile setupVersionFile `catchIO` \_ -> return ""
+ case reads versionString of
+ [(version, s)] | all isSpace s -> return (Just version)
+ _ -> return Nothing
+
+ -- \| Update a Setup.hs script, creating it if necessary.
+ updateSetupScript :: Version -> BuildType -> IO ()
+ updateSetupScript _ Custom = do
+ useHs <- doesFileExist customSetupHs
+ useLhs <- doesFileExist customSetupLhs
+ unless (useHs || useLhs) $
+ die'
+ verbosity
+ "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."
+ let src = (if useHs then customSetupHs else customSetupLhs)
+ srcNewer <- src `moreRecentFile` setupHs
+ when srcNewer $
+ if useHs
+ then copyFileVerbose verbosity src setupHs
+ else runSimplePreProcessor ppUnlit src setupHs verbosity
where
- buildTypeString = show bt
- cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion
- compilerVersionString = prettyShow $
- maybe buildCompilerId compilerId
- $ useCompiler options'
- platformString = prettyShow platform
-
- -- | Look up the setup executable in the cache; update the cache if the setup
- -- executable is not found.
- getCachedSetupExecutable :: SetupScriptOptions
- -> Version -> Maybe InstalledPackageId
- -> IO FilePath
- getCachedSetupExecutable options' cabalLibVersion
- maybeCabalLibInstalledPkgId = do
- (setupCacheDir, cachedSetupProgFile) <-
- cachedSetupDirAndProg options' cabalLibVersion
- cachedSetupExists <- doesFileExist cachedSetupProgFile
- if cachedSetupExists
- then debug verbosity $
- "Found cached setup executable: " ++ cachedSetupProgFile
- else criticalSection' $ do
- -- The cache may have been populated while we were waiting.
- cachedSetupExists' <- doesFileExist cachedSetupProgFile
- if cachedSetupExists'
- then debug verbosity $
- "Found cached setup executable: " ++ cachedSetupProgFile
- else do
- debug verbosity $ "Setup executable not found in the cache."
- src <- compileSetupExecutable options'
- cabalLibVersion maybeCabalLibInstalledPkgId True
- createDirectoryIfMissingVerbose verbosity True setupCacheDir
- installExecutableFile verbosity src cachedSetupProgFile
- -- Do not strip if we're using GHCJS, since the result may be a script
- when (maybe True ((/=GHCJS).compilerFlavor) $ useCompiler options') $
- Strip.stripExe verbosity platform (useProgramDb options')
- cachedSetupProgFile
- return cachedSetupProgFile
+ customSetupHs = workingDir options </> "Setup.hs"
+ customSetupLhs = workingDir options </> "Setup.lhs"
+ updateSetupScript cabalLibVersion _ =
+ rewriteFileLBS verbosity setupHs (buildTypeScript cabalLibVersion)
+
+ buildTypeScript :: Version -> BS.ByteString
+ buildTypeScript cabalLibVersion = case bt of
+ Simple -> "import Distribution.Simple; main = defaultMain\n"
+ Configure
+ | cabalLibVersion >= mkVersion [1, 3, 10] -> "import Distribution.Simple; main = defaultMainWithHooks autoconfUserHooks\n"
+ | otherwise -> "import Distribution.Simple; main = defaultMainWithHooks defaultUserHooks\n"
+ Make -> "import Distribution.Make; main = defaultMain\n"
+ Custom -> error "buildTypeScript Custom"
+
+ installedCabalVersion
+ :: SetupScriptOptions
+ -> Compiler
+ -> ProgramDb
+ -> IO
+ ( Version
+ , Maybe InstalledPackageId
+ , SetupScriptOptions
+ )
+ installedCabalVersion options' _ _
+ | packageName pkg == mkPackageName "Cabal"
+ && bt == Custom =
+ return (packageVersion pkg, Nothing, options')
+ installedCabalVersion options' compiler progdb = do
+ index <- maybeGetInstalledPackages options' compiler progdb
+ let cabalDepName = mkPackageName "Cabal"
+ cabalDepVersion = useCabalVersion options'
+ options'' = options'{usePackageIndex = Just index}
+ case PackageIndex.lookupDependency index cabalDepName cabalDepVersion of
+ [] ->
+ die' verbosity $
+ "The package '"
+ ++ prettyShow (packageName pkg)
+ ++ "' requires Cabal library version "
+ ++ prettyShow (useCabalVersion options)
+ ++ " but no suitable version is installed."
+ pkgs ->
+ let ipkginfo = fromMaybe err $ safeHead . snd . bestVersion fst $ pkgs
+ err = error "Distribution.Client.installedCabalVersion: empty version list"
+ in return
+ ( packageVersion ipkginfo
+ , Just . IPI.installedComponentId $ ipkginfo
+ , options''
+ )
+
+ bestVersion :: (a -> Version) -> [a] -> a
+ bestVersion f = firstMaximumBy (comparing (preference . f))
where
- criticalSection' = maybe id criticalSection $ setupCacheLock options'
-
- -- | If the Setup.hs is out of date wrt the executable then recompile it.
- -- Currently this is GHC/GHCJS only. It should really be generalised.
- --
- compileSetupExecutable :: SetupScriptOptions
- -> Version -> Maybe ComponentId -> Bool
- -> IO FilePath
- compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId
- forceCompile = do
- setupHsNewer <- setupHs `moreRecentFile` setupProgFile
- cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile
- let outOfDate = setupHsNewer || cabalVersionNewer
- when (outOfDate || forceCompile) $ do
- debug verbosity "Setup executable needs to be updated, compiling..."
- (compiler, progdb, options'') <- configureCompiler options'
- let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion
- (program, extraOpts)
- = case compilerFlavor compiler of
- GHCJS -> (ghcjsProgram, ["-build-runner"])
- _ -> (ghcProgram, ["-threaded"])
- cabalDep = maybe [] (\ipkgid -> [(ipkgid, cabalPkgid)])
- maybeCabalLibInstalledPkgId
-
- -- With 'useDependenciesExclusive' we enforce the deps specified,
- -- so only the given ones can be used. Otherwise we allow the use
- -- of packages in the ambient environment, and add on a dep on the
- -- Cabal library (unless 'useDependencies' already contains one).
- --
- -- With 'useVersionMacros' we use a version CPP macros .h file.
- --
- -- Both of these options should be enabled for packages that have
- -- opted-in and declared a custom-settup stanza.
- --
- selectedDeps | useDependenciesExclusive options'
- = useDependencies options'
- | otherwise = useDependencies options' ++
- if any (isCabalPkgId . snd)
- (useDependencies options')
- then []
- else cabalDep
- addRenaming (ipid, _) =
- -- Assert 'DefUnitId' invariant
- (Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))
- ,defaultRenaming)
- cppMacrosFile = setupDir </> "setup_macros.h"
- ghcOptions = mempty {
- -- Respect -v0, but don't crank up verbosity on GHC if
- -- Cabal verbosity is requested. For that, use
- -- --ghc-option=-v instead!
- ghcOptVerbosity = Flag (min verbosity normal)
- , ghcOptMode = Flag GhcModeMake
- , ghcOptInputFiles = toNubListR [setupHs]
- , ghcOptOutputFile = Flag setupProgFile
- , ghcOptObjDir = Flag setupDir
- , ghcOptHiDir = Flag setupDir
- , ghcOptSourcePathClear = Flag True
- , ghcOptSourcePath = case bt of
- Custom -> toNubListR [workingDir options']
- _ -> mempty
- , ghcOptPackageDBs = usePackageDB options''
- , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')
- , ghcOptCabal = Flag (useDependenciesExclusive options')
- , ghcOptPackages = toNubListR $ map addRenaming selectedDeps
- , ghcOptCppIncludes = toNubListR [ cppMacrosFile
- | useVersionMacros options' ]
- , ghcOptExtra = extraOpts
+ -- Like maximumBy, but picks the first maximum element instead of the
+ -- last. In general, we expect the preferred version to go first in the
+ -- list. For the default case, this has the effect of choosing the version
+ -- installed in the user package DB instead of the global one. See #1463.
+ --
+ -- Note: firstMaximumBy could be written as just
+ -- `maximumBy cmp . reverse`, but the problem is that the behaviour of
+ -- maximumBy is not fully specified in the case when there is not a single
+ -- greatest element.
+ firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a
+ firstMaximumBy _ [] =
+ error "Distribution.Client.firstMaximumBy: empty list"
+ firstMaximumBy cmp xs = foldl1' maxBy xs
+ where
+ maxBy x y = case cmp x y of GT -> x; EQ -> x; LT -> y
+
+ preference version =
+ ( sameVersion
+ , sameMajorVersion
+ , stableVersion
+ , latestVersion
+ )
+ where
+ sameVersion = version == cabalVersion
+ sameMajorVersion = majorVersion version == majorVersion cabalVersion
+ majorVersion = take 2 . versionNumbers
+ stableVersion = case versionNumbers version of
+ (_ : x : _) -> even x
+ _ -> False
+ latestVersion = version
+
+ configureCompiler
+ :: SetupScriptOptions
+ -> IO (Compiler, ProgramDb, SetupScriptOptions)
+ configureCompiler options' = do
+ (comp, progdb) <- case useCompiler options' of
+ Just comp -> return (comp, useProgramDb options')
+ Nothing -> do
+ (comp, _, progdb) <-
+ configCompilerEx
+ (Just GHC)
+ Nothing
+ Nothing
+ (useProgramDb options')
+ verbosity
+ return (comp, progdb)
+ -- Whenever we need to call configureCompiler, we also need to access the
+ -- package index, so let's cache it in SetupScriptOptions.
+ index <- maybeGetInstalledPackages options' comp progdb
+ return
+ ( comp
+ , progdb
+ , options'
+ { useCompiler = Just comp
+ , usePackageIndex = Just index
+ , useProgramDb = progdb
}
- let ghcCmdLine = renderGhcOptions compiler platform ghcOptions
- when (useVersionMacros options') $
- rewriteFileEx verbosity cppMacrosFile
- $ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)
- case useLoggingHandle options of
- Nothing -> runDbProgram verbosity program progdb ghcCmdLine
-
- -- If build logging is enabled, redirect compiler output to
- -- the log file.
- (Just logHandle) -> do output <- getDbProgramOutput verbosity program
- progdb ghcCmdLine
- hPutStr logHandle output
- return setupProgFile
-
+ )
+
+ -- \| Path to the setup exe cache directory and path to the cached setup
+ -- executable.
+ cachedSetupDirAndProg
+ :: SetupScriptOptions
+ -> Version
+ -> IO (FilePath, FilePath)
+ cachedSetupDirAndProg options' cabalLibVersion = do
+ cacheDir <- defaultCacheDir
+ let setupCacheDir = cacheDir </> "setup-exe-cache"
+ cachedSetupProgFile =
+ setupCacheDir
+ </> ( "setup-"
+ ++ buildTypeString
+ ++ "-"
+ ++ cabalVersionString
+ ++ "-"
+ ++ platformString
+ ++ "-"
+ ++ compilerVersionString
+ )
+ <.> exeExtension buildPlatform
+ return (setupCacheDir, cachedSetupProgFile)
+ where
+ buildTypeString = show bt
+ cabalVersionString = "Cabal-" ++ prettyShow cabalLibVersion
+ compilerVersionString =
+ prettyShow $
+ maybe buildCompilerId compilerId $
+ useCompiler options'
+ platformString = prettyShow platform
+
+ -- \| Look up the setup executable in the cache; update the cache if the setup
+ -- executable is not found.
+ getCachedSetupExecutable
+ :: SetupScriptOptions
+ -> Version
+ -> Maybe InstalledPackageId
+ -> IO FilePath
+ getCachedSetupExecutable
+ options'
+ cabalLibVersion
+ maybeCabalLibInstalledPkgId = do
+ (setupCacheDir, cachedSetupProgFile) <-
+ cachedSetupDirAndProg options' cabalLibVersion
+ cachedSetupExists <- doesFileExist cachedSetupProgFile
+ if cachedSetupExists
+ then
+ debug verbosity $
+ "Found cached setup executable: " ++ cachedSetupProgFile
+ else criticalSection' $ do
+ -- The cache may have been populated while we were waiting.
+ cachedSetupExists' <- doesFileExist cachedSetupProgFile
+ if cachedSetupExists'
+ then
+ debug verbosity $
+ "Found cached setup executable: " ++ cachedSetupProgFile
+ else do
+ debug verbosity $ "Setup executable not found in the cache."
+ src <-
+ compileSetupExecutable
+ options'
+ cabalLibVersion
+ maybeCabalLibInstalledPkgId
+ True
+ createDirectoryIfMissingVerbose verbosity True setupCacheDir
+ installExecutableFile verbosity src cachedSetupProgFile
+ -- Do not strip if we're using GHCJS, since the result may be a script
+ when (maybe True ((/= GHCJS) . compilerFlavor) $ useCompiler options') $
+ Strip.stripExe
+ verbosity
+ platform
+ (useProgramDb options')
+ cachedSetupProgFile
+ return cachedSetupProgFile
+ where
+ criticalSection' = maybe id criticalSection $ setupCacheLock options'
+
+ -- \| If the Setup.hs is out of date wrt the executable then recompile it.
+ -- Currently this is GHC/GHCJS only. It should really be generalised.
+ compileSetupExecutable
+ :: SetupScriptOptions
+ -> Version
+ -> Maybe ComponentId
+ -> Bool
+ -> IO FilePath
+ compileSetupExecutable
+ options'
+ cabalLibVersion
+ maybeCabalLibInstalledPkgId
+ forceCompile = do
+ setupHsNewer <- setupHs `moreRecentFile` setupProgFile
+ cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile
+ let outOfDate = setupHsNewer || cabalVersionNewer
+ when (outOfDate || forceCompile) $ do
+ debug verbosity "Setup executable needs to be updated, compiling..."
+ (compiler, progdb, options'') <- configureCompiler options'
+ let cabalPkgid = PackageIdentifier (mkPackageName "Cabal") cabalLibVersion
+ (program, extraOpts) =
+ case compilerFlavor compiler of
+ GHCJS -> (ghcjsProgram, ["-build-runner"])
+ _ -> (ghcProgram, ["-threaded"])
+ cabalDep =
+ maybe
+ []
+ (\ipkgid -> [(ipkgid, cabalPkgid)])
+ maybeCabalLibInstalledPkgId
+
+ -- With 'useDependenciesExclusive' we enforce the deps specified,
+ -- so only the given ones can be used. Otherwise we allow the use
+ -- of packages in the ambient environment, and add on a dep on the
+ -- Cabal library (unless 'useDependencies' already contains one).
+ --
+ -- With 'useVersionMacros' we use a version CPP macros .h file.
+ --
+ -- Both of these options should be enabled for packages that have
+ -- opted-in and declared a custom-settup stanza.
+ --
+ selectedDeps
+ | useDependenciesExclusive options' =
+ useDependencies options'
+ | otherwise =
+ useDependencies options'
+ ++ if any
+ (isCabalPkgId . snd)
+ (useDependencies options')
+ then []
+ else cabalDep
+ addRenaming (ipid, _) =
+ -- Assert 'DefUnitId' invariant
+ ( Backpack.DefiniteUnitId (unsafeMkDefUnitId (newSimpleUnitId ipid))
+ , defaultRenaming
+ )
+ cppMacrosFile = setupDir </> "setup_macros.h"
+ ghcOptions =
+ mempty
+ { -- Respect -v0, but don't crank up verbosity on GHC if
+ -- Cabal verbosity is requested. For that, use
+ -- --ghc-option=-v instead!
+ ghcOptVerbosity = Flag (min verbosity normal)
+ , ghcOptMode = Flag GhcModeMake
+ , ghcOptInputFiles = toNubListR [setupHs]
+ , ghcOptOutputFile = Flag setupProgFile
+ , ghcOptObjDir = Flag setupDir
+ , ghcOptHiDir = Flag setupDir
+ , ghcOptSourcePathClear = Flag True
+ , ghcOptSourcePath = case bt of
+ Custom -> toNubListR [workingDir options']
+ _ -> mempty
+ , ghcOptPackageDBs = usePackageDB options''
+ , ghcOptHideAllPackages = Flag (useDependenciesExclusive options')
+ , ghcOptCabal = Flag (useDependenciesExclusive options')
+ , ghcOptPackages = toNubListR $ map addRenaming selectedDeps
+ , ghcOptCppIncludes =
+ toNubListR
+ [ cppMacrosFile
+ | useVersionMacros options'
+ ]
+ , ghcOptExtra = extraOpts
+ }
+ let ghcCmdLine = renderGhcOptions compiler platform ghcOptions
+ when (useVersionMacros options') $
+ rewriteFileEx verbosity cppMacrosFile $
+ generatePackageVersionMacros (pkgVersion $ package pkg) (map snd selectedDeps)
+ case useLoggingHandle options of
+ Nothing -> runDbProgram verbosity program progdb ghcCmdLine
+ -- If build logging is enabled, redirect compiler output to
+ -- the log file.
+ (Just logHandle) -> do
+ output <-
+ getDbProgramOutput
+ verbosity
+ program
+ progdb
+ ghcCmdLine
+ hPutStr logHandle output
+ return setupProgFile
isCabalPkgId :: PackageIdentifier -> Bool
isCabalPkgId (PackageIdentifier pname _) = pname == mkPackageName "Cabal"
diff --git a/cabal-install/src/Distribution/Client/Signal.hs b/cabal-install/src/Distribution/Client/Signal.hs
index 726fd8cbcc3d60a4b99936b5d8d299deb87b38e5..c009d805cd44161c0f1a2aa1f1a10726d92b9c2a 100644
--- a/cabal-install/src/Distribution/Client/Signal.hs
+++ b/cabal-install/src/Distribution/Client/Signal.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE CPP #-}
+
module Distribution.Client.Signal
( installTerminationHandler
- , Terminated(..)
+ , Terminated (..)
)
where
@@ -30,7 +31,6 @@ instance Show Terminated where
-- called from the main thread.
--
-- It is a noop on Windows.
---
installTerminationHandler :: IO ()
#ifdef mingw32_HOST_OS
diff --git a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
index 02ac3973218a9e79517fd2239b44809bc90b314b..f4422080a4b657d47c69bb15938f1855a473b08a 100644
--- a/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
+++ b/cabal-install/src/Distribution/Client/SolverInstallPlan.hs
@@ -1,7 +1,11 @@
-{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
+
-----------------------------------------------------------------------------
+
+-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.SolverInstallPlan
-- Copyright : (c) Duncan Coutts 2008
@@ -16,74 +20,78 @@
-- things are going to be installed. To put it another way: the
-- dependency solver produces a 'SolverInstallPlan', which is then
-- consumed by various other parts of Cabal.
---
------------------------------------------------------------------------------
-module Distribution.Client.SolverInstallPlan(
- SolverInstallPlan(..),
- SolverPlanPackage,
- ResolverPackage(..),
-
- -- * Operations on 'SolverInstallPlan's
- new,
- toList,
- toMap,
-
- remove,
-
- showPlanIndex,
- showInstallPlan,
-
- -- * Checking validity of plans
- valid,
- closed,
- consistent,
- acyclic,
-
- -- ** Details on invalid plans
- SolverPlanProblem(..),
- showPlanProblem,
- problems,
-
- -- ** Querying the install plan
- dependencyClosure,
- reverseDependencyClosure,
- topologicalOrder,
- reverseTopologicalOrder,
-) where
+module Distribution.Client.SolverInstallPlan
+ ( SolverInstallPlan (..)
+ , SolverPlanPackage
+ , ResolverPackage (..)
+
+ -- * Operations on 'SolverInstallPlan's
+ , new
+ , toList
+ , toMap
+ , remove
+ , showPlanIndex
+ , showInstallPlan
+
+ -- * Checking validity of plans
+ , valid
+ , closed
+ , consistent
+ , acyclic
+
+ -- ** Details on invalid plans
+ , SolverPlanProblem (..)
+ , showPlanProblem
+ , problems
+
+ -- ** Querying the install plan
+ , dependencyClosure
+ , reverseDependencyClosure
+ , topologicalOrder
+ , reverseTopologicalOrder
+ ) where
import Distribution.Client.Compat.Prelude hiding (toList)
import Prelude ()
import Distribution.Package
- ( PackageIdentifier(..), Package(..), PackageName
- , HasUnitId(..), PackageId, packageVersion, packageName )
-import Distribution.Types.Flag (nullFlagAssignment)
+ ( HasUnitId (..)
+ , Package (..)
+ , PackageId
+ , PackageIdentifier (..)
+ , PackageName
+ , packageName
+ , packageVersion
+ )
import qualified Distribution.Solver.Types.ComponentDeps as CD
+import Distribution.Types.Flag (nullFlagAssignment)
import Distribution.Client.Types
- ( UnresolvedPkgLoc )
+ ( UnresolvedPkgLoc
+ )
import Distribution.Version
- ( Version )
+ ( Version
+ )
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.ResolverPackage
-import Distribution.Solver.Types.SolverId
-import Distribution.Solver.Types.SolverPackage
+import Distribution.Solver.Types.ResolverPackage
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SolverId
+import Distribution.Solver.Types.SolverPackage
-import Distribution.Compat.Graph (Graph, IsNode(..))
+import Data.Array ((!))
import qualified Data.Foldable as Foldable
import qualified Data.Graph as OldGraph
-import qualified Distribution.Compat.Graph as Graph
import qualified Data.Map as Map
-import Data.Array ((!))
+import Distribution.Compat.Graph (Graph, IsNode (..))
+import qualified Distribution.Compat.Graph as Graph
type SolverPlanPackage = ResolverPackage UnresolvedPkgLoc
type SolverPlanIndex = Graph SolverPlanPackage
-data SolverInstallPlan = SolverInstallPlan {
- planIndex :: !SolverPlanIndex,
- planIndepGoals :: !IndependentGoals
+data SolverInstallPlan = SolverInstallPlan
+ { planIndex :: !SolverPlanIndex
+ , planIndepGoals :: !IndependentGoals
}
deriving (Typeable, Generic)
@@ -99,8 +107,6 @@ planPkgOf plan v =
Nothing -> error "InstallPlan: internal error: planPkgOf lookup failed"
-}
-
-
instance Binary SolverInstallPlan
instance Structured SolverInstallPlan
@@ -111,33 +117,38 @@ showInstallPlan :: SolverInstallPlan -> String
showInstallPlan = showPlanIndex . toList
showPlanPackage :: SolverPlanPackage -> String
-showPlanPackage (PreExisting ipkg) = "PreExisting " ++ prettyShow (packageId ipkg)
- ++ " (" ++ prettyShow (installedUnitId ipkg)
- ++ ")"
-showPlanPackage (Configured spkg) =
- "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps
+showPlanPackage (PreExisting ipkg) =
+ "PreExisting "
+ ++ prettyShow (packageId ipkg)
+ ++ " ("
+ ++ prettyShow (installedUnitId ipkg)
+ ++ ")"
+showPlanPackage (Configured spkg) =
+ "Configured " ++ prettyShow (packageId spkg) ++ flags ++ comps
where
flags
- | nullFlagAssignment fa = ""
- | otherwise = " " ++ prettyShow (solverPkgFlags spkg)
+ | nullFlagAssignment fa = ""
+ | otherwise = " " ++ prettyShow (solverPkgFlags spkg)
where
fa = solverPkgFlags spkg
- comps | null deps = ""
- | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps)
+ comps
+ | null deps = ""
+ | otherwise = " " ++ unwords (map prettyShow $ Foldable.toList deps)
where
deps :: Set CD.Component
- deps = CD.components (solverPkgLibDeps spkg)
- <> CD.components (solverPkgExeDeps spkg)
+ deps =
+ CD.components (solverPkgLibDeps spkg)
+ <> CD.components (solverPkgExeDeps spkg)
-- | Build an installation plan from a valid set of resolved packages.
---
-new :: IndependentGoals
- -> SolverPlanIndex
- -> Either [SolverPlanProblem] SolverInstallPlan
+new
+ :: IndependentGoals
+ -> SolverPlanIndex
+ -> Either [SolverPlanProblem] SolverInstallPlan
new indepGoals index =
case problems indepGoals index of
- [] -> Right (SolverInstallPlan index indepGoals)
+ [] -> Right (SolverInstallPlan index indepGoals)
probs -> Left probs
toList :: SolverInstallPlan -> [SolverPlanPackage]
@@ -151,19 +162,23 @@ toMap = Graph.toMap . planIndex
-- package. This is primarily useful for obtaining an install plan for
-- the dependencies of a package or set of packages without actually
-- installing the package itself, as when doing development.
---
-remove :: (SolverPlanPackage -> Bool)
- -> SolverInstallPlan
- -> Either [SolverPlanProblem]
- (SolverInstallPlan)
+remove
+ :: (SolverPlanPackage -> Bool)
+ -> SolverInstallPlan
+ -> Either
+ [SolverPlanProblem]
+ (SolverInstallPlan)
remove shouldRemove plan =
- new (planIndepGoals plan) newIndex
+ new (planIndepGoals plan) newIndex
where
- newIndex = Graph.fromDistinctList $
- filter (not . shouldRemove) (toList plan)
+ newIndex =
+ Graph.fromDistinctList $
+ filter (not . shouldRemove) (toList plan)
-- ------------------------------------------------------------
+
-- * Checking validity of plans
+
-- ------------------------------------------------------------
-- | A valid installation plan is a set of packages that is 'acyclic',
@@ -171,76 +186,87 @@ remove shouldRemove plan =
-- plan has to have a valid configuration (see 'configuredPackageValid').
--
-- * if the result is @False@ use 'problems' to get a detailed list.
---
-valid :: IndependentGoals
- -> SolverPlanIndex
- -> Bool
+valid
+ :: IndependentGoals
+ -> SolverPlanIndex
+ -> Bool
valid indepGoals index =
- null $ problems indepGoals index
+ null $ problems indepGoals index
-data SolverPlanProblem =
- PackageMissingDeps SolverPlanPackage
- [PackageIdentifier]
- | PackageCycle [SolverPlanPackage]
- | PackageInconsistency PackageName [(PackageIdentifier, Version)]
- | PackageStateInvalid SolverPlanPackage SolverPlanPackage
+data SolverPlanProblem
+ = PackageMissingDeps
+ SolverPlanPackage
+ [PackageIdentifier]
+ | PackageCycle [SolverPlanPackage]
+ | PackageInconsistency PackageName [(PackageIdentifier, Version)]
+ | PackageStateInvalid SolverPlanPackage SolverPlanPackage
showPlanProblem :: SolverPlanProblem -> String
showPlanProblem (PackageMissingDeps pkg missingDeps) =
- "Package " ++ prettyShow (packageId pkg)
- ++ " depends on the following packages which are missing from the plan: "
- ++ intercalate ", " (map prettyShow missingDeps)
-
+ "Package "
+ ++ prettyShow (packageId pkg)
+ ++ " depends on the following packages which are missing from the plan: "
+ ++ intercalate ", " (map prettyShow missingDeps)
showPlanProblem (PackageCycle cycleGroup) =
- "The following packages are involved in a dependency cycle "
- ++ intercalate ", " (map (prettyShow.packageId) cycleGroup)
-
+ "The following packages are involved in a dependency cycle "
+ ++ intercalate ", " (map (prettyShow . packageId) cycleGroup)
showPlanProblem (PackageInconsistency name inconsistencies) =
- "Package " ++ prettyShow name
- ++ " is required by several packages,"
- ++ " but they require inconsistent versions:\n"
- ++ unlines [ " package " ++ prettyShow pkg ++ " requires "
- ++ prettyShow (PackageIdentifier name ver)
- | (pkg, ver) <- inconsistencies ]
-
+ "Package "
+ ++ prettyShow name
+ ++ " is required by several packages,"
+ ++ " but they require inconsistent versions:\n"
+ ++ unlines
+ [ " package "
+ ++ prettyShow pkg
+ ++ " requires "
+ ++ prettyShow (PackageIdentifier name ver)
+ | (pkg, ver) <- inconsistencies
+ ]
showPlanProblem (PackageStateInvalid pkg pkg') =
- "Package " ++ prettyShow (packageId pkg)
- ++ " is in the " ++ showPlanState pkg
- ++ " state but it depends on package " ++ prettyShow (packageId pkg')
- ++ " which is in the " ++ showPlanState pkg'
- ++ " state"
+ "Package "
+ ++ prettyShow (packageId pkg)
+ ++ " is in the "
+ ++ showPlanState pkg
+ ++ " state but it depends on package "
+ ++ prettyShow (packageId pkg')
+ ++ " which is in the "
+ ++ showPlanState pkg'
+ ++ " state"
where
showPlanState (PreExisting _) = "pre-existing"
- showPlanState (Configured _) = "configured"
+ showPlanState (Configured _) = "configured"
-- | For an invalid plan, produce a detailed list of problems as human readable
-- error messages. This is mainly intended for debugging purposes.
-- Use 'showPlanProblem' for a human readable explanation.
---
-problems :: IndependentGoals
- -> SolverPlanIndex
- -> [SolverPlanProblem]
+problems
+ :: IndependentGoals
+ -> SolverPlanIndex
+ -> [SolverPlanProblem]
problems indepGoals index =
-
- [ PackageMissingDeps pkg
- (mapMaybe
- (fmap packageId . flip Graph.lookup index)
- missingDeps)
- | (pkg, missingDeps) <- Graph.broken index ]
-
- ++ [ PackageCycle cycleGroup
- | cycleGroup <- Graph.cycles index ]
-
- ++ [ PackageInconsistency name inconsistencies
- | (name, inconsistencies) <-
- dependencyInconsistencies indepGoals index ]
-
- ++ [ PackageStateInvalid pkg pkg'
- | pkg <- Foldable.toList index
- , Just pkg' <- map (flip Graph.lookup index)
- (nodeNeighbors pkg)
- , not (stateDependencyRelation pkg pkg') ]
-
+ [ PackageMissingDeps
+ pkg
+ ( mapMaybe
+ (fmap packageId . flip Graph.lookup index)
+ missingDeps
+ )
+ | (pkg, missingDeps) <- Graph.broken index
+ ]
+ ++ [ PackageCycle cycleGroup
+ | cycleGroup <- Graph.cycles index
+ ]
+ ++ [ PackageInconsistency name inconsistencies
+ | (name, inconsistencies) <-
+ dependencyInconsistencies indepGoals index
+ ]
+ ++ [ PackageStateInvalid pkg pkg'
+ | pkg <- Foldable.toList index
+ , Just pkg' <-
+ map
+ (flip Graph.lookup index)
+ (nodeNeighbors pkg)
+ , not (stateDependencyRelation pkg pkg')
+ ]
-- | Compute all roots of the install plan, and verify that the transitive
-- plans from those roots are all consistent.
@@ -249,16 +275,19 @@ problems indepGoals index =
-- may be absent from the subplans even if the larger plan contains a dependency
-- cycle. Such cycles may or may not be an issue; either way, we don't check
-- for them here.
-dependencyInconsistencies :: IndependentGoals
- -> SolverPlanIndex
- -> [(PackageName, [(PackageIdentifier, Version)])]
-dependencyInconsistencies indepGoals index =
- concatMap dependencyInconsistencies' subplans
+dependencyInconsistencies
+ :: IndependentGoals
+ -> SolverPlanIndex
+ -> [(PackageName, [(PackageIdentifier, Version)])]
+dependencyInconsistencies indepGoals index =
+ concatMap dependencyInconsistencies' subplans
where
subplans :: [SolverPlanIndex]
- subplans = -- Not Graph.closure!!
- map (nonSetupClosure index)
- (rootSets indepGoals index)
+ subplans =
+ -- Not Graph.closure!!
+ map
+ (nonSetupClosure index)
+ (rootSets indepGoals index)
-- NB: When we check for inconsistencies, packages from the setup
-- scripts don't count as part of the closure (this way, we
@@ -267,22 +296,24 @@ dependencyInconsistencies indepGoals index =
--
-- This is a best effort function that swallows any non-existent
-- SolverIds.
-nonSetupClosure :: SolverPlanIndex
- -> [SolverId]
- -> SolverPlanIndex
+nonSetupClosure
+ :: SolverPlanIndex
+ -> [SolverId]
+ -> SolverPlanIndex
nonSetupClosure index pkgids0 = closure Graph.empty pkgids0
- where
+ where
closure :: Graph SolverPlanPackage -> [SolverId] -> SolverPlanIndex
- closure completed [] = completed
- closure completed (pkgid:pkgids) =
+ closure completed [] = completed
+ closure completed (pkgid : pkgids) =
case Graph.lookup pkgid index of
- Nothing -> closure completed pkgids
- Just pkg ->
+ Nothing -> closure completed pkgids
+ Just pkg ->
case Graph.lookup (nodeKey pkg) completed of
- Just _ -> closure completed pkgids
+ Just _ -> closure completed pkgids
Nothing -> closure completed' pkgids'
- where completed' = Graph.insert pkg completed
- pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids
+ where
+ completed' = Graph.insert pkg completed
+ pkgids' = CD.nonSetupDeps (resolverPackageLibDeps pkg) ++ pkgids
-- | Compute the root sets of a plan
--
@@ -292,8 +323,11 @@ nonSetupClosure index pkgids0 = closure Graph.empty pkgids0
-- with all setup dependencies of all packages.
rootSets :: IndependentGoals -> SolverPlanIndex -> [[SolverId]]
rootSets (IndependentGoals indepGoals) index =
- if indepGoals then map (:[]) libRoots else [libRoots]
- ++ setupRoots index
+ if indepGoals
+ then map (: []) libRoots
+ else
+ [libRoots]
+ ++ setupRoots index
where
libRoots :: [SolverId]
libRoots = libraryRoots index
@@ -304,18 +338,19 @@ rootSets (IndependentGoals indepGoals) index =
-- (no reverse library dependencies but also no reverse setup dependencies).
libraryRoots :: SolverPlanIndex -> [SolverId]
libraryRoots index =
- map (nodeKey . toPkgId) roots
+ map (nodeKey . toPkgId) roots
where
(graph, toPkgId, _) = Graph.toGraph index
indegree = OldGraph.indegree graph
- roots = filter isRoot (OldGraph.vertices graph)
+ roots = filter isRoot (OldGraph.vertices graph)
isRoot v = indegree ! v == 0
-- | The setup dependencies of each package in the plan
setupRoots :: SolverPlanIndex -> [[SolverId]]
-setupRoots = filter (not . null)
- . map (CD.setupDeps . resolverPackageLibDeps)
- . Foldable.toList
+setupRoots =
+ filter (not . null)
+ . map (CD.setupDeps . resolverPackageLibDeps)
+ . Foldable.toList
-- | Given a package index where we assume we want to use all the packages
-- (use 'dependencyClosure' if you need to get such a index subset) find out
@@ -326,30 +361,32 @@ setupRoots = filter (not . null)
-- Each element in the result is a package name along with the packages that
-- depend on it and the versions they require. These are guaranteed to be
-- distinct.
---
-dependencyInconsistencies' :: SolverPlanIndex
- -> [(PackageName, [(PackageIdentifier, Version)])]
+dependencyInconsistencies'
+ :: SolverPlanIndex
+ -> [(PackageName, [(PackageIdentifier, Version)])]
dependencyInconsistencies' index =
- [ (name, [ (pid, packageVersion dep) | (dep,pids) <- uses, pid <- pids])
- | (name, ipid_map) <- Map.toList inverseIndex
- , let uses = Map.elems ipid_map
- , reallyIsInconsistent (map fst uses)
- ]
+ [ (name, [(pid, packageVersion dep) | (dep, pids) <- uses, pid <- pids])
+ | (name, ipid_map) <- Map.toList inverseIndex
+ , let uses = Map.elems ipid_map
+ , reallyIsInconsistent (map fst uses)
+ ]
where
-- For each package name (of a dependency, somewhere)
-- and each installed ID of that package
-- the associated package instance
-- and a list of reverse dependencies (as source IDs)
inverseIndex :: Map PackageName (Map SolverId (SolverPlanPackage, [PackageId]))
- inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))
- [ (packageName dep, Map.fromList [(sid,(dep,[packageId pkg]))])
- | -- For each package @pkg@
+ inverseIndex =
+ Map.fromListWith
+ (Map.unionWith (\(a, b) (_, b') -> (a, b ++ b')))
+ [ (packageName dep, Map.fromList [(sid, (dep, [packageId pkg]))])
+ | -- For each package @pkg@
pkg <- Foldable.toList index
- -- Find out which @sid@ @pkg@ depends on
- , sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg)
- -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@)
- , Just dep <- [Graph.lookup sid index]
- ]
+ , -- Find out which @sid@ @pkg@ depends on
+ sid <- CD.nonSetupDeps (resolverPackageLibDeps pkg)
+ , -- And look up those @sid@ (i.e., @sid@ is the ID of @dep@)
+ Just dep <- [Graph.lookup sid index]
+ ]
-- If, in a single install plan, we depend on more than one version of a
-- package, then this is ONLY okay in the (rather special) case that we
@@ -357,21 +394,19 @@ dependencyInconsistencies' index =
-- depends on the other. This is necessary for example for the base where
-- we have base-3 depending on base-4.
reallyIsInconsistent :: [SolverPlanPackage] -> Bool
- reallyIsInconsistent [] = False
- reallyIsInconsistent [_p] = False
+ reallyIsInconsistent [] = False
+ reallyIsInconsistent [_p] = False
reallyIsInconsistent [p1, p2] =
let pid1 = nodeKey p1
pid2 = nodeKey p2
- in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2)
- && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1)
+ in pid1 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p2)
+ && pid2 `notElem` CD.nonSetupDeps (resolverPackageLibDeps p1)
reallyIsInconsistent _ = True
-
-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.
--
-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out
-- which packages are involved in dependency cycles.
---
acyclic :: SolverPlanIndex -> Bool
acyclic = null . Graph.cycles
@@ -381,7 +416,6 @@ acyclic = null . Graph.cycles
--
-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out
-- which packages depend on packages not in the index.
---
closed :: SolverPlanIndex -> Bool
closed = null . Graph.broken
@@ -400,44 +434,40 @@ closed = null . Graph.broken
--
-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to
-- find out which packages are.
---
consistent :: SolverPlanIndex -> Bool
consistent = null . dependencyInconsistencies (IndependentGoals False)
-- | The states of packages have that depend on each other must respect
-- this relation. That is for very case where package @a@ depends on
-- package @b@ we require that @dependencyStatesOk a b = True@.
---
-stateDependencyRelation :: SolverPlanPackage
- -> SolverPlanPackage
- -> Bool
-stateDependencyRelation PreExisting{} PreExisting{} = True
-
-stateDependencyRelation (Configured _) PreExisting{} = True
-stateDependencyRelation (Configured _) (Configured _) = True
-
-stateDependencyRelation _ _ = False
-
+stateDependencyRelation
+ :: SolverPlanPackage
+ -> SolverPlanPackage
+ -> Bool
+stateDependencyRelation PreExisting{} PreExisting{} = True
+stateDependencyRelation (Configured _) PreExisting{} = True
+stateDependencyRelation (Configured _) (Configured _) = True
+stateDependencyRelation _ _ = False
-- | Compute the dependency closure of a package in a install plan
---
-dependencyClosure :: SolverInstallPlan
- -> [SolverId]
- -> [SolverPlanPackage]
+dependencyClosure
+ :: SolverInstallPlan
+ -> [SolverId]
+ -> [SolverPlanPackage]
dependencyClosure plan = fromMaybe [] . Graph.closure (planIndex plan)
-
-reverseDependencyClosure :: SolverInstallPlan
- -> [SolverId]
- -> [SolverPlanPackage]
+reverseDependencyClosure
+ :: SolverInstallPlan
+ -> [SolverId]
+ -> [SolverPlanPackage]
reverseDependencyClosure plan = fromMaybe [] . Graph.revClosure (planIndex plan)
-
-topologicalOrder :: SolverInstallPlan
- -> [SolverPlanPackage]
+topologicalOrder
+ :: SolverInstallPlan
+ -> [SolverPlanPackage]
topologicalOrder plan = Graph.topSort (planIndex plan)
-
-reverseTopologicalOrder :: SolverInstallPlan
- -> [SolverPlanPackage]
+reverseTopologicalOrder
+ :: SolverInstallPlan
+ -> [SolverPlanPackage]
reverseTopologicalOrder plan = Graph.revTopSort (planIndex plan)
diff --git a/cabal-install/src/Distribution/Client/SourceFiles.hs b/cabal-install/src/Distribution/Client/SourceFiles.hs
index 669f30a35b957f7faadaee0481aa382f85128a35..ddff8dad99f4461de9fafd817e7c27c02b0b9267 100644
--- a/cabal-install/src/Distribution/Client/SourceFiles.hs
+++ b/cabal-install/src/Distribution/Client/SourceFiles.hs
@@ -22,36 +22,36 @@ import Distribution.Solver.Types.OptionalStanza
import Distribution.Simple.Glob (matchDirFileGlobWithDie)
import Distribution.Simple.PreProcess
-import Distribution.Types.PackageDescription
+import Distribution.Types.Benchmark
+import Distribution.Types.BenchmarkInterface
+import Distribution.Types.BuildInfo
import Distribution.Types.Component
import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec)
-import Distribution.Types.Library
import Distribution.Types.Executable
-import Distribution.Types.Benchmark
-import Distribution.Types.BenchmarkInterface
+import Distribution.Types.ForeignLib
+import Distribution.Types.Library
+import Distribution.Types.PackageDescription
import Distribution.Types.TestSuite
import Distribution.Types.TestSuiteInterface
-import Distribution.Types.BuildInfo
-import Distribution.Types.ForeignLib
import Distribution.Utils.Path
import Distribution.ModuleName
-import Prelude ()
import Distribution.Client.Compat.Prelude
import Distribution.Verbosity (normal)
+import Prelude ()
import System.FilePath
needElaboratedConfiguredPackage :: ElaboratedConfiguredPackage -> Rebuild ()
needElaboratedConfiguredPackage elab =
- case elabPkgOrComp elab of
- ElabComponent ecomp -> needElaboratedComponent elab ecomp
- ElabPackage epkg -> needElaboratedPackage elab epkg
+ case elabPkgOrComp elab of
+ ElabComponent ecomp -> needElaboratedComponent elab ecomp
+ ElabPackage epkg -> needElaboratedPackage elab epkg
needElaboratedPackage :: ElaboratedConfiguredPackage -> ElaboratedPackage -> Rebuild ()
needElaboratedPackage elab epkg =
- traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)
+ traverse_ (needComponent pkg_descr) (enabledComponents pkg_descr enabled)
where
pkg_descr :: PackageDescription
pkg_descr = elabPkgDescription elab
@@ -62,116 +62,137 @@ needElaboratedPackage elab epkg =
needElaboratedComponent :: ElaboratedConfiguredPackage -> ElaboratedComponent -> Rebuild ()
needElaboratedComponent elab ecomp =
- case mb_comp of
- Nothing -> needSetup
- Just comp -> needComponent pkg_descr comp
+ case mb_comp of
+ Nothing -> needSetup
+ Just comp -> needComponent pkg_descr comp
where
pkg_descr :: PackageDescription
pkg_descr = elabPkgDescription elab
- mb_comp :: Maybe Component
- mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp)
+ mb_comp :: Maybe Component
+ mb_comp = fmap (getComponent pkg_descr) (compComponentName ecomp)
needComponent :: PackageDescription -> Component -> Rebuild ()
needComponent pkg_descr comp =
- case comp of
- CLib lib -> needLibrary pkg_descr lib
- CFLib flib -> needForeignLib pkg_descr flib
- CExe exe -> needExecutable pkg_descr exe
- CTest test -> needTestSuite pkg_descr test
- CBench bench -> needBenchmark pkg_descr bench
+ case comp of
+ CLib lib -> needLibrary pkg_descr lib
+ CFLib flib -> needForeignLib pkg_descr flib
+ CExe exe -> needExecutable pkg_descr exe
+ CTest test -> needTestSuite pkg_descr test
+ CBench bench -> needBenchmark pkg_descr bench
needSetup :: Rebuild ()
needSetup = findFirstFileMonitored id ["Setup.hs", "Setup.lhs"] >> return ()
needLibrary :: PackageDescription -> Library -> Rebuild ()
-needLibrary pkg_descr (Library { exposedModules = modules
- , signatures = sigs
- , libBuildInfo = bi })
- = needBuildInfo pkg_descr bi (modules ++ sigs)
+needLibrary
+ pkg_descr
+ ( Library
+ { exposedModules = modules
+ , signatures = sigs
+ , libBuildInfo = bi
+ }
+ ) =
+ needBuildInfo pkg_descr bi (modules ++ sigs)
needForeignLib :: PackageDescription -> ForeignLib -> Rebuild ()
-needForeignLib pkg_descr (ForeignLib { foreignLibModDefFile = fs
- , foreignLibBuildInfo = bi })
- = do traverse_ needIfExists fs
- needBuildInfo pkg_descr bi []
+needForeignLib
+ pkg_descr
+ ( ForeignLib
+ { foreignLibModDefFile = fs
+ , foreignLibBuildInfo = bi
+ }
+ ) =
+ do
+ traverse_ needIfExists fs
+ needBuildInfo pkg_descr bi []
needExecutable :: PackageDescription -> Executable -> Rebuild ()
-needExecutable pkg_descr (Executable { modulePath = mainPath
- , buildInfo = bi })
- = do needBuildInfo pkg_descr bi []
- needMainFile bi mainPath
+needExecutable
+ pkg_descr
+ ( Executable
+ { modulePath = mainPath
+ , buildInfo = bi
+ }
+ ) =
+ do
+ needBuildInfo pkg_descr bi []
+ needMainFile bi mainPath
needTestSuite :: PackageDescription -> TestSuite -> Rebuild ()
-needTestSuite pkg_descr t
- = case testInterface t of
- TestSuiteExeV10 _ mainPath -> do
- needBuildInfo pkg_descr bi []
- needMainFile bi mainPath
- TestSuiteLibV09 _ m ->
- needBuildInfo pkg_descr bi [m]
- TestSuiteUnsupported _ -> return () -- soft fail
- where
- bi :: BuildInfo
- bi = testBuildInfo t
+needTestSuite pkg_descr t =
+ case testInterface t of
+ TestSuiteExeV10 _ mainPath -> do
+ needBuildInfo pkg_descr bi []
+ needMainFile bi mainPath
+ TestSuiteLibV09 _ m ->
+ needBuildInfo pkg_descr bi [m]
+ TestSuiteUnsupported _ -> return () -- soft fail
+ where
+ bi :: BuildInfo
+ bi = testBuildInfo t
needMainFile :: BuildInfo -> FilePath -> Rebuild ()
needMainFile bi mainPath = do
- -- The matter here is subtle. It might *seem* that we
- -- should just search for mainPath, but as per
- -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is'
- -- will actually be the source file AFTER preprocessing,
- -- whereas we need to get the file *prior* to preprocessing.
- ppFile <- findFileWithExtensionMonitored
- (ppSuffixes knownSuffixHandlers)
- (map getSymbolicPath (hsSourceDirs bi))
- (dropExtension mainPath)
- case ppFile of
- -- But check the original path in the end, because
- -- maybe it's a non-preprocessed file with a non-traditional
- -- extension.
- Nothing -> findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath
- >>= maybe (return ()) need
- Just pp -> need pp
+ -- The matter here is subtle. It might *seem* that we
+ -- should just search for mainPath, but as per
+ -- b61cb051f63ed5869b8f4a6af996ff7e833e4b39 'main-is'
+ -- will actually be the source file AFTER preprocessing,
+ -- whereas we need to get the file *prior* to preprocessing.
+ ppFile <-
+ findFileWithExtensionMonitored
+ (ppSuffixes knownSuffixHandlers)
+ (map getSymbolicPath (hsSourceDirs bi))
+ (dropExtension mainPath)
+ case ppFile of
+ -- But check the original path in the end, because
+ -- maybe it's a non-preprocessed file with a non-traditional
+ -- extension.
+ Nothing ->
+ findFileMonitored (map getSymbolicPath (hsSourceDirs bi)) mainPath
+ >>= maybe (return ()) need
+ Just pp -> need pp
needBenchmark :: PackageDescription -> Benchmark -> Rebuild ()
-needBenchmark pkg_descr bm
- = case benchmarkInterface bm of
- BenchmarkExeV10 _ mainPath -> do
- needBuildInfo pkg_descr bi []
- needMainFile bi mainPath
- BenchmarkUnsupported _ -> return () -- soft fail
- where
- bi :: BuildInfo
- bi = benchmarkBuildInfo bm
+needBenchmark pkg_descr bm =
+ case benchmarkInterface bm of
+ BenchmarkExeV10 _ mainPath -> do
+ needBuildInfo pkg_descr bi []
+ needMainFile bi mainPath
+ BenchmarkUnsupported _ -> return () -- soft fail
+ where
+ bi :: BuildInfo
+ bi = benchmarkBuildInfo bm
needBuildInfo :: PackageDescription -> BuildInfo -> [ModuleName] -> Rebuild ()
needBuildInfo pkg_descr bi modules = do
- -- NB: These are separate because there may be both A.hs and
- -- A.hs-boot; need to track both.
- findNeededModules ["hs", "lhs", "hsig", "lhsig"]
- findNeededModules ["hs-boot", "lhs-boot"]
- root <- askRoot
- expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie normal (\ _ _ -> return []) (specVersion pkg_descr) root fpath
- traverse_ needIfExists $ concat
- [ cSources bi
- , cxxSources bi
- , jsSources bi
- , cmmSources bi
- , asmSources bi
- , expandedExtraSrcFiles
- ]
- for_ (installIncludes bi) $ \f ->
- findFileMonitored ("." : includeDirs bi) f
- >>= maybe (return ()) need
+ -- NB: These are separate because there may be both A.hs and
+ -- A.hs-boot; need to track both.
+ findNeededModules ["hs", "lhs", "hsig", "lhsig"]
+ findNeededModules ["hs-boot", "lhs-boot"]
+ root <- askRoot
+ expandedExtraSrcFiles <- liftIO $ fmap concat . for (extraSrcFiles pkg_descr) $ \fpath -> matchDirFileGlobWithDie normal (\_ _ -> return []) (specVersion pkg_descr) root fpath
+ traverse_ needIfExists $
+ concat
+ [ cSources bi
+ , cxxSources bi
+ , jsSources bi
+ , cmmSources bi
+ , asmSources bi
+ , expandedExtraSrcFiles
+ ]
+ for_ (installIncludes bi) $ \f ->
+ findFileMonitored ("." : includeDirs bi) f
+ >>= maybe (return ()) need
where
findNeededModules :: [String] -> Rebuild ()
- findNeededModules exts = traverse_
+ findNeededModules exts =
+ traverse_
(findNeededModule exts)
(modules ++ otherModules bi)
findNeededModule :: [String] -> ModuleName -> Rebuild ()
findNeededModule exts m =
- findFileWithExtensionMonitored
- (ppSuffixes knownSuffixHandlers ++ exts)
- (map getSymbolicPath (hsSourceDirs bi))
- (toFilePath m)
- >>= maybe (return ()) need
+ findFileWithExtensionMonitored
+ (ppSuffixes knownSuffixHandlers ++ exts)
+ (map getSymbolicPath (hsSourceDirs bi))
+ (toFilePath m)
+ >>= maybe (return ()) need
diff --git a/cabal-install/src/Distribution/Client/SrcDist.hs b/cabal-install/src/Distribution/Client/SrcDist.hs
index b418733c645cee7ee46c543a90f93830e166ce61..72a740bc7c08612d6d0c76e2453752d56f8bd820 100644
--- a/cabal-install/src/Distribution/Client/SrcDist.hs
+++ b/cabal-install/src/Distribution/Client/SrcDist.hs
@@ -1,40 +1,40 @@
{-# LANGUAGE OverloadedStrings #-}
+
-- | Utilities to implement cabal @v2-sdist@.
-module Distribution.Client.SrcDist (
- allPackageSourceFiles,
- packageDirToSdist,
-) where
+module Distribution.Client.SrcDist
+ ( allPackageSourceFiles
+ , packageDirToSdist
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify)
-import Control.Monad.Trans (liftIO)
+import Control.Monad.State.Lazy (StateT, evalStateT, gets, modify)
+import Control.Monad.Trans (liftIO)
import Control.Monad.Writer.Lazy (WriterT, execWriterT, tell)
-import System.FilePath (normalise, takeDirectory, (</>))
+import System.FilePath (normalise, takeDirectory, (</>))
-import Distribution.Client.Utils (tryFindAddSourcePackageDesc)
-import Distribution.Package (Package (packageId))
+import Distribution.Client.Utils (tryFindAddSourcePackageDesc)
+import Distribution.Package (Package (packageId))
import Distribution.PackageDescription.Configuration (flattenPackageDescription)
-import Distribution.Simple.PackageDescription (readGenericPackageDescription)
-import Distribution.Simple.PreProcess (knownSuffixHandlers)
-import Distribution.Simple.SrcDist (listPackageSourcesWithDie)
-import Distribution.Simple.Utils (die')
-import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
+import Distribution.Simple.PackageDescription (readGenericPackageDescription)
+import Distribution.Simple.PreProcess (knownSuffixHandlers)
+import Distribution.Simple.SrcDist (listPackageSourcesWithDie)
+import Distribution.Simple.Utils (die')
+import Distribution.Types.GenericPackageDescription (GenericPackageDescription)
-import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
-import qualified Codec.Compression.GZip as GZip
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as BSL
-import qualified Data.Set as Set
+import qualified Codec.Compression.GZip as GZip
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as BSL
+import qualified Data.Set as Set
-- | List all source files of a given add-source dependency. Exits with error if
-- something is wrong (e.g. there is no .cabal file in the given directory).
--
-- Used in sandbox and projectbuilding.
-- TODO: when sandboxes are removed, move to ProjectBuilding.
---
allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]
allPackageSourceFiles verbosity packageDir = do
pd <- do
@@ -46,52 +46,56 @@ allPackageSourceFiles verbosity packageDir = do
-- | Create a tarball for a package in a directory
packageDirToSdist
- :: Verbosity
- -> GenericPackageDescription -- ^ read in GPD
- -> FilePath -- ^ directory containing that GPD
- -> IO BSL.ByteString -- ^ resulting sdist tarball
+ :: Verbosity
+ -> GenericPackageDescription
+ -- ^ read in GPD
+ -> FilePath
+ -- ^ directory containing that GPD
+ -> IO BSL.ByteString
+ -- ^ resulting sdist tarball
packageDirToSdist verbosity gpd dir = do
- let thisDie :: Verbosity -> String -> IO a
- thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
+ let thisDie :: Verbosity -> String -> IO a
+ thisDie v s = die' v $ "sdist of " <> prettyShow (packageId gpd) ++ ": " ++ s
- files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers
- let files :: [FilePath]
- files = nub $ sort $ map normalise files'
+ files' <- listPackageSourcesWithDie verbosity thisDie dir (flattenPackageDescription gpd) knownSuffixHandlers
+ let files :: [FilePath]
+ files = nub $ sort $ map normalise files'
- let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
- entriesM = do
- let prefix = prettyShow (packageId gpd)
- modify (Set.insert prefix)
- case Tar.toTarPath True prefix of
- Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
- Right path -> tell [Tar.directoryEntry path]
+ let entriesM :: StateT (Set.Set FilePath) (WriterT [Tar.Entry] IO) ()
+ entriesM = do
+ let prefix = prettyShow (packageId gpd)
+ modify (Set.insert prefix)
+ case Tar.toTarPath True prefix of
+ Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
+ Right path -> tell [Tar.directoryEntry path]
- for_ files $ \file -> do
- let fileDir = takeDirectory (prefix </> file)
- needsEntry <- gets (Set.notMember fileDir)
+ for_ files $ \file -> do
+ let fileDir = takeDirectory (prefix </> file)
+ needsEntry <- gets (Set.notMember fileDir)
- when needsEntry $ do
- modify (Set.insert fileDir)
- case Tar.toTarPath True fileDir of
- Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
- Right path -> tell [Tar.directoryEntry path]
+ when needsEntry $ do
+ modify (Set.insert fileDir)
+ case Tar.toTarPath True fileDir of
+ Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
+ Right path -> tell [Tar.directoryEntry path]
- contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
- case Tar.toTarPath False (prefix </> file) of
- Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
- Right path -> tell [(Tar.fileEntry path contents) { Tar.entryPermissions = Tar.ordinaryFilePermissions }]
+ contents <- liftIO . fmap BSL.fromStrict . BS.readFile $ dir </> file
+ case Tar.toTarPath False (prefix </> file) of
+ Left err -> liftIO $ die' verbosity ("Error packing sdist: " ++ err)
+ Right path -> tell [(Tar.fileEntry path contents){Tar.entryPermissions = Tar.ordinaryFilePermissions}]
- entries <- execWriterT (evalStateT entriesM mempty)
- let -- Pretend our GZip file is made on Unix.
- normalize bs = BSL.concat [pfx, "\x03", rest']
- where
- (pfx, rest) = BSL.splitAt 9 bs
- rest' = BSL.tail rest
- -- The Unix epoch, which is the default value, is
- -- unsuitable because it causes unpacking problems on
- -- Windows; we need a post-1980 date. One gigasecond
- -- after the epoch is during 2001-09-09, so that does
- -- nicely. See #5596.
- setModTime :: Tar.Entry -> Tar.Entry
- setModTime entry = entry { Tar.entryTime = 1000000000 }
- return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
+ entries <- execWriterT (evalStateT entriesM mempty)
+ let
+ -- Pretend our GZip file is made on Unix.
+ normalize bs = BSL.concat [pfx, "\x03", rest']
+ where
+ (pfx, rest) = BSL.splitAt 9 bs
+ rest' = BSL.tail rest
+ -- The Unix epoch, which is the default value, is
+ -- unsuitable because it causes unpacking problems on
+ -- Windows; we need a post-1980 date. One gigasecond
+ -- after the epoch is during 2001-09-09, so that does
+ -- nicely. See #5596.
+ setModTime :: Tar.Entry -> Tar.Entry
+ setModTime entry = entry{Tar.entryTime = 1000000000}
+ return . normalize . GZip.compress . Tar.write $ fmap setModTime entries
diff --git a/cabal-install/src/Distribution/Client/Store.hs b/cabal-install/src/Distribution/Client/Store.hs
index d78fb3dcc92d6d8a29477cce17535bc9d7415f8a..d678e137090cb25b9a4cf4f82e8cf39eb022a9c3 100644
--- a/cabal-install/src/Distribution/Client/Store.hs
+++ b/cabal-install/src/Distribution/Client/Store.hs
@@ -1,44 +1,47 @@
-{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns #-}
-
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
-- | Management for the installed package store.
---
-module Distribution.Client.Store (
-
- -- * The store layout
- StoreDirLayout(..),
- defaultStoreDirLayout,
+module Distribution.Client.Store
+ ( -- * The store layout
+ StoreDirLayout (..)
+ , defaultStoreDirLayout
-- * Reading store entries
- getStoreEntries,
- doesStoreEntryExist,
+ , getStoreEntries
+ , doesStoreEntryExist
-- * Creating store entries
- newStoreEntry,
- NewStoreEntryOutcome(..),
+ , newStoreEntry
+ , NewStoreEntryOutcome (..)
-- * Concurrency strategy
-- $concurrency
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Client.DistDirLayout
-import Distribution.Client.RebuildMonad
+import Distribution.Client.DistDirLayout
+import Distribution.Client.RebuildMonad
-import Distribution.Package (UnitId, mkUnitId)
-import Distribution.Compiler (CompilerId)
+import Distribution.Compiler (CompilerId)
+import Distribution.Package (UnitId, mkUnitId)
-import Distribution.Simple.Utils
- ( withTempDirectory, debug, info )
-import Distribution.Verbosity
- ( silent )
+import Distribution.Simple.Utils
+ ( debug
+ , info
+ , withTempDirectory
+ )
+import Distribution.Verbosity
+ ( silent
+ )
+import Control.Exception
import qualified Data.Set as Set
-import Control.Exception
-import System.FilePath
-import System.Directory
+import System.Directory
+import System.FilePath
#ifdef MIN_VERSION_lukko
import Lukko
@@ -125,37 +128,33 @@ import GHC.IO.Handle.Lock (hUnlock)
-- for cabal. It does mean however that the package db update should be insert
-- or replace, i.e. not failing if the db entry already exists.
-
-- | Check if a particular 'UnitId' exists in the store.
---
doesStoreEntryExist :: StoreDirLayout -> CompilerId -> UnitId -> IO Bool
doesStoreEntryExist StoreDirLayout{storePackageDirectory} compid unitid =
- doesDirectoryExist (storePackageDirectory compid unitid)
-
+ doesDirectoryExist (storePackageDirectory compid unitid)
-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
---
getStoreEntries :: StoreDirLayout -> CompilerId -> Rebuild (Set UnitId)
getStoreEntries StoreDirLayout{storeDirectory} compid = do
- paths <- getDirectoryContentsMonitored (storeDirectory compid)
- return $! mkEntries paths
+ paths <- getDirectoryContentsMonitored (storeDirectory compid)
+ return $! mkEntries paths
where
- mkEntries = Set.delete (mkUnitId "package.db")
- . Set.delete (mkUnitId "incoming")
- . Set.fromList
- . map mkUnitId
- . filter valid
- valid ('.':_) = False
- valid _ = True
-
+ mkEntries =
+ Set.delete (mkUnitId "package.db")
+ . Set.delete (mkUnitId "incoming")
+ . Set.fromList
+ . map mkUnitId
+ . filter valid
+ valid ('.' : _) = False
+ valid _ = True
-- | The outcome of 'newStoreEntry': either the store entry was newly created
-- or it existed already. The latter case happens if there was a race between
-- two builds of the same store entry.
---
-data NewStoreEntryOutcome = UseNewStoreEntry
- | UseExistingStoreEntry
+data NewStoreEntryOutcome
+ = UseNewStoreEntry
+ | UseExistingStoreEntry
deriving (Eq, Show)
-- | Place a new entry into the store. See the concurrency strategy description
@@ -172,42 +171,46 @@ data NewStoreEntryOutcome = UseNewStoreEntry
-- /must/ check the 'NewStoreEntryOutcome' and if it's'UseExistingStoreEntry'
-- then you must read the existing registration information (unless your
-- registration information is constructed fully deterministically).
---
-newStoreEntry :: Verbosity
- -> StoreDirLayout
- -> CompilerId
- -> UnitId
- -> (FilePath -> IO (FilePath, [FilePath])) -- ^ Action to place files.
- -> IO () -- ^ Register action, if necessary.
- -> IO NewStoreEntryOutcome
-newStoreEntry verbosity storeDirLayout@StoreDirLayout{..}
- compid unitid
- copyFiles register =
+newStoreEntry
+ :: Verbosity
+ -> StoreDirLayout
+ -> CompilerId
+ -> UnitId
+ -> (FilePath -> IO (FilePath, [FilePath]))
+ -- ^ Action to place files.
+ -> IO ()
+ -- ^ Register action, if necessary.
+ -> IO NewStoreEntryOutcome
+newStoreEntry
+ verbosity
+ storeDirLayout@StoreDirLayout{..}
+ compid
+ unitid
+ copyFiles
+ register =
-- See $concurrency above for an explanation of the concurrency protocol
withTempIncomingDir storeDirLayout compid $ \incomingTmpDir -> do
-
-- Write all store entry files within the temp dir and return the prefix.
(incomingEntryDir, otherFiles) <- copyFiles incomingTmpDir
-- Take a lock named after the 'UnitId' in question.
withIncomingUnitIdLock verbosity storeDirLayout compid unitid $ do
-
-- Check for the existence of the final store entry directory.
exists <- doesStoreEntryExist storeDirLayout compid unitid
if exists
- -- If the entry exists then we lost the race and we must abandon,
+ then -- If the entry exists then we lost the race and we must abandon,
-- unlock and re-use the existing store entry.
- then do
+ do
info verbosity $
- "Concurrent build race: abandoning build in favour of existing "
- ++ "store entry " ++ prettyShow compid </> prettyShow unitid
+ "Concurrent build race: abandoning build in favour of existing "
+ ++ "store entry "
+ ++ prettyShow compid
+ </> prettyShow unitid
return UseExistingStoreEntry
-
- -- If the entry does not exist then we won the race and can proceed.
- else do
-
+ else -- If the entry does not exist then we won the race and can proceed.
+ do
-- Register the package into the package db (if appropriate).
register
@@ -221,26 +224,35 @@ newStoreEntry verbosity storeDirLayout@StoreDirLayout{..}
debug verbosity $
"Installed store entry " ++ prettyShow compid </> prettyShow unitid
return UseNewStoreEntry
- where
- finalEntryDir = storePackageDirectory compid unitid
-
-
-withTempIncomingDir :: StoreDirLayout -> CompilerId
- -> (FilePath -> IO a) -> IO a
+ where
+ finalEntryDir = storePackageDirectory compid unitid
+
+withTempIncomingDir
+ :: StoreDirLayout
+ -> CompilerId
+ -> (FilePath -> IO a)
+ -> IO a
withTempIncomingDir StoreDirLayout{storeIncomingDirectory} compid action = do
- createDirectoryIfMissing True incomingDir
- withTempDirectory silent incomingDir "new" action
+ createDirectoryIfMissing True incomingDir
+ withTempDirectory silent incomingDir "new" action
where
incomingDir = storeIncomingDirectory compid
-
-withIncomingUnitIdLock :: Verbosity -> StoreDirLayout
- -> CompilerId -> UnitId
- -> IO a -> IO a
-withIncomingUnitIdLock verbosity StoreDirLayout{storeIncomingLock}
- compid unitid action =
+withIncomingUnitIdLock
+ :: Verbosity
+ -> StoreDirLayout
+ -> CompilerId
+ -> UnitId
+ -> IO a
+ -> IO a
+withIncomingUnitIdLock
+ verbosity
+ StoreDirLayout{storeIncomingLock}
+ compid
+ unitid
+ action =
bracket takeLock releaseLock (\_hnd -> action)
- where
+ where
#ifdef MIN_VERSION_lukko
takeLock
| fileLockingSupported = do
diff --git a/cabal-install/src/Distribution/Client/Tar.hs b/cabal-install/src/Distribution/Client/Tar.hs
index d59dcf8160ad297a42c2d0580382b671b36f0054..313821a6b1ad8a87a64615bfb5063b3d4a160a92 100644
--- a/cabal-install/src/Distribution/Client/Tar.hs
+++ b/cabal-install/src/Distribution/Client/Tar.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE DeriveFunctor #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Tar
-- Copyright : (c) 2007 Bjorn Bringert,
@@ -12,65 +16,75 @@
-- Portability : portable
--
-- Reading, writing and manipulating \"@.tar@\" archive files.
---
------------------------------------------------------------------------------
-module Distribution.Client.Tar (
- -- * @tar.gz@ operations
- createTarGzFile,
- extractTarGzFile,
-
- -- * Other local utils
- buildTreeRefTypeCode,
- buildTreeSnapshotTypeCode,
- isBuildTreeRefTypeCode,
- filterEntries,
- filterEntriesM,
- entriesToList,
+module Distribution.Client.Tar
+ ( -- * @tar.gz@ operations
+ createTarGzFile
+ , extractTarGzFile
+
+ -- * Other local utils
+ , buildTreeRefTypeCode
+ , buildTreeSnapshotTypeCode
+ , isBuildTreeRefTypeCode
+ , filterEntries
+ , filterEntriesM
+ , entriesToList
) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import qualified Data.ByteString.Lazy as BS
-import qualified Codec.Archive.Tar as Tar
-import qualified Codec.Archive.Tar.Entry as Tar
+import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Check as Tar
-import qualified Codec.Compression.GZip as GZip
+import qualified Codec.Archive.Tar.Entry as Tar
+import qualified Codec.Compression.GZip as GZip
+import qualified Data.ByteString.Lazy as BS
import qualified Distribution.Client.GZipUtils as GZipUtils
-- for foldEntries...
import Control.Exception (throw)
--
+
-- * High level operations
+
--
-createTarGzFile :: FilePath -- ^ Full Tarball path
- -> FilePath -- ^ Base directory
- -> FilePath -- ^ Directory to archive, relative to base dir
- -> IO ()
+createTarGzFile
+ :: FilePath
+ -- ^ Full Tarball path
+ -> FilePath
+ -- ^ Base directory
+ -> FilePath
+ -- ^ Directory to archive, relative to base dir
+ -> IO ()
createTarGzFile tar base dir =
BS.writeFile tar . GZip.compress . Tar.write =<< Tar.pack base [dir]
-extractTarGzFile :: FilePath -- ^ Destination directory
- -> FilePath -- ^ Expected subdir (to check for tarbombs)
- -> FilePath -- ^ Tarball
- -> IO ()
+extractTarGzFile
+ :: FilePath
+ -- ^ Destination directory
+ -> FilePath
+ -- ^ Expected subdir (to check for tarbombs)
+ -> FilePath
+ -- ^ Tarball
+ -> IO ()
extractTarGzFile dir expected tar =
- Tar.unpack dir . Tar.checkTarbomb expected . Tar.read
- . GZipUtils.maybeDecompress =<< BS.readFile tar
+ Tar.unpack dir
+ . Tar.checkTarbomb expected
+ . Tar.read
+ . GZipUtils.maybeDecompress
+ =<< BS.readFile tar
instance (Exception a, Exception b) => Exception (Either a b) where
- toException (Left e) = toException e
+ toException (Left e) = toException e
toException (Right e) = toException e
fromException e =
case fromException e of
Just e' -> Just (Left e')
Nothing -> case fromException e of
- Just e' -> Just (Right e')
- Nothing -> Nothing
-
+ Just e' -> Just (Right e')
+ Nothing -> Nothing
-- | Type code for the local build tree reference entry type. We don't use the
-- symbolic link entry type because it allows only 100 ASCII characters for the
@@ -85,9 +99,11 @@ buildTreeSnapshotTypeCode = 'S'
-- | Is this a type code for a build tree reference?
isBuildTreeRefTypeCode :: Tar.TypeCode -> Bool
isBuildTreeRefTypeCode typeCode
- | (typeCode == buildTreeRefTypeCode
- || typeCode == buildTreeSnapshotTypeCode) = True
- | otherwise = False
+ | ( typeCode == buildTreeRefTypeCode
+ || typeCode == buildTreeSnapshotTypeCode
+ ) =
+ True
+ | otherwise = False
filterEntries :: (Tar.Entry -> Bool) -> Tar.Entries e -> Tar.Entries e
filterEntries p =
@@ -96,19 +112,22 @@ filterEntries p =
Tar.Done
Tar.Fail
-filterEntriesM :: Monad m => (Tar.Entry -> m Bool)
- -> Tar.Entries e -> m (Tar.Entries e)
+filterEntriesM
+ :: Monad m
+ => (Tar.Entry -> m Bool)
+ -> Tar.Entries e
+ -> m (Tar.Entries e)
filterEntriesM p =
Tar.foldEntries
- (\entry rest -> do
- keep <- p entry
- xs <- rest
- if keep
- then return (Tar.Next entry xs)
- else return xs)
+ ( \entry rest -> do
+ keep <- p entry
+ xs <- rest
+ if keep
+ then return (Tar.Next entry xs)
+ else return xs
+ )
(return Tar.Done)
(return . Tar.Fail)
entriesToList :: Exception e => Tar.Entries e -> [Tar.Entry]
entriesToList = Tar.foldEntries (:) [] throw
-
diff --git a/cabal-install/src/Distribution/Client/TargetProblem.hs b/cabal-install/src/Distribution/Client/TargetProblem.hs
index 14004d50abdfa3e397c41cedc996a4315f6be1d7..680250273c0224c1c0de025e839f92730e4ba9bd 100644
--- a/cabal-install/src/Distribution/Client/TargetProblem.hs
+++ b/cabal-install/src/Distribution/Client/TargetProblem.hs
@@ -1,52 +1,53 @@
{-# LANGUAGE DeriveFunctor #-}
-module Distribution.Client.TargetProblem (
- TargetProblem(..),
- TargetProblem',
-) where
+
+module Distribution.Client.TargetProblem
+ ( TargetProblem (..)
+ , TargetProblem'
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Client.ProjectPlanning (AvailableTarget)
-import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector)
-import Distribution.Package (PackageId, PackageName)
-import Distribution.Simple.LocalBuildInfo (ComponentName (..))
+import Distribution.Client.ProjectPlanning (AvailableTarget)
+import Distribution.Client.TargetSelector (SubComponentTarget, TargetSelector)
+import Distribution.Package (PackageId, PackageName)
+import Distribution.Simple.LocalBuildInfo (ComponentName (..))
import Distribution.Types.UnqualComponentName (UnqualComponentName)
-- | Target problems that occur during project orchestration.
data TargetProblem a
- = TargetNotInProject PackageName
- | TargetAvailableInIndex PackageName
-
- | TargetComponentNotProjectLocal
- PackageId ComponentName SubComponentTarget
-
- | TargetComponentNotBuildable
- PackageId ComponentName SubComponentTarget
-
- | TargetOptionalStanzaDisabledByUser
- PackageId ComponentName SubComponentTarget
-
- | TargetOptionalStanzaDisabledBySolver
- PackageId ComponentName SubComponentTarget
-
- | TargetProblemUnknownComponent
- PackageName (Either UnqualComponentName ComponentName)
-
- | TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
- -- ^ The 'TargetSelector' matches component (test/benchmark/...) but none are buildable
-
- | TargetProblemNoTargets TargetSelector
- -- ^ There are no targets at all
-
- -- The target matching stuff only returns packages local to the project,
+ = TargetNotInProject PackageName
+ | TargetAvailableInIndex PackageName
+ | TargetComponentNotProjectLocal
+ PackageId
+ ComponentName
+ SubComponentTarget
+ | TargetComponentNotBuildable
+ PackageId
+ ComponentName
+ SubComponentTarget
+ | TargetOptionalStanzaDisabledByUser
+ PackageId
+ ComponentName
+ SubComponentTarget
+ | TargetOptionalStanzaDisabledBySolver
+ PackageId
+ ComponentName
+ SubComponentTarget
+ | TargetProblemUnknownComponent
+ PackageName
+ (Either UnqualComponentName ComponentName)
+ | -- | The 'TargetSelector' matches component (test/benchmark/...) but none are buildable
+ TargetProblemNoneEnabled TargetSelector [AvailableTarget ()]
+ | -- | There are no targets at all
+ TargetProblemNoTargets TargetSelector
+ | -- The target matching stuff only returns packages local to the project,
-- so these lookups should never fail, but if 'resolveTargets' is called
-- directly then of course it can.
- | TargetProblemNoSuchPackage PackageId
- | TargetProblemNoSuchComponent PackageId ComponentName
-
- -- | A custom target problem
- | CustomTargetProblem a
+ TargetProblemNoSuchPackage PackageId
+ | TargetProblemNoSuchComponent PackageId ComponentName
+ | -- | A custom target problem
+ CustomTargetProblem a
deriving (Eq, Show, Functor)
-- | Type alias for a 'TargetProblem' with no user-defined problems/errors.
diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs
index 498d53a7e0d02af547a302e9d95f006db53e7325..342a8f09d2ec5c8067d35f2287dbde504139ebe8 100644
--- a/cabal-install/src/Distribution/Client/TargetSelector.hs
+++ b/cabal-install/src/Distribution/Client/TargetSelector.hs
@@ -1,10 +1,16 @@
-{-# LANGUAGE CPP, DeriveGeneric, DeriveFunctor,
- RecordWildCards, NamedFieldPuns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-
-- TODO
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.TargetSelector
-- Copyright : (c) Duncan Coutts 2012, 2015, 2016
@@ -13,96 +19,145 @@
-- Maintainer : duncan@community.haskell.org
--
-- Handling for user-specified target selectors.
---
------------------------------------------------------------------------------
-module Distribution.Client.TargetSelector (
-
- -- * Target selectors
- TargetSelector(..),
- TargetImplicitCwd(..),
- ComponentKind(..),
- ComponentKindFilter,
- SubComponentTarget(..),
- QualLevel(..),
- componentKind,
+module Distribution.Client.TargetSelector
+ ( -- * Target selectors
+ TargetSelector (..)
+ , TargetImplicitCwd (..)
+ , ComponentKind (..)
+ , ComponentKindFilter
+ , SubComponentTarget (..)
+ , QualLevel (..)
+ , componentKind
-- * Reading target selectors
- readTargetSelectors,
- TargetSelectorProblem(..),
- reportTargetSelectorProblems,
- showTargetSelector,
- TargetString(..),
- showTargetString,
- parseTargetString,
+ , readTargetSelectors
+ , TargetSelectorProblem (..)
+ , reportTargetSelectorProblems
+ , showTargetSelector
+ , TargetString (..)
+ , showTargetString
+ , parseTargetString
+
-- ** non-IO
- readTargetSelectorsWith,
- DirActions(..),
- defaultDirActions,
+ , readTargetSelectorsWith
+ , DirActions (..)
+ , defaultDirActions
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
+import Distribution.Client.Types
+ ( PackageLocation (..)
+ , PackageSpecifier (..)
+ )
import Distribution.Package
- ( Package(..), PackageId, PackageName, packageName )
+ ( Package (..)
+ , PackageId
+ , PackageName
+ , packageName
+ )
import Distribution.Types.UnqualComponentName
- ( UnqualComponentName, mkUnqualComponentName, unUnqualComponentName
- , packageNameToUnqualComponentName )
-import Distribution.Client.Types
- ( PackageLocation(..), PackageSpecifier(..) )
+ ( UnqualComponentName
+ , mkUnqualComponentName
+ , packageNameToUnqualComponentName
+ , unUnqualComponentName
+ )
+import Distribution.ModuleName
+ ( ModuleName
+ , toFilePath
+ )
import Distribution.PackageDescription
- ( PackageDescription
- , Executable(..)
- , TestSuite(..), TestSuiteInterface(..), testModules
- , Benchmark(..), BenchmarkInterface(..), benchmarkModules
- , BuildInfo(..), explicitLibModules, exeModules )
+ ( Benchmark (..)
+ , BenchmarkInterface (..)
+ , BuildInfo (..)
+ , Executable (..)
+ , PackageDescription
+ , TestSuite (..)
+ , TestSuiteInterface (..)
+ , benchmarkModules
+ , exeModules
+ , explicitLibModules
+ , testModules
+ )
import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription )
-import Distribution.Solver.Types.SourcePackage
- ( SourcePackage(..) )
-import Distribution.ModuleName
- ( ModuleName, toFilePath )
+ ( flattenPackageDescription
+ )
import Distribution.Simple.LocalBuildInfo
- ( Component(..), ComponentName(..), LibraryName(..)
- , pkgComponents, componentName, componentBuildInfo )
+ ( Component (..)
+ , ComponentName (..)
+ , LibraryName (..)
+ , componentBuildInfo
+ , componentName
+ , pkgComponents
+ )
+import Distribution.Solver.Types.SourcePackage
+ ( SourcePackage (..)
+ )
import Distribution.Types.ForeignLib
-import Distribution.Simple.Utils
- ( die', lowercase, ordNub )
import Distribution.Client.Utils
- ( makeRelativeCanonical )
+ ( makeRelativeCanonical
+ )
+import Distribution.Simple.Utils
+ ( die'
+ , lowercase
+ , ordNub
+ )
+import Control.Arrow ((&&&))
+import Control.Monad hiding
+ ( mfilter
+ )
import Data.List
- ( stripPrefix, groupBy )
+ ( groupBy
+ , stripPrefix
+ )
import qualified Data.List.NonEmpty as NE
-import qualified Data.Map.Lazy as Map.Lazy
+import qualified Data.Map.Lazy as Map.Lazy
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
-import Control.Arrow ((&&&))
-import Control.Monad
- hiding ( mfilter )
-import qualified Distribution.Deprecated.ReadP as Parse
-import Distribution.Deprecated.ReadP
- ( (+++), (<++) )
import Distribution.Deprecated.ParseUtils
- ( readPToMaybe )
-import System.FilePath as FilePath
- ( takeExtension, dropExtension
- , splitDirectories, joinPath, splitPath )
+ ( readPToMaybe
+ )
+import Distribution.Deprecated.ReadP
+ ( (+++)
+ , (<++)
+ )
+import qualified Distribution.Deprecated.ReadP as Parse
+import Distribution.Utils.Path
import qualified System.Directory as IO
- ( doesFileExist, doesDirectoryExist, canonicalizePath
- , getCurrentDirectory )
+ ( canonicalizePath
+ , doesDirectoryExist
+ , doesFileExist
+ , getCurrentDirectory
+ )
import System.FilePath
- ( (</>), (<.>), normalise, dropTrailingPathSeparator, equalFilePath )
+ ( dropTrailingPathSeparator
+ , equalFilePath
+ , normalise
+ , (<.>)
+ , (</>)
+ )
+import System.FilePath as FilePath
+ ( dropExtension
+ , joinPath
+ , splitDirectories
+ , splitPath
+ , takeExtension
+ )
import Text.EditDistance
- ( defaultEditCosts, restrictedDamerauLevenshteinDistance )
-import Distribution.Utils.Path
+ ( defaultEditCosts
+ , restrictedDamerauLevenshteinDistance
+ )
import qualified Prelude (foldr1)
-- ------------------------------------------------------------
+
-- * Target selector terms
+
-- ------------------------------------------------------------
-- | A target selector is expression selecting a set of components (as targets
@@ -124,46 +179,35 @@ import qualified Prelude (foldr1)
-- > [ package name | package dir | package .cabal file ]
-- > [ [lib:|exe:] component name ]
-- > [ module name | source file ]
---
-data TargetSelector =
-
- -- | One (or more) packages as a whole, or all the components of a
- -- particular kind within the package(s).
- --
- -- These are always packages that are local to the project. In the case
- -- that there is more than one, they all share the same directory location.
- --
- TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter)
-
- -- | A package specified by name. This may refer to @extra-packages@ from
- -- the @cabal.project@ file, or a dependency of a known project package or
- -- could refer to a package from a hackage archive. It needs further
- -- context to resolve to a specific package.
- --
- | TargetPackageNamed PackageName (Maybe ComponentKindFilter)
-
- -- | All packages, or all components of a particular kind in all packages.
- --
- | TargetAllPackages (Maybe ComponentKindFilter)
-
- -- | A specific component in a package within the project.
- --
- | TargetComponent PackageId ComponentName SubComponentTarget
-
- -- | A component in a package, but where it cannot be verified that the
- -- package has such a component, or because the package is itself not
- -- known.
- --
- | TargetComponentUnknown PackageName
- (Either UnqualComponentName ComponentName)
- SubComponentTarget
+data TargetSelector
+ = -- | One (or more) packages as a whole, or all the components of a
+ -- particular kind within the package(s).
+ --
+ -- These are always packages that are local to the project. In the case
+ -- that there is more than one, they all share the same directory location.
+ TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter)
+ | -- | A package specified by name. This may refer to @extra-packages@ from
+ -- the @cabal.project@ file, or a dependency of a known project package or
+ -- could refer to a package from a hackage archive. It needs further
+ -- context to resolve to a specific package.
+ TargetPackageNamed PackageName (Maybe ComponentKindFilter)
+ | -- | All packages, or all components of a particular kind in all packages.
+ TargetAllPackages (Maybe ComponentKindFilter)
+ | -- | A specific component in a package within the project.
+ TargetComponent PackageId ComponentName SubComponentTarget
+ | -- | A component in a package, but where it cannot be verified that the
+ -- package has such a component, or because the package is itself not
+ -- known.
+ TargetComponentUnknown
+ PackageName
+ (Either UnqualComponentName ComponentName)
+ SubComponentTarget
deriving (Eq, Ord, Show, Generic)
-- | Does this 'TargetPackage' selector arise from syntax referring to a
-- package in the current directory (e.g. @tests@ or no giving no explicit
-- target at all) or does it come from syntax referring to a package name
-- or location.
---
data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed
deriving (Eq, Ord, Show, Generic)
@@ -174,84 +218,82 @@ type ComponentKindFilter = ComponentKind
-- | Either the component as a whole or detail about a file or module target
-- within a component.
---
-data SubComponentTarget =
-
- -- | The component as a whole
- WholeComponent
-
- -- | A specific module within a component.
- | ModuleTarget ModuleName
-
- -- | A specific file within a component. Note that this does not carry the
- -- file extension.
- | FileTarget FilePath
+data SubComponentTarget
+ = -- | The component as a whole
+ WholeComponent
+ | -- | A specific module within a component.
+ ModuleTarget ModuleName
+ | -- | A specific file within a component. Note that this does not carry the
+ -- file extension.
+ FileTarget FilePath
deriving (Eq, Ord, Show, Generic)
instance Binary SubComponentTarget
instance Structured SubComponentTarget
-
-- ------------------------------------------------------------
+
-- * Top level, do everything
--- ------------------------------------------------------------
+-- ------------------------------------------------------------
-- | Parse a bunch of command line args as 'TargetSelector's, failing with an
-- error if any are unrecognised. The possible target selectors are based on
-- the available packages (and their locations).
---
-readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]
- -> Maybe ComponentKindFilter
- -- ^ This parameter is used when there are ambiguous selectors.
- -- If it is 'Just', then we attempt to resolve ambiguity
- -- by applying it, since otherwise there is no way to allow
- -- contextually valid yet syntactically ambiguous selectors.
- -- (#4676, #5461)
- -> [String]
- -> IO (Either [TargetSelectorProblem] [TargetSelector])
+readTargetSelectors
+ :: [PackageSpecifier (SourcePackage (PackageLocation a))]
+ -> Maybe ComponentKindFilter
+ -- ^ This parameter is used when there are ambiguous selectors.
+ -- If it is 'Just', then we attempt to resolve ambiguity
+ -- by applying it, since otherwise there is no way to allow
+ -- contextually valid yet syntactically ambiguous selectors.
+ -- (#4676, #5461)
+ -> [String]
+ -> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors = readTargetSelectorsWith defaultDirActions
-readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m
- -> [PackageSpecifier (SourcePackage (PackageLocation a))]
- -> Maybe ComponentKindFilter
- -> [String]
- -> m (Either [TargetSelectorProblem] [TargetSelector])
+readTargetSelectorsWith
+ :: (Applicative m, Monad m)
+ => DirActions m
+ -> [PackageSpecifier (SourcePackage (PackageLocation a))]
+ -> Maybe ComponentKindFilter
+ -> [String]
+ -> m (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs =
- case parseTargetStrings targetStrs of
- ([], usertargets) -> do
- usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets
- knowntargets <- getKnownTargets dirActions pkgs
- case resolveTargetSelectors knowntargets usertargets' mfilter of
- ([], btargets) -> return (Right btargets)
- (problems, _) -> return (Left problems)
- (strs, _) -> return (Left (map TargetSelectorUnrecognised strs))
-
-
-data DirActions m = DirActions {
- doesFileExist :: FilePath -> m Bool,
- doesDirectoryExist :: FilePath -> m Bool,
- canonicalizePath :: FilePath -> m FilePath,
- getCurrentDirectory :: m FilePath
- }
+ case parseTargetStrings targetStrs of
+ ([], usertargets) -> do
+ usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets
+ knowntargets <- getKnownTargets dirActions pkgs
+ case resolveTargetSelectors knowntargets usertargets' mfilter of
+ ([], btargets) -> return (Right btargets)
+ (problems, _) -> return (Left problems)
+ (strs, _) -> return (Left (map TargetSelectorUnrecognised strs))
+
+data DirActions m = DirActions
+ { doesFileExist :: FilePath -> m Bool
+ , doesDirectoryExist :: FilePath -> m Bool
+ , canonicalizePath :: FilePath -> m FilePath
+ , getCurrentDirectory :: m FilePath
+ }
defaultDirActions :: DirActions IO
defaultDirActions =
- DirActions {
- doesFileExist = IO.doesFileExist,
- doesDirectoryExist = IO.doesDirectoryExist,
- -- Workaround for <https://github.com/haskell/directory/issues/63>
- canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator,
- getCurrentDirectory = IO.getCurrentDirectory
+ DirActions
+ { doesFileExist = IO.doesFileExist
+ , doesDirectoryExist = IO.doesDirectoryExist
+ , -- Workaround for <https://github.com/haskell/directory/issues/63>
+ canonicalizePath = IO.canonicalizePath . dropTrailingPathSeparator
+ , getCurrentDirectory = IO.getCurrentDirectory
}
makeRelativeToCwd :: Applicative m => DirActions m -> FilePath -> m FilePath
makeRelativeToCwd DirActions{..} path =
- makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory
-
+ makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory
-- ------------------------------------------------------------
+
-- * Parsing target strings
+
-- ------------------------------------------------------------
-- | The outline parse of a target selector. It takes one of the forms:
@@ -260,257 +302,278 @@ makeRelativeToCwd DirActions{..} path =
-- > str1:str2
-- > str1:str2:str3
-- > str1:str2:str3:str4
---
-data TargetString =
- TargetString1 String
- | TargetString2 String String
- | TargetString3 String String String
- | TargetString4 String String String String
- | TargetString5 String String String String String
- | TargetString7 String String String String String String String
+data TargetString
+ = TargetString1 String
+ | TargetString2 String String
+ | TargetString3 String String String
+ | TargetString4 String String String String
+ | TargetString5 String String String String String
+ | TargetString7 String String String String String String String
deriving (Show, Eq)
-- | Parse a bunch of 'TargetString's (purely without throwing exceptions).
---
parseTargetStrings :: [String] -> ([String], [TargetString])
parseTargetStrings =
- partitionEithers
- . map (\str -> maybe (Left str) Right (parseTargetString str))
+ partitionEithers
+ . map (\str -> maybe (Left str) Right (parseTargetString str))
parseTargetString :: String -> Maybe TargetString
parseTargetString =
- readPToMaybe parseTargetApprox
+ readPToMaybe parseTargetApprox
where
parseTargetApprox :: Parse.ReadP r TargetString
parseTargetApprox =
- (do a <- tokenQ
- return (TargetString1 a))
- +++ (do a <- tokenQ0
- _ <- Parse.char ':'
- b <- tokenQ
- return (TargetString2 a b))
- +++ (do a <- tokenQ0
- _ <- Parse.char ':'
- b <- tokenQ
- _ <- Parse.char ':'
- c <- tokenQ
- return (TargetString3 a b c))
- +++ (do a <- tokenQ0
- _ <- Parse.char ':'
- b <- token
- _ <- Parse.char ':'
- c <- tokenQ
- _ <- Parse.char ':'
- d <- tokenQ
- return (TargetString4 a b c d))
- +++ (do a <- tokenQ0
- _ <- Parse.char ':'
- b <- token
- _ <- Parse.char ':'
- c <- tokenQ
- _ <- Parse.char ':'
- d <- tokenQ
- _ <- Parse.char ':'
- e <- tokenQ
- return (TargetString5 a b c d e))
- +++ (do a <- tokenQ0
- _ <- Parse.char ':'
- b <- token
- _ <- Parse.char ':'
- c <- tokenQ
- _ <- Parse.char ':'
- d <- tokenQ
- _ <- Parse.char ':'
- e <- tokenQ
- _ <- Parse.char ':'
- f <- tokenQ
- _ <- Parse.char ':'
- g <- tokenQ
- return (TargetString7 a b c d e f g))
-
- token = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
+ ( do
+ a <- tokenQ
+ return (TargetString1 a)
+ )
+ +++ ( do
+ a <- tokenQ0
+ _ <- Parse.char ':'
+ b <- tokenQ
+ return (TargetString2 a b)
+ )
+ +++ ( do
+ a <- tokenQ0
+ _ <- Parse.char ':'
+ b <- tokenQ
+ _ <- Parse.char ':'
+ c <- tokenQ
+ return (TargetString3 a b c)
+ )
+ +++ ( do
+ a <- tokenQ0
+ _ <- Parse.char ':'
+ b <- token
+ _ <- Parse.char ':'
+ c <- tokenQ
+ _ <- Parse.char ':'
+ d <- tokenQ
+ return (TargetString4 a b c d)
+ )
+ +++ ( do
+ a <- tokenQ0
+ _ <- Parse.char ':'
+ b <- token
+ _ <- Parse.char ':'
+ c <- tokenQ
+ _ <- Parse.char ':'
+ d <- tokenQ
+ _ <- Parse.char ':'
+ e <- tokenQ
+ return (TargetString5 a b c d e)
+ )
+ +++ ( do
+ a <- tokenQ0
+ _ <- Parse.char ':'
+ b <- token
+ _ <- Parse.char ':'
+ c <- tokenQ
+ _ <- Parse.char ':'
+ d <- tokenQ
+ _ <- Parse.char ':'
+ e <- tokenQ
+ _ <- Parse.char ':'
+ f <- tokenQ
+ _ <- Parse.char ':'
+ g <- tokenQ
+ return (TargetString7 a b c d e f g)
+ )
+
+ token = Parse.munch1 (\x -> not (isSpace x) && x /= ':')
tokenQ = parseHaskellString <++ token
token0 = Parse.munch (\x -> not (isSpace x) && x /= ':')
- tokenQ0= parseHaskellString <++ token0
+ tokenQ0 = parseHaskellString <++ token0
parseHaskellString :: Parse.ReadP r String
parseHaskellString = Parse.readS_to_P reads
-
-- | Render a 'TargetString' back as the external syntax. This is mainly for
-- error messages.
---
showTargetString :: TargetString -> String
showTargetString = intercalate ":" . components
where
- components (TargetString1 s1) = [s1]
- components (TargetString2 s1 s2) = [s1,s2]
- components (TargetString3 s1 s2 s3) = [s1,s2,s3]
- components (TargetString4 s1 s2 s3 s4) = [s1,s2,s3,s4]
- components (TargetString5 s1 s2 s3 s4 s5) = [s1,s2,s3,s4,s5]
- components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1,s2,s3,s4,s5,s6,s7]
+ components (TargetString1 s1) = [s1]
+ components (TargetString2 s1 s2) = [s1, s2]
+ components (TargetString3 s1 s2 s3) = [s1, s2, s3]
+ components (TargetString4 s1 s2 s3 s4) = [s1, s2, s3, s4]
+ components (TargetString5 s1 s2 s3 s4 s5) = [s1, s2, s3, s4, s5]
+ components (TargetString7 s1 s2 s3 s4 s5 s6 s7) = [s1, s2, s3, s4, s5, s6, s7]
showTargetSelector :: TargetSelector -> String
showTargetSelector ts =
- case [ t | ql <- [QL1 .. QLFull]
- , t <- renderTargetSelector ql ts ]
- of (t':_) -> showTargetString (forgetFileStatus t')
- [] -> ""
+ case [ t | ql <- [QL1 .. QLFull], t <- renderTargetSelector ql ts
+ ] of
+ (t' : _) -> showTargetString (forgetFileStatus t')
+ [] -> ""
showTargetSelectorKind :: TargetSelector -> String
showTargetSelectorKind bt = case bt of
- TargetPackage TargetExplicitNamed _ Nothing -> "package"
+ TargetPackage TargetExplicitNamed _ Nothing -> "package"
TargetPackage TargetExplicitNamed _ (Just _) -> "package:filter"
- TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package"
- TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter"
- TargetPackageNamed _ Nothing -> "named-package"
- TargetPackageNamed _ (Just _) -> "named-package:filter"
- TargetAllPackages Nothing -> "package *"
- TargetAllPackages (Just _) -> "package *:filter"
- TargetComponent _ _ WholeComponent -> "component"
- TargetComponent _ _ ModuleTarget{} -> "module"
- TargetComponent _ _ FileTarget{} -> "file"
- TargetComponentUnknown _ _ WholeComponent -> "unknown-component"
- TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module"
- TargetComponentUnknown _ _ FileTarget{} -> "unknown-file"
-
+ TargetPackage TargetImplicitCwd _ Nothing -> "cwd-package"
+ TargetPackage TargetImplicitCwd _ (Just _) -> "cwd-package:filter"
+ TargetPackageNamed _ Nothing -> "named-package"
+ TargetPackageNamed _ (Just _) -> "named-package:filter"
+ TargetAllPackages Nothing -> "package *"
+ TargetAllPackages (Just _) -> "package *:filter"
+ TargetComponent _ _ WholeComponent -> "component"
+ TargetComponent _ _ ModuleTarget{} -> "module"
+ TargetComponent _ _ FileTarget{} -> "file"
+ TargetComponentUnknown _ _ WholeComponent -> "unknown-component"
+ TargetComponentUnknown _ _ ModuleTarget{} -> "unknown-module"
+ TargetComponentUnknown _ _ FileTarget{} -> "unknown-file"
-- ------------------------------------------------------------
+
-- * Checking if targets exist as files
+
-- ------------------------------------------------------------
-data TargetStringFileStatus =
- TargetStringFileStatus1 String FileStatus
- | TargetStringFileStatus2 String FileStatus String
- | TargetStringFileStatus3 String FileStatus String String
- | TargetStringFileStatus4 String String String String
- | TargetStringFileStatus5 String String String String String
- | TargetStringFileStatus7 String String String String String String String
+data TargetStringFileStatus
+ = TargetStringFileStatus1 String FileStatus
+ | TargetStringFileStatus2 String FileStatus String
+ | TargetStringFileStatus3 String FileStatus String String
+ | TargetStringFileStatus4 String String String String
+ | TargetStringFileStatus5 String String String String String
+ | TargetStringFileStatus7 String String String String String String String
deriving (Eq, Ord, Show)
-data FileStatus = FileStatusExistsFile FilePath -- the canonicalised filepath
- | FileStatusExistsDir FilePath -- the canonicalised filepath
- | FileStatusNotExists Bool -- does the parent dir exist even?
+data FileStatus
+ = FileStatusExistsFile FilePath -- the canonicalised filepath
+ | FileStatusExistsDir FilePath -- the canonicalised filepath
+ | FileStatusNotExists Bool -- does the parent dir exist even?
deriving (Eq, Ord, Show)
noFileStatus :: FileStatus
noFileStatus = FileStatusNotExists False
-getTargetStringFileStatus :: (Applicative m, Monad m) => DirActions m
- -> TargetString -> m TargetStringFileStatus
+getTargetStringFileStatus
+ :: (Applicative m, Monad m)
+ => DirActions m
+ -> TargetString
+ -> m TargetStringFileStatus
getTargetStringFileStatus DirActions{..} t =
- case t of
- TargetString1 s1 ->
- (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1
- TargetString2 s1 s2 ->
- (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1
- TargetString3 s1 s2 s3 ->
- (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1
- TargetString4 s1 s2 s3 s4 ->
- return (TargetStringFileStatus4 s1 s2 s3 s4)
- TargetString5 s1 s2 s3 s4 s5 ->
- return (TargetStringFileStatus5 s1 s2 s3 s4 s5)
- TargetString7 s1 s2 s3 s4 s5 s6 s7 ->
- return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7)
+ case t of
+ TargetString1 s1 ->
+ (\f1 -> TargetStringFileStatus1 s1 f1) <$> fileStatus s1
+ TargetString2 s1 s2 ->
+ (\f1 -> TargetStringFileStatus2 s1 f1 s2) <$> fileStatus s1
+ TargetString3 s1 s2 s3 ->
+ (\f1 -> TargetStringFileStatus3 s1 f1 s2 s3) <$> fileStatus s1
+ TargetString4 s1 s2 s3 s4 ->
+ return (TargetStringFileStatus4 s1 s2 s3 s4)
+ TargetString5 s1 s2 s3 s4 s5 ->
+ return (TargetStringFileStatus5 s1 s2 s3 s4 s5)
+ TargetString7 s1 s2 s3 s4 s5 s6 s7 ->
+ return (TargetStringFileStatus7 s1 s2 s3 s4 s5 s6 s7)
where
fileStatus f = do
fexists <- doesFileExist f
dexists <- doesDirectoryExist f
case splitPath f of
- _ | fexists -> FileStatusExistsFile <$> canonicalizePath f
- | dexists -> FileStatusExistsDir <$> canonicalizePath f
- (d:_) -> FileStatusNotExists <$> doesDirectoryExist d
- _ -> pure (FileStatusNotExists False)
+ _
+ | fexists -> FileStatusExistsFile <$> canonicalizePath f
+ | dexists -> FileStatusExistsDir <$> canonicalizePath f
+ (d : _) -> FileStatusNotExists <$> doesDirectoryExist d
+ _ -> pure (FileStatusNotExists False)
forgetFileStatus :: TargetStringFileStatus -> TargetString
forgetFileStatus t = case t of
- TargetStringFileStatus1 s1 _ -> TargetString1 s1
- TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2
- TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3
- TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4
- TargetStringFileStatus5 s1 s2 s3 s4
- s5 -> TargetString5 s1 s2 s3 s4 s5
- TargetStringFileStatus7 s1 s2 s3 s4
- s5 s6 s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7
+ TargetStringFileStatus1 s1 _ -> TargetString1 s1
+ TargetStringFileStatus2 s1 _ s2 -> TargetString2 s1 s2
+ TargetStringFileStatus3 s1 _ s2 s3 -> TargetString3 s1 s2 s3
+ TargetStringFileStatus4 s1 s2 s3 s4 -> TargetString4 s1 s2 s3 s4
+ TargetStringFileStatus5
+ s1
+ s2
+ s3
+ s4
+ s5 -> TargetString5 s1 s2 s3 s4 s5
+ TargetStringFileStatus7
+ s1
+ s2
+ s3
+ s4
+ s5
+ s6
+ s7 -> TargetString7 s1 s2 s3 s4 s5 s6 s7
getFileStatus :: TargetStringFileStatus -> Maybe FileStatus
-getFileStatus (TargetStringFileStatus1 _ f) = Just f
-getFileStatus (TargetStringFileStatus2 _ f _) = Just f
+getFileStatus (TargetStringFileStatus1 _ f) = Just f
+getFileStatus (TargetStringFileStatus2 _ f _) = Just f
getFileStatus (TargetStringFileStatus3 _ f _ _) = Just f
-getFileStatus _ = Nothing
+getFileStatus _ = Nothing
setFileStatus :: FileStatus -> TargetStringFileStatus -> TargetStringFileStatus
-setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f
-setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2
+setFileStatus f (TargetStringFileStatus1 s1 _) = TargetStringFileStatus1 s1 f
+setFileStatus f (TargetStringFileStatus2 s1 _ s2) = TargetStringFileStatus2 s1 f s2
setFileStatus f (TargetStringFileStatus3 s1 _ s2 s3) = TargetStringFileStatus3 s1 f s2 s3
-setFileStatus _ t = t
+setFileStatus _ t = t
copyFileStatus :: TargetStringFileStatus -> TargetStringFileStatus -> TargetStringFileStatus
copyFileStatus src dst =
- case getFileStatus src of
- Just f -> setFileStatus f dst
- Nothing -> dst
+ case getFileStatus src of
+ Just f -> setFileStatus f dst
+ Nothing -> dst
-- ------------------------------------------------------------
+
-- * Resolving target strings to target selectors
--- ------------------------------------------------------------
+-- ------------------------------------------------------------
-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to.
---
-resolveTargetSelectors :: KnownTargets
- -> [TargetStringFileStatus]
- -> Maybe ComponentKindFilter
- -> ([TargetSelectorProblem],
- [TargetSelector])
+resolveTargetSelectors
+ :: KnownTargets
+ -> [TargetStringFileStatus]
+ -> Maybe ComponentKindFilter
+ -> ( [TargetSelectorProblem]
+ , [TargetSelector]
+ )
-- default local dir target if there's no given target:
resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ =
- ([TargetSelectorNoTargetsInProject], [])
-
+ ([TargetSelectorNoTargetsInProject], [])
-- if the component kind filter is just exes, we don't want to suggest "all" as a target.
resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] ckf =
- ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind) ], [])
-
+ ([TargetSelectorNoTargetsInCwd (ckf /= Just ExeKind)], [])
resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ =
- ([], [TargetPackage TargetImplicitCwd pkgids Nothing])
+ ([], [TargetPackage TargetImplicitCwd pkgids Nothing])
where
- pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ]
-
+ pkgids = [pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary]
resolveTargetSelectors knowntargets targetStrs mfilter =
- partitionEithers
- . map (resolveTargetSelector knowntargets mfilter)
- $ targetStrs
-
-resolveTargetSelector :: KnownTargets
- -> Maybe ComponentKindFilter
- -> TargetStringFileStatus
- -> Either TargetSelectorProblem TargetSelector
+ partitionEithers
+ . map (resolveTargetSelector knowntargets mfilter)
+ $ targetStrs
+
+resolveTargetSelector
+ :: KnownTargets
+ -> Maybe ComponentKindFilter
+ -> TargetStringFileStatus
+ -> Either TargetSelectorProblem TargetSelector
resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =
- case findMatch (matcher targetStrStatus) of
-
- Unambiguous _
- | projectIsEmpty -> Left TargetSelectorNoTargetsInProject
-
- Unambiguous (TargetPackage TargetImplicitCwd [] _)
- -> Left (TargetSelectorNoCurrentPackage targetStr)
-
- Unambiguous target -> Right target
-
- None errs
- | projectIsEmpty -> Left TargetSelectorNoTargetsInProject
- | otherwise -> Left (classifyMatchErrors errs)
-
- Ambiguous _ targets
- | Just kfilter <- mfilter
- , [target] <- applyKindFilter kfilter targets -> Right target
-
- Ambiguous exactMatch targets ->
- case disambiguateTargetSelectors
- matcher targetStrStatus exactMatch
- targets of
- Right targets' -> Left (TargetSelectorAmbiguous targetStr targets')
- Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms)
- Left [] -> internalError "resolveTargetSelector"
+ case findMatch (matcher targetStrStatus) of
+ Unambiguous _
+ | projectIsEmpty -> Left TargetSelectorNoTargetsInProject
+ Unambiguous (TargetPackage TargetImplicitCwd [] _) ->
+ Left (TargetSelectorNoCurrentPackage targetStr)
+ Unambiguous target -> Right target
+ None errs
+ | projectIsEmpty -> Left TargetSelectorNoTargetsInProject
+ | otherwise -> Left (classifyMatchErrors errs)
+ Ambiguous _ targets
+ | Just kfilter <- mfilter
+ , [target] <- applyKindFilter kfilter targets ->
+ Right target
+ Ambiguous exactMatch targets ->
+ case disambiguateTargetSelectors
+ matcher
+ targetStrStatus
+ exactMatch
+ targets of
+ Right targets' -> Left (TargetSelectorAmbiguous targetStr targets')
+ Left ((m, ms) : _) -> Left (MatchingInternalError targetStr m ms)
+ Left [] -> internalError "resolveTargetSelector"
where
matcher = matchTargetSelector knowntargets
@@ -519,105 +582,120 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =
projectIsEmpty = null knownPackagesAll
classifyMatchErrors errs
- | Just expectedNE <- NE.nonEmpty expected
- = let (things, got:|_) = NE.unzip expectedNE in
- TargetSelectorExpected targetStr (NE.toList things) got
-
- | not (null nosuch)
- = TargetSelectorNoSuch targetStr nosuch
-
- | otherwise
- = internalError $ "classifyMatchErrors: " ++ show errs
+ | Just expectedNE <- NE.nonEmpty expected =
+ let (things, got :| _) = NE.unzip expectedNE
+ in TargetSelectorExpected targetStr (NE.toList things) got
+ | not (null nosuch) =
+ TargetSelectorNoSuch targetStr nosuch
+ | otherwise =
+ internalError $ "classifyMatchErrors: " ++ show errs
where
- expected = [ (thing, got)
- | (_, MatchErrorExpected thing got)
- <- map (innerErr Nothing) errs ]
+ expected =
+ [ (thing, got)
+ | (_, MatchErrorExpected thing got) <-
+ map (innerErr Nothing) errs
+ ]
-- Trim the list of alternatives by dropping duplicates and
-- retaining only at most three most similar (by edit distance) ones.
- nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $
- [ ((inside, thing, got), Set.fromList alts)
- | (inside, MatchErrorNoSuch thing got alts)
- <- map (innerErr Nothing) errs
- ]
+ nosuch =
+ Map.foldrWithKey genResults [] $
+ Map.fromListWith Set.union $
+ [ ((inside, thing, got), Set.fromList alts)
+ | (inside, MatchErrorNoSuch thing got alts) <-
+ map (innerErr Nothing) errs
+ ]
- genResults (inside, thing, got) alts acc = (
- inside
+ genResults (inside, thing, got) alts acc =
+ ( inside
, thing
, got
- , take maxResults
- $ map fst
- $ takeWhile distanceLow
- $ sortBy (comparing snd)
- $ map addLevDist
- $ Set.toList alts
- ) : acc
+ , take maxResults $
+ map fst $
+ takeWhile distanceLow $
+ sortBy (comparing snd) $
+ map addLevDist $
+ Set.toList alts
+ )
+ : acc
where
- addLevDist = id &&& restrictedDamerauLevenshteinDistance
- defaultEditCosts got
+ addLevDist =
+ id
+ &&& restrictedDamerauLevenshteinDistance
+ defaultEditCosts
+ got
distanceLow (_, dist) = dist < length got `div` 2
maxResults = 3
- innerErr _ (MatchErrorIn kind thing m)
- = innerErr (Just (kind,thing)) m
- innerErr c m = (c,m)
+ innerErr _ (MatchErrorIn kind thing m) =
+ innerErr (Just (kind, thing)) m
+ innerErr c m = (c, m)
applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector]
applyKindFilter kfilter = filter go
where
- go (TargetPackage _ _ (Just filter')) = kfilter == filter'
- go (TargetPackageNamed _ (Just filter')) = kfilter == filter'
- go (TargetAllPackages (Just filter')) = kfilter == filter'
+ go (TargetPackage _ _ (Just filter')) = kfilter == filter'
+ go (TargetPackageNamed _ (Just filter')) = kfilter == filter'
+ go (TargetAllPackages (Just filter')) = kfilter == filter'
go (TargetComponent _ cname _)
- | CLibName _ <- cname = kfilter == LibKind
- | CFLibName _ <- cname = kfilter == FLibKind
- | CExeName _ <- cname = kfilter == ExeKind
- | CTestName _ <- cname = kfilter == TestKind
- | CBenchName _ <- cname = kfilter == BenchKind
- go _ = True
+ | CLibName _ <- cname = kfilter == LibKind
+ | CFLibName _ <- cname = kfilter == FLibKind
+ | CExeName _ <- cname = kfilter == ExeKind
+ | CTestName _ <- cname = kfilter == TestKind
+ | CBenchName _ <- cname = kfilter == BenchKind
+ go _ = True
-- | The various ways that trying to resolve a 'TargetString' to a
-- 'TargetSelector' can fail.
---
data TargetSelectorProblem
- = TargetSelectorExpected TargetString [String] String
- -- ^ [expected thing] (actually got)
- | TargetSelectorNoSuch TargetString
- [(Maybe (String, String), String, String, [String])]
- -- ^ [([in thing], no such thing, actually got, alternatives)]
- | TargetSelectorAmbiguous TargetString
- [(TargetString, TargetSelector)]
-
- | MatchingInternalError TargetString TargetSelector
- [(TargetString, [TargetSelector])]
- | TargetSelectorUnrecognised String
- -- ^ Syntax error when trying to parse a target string.
- | TargetSelectorNoCurrentPackage TargetString
- | TargetSelectorNoTargetsInCwd Bool
- -- ^ bool that flags when it is acceptable to suggest "all" as a target
- | TargetSelectorNoTargetsInProject
- | TargetSelectorNoScript TargetString
+ = -- | [expected thing] (actually got)
+ TargetSelectorExpected TargetString [String] String
+ | -- | [([in thing], no such thing, actually got, alternatives)]
+ TargetSelectorNoSuch
+ TargetString
+ [(Maybe (String, String), String, String, [String])]
+ | TargetSelectorAmbiguous
+ TargetString
+ [(TargetString, TargetSelector)]
+ | MatchingInternalError
+ TargetString
+ TargetSelector
+ [(TargetString, [TargetSelector])]
+ | -- | Syntax error when trying to parse a target string.
+ TargetSelectorUnrecognised String
+ | TargetSelectorNoCurrentPackage TargetString
+ | -- | bool that flags when it is acceptable to suggest "all" as a target
+ TargetSelectorNoTargetsInCwd Bool
+ | TargetSelectorNoTargetsInProject
+ | TargetSelectorNoScript TargetString
deriving (Show, Eq)
-- | Qualification levels.
-- Given the filepath src/F, executable component A, and package foo:
-data QualLevel = QL1 -- ^ @src/F@
- | QL2 -- ^ @foo:src/F | A:src/F@
- | QL3 -- ^ @foo:A:src/F | exe:A:src/F@
- | QLFull -- ^ @pkg:foo:exe:A:file:src/F@
+data QualLevel
+ = -- | @src/F@
+ QL1
+ | -- | @foo:src/F | A:src/F@
+ QL2
+ | -- | @foo:A:src/F | exe:A:src/F@
+ QL3
+ | -- | @pkg:foo:exe:A:file:src/F@
+ QLFull
deriving (Eq, Enum, Show)
disambiguateTargetSelectors
:: (TargetStringFileStatus -> Match TargetSelector)
- -> TargetStringFileStatus -> MatchClass
+ -> TargetStringFileStatus
+ -> MatchClass
-> [TargetSelector]
- -> Either [(TargetSelector, [(TargetString, [TargetSelector])])]
- [(TargetString, TargetSelector)]
+ -> Either
+ [(TargetSelector, [(TargetString, [TargetSelector])])]
+ [(TargetString, TargetSelector)]
disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
- case partitionEithers results of
- (errs@(_:_), _) -> Left errs
- ([], ok) -> Right ok
+ case partitionEithers results of
+ (errs@(_ : _), _) -> Left errs
+ ([], ok) -> Right ok
where
-- So, here's the strategy. We take the original match results, and make a
-- table of all their renderings at all qualification levels.
@@ -636,7 +714,8 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
, let matchRenderings =
[ copyFileStatus matchInput rendering
| ql <- [QL1 .. QLFull]
- , rendering <- renderTargetSelector ql matchResult ]
+ , rendering <- renderTargetSelector ql matchResult
+ ]
]
-- Of course the point is that we're looking for renderings that are
@@ -646,251 +725,314 @@ disambiguateTargetSelectors matcher matchInput exactMatch matchResults =
memoisedMatches :: Map TargetStringFileStatus (Match TargetSelector)
memoisedMatches =
- -- avoid recomputing the main one if it was an exact match
- (if exactMatch == Exact
- then Map.insert matchInput (Match Exact 0 matchResults)
- else id)
- $ Map.Lazy.fromList
- -- (matcher rendering) should *always* be a Match! Otherwise we will hit
- -- the internal error later on.
+ -- avoid recomputing the main one if it was an exact match
+ ( if exactMatch == Exact
+ then Map.insert matchInput (Match Exact 0 matchResults)
+ else id
+ )
+ $ Map.Lazy.fromList
+ -- (matcher rendering) should *always* be a Match! Otherwise we will hit
+ -- the internal error later on.
[ (rendering, matcher rendering)
- | rendering <- concatMap snd matchResultsRenderings ]
+ | rendering <- concatMap snd matchResultsRenderings
+ ]
-- Finally, for each of the match results, we go through all their
-- possible renderings (in order of qualification level, though remember
-- there can be multiple renderings per level), and find the first one
-- that has an unambiguous match.
- results :: [Either (TargetSelector, [(TargetString, [TargetSelector])])
- (TargetString, TargetSelector)]
+ results
+ :: [ Either
+ (TargetSelector, [(TargetString, [TargetSelector])])
+ (TargetString, TargetSelector)
+ ]
results =
[ case findUnambiguous originalMatch matchRenderings of
- Just unambiguousRendering ->
- Right ( forgetFileStatus unambiguousRendering
- , originalMatch)
-
- -- This case is an internal error, but we bubble it up and report it
- Nothing ->
- Left ( originalMatch
- , [ (forgetFileStatus rendering, matches)
- | rendering <- matchRenderings
- , let Match m _ matches =
- memoisedMatches Map.! rendering
- , m /= Inexact
- ] )
-
- | (originalMatch, matchRenderings) <- matchResultsRenderings ]
-
- findUnambiguous :: TargetSelector
- -> [TargetStringFileStatus]
- -> Maybe TargetStringFileStatus
- findUnambiguous _ [] = Nothing
- findUnambiguous t (r:rs) =
+ Just unambiguousRendering ->
+ Right
+ ( forgetFileStatus unambiguousRendering
+ , originalMatch
+ )
+ -- This case is an internal error, but we bubble it up and report it
+ Nothing ->
+ Left
+ ( originalMatch
+ , [ (forgetFileStatus rendering, matches)
+ | rendering <- matchRenderings
+ , let Match m _ matches =
+ memoisedMatches Map.! rendering
+ , m /= Inexact
+ ]
+ )
+ | (originalMatch, matchRenderings) <- matchResultsRenderings
+ ]
+
+ findUnambiguous
+ :: TargetSelector
+ -> [TargetStringFileStatus]
+ -> Maybe TargetStringFileStatus
+ findUnambiguous _ [] = Nothing
+ findUnambiguous t (r : rs) =
case memoisedMatches Map.! r of
- Match Exact _ [t'] | t == t'
- -> Just r
- Match Exact _ _ -> findUnambiguous t rs
+ Match Exact _ [t']
+ | t == t' ->
+ Just r
+ Match Exact _ _ -> findUnambiguous t rs
Match Unknown _ _ -> findUnambiguous t rs
Match Inexact _ _ -> internalError "Match Inexact"
- NoMatch _ _ -> internalError "NoMatch"
+ NoMatch _ _ -> internalError "NoMatch"
internalError :: String -> a
internalError msg =
error $ "TargetSelector: internal error: " ++ msg
-
-- | Throw an exception with a formatted message if there are any problems.
---
reportTargetSelectorProblems :: Verbosity -> [TargetSelectorProblem] -> IO a
reportTargetSelectorProblems verbosity problems = do
-
- case [ str | TargetSelectorUnrecognised str <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
+ case [str | TargetSelectorUnrecognised str <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
[ "Unrecognised target syntax for '" ++ name ++ "'."
- | name <- targets ]
-
- case [ (t, m, ms) | MatchingInternalError t m ms <- problems ] of
- [] -> return ()
- ((target, originalMatch, renderingsAndMatches):_) ->
- die' verbosity $ "Internal error in target matching: could not make an "
- ++ "unambiguous fully qualified target selector for '"
- ++ showTargetString target ++ "'.\n"
- ++ "We made the target '" ++ showTargetSelector originalMatch ++ "' ("
- ++ showTargetSelectorKind originalMatch ++ ") that was expected to "
- ++ "be unambiguous but matches the following targets:\n"
- ++ unlines
- [ "'" ++ showTargetString rendering ++ "', matching:"
- ++ concatMap ("\n - " ++)
- [ showTargetSelector match ++
- " (" ++ showTargetSelectorKind match ++ ")"
- | match <- matches ]
- | (rendering, matches) <- renderingsAndMatches ]
- ++ "\nNote: Cabal expects to be able to make a single fully "
- ++ "qualified name for a target or provide a more specific error. "
- ++ "Our failure to do so is a bug in cabal. "
- ++ "Tracking issue: https://github.com/haskell/cabal/issues/8684"
- ++ "\n\nHint: this may be caused by trying to build a package that "
- ++ "exists in the project directory but is missing from "
- ++ "the 'packages' stanza in your cabal project file."
-
- case [ (t, e, g) | TargetSelectorExpected t e g <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
- [ "Unrecognised target '" ++ showTargetString target
- ++ "'.\n"
- ++ "Expected a " ++ intercalate " or " expected
- ++ ", rather than '" ++ got ++ "'."
- | (target, expected, got) <- targets ]
-
- case [ (t, e) | TargetSelectorNoSuch t e <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
- [ "Unknown target '" ++ showTargetString target ++
- "'.\n" ++ unlines
- [ (case inside of
- Just (kind, "")
- -> "The " ++ kind ++ " has no "
- Just (kind, thing)
- -> "The " ++ kind ++ " " ++ thing ++ " has no "
- Nothing -> "There is no ")
- ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"
- | (thing, got, _alts) <- nosuch' ] ++ "."
- ++ if null alternatives then "" else
- "\nPerhaps you meant " ++ intercalate ";\nor "
- [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?"
- | (thing, alts) <- alternatives ]
- | (inside, nosuch') <- groupByContainer nosuch
- , let alternatives =
- [ (thing, alts)
- | (thing,_got,alts@(_:_)) <- nosuch' ]
+ | name <- targets
+ ]
+
+ case [(t, m, ms) | MatchingInternalError t m ms <- problems] of
+ [] -> return ()
+ ((target, originalMatch, renderingsAndMatches) : _) ->
+ die' verbosity $
+ "Internal error in target matching: could not make an "
+ ++ "unambiguous fully qualified target selector for '"
+ ++ showTargetString target
+ ++ "'.\n"
+ ++ "We made the target '"
+ ++ showTargetSelector originalMatch
+ ++ "' ("
+ ++ showTargetSelectorKind originalMatch
+ ++ ") that was expected to "
+ ++ "be unambiguous but matches the following targets:\n"
+ ++ unlines
+ [ "'"
+ ++ showTargetString rendering
+ ++ "', matching:"
+ ++ concatMap
+ ("\n - " ++)
+ [ showTargetSelector match
+ ++ " ("
+ ++ showTargetSelectorKind match
+ ++ ")"
+ | match <- matches
+ ]
+ | (rendering, matches) <- renderingsAndMatches
]
+ ++ "\nNote: Cabal expects to be able to make a single fully "
+ ++ "qualified name for a target or provide a more specific error. "
+ ++ "Our failure to do so is a bug in cabal. "
+ ++ "Tracking issue: https://github.com/haskell/cabal/issues/8684"
+ ++ "\n\nHint: this may be caused by trying to build a package that "
+ ++ "exists in the project directory but is missing from "
+ ++ "the 'packages' stanza in your cabal project file."
+
+ case [(t, e, g) | TargetSelectorExpected t e g <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
+ [ "Unrecognised target '"
+ ++ showTargetString target
+ ++ "'.\n"
+ ++ "Expected a "
+ ++ intercalate " or " expected
+ ++ ", rather than '"
+ ++ got
+ ++ "'."
+ | (target, expected, got) <- targets
+ ]
+
+ case [(t, e) | TargetSelectorNoSuch t e <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
+ [ "Unknown target '"
+ ++ showTargetString target
+ ++ "'.\n"
+ ++ unlines
+ [ ( case inside of
+ Just (kind, "") ->
+ "The " ++ kind ++ " has no "
+ Just (kind, thing) ->
+ "The " ++ kind ++ " " ++ thing ++ " has no "
+ Nothing -> "There is no "
+ )
+ ++ intercalate
+ " or "
+ [ mungeThing thing ++ " '" ++ got ++ "'"
+ | (thing, got, _alts) <- nosuch'
+ ]
+ ++ "."
+ ++ if null alternatives
+ then ""
+ else
+ "\nPerhaps you meant "
+ ++ intercalate
+ ";\nor "
+ [ "the " ++ thing ++ " '" ++ intercalate "' or '" alts ++ "'?"
+ | (thing, alts) <- alternatives
+ ]
+ | (inside, nosuch') <- groupByContainer nosuch
+ , let alternatives =
+ [ (thing, alts)
+ | (thing, _got, alts@(_ : _)) <- nosuch'
+ ]
+ ]
| (target, nosuch) <- targets
, let groupByContainer =
- map (\g@((inside,_,_,_):_) ->
- (inside, [ (thing,got,alts)
- | (_,thing,got,alts) <- g ]))
- . groupBy ((==) `on` (\(x,_,_,_) -> x))
- . sortBy (compare `on` (\(x,_,_,_) -> x))
+ map
+ ( \g@((inside, _, _, _) : _) ->
+ ( inside
+ , [ (thing, got, alts)
+ | (_, thing, got, alts) <- g
+ ]
+ )
+ )
+ . groupBy ((==) `on` (\(x, _, _, _) -> x))
+ . sortBy (compare `on` (\(x, _, _, _) -> x))
]
- where
- mungeThing "file" = "file target"
- mungeThing thing = thing
-
- case [ (t, ts) | TargetSelectorAmbiguous t ts <- problems ] of
- [] -> return ()
- targets ->
- die' verbosity $ unlines
- [ "Ambiguous target '" ++ showTargetString target
+ where
+ mungeThing "file" = "file target"
+ mungeThing thing = thing
+
+ case [(t, ts) | TargetSelectorAmbiguous t ts <- problems] of
+ [] -> return ()
+ targets ->
+ die' verbosity $
+ unlines
+ [ "Ambiguous target '"
+ ++ showTargetString target
++ "'. It could be:\n "
- ++ unlines [ " "++ showTargetString ut ++
- " (" ++ showTargetSelectorKind bt ++ ")"
- | (ut, bt) <- amb ]
- | (target, amb) <- targets ]
-
- case [ t | TargetSelectorNoCurrentPackage t <- problems ] of
- [] -> return ()
- target:_ ->
- die' verbosity $
- "The target '" ++ showTargetString target ++ "' refers to the "
- ++ "components in the package in the current directory, but there "
- ++ "is no package in the current directory (or at least not listed "
- ++ "as part of the project)."
- --TODO: report a different error if there is a .cabal file but it's
- -- not a member of the project
-
- case [ () | TargetSelectorNoTargetsInCwd True <- problems ] of
- [] -> return ()
- _:_ ->
- die' verbosity $
- "No targets given and there is no package in the current "
- ++ "directory. Use the target 'all' for all packages in the "
- ++ "project or specify packages or components by name or location. "
- ++ "See 'cabal build --help' for more details on target options."
-
- case [ () | TargetSelectorNoTargetsInCwd False <- problems ] of
- [] -> return ()
- _:_ ->
- die' verbosity $
- "No targets given and there is no package in the current "
- ++ "directory. Specify packages or components by name or location. "
- ++ "See 'cabal build --help' for more details on target options."
-
- case [ () | TargetSelectorNoTargetsInProject <- problems ] of
- [] -> return ()
- _:_ ->
- die' verbosity $
- "There is no <pkgname>.cabal package file or cabal.project file. "
- ++ "To build packages locally you need at minimum a <pkgname>.cabal "
- ++ "file. You can use 'cabal init' to create one.\n"
- ++ "\n"
- ++ "For non-trivial projects you will also want a cabal.project "
- ++ "file in the root directory of your project. This file lists the "
- ++ "packages in your project and all other build configuration. "
- ++ "See the Cabal user guide for full details."
-
- case [ t | TargetSelectorNoScript t <- problems ] of
- [] -> return ()
- target:_ ->
- die' verbosity $
- "The script '" ++ showTargetString target ++ "' does not exist, "
- ++ "and only script targets may contain whitespace characters or end "
- ++ "with ':'"
-
- fail "reportTargetSelectorProblems: internal error"
+ ++ unlines
+ [ " "
+ ++ showTargetString ut
+ ++ " ("
+ ++ showTargetSelectorKind bt
+ ++ ")"
+ | (ut, bt) <- amb
+ ]
+ | (target, amb) <- targets
+ ]
+ case [t | TargetSelectorNoCurrentPackage t <- problems] of
+ [] -> return ()
+ target : _ ->
+ die' verbosity $
+ "The target '"
+ ++ showTargetString target
+ ++ "' refers to the "
+ ++ "components in the package in the current directory, but there "
+ ++ "is no package in the current directory (or at least not listed "
+ ++ "as part of the project)."
+ -- TODO: report a different error if there is a .cabal file but it's
+ -- not a member of the project
+
+ case [() | TargetSelectorNoTargetsInCwd True <- problems] of
+ [] -> return ()
+ _ : _ ->
+ die' verbosity $
+ "No targets given and there is no package in the current "
+ ++ "directory. Use the target 'all' for all packages in the "
+ ++ "project or specify packages or components by name or location. "
+ ++ "See 'cabal build --help' for more details on target options."
+
+ case [() | TargetSelectorNoTargetsInCwd False <- problems] of
+ [] -> return ()
+ _ : _ ->
+ die' verbosity $
+ "No targets given and there is no package in the current "
+ ++ "directory. Specify packages or components by name or location. "
+ ++ "See 'cabal build --help' for more details on target options."
+
+ case [() | TargetSelectorNoTargetsInProject <- problems] of
+ [] -> return ()
+ _ : _ ->
+ die' verbosity $
+ "There is no <pkgname>.cabal package file or cabal.project file. "
+ ++ "To build packages locally you need at minimum a <pkgname>.cabal "
+ ++ "file. You can use 'cabal init' to create one.\n"
+ ++ "\n"
+ ++ "For non-trivial projects you will also want a cabal.project "
+ ++ "file in the root directory of your project. This file lists the "
+ ++ "packages in your project and all other build configuration. "
+ ++ "See the Cabal user guide for full details."
+
+ case [t | TargetSelectorNoScript t <- problems] of
+ [] -> return ()
+ target : _ ->
+ die' verbosity $
+ "The script '"
+ ++ showTargetString target
+ ++ "' does not exist, "
+ ++ "and only script targets may contain whitespace characters or end "
+ ++ "with ':'"
+
+ fail "reportTargetSelectorProblems: internal error"
----------------------------------
-- Syntax type
--
-- | Syntax for the 'TargetSelector': the matcher and renderer
---
-data Syntax = Syntax QualLevel Matcher Renderer
- | AmbiguousAlternatives Syntax Syntax
- | ShadowingAlternatives Syntax Syntax
+data Syntax
+ = Syntax QualLevel Matcher Renderer
+ | AmbiguousAlternatives Syntax Syntax
+ | ShadowingAlternatives Syntax Syntax
-type Matcher = TargetStringFileStatus -> Match TargetSelector
+type Matcher = TargetStringFileStatus -> Match TargetSelector
type Renderer = TargetSelector -> [TargetStringFileStatus]
-foldSyntax :: (a -> a -> a) -> (a -> a -> a)
- -> (QualLevel -> Matcher -> Renderer -> a)
- -> (Syntax -> a)
+foldSyntax
+ :: (a -> a -> a)
+ -> (a -> a -> a)
+ -> (QualLevel -> Matcher -> Renderer -> a)
+ -> (Syntax -> a)
foldSyntax ambiguous unambiguous syntax = go
where
- go (Syntax ql match render) = syntax ql match render
- go (AmbiguousAlternatives a b) = ambiguous (go a) (go b)
+ go (Syntax ql match render) = syntax ql match render
+ go (AmbiguousAlternatives a b) = ambiguous (go a) (go b)
go (ShadowingAlternatives a b) = unambiguous (go a) (go b)
-
----------------------------------
-- Top level renderer and matcher
--
-renderTargetSelector :: QualLevel -> TargetSelector
- -> [TargetStringFileStatus]
+renderTargetSelector
+ :: QualLevel
+ -> TargetSelector
+ -> [TargetStringFileStatus]
renderTargetSelector ql ts =
- foldSyntax
- (++) (++)
- (\ql' _ render -> guard (ql == ql') >> render ts)
- syntax
+ foldSyntax
+ (++)
+ (++)
+ (\ql' _ render -> guard (ql == ql') >> render ts)
+ syntax
where
syntax = syntaxForms emptyKnownTargets
- -- don't need known targets for rendering
-matchTargetSelector :: KnownTargets
- -> TargetStringFileStatus
- -> Match TargetSelector
-matchTargetSelector knowntargets = \usertarget ->
- nubMatchesBy (==) $
+-- don't need known targets for rendering
- let ql = targetQualLevel usertarget in
- foldSyntax
- (<|>) (<//>)
- (\ql' match _ -> guard (ql == ql') >> match usertarget)
- syntax
+matchTargetSelector
+ :: KnownTargets
+ -> TargetStringFileStatus
+ -> Match TargetSelector
+matchTargetSelector knowntargets = \usertarget ->
+ nubMatchesBy (==) $
+ let ql = targetQualLevel usertarget
+ in foldSyntax
+ (<|>)
+ (<//>)
+ (\ql' match _ -> guard (ql == ql') >> match usertarget)
+ syntax
where
syntax = syntaxForms knowntargets
@@ -901,21 +1043,20 @@ matchTargetSelector knowntargets = \usertarget ->
targetQualLevel TargetStringFileStatus5{} = QLFull
targetQualLevel TargetStringFileStatus7{} = QLFull
-
----------------------------------
-- Syntax forms
--
-- | All the forms of syntax for 'TargetSelector'.
---
syntaxForms :: KnownTargets -> Syntax
-syntaxForms KnownTargets {
- knownPackagesAll = pinfo,
- knownPackagesPrimary = ppinfo,
- knownComponentsAll = cinfo,
- knownComponentsPrimary = pcinfo,
- knownComponentsOther = ocinfo
- } =
+syntaxForms
+ KnownTargets
+ { knownPackagesAll = pinfo
+ , knownPackagesPrimary = ppinfo
+ , knownComponentsAll = cinfo
+ , knownComponentsPrimary = pcinfo
+ , knownComponentsOther = ocinfo
+ } =
-- The various forms of syntax here are ambiguous in many cases.
-- Our policy is by default we expose that ambiguity and report
-- ambiguous matches. In certain cases we override the ambiguity
@@ -927,72 +1068,65 @@ syntaxForms KnownTargets {
-- not ambiguous like "Q" vs "Q.hs" or "Data.Q" vs "Data/Q".
ambiguousAlternatives
- -- convenient single-component forms
+ -- convenient single-component forms
[ shadowingAlternatives
[ ambiguousAlternatives
[ syntaxForm1All
- , syntaxForm1Filter ppinfo
+ , syntaxForm1Filter ppinfo
, shadowingAlternatives
[ syntaxForm1Component pcinfo
- , syntaxForm1Package pinfo
+ , syntaxForm1Package pinfo
]
]
, syntaxForm1Component ocinfo
- , syntaxForm1Module cinfo
- , syntaxForm1File pinfo
+ , syntaxForm1Module cinfo
+ , syntaxForm1File pinfo
]
-
- -- two-component partially qualified forms
+ , -- two-component partially qualified forms
-- fully qualified form for 'all'
- , syntaxForm2MetaAll
+ syntaxForm2MetaAll
, syntaxForm2AllFilter
, syntaxForm2NamespacePackage pinfo
, syntaxForm2PackageComponent pinfo
- , syntaxForm2PackageFilter pinfo
- , syntaxForm2KindComponent cinfo
+ , syntaxForm2PackageFilter pinfo
+ , syntaxForm2KindComponent cinfo
, shadowingAlternatives
- [ syntaxForm2PackageModule pinfo
- , syntaxForm2PackageFile pinfo
+ [ syntaxForm2PackageModule pinfo
+ , syntaxForm2PackageFile pinfo
]
, shadowingAlternatives
[ syntaxForm2ComponentModule cinfo
- , syntaxForm2ComponentFile cinfo
+ , syntaxForm2ComponentFile cinfo
]
-
- -- rarely used partially qualified forms
- , syntaxForm3PackageKindComponent pinfo
+ , -- rarely used partially qualified forms
+ syntaxForm3PackageKindComponent pinfo
, shadowingAlternatives
[ syntaxForm3PackageComponentModule pinfo
- , syntaxForm3PackageComponentFile pinfo
+ , syntaxForm3PackageComponentFile pinfo
]
, shadowingAlternatives
- [ syntaxForm3KindComponentModule cinfo
- , syntaxForm3KindComponentFile cinfo
+ [ syntaxForm3KindComponentModule cinfo
+ , syntaxForm3KindComponentFile cinfo
]
, syntaxForm3NamespacePackageFilter pinfo
-
- -- fully-qualified forms for all and cwd with filter
- , syntaxForm3MetaAllFilter
+ , -- fully-qualified forms for all and cwd with filter
+ syntaxForm3MetaAllFilter
, syntaxForm3MetaCwdFilter ppinfo
-
- -- fully-qualified form for package and package with filter
- , syntaxForm3MetaNamespacePackage pinfo
+ , -- fully-qualified form for package and package with filter
+ syntaxForm3MetaNamespacePackage pinfo
, syntaxForm4MetaNamespacePackageFilter pinfo
-
- -- fully-qualified forms for component, module and file
- , syntaxForm5MetaNamespacePackageKindComponent pinfo
+ , -- fully-qualified forms for component, module and file
+ syntaxForm5MetaNamespacePackageKindComponent pinfo
, syntaxForm7MetaNamespacePackageKindComponentNamespaceModule pinfo
- , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo
+ , syntaxForm7MetaNamespacePackageKindComponentNamespaceFile pinfo
]
- where
- ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives
- shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives
-
+ where
+ ambiguousAlternatives = Prelude.foldr1 AmbiguousAlternatives
+ shadowingAlternatives = Prelude.foldr1 ShadowingAlternatives
-- | Syntax: "all" to select all packages in the project
--
-- > cabal build all
---
syntaxForm1All :: Syntax
syntaxForm1All =
syntaxForm1 render $ \str1 _fstatus1 -> do
@@ -1006,28 +1140,25 @@ syntaxForm1All =
-- | Syntax: filter
--
-- > cabal build tests
---
syntaxForm1Filter :: [KnownPackage] -> Syntax
syntaxForm1Filter ps =
syntaxForm1 render $ \str1 _fstatus1 -> do
kfilter <- matchComponentKindFilter str1
return (TargetPackage TargetImplicitCwd pids (Just kfilter))
where
- pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]
+ pids = [pinfoId | KnownPackage{pinfoId} <- ps]
render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =
[TargetStringFileStatus1 (dispF kfilter) noFileStatus]
render _ = []
-
-- | Syntax: package (name, dir or file)
--
-- > cabal build foo
-- > cabal build ../bar ../bar/bar.cabal
---
syntaxForm1Package :: [KnownPackage] -> Syntax
syntaxForm1Package pinfo =
syntaxForm1 render $ \str1 fstatus1 -> do
- guardPackage str1 fstatus1
+ guardPackage str1 fstatus1
p <- matchPackage pinfo str1 fstatus1
case p of
KnownPackage{pinfoId} ->
@@ -1044,7 +1175,6 @@ syntaxForm1Package pinfo =
-- | Syntax: component
--
-- > cabal build foo
---
syntaxForm1Component :: [KnownComponent] -> Syntax
syntaxForm1Component cs =
syntaxForm1 render $ \str1 _fstatus1 -> do
@@ -1059,13 +1189,12 @@ syntaxForm1Component cs =
-- | Syntax: module
--
-- > cabal build Data.Foo
---
syntaxForm1Module :: [KnownComponent] -> Syntax
syntaxForm1Module cs =
- syntaxForm1 render $ \str1 _fstatus1 -> do
+ syntaxForm1 render $ \str1 _fstatus1 -> do
guardModuleName str1
- let ms = [ (m,c) | c <- cs, m <- cinfoModules c ]
- (m,c) <- matchModuleNameAnd ms str1
+ let ms = [(m, c) | c <- cs, m <- cinfoModules c]
+ (m, c) <- matchModuleNameAnd ms str1
return (TargetComponent (cinfoPackageId c) (cinfoName c) (ModuleTarget m))
where
render (TargetComponent _p _c (ModuleTarget m)) =
@@ -1075,21 +1204,20 @@ syntaxForm1Module cs =
-- | Syntax: file name
--
-- > cabal build Data/Foo.hs bar/Main.hsc
---
syntaxForm1File :: [KnownPackage] -> Syntax
syntaxForm1File ps =
- -- Note there's a bit of an inconsistency here vs the other syntax forms
- -- for files. For the single-part syntax the target has to point to a file
- -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for
- -- all the other forms we don't require that.
+ -- Note there's a bit of an inconsistency here vs the other syntax forms
+ -- for files. For the single-part syntax the target has to point to a file
+ -- that exists (due to our use of matchPackageDirectoryPrefix), whereas for
+ -- all the other forms we don't require that.
syntaxForm1 render $ \str1 fstatus1 ->
expecting "file" str1 $ do
- (pkgfile, ~KnownPackage{pinfoId, pinfoComponents})
- -- always returns the KnownPackage case
- <- matchPackageDirectoryPrefix ps fstatus1
- orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
- (filepath, c) <- matchComponentFile pinfoComponents pkgfile
- return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
+ (pkgfile, ~KnownPackage{pinfoId, pinfoComponents}) <-
+ -- always returns the KnownPackage case
+ matchPackageDirectoryPrefix ps fstatus1
+ orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
+ (filepath, c) <- matchComponentFile pinfoComponents pkgfile
+ return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
where
render (TargetComponent _p _c (FileTarget f)) =
[TargetStringFileStatus1 f noFileStatus]
@@ -1100,7 +1228,6 @@ syntaxForm1File ps =
-- | Syntax: :all
--
-- > cabal build :all
---
syntaxForm2MetaAll :: Syntax
syntaxForm2MetaAll =
syntaxForm2 render $ \str1 _fstatus1 str2 -> do
@@ -1115,7 +1242,6 @@ syntaxForm2MetaAll =
-- | Syntax: all : filer
--
-- > cabal build all:tests
---
syntaxForm2AllFilter :: Syntax
syntaxForm2AllFilter =
syntaxForm2 render $ \str1 _fstatus1 str2 -> do
@@ -1130,11 +1256,10 @@ syntaxForm2AllFilter =
-- | Syntax: package : filer
--
-- > cabal build foo:tests
---
syntaxForm2PackageFilter :: [KnownPackage] -> Syntax
syntaxForm2PackageFilter ps =
syntaxForm2 render $ \str1 fstatus1 str2 -> do
- guardPackage str1 fstatus1
+ guardPackage str1 fstatus1
p <- matchPackage ps str1 fstatus1
kfilter <- matchComponentKindFilter str2
case p of
@@ -1152,12 +1277,11 @@ syntaxForm2PackageFilter ps =
-- | Syntax: pkg : package name
--
-- > cabal build pkg:foo
---
syntaxForm2NamespacePackage :: [KnownPackage] -> Syntax
syntaxForm2NamespacePackage pinfo =
syntaxForm2 render $ \str1 _fstatus1 str2 -> do
- guardNamespacePackage str1
- guardPackageName str2
+ guardNamespacePackage str1
+ guardPackageName str2
p <- matchPackage pinfo str2 noFileStatus
case p of
KnownPackage{pinfoId} ->
@@ -1176,23 +1300,22 @@ syntaxForm2NamespacePackage pinfo =
-- > cabal build foo:foo
-- > cabal build ./foo:foo
-- > cabal build ./foo.cabal:foo
---
syntaxForm2PackageComponent :: [KnownPackage] -> Syntax
syntaxForm2PackageComponent ps =
syntaxForm2 render $ \str1 fstatus1 str2 -> do
- guardPackage str1 fstatus1
- guardComponentName str2
+ guardPackage str1 fstatus1
+ guardComponentName str2
p <- matchPackage ps str1 fstatus1
case p of
KnownPackage{pinfoId, pinfoComponents} ->
orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
c <- matchComponentName pinfoComponents str2
return (TargetComponent pinfoId (cinfoName c) WholeComponent)
- --TODO: the error here ought to say there's no component by that name in
- -- this package, and name the package
+ -- TODO: the error here ought to say there's no component by that name in
+ -- this package, and name the package
KnownPackageName pn ->
- let cn = mkUnqualComponentName str2 in
- return (TargetComponentUnknown pn (Left cn) WholeComponent)
+ let cn = mkUnqualComponentName str2
+ in return (TargetComponentUnknown pn (Left cn) WholeComponent)
where
render (TargetComponent p c WholeComponent) =
[TargetStringFileStatus2 (dispP p) noFileStatus (dispC p c)]
@@ -1203,7 +1326,6 @@ syntaxForm2PackageComponent ps =
-- | Syntax: namespace : component
--
-- > cabal build lib:foo exe:foo
---
syntaxForm2KindComponent :: [KnownComponent] -> Syntax
syntaxForm2KindComponent cs =
syntaxForm2 render $ \str1 _fstatus1 str2 -> do
@@ -1221,18 +1343,17 @@ syntaxForm2KindComponent cs =
-- > cabal build foo:Data.Foo
-- > cabal build ./foo:Data.Foo
-- > cabal build ./foo.cabal:Data.Foo
---
syntaxForm2PackageModule :: [KnownPackage] -> Syntax
syntaxForm2PackageModule ps =
syntaxForm2 render $ \str1 fstatus1 str2 -> do
- guardPackage str1 fstatus1
- guardModuleName str2
+ guardPackage str1 fstatus1
+ guardModuleName str2
p <- matchPackage ps str1 fstatus1
case p of
KnownPackage{pinfoId, pinfoComponents} ->
orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
- let ms = [ (m,c) | c <- pinfoComponents, m <- cinfoModules c ]
- (m,c) <- matchModuleNameAnd ms str2
+ let ms = [(m, c) | c <- pinfoComponents, m <- cinfoModules c]
+ (m, c) <- matchModuleNameAnd ms str2
return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))
KnownPackageName pn -> do
m <- matchModuleNameUnknown str2
@@ -1246,18 +1367,21 @@ syntaxForm2PackageModule ps =
-- | Syntax: component : module
--
-- > cabal build foo:Data.Foo
---
syntaxForm2ComponentModule :: [KnownComponent] -> Syntax
syntaxForm2ComponentModule cs =
syntaxForm2 render $ \str1 _fstatus1 str2 -> do
guardComponentName str1
- guardModuleName str2
+ guardModuleName str2
c <- matchComponentName cs str1
orNoThingIn "component" (cinfoStrName c) $ do
let ms = cinfoModules c
m <- matchModuleName ms str2
- return (TargetComponent (cinfoPackageId c) (cinfoName c)
- (ModuleTarget m))
+ return
+ ( TargetComponent
+ (cinfoPackageId c)
+ (cinfoName c)
+ (ModuleTarget m)
+ )
where
render (TargetComponent p c (ModuleTarget m)) =
[TargetStringFileStatus2 (dispC p c) noFileStatus (dispM m)]
@@ -1268,11 +1392,10 @@ syntaxForm2ComponentModule cs =
-- > cabal build foo:Data/Foo.hs
-- > cabal build ./foo:Data/Foo.hs
-- > cabal build ./foo.cabal:Data/Foo.hs
---
syntaxForm2PackageFile :: [KnownPackage] -> Syntax
syntaxForm2PackageFile ps =
syntaxForm2 render $ \str1 fstatus1 str2 -> do
- guardPackage str1 fstatus1
+ guardPackage str1 fstatus1
p <- matchPackage ps str1 fstatus1
case p of
KnownPackage{pinfoId, pinfoComponents} ->
@@ -1280,9 +1403,9 @@ syntaxForm2PackageFile ps =
(filepath, c) <- matchComponentFile pinfoComponents str2
return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
KnownPackageName pn ->
- let filepath = str2 in
- -- We assume the primary library component of the package:
- return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath))
+ let filepath = str2
+ in -- We assume the primary library component of the package:
+ return (TargetComponentUnknown pn (Right $ CLibName LMainLibName) (FileTarget filepath))
where
render (TargetComponent p _c (FileTarget f)) =
[TargetStringFileStatus2 (dispP p) noFileStatus f]
@@ -1291,7 +1414,6 @@ syntaxForm2PackageFile ps =
-- | Syntax: component : filename
--
-- > cabal build foo:Data/Foo.hs
---
syntaxForm2ComponentFile :: [KnownComponent] -> Syntax
syntaxForm2ComponentFile cs =
syntaxForm2 render $ \str1 _fstatus1 str2 -> do
@@ -1299,8 +1421,12 @@ syntaxForm2ComponentFile cs =
c <- matchComponentName cs str1
orNoThingIn "component" (cinfoStrName c) $ do
(filepath, _) <- matchComponentFile [c] str2
- return (TargetComponent (cinfoPackageId c) (cinfoName c)
- (FileTarget filepath))
+ return
+ ( TargetComponent
+ (cinfoPackageId c)
+ (cinfoName c)
+ (FileTarget filepath)
+ )
where
render (TargetComponent p c (FileTarget f)) =
[TargetStringFileStatus2 (dispC p c) noFileStatus f]
@@ -1311,7 +1437,6 @@ syntaxForm2ComponentFile cs =
-- | Syntax: :all : filter
--
-- > cabal build :all:tests
---
syntaxForm3MetaAllFilter :: Syntax
syntaxForm3MetaAllFilter =
syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
@@ -1332,7 +1457,7 @@ syntaxForm3MetaCwdFilter ps =
kfilter <- matchComponentKindFilter str3
return (TargetPackage TargetImplicitCwd pids (Just kfilter))
where
- pids = [ pinfoId | KnownPackage{pinfoId} <- ps ]
+ pids = [pinfoId | KnownPackage{pinfoId} <- ps]
render (TargetPackage TargetImplicitCwd _ (Just kfilter)) =
[TargetStringFileStatus3 "" noFileStatus "cwd" (dispF kfilter)]
render _ = []
@@ -1340,13 +1465,12 @@ syntaxForm3MetaCwdFilter ps =
-- | Syntax: :pkg : package name
--
-- > cabal build :pkg:foo
---
syntaxForm3MetaNamespacePackage :: [KnownPackage] -> Syntax
syntaxForm3MetaNamespacePackage pinfo =
syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
- guardNamespaceMeta str1
- guardNamespacePackage str2
- guardPackageName str3
+ guardNamespaceMeta str1
+ guardNamespacePackage str2
+ guardPackageName str3
p <- matchPackage pinfo str3 noFileStatus
case p of
KnownPackage{pinfoId} ->
@@ -1365,13 +1489,12 @@ syntaxForm3MetaNamespacePackage pinfo =
-- > cabal build foo:lib:foo
-- > cabal build foo/:lib:foo
-- > cabal build foo.cabal:lib:foo
---
syntaxForm3PackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm3PackageKindComponent ps =
syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do
- guardPackage str1 fstatus1
+ guardPackage str1 fstatus1
ckind <- matchComponentKind str2
- guardComponentName str3
+ guardComponentName str3
p <- matchPackage ps str1 fstatus1
case p of
KnownPackage{pinfoId, pinfoComponents} ->
@@ -1379,8 +1502,8 @@ syntaxForm3PackageKindComponent ps =
c <- matchComponentKindAndName pinfoComponents ckind str3
return (TargetComponent pinfoId (cinfoName c) WholeComponent)
KnownPackageName pn ->
- let cn = mkComponentName pn ckind (mkUnqualComponentName str3) in
- return (TargetComponentUnknown pn (Right cn) WholeComponent)
+ let cn = mkComponentName pn ckind (mkUnqualComponentName str3)
+ in return (TargetComponentUnknown pn (Right cn) WholeComponent)
where
render (TargetComponent p c WholeComponent) =
[TargetStringFileStatus3 (dispP p) noFileStatus (dispCK c) (dispC p c)]
@@ -1393,13 +1516,12 @@ syntaxForm3PackageKindComponent ps =
-- > cabal build foo:foo:Data.Foo
-- > cabal build foo/:foo:Data.Foo
-- > cabal build foo.cabal:foo:Data.Foo
---
syntaxForm3PackageComponentModule :: [KnownPackage] -> Syntax
syntaxForm3PackageComponentModule ps =
syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do
guardPackage str1 fstatus1
guardComponentName str2
- guardModuleName str3
+ guardModuleName str3
p <- matchPackage ps str1 fstatus1
case p of
KnownPackage{pinfoId, pinfoComponents} ->
@@ -1410,8 +1532,8 @@ syntaxForm3PackageComponentModule ps =
m <- matchModuleName ms str3
return (TargetComponent pinfoId (cinfoName c) (ModuleTarget m))
KnownPackageName pn -> do
- let cn = mkUnqualComponentName str2
- m <- matchModuleNameUnknown str3
+ let cn = mkUnqualComponentName str2
+ m <- matchModuleNameUnknown str3
return (TargetComponentUnknown pn (Left cn) (ModuleTarget m))
where
render (TargetComponent p c (ModuleTarget m)) =
@@ -1423,19 +1545,22 @@ syntaxForm3PackageComponentModule ps =
-- | Syntax: namespace : component : module
--
-- > cabal build lib:foo:Data.Foo
---
syntaxForm3KindComponentModule :: [KnownComponent] -> Syntax
syntaxForm3KindComponentModule cs =
syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
ckind <- matchComponentKind str1
guardComponentName str2
- guardModuleName str3
+ guardModuleName str3
c <- matchComponentKindAndName cs ckind str2
orNoThingIn "component" (cinfoStrName c) $ do
let ms = cinfoModules c
m <- matchModuleName ms str3
- return (TargetComponent (cinfoPackageId c) (cinfoName c)
- (ModuleTarget m))
+ return
+ ( TargetComponent
+ (cinfoPackageId c)
+ (cinfoName c)
+ (ModuleTarget m)
+ )
where
render (TargetComponent p c (ModuleTarget m)) =
[TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) (dispM m)]
@@ -1446,12 +1571,11 @@ syntaxForm3KindComponentModule cs =
-- > cabal build foo:foo:Data/Foo.hs
-- > cabal build foo/:foo:Data/Foo.hs
-- > cabal build foo.cabal:foo:Data/Foo.hs
---
syntaxForm3PackageComponentFile :: [KnownPackage] -> Syntax
syntaxForm3PackageComponentFile ps =
syntaxForm3 render $ \str1 fstatus1 str2 str3 -> do
- guardPackage str1 fstatus1
- guardComponentName str2
+ guardPackage str1 fstatus1
+ guardComponentName str2
p <- matchPackage ps str1 fstatus1
case p of
KnownPackage{pinfoId, pinfoComponents} ->
@@ -1462,8 +1586,8 @@ syntaxForm3PackageComponentFile ps =
return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
KnownPackageName pn ->
let cn = mkUnqualComponentName str2
- filepath = str3 in
- return (TargetComponentUnknown pn (Left cn) (FileTarget filepath))
+ filepath = str3
+ in return (TargetComponentUnknown pn (Left cn) (FileTarget filepath))
where
render (TargetComponent p c (FileTarget f)) =
[TargetStringFileStatus3 (dispP p) noFileStatus (dispC p c) f]
@@ -1474,7 +1598,6 @@ syntaxForm3PackageComponentFile ps =
-- | Syntax: namespace : component : filename
--
-- > cabal build lib:foo:Data/Foo.hs
---
syntaxForm3KindComponentFile :: [KnownComponent] -> Syntax
syntaxForm3KindComponentFile cs =
syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
@@ -1483,8 +1606,12 @@ syntaxForm3KindComponentFile cs =
c <- matchComponentKindAndName cs ckind str2
orNoThingIn "component" (cinfoStrName c) $ do
(filepath, _) <- matchComponentFile [c] str3
- return (TargetComponent (cinfoPackageId c) (cinfoName c)
- (FileTarget filepath))
+ return
+ ( TargetComponent
+ (cinfoPackageId c)
+ (cinfoName c)
+ (FileTarget filepath)
+ )
where
render (TargetComponent p c (FileTarget f)) =
[TargetStringFileStatus3 (dispCK c) noFileStatus (dispC p c) f]
@@ -1494,8 +1621,8 @@ syntaxForm3NamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm3NamespacePackageFilter ps =
syntaxForm3 render $ \str1 _fstatus1 str2 str3 -> do
guardNamespacePackage str1
- guardPackageName str2
- p <- matchPackage ps str2 noFileStatus
+ guardPackageName str2
+ p <- matchPackage ps str2 noFileStatus
kfilter <- matchComponentKindFilter str3
case p of
KnownPackage{pinfoId} ->
@@ -1514,10 +1641,10 @@ syntaxForm3NamespacePackageFilter ps =
syntaxForm4MetaNamespacePackageFilter :: [KnownPackage] -> Syntax
syntaxForm4MetaNamespacePackageFilter ps =
syntaxForm4 render $ \str1 str2 str3 str4 -> do
- guardNamespaceMeta str1
+ guardNamespaceMeta str1
guardNamespacePackage str2
- guardPackageName str3
- p <- matchPackage ps str3 noFileStatus
+ guardPackageName str3
+ p <- matchPackage ps str3 noFileStatus
kfilter <- matchComponentKindFilter str4
case p of
KnownPackage{pinfoId} ->
@@ -1534,24 +1661,23 @@ syntaxForm4MetaNamespacePackageFilter ps =
-- | Syntax: :pkg : package : namespace : component
--
-- > cabal build :pkg:foo:lib:foo
---
syntaxForm5MetaNamespacePackageKindComponent :: [KnownPackage] -> Syntax
syntaxForm5MetaNamespacePackageKindComponent ps =
syntaxForm5 render $ \str1 str2 str3 str4 str5 -> do
- guardNamespaceMeta str1
+ guardNamespaceMeta str1
guardNamespacePackage str2
- guardPackageName str3
+ guardPackageName str3
ckind <- matchComponentKind str4
- guardComponentName str5
- p <- matchPackage ps str3 noFileStatus
+ guardComponentName str5
+ p <- matchPackage ps str3 noFileStatus
case p of
KnownPackage{pinfoId, pinfoComponents} ->
orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
c <- matchComponentKindAndName pinfoComponents ckind str5
return (TargetComponent pinfoId (cinfoName c) WholeComponent)
KnownPackageName pn ->
- let cn = mkComponentName pn ckind (mkUnqualComponentName str5) in
- return (TargetComponentUnknown pn (Right cn) WholeComponent)
+ let cn = mkComponentName pn ckind (mkUnqualComponentName str5)
+ in return (TargetComponentUnknown pn (Right cn) WholeComponent)
where
render (TargetComponent p c WholeComponent) =
[TargetStringFileStatus5 "" "pkg" (dispP p) (dispCK c) (dispC p c)]
@@ -1562,18 +1688,17 @@ syntaxForm5MetaNamespacePackageKindComponent ps =
-- | Syntax: :pkg : package : namespace : component : module : module
--
-- > cabal build :pkg:foo:lib:foo:module:Data.Foo
---
syntaxForm7MetaNamespacePackageKindComponentNamespaceModule
:: [KnownPackage] -> Syntax
syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps =
syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do
- guardNamespaceMeta str1
+ guardNamespaceMeta str1
guardNamespacePackage str2
- guardPackageName str3
+ guardPackageName str3
ckind <- matchComponentKind str4
- guardComponentName str5
- guardNamespaceModule str6
- p <- matchPackage ps str3 noFileStatus
+ guardComponentName str5
+ guardNamespaceModule str6
+ p <- matchPackage ps str3 noFileStatus
case p of
KnownPackage{pinfoId, pinfoComponents} ->
orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
@@ -1588,68 +1713,113 @@ syntaxForm7MetaNamespacePackageKindComponentNamespaceModule ps =
return (TargetComponentUnknown pn (Right cn) (ModuleTarget m))
where
render (TargetComponent p c (ModuleTarget m)) =
- [TargetStringFileStatus7 "" "pkg" (dispP p)
- (dispCK c) (dispC p c)
- "module" (dispM m)]
+ [ TargetStringFileStatus7
+ ""
+ "pkg"
+ (dispP p)
+ (dispCK c)
+ (dispC p c)
+ "module"
+ (dispM m)
+ ]
render (TargetComponentUnknown pn (Right c) (ModuleTarget m)) =
- [TargetStringFileStatus7 "" "pkg" (dispPN pn)
- (dispCK c) (dispC' pn c)
- "module" (dispM m)]
+ [ TargetStringFileStatus7
+ ""
+ "pkg"
+ (dispPN pn)
+ (dispCK c)
+ (dispC' pn c)
+ "module"
+ (dispM m)
+ ]
render _ = []
-- | Syntax: :pkg : package : namespace : component : file : filename
--
-- > cabal build :pkg:foo:lib:foo:file:Data/Foo.hs
---
syntaxForm7MetaNamespacePackageKindComponentNamespaceFile
:: [KnownPackage] -> Syntax
syntaxForm7MetaNamespacePackageKindComponentNamespaceFile ps =
syntaxForm7 render $ \str1 str2 str3 str4 str5 str6 str7 -> do
- guardNamespaceMeta str1
+ guardNamespaceMeta str1
guardNamespacePackage str2
- guardPackageName str3
+ guardPackageName str3
ckind <- matchComponentKind str4
- guardComponentName str5
- guardNamespaceFile str6
- p <- matchPackage ps str3 noFileStatus
+ guardComponentName str5
+ guardNamespaceFile str6
+ p <- matchPackage ps str3 noFileStatus
case p of
KnownPackage{pinfoId, pinfoComponents} ->
orNoThingIn "package" (prettyShow (packageName pinfoId)) $ do
c <- matchComponentKindAndName pinfoComponents ckind str5
orNoThingIn "component" (cinfoStrName c) $ do
- (filepath,_) <- matchComponentFile [c] str7
+ (filepath, _) <- matchComponentFile [c] str7
return (TargetComponent pinfoId (cinfoName c) (FileTarget filepath))
KnownPackageName pn ->
- let cn = mkComponentName pn ckind (mkUnqualComponentName str5)
- filepath = str7 in
- return (TargetComponentUnknown pn (Right cn) (FileTarget filepath))
+ let cn = mkComponentName pn ckind (mkUnqualComponentName str5)
+ filepath = str7
+ in return (TargetComponentUnknown pn (Right cn) (FileTarget filepath))
where
render (TargetComponent p c (FileTarget f)) =
- [TargetStringFileStatus7 "" "pkg" (dispP p)
- (dispCK c) (dispC p c)
- "file" f]
+ [ TargetStringFileStatus7
+ ""
+ "pkg"
+ (dispP p)
+ (dispCK c)
+ (dispC p c)
+ "file"
+ f
+ ]
render (TargetComponentUnknown pn (Right c) (FileTarget f)) =
- [TargetStringFileStatus7 "" "pkg" (dispPN pn)
- (dispCK c) (dispC' pn c)
- "file" f]
+ [ TargetStringFileStatus7
+ ""
+ "pkg"
+ (dispPN pn)
+ (dispCK c)
+ (dispC' pn c)
+ "file"
+ f
+ ]
render _ = []
-
---------------------------------------
-- Syntax utils
--
type Match1 = String -> FileStatus -> Match TargetSelector
-type Match2 = String -> FileStatus -> String
- -> Match TargetSelector
-type Match3 = String -> FileStatus -> String -> String
- -> Match TargetSelector
-type Match4 = String -> String -> String -> String
- -> Match TargetSelector
-type Match5 = String -> String -> String -> String -> String
- -> Match TargetSelector
-type Match7 = String -> String -> String -> String -> String -> String -> String
- -> Match TargetSelector
+type Match2 =
+ String
+ -> FileStatus
+ -> String
+ -> Match TargetSelector
+type Match3 =
+ String
+ -> FileStatus
+ -> String
+ -> String
+ -> Match TargetSelector
+type Match4 =
+ String
+ -> String
+ -> String
+ -> String
+ -> Match TargetSelector
+type Match5 =
+ String
+ -> String
+ -> String
+ -> String
+ -> String
+ -> Match TargetSelector
+type Match7 =
+ String
+ -> String
+ -> String
+ -> String
+ -> String
+ -> String
+ -> String
+ -> Match TargetSelector
syntaxForm1 :: Renderer -> Match1 -> Syntax
syntaxForm2 :: Renderer -> Match2 -> Syntax
@@ -1657,44 +1827,43 @@ syntaxForm3 :: Renderer -> Match3 -> Syntax
syntaxForm4 :: Renderer -> Match4 -> Syntax
syntaxForm5 :: Renderer -> Match5 -> Syntax
syntaxForm7 :: Renderer -> Match7 -> Syntax
-
syntaxForm1 render f =
- Syntax QL1 match render
+ Syntax QL1 match render
where
match = \(TargetStringFileStatus1 str1 fstatus1) ->
- f str1 fstatus1
+ f str1 fstatus1
syntaxForm2 render f =
- Syntax QL2 match render
+ Syntax QL2 match render
where
match = \(TargetStringFileStatus2 str1 fstatus1 str2) ->
- f str1 fstatus1 str2
+ f str1 fstatus1 str2
syntaxForm3 render f =
- Syntax QL3 match render
+ Syntax QL3 match render
where
match = \(TargetStringFileStatus3 str1 fstatus1 str2 str3) ->
- f str1 fstatus1 str2 str3
+ f str1 fstatus1 str2 str3
syntaxForm4 render f =
- Syntax QLFull match render
+ Syntax QLFull match render
where
- match (TargetStringFileStatus4 str1 str2 str3 str4)
- = f str1 str2 str3 str4
+ match (TargetStringFileStatus4 str1 str2 str3 str4) =
+ f str1 str2 str3 str4
match _ = mzero
syntaxForm5 render f =
- Syntax QLFull match render
+ Syntax QLFull match render
where
- match (TargetStringFileStatus5 str1 str2 str3 str4 str5)
- = f str1 str2 str3 str4 str5
+ match (TargetStringFileStatus5 str1 str2 str3 str4 str5) =
+ f str1 str2 str3 str4 str5
match _ = mzero
syntaxForm7 render f =
- Syntax QLFull match render
+ Syntax QLFull match render
where
- match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7)
- = f str1 str2 str3 str4 str5 str6 str7
+ match (TargetStringFileStatus7 str1 str2 str3 str4 str5 str6 str7) =
+ f str1 str2 str3 str4 str5 str6 str7
match _ = mzero
dispP :: Package p => p -> String
@@ -1724,166 +1893,179 @@ dispF = showComponentKindFilterShort
dispM :: ModuleName -> String
dispM = prettyShow
-
-------------------------------
-- Package and component info
--
-data KnownTargets = KnownTargets {
- knownPackagesAll :: [KnownPackage],
- knownPackagesPrimary :: [KnownPackage],
- knownPackagesOther :: [KnownPackage],
- knownComponentsAll :: [KnownComponent],
- knownComponentsPrimary :: [KnownComponent],
- knownComponentsOther :: [KnownComponent]
- }
- deriving Show
-
-data KnownPackage =
- KnownPackage {
- pinfoId :: PackageId,
- pinfoDirectory :: Maybe (FilePath, FilePath),
- pinfoPackageFile :: Maybe (FilePath, FilePath),
- pinfoComponents :: [KnownComponent]
- }
- | KnownPackageName {
- pinfoName :: PackageName
- }
- deriving Show
-
-data KnownComponent = KnownComponent {
- cinfoName :: ComponentName,
- cinfoStrName :: ComponentStringName,
- cinfoPackageId :: PackageId,
- cinfoSrcDirs :: [FilePath],
- cinfoModules :: [ModuleName],
- cinfoHsFiles :: [FilePath], -- other hs files (like main.hs)
- cinfoCFiles :: [FilePath],
- cinfoJsFiles :: [FilePath]
- }
- deriving Show
+data KnownTargets = KnownTargets
+ { knownPackagesAll :: [KnownPackage]
+ , knownPackagesPrimary :: [KnownPackage]
+ , knownPackagesOther :: [KnownPackage]
+ , knownComponentsAll :: [KnownComponent]
+ , knownComponentsPrimary :: [KnownComponent]
+ , knownComponentsOther :: [KnownComponent]
+ }
+ deriving (Show)
+
+data KnownPackage
+ = KnownPackage
+ { pinfoId :: PackageId
+ , pinfoDirectory :: Maybe (FilePath, FilePath)
+ , pinfoPackageFile :: Maybe (FilePath, FilePath)
+ , pinfoComponents :: [KnownComponent]
+ }
+ | KnownPackageName
+ { pinfoName :: PackageName
+ }
+ deriving (Show)
+
+data KnownComponent = KnownComponent
+ { cinfoName :: ComponentName
+ , cinfoStrName :: ComponentStringName
+ , cinfoPackageId :: PackageId
+ , cinfoSrcDirs :: [FilePath]
+ , cinfoModules :: [ModuleName]
+ , cinfoHsFiles :: [FilePath] -- other hs files (like main.hs)
+ , cinfoCFiles :: [FilePath]
+ , cinfoJsFiles :: [FilePath]
+ }
+ deriving (Show)
type ComponentStringName = String
knownPackageName :: KnownPackage -> PackageName
-knownPackageName KnownPackage{pinfoId} = packageName pinfoId
+knownPackageName KnownPackage{pinfoId} = packageName pinfoId
knownPackageName KnownPackageName{pinfoName} = pinfoName
emptyKnownTargets :: KnownTargets
emptyKnownTargets = KnownTargets [] [] [] [] [] []
-getKnownTargets :: forall m a. (Applicative m, Monad m)
- => DirActions m
- -> [PackageSpecifier (SourcePackage (PackageLocation a))]
- -> m KnownTargets
+getKnownTargets
+ :: forall m a
+ . (Applicative m, Monad m)
+ => DirActions m
+ -> [PackageSpecifier (SourcePackage (PackageLocation a))]
+ -> m KnownTargets
getKnownTargets dirActions@DirActions{..} pkgs = do
- pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs
- cwd <- getCurrentDirectory
- (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo
- return KnownTargets {
- knownPackagesAll = pinfo,
- knownPackagesPrimary = ppinfo,
- knownPackagesOther = opinfo,
- knownComponentsAll = allComponentsIn pinfo,
- knownComponentsPrimary = allComponentsIn ppinfo,
- knownComponentsOther = allComponentsIn opinfo
- }
+ pinfo <- traverse (collectKnownPackageInfo dirActions) pkgs
+ cwd <- getCurrentDirectory
+ (ppinfo, opinfo) <- selectPrimaryPackage cwd pinfo
+ return
+ KnownTargets
+ { knownPackagesAll = pinfo
+ , knownPackagesPrimary = ppinfo
+ , knownPackagesOther = opinfo
+ , knownComponentsAll = allComponentsIn pinfo
+ , knownComponentsPrimary = allComponentsIn ppinfo
+ , knownComponentsOther = allComponentsIn opinfo
+ }
where
mPkgDir :: KnownPackage -> Maybe FilePath
- mPkgDir KnownPackage { pinfoDirectory = Just (dir,_) } = Just dir
+ mPkgDir KnownPackage{pinfoDirectory = Just (dir, _)} = Just dir
mPkgDir _ = Nothing
- selectPrimaryPackage :: FilePath
- -> [KnownPackage]
- -> m ([KnownPackage], [KnownPackage])
- selectPrimaryPackage _ [] = return ([] , [])
+ selectPrimaryPackage
+ :: FilePath
+ -> [KnownPackage]
+ -> m ([KnownPackage], [KnownPackage])
+ selectPrimaryPackage _ [] = return ([], [])
selectPrimaryPackage cwd (pkg : packages) = do
(ppinfo, opinfo) <- selectPrimaryPackage cwd packages
isPkgDirCwd <- maybe (pure False) (compareFilePath dirActions cwd) (mPkgDir pkg)
return (if isPkgDirCwd then (pkg : ppinfo, opinfo) else (ppinfo, pkg : opinfo))
allComponentsIn ps =
- [ c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents ]
+ [c | KnownPackage{pinfoComponents} <- ps, c <- pinfoComponents]
-
-collectKnownPackageInfo :: (Applicative m, Monad m) => DirActions m
- -> PackageSpecifier (SourcePackage (PackageLocation a))
- -> m KnownPackage
+collectKnownPackageInfo
+ :: (Applicative m, Monad m)
+ => DirActions m
+ -> PackageSpecifier (SourcePackage (PackageLocation a))
+ -> m KnownPackage
collectKnownPackageInfo _ (NamedPackage pkgname _props) =
- return (KnownPackageName pkgname)
-collectKnownPackageInfo dirActions@DirActions{..}
- (SpecificSourcePackage SourcePackage {
- srcpkgDescription = pkg,
- srcpkgSource = loc
- }) = do
+ return (KnownPackageName pkgname)
+collectKnownPackageInfo
+ dirActions@DirActions{..}
+ ( SpecificSourcePackage
+ SourcePackage
+ { srcpkgDescription = pkg
+ , srcpkgSource = loc
+ }
+ ) = do
(pkgdir, pkgfile) <-
case loc of
- --TODO: local tarballs, remote tarballs etc
+ -- TODO: local tarballs, remote tarballs etc
LocalUnpackedPackage dir -> do
dirabs <- canonicalizePath dir
dirrel <- makeRelativeToCwd dirActions dirabs
- --TODO: ought to get this earlier in project reading
+ -- TODO: ought to get this earlier in project reading
let fileabs = dirabs </> prettyShow (packageName pkg) <.> "cabal"
filerel = dirrel </> prettyShow (packageName pkg) <.> "cabal"
exists <- doesFileExist fileabs
- return ( Just (dirabs, dirrel)
- , if exists then Just (fileabs, filerel) else Nothing
- )
+ return
+ ( Just (dirabs, dirrel)
+ , if exists then Just (fileabs, filerel) else Nothing
+ )
_ -> return (Nothing, Nothing)
let pinfo =
- KnownPackage {
- pinfoId = packageId pkg,
- pinfoDirectory = pkgdir,
- pinfoPackageFile = pkgfile,
- pinfoComponents = collectKnownComponentInfo
- (flattenPackageDescription pkg)
- }
+ KnownPackage
+ { pinfoId = packageId pkg
+ , pinfoDirectory = pkgdir
+ , pinfoPackageFile = pkgfile
+ , pinfoComponents =
+ collectKnownComponentInfo
+ (flattenPackageDescription pkg)
+ }
return pinfo
-
collectKnownComponentInfo :: PackageDescription -> [KnownComponent]
collectKnownComponentInfo pkg =
- [ KnownComponent {
- cinfoName = componentName c,
- cinfoStrName = componentStringName (packageName pkg) (componentName c),
- cinfoPackageId = packageId pkg,
- cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi)),
- cinfoModules = ordNub (componentModules c),
- cinfoHsFiles = ordNub (componentHsFiles c),
- cinfoCFiles = ordNub (cSources bi),
- cinfoJsFiles = ordNub (jsSources bi)
- }
- | c <- pkgComponents pkg
- , let bi = componentBuildInfo c ]
-
+ [ KnownComponent
+ { cinfoName = componentName c
+ , cinfoStrName = componentStringName (packageName pkg) (componentName c)
+ , cinfoPackageId = packageId pkg
+ , cinfoSrcDirs = ordNub (map getSymbolicPath (hsSourceDirs bi))
+ , cinfoModules = ordNub (componentModules c)
+ , cinfoHsFiles = ordNub (componentHsFiles c)
+ , cinfoCFiles = ordNub (cSources bi)
+ , cinfoJsFiles = ordNub (jsSources bi)
+ }
+ | c <- pkgComponents pkg
+ , let bi = componentBuildInfo c
+ ]
componentStringName :: PackageName -> ComponentName -> ComponentStringName
componentStringName pkgname (CLibName LMainLibName) = prettyShow pkgname
componentStringName _ (CLibName (LSubLibName name)) = unUnqualComponentName name
-componentStringName _ (CFLibName name) = unUnqualComponentName name
-componentStringName _ (CExeName name) = unUnqualComponentName name
-componentStringName _ (CTestName name) = unUnqualComponentName name
+componentStringName _ (CFLibName name) = unUnqualComponentName name
+componentStringName _ (CExeName name) = unUnqualComponentName name
+componentStringName _ (CTestName name) = unUnqualComponentName name
componentStringName _ (CBenchName name) = unUnqualComponentName name
componentModules :: Component -> [ModuleName]
-- I think it's unlikely users will ask to build a requirement
-- which is not mentioned locally.
-componentModules (CLib lib) = explicitLibModules lib
-componentModules (CFLib flib) = foreignLibModules flib
-componentModules (CExe exe) = exeModules exe
-componentModules (CTest test) = testModules test
+componentModules (CLib lib) = explicitLibModules lib
+componentModules (CFLib flib) = foreignLibModules flib
+componentModules (CExe exe) = exeModules exe
+componentModules (CTest test) = testModules test
componentModules (CBench bench) = benchmarkModules bench
componentHsFiles :: Component -> [FilePath]
componentHsFiles (CExe exe) = [modulePath exe]
-componentHsFiles (CTest TestSuite {
- testInterface = TestSuiteExeV10 _ mainfile
- }) = [mainfile]
-componentHsFiles (CBench Benchmark {
- benchmarkInterface = BenchmarkExeV10 _ mainfile
- }) = [mainfile]
-componentHsFiles _ = []
-
+componentHsFiles
+ ( CTest
+ TestSuite
+ { testInterface = TestSuiteExeV10 _ mainfile
+ }
+ ) = [mainfile]
+componentHsFiles
+ ( CBench
+ Benchmark
+ { benchmarkInterface = BenchmarkExeV10 _ mainfile
+ }
+ ) = [mainfile]
+componentHsFiles _ = []
------------------------------
-- Matching meta targets
@@ -1910,18 +2092,17 @@ guardNamespaceFile = guardToken ["file"] "'file' namespace"
guardToken :: [String] -> String -> String -> Match ()
guardToken tokens msg s
| caseFold s `elem` tokens = increaseConfidence
- | otherwise = matchErrorExpected msg s
-
+ | otherwise = matchErrorExpected msg s
------------------------------
-- Matching component kinds
--
componentKind :: ComponentName -> ComponentKind
-componentKind (CLibName _) = LibKind
-componentKind (CFLibName _) = FLibKind
-componentKind (CExeName _) = ExeKind
-componentKind (CTestName _) = TestKind
+componentKind (CLibName _) = LibKind
+componentKind (CFLibName _) = FLibKind
+componentKind (CExeName _) = ExeKind
+componentKind (CTestName _) = TestKind
componentKind (CBenchName _) = BenchKind
cinfoKind :: KnownComponent -> ComponentKind
@@ -1929,186 +2110,195 @@ cinfoKind = componentKind . cinfoName
matchComponentKind :: String -> Match ComponentKind
matchComponentKind s
- | s' `elem` liblabels = increaseConfidence >> return LibKind
- | s' `elem` fliblabels = increaseConfidence >> return FLibKind
- | s' `elem` exelabels = increaseConfidence >> return ExeKind
- | s' `elem` testlabels = increaseConfidence >> return TestKind
+ | s' `elem` liblabels = increaseConfidence >> return LibKind
+ | s' `elem` fliblabels = increaseConfidence >> return FLibKind
+ | s' `elem` exelabels = increaseConfidence >> return ExeKind
+ | s' `elem` testlabels = increaseConfidence >> return TestKind
| s' `elem` benchlabels = increaseConfidence >> return BenchKind
- | otherwise = matchErrorExpected "component kind" s
+ | otherwise = matchErrorExpected "component kind" s
where
- s' = caseFold s
- liblabels = ["lib", "library"]
- fliblabels = ["flib", "foreign-library"]
- exelabels = ["exe", "executable"]
- testlabels = ["tst", "test", "test-suite"]
+ s' = caseFold s
+ liblabels = ["lib", "library"]
+ fliblabels = ["flib", "foreign-library"]
+ exelabels = ["exe", "executable"]
+ testlabels = ["tst", "test", "test-suite"]
benchlabels = ["bench", "benchmark"]
matchComponentKindFilter :: String -> Match ComponentKind
matchComponentKindFilter s
- | s' `elem` liblabels = increaseConfidence >> return LibKind
- | s' `elem` fliblabels = increaseConfidence >> return FLibKind
- | s' `elem` exelabels = increaseConfidence >> return ExeKind
- | s' `elem` testlabels = increaseConfidence >> return TestKind
+ | s' `elem` liblabels = increaseConfidence >> return LibKind
+ | s' `elem` fliblabels = increaseConfidence >> return FLibKind
+ | s' `elem` exelabels = increaseConfidence >> return ExeKind
+ | s' `elem` testlabels = increaseConfidence >> return TestKind
| s' `elem` benchlabels = increaseConfidence >> return BenchKind
- | otherwise = matchErrorExpected "component kind filter" s
+ | otherwise = matchErrorExpected "component kind filter" s
where
- s' = caseFold s
- liblabels = ["libs", "libraries"]
- fliblabels = ["flibs", "foreign-libraries"]
- exelabels = ["exes", "executables"]
- testlabels = ["tests", "test-suites"]
+ s' = caseFold s
+ liblabels = ["libs", "libraries"]
+ fliblabels = ["flibs", "foreign-libraries"]
+ exelabels = ["exes", "executables"]
+ testlabels = ["tests", "test-suites"]
benchlabels = ["benches", "benchmarks"]
showComponentKind :: ComponentKind -> String
-showComponentKind LibKind = "library"
-showComponentKind FLibKind = "foreign library"
-showComponentKind ExeKind = "executable"
-showComponentKind TestKind = "test-suite"
+showComponentKind LibKind = "library"
+showComponentKind FLibKind = "foreign library"
+showComponentKind ExeKind = "executable"
+showComponentKind TestKind = "test-suite"
showComponentKind BenchKind = "benchmark"
showComponentKindShort :: ComponentKind -> String
-showComponentKindShort LibKind = "lib"
-showComponentKindShort FLibKind = "flib"
-showComponentKindShort ExeKind = "exe"
-showComponentKindShort TestKind = "test"
+showComponentKindShort LibKind = "lib"
+showComponentKindShort FLibKind = "flib"
+showComponentKindShort ExeKind = "exe"
+showComponentKindShort TestKind = "test"
showComponentKindShort BenchKind = "bench"
showComponentKindFilterShort :: ComponentKind -> String
-showComponentKindFilterShort LibKind = "libs"
-showComponentKindFilterShort FLibKind = "flibs"
-showComponentKindFilterShort ExeKind = "exes"
-showComponentKindFilterShort TestKind = "tests"
+showComponentKindFilterShort LibKind = "libs"
+showComponentKindFilterShort FLibKind = "flibs"
+showComponentKindFilterShort ExeKind = "exes"
+showComponentKindFilterShort TestKind = "tests"
showComponentKindFilterShort BenchKind = "benchmarks"
-
------------------------------
-- Matching package targets
--
guardPackage :: String -> FileStatus -> Match ()
guardPackage str fstatus =
- guardPackageName str
- <|> guardPackageDir str fstatus
- <|> guardPackageFile str fstatus
-
+ guardPackageName str
+ <|> guardPackageDir str fstatus
+ <|> guardPackageFile str fstatus
guardPackageName :: String -> Match ()
guardPackageName s
| validPackageName s = increaseConfidence
- | otherwise = matchErrorExpected "package name" s
+ | otherwise = matchErrorExpected "package name" s
validPackageName :: String -> Bool
validPackageName s =
- all validPackageNameChar s
+ all validPackageNameChar s
&& not (null s)
where
validPackageNameChar c = isAlphaNum c || c == '-'
-
guardPackageDir :: String -> FileStatus -> Match ()
guardPackageDir _ (FileStatusExistsDir _) = increaseConfidence
guardPackageDir str _ = matchErrorExpected "package directory" str
-
guardPackageFile :: String -> FileStatus -> Match ()
guardPackageFile _ (FileStatusExistsFile file)
- | takeExtension file == ".cabal"
- = increaseConfidence
+ | takeExtension file == ".cabal" =
+ increaseConfidence
guardPackageFile str _ = matchErrorExpected "package .cabal file" str
-
matchPackage :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackage pinfo = \str fstatus ->
- orNoThingIn "project" "" $
- matchPackageName pinfo str
- <//> (matchPackageNameUnknown str
- <|> matchPackageDir pinfo str fstatus
- <|> matchPackageFile pinfo str fstatus)
-
+ orNoThingIn "project" "" $
+ matchPackageName pinfo str
+ <//> ( matchPackageNameUnknown str
+ <|> matchPackageDir pinfo str fstatus
+ <|> matchPackageFile pinfo str fstatus
+ )
matchPackageName :: [KnownPackage] -> String -> Match KnownPackage
matchPackageName ps = \str -> do
- guard (validPackageName str)
- orNoSuchThing "package" str
- (map (prettyShow . knownPackageName) ps) $
- increaseConfidenceFor $
- matchInexactly caseFold (prettyShow . knownPackageName) ps str
-
+ guard (validPackageName str)
+ orNoSuchThing
+ "package"
+ str
+ (map (prettyShow . knownPackageName) ps)
+ $ increaseConfidenceFor
+ $ matchInexactly caseFold (prettyShow . knownPackageName) ps str
matchPackageNameUnknown :: String -> Match KnownPackage
matchPackageNameUnknown str = do
- pn <- matchParse str
- unknownMatch (KnownPackageName pn)
-
-
-matchPackageDir :: [KnownPackage]
- -> String -> FileStatus -> Match KnownPackage
+ pn <- matchParse str
+ unknownMatch (KnownPackageName pn)
+
+matchPackageDir
+ :: [KnownPackage]
+ -> String
+ -> FileStatus
+ -> Match KnownPackage
matchPackageDir ps = \str fstatus ->
- case fstatus of
- FileStatusExistsDir canondir ->
- orNoSuchThing "package directory" str (map (snd . fst) dirs) $
- increaseConfidenceFor $
- fmap snd $ matchExactly (fst . fst) dirs canondir
- _ -> mzero
+ case fstatus of
+ FileStatusExistsDir canondir ->
+ orNoSuchThing "package directory" str (map (snd . fst) dirs) $
+ increaseConfidenceFor $
+ fmap snd $
+ matchExactly (fst . fst) dirs canondir
+ _ -> mzero
where
- dirs = [ ((dabs,drel),p)
- | p@KnownPackage{ pinfoDirectory = Just (dabs,drel) } <- ps ]
-
+ dirs =
+ [ ((dabs, drel), p)
+ | p@KnownPackage{pinfoDirectory = Just (dabs, drel)} <- ps
+ ]
matchPackageFile :: [KnownPackage] -> String -> FileStatus -> Match KnownPackage
matchPackageFile ps = \str fstatus -> do
- case fstatus of
- FileStatusExistsFile canonfile ->
- orNoSuchThing "package .cabal file" str (map (snd . fst) files) $
- increaseConfidenceFor $
- fmap snd $ matchExactly (fst . fst) files canonfile
- _ -> mzero
+ case fstatus of
+ FileStatusExistsFile canonfile ->
+ orNoSuchThing "package .cabal file" str (map (snd . fst) files) $
+ increaseConfidenceFor $
+ fmap snd $
+ matchExactly (fst . fst) files canonfile
+ _ -> mzero
where
- files = [ ((fabs,frel),p)
- | p@KnownPackage{ pinfoPackageFile = Just (fabs,frel) } <- ps ]
+ files =
+ [ ((fabs, frel), p)
+ | p@KnownPackage{pinfoPackageFile = Just (fabs, frel)} <- ps
+ ]
---TODO: test outcome when dir exists but doesn't match any known one
+-- TODO: test outcome when dir exists but doesn't match any known one
---TODO: perhaps need another distinction, vs no such thing, point is the
+-- TODO: perhaps need another distinction, vs no such thing, point is the
-- thing is not known, within the project, but could be outside project
-
------------------------------
-- Matching component targets
--
-
guardComponentName :: String -> Match ()
guardComponentName s
| all validComponentChar s
- && not (null s) = increaseConfidence
- | otherwise = matchErrorExpected "component name" s
+ && not (null s) =
+ increaseConfidence
+ | otherwise = matchErrorExpected "component name" s
where
- validComponentChar c = isAlphaNum c || c == '.'
- || c == '_' || c == '-' || c == '\''
-
+ validComponentChar c =
+ isAlphaNum c
+ || c == '.'
+ || c == '_'
+ || c == '-'
+ || c == '\''
matchComponentName :: [KnownComponent] -> String -> Match KnownComponent
matchComponentName cs str =
- orNoSuchThing "component" str (map cinfoStrName cs)
- $ increaseConfidenceFor
- $ matchInexactly caseFold cinfoStrName cs str
-
+ orNoSuchThing "component" str (map cinfoStrName cs) $
+ increaseConfidenceFor $
+ matchInexactly caseFold cinfoStrName cs str
-matchComponentKindAndName :: [KnownComponent] -> ComponentKind -> String
- -> Match KnownComponent
+matchComponentKindAndName
+ :: [KnownComponent]
+ -> ComponentKind
+ -> String
+ -> Match KnownComponent
matchComponentKindAndName cs ckind str =
- orNoSuchThing (showComponentKind ckind ++ " component") str
- (map render cs)
- $ increaseConfidenceFor
- $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))
- (\c -> (cinfoKind c, cinfoStrName c))
- cs
- (ckind, str)
+ orNoSuchThing
+ (showComponentKind ckind ++ " component")
+ str
+ (map render cs)
+ $ increaseConfidenceFor
+ $ matchInexactly
+ (\(ck, cn) -> (ck, caseFold cn))
+ (\c -> (cinfoKind c, cinfoStrName c))
+ cs
+ (ckind, str)
where
render c = showComponentKindShort (cinfoKind c) ++ ":" ++ cinfoStrName c
-
------------------------------
-- Matching module targets
--
@@ -2116,109 +2306,119 @@ matchComponentKindAndName cs ckind str =
guardModuleName :: String -> Match ()
guardModuleName s =
case simpleParsec s :: Maybe ModuleName of
- Just _ -> increaseConfidence
- _ | all validModuleChar s
- && not (null s) -> return ()
- | otherwise -> matchErrorExpected "module name" s
- where
- validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''
-
+ Just _ -> increaseConfidence
+ _
+ | all validModuleChar s
+ && not (null s) ->
+ return ()
+ | otherwise -> matchErrorExpected "module name" s
+ where
+ validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''
matchModuleName :: [ModuleName] -> String -> Match ModuleName
matchModuleName ms str =
- orNoSuchThing "module" str (map prettyShow ms)
- $ increaseConfidenceFor
- $ matchInexactly caseFold prettyShow ms str
-
+ orNoSuchThing "module" str (map prettyShow ms) $
+ increaseConfidenceFor $
+ matchInexactly caseFold prettyShow ms str
matchModuleNameAnd :: [(ModuleName, a)] -> String -> Match (ModuleName, a)
matchModuleNameAnd ms str =
- orNoSuchThing "module" str (map (prettyShow . fst) ms)
- $ increaseConfidenceFor
- $ matchInexactly caseFold (prettyShow . fst) ms str
-
+ orNoSuchThing "module" str (map (prettyShow . fst) ms) $
+ increaseConfidenceFor $
+ matchInexactly caseFold (prettyShow . fst) ms str
matchModuleNameUnknown :: String -> Match ModuleName
matchModuleNameUnknown str =
- expecting "module" str
- $ increaseConfidenceFor
- $ matchParse str
-
+ expecting "module" str $
+ increaseConfidenceFor $
+ matchParse str
------------------------------
-- Matching file targets
--
-matchPackageDirectoryPrefix :: [KnownPackage] -> FileStatus
- -> Match (FilePath, KnownPackage)
+matchPackageDirectoryPrefix
+ :: [KnownPackage]
+ -> FileStatus
+ -> Match (FilePath, KnownPackage)
matchPackageDirectoryPrefix ps (FileStatusExistsFile filepath) =
- increaseConfidenceFor $
- matchDirectoryPrefix pkgdirs filepath
+ increaseConfidenceFor $
+ matchDirectoryPrefix pkgdirs filepath
where
- pkgdirs = [ (dir, p)
- | p@KnownPackage { pinfoDirectory = Just (dir,_) } <- ps ]
+ pkgdirs =
+ [ (dir, p)
+ | p@KnownPackage{pinfoDirectory = Just (dir, _)} <- ps
+ ]
matchPackageDirectoryPrefix _ _ = mzero
-
-matchComponentFile :: [KnownComponent] -> String
- -> Match (FilePath, KnownComponent)
+matchComponentFile
+ :: [KnownComponent]
+ -> String
+ -> Match (FilePath, KnownComponent)
matchComponentFile cs str =
- orNoSuchThing "file" str [] $
- matchComponentModuleFile cs str
- <|> matchComponentOtherFile cs str
-
-
-matchComponentOtherFile :: [KnownComponent] -> String
- -> Match (FilePath, KnownComponent)
+ orNoSuchThing "file" str [] $
+ matchComponentModuleFile cs str
+ <|> matchComponentOtherFile cs str
+
+matchComponentOtherFile
+ :: [KnownComponent]
+ -> String
+ -> Match (FilePath, KnownComponent)
matchComponentOtherFile cs =
- matchFile
- [ (normalise (srcdir </> file), c)
- | c <- cs
- , srcdir <- cinfoSrcDirs c
- , file <- cinfoHsFiles c
- ++ cinfoCFiles c
- ++ cinfoJsFiles c
- ]
- . normalise
-
-
-matchComponentModuleFile :: [KnownComponent] -> String
- -> Match (FilePath, KnownComponent)
+ matchFile
+ [ (normalise (srcdir </> file), c)
+ | c <- cs
+ , srcdir <- cinfoSrcDirs c
+ , file <-
+ cinfoHsFiles c
+ ++ cinfoCFiles c
+ ++ cinfoJsFiles c
+ ]
+ . normalise
+
+matchComponentModuleFile
+ :: [KnownComponent]
+ -> String
+ -> Match (FilePath, KnownComponent)
matchComponentModuleFile cs str = do
- matchFile
- [ (normalise (d </> toFilePath m), c)
- | c <- cs
- , d <- cinfoSrcDirs c
- , m <- cinfoModules c
- ]
- (dropExtension (normalise str)) -- Drop the extension because FileTarget
- -- is stored without the extension
+ matchFile
+ [ (normalise (d </> toFilePath m), c)
+ | c <- cs
+ , d <- cinfoSrcDirs c
+ , m <- cinfoModules c
+ ]
+ (dropExtension (normalise str)) -- Drop the extension because FileTarget
+ -- is stored without the extension
-- utils
-- | Compare two filepaths for equality using DirActions' canonicalizePath
-- to normalize AND canonicalize filepaths before comparison.
-compareFilePath :: (Applicative m, Monad m) => DirActions m
- -> FilePath -> FilePath -> m Bool
+compareFilePath
+ :: (Applicative m, Monad m)
+ => DirActions m
+ -> FilePath
+ -> FilePath
+ -> m Bool
compareFilePath DirActions{..} fp1 fp2
| equalFilePath fp1 fp2 = pure True -- avoid unnecessary IO if we can match earlier
| otherwise = do
- c1 <- canonicalizePath fp1
- c2 <- canonicalizePath fp2
- pure $ equalFilePath c1 c2
-
+ c1 <- canonicalizePath fp1
+ c2 <- canonicalizePath fp2
+ pure $ equalFilePath c1 c2
matchFile :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)
matchFile fs =
- increaseConfidenceFor
+ increaseConfidenceFor
. matchInexactly caseFold fst fs
matchDirectoryPrefix :: [(FilePath, a)] -> FilePath -> Match (FilePath, a)
matchDirectoryPrefix dirs filepath =
- tryEach $
- [ (file, x)
- | (dir,x) <- dirs
- , file <- maybeToList (stripDirectory dir) ]
+ tryEach $
+ [ (file, x)
+ | (dir, x) <- dirs
+ , file <- maybeToList (stripDirectory dir)
+ ]
where
stripDirectory :: FilePath -> Maybe FilePath
stripDirectory dir =
@@ -2226,7 +2426,6 @@ matchDirectoryPrefix dirs filepath =
filepathsplit = splitDirectories filepath
-
------------------------------
-- Matching monad
--
@@ -2237,61 +2436,65 @@ matchDirectoryPrefix dirs filepath =
-- There are various matcher primitives ('matchExactly', 'matchInexactly'),
-- ways to combine matchers ('matchPlus', 'matchPlusShadowing') and finally we
-- can run a matcher against an input using 'findMatch'.
---
-data Match a = NoMatch !Confidence [MatchError]
- | Match !MatchClass !Confidence [a]
- deriving Show
+data Match a
+ = NoMatch !Confidence [MatchError]
+ | Match !MatchClass !Confidence [a]
+ deriving (Show)
-- | The kind of match, inexact or exact. We keep track of this so we can
-- prefer exact over inexact matches. The 'Ord' here is important: we try
-- to maximise this, so 'Exact' is the top value and 'Inexact' the bottom.
---
-data MatchClass = Unknown -- ^ Matches an unknown thing e.g. parses as a package
- -- name without it being a specific known package
- | Inexact -- ^ Matches a known thing inexactly
- -- e.g. matches a known package case insensitively
- | Exact -- ^ Exactly matches a known thing,
- -- e.g. matches a known package case sensitively
+data MatchClass
+ = -- | Matches an unknown thing e.g. parses as a package
+ -- name without it being a specific known package
+ Unknown
+ | -- | Matches a known thing inexactly
+ -- e.g. matches a known package case insensitively
+ Inexact
+ | -- | Exactly matches a known thing,
+ -- e.g. matches a known package case sensitively
+ Exact
deriving (Show, Eq, Ord)
type Confidence = Int
-data MatchError = MatchErrorExpected String String -- thing got
- | MatchErrorNoSuch String String [String] -- thing got alts
- | MatchErrorIn String String MatchError -- kind thing
+data MatchError
+ = MatchErrorExpected String String -- thing got
+ | MatchErrorNoSuch String String [String] -- thing got alts
+ | MatchErrorIn String String MatchError -- kind thing
deriving (Show, Eq)
-
instance Functor Match where
- fmap _ (NoMatch d ms) = NoMatch d ms
- fmap f (Match m d xs) = Match m d (fmap f xs)
+ fmap _ (NoMatch d ms) = NoMatch d ms
+ fmap f (Match m d xs) = Match m d (fmap f xs)
instance Applicative Match where
- pure a = Match Exact 0 [a]
- (<*>) = ap
+ pure a = Match Exact 0 [a]
+ (<*>) = ap
instance Alternative Match where
- empty = NoMatch 0 []
- (<|>) = matchPlus
+ empty = NoMatch 0 []
+ (<|>) = matchPlus
instance Monad Match where
- return = pure
- NoMatch d ms >>= _ = NoMatch d ms
- Match m d xs >>= f =
- -- To understand this, it needs to be read in context with the
- -- implementation of 'matchPlus' below
- case msum (map f xs) of
- Match m' d' xs' -> Match (min m m') (d + d') xs'
- -- The minimum match class is the one we keep. The match depth is
- -- tracked but not used in the Match case.
-
- NoMatch d' ms -> NoMatch (d + d') ms
- -- Here is where we transfer the depth we were keeping track of in
- -- the Match case over to the NoMatch case where it finally gets used.
+ return = pure
+ NoMatch d ms >>= _ = NoMatch d ms
+ Match m d xs >>= f =
+ -- To understand this, it needs to be read in context with the
+ -- implementation of 'matchPlus' below
+ case msum (map f xs) of
+ Match m' d' xs' -> Match (min m m') (d + d') xs'
+ -- The minimum match class is the one we keep. The match depth is
+ -- tracked but not used in the Match case.
+
+ NoMatch d' ms -> NoMatch (d + d') ms
+
+-- Here is where we transfer the depth we were keeping track of in
+-- the Match case over to the NoMatch case where it finally gets used.
instance MonadPlus Match where
- mzero = empty
- mplus = matchPlus
+ mzero = empty
+ mplus = matchPlus
(<//>) :: Match a -> Match a -> Match a
(<//>) = matchPlusShadowing
@@ -2303,17 +2506,16 @@ infixl 3 <//>
-- ambiguous matches.
--
-- This operator is associative, has unit 'mzero' and is also commutative.
---
matchPlus :: Match a -> Match a -> Match a
-matchPlus a@(Match _ _ _ ) (NoMatch _ _) = a
-matchPlus (NoMatch _ _ ) b@(Match _ _ _) = b
+matchPlus a@(Match _ _ _) (NoMatch _ _) = a
+matchPlus (NoMatch _ _) b@(Match _ _ _) = b
matchPlus a@(NoMatch d_a ms_a) b@(NoMatch d_b ms_b)
- | d_a > d_b = a -- We only really make use of the depth in the NoMatch case.
+ | d_a > d_b = a -- We only really make use of the depth in the NoMatch case.
| d_a < d_b = b
| otherwise = NoMatch d_a (ms_a ++ ms_b)
matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b)
- | m_a > m_b = a -- exact over inexact
- | m_a < m_b = b -- exact over inexact
+ | m_a > m_b = a -- exact over inexact
+ | m_a < m_b = b -- exact over inexact
| otherwise = Match m_a (max d_a d_b) (xs_a ++ xs_b)
-- | Combine two matchers. This is similar to 'matchPlus' with the
@@ -2321,33 +2523,31 @@ matchPlus a@(Match m_a d_a xs_a) b@(Match m_b d_b xs_b)
-- match on the right. Inexact matches are still collected however.
--
-- This operator is associative, has unit 'mzero' and is not commutative.
---
matchPlusShadowing :: Match a -> Match a -> Match a
matchPlusShadowing a@(Match Exact _ _) _ = a
-matchPlusShadowing a b = matchPlus a b
-
+matchPlusShadowing a b = matchPlus a b
------------------------------
-- Various match primitives
--
matchErrorExpected :: String -> String -> Match a
-matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
+matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]
matchErrorNoSuch :: String -> String -> [String] -> Match a
matchErrorNoSuch thing got alts = NoMatch 0 [MatchErrorNoSuch thing got alts]
expecting :: String -> String -> Match a -> Match a
expecting thing got (NoMatch 0 _) = matchErrorExpected thing got
-expecting _ _ m = m
+expecting _ _ m = m
orNoSuchThing :: String -> String -> [String] -> Match a -> Match a
orNoSuchThing thing got alts (NoMatch 0 _) = matchErrorNoSuch thing got alts
-orNoSuchThing _ _ _ m = m
+orNoSuchThing _ _ _ m = m
orNoThingIn :: String -> String -> Match a -> Match a
orNoThingIn kind name (NoMatch n ms) =
- NoMatch n [ MatchErrorIn kind name m | m <- ms ]
+ NoMatch n [MatchErrorIn kind name m | m <- ms]
orNoThingIn _ _ m = m
increaseConfidence :: Match ()
@@ -2357,16 +2557,13 @@ increaseConfidenceFor :: Match a -> Match a
increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r
nubMatchesBy :: (a -> a -> Bool) -> Match a -> Match a
-nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs
-nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs)
+nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs
+nubMatchesBy eq (Match m d xs) = Match m d (nubBy eq xs)
-- | Lift a list of matches to an exact match.
---
exactMatches, inexactMatches :: [a] -> Match a
-
exactMatches [] = mzero
exactMatches xs = Match Exact 0 xs
-
inexactMatches [] = mzero
inexactMatches xs = Match Inexact 0 xs
@@ -2376,7 +2573,6 @@ unknownMatch x = Match Unknown 0 [x]
tryEach :: [a] -> Match a
tryEach = exactMatches
-
------------------------------
-- Top level match runner
--
@@ -2384,23 +2580,23 @@ tryEach = exactMatches
-- | Given a matcher and a key to look up, use the matcher to find all the
-- possible matches. There may be 'None', a single 'Unambiguous' match or
-- you may have an 'Ambiguous' match with several possibilities.
---
findMatch :: Match a -> MaybeAmbiguous a
findMatch match = case match of
NoMatch _ msgs -> None msgs
- Match _ _ [x] -> Unambiguous x
- Match m d [] -> error $ "findMatch: impossible: " ++ show match'
- where match' = Match m d [] :: Match ()
- -- TODO: Maybe use Data.List.NonEmpty inside
- -- Match so that this case would be correct
- -- by construction?
- Match m _ xs -> Ambiguous m xs
-
-data MaybeAmbiguous a = None [MatchError]
- | Unambiguous a
- | Ambiguous MatchClass [a]
- deriving Show
-
+ Match _ _ [x] -> Unambiguous x
+ Match m d [] -> error $ "findMatch: impossible: " ++ show match'
+ where
+ match' = Match m d [] :: Match ()
+ -- TODO: Maybe use Data.List.NonEmpty inside
+ -- Match so that this case would be correct
+ -- by construction?
+ Match m _ xs -> Ambiguous m xs
+
+data MaybeAmbiguous a
+ = None [MatchError]
+ | Unambiguous a
+ | Ambiguous MatchClass [a]
+ deriving (Show)
------------------------------
-- Basic matchers
@@ -2408,14 +2604,13 @@ data MaybeAmbiguous a = None [MatchError]
-- | A primitive matcher that looks up a value in a finite 'Map'. The
-- value must match exactly.
---
matchExactly :: Ord k => (a -> k) -> [a] -> (k -> Match a)
matchExactly key xs =
- \k -> case Map.lookup k m of
- Nothing -> mzero
- Just ys -> exactMatches ys
+ \k -> case Map.lookup k m of
+ Nothing -> mzero
+ Just ys -> exactMatches ys
where
- m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]
+ m = Map.fromListWith (++) [(key x, [x]) | x <- xs]
-- | A primitive matcher that looks up a value in a finite 'Map'. It checks
-- for an exact or inexact match. We get an inexact match if the match
@@ -2425,17 +2620,20 @@ matchExactly key xs =
-- So for example if we used string case fold as the canonicalisation
-- function, then we would get case insensitive matching (but it will still
-- report an exact match when the case matches too).
---
-matchInexactly :: (Ord k, Ord k') => (k -> k') -> (a -> k)
- -> [a] -> (k -> Match a)
+matchInexactly
+ :: (Ord k, Ord k')
+ => (k -> k')
+ -> (a -> k)
+ -> [a]
+ -> (k -> Match a)
matchInexactly cannonicalise key xs =
- \k -> case Map.lookup k m of
- Just ys -> exactMatches ys
- Nothing -> case Map.lookup (cannonicalise k) m' of
- Just ys -> inexactMatches ys
- Nothing -> mzero
+ \k -> case Map.lookup k m of
+ Just ys -> exactMatches ys
+ Nothing -> case Map.lookup (cannonicalise k) m' of
+ Just ys -> inexactMatches ys
+ Nothing -> mzero
where
- m = Map.fromListWith (++) [ (key x, [x]) | x <- xs ]
+ m = Map.fromListWith (++) [(key x, [x]) | x <- xs]
-- the map of canonicalised keys to groups of inexact matches
m' = Map.mapKeysWith (++) cannonicalise m
@@ -2443,7 +2641,6 @@ matchInexactly cannonicalise key xs =
matchParse :: Parsec a => String -> Match a
matchParse = maybe mzero return . simpleParsec
-
------------------------------
-- Utils
--
@@ -2454,22 +2651,21 @@ caseFold = lowercase
-- | Make a 'ComponentName' given an 'UnqualComponentName' and knowing the
-- 'ComponentKind'. We also need the 'PackageName' to distinguish the package's
-- primary library from named private libraries.
---
-mkComponentName :: PackageName
- -> ComponentKind
- -> UnqualComponentName
- -> ComponentName
+mkComponentName
+ :: PackageName
+ -> ComponentKind
+ -> UnqualComponentName
+ -> ComponentName
mkComponentName pkgname ckind ucname =
case ckind of
LibKind
- | packageNameToUnqualComponentName pkgname == ucname
- -> CLibName LMainLibName
+ | packageNameToUnqualComponentName pkgname == ucname ->
+ CLibName LMainLibName
| otherwise -> CLibName $ LSubLibName ucname
- FLibKind -> CFLibName ucname
- ExeKind -> CExeName ucname
- TestKind -> CTestName ucname
- BenchKind -> CBenchName ucname
-
+ FLibKind -> CFLibName ucname
+ ExeKind -> CExeName ucname
+ TestKind -> CTestName ucname
+ BenchKind -> CBenchName ucname
------------------------------
-- Example inputs
diff --git a/cabal-install/src/Distribution/Client/Targets.hs b/cabal-install/src/Distribution/Client/Targets.hs
index 8c6d866d14cdac51bd232cd92515f1042b3da487..71ee03d8bcabe3c34f95c0452e72c384ac6eb71d 100644
--- a/cabal-install/src/Distribution/Client/Targets.hs
+++ b/cabal-install/src/Distribution/Client/Targets.hs
@@ -1,9 +1,14 @@
{-# LANGUAGE CPP #-}
-{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Targets
-- Copyright : (c) Duncan Coutts 2011
@@ -12,540 +17,590 @@
-- Maintainer : duncan@community.haskell.org
--
-- Handling for user-specified targets
------------------------------------------------------------------------------
-module Distribution.Client.Targets (
- -- * User targets
- UserTarget(..),
- readUserTargets,
-
- -- * Resolving user targets to package specifiers
- resolveUserTargets,
-
- -- ** Detailed interface
- UserTargetProblem(..),
- readUserTarget,
- reportUserTargetProblems,
- expandUserTarget,
-
- PackageTarget(..),
- fetchPackageTarget,
- readPackageTarget,
-
- PackageTargetProblem(..),
- reportPackageTargetProblems,
-
- disambiguatePackageTargets,
- disambiguatePackageName,
-
- -- * User constraints
- UserQualifier(..),
- UserConstraintScope(..),
- UserConstraint(..),
- userConstraintPackageName,
- readUserConstraint,
- userToPackageConstraint,
-
+module Distribution.Client.Targets
+ ( -- * User targets
+ UserTarget (..)
+ , readUserTargets
+
+ -- * Resolving user targets to package specifiers
+ , resolveUserTargets
+
+ -- ** Detailed interface
+ , UserTargetProblem (..)
+ , readUserTarget
+ , reportUserTargetProblems
+ , expandUserTarget
+ , PackageTarget (..)
+ , fetchPackageTarget
+ , readPackageTarget
+ , PackageTargetProblem (..)
+ , reportPackageTargetProblems
+ , disambiguatePackageTargets
+ , disambiguatePackageName
+
+ -- * User constraints
+ , UserQualifier (..)
+ , UserConstraintScope (..)
+ , UserConstraint (..)
+ , userConstraintPackageName
+ , readUserConstraint
+ , userToPackageConstraint
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Package
- ( Package(..), PackageName, unPackageName, mkPackageName
- , packageName )
import Distribution.Client.Types
- ( PackageLocation(..), ResolvedPkgLoc, UnresolvedSourcePackage
- , PackageSpecifier(..) )
-
-import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PackageConstraint
-import Distribution.Solver.Types.PackagePath
-import Distribution.Solver.Types.PackageIndex (PackageIndex)
+ ( PackageLocation (..)
+ , PackageSpecifier (..)
+ , ResolvedPkgLoc
+ , UnresolvedSourcePackage
+ )
+import Distribution.Package
+ ( Package (..)
+ , PackageName
+ , mkPackageName
+ , packageName
+ , unPackageName
+ )
+
+import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackageConstraint
+import Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
-import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.PackagePath
+import Distribution.Solver.Types.SourcePackage
-import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as Tar
-import qualified Distribution.Client.Tar as Tar
import Distribution.Client.FetchUtils
-import Distribution.Client.Utils ( tryFindPackageDesc )
import Distribution.Client.GlobalFlags
- ( RepoContext(..) )
+ ( RepoContext (..)
+ )
+import qualified Distribution.Client.Tar as Tar
+import Distribution.Client.Utils (tryFindPackageDesc)
import Distribution.Types.PackageVersionConstraint
- ( PackageVersionConstraint (..) )
+ ( PackageVersionConstraint (..)
+ )
import Distribution.PackageDescription
- ( GenericPackageDescription )
+ ( GenericPackageDescription
+ )
+import Distribution.Simple.Utils
+ ( die'
+ , lowercase
+ )
import Distribution.Types.Flag
- ( parsecFlagAssignmentNonEmpty )
+ ( parsecFlagAssignmentNonEmpty
+ )
import Distribution.Version
- ( isAnyVersion )
-import Distribution.Simple.Utils
- ( die', lowercase )
+ ( isAnyVersion
+ )
import Distribution.PackageDescription.Parsec
- ( parseGenericPackageDescriptionMaybe )
+ ( parseGenericPackageDescriptionMaybe
+ )
import Distribution.Simple.PackageDescription
- ( readGenericPackageDescription )
+ ( readGenericPackageDescription
+ )
-import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as BS
+import qualified Data.Map as Map
import qualified Distribution.Client.GZipUtils as GZipUtils
import qualified Distribution.Compat.CharParsing as P
-import System.FilePath
- ( takeExtension, dropExtension, takeDirectory, splitPath )
-import System.Directory
- ( doesFileExist, doesDirectoryExist )
import Network.URI
- ( URI(..), URIAuth(..), parseAbsoluteURI )
+ ( URI (..)
+ , URIAuth (..)
+ , parseAbsoluteURI
+ )
+import System.Directory
+ ( doesDirectoryExist
+ , doesFileExist
+ )
+import System.FilePath
+ ( dropExtension
+ , splitPath
+ , takeDirectory
+ , takeExtension
+ )
-- ------------------------------------------------------------
+
-- * User targets
+
-- ------------------------------------------------------------
-- | Various ways that a user may specify a package or package collection.
---
-data UserTarget =
-
- -- | A partially specified package, identified by name and possibly with
- -- an exact version or a version constraint.
- --
- -- > cabal install foo
- -- > cabal install foo-1.0
- -- > cabal install 'foo < 2'
- --
- UserTargetNamed PackageVersionConstraint
-
- -- | A specific package that is unpacked in a local directory, often the
- -- current directory.
- --
- -- > cabal install .
- -- > cabal install ../lib/other
- --
- -- * Note: in future, if multiple @.cabal@ files are allowed in a single
- -- directory then this will refer to the collection of packages.
- --
- | UserTargetLocalDir FilePath
-
- -- | A specific local unpacked package, identified by its @.cabal@ file.
- --
- -- > cabal install foo.cabal
- -- > cabal install ../lib/other/bar.cabal
- --
- | UserTargetLocalCabalFile FilePath
-
- -- | A specific package that is available as a local tarball file
- --
- -- > cabal install dist/foo-1.0.tar.gz
- -- > cabal install ../build/baz-1.0.tar.gz
- --
- | UserTargetLocalTarball FilePath
-
- -- | A specific package that is available as a remote tarball file
- --
- -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz
- --
- | UserTargetRemoteTarball URI
- deriving (Show,Eq)
-
+data UserTarget
+ = -- | A partially specified package, identified by name and possibly with
+ -- an exact version or a version constraint.
+ --
+ -- > cabal install foo
+ -- > cabal install foo-1.0
+ -- > cabal install 'foo < 2'
+ UserTargetNamed PackageVersionConstraint
+ | -- | A specific package that is unpacked in a local directory, often the
+ -- current directory.
+ --
+ -- > cabal install .
+ -- > cabal install ../lib/other
+ --
+ -- * Note: in future, if multiple @.cabal@ files are allowed in a single
+ -- directory then this will refer to the collection of packages.
+ UserTargetLocalDir FilePath
+ | -- | A specific local unpacked package, identified by its @.cabal@ file.
+ --
+ -- > cabal install foo.cabal
+ -- > cabal install ../lib/other/bar.cabal
+ UserTargetLocalCabalFile FilePath
+ | -- | A specific package that is available as a local tarball file
+ --
+ -- > cabal install dist/foo-1.0.tar.gz
+ -- > cabal install ../build/baz-1.0.tar.gz
+ UserTargetLocalTarball FilePath
+ | -- | A specific package that is available as a remote tarball file
+ --
+ -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz
+ UserTargetRemoteTarball URI
+ deriving (Show, Eq)
-- ------------------------------------------------------------
+
-- * Parsing and checking user targets
+
-- ------------------------------------------------------------
readUserTargets :: Verbosity -> [String] -> IO [UserTarget]
readUserTargets verbosity targetStrs = do
- (problems, targets) <- liftM partitionEithers
- (traverse readUserTarget targetStrs)
- reportUserTargetProblems verbosity problems
- return targets
-
+ (problems, targets) <-
+ liftM
+ partitionEithers
+ (traverse readUserTarget targetStrs)
+ reportUserTargetProblems verbosity problems
+ return targets
data UserTargetProblem
- = UserTargetUnexpectedFile String
- | UserTargetNonexistantFile String
- | UserTargetUnexpectedUriScheme String
- | UserTargetUnrecognisedUri String
- | UserTargetUnrecognised String
- deriving Show
+ = UserTargetUnexpectedFile String
+ | UserTargetNonexistantFile String
+ | UserTargetUnexpectedUriScheme String
+ | UserTargetUnrecognisedUri String
+ | UserTargetUnrecognised String
+ deriving (Show)
readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)
readUserTarget targetstr =
- case eitherParsec targetstr of
- Right dep -> return (Right (UserTargetNamed dep))
- Left _err -> do
- fileTarget <- testFileTargets targetstr
- case fileTarget of
- Just target -> return target
- Nothing ->
- case testUriTargets targetstr of
- Just target -> return target
- Nothing -> return (Left (UserTargetUnrecognised targetstr))
+ case eitherParsec targetstr of
+ Right dep -> return (Right (UserTargetNamed dep))
+ Left _err -> do
+ fileTarget <- testFileTargets targetstr
+ case fileTarget of
+ Just target -> return target
+ Nothing ->
+ case testUriTargets targetstr of
+ Just target -> return target
+ Nothing -> return (Left (UserTargetUnrecognised targetstr))
where
testFileTargets :: FilePath -> IO (Maybe (Either UserTargetProblem UserTarget))
testFileTargets filename = do
- isDir <- doesDirectoryExist filename
+ isDir <- doesDirectoryExist filename
isFile <- doesFileExist filename
parentDirExists <- case takeDirectory filename of
- [] -> return False
- dir -> doesDirectoryExist dir
+ [] -> return False
+ dir -> doesDirectoryExist dir
let result :: Maybe (Either UserTargetProblem UserTarget)
result
- | isDir
- = Just (Right (UserTargetLocalDir filename))
-
- | isFile && extensionIsTarGz filename
- = Just (Right (UserTargetLocalTarball filename))
-
- | isFile && takeExtension filename == ".cabal"
- = Just (Right (UserTargetLocalCabalFile filename))
-
- | isFile
- = Just (Left (UserTargetUnexpectedFile filename))
-
- | parentDirExists
- = Just (Left (UserTargetNonexistantFile filename))
-
- | otherwise
- = Nothing
+ | isDir =
+ Just (Right (UserTargetLocalDir filename))
+ | isFile && extensionIsTarGz filename =
+ Just (Right (UserTargetLocalTarball filename))
+ | isFile && takeExtension filename == ".cabal" =
+ Just (Right (UserTargetLocalCabalFile filename))
+ | isFile =
+ Just (Left (UserTargetUnexpectedFile filename))
+ | parentDirExists =
+ Just (Left (UserTargetNonexistantFile filename))
+ | otherwise =
+ Nothing
return result
testUriTargets :: String -> Maybe (Either UserTargetProblem UserTarget)
testUriTargets str =
case parseAbsoluteURI str of
- Just uri@URI {
- uriScheme = scheme,
- uriAuthority = Just URIAuth { uriRegName = host }
- }
- | scheme /= "http:" && scheme /= "https:" ->
- Just (Left (UserTargetUnexpectedUriScheme targetstr))
-
- | null host ->
- Just (Left (UserTargetUnrecognisedUri targetstr))
-
- | otherwise ->
- Just (Right (UserTargetRemoteTarball uri))
+ Just
+ uri@URI
+ { uriScheme = scheme
+ , uriAuthority = Just URIAuth{uriRegName = host}
+ }
+ | scheme /= "http:" && scheme /= "https:" ->
+ Just (Left (UserTargetUnexpectedUriScheme targetstr))
+ | null host ->
+ Just (Left (UserTargetUnrecognisedUri targetstr))
+ | otherwise ->
+ Just (Right (UserTargetRemoteTarball uri))
_ -> Nothing
extensionIsTarGz :: FilePath -> Bool
- extensionIsTarGz f = takeExtension f == ".gz"
- && takeExtension (dropExtension f) == ".tar"
+ extensionIsTarGz f =
+ takeExtension f == ".gz"
+ && takeExtension (dropExtension f) == ".tar"
reportUserTargetProblems :: Verbosity -> [UserTargetProblem] -> IO ()
reportUserTargetProblems verbosity problems = do
- case [ target | UserTargetUnrecognised target <- problems ] of
- [] -> return ()
- target -> die' verbosity
- $ unlines
- [ "Unrecognised target '" ++ name ++ "'."
- | name <- target ]
- ++ "Targets can be:\n"
- ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
- ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
- ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"
-
- case [ target | UserTargetNonexistantFile target <- problems ] of
- [] -> return ()
- target -> die' verbosity
- $ unlines
- [ "The file does not exist '" ++ name ++ "'."
- | name <- target ]
-
- case [ target | UserTargetUnexpectedFile target <- problems ] of
- [] -> return ()
- target -> die' verbosity
- $ unlines
- [ "Unrecognised file target '" ++ name ++ "'."
- | name <- target ]
- ++ "File targets can be either package tarballs 'pkgname.tar.gz' "
- ++ "or cabal files 'pkgname.cabal'."
-
- case [ target | UserTargetUnexpectedUriScheme target <- problems ] of
- [] -> return ()
- target -> die' verbosity
- $ unlines
- [ "URL target not supported '" ++ name ++ "'."
- | name <- target ]
- ++ "Only 'http://' and 'https://' URLs are supported."
-
- case [ target | UserTargetUnrecognisedUri target <- problems ] of
- [] -> return ()
- target -> die' verbosity
- $ unlines
- [ "Unrecognise URL target '" ++ name ++ "'."
- | name <- target ]
-
+ case [target | UserTargetUnrecognised target <- problems] of
+ [] -> return ()
+ target ->
+ die' verbosity $
+ unlines
+ [ "Unrecognised target '" ++ name ++ "'."
+ | name <- target
+ ]
+ ++ "Targets can be:\n"
+ ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"
+ ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"
+ ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"
+
+ case [target | UserTargetNonexistantFile target <- problems] of
+ [] -> return ()
+ target ->
+ die' verbosity $
+ unlines
+ [ "The file does not exist '" ++ name ++ "'."
+ | name <- target
+ ]
+
+ case [target | UserTargetUnexpectedFile target <- problems] of
+ [] -> return ()
+ target ->
+ die' verbosity $
+ unlines
+ [ "Unrecognised file target '" ++ name ++ "'."
+ | name <- target
+ ]
+ ++ "File targets can be either package tarballs 'pkgname.tar.gz' "
+ ++ "or cabal files 'pkgname.cabal'."
+
+ case [target | UserTargetUnexpectedUriScheme target <- problems] of
+ [] -> return ()
+ target ->
+ die' verbosity $
+ unlines
+ [ "URL target not supported '" ++ name ++ "'."
+ | name <- target
+ ]
+ ++ "Only 'http://' and 'https://' URLs are supported."
+
+ case [target | UserTargetUnrecognisedUri target <- problems] of
+ [] -> return ()
+ target ->
+ die' verbosity $
+ unlines
+ [ "Unrecognise URL target '" ++ name ++ "'."
+ | name <- target
+ ]
-- ------------------------------------------------------------
+
-- * Resolving user targets to package specifiers
+
-- ------------------------------------------------------------
-- | Given a bunch of user-specified targets, try to resolve what it is they
-- refer to. They can either be specific packages (local dirs, tarballs etc)
-- or they can be named packages (with or without version info).
---
-resolveUserTargets :: Package pkg
- => Verbosity
- -> RepoContext
- -> PackageIndex pkg
- -> [UserTarget]
- -> IO [PackageSpecifier UnresolvedSourcePackage]
+resolveUserTargets
+ :: Package pkg
+ => Verbosity
+ -> RepoContext
+ -> PackageIndex pkg
+ -> [UserTarget]
+ -> IO [PackageSpecifier UnresolvedSourcePackage]
resolveUserTargets verbosity repoCtxt available userTargets = do
+ -- given the user targets, get a list of fully or partially resolved
+ -- package references
+ packageTargets <-
+ traverse (readPackageTarget verbosity)
+ =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat
+ =<< traverse (expandUserTarget verbosity) userTargets
- -- given the user targets, get a list of fully or partially resolved
- -- package references
- packageTargets <- traverse (readPackageTarget verbosity)
- =<< traverse (fetchPackageTarget verbosity repoCtxt) . concat
- =<< traverse (expandUserTarget verbosity) userTargets
-
- -- users are allowed to give package names case-insensitively, so we must
- -- disambiguate named package references
- let (problems, packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) =
- disambiguatePackageTargets available availableExtra packageTargets
-
- -- use any extra specific available packages to help us disambiguate
- availableExtra :: [PackageName]
- availableExtra = [ packageName pkg
- | PackageTargetLocation pkg <- packageTargets ]
+ -- users are allowed to give package names case-insensitively, so we must
+ -- disambiguate named package references
+ let (problems, packageSpecifiers) :: ([PackageTargetProblem], [PackageSpecifier UnresolvedSourcePackage]) =
+ disambiguatePackageTargets available availableExtra packageTargets
- reportPackageTargetProblems verbosity problems
+ -- use any extra specific available packages to help us disambiguate
+ availableExtra :: [PackageName]
+ availableExtra =
+ [ packageName pkg
+ | PackageTargetLocation pkg <- packageTargets
+ ]
- return packageSpecifiers
+ reportPackageTargetProblems verbosity problems
+ return packageSpecifiers
-- ------------------------------------------------------------
+
-- * Package targets
+
-- ------------------------------------------------------------
-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.
-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.
---
-data PackageTarget pkg =
- PackageTargetNamed PackageName [PackageProperty] UserTarget
-
- -- | A package identified by name, but case insensitively, so it needs
- -- to be resolved to the right case-sensitive name.
- | PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget
- | PackageTargetLocation pkg
+data PackageTarget pkg
+ = PackageTargetNamed PackageName [PackageProperty] UserTarget
+ | -- | A package identified by name, but case insensitively, so it needs
+ -- to be resolved to the right case-sensitive name.
+ PackageTargetNamedFuzzy PackageName [PackageProperty] UserTarget
+ | PackageTargetLocation pkg
deriving (Show, Functor, Foldable, Traversable)
-
-- ------------------------------------------------------------
+
-- * Converting user targets to package targets
+
-- ------------------------------------------------------------
-- | Given a user-specified target, expand it to a bunch of package targets
-- (each of which refers to only one package).
---
-expandUserTarget :: Verbosity
- -> UserTarget
- -> IO [PackageTarget (PackageLocation ())]
+expandUserTarget
+ :: Verbosity
+ -> UserTarget
+ -> IO [PackageTarget (PackageLocation ())]
expandUserTarget verbosity userTarget = case userTarget of
-
- UserTargetNamed (PackageVersionConstraint name vrange) ->
- let props = [ PackagePropertyVersion vrange
- | not (isAnyVersion vrange) ]
- in return [PackageTargetNamedFuzzy name props userTarget]
-
- UserTargetLocalDir dir ->
- return [ PackageTargetLocation (LocalUnpackedPackage dir) ]
-
- UserTargetLocalCabalFile file -> do
- let dir = takeDirectory file
- _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check
- return [ PackageTargetLocation (LocalUnpackedPackage dir) ]
-
- UserTargetLocalTarball tarballFile ->
- return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]
-
- UserTargetRemoteTarball tarballURL ->
- return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]
+ UserTargetNamed (PackageVersionConstraint name vrange) ->
+ let props =
+ [ PackagePropertyVersion vrange
+ | not (isAnyVersion vrange)
+ ]
+ in return [PackageTargetNamedFuzzy name props userTarget]
+ UserTargetLocalDir dir ->
+ return [PackageTargetLocation (LocalUnpackedPackage dir)]
+ UserTargetLocalCabalFile file -> do
+ let dir = takeDirectory file
+ _ <- tryFindPackageDesc verbosity dir (localPackageError dir) -- just as a check
+ return [PackageTargetLocation (LocalUnpackedPackage dir)]
+ UserTargetLocalTarball tarballFile ->
+ return [PackageTargetLocation (LocalTarballPackage tarballFile)]
+ UserTargetRemoteTarball tarballURL ->
+ return [PackageTargetLocation (RemoteTarballPackage tarballURL ())]
localPackageError :: FilePath -> String
localPackageError dir =
- "Error reading local package.\nCouldn't find .cabal file in: " ++ dir
+ "Error reading local package.\nCouldn't find .cabal file in: " ++ dir
-- ------------------------------------------------------------
+
-- * Fetching and reading package targets
--- ------------------------------------------------------------
+-- ------------------------------------------------------------
-- | Fetch any remote targets so that they can be read.
---
-fetchPackageTarget :: Verbosity
- -> RepoContext
- -> PackageTarget (PackageLocation ())
- -> IO (PackageTarget ResolvedPkgLoc)
-fetchPackageTarget verbosity repoCtxt = traverse $
- fetchPackage verbosity repoCtxt . fmap (const Nothing)
-
+fetchPackageTarget
+ :: Verbosity
+ -> RepoContext
+ -> PackageTarget (PackageLocation ())
+ -> IO (PackageTarget ResolvedPkgLoc)
+fetchPackageTarget verbosity repoCtxt =
+ traverse $
+ fetchPackage verbosity repoCtxt . fmap (const Nothing)
-- | Given a package target that has been fetched, read the .cabal file.
--
-- This only affects targets given by location, named targets are unaffected.
---
-readPackageTarget :: Verbosity
- -> PackageTarget ResolvedPkgLoc
- -> IO (PackageTarget UnresolvedSourcePackage)
+readPackageTarget
+ :: Verbosity
+ -> PackageTarget ResolvedPkgLoc
+ -> IO (PackageTarget UnresolvedSourcePackage)
readPackageTarget verbosity = traverse modifyLocation
where
modifyLocation :: ResolvedPkgLoc -> IO UnresolvedSourcePackage
modifyLocation location = case location of
-
LocalUnpackedPackage dir -> do
- pkg <- tryFindPackageDesc verbosity dir (localPackageError dir) >>=
- readGenericPackageDescription verbosity
- return SourcePackage
- { srcpkgPackageId = packageId pkg
- , srcpkgDescription = pkg
- , srcpkgSource = fmap Just location
- , srcpkgDescrOverride = Nothing
- }
-
+ pkg <-
+ tryFindPackageDesc verbosity dir (localPackageError dir)
+ >>= readGenericPackageDescription verbosity
+ return
+ SourcePackage
+ { srcpkgPackageId = packageId pkg
+ , srcpkgDescription = pkg
+ , srcpkgSource = fmap Just location
+ , srcpkgDescrOverride = Nothing
+ }
LocalTarballPackage tarballFile ->
readTarballPackageTarget location tarballFile tarballFile
-
RemoteTarballPackage tarballURL tarballFile ->
readTarballPackageTarget location tarballFile (show tarballURL)
-
RepoTarballPackage _repo _pkgid _ ->
error "TODO: readPackageTarget RepoTarballPackage"
- -- For repo tarballs this info should be obtained from the index.
+ -- For repo tarballs this info should be obtained from the index.
RemoteSourceRepoPackage _srcRepo _ ->
error "TODO: readPackageTarget RemoteSourceRepoPackage"
- -- This can't happen, because it would have errored out already
- -- in fetchPackage, via fetchPackageTarget before it gets to this
- -- function.
- --
- -- When that is corrected, this will also need to be fixed.
+ -- This can't happen, because it would have errored out already
+ -- in fetchPackage, via fetchPackageTarget before it gets to this
+ -- function.
+ --
+ -- When that is corrected, this will also need to be fixed.
readTarballPackageTarget :: ResolvedPkgLoc -> FilePath -> FilePath -> IO UnresolvedSourcePackage
readTarballPackageTarget location tarballFile tarballOriginalLoc = do
- (filename, content) <- extractTarballPackageCabalFile
- tarballFile tarballOriginalLoc
+ (filename, content) <-
+ extractTarballPackageCabalFile
+ tarballFile
+ tarballOriginalLoc
case parsePackageDescription' content of
- Nothing -> die' verbosity $ "Could not parse the cabal file "
- ++ filename ++ " in " ++ tarballFile
+ Nothing ->
+ die' verbosity $
+ "Could not parse the cabal file "
+ ++ filename
+ ++ " in "
+ ++ tarballFile
Just pkg ->
- return SourcePackage
- { srcpkgPackageId = packageId pkg
- , srcpkgDescription = pkg
- , srcpkgSource = fmap Just location
- , srcpkgDescrOverride = Nothing
- }
-
- extractTarballPackageCabalFile :: FilePath -> String
- -> IO (FilePath, BS.ByteString)
+ return
+ SourcePackage
+ { srcpkgPackageId = packageId pkg
+ , srcpkgDescription = pkg
+ , srcpkgSource = fmap Just location
+ , srcpkgDescrOverride = Nothing
+ }
+
+ extractTarballPackageCabalFile
+ :: FilePath
+ -> String
+ -> IO (FilePath, BS.ByteString)
extractTarballPackageCabalFile tarballFile tarballOriginalLoc =
- either (die' verbosity . formatErr) return
+ either (die' verbosity . formatErr) return
. check
. accumEntryMap
. Tar.filterEntries isCabalFile
. Tar.read
. GZipUtils.maybeDecompress
- =<< BS.readFile tarballFile
+ =<< BS.readFile tarballFile
where
formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg
- accumEntryMap :: Tar.Entries Tar.FormatError
- -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry)
- accumEntryMap = Tar.foldlEntries
- (\m e -> Map.insert (Tar.entryTarPath e) e m)
- Map.empty
+ accumEntryMap
+ :: Tar.Entries Tar.FormatError
+ -> Either (Tar.FormatError, Map Tar.TarPath Tar.Entry) (Map Tar.TarPath Tar.Entry)
+ accumEntryMap =
+ Tar.foldlEntries
+ (\m e -> Map.insert (Tar.entryTarPath e) e m)
+ Map.empty
- check (Left e) = Left (show e)
+ check (Left e) = Left (show e)
check (Right m) = case Map.elems m of
- [] -> Left noCabalFile
- [file] -> case Tar.entryContent file of
- Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
- _ -> Left noCabalFile
- _files -> Left multipleCabalFiles
+ [] -> Left noCabalFile
+ [file] -> case Tar.entryContent file of
+ Tar.NormalFile content _ -> Right (Tar.entryPath file, content)
+ _ -> Left noCabalFile
+ _files -> Left multipleCabalFiles
where
- noCabalFile = "No cabal file found"
+ noCabalFile = "No cabal file found"
multipleCabalFiles = "Multiple cabal files found"
isCabalFile :: Tar.Entry -> Bool
isCabalFile e = case splitPath (Tar.entryPath e) of
- [ _dir, file] -> takeExtension file == ".cabal"
+ [_dir, file] -> takeExtension file == ".cabal"
[".", _dir, file] -> takeExtension file == ".cabal"
- _ -> False
+ _ -> False
parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription
parsePackageDescription' bs =
- parseGenericPackageDescriptionMaybe (BS.toStrict bs)
+ parseGenericPackageDescriptionMaybe (BS.toStrict bs)
-- ------------------------------------------------------------
+
-- * Checking package targets
+
-- ------------------------------------------------------------
data PackageTargetProblem
- = PackageNameUnknown PackageName UserTarget
- | PackageNameAmbiguous PackageName [PackageName] UserTarget
- deriving Show
-
+ = PackageNameUnknown PackageName UserTarget
+ | PackageNameAmbiguous PackageName [PackageName] UserTarget
+ deriving (Show)
-- | Users are allowed to give package names case-insensitively, so we must
-- disambiguate named package references.
---
-disambiguatePackageTargets :: Package pkg'
- => PackageIndex pkg'
- -> [PackageName]
- -> [PackageTarget pkg]
- -> ( [PackageTargetProblem]
- , [PackageSpecifier pkg] )
+disambiguatePackageTargets
+ :: Package pkg'
+ => PackageIndex pkg'
+ -> [PackageName]
+ -> [PackageTarget pkg]
+ -> ( [PackageTargetProblem]
+ , [PackageSpecifier pkg]
+ )
disambiguatePackageTargets availablePkgIndex availableExtra targets =
- partitionEithers (map disambiguatePackageTarget targets)
+ partitionEithers (map disambiguatePackageTarget targets)
where
disambiguatePackageTarget packageTarget = case packageTarget of
PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)
-
PackageTargetNamed pkgname props userTarget
- | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)
- -> Left (PackageNameUnknown pkgname userTarget)
+ | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) ->
+ Left (PackageNameUnknown pkgname userTarget)
| otherwise -> Right (NamedPackage pkgname props)
-
PackageTargetNamedFuzzy pkgname props userTarget ->
case disambiguatePackageName packageNameEnv pkgname of
- None -> Left (PackageNameUnknown
- pkgname userTarget)
- Ambiguous pkgnames -> Left (PackageNameAmbiguous
- pkgname pkgnames userTarget)
+ None ->
+ Left
+ ( PackageNameUnknown
+ pkgname
+ userTarget
+ )
+ Ambiguous pkgnames ->
+ Left
+ ( PackageNameAmbiguous
+ pkgname
+ pkgnames
+ userTarget
+ )
Unambiguous pkgname' -> Right (NamedPackage pkgname' props)
-- use any extra specific available packages to help us disambiguate
packageNameEnv :: PackageNameEnv
- packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)
- (extraPackageNameEnv availableExtra)
-
+ packageNameEnv =
+ mappend
+ (indexPackageNameEnv availablePkgIndex)
+ (extraPackageNameEnv availableExtra)
-- | Report problems to the user. That is, if there are any problems
-- then raise an exception.
-reportPackageTargetProblems :: Verbosity
- -> [PackageTargetProblem] -> IO ()
+reportPackageTargetProblems
+ :: Verbosity
+ -> [PackageTargetProblem]
+ -> IO ()
reportPackageTargetProblems verbosity problems = do
- case [ pkg | PackageNameUnknown pkg _ <- problems ] of
- [] -> return ()
- pkgs -> die' verbosity $ unlines
- [ "There is no package named '" ++ prettyShow name ++ "'. "
- | name <- pkgs ]
- ++ "You may need to run 'cabal update' to get the latest "
- ++ "list of available packages."
-
- case [ (pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems ] of
- [] -> return ()
- ambiguities -> die' verbosity $ unlines
- [ "There is no package named '" ++ prettyShow name ++ "'. "
- ++ (if length matches > 1
- then "However, the following package names exist: "
- else "However, the following package name exists: ")
- ++ intercalate ", " [ "'" ++ prettyShow m ++ "'" | m <- matches]
- ++ "."
- | (name, matches) <- ambiguities ]
-
+ case [pkg | PackageNameUnknown pkg _ <- problems] of
+ [] -> return ()
+ pkgs ->
+ die' verbosity $
+ unlines
+ [ "There is no package named '" ++ prettyShow name ++ "'. "
+ | name <- pkgs
+ ]
+ ++ "You may need to run 'cabal update' to get the latest "
+ ++ "list of available packages."
+
+ case [(pkg, matches) | PackageNameAmbiguous pkg matches _ <- problems] of
+ [] -> return ()
+ ambiguities ->
+ die' verbosity $
+ unlines
+ [ "There is no package named '"
+ ++ prettyShow name
+ ++ "'. "
+ ++ ( if length matches > 1
+ then "However, the following package names exist: "
+ else "However, the following package name exists: "
+ )
+ ++ intercalate ", " ["'" ++ prettyShow m ++ "'" | m <- matches]
+ ++ "."
+ | (name, matches) <- ambiguities
+ ]
-- ------------------------------------------------------------
+
-- * Disambiguating package names
+
-- ------------------------------------------------------------
data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]
@@ -559,17 +614,16 @@ data MaybeAmbiguous a = None | Unambiguous a | Ambiguous [a]
--
-- Note: Before cabal 2.2, when only a single package matched
-- case-insensitively it would be considered 'Unambiguous'.
---
-disambiguatePackageName :: PackageNameEnv
- -> PackageName
- -> MaybeAmbiguous PackageName
+disambiguatePackageName
+ :: PackageNameEnv
+ -> PackageName
+ -> MaybeAmbiguous PackageName
disambiguatePackageName (PackageNameEnv pkgNameLookup) name =
- case nub (pkgNameLookup name) of
- [] -> None
- names -> case find (name==) names of
- Just name' -> Unambiguous name'
- Nothing -> Ambiguous names
-
+ case nub (pkgNameLookup name) of
+ [] -> None
+ names -> case find (name ==) names of
+ Just name' -> Unambiguous name'
+ Nothing -> Ambiguous names
newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])
@@ -594,24 +648,24 @@ extraPackageNameEnv names = PackageNameEnv pkgNameLookup
[ pname'
| let lname = lowercase (unPackageName pname)
, pname' <- names
- , lowercase (unPackageName pname') == lname ]
-
+ , lowercase (unPackageName pname') == lname
+ ]
-- ------------------------------------------------------------
+
-- * Package constraints
+
-- ------------------------------------------------------------
-- | Version of 'Qualifier' that a user may specify on the
-- command line.
-data UserQualifier =
- -- | Top-level dependency.
- UserQualToplevel
-
- -- | Setup dependency.
- | UserQualSetup PackageName
-
- -- | Executable dependency.
- | UserQualExe PackageName PackageName
+data UserQualifier
+ = -- | Top-level dependency.
+ UserQualToplevel
+ | -- | Setup dependency.
+ UserQualSetup PackageName
+ | -- | Executable dependency.
+ UserQualExe PackageName PackageName
deriving (Eq, Show, Generic)
instance Binary UserQualifier
@@ -619,15 +673,13 @@ instance Structured UserQualifier
-- | Version of 'ConstraintScope' that a user may specify on the
-- command line.
-data UserConstraintScope =
- -- | Scope that applies to the package when it has the specified qualifier.
- UserQualified UserQualifier PackageName
-
- -- | Scope that applies to the package when it has a setup qualifier.
- | UserAnySetupQualifier PackageName
-
- -- | Scope that applies to the package when it has any qualifier.
- | UserAnyQualifier PackageName
+data UserConstraintScope
+ = -- | Scope that applies to the package when it has the specified qualifier.
+ UserQualified UserQualifier PackageName
+ | -- | Scope that applies to the package when it has a setup qualifier.
+ UserAnySetupQualifier PackageName
+ | -- | Scope that applies to the package when it has any qualifier.
+ UserAnyQualifier PackageName
deriving (Eq, Show, Generic)
instance Binary UserConstraintScope
@@ -640,14 +692,14 @@ fromUserQualifier (UserQualExe name1 name2) = QualExe name1 name2
fromUserConstraintScope :: UserConstraintScope -> ConstraintScope
fromUserConstraintScope (UserQualified q pn) =
- ScopeQualified (fromUserQualifier q) pn
+ ScopeQualified (fromUserQualifier q) pn
fromUserConstraintScope (UserAnySetupQualifier pn) = ScopeAnySetupQualifier pn
fromUserConstraintScope (UserAnyQualifier pn) = ScopeAnyQualifier pn
-- | Version of 'PackageConstraint' that the user can specify on
-- the command line.
-data UserConstraint =
- UserConstraint UserConstraintScope PackageProperty
+data UserConstraint
+ = UserConstraint UserConstraintScope PackageProperty
deriving (Eq, Show, Generic)
instance Binary UserConstraint
@@ -666,50 +718,51 @@ userToPackageConstraint (UserConstraint scope prop) =
readUserConstraint :: String -> Either String UserConstraint
readUserConstraint str =
- case explicitEitherParsec parsec str of
- Left err -> Left $ msgCannotParse ++ err
- Right c -> Right c
+ case explicitEitherParsec parsec str of
+ Left err -> Left $ msgCannotParse ++ err
+ Right c -> Right c
where
msgCannotParse =
- "expected a (possibly qualified) package name followed by a " ++
- "constraint, which is either a version range, 'installed', " ++
- "'source', 'test', 'bench', or flags. "
+ "expected a (possibly qualified) package name followed by a "
+ ++ "constraint, which is either a version range, 'installed', "
+ ++ "'source', 'test', 'bench', or flags. "
instance Pretty UserConstraint where
pretty (UserConstraint scope prop) =
dispPackageConstraint $ PackageConstraint (fromUserConstraintScope scope) prop
instance Parsec UserConstraint where
- parsec = do
- scope <- parseConstraintScope
- P.spaces
- prop <- P.choice
- [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-"
- , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be)
- , PackagePropertyInstalled <$ P.string "installed"
- , PackagePropertySource <$ P.string "source"
- , PackagePropertyStanzas [TestStanzas] <$ P.string "test"
- , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"
- ]
- return (UserConstraint scope prop)
-
- where
- parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
- parseConstraintScope = do
- pn <- parsec
- P.choice
- [ P.char '.' *> withDot pn
- , P.char ':' *> withColon pn
- , return (UserQualified UserQualToplevel pn)
- ]
- where
- withDot :: PackageName -> m UserConstraintScope
- withDot pn
- | pn == mkPackageName "any" = UserAnyQualifier <$> parsec
- | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
- | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
-
- withColon :: PackageName -> m UserConstraintScope
- withColon pn = UserQualified (UserQualSetup pn)
- <$ P.string "setup."
- <*> parsec
+ parsec = do
+ scope <- parseConstraintScope
+ P.spaces
+ prop <-
+ P.choice
+ [ PackagePropertyFlags <$> parsecFlagAssignmentNonEmpty -- headed by "+-"
+ , PackagePropertyVersion <$> parsec -- headed by "<=>" (will be)
+ , PackagePropertyInstalled <$ P.string "installed"
+ , PackagePropertySource <$ P.string "source"
+ , PackagePropertyStanzas [TestStanzas] <$ P.string "test"
+ , PackagePropertyStanzas [BenchStanzas] <$ P.string "bench"
+ ]
+ return (UserConstraint scope prop)
+ where
+ parseConstraintScope :: forall m. CabalParsing m => m UserConstraintScope
+ parseConstraintScope = do
+ pn <- parsec
+ P.choice
+ [ P.char '.' *> withDot pn
+ , P.char ':' *> withColon pn
+ , return (UserQualified UserQualToplevel pn)
+ ]
+ where
+ withDot :: PackageName -> m UserConstraintScope
+ withDot pn
+ | pn == mkPackageName "any" = UserAnyQualifier <$> parsec
+ | pn == mkPackageName "setup" = UserAnySetupQualifier <$> parsec
+ | otherwise = P.unexpected $ "constraint scope: " ++ unPackageName pn
+
+ withColon :: PackageName -> m UserConstraintScope
+ withColon pn =
+ UserQualified (UserQualSetup pn)
+ <$ P.string "setup."
+ <*> parsec
diff --git a/cabal-install/src/Distribution/Client/Types.hs b/cabal-install/src/Distribution/Client/Types.hs
index fe5710d9477e919e51e6e0050c9705b51553c4d0..710960ee9397465cdb0c05171ddf36d2ffb56b86 100644
--- a/cabal-install/src/Distribution/Client/Types.hs
+++ b/cabal-install/src/Distribution/Client/Types.hs
@@ -1,10 +1,14 @@
-{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Types
-- Copyright : (c) David Himmelstrup 2005
@@ -16,21 +20,19 @@
-- Portability : portable
--
-- Various common data types for the entire cabal-install system
------------------------------------------------------------------------------
-module Distribution.Client.Types (
- module Distribution.Client.Types.AllowNewer,
- module Distribution.Client.Types.ConfiguredId,
- module Distribution.Client.Types.ConfiguredPackage,
- module Distribution.Client.Types.BuildResults,
- module Distribution.Client.Types.PackageLocation,
- module Distribution.Client.Types.PackageSpecifier,
- module Distribution.Client.Types.ReadyPackage,
- module Distribution.Client.Types.Repo,
- module Distribution.Client.Types.RepoName,
- module Distribution.Client.Types.SourcePackageDb,
- module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy,
-) where
-
+module Distribution.Client.Types
+ ( module Distribution.Client.Types.AllowNewer
+ , module Distribution.Client.Types.ConfiguredId
+ , module Distribution.Client.Types.ConfiguredPackage
+ , module Distribution.Client.Types.BuildResults
+ , module Distribution.Client.Types.PackageLocation
+ , module Distribution.Client.Types.PackageSpecifier
+ , module Distribution.Client.Types.ReadyPackage
+ , module Distribution.Client.Types.Repo
+ , module Distribution.Client.Types.RepoName
+ , module Distribution.Client.Types.SourcePackageDb
+ , module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
+ ) where
import Distribution.Client.Types.AllowNewer
import Distribution.Client.Types.BuildResults
@@ -38,8 +40,8 @@ import Distribution.Client.Types.ConfiguredId
import Distribution.Client.Types.ConfiguredPackage
import Distribution.Client.Types.PackageLocation
import Distribution.Client.Types.PackageSpecifier
+import Distribution.Client.Types.ReadyPackage
import Distribution.Client.Types.Repo
import Distribution.Client.Types.RepoName
-import Distribution.Client.Types.ReadyPackage
import Distribution.Client.Types.SourcePackageDb
import Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
diff --git a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs
index 809f9f690be23520ddc591c4ef7996ae30f88aff..0a5700174b8fb934c4a8ba65f52bd362f3fcab70 100644
--- a/cabal-install/src/Distribution/Client/Types/AllowNewer.hs
+++ b/cabal-install/src/Distribution/Client/Types/AllowNewer.hs
@@ -1,26 +1,27 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.AllowNewer (
- AllowNewer (..),
- AllowOlder (..),
- RelaxDeps (..),
- mkRelaxDepSome,
- RelaxDepMod (..),
- RelaxDepScope (..),
- RelaxDepSubject (..),
- RelaxedDep (..),
- isRelaxDeps,
-) where
+
+module Distribution.Client.Types.AllowNewer
+ ( AllowNewer (..)
+ , AllowOlder (..)
+ , RelaxDeps (..)
+ , mkRelaxDepSome
+ , RelaxDepMod (..)
+ , RelaxDepScope (..)
+ , RelaxDepSubject (..)
+ , RelaxedDep (..)
+ , isRelaxDeps
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Parsec (parsecLeadingCommaNonEmpty)
-import Distribution.Types.PackageId (PackageId, PackageIdentifier (..))
+import Distribution.Parsec (parsecLeadingCommaNonEmpty)
+import Distribution.Types.PackageId (PackageId, PackageIdentifier (..))
import Distribution.Types.PackageName (PackageName, mkPackageName)
-import Distribution.Types.Version (nullVersion)
+import Distribution.Types.Version (nullVersion)
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- $setup
-- >>> import Distribution.Parsec
@@ -30,116 +31,120 @@ import qualified Text.PrettyPrint as Disp
-- module
-- | 'RelaxDeps' in the context of upper bounds (i.e. for @--allow-newer@ flag)
-newtype AllowNewer = AllowNewer { unAllowNewer :: RelaxDeps }
- deriving (Eq, Read, Show, Generic)
+newtype AllowNewer = AllowNewer {unAllowNewer :: RelaxDeps}
+ deriving (Eq, Read, Show, Generic)
-- | 'RelaxDeps' in the context of lower bounds (i.e. for @--allow-older@ flag)
-newtype AllowOlder = AllowOlder { unAllowOlder :: RelaxDeps }
- deriving (Eq, Read, Show, Generic)
+newtype AllowOlder = AllowOlder {unAllowOlder :: RelaxDeps}
+ deriving (Eq, Read, Show, Generic)
-- | Generic data type for policy when relaxing bounds in dependencies.
-- Don't use this directly: use 'AllowOlder' or 'AllowNewer' depending
-- on whether or not you are relaxing an lower or upper bound
-- (respectively).
-data RelaxDeps =
-
- -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.
- --
- -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all
- -- dependencies, never choose versions newer (resp. older) than allowed.
+data RelaxDeps
+ = -- | Ignore upper (resp. lower) bounds in some (or no) dependencies on the given packages.
+ --
+ -- @RelaxDepsSome []@ is the default, i.e. honor the bounds in all
+ -- dependencies, never choose versions newer (resp. older) than allowed.
RelaxDepsSome [RelaxedDep]
-
- -- | Ignore upper (resp. lower) bounds in dependencies on all packages.
- --
- -- __Note__: This is should be semantically equivalent to
- --
- -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
- --
- -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')
- | RelaxDepsAll
+ | -- | Ignore upper (resp. lower) bounds in dependencies on all packages.
+ --
+ -- __Note__: This is should be semantically equivalent to
+ --
+ -- > RelaxDepsSome [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
+ --
+ -- (TODO: consider normalising 'RelaxDeps' and/or 'RelaxedDep')
+ RelaxDepsAll
deriving (Eq, Read, Show, Generic)
-- | Dependencies can be relaxed either for all packages in the install plan, or
-- only for some packages.
data RelaxedDep = RelaxedDep !RelaxDepScope !RelaxDepMod !RelaxDepSubject
- deriving (Eq, Read, Show, Generic)
+ deriving (Eq, Read, Show, Generic)
-- | Specify the scope of a relaxation, i.e. limit which depending
-- packages are allowed to have their version constraints relaxed.
-data RelaxDepScope = RelaxDepScopeAll
- -- ^ Apply relaxation in any package
- | RelaxDepScopePackage !PackageName
- -- ^ Apply relaxation to in all versions of a package
- | RelaxDepScopePackageId !PackageId
- -- ^ Apply relaxation to a specific version of a package only
- deriving (Eq, Read, Show, Generic)
+data RelaxDepScope
+ = -- | Apply relaxation in any package
+ RelaxDepScopeAll
+ | -- | Apply relaxation to in all versions of a package
+ RelaxDepScopePackage !PackageName
+ | -- | Apply relaxation to a specific version of a package only
+ RelaxDepScopePackageId !PackageId
+ deriving (Eq, Read, Show, Generic)
-- | Modifier for dependency relaxation
-data RelaxDepMod = RelaxDepModNone -- ^ Default semantics
- | RelaxDepModCaret -- ^ Apply relaxation only to @^>=@ constraints
- deriving (Eq, Read, Show, Generic)
+data RelaxDepMod
+ = -- | Default semantics
+ RelaxDepModNone
+ | -- | Apply relaxation only to @^>=@ constraints
+ RelaxDepModCaret
+ deriving (Eq, Read, Show, Generic)
-- | Express whether to relax bounds /on/ @all@ packages, or a single package
-data RelaxDepSubject = RelaxDepSubjectAll
- | RelaxDepSubjectPkg !PackageName
- deriving (Eq, Ord, Read, Show, Generic)
+data RelaxDepSubject
+ = RelaxDepSubjectAll
+ | RelaxDepSubjectPkg !PackageName
+ deriving (Eq, Ord, Read, Show, Generic)
instance Pretty RelaxedDep where
pretty (RelaxedDep scope rdmod subj) = case scope of
- RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep
- RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
- RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
+ RelaxDepScopeAll -> Disp.text "*:" Disp.<> modDep
+ RelaxDepScopePackage p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
+ RelaxDepScopePackageId p0 -> pretty p0 Disp.<> Disp.colon Disp.<> modDep
where
modDep = case rdmod of
- RelaxDepModNone -> pretty subj
- RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj
+ RelaxDepModNone -> pretty subj
+ RelaxDepModCaret -> Disp.char '^' Disp.<> pretty subj
instance Parsec RelaxedDep where
- parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
+ parsec = P.char '*' *> relaxedDepStarP <|> (parsec >>= relaxedDepPkgidP)
-- continuation after *
relaxedDepStarP :: CabalParsing m => m RelaxedDep
relaxedDepStarP =
- RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
+ RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
<|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
-- continuation after package identifier
relaxedDepPkgidP :: CabalParsing m => PackageIdentifier -> m RelaxedDep
relaxedDepPkgidP pid@(PackageIdentifier pn v)
- | pn == mkPackageName "all"
- , v == nullVersion
- = RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
- <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
-
- | v == nullVersion
- = RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec
- <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))
-
- | otherwise
- = RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec
+ | pn == mkPackageName "all"
+ , v == nullVersion =
+ RelaxedDep RelaxDepScopeAll <$ P.char ':' <*> modP <*> parsec
+ <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll)
+ | v == nullVersion =
+ RelaxedDep (RelaxDepScopePackage pn) <$ P.char ':' <*> modP <*> parsec
+ <|> pure (RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn))
+ | otherwise =
+ RelaxedDep (RelaxDepScopePackageId pid) <$ P.char ':' <*> modP <*> parsec
modP :: P.CharParsing m => m RelaxDepMod
modP = RelaxDepModCaret <$ P.char '^' <|> pure RelaxDepModNone
instance Pretty RelaxDepSubject where
- pretty RelaxDepSubjectAll = Disp.text "*"
+ pretty RelaxDepSubjectAll = Disp.text "*"
pretty (RelaxDepSubjectPkg pn) = pretty pn
instance Parsec RelaxDepSubject where
parsec = RelaxDepSubjectAll <$ P.char '*' <|> pkgn
where
pkgn = do
- pn <- parsec
- pure $ if pn == mkPackageName "all"
- then RelaxDepSubjectAll
- else RelaxDepSubjectPkg pn
+ pn <- parsec
+ pure $
+ if pn == mkPackageName "all"
+ then RelaxDepSubjectAll
+ else RelaxDepSubjectPkg pn
instance Pretty RelaxDeps where
pretty rd | not (isRelaxDeps rd) = Disp.text "none"
- pretty (RelaxDepsSome pkgs) = Disp.fsep .
- Disp.punctuate Disp.comma .
- map pretty $ pkgs
- pretty RelaxDepsAll = Disp.text "all"
+ pretty (RelaxDepsSome pkgs) =
+ Disp.fsep
+ . Disp.punctuate Disp.comma
+ . map pretty
+ $ pkgs
+ pretty RelaxDepsAll = Disp.text "all"
-- |
--
@@ -165,17 +170,16 @@ instance Pretty RelaxDeps where
--
-- >>> simpleParsec "" :: Maybe RelaxDeps
-- Nothing
---
instance Parsec RelaxDeps where
- parsec = do
- xs <- parsecLeadingCommaNonEmpty parsec
- pure $ case toList xs of
- [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll]
- -> RelaxDepsAll
- [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
- | pn == mkPackageName "none"
- -> mempty
- xs' -> mkRelaxDepSome xs'
+ parsec = do
+ xs <- parsecLeadingCommaNonEmpty parsec
+ pure $ case toList xs of
+ [RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll] ->
+ RelaxDepsAll
+ [RelaxedDep RelaxDepScopeAll RelaxDepModNone (RelaxDepSubjectPkg pn)]
+ | pn == mkPackageName "none" ->
+ mempty
+ xs' -> mkRelaxDepSome xs'
instance Binary RelaxDeps
instance Binary RelaxDepMod
@@ -197,33 +201,32 @@ instance Structured AllowOlder
--
-- Equivalent to @isRelaxDeps = (/= 'mempty')@
isRelaxDeps :: RelaxDeps -> Bool
-isRelaxDeps (RelaxDepsSome []) = False
-isRelaxDeps (RelaxDepsSome (_:_)) = True
-isRelaxDeps RelaxDepsAll = True
+isRelaxDeps (RelaxDepsSome []) = False
+isRelaxDeps (RelaxDepsSome (_ : _)) = True
+isRelaxDeps RelaxDepsAll = True
-- | A smarter 'RelaxedDepsSome', @*:*@ is the same as @all@.
mkRelaxDepSome :: [RelaxedDep] -> RelaxDeps
mkRelaxDepSome xs
- | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs
- = RelaxDepsAll
-
- | otherwise
- = RelaxDepsSome xs
+ | any (== RelaxedDep RelaxDepScopeAll RelaxDepModNone RelaxDepSubjectAll) xs =
+ RelaxDepsAll
+ | otherwise =
+ RelaxDepsSome xs
-- | 'RelaxDepsAll' is the /absorbing element/
instance Semigroup RelaxDeps where
- -- identity element
- RelaxDepsSome [] <> r = r
- l@(RelaxDepsSome _) <> RelaxDepsSome [] = l
- -- absorbing element
- l@RelaxDepsAll <> _ = l
- (RelaxDepsSome _) <> r@RelaxDepsAll = r
- -- combining non-{identity,absorbing} elements
- (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b)
+ -- identity element
+ RelaxDepsSome [] <> r = r
+ l@(RelaxDepsSome _) <> RelaxDepsSome [] = l
+ -- absorbing element
+ l@RelaxDepsAll <> _ = l
+ (RelaxDepsSome _) <> r@RelaxDepsAll = r
+ -- combining non-{identity,absorbing} elements
+ (RelaxDepsSome a) <> (RelaxDepsSome b) = RelaxDepsSome (a ++ b)
-- | @'RelaxDepsSome' []@ is the /identity element/
instance Monoid RelaxDeps where
- mempty = RelaxDepsSome []
+ mempty = RelaxDepsSome []
mappend = (<>)
instance Semigroup AllowNewer where
@@ -233,9 +236,9 @@ instance Semigroup AllowOlder where
AllowOlder x <> AllowOlder y = AllowOlder (x <> y)
instance Monoid AllowNewer where
- mempty = AllowNewer mempty
+ mempty = AllowNewer mempty
mappend = (<>)
instance Monoid AllowOlder where
- mempty = AllowOlder mempty
+ mempty = AllowOlder mempty
mappend = (<>)
diff --git a/cabal-install/src/Distribution/Client/Types/BuildResults.hs b/cabal-install/src/Distribution/Client/Types/BuildResults.hs
index 55cf42de9c6bfec6524921c8e6849107e5089edf..55c015346201786afbf3b67f4f6890de86fecf83 100644
--- a/cabal-install/src/Distribution/Client/Types/BuildResults.hs
+++ b/cabal-install/src/Distribution/Client/Types/BuildResults.hs
@@ -1,37 +1,37 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.BuildResults (
- BuildOutcome,
- BuildOutcomes,
- BuildFailure (..),
- BuildResult (..),
- TestsResult (..),
- DocsResult (..),
-) where
+
+module Distribution.Client.Types.BuildResults
+ ( BuildOutcome
+ , BuildOutcomes
+ , BuildFailure (..)
+ , BuildResult (..)
+ , TestsResult (..)
+ , DocsResult (..)
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Types.InstalledPackageInfo (InstalledPackageInfo)
-import Distribution.Types.PackageId (PackageId)
-import Distribution.Types.UnitId (UnitId)
+import Distribution.Types.PackageId (PackageId)
+import Distribution.Types.UnitId (UnitId)
-- | A summary of the outcome for building a single package.
---
type BuildOutcome = Either BuildFailure BuildResult
-- | A summary of the outcome for building a whole set of packages.
---
type BuildOutcomes = Map UnitId BuildOutcome
-data BuildFailure = PlanningFailed
- | DependentFailed PackageId
- | GracefulFailure String
- | DownloadFailed SomeException
- | UnpackFailed SomeException
- | ConfigureFailed SomeException
- | BuildFailed SomeException
- | TestsFailed SomeException
- | InstallFailed SomeException
+data BuildFailure
+ = PlanningFailed
+ | DependentFailed PackageId
+ | GracefulFailure String
+ | DownloadFailed SomeException
+ | UnpackFailed SomeException
+ | ConfigureFailed SomeException
+ | BuildFailed SomeException
+ | TestsFailed SomeException
+ | InstallFailed SomeException
deriving (Show, Typeable, Generic)
instance Exception BuildFailure
@@ -40,11 +40,14 @@ instance Exception BuildFailure
-- the public library's 'InstalledPackageInfo' is stored here, even if
-- there were 'InstalledPackageInfo' from internal libraries. This
-- 'InstalledPackageInfo' is not used anyway, so it makes no difference.
-data BuildResult = BuildResult DocsResult TestsResult
- (Maybe InstalledPackageInfo)
+data BuildResult
+ = BuildResult
+ DocsResult
+ TestsResult
+ (Maybe InstalledPackageInfo)
deriving (Show, Generic)
-data DocsResult = DocsNotTried | DocsFailed | DocsOk
+data DocsResult = DocsNotTried | DocsFailed | DocsOk
deriving (Show, Generic, Typeable)
data TestsResult = TestsNotTried | TestsOk
deriving (Show, Generic, Typeable)
diff --git a/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs b/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs
index 6b54533367731109e672f6534d87833817fdbd87..04f80ff97cf022efe1228f2d6b790e1efd40ad05 100644
--- a/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs
+++ b/cabal-install/src/Distribution/Client/Types/ConfiguredId.hs
@@ -1,20 +1,21 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.ConfiguredId (
- InstalledPackageId,
- ConfiguredId (..),
- annotatedIdToConfiguredId,
- HasConfiguredId (..),
-) where
+
+module Distribution.Client.Types.ConfiguredId
+ ( InstalledPackageId
+ , ConfiguredId (..)
+ , annotatedIdToConfiguredId
+ , HasConfiguredId (..)
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.InstalledPackageInfo (InstalledPackageInfo, sourceComponentName, installedComponentId)
-import Distribution.Package (Package (..))
-import Distribution.Types.AnnotatedId (AnnotatedId (..))
-import Distribution.Types.ComponentId (ComponentId)
-import Distribution.Types.ComponentName (ComponentName)
-import Distribution.Types.PackageId (PackageId)
+import Distribution.InstalledPackageInfo (InstalledPackageInfo, installedComponentId, sourceComponentName)
+import Distribution.Package (Package (..))
+import Distribution.Types.AnnotatedId (AnnotatedId (..))
+import Distribution.Types.ComponentId (ComponentId)
+import Distribution.Types.ComponentName (ComponentName)
+import Distribution.Types.PackageId (PackageId)
-------------------------------------------------------------------------------
-- InstalledPackageId
@@ -30,7 +31,6 @@ import Distribution.Types.PackageId (PackageId)
-- their primary library, which is a unit id. In future this may change
-- slightly and we may distinguish these two types and have an explicit
-- conversion when we register units with the compiler.
---
type InstalledPackageId = ComponentId
-------------------------------------------------------------------------------
@@ -45,18 +45,19 @@ type InstalledPackageId = ComponentId
--
-- An already installed package of course is also "configured" (all its
-- configuration parameters and dependencies have been specified).
-data ConfiguredId = ConfiguredId {
- confSrcId :: PackageId
+data ConfiguredId = ConfiguredId
+ { confSrcId :: PackageId
, confCompName :: Maybe ComponentName
, confInstId :: ComponentId
}
deriving (Eq, Ord, Generic)
annotatedIdToConfiguredId :: AnnotatedId ComponentId -> ConfiguredId
-annotatedIdToConfiguredId aid = ConfiguredId {
- confSrcId = ann_pid aid,
- confCompName = Just (ann_cname aid),
- confInstId = ann_id aid
+annotatedIdToConfiguredId aid =
+ ConfiguredId
+ { confSrcId = ann_pid aid
+ , confCompName = Just (ann_cname aid)
+ , confInstId = ann_id aid
}
instance Binary ConfiguredId
@@ -73,11 +74,13 @@ instance Package ConfiguredId where
-------------------------------------------------------------------------------
class HasConfiguredId a where
- configuredId :: a -> ConfiguredId
+ configuredId :: a -> ConfiguredId
-- NB: This instance is slightly dangerous, in that you'll lose
-- information about the specific UnitId you depended on.
instance HasConfiguredId InstalledPackageInfo where
- configuredId ipkg = ConfiguredId (packageId ipkg)
- (Just (sourceComponentName ipkg))
- (installedComponentId ipkg)
+ configuredId ipkg =
+ ConfiguredId
+ (packageId ipkg)
+ (Just (sourceComponentName ipkg))
+ (installedComponentId ipkg)
diff --git a/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs b/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs
index 62b8f3360b88169c2ac6a86d369f85c8cb4e481b..0b7d62e7e7709399cc658a99486293c60b6dae21 100644
--- a/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs
+++ b/cabal-install/src/Distribution/Client/Types/ConfiguredPackage.hs
@@ -1,24 +1,25 @@
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeFamilies #-}
-module Distribution.Client.Types.ConfiguredPackage (
- ConfiguredPackage (..),
-) where
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Client.Types.ConfiguredPackage
+ ( ConfiguredPackage (..)
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Compat.Graph (IsNode (..))
-import Distribution.Package (newSimpleUnitId, HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId)
-import Distribution.Types.Flag (FlagAssignment)
+import Distribution.Package (HasMungedPackageId (..), HasUnitId (..), Package (..), PackageInstalled (..), UnitId, newSimpleUnitId)
+import Distribution.Simple.Utils (ordNub)
import Distribution.Types.ComponentName
+import Distribution.Types.Flag (FlagAssignment)
import Distribution.Types.LibraryName (LibraryName (..))
import Distribution.Types.MungedPackageId (computeCompatPackageId)
-import Distribution.Simple.Utils (ordNub)
import Distribution.Client.Types.ConfiguredId
-import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet)
+import Distribution.Solver.Types.OptionalStanza (OptionalStanzaSet)
import Distribution.Solver.Types.PackageFixedDeps
-import Distribution.Solver.Types.SourcePackage (SourcePackage)
+import Distribution.Solver.Types.SourcePackage (SourcePackage)
import qualified Distribution.Solver.Types.ComponentDeps as CD
@@ -29,45 +30,44 @@ import qualified Distribution.Solver.Types.ComponentDeps as CD
--
-- 'ConfiguredPackage' is assumed to not support Backpack. Only the
-- @v2-build@ codepath supports Backpack.
---
data ConfiguredPackage loc = ConfiguredPackage
- { confPkgId :: InstalledPackageId
- , confPkgSource :: SourcePackage loc -- ^ package info, including repo
- , confPkgFlags :: FlagAssignment -- ^ complete flag assignment for the package
- , confPkgStanzas :: OptionalStanzaSet -- ^ list of enabled optional stanzas for the package
- , confPkgDeps :: CD.ComponentDeps [ConfiguredId]
- -- ^ set of exact dependencies (installed or source).
- --
- -- These must be consistent with the 'buildDepends'
- -- in the 'PackageDescription' that you'd get by
- -- applying the flag assignment and optional stanzas.
- }
+ { confPkgId :: InstalledPackageId
+ , confPkgSource :: SourcePackage loc
+ -- ^ package info, including repo
+ , confPkgFlags :: FlagAssignment
+ -- ^ complete flag assignment for the package
+ , confPkgStanzas :: OptionalStanzaSet
+ -- ^ list of enabled optional stanzas for the package
+ , confPkgDeps :: CD.ComponentDeps [ConfiguredId]
+ -- ^ set of exact dependencies (installed or source).
+ --
+ -- These must be consistent with the 'buildDepends'
+ -- in the 'PackageDescription' that you'd get by
+ -- applying the flag assignment and optional stanzas.
+ }
deriving (Eq, Show, Generic)
-- | 'HasConfiguredId' indicates data types which have a 'ConfiguredId'.
-- This type class is mostly used to conveniently finesse between
-- 'ElaboratedPackage' and 'ElaboratedComponent'.
---
instance HasConfiguredId (ConfiguredPackage loc) where
- configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg)
+ configuredId pkg = ConfiguredId (packageId pkg) (Just (CLibName LMainLibName)) (confPkgId pkg)
-- 'ConfiguredPackage' is the legacy codepath, we are guaranteed
-- to never have a nontrivial 'UnitId'
instance PackageFixedDeps (ConfiguredPackage loc) where
- depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps
+ depends = fmap (map (newSimpleUnitId . confInstId)) . confPkgDeps
instance IsNode (ConfiguredPackage loc) where
- type Key (ConfiguredPackage loc) = UnitId
- nodeKey = newSimpleUnitId . confPkgId
- -- TODO: if we update ConfiguredPackage to support order-only
- -- dependencies, need to include those here.
- -- NB: have to deduplicate, otherwise the planner gets confused
- nodeNeighbors = ordNub . CD.flatDeps . depends
-
-instance (Binary loc) => Binary (ConfiguredPackage loc)
-
+ type Key (ConfiguredPackage loc) = UnitId
+ nodeKey = newSimpleUnitId . confPkgId
+ -- TODO: if we update ConfiguredPackage to support order-only
+ -- dependencies, need to include those here.
+ -- NB: have to deduplicate, otherwise the planner gets confused
+ nodeNeighbors = ordNub . CD.flatDeps . depends
+instance Binary loc => Binary (ConfiguredPackage loc)
instance Package (ConfiguredPackage loc) where
packageId cpkg = packageId (confPkgSource cpkg)
@@ -81,4 +81,3 @@ instance HasUnitId (ConfiguredPackage loc) where
instance PackageInstalled (ConfiguredPackage loc) where
installedDepends = CD.flatDeps . depends
-
diff --git a/cabal-install/src/Distribution/Client/Types/Credentials.hs b/cabal-install/src/Distribution/Client/Types/Credentials.hs
index 1b555718b85c65fde1e43e06b3941910938fc74f..da208111c1f7a43e3ebb5c18aef4b7a8d627a7dc 100644
--- a/cabal-install/src/Distribution/Client/Types/Credentials.hs
+++ b/cabal-install/src/Distribution/Client/Types/Credentials.hs
@@ -1,9 +1,9 @@
-module Distribution.Client.Types.Credentials (
- Username (..),
- Password (..),
-) where
+module Distribution.Client.Types.Credentials
+ ( Username (..)
+ , Password (..)
+ ) where
import Prelude (String)
-newtype Username = Username { unUsername :: String }
-newtype Password = Password { unPassword :: String }
+newtype Username = Username {unUsername :: String}
+newtype Password = Password {unPassword :: String}
diff --git a/cabal-install/src/Distribution/Client/Types/InstallMethod.hs b/cabal-install/src/Distribution/Client/Types/InstallMethod.hs
index c850b66f411c3437b575cc4661362765d5e2817f..b7b24aecf085142a3b07fbe62625831c055f1c8d 100644
--- a/cabal-install/src/Distribution/Client/Types/InstallMethod.hs
+++ b/cabal-install/src/Distribution/Client/Types/InstallMethod.hs
@@ -1,15 +1,16 @@
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Client.Types.InstallMethod where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
data InstallMethod
- = InstallMethodCopy
- | InstallMethodSymlink
+ = InstallMethodCopy
+ | InstallMethodSymlink
deriving (Eq, Show, Generic, Bounded, Enum)
instance Binary InstallMethod
@@ -17,16 +18,16 @@ instance Structured InstallMethod
-- | Last
instance Semigroup InstallMethod where
- _ <> x = x
+ _ <> x = x
instance Parsec InstallMethod where
- parsec = do
- name <- P.munch1 isAlpha
- case name of
- "copy" -> pure InstallMethodCopy
- "symlink" -> pure InstallMethodSymlink
- _ -> P.unexpected $ "InstallMethod: " ++ name
+ parsec = do
+ name <- P.munch1 isAlpha
+ case name of
+ "copy" -> pure InstallMethodCopy
+ "symlink" -> pure InstallMethodSymlink
+ _ -> P.unexpected $ "InstallMethod: " ++ name
instance Pretty InstallMethod where
- pretty InstallMethodCopy = PP.text "copy"
- pretty InstallMethodSymlink = PP.text "symlink"
+ pretty InstallMethodCopy = PP.text "copy"
+ pretty InstallMethodSymlink = PP.text "symlink"
diff --git a/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs b/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs
index d6f8c8b5547d5247864ec99d6795f33facb7a64f..e992224243aea60ab872baaeba122bd208ded526 100644
--- a/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs
+++ b/cabal-install/src/Distribution/Client/Types/OverwritePolicy.hs
@@ -1,31 +1,32 @@
{-# LANGUAGE DeriveGeneric #-}
+
module Distribution.Client.Types.OverwritePolicy where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as PP
+import qualified Text.PrettyPrint as PP
data OverwritePolicy
- = NeverOverwrite
- | AlwaysOverwrite
- | PromptOverwrite
+ = NeverOverwrite
+ | AlwaysOverwrite
+ | PromptOverwrite
deriving (Show, Eq, Generic, Bounded, Enum)
instance Binary OverwritePolicy
instance Structured OverwritePolicy
instance Parsec OverwritePolicy where
- parsec = do
- name <- P.munch1 isAlpha
- case name of
- "always" -> pure AlwaysOverwrite
- "never" -> pure NeverOverwrite
- "prompt" -> pure PromptOverwrite
- _ -> P.unexpected $ "OverwritePolicy: " ++ name
+ parsec = do
+ name <- P.munch1 isAlpha
+ case name of
+ "always" -> pure AlwaysOverwrite
+ "never" -> pure NeverOverwrite
+ "prompt" -> pure PromptOverwrite
+ _ -> P.unexpected $ "OverwritePolicy: " ++ name
instance Pretty OverwritePolicy where
- pretty NeverOverwrite = PP.text "never"
- pretty AlwaysOverwrite = PP.text "always"
- pretty PromptOverwrite = PP.text "prompt"
+ pretty NeverOverwrite = PP.text "never"
+ pretty AlwaysOverwrite = PP.text "always"
+ pretty PromptOverwrite = PP.text "prompt"
diff --git a/cabal-install/src/Distribution/Client/Types/PackageLocation.hs b/cabal-install/src/Distribution/Client/Types/PackageLocation.hs
index 2038781bbbafaa28c927fc1b7c8866791088560c..2f4993e22bd35a914ed570ce6198a80e8a99f389 100644
--- a/cabal-install/src/Distribution/Client/Types/PackageLocation.hs
+++ b/cabal-install/src/Distribution/Client/Types/PackageLocation.hs
@@ -1,11 +1,12 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.PackageLocation (
- PackageLocation (..),
- UnresolvedPkgLoc,
- ResolvedPkgLoc,
- UnresolvedSourcePackage,
-) where
+
+module Distribution.Client.Types.PackageLocation
+ ( PackageLocation (..)
+ , UnresolvedPkgLoc
+ , ResolvedPkgLoc
+ , UnresolvedSourcePackage
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
@@ -15,32 +16,27 @@ import Network.URI (URI)
import Distribution.Types.PackageId (PackageId)
import Distribution.Client.Types.Repo
-import Distribution.Client.Types.SourceRepo (SourceRepoMaybe)
+import Distribution.Client.Types.SourceRepo (SourceRepoMaybe)
import Distribution.Solver.Types.SourcePackage (SourcePackage)
type UnresolvedPkgLoc = PackageLocation (Maybe FilePath)
type ResolvedPkgLoc = PackageLocation FilePath
-data PackageLocation local =
-
- -- | An unpacked package in the given dir, or current dir
+data PackageLocation local
+ = -- | An unpacked package in the given dir, or current dir
LocalUnpackedPackage FilePath
-
- -- | A package as a tarball that's available as a local tarball
- | LocalTarballPackage FilePath
-
- -- | A package as a tarball from a remote URI
- | RemoteTarballPackage URI local
-
- -- | A package available as a tarball from a repository.
+ | -- | A package as a tarball that's available as a local tarball
+ LocalTarballPackage FilePath
+ | -- | A package as a tarball from a remote URI
+ RemoteTarballPackage URI local
+ | -- | A package available as a tarball from a repository.
--
-- It may be from a local repository or from a remote repository, with a
-- locally cached copy. ie a package available from hackage
- | RepoTarballPackage Repo PackageId local
-
- -- | A package available from a version control system source repository
- | RemoteSourceRepoPackage SourceRepoMaybe local
+ RepoTarballPackage Repo PackageId local
+ | -- | A package available from a version control system source repository
+ RemoteSourceRepoPackage SourceRepoMaybe local
deriving (Show, Functor, Eq, Ord, Generic, Typeable)
instance Binary local => Binary (PackageLocation local)
diff --git a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs
index 3fbe0265d4f2020767b276d3582d310269dd91ad..5f25be4aa77dfe0549b43133ec04f1f12f93c7aa 100644
--- a/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs
+++ b/cabal-install/src/Distribution/Client/Types/PackageSpecifier.hs
@@ -1,55 +1,55 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.PackageSpecifier (
- PackageSpecifier (..),
- pkgSpecifierTarget,
- pkgSpecifierConstraints,
-) where
+
+module Distribution.Client.Types.PackageSpecifier
+ ( PackageSpecifier (..)
+ , pkgSpecifierTarget
+ , pkgSpecifierConstraints
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Package (Package (..), packageName, packageVersion)
+import Distribution.Package (Package (..), packageName, packageVersion)
import Distribution.Types.PackageName (PackageName)
-import Distribution.Version (thisVersion)
+import Distribution.Version (thisVersion)
import Distribution.Solver.Types.ConstraintSource
import Distribution.Solver.Types.LabeledPackageConstraint
import Distribution.Solver.Types.PackageConstraint
-- | A fully or partially resolved reference to a package.
---
-data PackageSpecifier pkg =
-
- -- | A partially specified reference to a package (either source or
- -- installed). It is specified by package name and optionally some
- -- required properties. Use a dependency resolver to pick a specific
- -- package satisfying these properties.
- --
- NamedPackage PackageName [PackageProperty]
-
- -- | A fully specified source package.
- --
- | SpecificSourcePackage pkg
+data PackageSpecifier pkg
+ = -- | A partially specified reference to a package (either source or
+ -- installed). It is specified by package name and optionally some
+ -- required properties. Use a dependency resolver to pick a specific
+ -- package satisfying these properties.
+ NamedPackage PackageName [PackageProperty]
+ | -- | A fully specified source package.
+ SpecificSourcePackage pkg
deriving (Eq, Show, Functor, Generic)
instance Binary pkg => Binary (PackageSpecifier pkg)
instance Structured pkg => Structured (PackageSpecifier pkg)
pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName
-pkgSpecifierTarget (NamedPackage name _) = name
+pkgSpecifierTarget (NamedPackage name _) = name
pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg
-pkgSpecifierConstraints :: Package pkg
- => PackageSpecifier pkg -> [LabeledPackageConstraint]
+pkgSpecifierConstraints
+ :: Package pkg
+ => PackageSpecifier pkg
+ -> [LabeledPackageConstraint]
pkgSpecifierConstraints (NamedPackage name props) = map toLpc props
where
- toLpc prop = LabeledPackageConstraint
- (PackageConstraint (scopeToplevel name) prop)
- ConstraintSourceUserTarget
-pkgSpecifierConstraints (SpecificSourcePackage pkg) =
- [LabeledPackageConstraint pc ConstraintSourceUserTarget]
+ toLpc prop =
+ LabeledPackageConstraint
+ (PackageConstraint (scopeToplevel name) prop)
+ ConstraintSourceUserTarget
+pkgSpecifierConstraints (SpecificSourcePackage pkg) =
+ [LabeledPackageConstraint pc ConstraintSourceUserTarget]
where
- pc = PackageConstraint
- (ScopeTarget $ packageName pkg)
- (PackagePropertyVersion $ thisVersion (packageVersion pkg))
+ pc =
+ PackageConstraint
+ (ScopeTarget $ packageName pkg)
+ (PackagePropertyVersion $ thisVersion (packageVersion pkg))
diff --git a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs
index 8a526a24817e54c90dd39f8083a3e0ded2ad0f17..e04b5af79c899a1bf0669adea4c834272695f102 100644
--- a/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs
+++ b/cabal-install/src/Distribution/Client/Types/ReadyPackage.hs
@@ -1,31 +1,41 @@
{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Distribution.Client.Types.ReadyPackage (
- GenericReadyPackage (..),
- ReadyPackage,
-) where
+{-# LANGUAGE TypeFamilies #-}
+
+module Distribution.Client.Types.ReadyPackage
+ ( GenericReadyPackage (..)
+ , ReadyPackage
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import Distribution.Compat.Graph (IsNode (..))
-import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled)
+import Distribution.Package (HasMungedPackageId, HasUnitId, Package, PackageInstalled)
import Distribution.Client.Types.ConfiguredPackage (ConfiguredPackage)
-import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc)
+import Distribution.Client.Types.PackageLocation (UnresolvedPkgLoc)
import Distribution.Solver.Types.PackageFixedDeps
-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be
-- installed already, hence itself ready to be installed.
newtype GenericReadyPackage srcpkg = ReadyPackage srcpkg -- see 'ConfiguredPackage'.
- deriving (Eq, Show, Generic, Package, PackageFixedDeps,
- HasMungedPackageId, HasUnitId, PackageInstalled, Binary)
+ deriving
+ ( Eq
+ , Show
+ , Generic
+ , Package
+ , PackageFixedDeps
+ , HasMungedPackageId
+ , HasUnitId
+ , PackageInstalled
+ , Binary
+ )
-- Can't newtype derive this
instance IsNode srcpkg => IsNode (GenericReadyPackage srcpkg) where
- type Key (GenericReadyPackage srcpkg) = Key srcpkg
- nodeKey (ReadyPackage spkg) = nodeKey spkg
- nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg
+ type Key (GenericReadyPackage srcpkg) = Key srcpkg
+ nodeKey (ReadyPackage spkg) = nodeKey spkg
+ nodeNeighbors (ReadyPackage spkg) = nodeNeighbors spkg
type ReadyPackage = GenericReadyPackage (ConfiguredPackage UnresolvedPkgLoc)
diff --git a/cabal-install/src/Distribution/Client/Types/Repo.hs b/cabal-install/src/Distribution/Client/Types/Repo.hs
index 7804c1f3c5f7d325c8429f01af56ac6000ce5641..b5606725432fb2f67cb4bbb57338a35e6848843c 100644
--- a/cabal-install/src/Distribution/Client/Types/Repo.hs
+++ b/cabal-install/src/Distribution/Client/Types/Repo.hs
@@ -1,18 +1,21 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.Repo (
- -- * Remote repository
- RemoteRepo (..),
- emptyRemoteRepo,
+
+module Distribution.Client.Types.Repo
+ ( -- * Remote repository
+ RemoteRepo (..)
+ , emptyRemoteRepo
+
-- * Local repository (no-index)
- LocalRepo (..),
- emptyLocalRepo,
- localRepoCacheKey,
+ , LocalRepo (..)
+ , emptyLocalRepo
+ , localRepoCacheKey
+
-- * Repository
- Repo (..),
- repoName,
- isRepoRemote,
- maybeRepoRemote,
-) where
+ , Repo (..)
+ , repoName
+ , isRepoRemote
+ , maybeRepoRemote
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
@@ -23,9 +26,9 @@ import Distribution.Simple.Utils (toUTF8BS)
import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)
-import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
import Distribution.Client.Types.RepoName
@@ -33,59 +36,55 @@ import Distribution.Client.Types.RepoName
-- Remote repository
-------------------------------------------------------------------------------
-data RemoteRepo =
- RemoteRepo {
- remoteRepoName :: RepoName,
- remoteRepoURI :: URI,
-
- -- | Enable secure access?
- --
- -- 'Nothing' here represents "whatever the default is"; this is important
- -- to allow for a smooth transition from opt-in to opt-out security
- -- (once we switch to opt-out, all access to the central Hackage
- -- repository should be secure by default)
- remoteRepoSecure :: Maybe Bool,
-
- -- | Root key IDs (for bootstrapping)
- remoteRepoRootKeys :: [String],
-
- -- | Threshold for verification during bootstrapping
- remoteRepoKeyThreshold :: Int,
-
- -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a
- -- special case we may know a repo supports both and want to try HTTPS
- -- if we can, but still allow falling back to HTTP.
- --
- -- This field is not currently stored in the config file, but is filled
- -- in automagically for known repos.
- remoteRepoShouldTryHttps :: Bool
- }
-
+data RemoteRepo = RemoteRepo
+ { remoteRepoName :: RepoName
+ , remoteRepoURI :: URI
+ , remoteRepoSecure :: Maybe Bool
+ -- ^ Enable secure access?
+ --
+ -- 'Nothing' here represents "whatever the default is"; this is important
+ -- to allow for a smooth transition from opt-in to opt-out security
+ -- (once we switch to opt-out, all access to the central Hackage
+ -- repository should be secure by default)
+ , remoteRepoRootKeys :: [String]
+ -- ^ Root key IDs (for bootstrapping)
+ , remoteRepoKeyThreshold :: Int
+ -- ^ Threshold for verification during bootstrapping
+ , remoteRepoShouldTryHttps :: Bool
+ -- ^ Normally a repo just specifies an HTTP or HTTPS URI, but as a
+ -- special case we may know a repo supports both and want to try HTTPS
+ -- if we can, but still allow falling back to HTTP.
+ --
+ -- This field is not currently stored in the config file, but is filled
+ -- in automagically for known repos.
+ }
deriving (Show, Eq, Ord, Generic)
instance Binary RemoteRepo
instance Structured RemoteRepo
instance Pretty RemoteRepo where
- pretty r =
- pretty (remoteRepoName r) <<>> Disp.colon <<>>
- Disp.text (uriToString id (remoteRepoURI r) [])
+ pretty r =
+ pretty (remoteRepoName r)
+ <<>> Disp.colon
+ <<>> Disp.text (uriToString id (remoteRepoURI r) [])
-- | Note: serialised format represents 'RemoteRepo' only partially.
instance Parsec RemoteRepo where
- parsec = do
- name <- parsec
- _ <- P.char ':'
- uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))
- uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)
- return RemoteRepo
- { remoteRepoName = name
- , remoteRepoURI = uri
- , remoteRepoSecure = Nothing
- , remoteRepoRootKeys = []
- , remoteRepoKeyThreshold = 0
- , remoteRepoShouldTryHttps = False
- }
+ parsec = do
+ name <- parsec
+ _ <- P.char ':'
+ uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))
+ uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)
+ return
+ RemoteRepo
+ { remoteRepoName = name
+ , remoteRepoURI = uri
+ , remoteRepoSecure = Nothing
+ , remoteRepoRootKeys = []
+ , remoteRepoKeyThreshold = 0
+ , remoteRepoShouldTryHttps = False
+ }
-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.
emptyRemoteRepo :: RepoName -> RemoteRepo
@@ -99,10 +98,10 @@ emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False
--
-- https://github.com/haskell/cabal/issues/6359
data LocalRepo = LocalRepo
- { localRepoName :: RepoName
- , localRepoPath :: FilePath
- , localRepoSharedCache :: Bool
- }
+ { localRepoName :: RepoName
+ , localRepoPath :: FilePath
+ , localRepoSharedCache :: Bool
+ }
deriving (Show, Eq, Ord, Generic)
instance Binary LocalRepo
@@ -110,14 +109,14 @@ instance Structured LocalRepo
-- | Note: doesn't parse 'localRepoSharedCache' field.
instance Parsec LocalRepo where
- parsec = do
- n <- parsec
- _ <- P.char ':'
- p <- P.munch1 (const True) -- restrict what can be a path?
- return (LocalRepo n p False)
+ parsec = do
+ n <- parsec
+ _ <- P.char ':'
+ p <- P.munch1 (const True) -- restrict what can be a path?
+ return (LocalRepo n p False)
instance Pretty LocalRepo where
- pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p
+ pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p
-- | Construct a partial 'LocalRepo' value to fold the field parser list over.
emptyLocalRepo :: RepoName -> LocalRepo
@@ -129,10 +128,15 @@ emptyLocalRepo name = LocalRepo name "" False
-- all be named "local", so we add a bit of `localRepoPath` into the
-- mix.
localRepoCacheKey :: LocalRepo -> String
-localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where
- hashPart
- = showHashValue $ truncateHash 8 $ hashValue
- $ LBS.fromStrict $ toUTF8BS $ localRepoPath local
+localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart
+ where
+ hashPart =
+ showHashValue $
+ truncateHash 8 $
+ hashValue $
+ LBS.fromStrict $
+ toUTF8BS $
+ localRepoPath local
-------------------------------------------------------------------------------
-- Any repository
@@ -142,21 +146,19 @@ localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart wh
--
-- NOTE: It is important that this type remains serializable.
data Repo
- -- | Local repository, without index.
+ = -- | Local repository, without index.
--
-- https://github.com/haskell/cabal/issues/6359
- = RepoLocalNoIndex
- { repoLocal :: LocalRepo
+ RepoLocalNoIndex
+ { repoLocal :: LocalRepo
, repoLocalDir :: FilePath
}
-
- -- | Standard (unsecured) remote repositories
- | RepoRemote {
- repoRemote :: RemoteRepo
+ | -- | Standard (unsecured) remote repositories
+ RepoRemote
+ { repoRemote :: RemoteRepo
, repoLocalDir :: FilePath
}
-
- -- | Secure repositories
+ | -- | Secure repositories
--
-- Although this contains the same fields as 'RepoRemote', we use a separate
-- constructor to avoid confusing the two.
@@ -164,8 +166,8 @@ data Repo
-- Not all access to a secure repo goes through the hackage-security
-- library currently; code paths that do not still make use of the
-- 'repoRemote' and 'repoLocalDir' fields directly.
- | RepoSecure {
- repoRemote :: RemoteRepo
+ RepoSecure
+ { repoRemote :: RemoteRepo
, repoLocalDir :: FilePath
}
deriving (Show, Eq, Ord, Generic)
@@ -176,15 +178,15 @@ instance Structured Repo
-- | Check if this is a remote repo
isRepoRemote :: Repo -> Bool
isRepoRemote RepoLocalNoIndex{} = False
-isRepoRemote _ = True
+isRepoRemote _ = True
-- | Extract @RemoteRepo@ from @Repo@ if remote.
maybeRepoRemote :: Repo -> Maybe RemoteRepo
maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing
-maybeRepoRemote (RepoRemote r _localDir) = Just r
-maybeRepoRemote (RepoSecure r _localDir) = Just r
+maybeRepoRemote (RepoRemote r _localDir) = Just r
+maybeRepoRemote (RepoSecure r _localDir) = Just r
repoName :: Repo -> RepoName
repoName (RepoLocalNoIndex r _) = localRepoName r
-repoName (RepoRemote r _) = remoteRepoName r
-repoName (RepoSecure r _) = remoteRepoName r
+repoName (RepoRemote r _) = remoteRepoName r
+repoName (RepoSecure r _) = remoteRepoName r
diff --git a/cabal-install/src/Distribution/Client/Types/RepoName.hs b/cabal-install/src/Distribution/Client/Types/RepoName.hs
index 37da5a638e429186454cc3df32ad05ae59879e3f..2eb2fb15fc864294fc34c266650f7fc8b520991a 100644
--- a/cabal-install/src/Distribution/Client/Types/RepoName.hs
+++ b/cabal-install/src/Distribution/Client/Types/RepoName.hs
@@ -1,13 +1,14 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.RepoName (
- RepoName (..),
-) where
+
+module Distribution.Client.Types.RepoName
+ ( RepoName (..)
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
import qualified Distribution.Compat.CharParsing as P
-import qualified Text.PrettyPrint as Disp
+import qualified Text.PrettyPrint as Disp
-- $setup
-- >>> import Distribution.Parsec
@@ -15,8 +16,7 @@ import qualified Text.PrettyPrint as Disp
-- | Repository name.
--
-- May be used as path segment.
---
-newtype RepoName = RepoName { unRepoName :: String }
+newtype RepoName = RepoName {unRepoName :: String}
deriving (Show, Eq, Ord, Generic)
instance Binary RepoName
@@ -24,7 +24,7 @@ instance Structured RepoName
instance NFData RepoName
instance Pretty RepoName where
- pretty = Disp.text . unRepoName
+ pretty = Disp.text . unRepoName
-- |
--
@@ -33,9 +33,9 @@ instance Pretty RepoName where
--
-- >>> simpleParsec "0123" :: Maybe RepoName
-- Nothing
---
instance Parsec RepoName where
- parsec = RepoName <$> parser where
- parser = (:) <$> lead <*> rest
- lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.')
- rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
+ parsec = RepoName <$> parser
+ where
+ parser = (:) <$> lead <*> rest
+ lead = P.satisfy (\c -> isAlpha c || c == '_' || c == '-' || c == '.')
+ rest = P.munch (\c -> isAlphaNum c || c == '_' || c == '-' || c == '.')
diff --git a/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs b/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs
index 79604250a3fabb0229d32ec6f961231b40082fd6..d24d88a01b433728265f4566798d39445543c4df 100644
--- a/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs
+++ b/cabal-install/src/Distribution/Client/Types/SourcePackageDb.hs
@@ -1,29 +1,29 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.SourcePackageDb (
- SourcePackageDb (..),
- lookupDependency,
- lookupPackageName,
-) where
+
+module Distribution.Client.Types.SourcePackageDb
+ ( SourcePackageDb (..)
+ , lookupDependency
+ , lookupPackageName
+ ) where
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Distribution.Types.PackageName (PackageName)
+import Distribution.Package (packageVersion)
+import Distribution.Types.PackageName (PackageName)
import Distribution.Types.VersionRange (VersionRange, withinRange)
-import Distribution.Package (packageVersion)
import Distribution.Client.Types.PackageLocation (UnresolvedSourcePackage)
+import Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Distribution.Solver.Types.PackageIndex as PackageIndex
-import Distribution.Solver.Types.PackageIndex (PackageIndex)
import qualified Data.Map as Map
-- | This is the information we get from a @00-index.tar.gz@ hackage index.
---
data SourcePackageDb = SourcePackageDb
- { packageIndex :: PackageIndex UnresolvedSourcePackage
- , packagePreferences :: Map PackageName VersionRange
- }
+ { packageIndex :: PackageIndex UnresolvedSourcePackage
+ , packagePreferences :: Map PackageName VersionRange
+ }
deriving (Eq, Generic)
instance Binary SourcePackageDb
@@ -42,7 +42,6 @@ lookupDependency sourceDb pname version =
where
pref = Map.lookup pname (packagePreferences sourceDb)
-
-- | Does a case-sensitive search by package name.
--
-- Additionally, `preferred-versions` (such as version deprecation) are
diff --git a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs
index 751c6c972661bd37a138ea68f775bd52235e63ee..05449d1887b1ca3e645b9ce6e8b1a51780739915 100644
--- a/cabal-install/src/Distribution/Client/Types/SourceRepo.hs
+++ b/cabal-install/src/Distribution/Client/Types/SourceRepo.hs
@@ -1,49 +1,49 @@
-{-# LANGUAGE ConstraintKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
-module Distribution.Client.Types.SourceRepo (
- SourceRepositoryPackage (..),
- SourceRepoList,
- SourceRepoMaybe,
- SourceRepoProxy,
- srpHoist,
- srpToProxy,
- srpFanOut,
- sourceRepositoryPackageGrammar,
-) where
+
+module Distribution.Client.Types.SourceRepo
+ ( SourceRepositoryPackage (..)
+ , SourceRepoList
+ , SourceRepoMaybe
+ , SourceRepoProxy
+ , srpHoist
+ , srpToProxy
+ , srpFanOut
+ , sourceRepositoryPackageGrammar
+ ) where
import Distribution.Client.Compat.Prelude
-import Distribution.Compat.Lens (Lens, Lens')
+import Distribution.Compat.Lens (Lens, Lens')
import Prelude ()
import Distribution.FieldGrammar
import Distribution.Types.SourceRepo (RepoType (..))
-- | @source-repository-package@ definition
---
data SourceRepositoryPackage f = SourceRepositoryPackage
- { srpType :: !RepoType
- , srpLocation :: !String
- , srpTag :: !(Maybe String)
- , srpBranch :: !(Maybe String)
- , srpSubdir :: !(f FilePath)
- , srpCommand :: ![String]
- }
+ { srpType :: !RepoType
+ , srpLocation :: !String
+ , srpTag :: !(Maybe String)
+ , srpBranch :: !(Maybe String)
+ , srpSubdir :: !(f FilePath)
+ , srpCommand :: ![String]
+ }
deriving (Generic)
-deriving instance (Eq (f FilePath)) => Eq (SourceRepositoryPackage f)
-deriving instance (Ord (f FilePath)) => Ord (SourceRepositoryPackage f)
-deriving instance (Show (f FilePath)) => Show (SourceRepositoryPackage f)
-deriving instance (Binary (f FilePath)) => Binary (SourceRepositoryPackage f)
+deriving instance Eq (f FilePath) => Eq (SourceRepositoryPackage f)
+deriving instance Ord (f FilePath) => Ord (SourceRepositoryPackage f)
+deriving instance Show (f FilePath) => Show (SourceRepositoryPackage f)
+deriving instance Binary (f FilePath) => Binary (SourceRepositoryPackage f)
deriving instance (Typeable f, Structured (f FilePath)) => Structured (SourceRepositoryPackage f)
-- | Read from @cabal.project@
-type SourceRepoList = SourceRepositoryPackage []
+type SourceRepoList = SourceRepositoryPackage []
-- | Distilled from 'Distribution.Types.SourceRepo.SourceRepo'
type SourceRepoMaybe = SourceRepositoryPackage Maybe
@@ -52,45 +52,46 @@ type SourceRepoMaybe = SourceRepositoryPackage Maybe
type SourceRepoProxy = SourceRepositoryPackage Proxy
srpHoist :: (forall x. f x -> g x) -> SourceRepositoryPackage f -> SourceRepositoryPackage g
-srpHoist nt s = s { srpSubdir = nt (srpSubdir s) }
+srpHoist nt s = s{srpSubdir = nt (srpSubdir s)}
srpToProxy :: SourceRepositoryPackage f -> SourceRepositoryPackage Proxy
-srpToProxy s = s { srpSubdir = Proxy }
+srpToProxy s = s{srpSubdir = Proxy}
-- | Split single @source-repository-package@ declaration with multiple subdirs,
-- into multiple ones with at most single subdir.
srpFanOut :: SourceRepositoryPackage [] -> NonEmpty (SourceRepositoryPackage Maybe)
-srpFanOut s@SourceRepositoryPackage { srpSubdir = [] } =
- s { srpSubdir = Nothing } :| []
-srpFanOut s@SourceRepositoryPackage { srpSubdir = d:ds } = f d :| map f ds where
- f subdir = s { srpSubdir = Just subdir }
+srpFanOut s@SourceRepositoryPackage{srpSubdir = []} =
+ s{srpSubdir = Nothing} :| []
+srpFanOut s@SourceRepositoryPackage{srpSubdir = d : ds} = f d :| map f ds
+ where
+ f subdir = s{srpSubdir = Just subdir}
-------------------------------------------------------------------------------
-- Lens
-------------------------------------------------------------------------------
srpTypeLens :: Lens' (SourceRepositoryPackage f) RepoType
-srpTypeLens f s = fmap (\x -> s { srpType = x }) (f (srpType s))
+srpTypeLens f s = fmap (\x -> s{srpType = x}) (f (srpType s))
{-# INLINE srpTypeLens #-}
srpLocationLens :: Lens' (SourceRepositoryPackage f) String
-srpLocationLens f s = fmap (\x -> s { srpLocation = x }) (f (srpLocation s))
+srpLocationLens f s = fmap (\x -> s{srpLocation = x}) (f (srpLocation s))
{-# INLINE srpLocationLens #-}
srpTagLens :: Lens' (SourceRepositoryPackage f) (Maybe String)
-srpTagLens f s = fmap (\x -> s { srpTag = x }) (f (srpTag s))
+srpTagLens f s = fmap (\x -> s{srpTag = x}) (f (srpTag s))
{-# INLINE srpTagLens #-}
srpBranchLens :: Lens' (SourceRepositoryPackage f) (Maybe String)
-srpBranchLens f s = fmap (\x -> s { srpBranch = x }) (f (srpBranch s))
+srpBranchLens f s = fmap (\x -> s{srpBranch = x}) (f (srpBranch s))
{-# INLINE srpBranchLens #-}
srpSubdirLens :: Lens (SourceRepositoryPackage f) (SourceRepositoryPackage g) (f FilePath) (g FilePath)
-srpSubdirLens f s = fmap (\x -> s { srpSubdir = x }) (f (srpSubdir s))
+srpSubdirLens f s = fmap (\x -> s{srpSubdir = x}) (f (srpSubdir s))
{-# INLINE srpSubdirLens #-}
srpCommandLensNE :: Lens' (SourceRepositoryPackage f) (Maybe (NonEmpty String))
-srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (nonEmpty (srpCommand s)))
+srpCommandLensNE f s = fmap (\x -> s{srpCommand = maybe [] toList x}) (f (nonEmpty (srpCommand s)))
{-# INLINE srpCommandLensNE #-}
-------------------------------------------------------------------------------
@@ -98,18 +99,20 @@ srpCommandLensNE f s = fmap (\x -> s { srpCommand = maybe [] toList x }) (f (non
-------------------------------------------------------------------------------
sourceRepositoryPackageGrammar
- :: ( FieldGrammar c g, Applicative (g SourceRepoList)
- , c (Identity RepoType)
- , c (List NoCommaFSep FilePathNT String)
- , c (NonEmpty' NoCommaFSep Token String)
- )
- => g SourceRepoList SourceRepoList
-sourceRepositoryPackageGrammar = SourceRepositoryPackage
- <$> uniqueField "type" srpTypeLens
- <*> uniqueFieldAla "location" Token srpLocationLens
- <*> optionalFieldAla "tag" Token srpTagLens
- <*> optionalFieldAla "branch" Token srpBranchLens
- <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...
+ :: ( FieldGrammar c g
+ , Applicative (g SourceRepoList)
+ , c (Identity RepoType)
+ , c (List NoCommaFSep FilePathNT String)
+ , c (NonEmpty' NoCommaFSep Token String)
+ )
+ => g SourceRepoList SourceRepoList
+sourceRepositoryPackageGrammar =
+ SourceRepositoryPackage
+ <$> uniqueField "type" srpTypeLens
+ <*> uniqueFieldAla "location" Token srpLocationLens
+ <*> optionalFieldAla "tag" Token srpTagLens
+ <*> optionalFieldAla "branch" Token srpBranchLens
+ <*> monoidalFieldAla "subdir" (alaList' NoCommaFSep FilePathNT) srpSubdirLens -- note: NoCommaFSep is somewhat important for roundtrip, as "." is there...
<*> fmap (maybe [] toList) pcc
where
pcc = optionalFieldAla "post-checkout-command" (alaNonEmpty' NoCommaFSep Token) srpCommandLensNE
diff --git a/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs b/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs
index b0563ca0c127c0021c84e9d3c25a6857af334021..042b62d997acf812888f9844c67fc7026e985dfd 100644
--- a/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs
+++ b/cabal-install/src/Distribution/Client/Types/WriteGhcEnvironmentFilesPolicy.hs
@@ -1,10 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
-module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy (
- WriteGhcEnvironmentFilesPolicy (..),
-) where
-import Prelude ()
+module Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy
+ ( WriteGhcEnvironmentFilesPolicy (..)
+ ) where
+
import Distribution.Client.Compat.Prelude
+import Prelude ()
-- | Whether 'v2-build' should write a .ghc.environment file after
-- success. Possible values: 'always', 'never' (the default), 'ghc8.4.4+'
diff --git a/cabal-install/src/Distribution/Client/Upload.hs b/cabal-install/src/Distribution/Client/Upload.hs
index d5f464399544ce755fca8a38e307f71eba4d4009..7f78ee8e2e346ff27aac08732a47b2306c5acd4c 100644
--- a/cabal-install/src/Distribution/Client/Upload.hs
+++ b/cabal-install/src/Distribution/Client/Upload.hs
@@ -1,32 +1,36 @@
module Distribution.Client.Upload (upload, uploadDoc, report) where
import Distribution.Client.Compat.Prelude
-import qualified Prelude as Unsafe (tail, head, read)
+import qualified Prelude as Unsafe (head, read, tail)
-import Distribution.Client.Types.Credentials ( Username(..), Password(..) )
-import Distribution.Client.Types.Repo (Repo, RemoteRepo(..), maybeRepoRemote)
-import Distribution.Client.Types.RepoName (unRepoName)
import Distribution.Client.HttpUtils
- ( HttpTransport(..), remoteRepoTryUpgradeToHttps )
+ ( HttpTransport (..)
+ , remoteRepoTryUpgradeToHttps
+ )
import Distribution.Client.Setup
- ( IsCandidate(..), RepoContext(..) )
+ ( IsCandidate (..)
+ , RepoContext (..)
+ )
+import Distribution.Client.Types.Credentials (Password (..), Username (..))
+import Distribution.Client.Types.Repo (RemoteRepo (..), Repo, maybeRepoRemote)
+import Distribution.Client.Types.RepoName (unRepoName)
-import Distribution.Simple.Utils (notice, warn, info, die', toUTF8BS)
-import Distribution.Utils.String (trim)
import Distribution.Client.Config
+import Distribution.Simple.Utils (die', info, notice, toUTF8BS, warn)
+import Distribution.Utils.String (trim)
-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import Distribution.Client.BuildReports.Anonymous (parseBuildReport)
+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
import qualified Distribution.Client.BuildReports.Upload as BuildReport
-import Network.URI (URI(uriPath, uriAuthority), URIAuth(uriRegName))
-import Network.HTTP (Header(..), HeaderName(..))
+import Network.HTTP (Header (..), HeaderName (..))
+import Network.URI (URI (uriAuthority, uriPath), URIAuth (uriRegName))
-import System.IO (hFlush, stdout)
-import System.IO.Echo (withoutInputEcho)
-import System.FilePath ((</>), takeExtension, takeFileName, dropExtension)
-import qualified System.FilePath.Posix as FilePath.Posix ((</>))
import System.Directory
+import System.FilePath (dropExtension, takeExtension, takeFileName, (</>))
+import qualified System.FilePath.Posix as FilePath.Posix ((</>))
+import System.IO (hFlush, stdout)
+import System.IO.Echo (withoutInputEcho)
type Auth = Maybe (String, String)
@@ -36,124 +40,162 @@ type Auth = Maybe (String, String)
-- Nothing
stripExtensions :: [String] -> FilePath -> Maybe String
stripExtensions exts path = foldM f path (reverse exts)
- where
- f p e
- | takeExtension p == '.':e = Just (dropExtension p)
- | otherwise = Nothing
-
-upload :: Verbosity -> RepoContext
- -> Maybe Username -> Maybe Password -> IsCandidate -> [FilePath]
- -> IO ()
+ where
+ f p e
+ | takeExtension p == '.' : e = Just (dropExtension p)
+ | otherwise = Nothing
+
+upload
+ :: Verbosity
+ -> RepoContext
+ -> Maybe Username
+ -> Maybe Password
+ -> IsCandidate
+ -> [FilePath]
+ -> IO ()
upload verbosity repoCtxt mUsername mPassword isCandidate paths = do
- let repos :: [Repo]
- repos = repoContextRepos repoCtxt
- transport <- repoContextGetTransport repoCtxt
- targetRepo <-
- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of
- [] -> die' verbosity "Cannot upload. No remote repositories are configured."
- (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))
- let targetRepoURI :: URI
- targetRepoURI = remoteRepoURI targetRepo
- domain :: String
- domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
- rootIfEmpty x = if null x then "/" else x
- uploadURI :: URI
- uploadURI = targetRepoURI {
- uriPath = rootIfEmpty (uriPath targetRepoURI) FilePath.Posix.</>
- case isCandidate of
- IsCandidate -> "packages/candidates"
- IsPublished -> "upload"
- }
- packageURI pkgid = targetRepoURI {
- uriPath = rootIfEmpty (uriPath targetRepoURI)
- FilePath.Posix.</> concat
- [ "package/", pkgid
- , case isCandidate of
- IsCandidate -> "/candidate"
- IsPublished -> ""
- ]
- }
- Username username <- maybe (promptUsername domain) return mUsername
- Password password <- maybe (promptPassword domain) return mPassword
- let auth = Just (username,password)
- for_ paths $ \path -> do
- notice verbosity $ "Uploading " ++ path ++ "... "
- case fmap takeFileName (stripExtensions ["tar", "gz"] path) of
- Just pkgid -> handlePackage transport verbosity uploadURI
- (packageURI pkgid) auth isCandidate path
- -- This case shouldn't really happen, since we check in Main that we
- -- only pass tar.gz files to upload.
- Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path
-
-uploadDoc :: Verbosity -> RepoContext
- -> Maybe Username -> Maybe Password -> IsCandidate -> FilePath
- -> IO ()
+ let repos :: [Repo]
+ repos = repoContextRepos repoCtxt
+ transport <- repoContextGetTransport repoCtxt
+ targetRepo <-
+ case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of
+ [] -> die' verbosity "Cannot upload. No remote repositories are configured."
+ (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs))
+ let targetRepoURI :: URI
+ targetRepoURI = remoteRepoURI targetRepo
+ domain :: String
+ domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
+ rootIfEmpty x = if null x then "/" else x
+ uploadURI :: URI
+ uploadURI =
+ targetRepoURI
+ { uriPath =
+ rootIfEmpty (uriPath targetRepoURI)
+ FilePath.Posix.</> case isCandidate of
+ IsCandidate -> "packages/candidates"
+ IsPublished -> "upload"
+ }
+ packageURI pkgid =
+ targetRepoURI
+ { uriPath =
+ rootIfEmpty (uriPath targetRepoURI)
+ FilePath.Posix.</> concat
+ [ "package/"
+ , pkgid
+ , case isCandidate of
+ IsCandidate -> "/candidate"
+ IsPublished -> ""
+ ]
+ }
+ Username username <- maybe (promptUsername domain) return mUsername
+ Password password <- maybe (promptPassword domain) return mPassword
+ let auth = Just (username, password)
+ for_ paths $ \path -> do
+ notice verbosity $ "Uploading " ++ path ++ "... "
+ case fmap takeFileName (stripExtensions ["tar", "gz"] path) of
+ Just pkgid ->
+ handlePackage
+ transport
+ verbosity
+ uploadURI
+ (packageURI pkgid)
+ auth
+ isCandidate
+ path
+ -- This case shouldn't really happen, since we check in Main that we
+ -- only pass tar.gz files to upload.
+ Nothing -> die' verbosity $ "Not a tar.gz file: " ++ path
+
+uploadDoc
+ :: Verbosity
+ -> RepoContext
+ -> Maybe Username
+ -> Maybe Password
+ -> IsCandidate
+ -> FilePath
+ -> IO ()
uploadDoc verbosity repoCtxt mUsername mPassword isCandidate path = do
- let repos = repoContextRepos repoCtxt
- transport <- repoContextGetTransport repoCtxt
- targetRepo <-
- case [ remoteRepo | Just remoteRepo <- map maybeRepoRemote repos ] of
- [] -> die' verbosity $ "Cannot upload. No remote repositories are configured."
- (r:rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r:|rs))
- let targetRepoURI = remoteRepoURI targetRepo
- domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
- rootIfEmpty x = if null x then "/" else x
- uploadURI = targetRepoURI {
- uriPath = rootIfEmpty (uriPath targetRepoURI)
- FilePath.Posix.</> concat
- [ "package/", pkgid
- , case isCandidate of
- IsCandidate -> "/candidate"
- IsPublished -> ""
- , "/docs"
- ]
- }
- packageUri = targetRepoURI {
- uriPath = rootIfEmpty (uriPath targetRepoURI)
- FilePath.Posix.</> concat
- [ "package/", pkgid
- , case isCandidate of
- IsCandidate -> "/candidate"
- IsPublished -> ""
- ]
- }
- (reverseSuffix, reversePkgid) = break (== '-')
- (reverse (takeFileName path))
- pkgid = reverse $ Unsafe.tail reversePkgid
- when (reverse reverseSuffix /= "docs.tar.gz"
- || null reversePkgid || Unsafe.head reversePkgid /= '-') $
- die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"
- Username username <- maybe (promptUsername domain) return mUsername
- Password password <- maybe (promptPassword domain) return mPassword
+ let repos = repoContextRepos repoCtxt
+ transport <- repoContextGetTransport repoCtxt
+ targetRepo <-
+ case [remoteRepo | Just remoteRepo <- map maybeRepoRemote repos] of
+ [] -> die' verbosity $ "Cannot upload. No remote repositories are configured."
+ (r : rs) -> remoteRepoTryUpgradeToHttps verbosity transport (last (r :| rs))
+ let targetRepoURI = remoteRepoURI targetRepo
+ domain = maybe "Hackage" uriRegName $ uriAuthority targetRepoURI
+ rootIfEmpty x = if null x then "/" else x
+ uploadURI =
+ targetRepoURI
+ { uriPath =
+ rootIfEmpty (uriPath targetRepoURI)
+ FilePath.Posix.</> concat
+ [ "package/"
+ , pkgid
+ , case isCandidate of
+ IsCandidate -> "/candidate"
+ IsPublished -> ""
+ , "/docs"
+ ]
+ }
+ packageUri =
+ targetRepoURI
+ { uriPath =
+ rootIfEmpty (uriPath targetRepoURI)
+ FilePath.Posix.</> concat
+ [ "package/"
+ , pkgid
+ , case isCandidate of
+ IsCandidate -> "/candidate"
+ IsPublished -> ""
+ ]
+ }
+ (reverseSuffix, reversePkgid) =
+ break
+ (== '-')
+ (reverse (takeFileName path))
+ pkgid = reverse $ Unsafe.tail reversePkgid
+ when
+ ( reverse reverseSuffix /= "docs.tar.gz"
+ || null reversePkgid
+ || Unsafe.head reversePkgid /= '-'
+ )
+ $ die' verbosity "Expected a file name matching the pattern <pkgid>-docs.tar.gz"
+ Username username <- maybe (promptUsername domain) return mUsername
+ Password password <- maybe (promptPassword domain) return mPassword
- let auth = Just (username,password)
- headers =
- [ Header HdrContentType "application/x-tar"
- , Header HdrContentEncoding "gzip"
- ]
- notice verbosity $ "Uploading documentation " ++ path ++ "... "
- resp <- putHttpFile transport verbosity uploadURI path auth headers
- case resp of
- -- Hackage responds with 204 No Content when docs are uploaded
- -- successfully.
- (code,_) | code `elem` [200,204] -> do
- notice verbosity $ okMessage packageUri
- (code,err) -> do
- notice verbosity $ "Error uploading documentation "
- ++ path ++ ": "
- ++ "http code " ++ show code ++ "\n"
- ++ err
- exitFailure
+ let auth = Just (username, password)
+ headers =
+ [ Header HdrContentType "application/x-tar"
+ , Header HdrContentEncoding "gzip"
+ ]
+ notice verbosity $ "Uploading documentation " ++ path ++ "... "
+ resp <- putHttpFile transport verbosity uploadURI path auth headers
+ case resp of
+ -- Hackage responds with 204 No Content when docs are uploaded
+ -- successfully.
+ (code, _) | code `elem` [200, 204] -> do
+ notice verbosity $ okMessage packageUri
+ (code, err) -> do
+ notice verbosity $
+ "Error uploading documentation "
+ ++ path
+ ++ ": "
+ ++ "http code "
+ ++ show code
+ ++ "\n"
+ ++ err
+ exitFailure
where
okMessage packageUri = case isCandidate of
IsCandidate ->
"Documentation successfully uploaded for package candidate. "
- ++ "You can now preview the result at '" ++ show packageUri
- ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'."
+ ++ "You can now preview the result at '"
+ ++ show packageUri
+ ++ "'. To upload non-candidate documentation, use 'cabal upload --publish'."
IsPublished ->
"Package documentation successfully published. You can now view it at '"
- ++ show packageUri ++ "'."
-
+ ++ show packageUri
+ ++ "'."
promptUsername :: String -> IO Username
promptUsername domain = do
@@ -172,60 +214,83 @@ promptPassword domain = do
report :: Verbosity -> RepoContext -> Maybe Username -> Maybe Password -> IO ()
report verbosity repoCtxt mUsername mPassword = do
- let repos :: [Repo]
- repos = repoContextRepos repoCtxt
+ let repos :: [Repo]
+ repos = repoContextRepos repoCtxt
remoteRepos :: [RemoteRepo]
remoteRepos = mapMaybe maybeRepoRemote repos
for_ remoteRepos $ \remoteRepo -> do
- let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)
- Username username <- maybe (promptUsername domain) return mUsername
- Password password <- maybe (promptPassword domain) return mPassword
- let auth :: (String, String)
- auth = (username, password)
-
- reportsDir <- defaultReportsDir
- let srcDir :: FilePath
- srcDir = reportsDir </> unRepoName (remoteRepoName remoteRepo)
- -- We don't want to bomb out just because we haven't built any packages
- -- from this repo yet.
- srcExists <- doesDirectoryExist srcDir
- when srcExists $ do
- contents <- getDirectoryContents srcDir
- for_ (filter (\c -> takeExtension c ==".log") contents) $ \logFile ->
- do inp <- readFile (srcDir </> logFile)
- let (reportStr, buildLog) = Unsafe.read inp :: (String,String) -- TODO: eradicateNoParse
- case parseBuildReport (toUTF8BS reportStr) of
- Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME
- Right report' ->
- do info verbosity $ "Uploading report for "
- ++ prettyShow (BuildReport.package report')
- BuildReport.uploadReports verbosity repoCtxt auth
- (remoteRepoURI remoteRepo) [(report', Just buildLog)]
- return ()
-
-handlePackage :: HttpTransport -> Verbosity -> URI -> URI -> Auth
- -> IsCandidate -> FilePath -> IO ()
+ let domain = maybe "Hackage" uriRegName $ uriAuthority (remoteRepoURI remoteRepo)
+ Username username <- maybe (promptUsername domain) return mUsername
+ Password password <- maybe (promptPassword domain) return mPassword
+ let auth :: (String, String)
+ auth = (username, password)
+
+ reportsDir <- defaultReportsDir
+ let srcDir :: FilePath
+ srcDir = reportsDir </> unRepoName (remoteRepoName remoteRepo)
+ -- We don't want to bomb out just because we haven't built any packages
+ -- from this repo yet.
+ srcExists <- doesDirectoryExist srcDir
+ when srcExists $ do
+ contents <- getDirectoryContents srcDir
+ for_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->
+ do
+ inp <- readFile (srcDir </> logFile)
+ let (reportStr, buildLog) = Unsafe.read inp :: (String, String) -- TODO: eradicateNoParse
+ case parseBuildReport (toUTF8BS reportStr) of
+ Left errs -> warn verbosity $ "Errors: " ++ errs -- FIXME
+ Right report' ->
+ do
+ info verbosity $
+ "Uploading report for "
+ ++ prettyShow (BuildReport.package report')
+ BuildReport.uploadReports
+ verbosity
+ repoCtxt
+ auth
+ (remoteRepoURI remoteRepo)
+ [(report', Just buildLog)]
+ return ()
+
+handlePackage
+ :: HttpTransport
+ -> Verbosity
+ -> URI
+ -> URI
+ -> Auth
+ -> IsCandidate
+ -> FilePath
+ -> IO ()
handlePackage transport verbosity uri packageUri auth isCandidate path =
- do resp <- postHttpFile transport verbosity uri path auth
- case resp of
- (code,warnings) | code `elem` [200, 204] ->
- notice verbosity $ okMessage isCandidate ++
- if null warnings then "" else "\n" ++ formatWarnings (trim warnings)
- (code,err) -> do
- notice verbosity $ "Error uploading " ++ path ++ ": "
- ++ "http code " ++ show code ++ "\n"
- ++ err
- exitFailure
- where
- okMessage :: IsCandidate -> String
- okMessage IsCandidate =
- "Package successfully uploaded as candidate. "
- ++ "You can now preview the result at '" ++ show packageUri
- ++ "'. To publish the candidate, use 'cabal upload --publish'."
- okMessage IsPublished =
- "Package successfully published. You can now view it at '"
- ++ show packageUri ++ "'."
+ do
+ resp <- postHttpFile transport verbosity uri path auth
+ case resp of
+ (code, warnings)
+ | code `elem` [200, 204] ->
+ notice verbosity $
+ okMessage isCandidate
+ ++ if null warnings then "" else "\n" ++ formatWarnings (trim warnings)
+ (code, err) -> do
+ notice verbosity $
+ "Error uploading "
+ ++ path
+ ++ ": "
+ ++ "http code "
+ ++ show code
+ ++ "\n"
+ ++ err
+ exitFailure
+ where
+ okMessage :: IsCandidate -> String
+ okMessage IsCandidate =
+ "Package successfully uploaded as candidate. "
+ ++ "You can now preview the result at '"
+ ++ show packageUri
+ ++ "'. To publish the candidate, use 'cabal upload --publish'."
+ okMessage IsPublished =
+ "Package successfully published. You can now view it at '"
+ ++ show packageUri
+ ++ "'."
formatWarnings :: String -> String
formatWarnings x = "Warnings:\n" ++ (unlines . map ("- " ++) . lines) x
-
diff --git a/cabal-install/src/Distribution/Client/Utils.hs b/cabal-install/src/Distribution/Client/Utils.hs
index 20e68a2695bb66f15277a9e4a972620d26190b5e..f7a51bf8c494af702fa63f36e1411f5335e5371c 100644
--- a/cabal-install/src/Distribution/Client/Utils.hs
+++ b/cabal-install/src/Distribution/Client/Utils.hs
@@ -1,21 +1,31 @@
-{-# LANGUAGE ScopedTypeVariables, CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Client.Utils
- ( MergeResult(..)
- , mergeBy, duplicates, duplicatesBy
+ ( MergeResult (..)
+ , mergeBy
+ , duplicates
+ , duplicatesBy
, readMaybe
- , inDir, withEnv, withEnvOverrides
- , logDirChange, withExtraPathEnv
- , determineNumJobs, numberOfProcessors
+ , inDir
+ , withEnv
+ , withEnvOverrides
+ , logDirChange
+ , withExtraPathEnv
+ , determineNumJobs
+ , numberOfProcessors
, removeExistingFile
, withTempFileName
, makeAbsoluteToCwd
- , makeRelativeToCwd, makeRelativeToDir
+ , makeRelativeToCwd
+ , makeRelativeToDir
, makeRelativeCanonical
, filePathToByteString
- , byteStringToFilePath, tryCanonicalizePath
+ , byteStringToFilePath
+ , tryCanonicalizePath
, canonicalizePathNoThrow
- , moreRecentFile, existsAndIsMoreRecentThan
+ , moreRecentFile
+ , existsAndIsMoreRecentThan
, tryFindAddSourcePackageDesc
, tryFindPackageDesc
, findOpenProgramLocation
@@ -33,45 +43,67 @@ module Distribution.Client.Utils
, giveRTSWarning
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Compat.Environment
-import Distribution.Compat.Time ( getModTime )
-import Distribution.Simple.Setup ( Flag(..) )
-import Distribution.Version
-import Distribution.Simple.Utils ( die', findPackageDesc, noticeNoWrap )
-import Distribution.System ( Platform (..), OS(..))
-import qualified Data.ByteString.Lazy as BS
-import Data.Bits
- ( (.|.), shiftL, shiftR )
-import System.FilePath
-import Control.Monad
- ( zipWithM_ )
-import Data.List
- ( groupBy, elemIndex )
import qualified Control.Exception as Exception
- ( finally )
+ ( finally
+ )
import qualified Control.Exception.Safe as Safe
- ( bracket )
+ ( bracket
+ )
+import Control.Monad
+ ( zipWithM_
+ )
+import Data.Bits
+ ( shiftL
+ , shiftR
+ , (.|.)
+ )
+import qualified Data.ByteString.Lazy as BS
+import Data.List
+ ( elemIndex
+ , groupBy
+ )
+import Distribution.Compat.Environment
+import Distribution.Compat.Time (getModTime)
+import Distribution.Simple.Setup (Flag (..))
+import Distribution.Simple.Utils (die', findPackageDesc, noticeNoWrap)
+import Distribution.System (OS (..), Platform (..))
+import Distribution.Version
import System.Directory
- ( canonicalizePath, doesFileExist, findExecutable, getCurrentDirectory
- , removeFile, setCurrentDirectory, getDirectoryContents, doesDirectoryExist )
+ ( canonicalizePath
+ , doesDirectoryExist
+ , doesFileExist
+ , findExecutable
+ , getCurrentDirectory
+ , getDirectoryContents
+ , removeFile
+ , setCurrentDirectory
+ )
+import System.FilePath
import System.IO
- ( Handle, hClose, openTempFile
- , hGetEncoding, hSetEncoding
- )
-import System.IO.Unsafe ( unsafePerformIO )
+ ( Handle
+ , hClose
+ , hGetEncoding
+ , hSetEncoding
+ , openTempFile
+ )
+import System.IO.Unsafe (unsafePerformIO)
-import GHC.Conc.Sync ( getNumProcessors )
-import GHC.IO.Encoding
- ( recover, TextEncoding(TextEncoding) )
-import GHC.IO.Encoding.Failure
- ( recoverEncode, CodingFailureMode(TransliterateCodingFailure) )
-import Data.Time.Clock.POSIX (getCurrentTime)
-import Data.Time.LocalTime (getCurrentTimeZone, localDay)
import Data.Time (utcToLocalTime)
import Data.Time.Calendar (toGregorian)
+import Data.Time.Clock.POSIX (getCurrentTime)
+import Data.Time.LocalTime (getCurrentTimeZone, localDay)
+import GHC.Conc.Sync (getNumProcessors)
+import GHC.IO.Encoding
+ ( TextEncoding (TextEncoding)
+ , recover
+ )
+import GHC.IO.Encoding.Failure
+ ( CodingFailureMode (TransliterateCodingFailure)
+ , recoverEncode
+ )
#if defined(mingw32_HOST_OS) || MIN_VERSION_directory(1,2,3)
import qualified System.Directory as Dir
import qualified System.IO.Error as IOError
@@ -79,18 +111,17 @@ import qualified System.IO.Error as IOError
import qualified Data.Set as Set
-- | Generic merging utility. For sorted input lists this is a full outer join.
---
mergeBy :: forall a b. (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]
mergeBy cmp = merge
where
- merge :: [a] -> [b] -> [MergeResult a b]
- merge [] ys = [ OnlyInRight y | y <- ys]
- merge xs [] = [ OnlyInLeft x | x <- xs]
- merge (x:xs) (y:ys) =
+ merge :: [a] -> [b] -> [MergeResult a b]
+ merge [] ys = [OnlyInRight y | y <- ys]
+ merge xs [] = [OnlyInLeft x | x <- xs]
+ merge (x : xs) (y : ys) =
case x `cmp` y of
- GT -> OnlyInRight y : merge (x:xs) ys
- EQ -> InBoth x y : merge xs ys
- LT -> OnlyInLeft x : merge xs (y:ys)
+ GT -> OnlyInRight y : merge (x : xs) ys
+ EQ -> InBoth x y : merge xs ys
+ LT -> OnlyInLeft x : merge xs (y : ys)
data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b
@@ -102,10 +133,10 @@ duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp
where
eq :: a -> a -> Bool
eq a b = case cmp a b of
- EQ -> True
- _ -> False
- moreThanOne (_:_:_) = True
- moreThanOne _ = False
+ EQ -> True
+ _ -> False
+ moreThanOne (_ : _ : _) = True
+ moreThanOne _ = False
-- | Like 'removeFile', but does not throw an exception when the file does not
-- exist.
@@ -118,10 +149,11 @@ removeExistingFile path = do
-- | A variant of 'withTempFile' that only gives us the file name, and while
-- it will clean up the file afterwards, it's lenient if the file is
-- moved\/deleted.
---
-withTempFileName :: FilePath
- -> String
- -> (FilePath -> IO a) -> IO a
+withTempFileName
+ :: FilePath
+ -> String
+ -> (FilePath -> IO a)
+ -> IO a
withTempFileName tmpDir template action =
Safe.bracket
(openTempFile tmpDir template)
@@ -163,12 +195,12 @@ withEnvOverrides overrides m = do
mb_olds <- traverse lookupEnv envVars
traverse_ (uncurry setOrUnsetEnv) overrides
m `Exception.finally` zipWithM_ setOrUnsetEnv envVars mb_olds
- where
+ where
envVars :: [String]
envVars = map fst overrides
setOrUnsetEnv :: String -> Maybe String -> IO ()
-setOrUnsetEnv var Nothing = unsetEnv var
+setOrUnsetEnv var Nothing = unsetEnv var
setOrUnsetEnv var (Just val) = setEnv var val
-- | Executes the action, increasing the PATH environment
@@ -185,8 +217,9 @@ withExtraPathEnv paths m = do
oldPath = mungePath $ intercalate [searchPathSeparator] oldPathSplit
-- TODO: This is a horrible hack to work around the fact that
-- setEnv can't take empty values as an argument
- mungePath p | p == "" = "/dev/null"
- | otherwise = p
+ mungePath p
+ | p == "" = "/dev/null"
+ | otherwise = p
setEnv "PATH" newPath
m `Exception.finally` setEnv "PATH" oldPath
@@ -195,8 +228,8 @@ logDirChange :: (String -> IO ()) -> Maybe FilePath -> IO a -> IO a
logDirChange _ Nothing m = m
logDirChange l (Just d) m = do
l $ "cabal: Entering directory '" ++ d ++ "'\n"
- m `Exception.finally`
- (l $ "cabal: Leaving directory '" ++ d ++ "'\n")
+ m
+ `Exception.finally` (l $ "cabal: Leaving directory '" ++ d ++ "'\n")
-- The number of processors is not going to change during the duration of the
-- program, so unsafePerformIO is safe here.
@@ -207,28 +240,30 @@ numberOfProcessors = unsafePerformIO getNumProcessors
determineNumJobs :: Flag (Maybe Int) -> Int
determineNumJobs numJobsFlag =
case numJobsFlag of
- NoFlag -> 1
- Flag Nothing -> numberOfProcessors
+ NoFlag -> 1
+ Flag Nothing -> numberOfProcessors
Flag (Just n) -> n
-- | Given a relative path, make it absolute relative to the current
-- directory. Absolute paths are returned unmodified.
makeAbsoluteToCwd :: FilePath -> IO FilePath
-makeAbsoluteToCwd path | isAbsolute path = return path
- | otherwise = do cwd <- getCurrentDirectory
- return $! cwd </> path
+makeAbsoluteToCwd path
+ | isAbsolute path = return path
+ | otherwise = do
+ cwd <- getCurrentDirectory
+ return $! cwd </> path
-- | Given a path (relative or absolute), make it relative to the current
-- directory, including using @../..@ if necessary.
makeRelativeToCwd :: FilePath -> IO FilePath
makeRelativeToCwd path =
- makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory
+ makeRelativeCanonical <$> canonicalizePath path <*> getCurrentDirectory
-- | Given a path (relative or absolute), make it relative to the given
-- directory, including using @../..@ if necessary.
makeRelativeToDir :: FilePath -> FilePath -> IO FilePath
makeRelativeToDir path dir =
- makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir
+ makeRelativeCanonical <$> canonicalizePath path <*> canonicalizePath dir
-- | Given a canonical absolute path and canonical absolute dir, make the path
-- relative to the directory, including using @../..@ if necessary. Returns
@@ -236,12 +271,13 @@ makeRelativeToDir path dir =
makeRelativeCanonical :: FilePath -> FilePath -> FilePath
makeRelativeCanonical path dir
| takeDrive path /= takeDrive dir = path
- | otherwise = go (splitPath path) (splitPath dir)
+ | otherwise = go (splitPath path) (splitPath dir)
where
- go (p:ps) (d:ds) | p' == d' = go ps ds
- where (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d)
- go [] [] = "./"
- go ps ds = joinPath (replicate (length ds) ".." ++ ps)
+ go (p : ps) (d : ds) | p' == d' = go ps ds
+ where
+ (p', d') = (dropTrailingPathSeparator p, dropTrailingPathSeparator d)
+ go [] [] = "./"
+ go ps ds = joinPath (replicate (length ds) ".." ++ ps)
-- | Convert a 'FilePath' to a lazy 'ByteString'. Each 'Char' is
-- encoded as a little-endian 'Word32'.
@@ -253,7 +289,7 @@ filePathToByteString p =
codepts = map (fromIntegral . ord) p
conv :: Word32 -> [Word8] -> [Word8]
- conv w32 rest = b0:b1:b2:b3:rest
+ conv w32 rest = b0 : b1 : b2 : b3 : rest
where
b0 = fromIntegral $ w32
b1 = fromIntegral $ w32 `shiftR` 8
@@ -262,14 +298,16 @@ filePathToByteString p =
-- | Reverse operation to 'filePathToByteString'.
byteStringToFilePath :: BS.ByteString -> FilePath
-byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected
- | otherwise = go 0
+byteStringToFilePath bs
+ | bslen `mod` 4 /= 0 = unexpected
+ | otherwise = go 0
where
unexpected = "Distribution.Client.Utils.byteStringToFilePath: unexpected"
bslen = BS.length bs
- go i | i == bslen = []
- | otherwise = (chr . fromIntegral $ w32) : go (i+4)
+ go i
+ | i == bslen = []
+ | otherwise = (chr . fromIntegral $ w32) : go (i + 4)
where
w32 :: Word32
w32 = b0 .|. (b1 `shiftL` 8) .|. (b2 `shiftL` 16) .|. (b3 `shiftL` 24)
@@ -280,6 +318,7 @@ byteStringToFilePath bs | bslen `mod` 4 /= 0 = unexpected
-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. Always
-- throws an error if the path refers to a non-existent file.
+{- FOURMOLU_DISABLE -}
tryCanonicalizePath :: FilePath -> IO FilePath
tryCanonicalizePath path = do
ret <- canonicalizePath path
@@ -290,6 +329,7 @@ tryCanonicalizePath path = do
Nothing (Just ret)
#endif
return ret
+{- FOURMOLU_ENABLE -}
-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
-- an exception, returns the path argument unmodified.
@@ -308,9 +348,10 @@ moreRecentFile a b = do
exists <- doesFileExist b
if not exists
then return True
- else do tb <- getModTime b
- ta <- getModTime a
- return (ta > tb)
+ else do
+ tb <- getModTime b
+ ta <- getModTime a
+ return (ta > tb)
-- | Like 'moreRecentFile', but also checks that the first file exists.
existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool
@@ -329,27 +370,31 @@ relaxEncodingErrors :: Handle -> IO ()
relaxEncodingErrors handle = do
maybeEncoding <- hGetEncoding handle
case maybeEncoding of
- Just (TextEncoding name decoder encoder) | not ("UTF" `isPrefixOf` name) ->
- let relax x = x { recover = recoverEncode TransliterateCodingFailure }
- in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))
+ Just (TextEncoding name decoder encoder)
+ | not ("UTF" `isPrefixOf` name) ->
+ let relax x = x{recover = recoverEncode TransliterateCodingFailure}
+ in hSetEncoding handle (TextEncoding name decoder (fmap relax encoder))
_ ->
return ()
--- |Like 'tryFindPackageDesc', but with error specific to add-source deps.
+-- | Like 'tryFindPackageDesc', but with error specific to add-source deps.
tryFindAddSourcePackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
-tryFindAddSourcePackageDesc verbosity depPath err = tryFindPackageDesc verbosity depPath $
- err ++ "\n" ++ "Failed to read cabal file of add-source dependency: "
- ++ depPath
-
--- |Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be
--- found, with @err@ prefixing the error message. This function simply allows
--- us to give a more descriptive error than that provided by @findPackageDesc@.
+tryFindAddSourcePackageDesc verbosity depPath err =
+ tryFindPackageDesc verbosity depPath $
+ err
+ ++ "\n"
+ ++ "Failed to read cabal file of add-source dependency: "
+ ++ depPath
+
+-- | Try to find a @.cabal@ file, in directory @depPath@. Fails if one cannot be
+-- found, with @err@ prefixing the error message. This function simply allows
+-- us to give a more descriptive error than that provided by @findPackageDesc@.
tryFindPackageDesc :: Verbosity -> FilePath -> String -> IO FilePath
tryFindPackageDesc verbosity depPath err = do
- errOrCabalFile <- findPackageDesc depPath
- case errOrCabalFile of
- Right file -> return file
- Left _ -> die' verbosity err
+ errOrCabalFile <- findPackageDesc depPath
+ case errOrCabalFile of
+ Right file -> return file
+ Left _ -> die' verbosity err
findOpenProgramLocation :: Platform -> IO (Either String FilePath)
findOpenProgramLocation (Platform _ os) =
@@ -360,41 +405,40 @@ findOpenProgramLocation (Platform _ os) =
Just s -> pure (Right s)
Nothing -> pure (Left ("Couldn't find file-opener program `" <> name <> "`"))
xdg = locate "xdg-open"
- in case os of
- Windows -> pure (Right "start")
- OSX -> locate "open"
- Linux -> xdg
- FreeBSD -> xdg
- OpenBSD -> xdg
- NetBSD -> xdg
- DragonFly -> xdg
- _ -> pure (Left ("Couldn't determine file-opener program for " <> show os))
-
+ in
+ case os of
+ Windows -> pure (Right "start")
+ OSX -> locate "open"
+ Linux -> xdg
+ FreeBSD -> xdg
+ OpenBSD -> xdg
+ NetBSD -> xdg
+ DragonFly -> xdg
+ _ -> pure (Left ("Couldn't determine file-opener program for " <> show os))
-- | Phase of building a dependency. Represents current status of package
-- dependency processing. See #4040 for details.
data ProgressPhase
- = ProgressDownloading
- | ProgressDownloaded
- | ProgressStarting
- | ProgressBuilding
- | ProgressHaddock
- | ProgressInstalling
- | ProgressCompleted
+ = ProgressDownloading
+ | ProgressDownloaded
+ | ProgressStarting
+ | ProgressBuilding
+ | ProgressHaddock
+ | ProgressInstalling
+ | ProgressCompleted
progressMessage :: Verbosity -> ProgressPhase -> String -> IO ()
progressMessage verbosity phase subject = do
- noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n"
+ noticeNoWrap verbosity $ phaseStr ++ subject ++ "\n"
where
phaseStr = case phase of
- ProgressDownloading -> "Downloading "
- ProgressDownloaded -> "Downloaded "
- ProgressStarting -> "Starting "
- ProgressBuilding -> "Building "
- ProgressHaddock -> "Haddock "
- ProgressInstalling -> "Installing "
- ProgressCompleted -> "Completed "
-
+ ProgressDownloading -> "Downloading "
+ ProgressDownloaded -> "Downloaded "
+ ProgressStarting -> "Starting "
+ ProgressBuilding -> "Building "
+ ProgressHaddock -> "Haddock "
+ ProgressInstalling -> "Installing "
+ ProgressCompleted -> "Completed "
-- | Given a version, return an API-compatible (according to PVP) version range.
--
@@ -405,20 +449,21 @@ progressMessage verbosity phase subject = do
-- Example: @pvpize True (mkVersion [0,4,1])@ produces the version range @>= 0.4 && < 0.5@ (which is the
-- same as @0.4.*@).
pvpize :: Bool -> Version -> VersionRange
-pvpize False v = majorBoundVersion v
-pvpize True v = orLaterVersion v'
- `intersectVersionRanges`
- earlierVersion (incVersion 1 v')
- where v' = alterVersion (take 2) v
+pvpize False v = majorBoundVersion v
+pvpize True v =
+ orLaterVersion v'
+ `intersectVersionRanges` earlierVersion (incVersion 1 v')
+ where
+ v' = alterVersion (take 2) v
-- | Increment the nth version component (counting from 0).
incVersion :: Int -> Version -> Version
incVersion n = alterVersion (incVersion' n)
where
- incVersion' 0 [] = [1]
- incVersion' 0 (v:_) = [v+1]
- incVersion' m [] = replicate m 0 ++ [1]
- incVersion' m (v:vs) = v : incVersion' (m-1) vs
+ incVersion' 0 [] = [1]
+ incVersion' 0 (v : _) = [v + 1]
+ incVersion' m [] = replicate m 0 ++ [1]
+ incVersion' m (v : vs) = v : incVersion' (m - 1) vs
-- | Returns the current calendar year.
getCurrentYear :: IO Integer
@@ -433,9 +478,9 @@ getCurrentYear = do
-- https://hackage.haskell.org/package/extra-1.7.9
listFilesInside :: (FilePath -> IO Bool) -> FilePath -> IO [FilePath]
listFilesInside test dir = ifNotM (test $ dropTrailingPathSeparator dir) (pure []) $ do
- (dirs,files) <- partitionM doesDirectoryExist =<< listContents dir
- rest <- concatMapM (listFilesInside test) dirs
- pure $ files ++ rest
+ (dirs, files) <- partitionM doesDirectoryExist =<< listContents dir
+ rest <- concatMapM (listFilesInside test) dirs
+ pure $ files ++ rest
-- | From System.Directory.Extra
-- https://hackage.haskell.org/package/extra-1.7.9
@@ -446,8 +491,8 @@ listFilesRecursive = listFilesInside (const $ pure True)
-- https://hackage.haskell.org/package/extra-1.7.9
listContents :: FilePath -> IO [FilePath]
listContents dir = do
- xs <- getDirectoryContents dir
- pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]
+ xs <- getDirectoryContents dir
+ pure $ sort [dir </> x | x <- xs, not $ all (== '.') x]
-- | From Control.Monad.Extra
-- https://hackage.haskell.org/package/extra-1.7.9
@@ -464,16 +509,17 @@ ifNotM = flip . ifM
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
{-# INLINE concatMapM #-}
concatMapM op = foldr f (pure [])
- where f x xs = do x' <- op x; if null x' then xs else do xs' <- xs; pure $ x' ++ xs'
+ where
+ f x xs = do x' <- op x; if null x' then xs else do { xs' <- xs; pure $ x' ++ xs' }
-- | From Control.Monad.Extra
-- https://hackage.haskell.org/package/extra-1.7.9
partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])
partitionM _ [] = pure ([], [])
-partitionM f (x:xs) = do
- res <- f x
- (as,bs) <- partitionM f xs
- pure ([x | res]++as, [x | not res]++bs)
+partitionM f (x : xs) = do
+ res <- f x
+ (as, bs) <- partitionM f xs
+ pure ([x | res] ++ as, [x | not res] ++ bs)
safeRead :: Read a => String -> Maybe a
safeRead s
@@ -492,28 +538,32 @@ hasElem :: Ord a => [a] -> a -> Bool
hasElem xs = (`Set.member` Set.fromList xs)
-- True if x occurs before y
-occursOnlyOrBefore :: (Eq a) => [a] -> a -> a -> Bool
+occursOnlyOrBefore :: Eq a => [a] -> a -> a -> Bool
occursOnlyOrBefore xs x y = case (elemIndex x xs, elemIndex y xs) of
- (Just i, Just j) -> i < j
- (Just _, _) -> True
- _ -> False
+ (Just i, Just j) -> i < j
+ (Just _, _) -> True
+ _ -> False
giveRTSWarning :: String -> String
-giveRTSWarning "run" = "Your RTS options are applied to cabal, not the "
- ++ "executable. Use '--' to separate cabal options from your "
- ++ "executable options. For example, use 'cabal run -- +RTS -N "
- ++ "to pass the '-N' RTS option to your executable."
-giveRTSWarning "test" = "Some RTS options were found standalone, "
- ++ "which affect cabal and not the binary. "
- ++ "Please note that +RTS inside the --test-options argument "
- ++ "suffices if your goal is to affect the tested binary. "
- ++ "For example, use \"cabal test --test-options='+RTS -N'\" "
- ++ "to pass the '-N' RTS option to your binary."
-giveRTSWarning "bench" = "Some RTS options were found standalone, "
- ++ "which affect cabal and not the binary. Please note "
- ++ "that +RTS inside the --benchmark-options argument "
- ++ "suffices if your goal is to affect the benchmarked "
- ++ "binary. For example, use \"cabal test --benchmark-options="
- ++ "'+RTS -N'\" to pass the '-N' RTS option to your binary."
-giveRTSWarning _ = "Your RTS options are applied to cabal, not the "
- ++ "binary."
+giveRTSWarning "run" =
+ "Your RTS options are applied to cabal, not the "
+ ++ "executable. Use '--' to separate cabal options from your "
+ ++ "executable options. For example, use 'cabal run -- +RTS -N "
+ ++ "to pass the '-N' RTS option to your executable."
+giveRTSWarning "test" =
+ "Some RTS options were found standalone, "
+ ++ "which affect cabal and not the binary. "
+ ++ "Please note that +RTS inside the --test-options argument "
+ ++ "suffices if your goal is to affect the tested binary. "
+ ++ "For example, use \"cabal test --test-options='+RTS -N'\" "
+ ++ "to pass the '-N' RTS option to your binary."
+giveRTSWarning "bench" =
+ "Some RTS options were found standalone, "
+ ++ "which affect cabal and not the binary. Please note "
+ ++ "that +RTS inside the --benchmark-options argument "
+ ++ "suffices if your goal is to affect the benchmarked "
+ ++ "binary. For example, use \"cabal test --benchmark-options="
+ ++ "'+RTS -N'\" to pass the '-N' RTS option to your binary."
+giveRTSWarning _ =
+ "Your RTS options are applied to cabal, not the "
+ ++ "binary."
diff --git a/cabal-install/src/Distribution/Client/Utils/Json.hs b/cabal-install/src/Distribution/Client/Utils/Json.hs
index 01d5753136b2822794a6a6622c4b64a9992e648c..ebbf2bb27fd5d58cfc6c2237bbbfdae424a6cc0f 100644
--- a/cabal-install/src/Distribution/Client/Utils/Json.hs
+++ b/cabal-install/src/Distribution/Client/Utils/Json.hs
@@ -5,15 +5,17 @@
-- The API is heavily inspired by @aeson@'s API but puts emphasis on
-- simplicity rather than performance. The 'ToJSON' instances are
-- intended to have an encoding compatible with @aeson@'s encoding.
---
module Distribution.Client.Utils.Json
- ( Value(..)
- , Object, object, Pair, (.=)
- , encodeToString
- , encodeToBuilder
- , ToJSON(toJSON)
- )
- where
+ ( Value (..)
+ , Object
+ , object
+ , Pair
+ , (.=)
+ , encodeToString
+ , encodeToBuilder
+ , ToJSON (toJSON)
+ )
+where
import Distribution.Client.Compat.Prelude
@@ -25,13 +27,14 @@ import qualified Data.ByteString.Builder as BB
-- TODO: We may want to replace 'String' with 'Text' or 'ByteString'
-- | A JSON value represented as a Haskell value.
-data Value = Object !Object
- | Array [Value]
- | String String
- | Number !Double
- | Bool !Bool
- | Null
- deriving (Eq, Read, Show)
+data Value
+ = Object !Object
+ | Array [Value]
+ | String String
+ | Number !Double
+ | Bool !Bool
+ | Null
+ deriving (Eq, Read, Show)
-- | A key\/value pair for an 'Object'
type Pair = (String, Value)
@@ -43,7 +46,7 @@ infixr 8 .=
-- | A key-value pair for encoding a JSON object.
(.=) :: ToJSON v => String -> v -> Pair
-k .= v = (k, toJSON v)
+k .= v = (k, toJSON v)
-- | Create a 'Value' from a list of name\/value 'Pair's.
object :: [Pair] -> Value
@@ -52,7 +55,6 @@ object = Object
instance IsString Value where
fromString = String
-
-- | A type that can be converted to JSON.
class ToJSON a where
-- | Convert a Haskell value to a JSON-friendly intermediate type.
@@ -71,17 +73,17 @@ instance ToJSON a => ToJSON [a] where
toJSON = Array . map toJSON
instance ToJSON a => ToJSON (Maybe a) where
- toJSON Nothing = Null
+ toJSON Nothing = Null
toJSON (Just a) = toJSON a
-instance (ToJSON a,ToJSON b) => ToJSON (a,b) where
- toJSON (a,b) = Array [toJSON a, toJSON b]
+instance (ToJSON a, ToJSON b) => ToJSON (a, b) where
+ toJSON (a, b) = Array [toJSON a, toJSON b]
-instance (ToJSON a,ToJSON b,ToJSON c) => ToJSON (a,b,c) where
- toJSON (a,b,c) = Array [toJSON a, toJSON b, toJSON c]
+instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where
+ toJSON (a, b, c) = Array [toJSON a, toJSON b, toJSON c]
-instance (ToJSON a,ToJSON b,ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
- toJSON (a,b,c,d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
+instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where
+ toJSON (a, b, c, d) = Array [toJSON a, toJSON b, toJSON c, toJSON d]
instance ToJSON Float where
toJSON = Number . realToFrac
@@ -89,21 +91,21 @@ instance ToJSON Float where
instance ToJSON Double where
toJSON = Number
-instance ToJSON Int where toJSON = Number . realToFrac
-instance ToJSON Int8 where toJSON = Number . realToFrac
-instance ToJSON Int16 where toJSON = Number . realToFrac
-instance ToJSON Int32 where toJSON = Number . realToFrac
+instance ToJSON Int where toJSON = Number . realToFrac
+instance ToJSON Int8 where toJSON = Number . realToFrac
+instance ToJSON Int16 where toJSON = Number . realToFrac
+instance ToJSON Int32 where toJSON = Number . realToFrac
-instance ToJSON Word where toJSON = Number . realToFrac
-instance ToJSON Word8 where toJSON = Number . realToFrac
-instance ToJSON Word16 where toJSON = Number . realToFrac
-instance ToJSON Word32 where toJSON = Number . realToFrac
+instance ToJSON Word where toJSON = Number . realToFrac
+instance ToJSON Word8 where toJSON = Number . realToFrac
+instance ToJSON Word16 where toJSON = Number . realToFrac
+instance ToJSON Word32 where toJSON = Number . realToFrac
-- | Possibly lossy due to conversion to 'Double'
-instance ToJSON Int64 where toJSON = Number . realToFrac
+instance ToJSON Int64 where toJSON = Number . realToFrac
-- | Possibly lossy due to conversion to 'Double'
-instance ToJSON Word64 where toJSON = Number . realToFrac
+instance ToJSON Word64 where toJSON = Number . realToFrac
-- | Possibly lossy due to conversion to 'Double'
instance ToJSON Integer where toJSON = Number . fromInteger
@@ -117,14 +119,14 @@ encodeToBuilder = encodeValueBB . toJSON
encodeValueBB :: Value -> Builder
encodeValueBB jv = case jv of
- Bool True -> "true"
+ Bool True -> "true"
Bool False -> "false"
- Null -> "null"
+ Null -> "null"
Number n
- | isNaN n || isInfinite n -> encodeValueBB Null
+ | isNaN n || isInfinite n -> encodeValueBB Null
| Just i <- doubleToInt64 n -> BB.int64Dec i
- | otherwise -> BB.doubleDec n
- Array a -> encodeArrayBB a
+ | otherwise -> BB.doubleDec n
+ Array a -> encodeArrayBB a
String s -> encodeStringBB s
Object o -> encodeObjectBB o
@@ -139,7 +141,7 @@ encodeObjectBB [] = "{}"
encodeObjectBB jvs = BB.char8 '{' <> go jvs <> BB.char8 '}'
where
go = mconcat . intersperse (BB.char8 ',') . map encPair
- encPair (l,x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
+ encPair (l, x) = encodeStringBB l <> BB.char8 ':' <> encodeValueBB x
encodeStringBB :: String -> Builder
encodeStringBB str = BB.char8 '"' <> go str <> BB.char8 '"'
@@ -155,34 +157,34 @@ encodeToString jv = encodeValue (toJSON jv) []
encodeValue :: Value -> ShowS
encodeValue jv = case jv of
- Bool b -> showString (if b then "true" else "false")
- Null -> showString "null"
+ Bool b -> showString (if b then "true" else "false")
+ Null -> showString "null"
Number n
- | isNaN n || isInfinite n -> encodeValue Null
+ | isNaN n || isInfinite n -> encodeValue Null
| Just i <- doubleToInt64 n -> shows i
- | otherwise -> shows n
+ | otherwise -> shows n
Array a -> encodeArray a
String s -> encodeString s
Object o -> encodeObject o
encodeArray :: [Value] -> ShowS
encodeArray [] = showString "[]"
-encodeArray jvs = ('[':) . go jvs . (']':)
+encodeArray jvs = ('[' :) . go jvs . (']' :)
where
- go [] = id
- go [x] = encodeValue x
- go (x:xs) = encodeValue x . (',':) . go xs
+ go [] = id
+ go [x] = encodeValue x
+ go (x : xs) = encodeValue x . (',' :) . go xs
encodeObject :: Object -> ShowS
encodeObject [] = showString "{}"
-encodeObject jvs = ('{':) . go jvs . ('}':)
+encodeObject jvs = ('{' :) . go jvs . ('}' :)
where
- go [] = id
- go [(l,x)] = encodeString l . (':':) . encodeValue x
- go ((l,x):lxs) = encodeString l . (':':) . encodeValue x . (',':) . go lxs
+ go [] = id
+ go [(l, x)] = encodeString l . (':' :) . encodeValue x
+ go ((l, x) : lxs) = encodeString l . (':' :) . encodeValue x . (',' :) . go lxs
encodeString :: String -> ShowS
-encodeString str = ('"':) . showString (escapeString str) . ('"':)
+encodeString str = ('"' :) . showString (escapeString str) . ('"' :)
------------------------------------------------------------------------------
-- helpers
@@ -193,8 +195,8 @@ doubleToInt64 :: Double -> Maybe Int64
doubleToInt64 x
| fromInteger x' == x
, x' <= toInteger (maxBound :: Int64)
- , x' >= toInteger (minBound :: Int64)
- = Just (fromIntegral x')
+ , x' >= toInteger (minBound :: Int64) =
+ Just (fromIntegral x')
| otherwise = Nothing
where
x' = round x
@@ -203,20 +205,21 @@ doubleToInt64 x
escapeString :: String -> String
escapeString s
| not (any needsEscape s) = s
- | otherwise = escape s
+ | otherwise = escape s
where
escape [] = []
- escape (x:xs) = case x of
- '\\' -> '\\':'\\':escape xs
- '"' -> '\\':'"':escape xs
- '\b' -> '\\':'b':escape xs
- '\f' -> '\\':'f':escape xs
- '\n' -> '\\':'n':escape xs
- '\r' -> '\\':'r':escape xs
- '\t' -> '\\':'t':escape xs
- c | ord c < 0x10 -> '\\':'u':'0':'0':'0':intToDigit (ord c):escape xs
- | ord c < 0x20 -> '\\':'u':'0':'0':'1':intToDigit (ord c - 0x10):escape xs
- | otherwise -> c : escape xs
+ escape (x : xs) = case x of
+ '\\' -> '\\' : '\\' : escape xs
+ '"' -> '\\' : '"' : escape xs
+ '\b' -> '\\' : 'b' : escape xs
+ '\f' -> '\\' : 'f' : escape xs
+ '\n' -> '\\' : 'n' : escape xs
+ '\r' -> '\\' : 'r' : escape xs
+ '\t' -> '\\' : 't' : escape xs
+ c
+ | ord c < 0x10 -> '\\' : 'u' : '0' : '0' : '0' : intToDigit (ord c) : escape xs
+ | ord c < 0x20 -> '\\' : 'u' : '0' : '0' : '1' : intToDigit (ord c - 0x10) : escape xs
+ | otherwise -> c : escape xs
-- unescaped = %x20-21 / %x23-5B / %x5D-10FFFF
- needsEscape c = ord c < 0x20 || c `elem` ['\\','"']
+ needsEscape c = ord c < 0x20 || c `elem` ['\\', '"']
diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs
index b0afe8f57671166eb49659856bb59544631b1e12..abc9ddd132139f3498d9612a7caee816c59b1a14 100644
--- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs
+++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs
@@ -1,64 +1,66 @@
-module Distribution.Client.Utils.Parsec (
- renderParseError,
- ) where
+module Distribution.Client.Utils.Parsec
+ ( renderParseError
+ ) where
import Distribution.Client.Compat.Prelude
+import System.FilePath (normalise)
import Prelude ()
-import System.FilePath (normalise)
-import qualified Data.ByteString as BS
+import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
-import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos)
+import Distribution.Parsec (PError (..), PWarning (..), Position (..), showPos, zeroPos)
import Distribution.Simple.Utils (fromUTF8BS)
-- | Render parse error highlighting the part of the input file.
renderParseError
- :: FilePath
- -> BS.ByteString
- -> NonEmpty PError
- -> [PWarning]
- -> String
-renderParseError filepath contents errors warnings = unlines $
+ :: FilePath
+ -> BS.ByteString
+ -> NonEmpty PError
+ -> [PWarning]
+ -> String
+renderParseError filepath contents errors warnings =
+ unlines $
[ "Errors encountered when parsing cabal file " <> filepath <> ":"
]
- ++ renderedErrors
- ++ renderedWarnings
+ ++ renderedErrors
+ ++ renderedWarnings
where
filepath' = normalise filepath
-- lines of the input file. 'lines' is taken, so they are called rows
-- contents, line number, whether it's empty line
rows :: [(String, Int, Bool)]
- rows = zipWith f (BS8.lines contents) [1..] where
+ rows = zipWith f (BS8.lines contents) [1 ..]
+ where
f bs i = let s = fromUTF8BS bs in (s, i, isEmptyOrComment s)
rowsZipper = listToZipper rows
isEmptyOrComment :: String -> Bool
isEmptyOrComment s = case dropWhile (== ' ') s of
- "" -> True -- empty
- ('-':'-':_) -> True -- comment
- _ -> False
+ "" -> True -- empty
+ ('-' : '-' : _) -> True -- comment
+ _ -> False
- renderedErrors = concatMap renderError errors
+ renderedErrors = concatMap renderError errors
renderedWarnings = concatMap renderWarning warnings
renderError :: PError -> [String]
renderError (PError pos@(Position row col) msg)
- -- if position is 0:0, then it doesn't make sense to show input
- -- looks like, Parsec errors have line-feed in them
- | pos == zeroPos = msgs
- | otherwise = msgs ++ formatInput row col
+ -- if position is 0:0, then it doesn't make sense to show input
+ -- looks like, Parsec errors have line-feed in them
+ | pos == zeroPos = msgs
+ | otherwise = msgs ++ formatInput row col
where
- msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, "" ]
+ msgs = ["", filepath' ++ ":" ++ showPos pos ++ ": error:", trimLF msg, ""]
renderWarning :: PWarning -> [String]
renderWarning (PWarning _ pos@(Position row col) msg)
- | pos == zeroPos = msgs
- | otherwise = msgs ++ formatInput row col
+ | pos == zeroPos = msgs
+ | otherwise = msgs ++ formatInput row col
where
- msgs = [ "", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, "" ]
+ msgs = ["", filepath' ++ ":" ++ showPos pos ++ ": warning:", trimLF msg, ""]
-- sometimes there are (especially trailing) newlines.
trimLF :: String -> String
@@ -67,19 +69,20 @@ renderParseError filepath contents errors warnings = unlines $
-- format line: prepend the given line number
formatInput :: Int -> Int -> [String]
formatInput row col = case advance (row - 1) rowsZipper of
- Zipper xs ys -> before ++ after where
- before = case span (\(_, _, b) -> b) xs of
- (_, []) -> []
- (zs, z : _) -> map formatInputLine $ z : reverse zs
-
- after = case ys of
- [] -> []
- (z : _zs) ->
- [ formatInputLine z -- error line
- , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^
- ]
- -- do we need rows after?
- -- ++ map formatInputLine (take 1 zs) -- one row after
+ Zipper xs ys -> before ++ after
+ where
+ before = case span (\(_, _, b) -> b) xs of
+ (_, []) -> []
+ (zs, z : _) -> map formatInputLine $ z : reverse zs
+
+ after = case ys of
+ [] -> []
+ (z : _zs) ->
+ [ formatInputLine z -- error line
+ , " | " ++ replicate (col - 1) ' ' ++ "^" -- pointer: ^
+ ]
+ -- do we need rows after?
+ -- ++ map formatInputLine (take 1 zs) -- one row after
formatInputLine :: (String, Int, Bool) -> String
formatInputLine (str, row, _) = leftPadShow row ++ " | " ++ str
@@ -96,7 +99,7 @@ listToZipper = Zipper []
advance :: Int -> Zipper a -> Zipper a
advance n z@(Zipper xs ys)
- | n <= 0 = z
- | otherwise = case ys of
- [] -> z
- (y:ys') -> advance (n - 1) $ Zipper (y:xs) ys'
+ | n <= 0 = z
+ | otherwise = case ys of
+ [] -> z
+ (y : ys') -> advance (n - 1) $ Zipper (y : xs) ys'
diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs
index aca3f4b109f4023d7815ebb0bbfdf7fd395e7977..7322253e692ddf6a0eb51ee7fcfa70db80cf4495 100644
--- a/cabal-install/src/Distribution/Client/VCS.hs
+++ b/cabal-install/src/Distribution/Client/VCS.hs
@@ -1,58 +1,76 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-}
-module Distribution.Client.VCS (
- -- * VCS driver type
- VCS,
- vcsRepoType,
- vcsProgram,
+
+module Distribution.Client.VCS
+ ( -- * VCS driver type
+ VCS
+ , vcsRepoType
+ , vcsProgram
+
-- ** Type re-exports
- RepoType,
- Program,
- ConfiguredProgram,
+ , RepoType
+ , Program
+ , ConfiguredProgram
-- * Validating 'SourceRepo's and configuring VCS drivers
- validatePDSourceRepo,
- validateSourceRepo,
- validateSourceRepos,
- SourceRepoProblem(..),
- configureVCS,
- configureVCSs,
+ , validatePDSourceRepo
+ , validateSourceRepo
+ , validateSourceRepos
+ , SourceRepoProblem (..)
+ , configureVCS
+ , configureVCSs
-- * Running the VCS driver
- cloneSourceRepo,
- syncSourceRepos,
+ , cloneSourceRepo
+ , syncSourceRepos
-- * The individual VCS drivers
- knownVCSs,
- vcsBzr,
- vcsDarcs,
- vcsGit,
- vcsHg,
- vcsSvn,
- vcsPijul,
+ , knownVCSs
+ , vcsBzr
+ , vcsDarcs
+ , vcsGit
+ , vcsHg
+ , vcsSvn
+ , vcsPijul
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Distribution.Types.SourceRepo
- ( RepoType(..), KnownRepoType (..) )
-import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
import Distribution.Client.RebuildMonad
- ( Rebuild, monitorFiles, MonitorFilePath, monitorDirectoryExistence )
-import Distribution.Verbosity as Verbosity
- ( normal )
+ ( MonitorFilePath
+ , Rebuild
+ , monitorDirectoryExistence
+ , monitorFiles
+ )
+import Distribution.Client.Types.SourceRepo (SourceRepoMaybe, SourceRepositoryPackage (..), srpToProxy)
+import qualified Distribution.PackageDescription as PD
import Distribution.Simple.Program
- ( Program(programFindVersion)
- , ConfiguredProgram(programVersion)
- , simpleProgram, findProgramVersion
- , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput
- , emptyProgramDb, requireProgram )
+ ( ConfiguredProgram (programVersion)
+ , Program (programFindVersion)
+ , ProgramInvocation (..)
+ , emptyProgramDb
+ , findProgramVersion
+ , getProgramInvocationOutput
+ , programInvocation
+ , requireProgram
+ , runProgramInvocation
+ , simpleProgram
+ )
+import Distribution.Types.SourceRepo
+ ( KnownRepoType (..)
+ , RepoType (..)
+ )
+import Distribution.Verbosity as Verbosity
+ ( normal
+ )
import Distribution.Version
- ( mkVersion )
-import qualified Distribution.PackageDescription as PD
+ ( mkVersion
+ )
#if !MIN_VERSION_base(4,18,0)
import Control.Applicative
@@ -60,130 +78,143 @@ import Control.Applicative
#endif
import Control.Exception
- ( throw, try )
+ ( throw
+ , try
+ )
import Control.Monad.Trans
- ( liftIO )
+ ( liftIO
+ )
import qualified Data.Char as Char
import qualified Data.List as List
-import qualified Data.Map as Map
-import System.FilePath
- ( takeDirectory, (</>) )
+import qualified Data.Map as Map
import System.Directory
- ( doesDirectoryExist
- , removeDirectoryRecursive
- )
+ ( doesDirectoryExist
+ , removeDirectoryRecursive
+ )
+import System.FilePath
+ ( takeDirectory
+ , (</>)
+ )
import System.IO.Error
- ( isDoesNotExistError )
-
+ ( isDoesNotExistError
+ )
-- | A driver for a version control system, e.g. git, darcs etc.
---
-data VCS program = VCS {
- -- | The type of repository this driver is for.
- vcsRepoType :: RepoType,
-
- -- | The vcs program itself.
- -- This is used at type 'Program' and 'ConfiguredProgram'.
- vcsProgram :: program,
-
- -- | The program invocation(s) to get\/clone a repository into a fresh
- -- local directory.
- vcsCloneRepo :: forall f. Verbosity
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath -- Source URI
- -> FilePath -- Destination directory
- -> [ProgramInvocation],
-
- -- | The program invocation(s) to synchronise a whole set of /related/
- -- repositories with corresponding local directories. Also returns the
- -- files that the command depends on, for change monitoring.
- vcsSyncRepos :: forall f. Verbosity
- -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)]
- -> IO [MonitorFilePath]
- }
-
+data VCS program = VCS
+ { vcsRepoType :: RepoType
+ -- ^ The type of repository this driver is for.
+ , vcsProgram :: program
+ -- ^ The vcs program itself.
+ -- This is used at type 'Program' and 'ConfiguredProgram'.
+ , vcsCloneRepo
+ :: forall f
+ . Verbosity
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath -- Source URI
+ -> FilePath -- Destination directory
+ -> [ProgramInvocation]
+ -- ^ The program invocation(s) to get\/clone a repository into a fresh
+ -- local directory.
+ , vcsSyncRepos
+ :: forall f
+ . Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
+ -- ^ The program invocation(s) to synchronise a whole set of /related/
+ -- repositories with corresponding local directories. Also returns the
+ -- files that the command depends on, for change monitoring.
+ }
-- ------------------------------------------------------------
+
-- * Selecting repos and drivers
+
-- ------------------------------------------------------------
-data SourceRepoProblem = SourceRepoRepoTypeUnspecified
- | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType
- | SourceRepoLocationUnspecified
- deriving Show
+data SourceRepoProblem
+ = SourceRepoRepoTypeUnspecified
+ | SourceRepoRepoTypeUnsupported (SourceRepositoryPackage Proxy) RepoType
+ | SourceRepoLocationUnspecified
+ deriving (Show)
-- | Validates that the 'SourceRepo' specifies a location URI and a repository
-- type that is supported by a VCS driver.
--
-- | It also returns the 'VCS' driver we should use to work with it.
---
validateSourceRepo
- :: SourceRepositoryPackage f
- -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)
+ :: SourceRepositoryPackage f
+ -> Either SourceRepoProblem (SourceRepositoryPackage f, String, RepoType, VCS Program)
validateSourceRepo = \repo -> do
- let rtype = srpType repo
- vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype
- let uri = srpLocation repo
- return (repo, uri, rtype, vcs)
+ let rtype = srpType repo
+ vcs <- Map.lookup rtype knownVCSs ?! SourceRepoRepoTypeUnsupported (srpToProxy repo) rtype
+ let uri = srpLocation repo
+ return (repo, uri, rtype, vcs)
where
a ?! e = maybe (Left e) Right a
validatePDSourceRepo
- :: PD.SourceRepo
- -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
+ :: PD.SourceRepo
+ -> Either SourceRepoProblem (SourceRepoMaybe, String, RepoType, VCS Program)
validatePDSourceRepo repo = do
- rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified
- uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified
- validateSourceRepo SourceRepositoryPackage
- { srpType = rtype
- , srpLocation = uri
- , srpTag = PD.repoTag repo
- , srpBranch = PD.repoBranch repo
- , srpSubdir = PD.repoSubdir repo
- , srpCommand = mempty
- }
+ rtype <- PD.repoType repo ?! SourceRepoRepoTypeUnspecified
+ uri <- PD.repoLocation repo ?! SourceRepoLocationUnspecified
+ validateSourceRepo
+ SourceRepositoryPackage
+ { srpType = rtype
+ , srpLocation = uri
+ , srpTag = PD.repoTag repo
+ , srpBranch = PD.repoBranch repo
+ , srpSubdir = PD.repoSubdir repo
+ , srpCommand = mempty
+ }
where
a ?! e = maybe (Left e) Right a
-
-
-- | As 'validateSourceRepo' but for a bunch of 'SourceRepo's, and return
-- things in a convenient form to pass to 'configureVCSs', or to report
-- problems.
---
-validateSourceRepos :: [SourceRepositoryPackage f]
- -> Either [(SourceRepositoryPackage f, SourceRepoProblem)]
- [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
+validateSourceRepos
+ :: [SourceRepositoryPackage f]
+ -> Either
+ [(SourceRepositoryPackage f, SourceRepoProblem)]
+ [(SourceRepositoryPackage f, String, RepoType, VCS Program)]
validateSourceRepos rs =
- case partitionEithers (map validateSourceRepo' rs) of
- (problems@(_:_), _) -> Left problems
- ([], vcss) -> Right vcss
+ case partitionEithers (map validateSourceRepo' rs) of
+ (problems@(_ : _), _) -> Left problems
+ ([], vcss) -> Right vcss
where
- validateSourceRepo' :: SourceRepositoryPackage f
- -> Either (SourceRepositoryPackage f, SourceRepoProblem)
- (SourceRepositoryPackage f, String, RepoType, VCS Program)
- validateSourceRepo' r = either (Left . (,) r) Right
- (validateSourceRepo r)
-
-
-configureVCS :: Verbosity
- -> VCS Program
- -> IO (VCS ConfiguredProgram)
+ validateSourceRepo'
+ :: SourceRepositoryPackage f
+ -> Either
+ (SourceRepositoryPackage f, SourceRepoProblem)
+ (SourceRepositoryPackage f, String, RepoType, VCS Program)
+ validateSourceRepo' r =
+ either
+ (Left . (,) r)
+ Right
+ (validateSourceRepo r)
+
+configureVCS
+ :: Verbosity
+ -> VCS Program
+ -> IO (VCS ConfiguredProgram)
configureVCS verbosity vcs@VCS{vcsProgram = prog} =
- asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb
+ asVcsConfigured <$> requireProgram verbosity prog emptyProgramDb
where
- asVcsConfigured (prog', _) = vcs { vcsProgram = prog' }
+ asVcsConfigured (prog', _) = vcs{vcsProgram = prog'}
-configureVCSs :: Verbosity
- -> Map RepoType (VCS Program)
- -> IO (Map RepoType (VCS ConfiguredProgram))
+configureVCSs
+ :: Verbosity
+ -> Map RepoType (VCS Program)
+ -> IO (Map RepoType (VCS ConfiguredProgram))
configureVCSs verbosity = traverse (configureVCS verbosity)
-
-- ------------------------------------------------------------
+
-- * Running the driver
+
-- ------------------------------------------------------------
-- | Clone a single source repo into a fresh directory, using a configured VCS.
@@ -192,22 +223,27 @@ configureVCSs verbosity = traverse (configureVCS verbosity)
-- fail if the destination directory already exists.
--
-- Make sure to validate the 'SourceRepo' using 'validateSourceRepo' first.
---
-
cloneSourceRepo
- :: Verbosity
- -> VCS ConfiguredProgram
- -> SourceRepositoryPackage f
- -> [Char]
- -> IO ()
-cloneSourceRepo verbosity vcs
- repo@SourceRepositoryPackage{ srpLocation = srcuri } destdir =
+ :: Verbosity
+ -> VCS ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> [Char]
+ -> IO ()
+cloneSourceRepo
+ verbosity
+ vcs
+ repo@SourceRepositoryPackage{srpLocation = srcuri}
+ destdir =
traverse_ (runProgramInvocation verbosity) invocations
- where
- invocations = vcsCloneRepo vcs verbosity
- (vcsProgram vcs) repo
- srcuri destdir
-
+ where
+ invocations =
+ vcsCloneRepo
+ vcs
+ verbosity
+ (vcsProgram vcs)
+ repo
+ srcuri
+ destdir
-- | Synchronise a set of 'SourceRepo's referring to the same repository with
-- corresponding local directories. The local directories may or may not
@@ -223,118 +259,127 @@ cloneSourceRepo verbosity vcs
-- For example if a single repo contains multiple packages in different subdirs
-- and in some project it may make sense to use a different state of the repo
-- for one subdir compared to another.
---
-syncSourceRepos :: Verbosity
- -> VCS ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)]
- -> Rebuild ()
+syncSourceRepos
+ :: Verbosity
+ -> VCS ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> Rebuild ()
syncSourceRepos verbosity vcs repos = do
- files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
- monitorFiles files
-
+ files <- liftIO $ vcsSyncRepos vcs verbosity (vcsProgram vcs) repos
+ monitorFiles files
-- ------------------------------------------------------------
+
-- * The various VCS drivers
+
-- ------------------------------------------------------------
-- | The set of all supported VCS drivers, organised by 'RepoType'.
---
knownVCSs :: Map RepoType (VCS Program)
-knownVCSs = Map.fromList [ (vcsRepoType vcs, vcs) | vcs <- vcss ]
+knownVCSs = Map.fromList [(vcsRepoType vcs, vcs) | vcs <- vcss]
where
- vcss = [ vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn ]
-
+ vcss = [vcsBzr, vcsDarcs, vcsGit, vcsHg, vcsSvn]
-- | VCS driver for Bazaar.
---
vcsBzr :: VCS Program
vcsBzr =
- VCS {
- vcsRepoType = KnownRepoType Bazaar,
- vcsProgram = bzrProgram,
- vcsCloneRepo,
- vcsSyncRepos
+ VCS
+ { vcsRepoType = KnownRepoType Bazaar
+ , vcsProgram = bzrProgram
+ , vcsCloneRepo
+ , vcsSyncRepos
}
where
- vcsCloneRepo :: Verbosity
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath
- -> FilePath
- -> [ProgramInvocation]
+ vcsCloneRepo
+ :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
- [ programInvocation prog
- ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg) ]
+ [ programInvocation
+ prog
+ ([branchCmd, srcuri, destdir] ++ tagArgs ++ verboseArg)
+ ]
where
-- The @get@ command was deprecated in version 2.4 in favour of
-- the alias @branch@
- branchCmd | programVersion prog >= Just (mkVersion [2,4])
- = "branch"
- | otherwise = "get"
+ branchCmd
+ | programVersion prog >= Just (mkVersion [2, 4]) =
+ "branch"
+ | otherwise = "get"
tagArgs :: [String]
tagArgs = case srpTag repo of
- Nothing -> []
+ Nothing -> []
Just tag -> ["-r", "tag:" ++ tag]
verboseArg :: [String]
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
- vcsSyncRepos :: Verbosity -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
+ vcsSyncRepos
+ :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for bzr"
bzrProgram :: Program
-bzrProgram = (simpleProgram "bzr") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff"
- (_:_:ver:_) -> ver
- _ -> ""
- }
-
+bzrProgram =
+ (simpleProgram "bzr")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "Bazaar (bzr) 2.6.0\n ... lots of extra stuff"
+ (_ : _ : ver : _) -> ver
+ _ -> ""
+ }
-- | VCS driver for Darcs.
---
vcsDarcs :: VCS Program
vcsDarcs =
- VCS {
- vcsRepoType = KnownRepoType Darcs,
- vcsProgram = darcsProgram,
- vcsCloneRepo,
- vcsSyncRepos
+ VCS
+ { vcsRepoType = KnownRepoType Darcs
+ , vcsProgram = darcsProgram
+ , vcsCloneRepo
+ , vcsSyncRepos
}
where
- vcsCloneRepo :: Verbosity
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath
- -> FilePath
- -> [ProgramInvocation]
+ vcsCloneRepo
+ :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
- [ programInvocation prog cloneArgs ]
+ [programInvocation prog cloneArgs]
where
cloneArgs :: [String]
- cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg
+ cloneArgs = [cloneCmd, srcuri, destdir] ++ tagArgs ++ verboseArg
-- At some point the @clone@ command was introduced as an alias for
-- @get@, and @clone@ seems to be the recommended one now.
cloneCmd :: String
- cloneCmd | programVersion prog >= Just (mkVersion [2,8])
- = "clone"
- | otherwise = "get"
+ cloneCmd
+ | programVersion prog >= Just (mkVersion [2, 8]) =
+ "clone"
+ | otherwise = "get"
tagArgs :: [String]
- tagArgs = case srpTag repo of
- Nothing -> []
+ tagArgs = case srpTag repo of
+ Nothing -> []
Just tag -> ["-t", tag]
verboseArg :: [String]
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
- vcsSyncRepos :: Verbosity -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)] -> IO [MonitorFilePath]
+ vcsSyncRepos
+ :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
vcsSyncRepos _ _ [] = return []
vcsSyncRepos verbosity prog ((primaryRepo, primaryLocalDir) : secondaryRepos) =
- monitors <$ do
+ monitors <$ do
vcsSyncRepo verbosity prog primaryRepo primaryLocalDir Nothing
- for_ secondaryRepos $ \ (repo, localDir) ->
+ for_ secondaryRepos $ \(repo, localDir) ->
vcsSyncRepo verbosity prog repo localDir $ Just primaryLocalDir
where
dirs :: [FilePath]
@@ -343,11 +388,12 @@ vcsDarcs =
monitors = monitorDirectoryExistence <$> dirs
vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer =
- try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \ case
- Right (_:_:_:x:_)
+ try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \case
+ Right (_ : _ : _ : x : _)
| Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x
, Just tag' <- srpTag
- , tag == tag' -> pure ()
+ , tag == tag' ->
+ pure ()
Left e | not (isDoesNotExistError e) -> throw e
_ -> do
removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw
@@ -360,247 +406,275 @@ vcsDarcs =
darcsWithOutput = darcs' getProgramInvocationOutput
darcs' :: (Verbosity -> ProgramInvocation -> t) -> FilePath -> [String] -> t
- darcs' f cwd args = f verbosity (programInvocation prog args)
- { progInvokeCwd = Just cwd }
+ darcs' f cwd args =
+ f
+ verbosity
+ (programInvocation prog args)
+ { progInvokeCwd = Just cwd
+ }
cloneArgs :: [String]
cloneArgs = ["clone"] ++ tagArgs ++ [srpLocation, localDir] ++ verboseArg
tagArgs :: [String]
- tagArgs = case srpTag of
- Nothing -> []
+ tagArgs = case srpTag of
+ Nothing -> []
Just tag -> ["-t" ++ tag]
verboseArg :: [String]
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
darcsProgram :: Program
-darcsProgram = (simpleProgram "darcs") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- "2.8.5 (release)"
- (ver:_) -> ver
- _ -> ""
- }
-
+darcsProgram =
+ (simpleProgram "darcs")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "2.8.5 (release)"
+ (ver : _) -> ver
+ _ -> ""
+ }
-- | VCS driver for Git.
---
vcsGit :: VCS Program
vcsGit =
- VCS {
- vcsRepoType = KnownRepoType Git,
- vcsProgram = gitProgram,
- vcsCloneRepo,
- vcsSyncRepos
+ VCS
+ { vcsRepoType = KnownRepoType Git
+ , vcsProgram = gitProgram
+ , vcsCloneRepo
+ , vcsSyncRepos
}
where
- vcsCloneRepo :: Verbosity
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath
- -> FilePath
- -> [ProgramInvocation]
+ vcsCloneRepo
+ :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
- [ programInvocation prog cloneArgs ]
+ [programInvocation prog cloneArgs]
-- And if there's a tag, we have to do that in a second step:
- ++ [ git (resetArgs tag) | tag <- maybeToList (srpTag repo) ]
- ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg)
- , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg)
- ]
+ ++ [git (resetArgs tag) | tag <- maybeToList (srpTag repo)]
+ ++ [ git (["submodule", "sync", "--recursive"] ++ verboseArg)
+ , git (["submodule", "update", "--init", "--force", "--recursive"] ++ verboseArg)
+ ]
where
- git args = (programInvocation prog args) {progInvokeCwd = Just destdir}
- cloneArgs = ["clone", srcuri, destdir]
- ++ branchArgs ++ verboseArg
+ git args = (programInvocation prog args){progInvokeCwd = Just destdir}
+ cloneArgs =
+ ["clone", srcuri, destdir]
+ ++ branchArgs
+ ++ verboseArg
branchArgs = case srpBranch repo of
- Just b -> ["--branch", b]
+ Just b -> ["--branch", b]
Nothing -> []
resetArgs tag = "reset" : verboseArg ++ ["--hard", tag, "--"]
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
- vcsSyncRepos :: Verbosity
- -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)]
- -> IO [MonitorFilePath]
+ vcsSyncRepos
+ :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
vcsSyncRepos _ _ [] = return []
- vcsSyncRepos verbosity gitProg
- ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
-
- vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
- sequence_
- [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
- | (repo, localDir) <- secondaryRepos ]
- return [ monitorDirectoryExistence dir
- | dir <- (primaryLocalDir : map snd secondaryRepos) ]
+ vcsSyncRepos
+ verbosity
+ gitProg
+ ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
+ vcsSyncRepo verbosity gitProg primaryRepo primaryLocalDir Nothing
+ sequence_
+ [ vcsSyncRepo verbosity gitProg repo localDir (Just primaryLocalDir)
+ | (repo, localDir) <- secondaryRepos
+ ]
+ return
+ [ monitorDirectoryExistence dir
+ | dir <- (primaryLocalDir : map snd secondaryRepos)
+ ]
vcsSyncRepo verbosity gitProg SourceRepositoryPackage{..} localDir peer = do
- exists <- doesDirectoryExist localDir
- if exists
- then git localDir ["fetch"]
- else git (takeDirectory localDir) cloneArgs
- -- Before trying to checkout other commits, all submodules must be
- -- de-initialised and the .git/modules directory must be deleted. This
- -- is needed because sometimes `git submodule sync` does not actually
- -- update the submodule source URL. Detailed description here:
- -- https://git.coop/-/snippets/85
- git localDir ["submodule", "deinit", "--force", "--all"]
- let gitModulesDir = localDir </> ".git" </> "modules"
- gitModulesExists <- doesDirectoryExist gitModulesDir
- when gitModulesExists $ removeDirectoryRecursive gitModulesDir
- git localDir resetArgs
- git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg
- git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg
- git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]
- git localDir $ ["clean", "-ffxdq"]
+ exists <- doesDirectoryExist localDir
+ if exists
+ then git localDir ["fetch"]
+ else git (takeDirectory localDir) cloneArgs
+ -- Before trying to checkout other commits, all submodules must be
+ -- de-initialised and the .git/modules directory must be deleted. This
+ -- is needed because sometimes `git submodule sync` does not actually
+ -- update the submodule source URL. Detailed description here:
+ -- https://git.coop/-/snippets/85
+ git localDir ["submodule", "deinit", "--force", "--all"]
+ let gitModulesDir = localDir </> ".git" </> "modules"
+ gitModulesExists <- doesDirectoryExist gitModulesDir
+ when gitModulesExists $ removeDirectoryRecursive gitModulesDir
+ git localDir resetArgs
+ git localDir $ ["submodule", "sync", "--recursive"] ++ verboseArg
+ git localDir $ ["submodule", "update", "--force", "--init", "--recursive"] ++ verboseArg
+ git localDir $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]
+ git localDir $ ["clean", "-ffxdq"]
where
git :: FilePath -> [String] -> IO ()
- git cwd args = runProgramInvocation verbosity $
- (programInvocation gitProg args) {
- progInvokeCwd = Just cwd
- }
-
- cloneArgs = ["clone", "--no-checkout", loc, localDir]
- ++ case peer of
- Nothing -> []
- Just peerLocalDir -> ["--reference", peerLocalDir]
- ++ verboseArg
- where loc = srpLocation
- resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--" ]
+ git cwd args =
+ runProgramInvocation verbosity $
+ (programInvocation gitProg args)
+ { progInvokeCwd = Just cwd
+ }
+
+ cloneArgs =
+ ["clone", "--no-checkout", loc, localDir]
+ ++ case peer of
+ Nothing -> []
+ Just peerLocalDir -> ["--reference", peerLocalDir]
+ ++ verboseArg
+ where
+ loc = srpLocation
+ resetArgs = "reset" : verboseArg ++ ["--hard", resetTarget, "--"]
resetTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
gitProgram :: Program
-gitProgram = (simpleProgram "git") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- "git version 2.5.5"
- (_:_:ver:_) | all isTypical ver -> ver
-
- -- or annoyingly "git version 2.17.1.windows.2" yes, really
- (_:_:ver:_) -> intercalate "."
- . takeWhile (all isNum)
- . split
- $ ver
- _ -> ""
- }
+gitProgram =
+ (simpleProgram "git")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "git version 2.5.5"
+ (_ : _ : ver : _) | all isTypical ver -> ver
+ -- or annoyingly "git version 2.17.1.windows.2" yes, really
+ (_ : _ : ver : _) ->
+ intercalate "."
+ . takeWhile (all isNum)
+ . split
+ $ ver
+ _ -> ""
+ }
where
- isNum c = c >= '0' && c <= '9'
+ isNum c = c >= '0' && c <= '9'
isTypical c = isNum c || c == '.'
- split cs = case break (=='.') cs of
- (chunk,[]) -> chunk : []
- (chunk,_:rest) -> chunk : split rest
+ split cs = case break (== '.') cs of
+ (chunk, []) -> chunk : []
+ (chunk, _ : rest) -> chunk : split rest
-- | VCS driver for Mercurial.
---
vcsHg :: VCS Program
vcsHg =
- VCS {
- vcsRepoType = KnownRepoType Mercurial,
- vcsProgram = hgProgram,
- vcsCloneRepo,
- vcsSyncRepos
+ VCS
+ { vcsRepoType = KnownRepoType Mercurial
+ , vcsProgram = hgProgram
+ , vcsCloneRepo
+ , vcsSyncRepos
}
where
- vcsCloneRepo :: Verbosity
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath
- -> FilePath
- -> [ProgramInvocation]
+ vcsCloneRepo
+ :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
vcsCloneRepo verbosity prog repo srcuri destdir =
- [ programInvocation prog cloneArgs ]
+ [programInvocation prog cloneArgs]
where
- cloneArgs = ["clone", srcuri, destdir]
- ++ branchArgs ++ tagArgs ++ verboseArg
+ cloneArgs =
+ ["clone", srcuri, destdir]
+ ++ branchArgs
+ ++ tagArgs
+ ++ verboseArg
branchArgs = case srpBranch repo of
- Just b -> ["--branch", b]
+ Just b -> ["--branch", b]
Nothing -> []
tagArgs = case srpTag repo of
- Just t -> ["--rev", t]
+ Just t -> ["--rev", t]
Nothing -> []
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
- vcsSyncRepos :: Verbosity
- -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)]
- -> IO [MonitorFilePath]
+ vcsSyncRepos
+ :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
vcsSyncRepos _ _ [] = return []
- vcsSyncRepos verbosity hgProg
- ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
- vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir
- sequence_
- [ vcsSyncRepo verbosity hgProg repo localDir
- | (repo, localDir) <- secondaryRepos ]
- return [ monitorDirectoryExistence dir
- | dir <- (primaryLocalDir : map snd secondaryRepos) ]
+ vcsSyncRepos
+ verbosity
+ hgProg
+ ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
+ vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir
+ sequence_
+ [ vcsSyncRepo verbosity hgProg repo localDir
+ | (repo, localDir) <- secondaryRepos
+ ]
+ return
+ [ monitorDirectoryExistence dir
+ | dir <- (primaryLocalDir : map snd secondaryRepos)
+ ]
vcsSyncRepo verbosity hgProg repo localDir = do
- exists <- doesDirectoryExist localDir
- if exists
- then hg localDir ["pull"]
- else hg (takeDirectory localDir) cloneArgs
- hg localDir checkoutArgs
+ exists <- doesDirectoryExist localDir
+ if exists
+ then hg localDir ["pull"]
+ else hg (takeDirectory localDir) cloneArgs
+ hg localDir checkoutArgs
where
hg :: FilePath -> [String] -> IO ()
- hg cwd args = runProgramInvocation verbosity $
- (programInvocation hgProg args) {
- progInvokeCwd = Just cwd
- }
- cloneArgs = ["clone", "--noupdate", (srpLocation repo), localDir]
- ++ verboseArg
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
- checkoutArgs = [ "checkout", "--clean" ]
- ++ tagArgs
+ hg cwd args =
+ runProgramInvocation verbosity $
+ (programInvocation hgProg args)
+ { progInvokeCwd = Just cwd
+ }
+ cloneArgs =
+ ["clone", "--noupdate", (srpLocation repo), localDir]
+ ++ verboseArg
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
+ checkoutArgs =
+ ["checkout", "--clean"]
+ ++ tagArgs
tagArgs = case srpTag repo of
- Just t -> ["--rev", t]
- Nothing -> []
+ Just t -> ["--rev", t]
+ Nothing -> []
hgProgram :: Program
-hgProgram = (simpleProgram "hg") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- Mercurial Distributed SCM (version 3.5.2)\n ... long message
- (_:_:_:_:ver:_) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
- _ -> ""
- }
-
+hgProgram =
+ (simpleProgram "hg")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- Mercurial Distributed SCM (version 3.5.2)\n ... long message
+ (_ : _ : _ : _ : ver : _) -> takeWhile (\c -> Char.isDigit c || c == '.') ver
+ _ -> ""
+ }
-- | VCS driver for Subversion.
---
vcsSvn :: VCS Program
vcsSvn =
- VCS {
- vcsRepoType = KnownRepoType SVN,
- vcsProgram = svnProgram,
- vcsCloneRepo,
- vcsSyncRepos
+ VCS
+ { vcsRepoType = KnownRepoType SVN
+ , vcsProgram = svnProgram
+ , vcsCloneRepo
+ , vcsSyncRepos
}
where
- vcsCloneRepo :: Verbosity
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath
- -> FilePath
- -> [ProgramInvocation]
+ vcsCloneRepo
+ :: Verbosity
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
vcsCloneRepo verbosity prog _repo srcuri destdir =
- [ programInvocation prog checkoutArgs ]
+ [programInvocation prog checkoutArgs]
where
checkoutArgs = ["checkout", srcuri, destdir] ++ verboseArg
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
- --TODO: branch or tag?
-
- vcsSyncRepos :: Verbosity
- -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)]
- -> IO [MonitorFilePath]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
+ -- TODO: branch or tag?
+
+ vcsSyncRepos
+ :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for svn"
svnProgram :: Program
-svnProgram = (simpleProgram "svn") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- svn, version 1.9.4 (r1740329)\n ... long message
- (_:_:ver:_) -> ver
- _ -> ""
- }
-
+svnProgram =
+ (simpleProgram "svn")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- svn, version 1.9.4 (r1740329)\n ... long message
+ (_ : _ : ver : _) -> ver
+ _ -> ""
+ }
-- | VCS driver for Pijul.
-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
@@ -667,85 +741,96 @@ svnProgram = (simpleProgram "svn") {
-- won't work, even the basics are in place. Tests are also written
-- but disabled, as the branching model differs from `git` one,
-- for which tests are written.
---
vcsPijul :: VCS Program
vcsPijul =
- VCS {
- vcsRepoType = KnownRepoType Pijul,
- vcsProgram = pijulProgram,
- vcsCloneRepo,
- vcsSyncRepos
+ VCS
+ { vcsRepoType = KnownRepoType Pijul
+ , vcsProgram = pijulProgram
+ , vcsCloneRepo
+ , vcsSyncRepos
}
where
- vcsCloneRepo :: Verbosity -- ^ it seems that pijul does not have verbose flag
- -> ConfiguredProgram
- -> SourceRepositoryPackage f
- -> FilePath
- -> FilePath
- -> [ProgramInvocation]
+ vcsCloneRepo
+ :: Verbosity
+ -- \^ it seems that pijul does not have verbose flag
+ -> ConfiguredProgram
+ -> SourceRepositoryPackage f
+ -> FilePath
+ -> FilePath
+ -> [ProgramInvocation]
vcsCloneRepo _verbosity prog repo srcuri destdir =
- [ programInvocation prog cloneArgs ]
+ [programInvocation prog cloneArgs]
-- And if there's a tag, we have to do that in a second step:
- ++ [ (programInvocation prog (checkoutArgs tag)) {
- progInvokeCwd = Just destdir
- }
- | tag <- maybeToList (srpTag repo) ]
+ ++ [ (programInvocation prog (checkoutArgs tag))
+ { progInvokeCwd = Just destdir
+ }
+ | tag <- maybeToList (srpTag repo)
+ ]
where
cloneArgs :: [String]
- cloneArgs = ["clone", srcuri, destdir]
- ++ branchArgs
+ cloneArgs =
+ ["clone", srcuri, destdir]
+ ++ branchArgs
branchArgs :: [String]
branchArgs = case srpBranch repo of
- Just b -> ["--from-branch", b]
+ Just b -> ["--from-branch", b]
Nothing -> []
checkoutArgs tag = "checkout" : [tag] -- TODO: this probably doesn't work either
-
- vcsSyncRepos :: Verbosity
- -> ConfiguredProgram
- -> [(SourceRepositoryPackage f, FilePath)]
- -> IO [MonitorFilePath]
+ vcsSyncRepos
+ :: Verbosity
+ -> ConfiguredProgram
+ -> [(SourceRepositoryPackage f, FilePath)]
+ -> IO [MonitorFilePath]
vcsSyncRepos _ _ [] = return []
- vcsSyncRepos verbosity pijulProg
- ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
-
- vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
- sequence_
- [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
- | (repo, localDir) <- secondaryRepos ]
- return [ monitorDirectoryExistence dir
- | dir <- (primaryLocalDir : map snd secondaryRepos) ]
+ vcsSyncRepos
+ verbosity
+ pijulProg
+ ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
+ vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
+ sequence_
+ [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
+ | (repo, localDir) <- secondaryRepos
+ ]
+ return
+ [ monitorDirectoryExistence dir
+ | dir <- (primaryLocalDir : map snd secondaryRepos)
+ ]
vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do
- exists <- doesDirectoryExist localDir
- if exists
- then pijul localDir ["pull"] -- TODO: this probably doesn't work.
+ exists <- doesDirectoryExist localDir
+ if exists
+ then pijul localDir ["pull"] -- TODO: this probably doesn't work.
else pijul (takeDirectory localDir) cloneArgs
- pijul localDir checkoutArgs
+ pijul localDir checkoutArgs
where
pijul :: FilePath -> [String] -> IO ()
- pijul cwd args = runProgramInvocation verbosity $
- (programInvocation pijulProg args) {
- progInvokeCwd = Just cwd
- }
+ pijul cwd args =
+ runProgramInvocation verbosity $
+ (programInvocation pijulProg args)
+ { progInvokeCwd = Just cwd
+ }
cloneArgs :: [String]
- cloneArgs = ["clone", loc, localDir]
- ++ case peer of
- Nothing -> []
- Just peerLocalDir -> [peerLocalDir]
- where loc = srpLocation
+ cloneArgs =
+ ["clone", loc, localDir]
+ ++ case peer of
+ Nothing -> []
+ Just peerLocalDir -> [peerLocalDir]
+ where
+ loc = srpLocation
checkoutArgs :: [String]
- checkoutArgs = "checkout" : ["--force", checkoutTarget, "--" ]
+ checkoutArgs = "checkout" : ["--force", checkoutTarget, "--"]
checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag) -- TODO: this is definitely wrong.
pijulProgram :: Program
-pijulProgram = (simpleProgram "pijul") {
- programFindVersion = findProgramVersion "--version" $ \str ->
- case words str of
- -- "pijul 0.12.2
- (_:ver:_) | all isTypical ver -> ver
- _ -> ""
- }
+pijulProgram =
+ (simpleProgram "pijul")
+ { programFindVersion = findProgramVersion "--version" $ \str ->
+ case words str of
+ -- "pijul 0.12.2
+ (_ : ver : _) | all isTypical ver -> ver
+ _ -> ""
+ }
where
- isNum c = c >= '0' && c <= '9'
+ isNum c = c >= '0' && c <= '9'
isTypical c = isNum c || c == '.'
diff --git a/cabal-install/src/Distribution/Client/Version.hs b/cabal-install/src/Distribution/Client/Version.hs
index ad2f48d7a0370c1a6454de96abfaca8cc960ee20..dc06552350fce61106909b0998aa9e2931b4ccb3 100644
--- a/cabal-install/src/Distribution/Client/Version.hs
+++ b/cabal-install/src/Distribution/Client/Version.hs
@@ -1,5 +1,4 @@
-- | Provides the version number of @cabal-install@.
-
module Distribution.Client.Version
( cabalInstallVersion
) where
@@ -13,4 +12,4 @@ import Distribution.Version
-- program coverage information generated by HPC, and hence was moved to be a standalone value.
--
cabalInstallVersion :: Version
-cabalInstallVersion = mkVersion [3,11]
+cabalInstallVersion = mkVersion [3, 11]
diff --git a/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs
index c220d9e92741c33a4e84194e5f267346257ad145..516cbdb63b3a157a3a7d906ffce87fc92f89b81a 100644
--- a/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs
+++ b/cabal-install/src/Distribution/Client/Win32SelfUpgrade.hs
@@ -1,5 +1,10 @@
-{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
-- Module : Distribution.Client.Win32SelfUpgrade
-- Copyright : (c) Duncan Coutts 2008
@@ -10,36 +15,35 @@
-- Portability : portable
--
-- Support for self-upgrading executables on Windows platforms.
------------------------------------------------------------------------------
-module Distribution.Client.Win32SelfUpgrade (
--- * Explanation
---
--- | Windows inherited a design choice from DOS that while initially innocuous
--- has rather unfortunate consequences. It maintains the invariant that every
--- open file has a corresponding name on disk. One positive consequence of this
--- is that an executable can always find its own executable file. The downside
--- is that a program cannot be deleted or upgraded while it is running without
--- hideous workarounds. This module implements one such hideous workaround.
---
--- The basic idea is:
---
--- * Move our own exe file to a new name
--- * Copy a new exe file to the previous name
--- * Run the new exe file, passing our own PID and new path
--- * Wait for the new process to start
--- * Close the new exe file
--- * Exit old process
---
--- Then in the new process:
---
--- * Inform the old process that we've started
--- * Wait for the old process to die
--- * Delete the old exe file
--- * Exit new process
---
-
- possibleSelfUpgrade,
- deleteOldExeFile,
+module Distribution.Client.Win32SelfUpgrade
+ ( -- * Explanation
+
+ --
+
+ -- | Windows inherited a design choice from DOS that while initially innocuous
+ -- has rather unfortunate consequences. It maintains the invariant that every
+ -- open file has a corresponding name on disk. One positive consequence of this
+ -- is that an executable can always find its own executable file. The downside
+ -- is that a program cannot be deleted or upgraded while it is running without
+ -- hideous workarounds. This module implements one such hideous workaround.
+ --
+ -- The basic idea is:
+ --
+ -- * Move our own exe file to a new name
+ -- * Copy a new exe file to the previous name
+ -- * Run the new exe file, passing our own PID and new path
+ -- * Wait for the new process to start
+ -- * Close the new exe file
+ -- * Exit old process
+ --
+ -- Then in the new process:
+ --
+ -- * Inform the old process that we've started
+ -- * Wait for the old process to die
+ -- * Delete the old exe file
+ -- * Exit new process
+ possibleSelfUpgrade
+ , deleteOldExeFile
) where
import Distribution.Client.Compat.Prelude hiding (log)
@@ -162,6 +166,7 @@ deleteOldExeFile verbosity oldPID tmpPath = do
-- A bunch of functions sadly not provided by the Win32 package.
+{- FOURMOLU_DISABLE -}
#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
@@ -224,3 +229,4 @@ deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()
deleteOldExeFile verbosity _ _ = die' verbosity "win32selfupgrade not needed except on win32"
#endif
+{- FOURMOLU_ENABLE -}
diff --git a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs
index 6ac62a6e82d6d4925d09cd2849135ffcb4c6f8c6..592306727c2c4708af05cec4bf62f8a86b119cf4 100644
--- a/cabal-install/src/Distribution/Deprecated/ParseUtils.hs
+++ b/cabal-install/src/Distribution/Deprecated/ParseUtils.hs
@@ -1,5 +1,9 @@
{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
-----------------------------------------------------------------------------
+-- This module is meant to be local-only to Distribution...
+{-# OPTIONS_HADDOCK hide #-}
+
-- |
-- Module : Distribution.Deprecated.ParseUtils
-- Copyright : (c) The University of Glasgow 2004
@@ -16,30 +20,42 @@
-- couple others. It has the parsing framework code and also little parsers for
-- many of the formats we get in various @.cabal@ file fields, like module
-- names, comma separated lists etc.
-
--- This module is meant to be local-only to Distribution...
-
-{-# OPTIONS_HADDOCK hide #-}
-{-# LANGUAGE Rank2Types #-}
-module Distribution.Deprecated.ParseUtils (
- LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
- runP, runE, ParseResult(..), parseFail, showPWarning,
- Field(..), lineNo,
- FieldDescr(..), readFields,
- parseHaskellString, parseTokenQ,
- parseOptCommaList,
- showFilePath, showToken, showFreeText,
- field, simpleField, listField, listFieldWithSep, spaceListField,
- newLineListField,
- liftField,
- readPToMaybe,
-
- fieldParsec, simpleFieldParsec,
- listFieldParsec,
- commaListFieldParsec,
- commaNewLineListFieldParsec,
-
- UnrecFieldParser,
+module Distribution.Deprecated.ParseUtils
+ ( LineNo
+ , PError (..)
+ , PWarning (..)
+ , locatedErrorMsg
+ , syntaxError
+ , warning
+ , runP
+ , runE
+ , ParseResult (..)
+ , parseFail
+ , showPWarning
+ , Field (..)
+ , lineNo
+ , FieldDescr (..)
+ , readFields
+ , parseHaskellString
+ , parseTokenQ
+ , parseOptCommaList
+ , showFilePath
+ , showToken
+ , showFreeText
+ , field
+ , simpleField
+ , listField
+ , listFieldWithSep
+ , spaceListField
+ , newLineListField
+ , liftField
+ , readPToMaybe
+ , fieldParsec
+ , simpleFieldParsec
+ , listFieldParsec
+ , commaListFieldParsec
+ , commaNewLineListFieldParsec
+ , UnrecFieldParser
) where
import Distribution.Client.Compat.Prelude hiding (get)
@@ -51,8 +67,8 @@ import Distribution.Pretty
import Distribution.ReadE
import Distribution.Utils.Generic
-import System.FilePath (normalise)
-import Text.PrettyPrint (Doc, punctuate, comma, fsep, sep)
+import System.FilePath (normalise)
+import Text.PrettyPrint (Doc, comma, fsep, punctuate, sep)
import qualified Text.Read as Read
import qualified Control.Monad.Fail as Fail
@@ -61,67 +77,73 @@ import Distribution.Parsec (ParsecParser, parsecLeadingCommaList, parsecLeadingO
import qualified Data.ByteString as BS
import qualified Distribution.Fields as Fields
import qualified Distribution.Fields.Field as Fields
-import qualified Distribution.Parsec as Parsec
import qualified Distribution.Fields.LexerMonad as Fields
+import qualified Distribution.Parsec as Parsec
import qualified Text.Parsec.Error as PE
import qualified Text.Parsec.Pos as PP
-- -----------------------------------------------------------------------------
-type LineNo = Int
+type LineNo = Int
-data PError = AmbiguousParse String LineNo
- | NoParse String LineNo
- | TabsError LineNo
- | FromString String (Maybe LineNo)
- deriving (Eq, Show)
+data PError
+ = AmbiguousParse String LineNo
+ | NoParse String LineNo
+ | TabsError LineNo
+ | FromString String (Maybe LineNo)
+ deriving (Eq, Show)
-data PWarning = PWarning String
- | UTFWarning LineNo String
- deriving (Eq, Show)
+data PWarning
+ = PWarning String
+ | UTFWarning LineNo String
+ deriving (Eq, Show)
showPWarning :: FilePath -> PWarning -> String
showPWarning fpath (PWarning msg) =
normalise fpath ++ ": " ++ msg
showPWarning fpath (UTFWarning line fname) =
- normalise fpath ++ ":" ++ show line
- ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."
+ normalise fpath
+ ++ ":"
+ ++ show line
+ ++ ": Invalid UTF-8 text in the '"
+ ++ fname
+ ++ "' field."
data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
- deriving Show
+ deriving (Show)
instance Functor ParseResult where
- fmap _ (ParseFailed err) = ParseFailed err
- fmap f (ParseOk ws x) = ParseOk ws $ f x
+ fmap _ (ParseFailed err) = ParseFailed err
+ fmap f (ParseOk ws x) = ParseOk ws $ f x
instance Applicative ParseResult where
- pure = ParseOk []
- (<*>) = ap
-
+ pure = ParseOk []
+ (<*>) = ap
+{- FOURMOLU_DISABLE -}
instance Monad ParseResult where
- return = pure
- ParseFailed err >>= _ = ParseFailed err
- ParseOk ws x >>= f = case f x of
- ParseFailed err -> ParseFailed err
- ParseOk ws' x' -> ParseOk (ws'++ws) x'
+ return = pure
+ ParseFailed err >>= _ = ParseFailed err
+ ParseOk ws x >>= f = case f x of
+ ParseFailed err -> ParseFailed err
+ ParseOk ws' x' -> ParseOk (ws' ++ ws) x'
#if !(MIN_VERSION_base(4,9,0))
- fail = parseResultFail
+ fail = parseResultFail
#elif !(MIN_VERSION_base(4,13,0))
- fail = Fail.fail
+ fail = Fail.fail
#endif
+{- FOURMOLU_ENABLE -}
instance Foldable ParseResult where
- foldMap _ (ParseFailed _ ) = mempty
+ foldMap _ (ParseFailed _) = mempty
foldMap f (ParseOk _ x) = f x
instance Traversable ParseResult where
traverse _ (ParseFailed err) = pure (ParseFailed err)
traverse f (ParseOk ws x) = ParseOk ws <$> f x
-
instance Fail.MonadFail ParseResult where
- fail = parseResultFail
+ fail = parseResultFail
parseResultFail :: String -> ParseResult a
parseResultFail s = parseFail (FromString s Nothing)
@@ -131,56 +153,63 @@ parseFail = ParseFailed
runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
runP line fieldname p s =
- case [ x | (x,"") <- results ] of
+ case [x | (x, "") <- results] of
[a] -> ParseOk (utf8Warnings line fieldname s) a
- --TODO: what is this double parse thing all about?
+ -- TODO: what is this double parse thing all about?
-- Can't we just do the all isSpace test the first time?
- [] -> case [ x | (x,ys) <- results, all isSpace ys ] of
- [a] -> ParseOk (utf8Warnings line fieldname s) a
- [] -> ParseFailed (NoParse fieldname line)
- _ -> ParseFailed (AmbiguousParse fieldname line)
- _ -> ParseFailed (AmbiguousParse fieldname line)
- where results = readP_to_S p s
+ [] -> case [x | (x, ys) <- results, all isSpace ys] of
+ [a] -> ParseOk (utf8Warnings line fieldname s) a
+ [] -> ParseFailed (NoParse fieldname line)
+ _ -> ParseFailed (AmbiguousParse fieldname line)
+ _ -> ParseFailed (AmbiguousParse fieldname line)
+ where
+ results = readP_to_S p s
runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
runE line fieldname p s =
- case runReadE p s of
- Right a -> ParseOk (utf8Warnings line fieldname s) a
- Left e -> syntaxError line $
+ case runReadE p s of
+ Right a -> ParseOk (utf8Warnings line fieldname s) a
+ Left e ->
+ syntaxError line $
"Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s
utf8Warnings :: LineNo -> String -> String -> [PWarning]
utf8Warnings line fieldname s =
- take 1 [ UTFWarning n fieldname
- | (n,l) <- zip [line..] (lines s)
- , '\xfffd' `elem` l ]
+ take
+ 1
+ [ UTFWarning n fieldname
+ | (n, l) <- zip [line ..] (lines s)
+ , '\xfffd' `elem` l
+ ]
locatedErrorMsg :: PError -> (Maybe LineNo, String)
-locatedErrorMsg (AmbiguousParse f n) = (Just n,
- "Ambiguous parse in field '"++f++"'.")
-locatedErrorMsg (NoParse f n) = (Just n,
- "Parse of field '"++f++"' failed.")
-locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
-locatedErrorMsg (FromString s n) = (n, s)
+locatedErrorMsg (AmbiguousParse f n) =
+ ( Just n
+ , "Ambiguous parse in field '" ++ f ++ "'."
+ )
+locatedErrorMsg (NoParse f n) =
+ ( Just n
+ , "Parse of field '" ++ f ++ "' failed."
+ )
+locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
+locatedErrorMsg (FromString s n) = (n, s)
syntaxError :: LineNo -> String -> ParseResult a
syntaxError n s = ParseFailed $ FromString s (Just n)
-
warning :: String -> ParseResult ()
warning s = ParseOk [PWarning s] ()
-- | Field descriptor. The parameter @a@ parameterizes over where the field's
-- value is stored in.
-data FieldDescr a
- = FieldDescr
- { fieldName :: String
- , fieldGet :: a -> Doc
- , fieldSet :: LineNo -> String -> a -> ParseResult a
- -- ^ @fieldSet n str x@ Parses the field value from the given input
- -- string @str@ and stores the result in @x@ if the parse was
- -- successful. Otherwise, reports an error on line number @n@.
- }
+data FieldDescr a = FieldDescr
+ { fieldName :: String
+ , fieldGet :: a -> Doc
+ , fieldSet :: LineNo -> String -> a -> ParseResult a
+ -- ^ @fieldSet n str x@ Parses the field value from the given input
+ -- string @str@ and stores the result in @x@ if the parse was
+ -- successful. Otherwise, reports an error on line number @n@.
+ }
field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a
field name showF readF =
@@ -190,88 +219,147 @@ fieldParsec :: String -> (a -> Doc) -> ParsecParser a -> FieldDescr a
fieldParsec name showF readF =
FieldDescr name showF $ \line val _st -> case explicitEitherParsec readF val of
Left err -> ParseFailed (FromString err (Just line))
- Right x -> ParseOk [] x
+ Right x -> ParseOk [] x
-- Lift a field descriptor storing into an 'a' to a field descriptor storing
-- into a 'b'.
liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
-liftField get set (FieldDescr name showF parseF)
- = FieldDescr name (showF . get)
- (\line str b -> do
- a <- parseF line str (get b)
- return (set a b))
+liftField get set (FieldDescr name showF parseF) =
+ FieldDescr
+ name
+ (showF . get)
+ ( \line str b -> do
+ a <- parseF line str (get b)
+ return (set a b)
+ )
-- Parser combinator for simple fields. Takes a field name, a pretty printer,
-- a parser function, an accessor, and a setter, returns a FieldDescr over the
-- compoid structure.
-simpleField :: String -> (a -> Doc) -> ReadP a a
- -> (b -> a) -> (a -> b -> b) -> FieldDescr b
-simpleField name showF readF get set
- = liftField get set $ field name showF readF
-
-simpleFieldParsec :: String -> (a -> Doc) -> ParsecParser a
- -> (b -> a) -> (a -> b -> b) -> FieldDescr b
-simpleFieldParsec name showF readF get set
- = liftField get set $ fieldParsec name showF readF
-
-commaListFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+simpleField
+ :: String
+ -> (a -> Doc)
+ -> ReadP a a
+ -> (b -> a)
+ -> (a -> b -> b)
+ -> FieldDescr b
+simpleField name showF readF get set =
+ liftField get set $ field name showF readF
+
+simpleFieldParsec
+ :: String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> a)
+ -> (a -> b -> b)
+ -> FieldDescr b
+simpleFieldParsec name showF readF get set =
+ liftField get set $ fieldParsec name showF readF
+
+commaListFieldWithSepParsec
+ :: Separator
+ -> String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
commaListFieldWithSepParsec separator name showF readF get set =
- liftField get set' $
- fieldParsec name showF' (parsecLeadingCommaList readF)
- where
- set' xs b = set (get b ++ xs) b
- showF' = separator . punctuate comma . map showF
-
-commaListFieldParsec :: String -> (a -> Doc) -> ParsecParser a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+ liftField get set' $
+ fieldParsec name showF' (parsecLeadingCommaList readF)
+ where
+ set' xs b = set (get b ++ xs) b
+ showF' = separator . punctuate comma . map showF
+
+commaListFieldParsec
+ :: String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
commaListFieldParsec = commaListFieldWithSepParsec fsep
commaNewLineListFieldParsec
- :: String -> (a -> Doc) -> ParsecParser a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+ :: String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
commaNewLineListFieldParsec = commaListFieldWithSepParsec sep
-spaceListField :: String -> (a -> Doc) -> ReadP [a] a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+spaceListField
+ :: String
+ -> (a -> Doc)
+ -> ReadP [a] a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
spaceListField name showF readF get set =
liftField get set' $
field name showF' (parseSpaceList readF)
where
set' xs b = set (get b ++ xs) b
- showF' = fsep . map showF
+ showF' = fsep . map showF
-- this is a different definition from listField, like
-- commaNewLineListField it pretty prints on multiple lines
-newLineListField :: String -> (a -> Doc) -> ReadP [a] a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+newLineListField
+ :: String
+ -> (a -> Doc)
+ -> ReadP [a] a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
newLineListField = listFieldWithSep sep
-listFieldWithSep :: Separator -> String -> (a -> Doc) -> ReadP [a] a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+listFieldWithSep
+ :: Separator
+ -> String
+ -> (a -> Doc)
+ -> ReadP [a] a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
listFieldWithSep separator name showF readF get set =
liftField get set' $
field name showF' (parseOptCommaList readF)
where
set' xs b = set (get b ++ xs) b
- showF' = separator . map showF
-
-listFieldWithSepParsec :: Separator -> String -> (a -> Doc) -> ParsecParser a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+ showF' = separator . map showF
+
+listFieldWithSepParsec
+ :: Separator
+ -> String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
listFieldWithSepParsec separator name showF readF get set =
liftField get set' $
fieldParsec name showF' (parsecLeadingOptCommaList readF)
where
set' xs b = set (get b ++ xs) b
- showF' = separator . map showF
-
-listField :: String -> (a -> Doc) -> ReadP [a] a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+ showF' = separator . map showF
+
+listField
+ :: String
+ -> (a -> Doc)
+ -> ReadP [a] a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
listField = listFieldWithSep fsep
listFieldParsec
- :: String -> (a -> Doc) -> ParsecParser a
- -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+ :: String
+ -> (a -> Doc)
+ -> ParsecParser a
+ -> (b -> [a])
+ -> ([a] -> b -> b)
+ -> FieldDescr b
listFieldParsec = listFieldWithSepParsec fsep
-- | The type of a function which, given a name-value pair of an
@@ -279,25 +367,27 @@ listFieldParsec = listFieldWithSepParsec fsep
-- decides whether to incorporate the unrecognized field
-- (by returning Just x, where x is a possibly modified version
-- of the structure being built), or not (by returning Nothing).
-type UnrecFieldParser a = (String,String) -> a -> Maybe a
+type UnrecFieldParser a = (String, String) -> a -> Maybe a
------------------------------------------------------------------------------
-- The data type for our three syntactic categories
data Field
- = F LineNo String String
- -- ^ A regular @<property>: <value>@ field
- | Section LineNo String String [Field]
- -- ^ A section with a name and possible parameter. The syntactic
- -- structure is:
- --
- -- @
- -- <sectionname> <arg> {
- -- <field>*
- -- }
- -- @
- deriving (Show
- ,Eq) -- for testing
+ = -- | A regular @<property>: <value>@ field
+ F LineNo String String
+ | -- | A section with a name and possible parameter. The syntactic
+ -- structure is:
+ --
+ -- @
+ -- <sectionname> <arg> {
+ -- <field>*
+ -- }
+ -- @
+ Section LineNo String String [Field]
+ deriving
+ ( Show
+ , Eq -- for testing
+ )
lineNo :: Field -> LineNo
lineNo (F n _ _) = n
@@ -305,25 +395,33 @@ lineNo (Section n _ _ _) = n
readFields :: BS.ByteString -> ParseResult [Field]
readFields input = case Fields.readFields' input of
- Right (fs, ws) -> ParseOk
- [ PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws ]
- (legacyFields fs)
- Left perr -> ParseFailed $ NoParse
- (PE.showErrorMessages
- "or" "unknown parse error" "expecting" "unexpected" "end of file"
- (PE.errorMessages perr))
+ Right (fs, ws) ->
+ ParseOk
+ [PWarning msg | Fields.PWarning _ _ msg <- Fields.toPWarnings ws]
+ (legacyFields fs)
+ Left perr ->
+ ParseFailed $
+ NoParse
+ ( PE.showErrorMessages
+ "or"
+ "unknown parse error"
+ "expecting"
+ "unexpected"
+ "end of file"
+ (PE.errorMessages perr)
+ )
(PP.sourceLine pos)
- where
- pos = PE.errorPos perr
+ where
+ pos = PE.errorPos perr
legacyFields :: [Fields.Field Parsec.Position] -> [Field]
legacyFields = map legacyField
legacyField :: Fields.Field Parsec.Position -> Field
legacyField (Fields.Field (Fields.Name pos name) fls) =
- F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls)
+ F (posToLineNo pos) (fromUTF8BS name) (Fields.fieldLinesToString fls)
legacyField (Fields.Section (Fields.Name pos name) args fs) =
- Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs)
+ Section (posToLineNo pos) (fromUTF8BS name) (Fields.sectionArgsToString args) (legacyFields fs)
posToLineNo :: Parsec.Position -> LineNo
posToLineNo (Parsec.Position row _) = row
@@ -346,8 +444,10 @@ parseHaskellString =
parseTokenQ :: ReadP r String
parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')
-parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
- -> ReadP r [a]
+parseSpaceList
+ :: ReadP r a
+ -- ^ The parser for the stuff between commas
+ -> ReadP r [a]
parseSpaceList p = sepBy p skipSpaces
-- This version avoid parse ambiguity for list element parsers
@@ -356,9 +456,12 @@ parseOptCommaList :: ReadP r a -> ReadP r [a]
parseOptCommaList p = sepBy p localSep
where
-- The separator must not be empty or it introduces ambiguity
- localSep = (skipSpaces >> char ',' >> skipSpaces)
- +++ (satisfy isSpace >> skipSpaces)
+ localSep =
+ (skipSpaces >> char ',' >> skipSpaces)
+ +++ (satisfy isSpace >> skipSpaces)
readPToMaybe :: ReadP a a -> String -> Maybe a
-readPToMaybe p str = listToMaybe [ r | (r,s) <- readP_to_S p str
- , all isSpace s ]
+readPToMaybe p str =
+ listToMaybe
+ [ r | (r, s) <- readP_to_S p str, all isSpace s
+ ]
diff --git a/cabal-install/src/Distribution/Deprecated/ReadP.hs b/cabal-install/src/Distribution/Deprecated/ReadP.hs
index 12cebf38e1ad7acc8e8cb948abb119aea8ff2bcc..f0626d5cfe7cb38685b67c351728d03a5aa68b34 100644
--- a/cabal-install/src/Distribution/Deprecated/ReadP.hs
+++ b/cabal-install/src/Distribution/Deprecated/ReadP.hs
@@ -1,6 +1,10 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
+
+-----------------------------------------------------------------------------
+
-----------------------------------------------------------------------------
+
-- |
--
-- Module : Distribution.Deprecated.ReadP
@@ -24,64 +28,61 @@
--
-- The unit tests have been moved to UnitTest.Distribution.Deprecated.ReadP, by
-- Mark Lentczner <mailto:mark@glyphic.com>
------------------------------------------------------------------------------
-
module Distribution.Deprecated.ReadP
- (
- -- * The 'ReadP' type
- ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
-
- -- * Primitive operations
- get, -- :: ReadP Char
- look, -- :: ReadP String
- (+++), -- :: ReadP a -> ReadP a -> ReadP a
- (<++), -- :: ReadP a -> ReadP a -> ReadP a
- gather, -- :: ReadP a -> ReadP (String, a)
-
- -- * Other operations
- pfail, -- :: ReadP a
- eof, -- :: ReadP ()
- satisfy, -- :: (Char -> Bool) -> ReadP Char
- char, -- :: Char -> ReadP Char
- string, -- :: String -> ReadP String
- munch, -- :: (Char -> Bool) -> ReadP String
- munch1, -- :: (Char -> Bool) -> ReadP String
- skipSpaces, -- :: ReadP ()
- skipSpaces1,-- :: ReadP ()
- choice, -- :: [ReadP a] -> ReadP a
- count, -- :: Int -> ReadP a -> ReadP [a]
- between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
- option, -- :: a -> ReadP a -> ReadP a
- optional, -- :: ReadP a -> ReadP ()
- many, -- :: ReadP a -> ReadP [a]
- many1, -- :: ReadP a -> ReadP [a]
- skipMany, -- :: ReadP a -> ReadP ()
- skipMany1, -- :: ReadP a -> ReadP ()
- sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
- sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
- endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
- endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
- chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
- chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
- chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
- chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
- manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
-
- -- * Running a parser
- ReadS, -- :: *; = String -> [(a,String)]
- readP_to_S, -- :: ReadP a -> ReadS a
- readS_to_P, -- :: ReadS a -> ReadP a
- readP_to_E,
-
- -- ** Internal
- Parser,
+ ( -- * The 'ReadP' type
+ ReadP -- :: * -> *; instance Functor, Monad, MonadPlus
+
+ -- * Primitive operations
+ , get -- :: ReadP Char
+ , look -- :: ReadP String
+ , (+++) -- :: ReadP a -> ReadP a -> ReadP a
+ , (<++) -- :: ReadP a -> ReadP a -> ReadP a
+ , gather -- :: ReadP a -> ReadP (String, a)
+
+ -- * Other operations
+ , pfail -- :: ReadP a
+ , eof -- :: ReadP ()
+ , satisfy -- :: (Char -> Bool) -> ReadP Char
+ , char -- :: Char -> ReadP Char
+ , string -- :: String -> ReadP String
+ , munch -- :: (Char -> Bool) -> ReadP String
+ , munch1 -- :: (Char -> Bool) -> ReadP String
+ , skipSpaces -- :: ReadP ()
+ , skipSpaces1 -- :: ReadP ()
+ , choice -- :: [ReadP a] -> ReadP a
+ , count -- :: Int -> ReadP a -> ReadP [a]
+ , between -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
+ , option -- :: a -> ReadP a -> ReadP a
+ , optional -- :: ReadP a -> ReadP ()
+ , many -- :: ReadP a -> ReadP [a]
+ , many1 -- :: ReadP a -> ReadP [a]
+ , skipMany -- :: ReadP a -> ReadP ()
+ , skipMany1 -- :: ReadP a -> ReadP ()
+ , sepBy -- :: ReadP a -> ReadP sep -> ReadP [a]
+ , sepBy1 -- :: ReadP a -> ReadP sep -> ReadP [a]
+ , endBy -- :: ReadP a -> ReadP sep -> ReadP [a]
+ , endBy1 -- :: ReadP a -> ReadP sep -> ReadP [a]
+ , chainr -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+ , chainl -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+ , chainl1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+ , chainr1 -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+ , manyTill -- :: ReadP a -> ReadP end -> ReadP [a]
+
+ -- * Running a parser
+ , ReadS -- :: *; = String -> [(a,String)]
+ , readP_to_S -- :: ReadP a -> ReadS a
+ , readS_to_P -- :: ReadS a -> ReadP a
+ , readP_to_E
+
+ -- ** Internal
+ , Parser
)
- where
+where
+import Distribution.Client.Compat.Prelude hiding (get, many)
import Prelude ()
-import Distribution.Client.Compat.Prelude hiding (many, get)
-import Control.Monad( replicateM, (>=>) )
+import Control.Monad (replicateM, (>=>))
import qualified Control.Monad.Fail as Fail
@@ -98,7 +99,7 @@ data P s a
| Look ([s] -> P s a)
| Fail
| Result a (P s a)
- | Final [(a,[s])] -- invariant: list is non-empty!
+ | Final [(a, [s])] -- invariant: list is non-empty!
-- Monad, MonadPlus
@@ -112,11 +113,11 @@ instance Applicative (P s) where
instance Monad (P s) where
return = pure
- (Get f) >>= k = Get (f >=> k)
- (Look f) >>= k = Look (f >=> k)
- Fail >>= _ = Fail
+ (Get f) >>= k = Get (f >=> k)
+ (Look f) >>= k = Look (f >=> k)
+ Fail >>= _ = Fail
(Result x p) >>= k = k x `mplus` (p >>= k)
- (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
+ (Final r) >>= k = final [ys' | (x, s) <- r, ys' <- run (k x) s]
#if !(MIN_VERSION_base(4,9,0))
fail _ = Fail
@@ -128,37 +129,33 @@ instance Fail.MonadFail (P s) where
fail _ = Fail
instance Alternative (P s) where
- empty = mzero
- (<|>) = mplus
+ empty = mzero
+ (<|>) = mplus
instance MonadPlus (P s) where
mzero = Fail
-- most common case: two gets are combined
- Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
-
+ Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` 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 `mplus` q = Result x (p `mplus` q)
+ p `mplus` Result x q = Result x (p `mplus` q)
-- fail disappears
- Fail `mplus` p = p
- p `mplus` Fail = p
-
+ Fail `mplus` p = p
+ p `mplus` 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 `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))
-- 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 `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)
-- ---------------------------------------------------------------------------
-- The ReadP type
@@ -172,7 +169,7 @@ instance Functor (Parser r s) where
fmap h (R f) = R (\k -> f (k . h))
instance Applicative (Parser r s) where
- pure x = R (\k -> k x)
+ pure x = R (\k -> k x)
(<*>) = ap
instance s ~ Char => Alternative (Parser r s) where
@@ -190,7 +187,7 @@ instance Monad (Parser r s) where
#endif
instance Fail.MonadFail (Parser r s) where
- fail _ = R (const Fail)
+ fail _ = R (const Fail)
instance s ~ Char => MonadPlus (Parser r s) where
mzero = pfail
@@ -199,17 +196,17 @@ instance s ~ Char => MonadPlus (Parser r s) where
-- ---------------------------------------------------------------------------
-- Operations over P
-final :: [(a,[s])] -> P s a
+final :: [(a, [s])] -> P s a
-- Maintains invariant for Final constructor
final [] = Fail
-final r = Final r
+final r = Final r
run :: P c a -> ([c] -> [(a, [c])])
-run (Get f) (c:s) = run (f c) s
-run (Look f) s = run (f s) s
-run (Result x p) s = (x,s) : run p s
-run (Final r) _ = r
-run _ _ = []
+run (Get f) (c : s) = run (f c) s
+run (Look f) s = run (f s) s
+run (Result x p) s = (x, s) : run p s
+run (Final r) _ = r
+run _ _ = []
-- ---------------------------------------------------------------------------
-- Operations over ReadP
@@ -230,9 +227,11 @@ pfail = R (const Fail)
eof :: ReadP r ()
-- ^ Succeeds iff we are at the end of input
-eof = do { s <- look
- ; if null s then return ()
- else pfail }
+eof = do
+ s <- look
+ if null s
+ then return ()
+ else pfail
(+++) :: ReadP r a -> ReadP r a -> ReadP r a
-- ^ Symmetric choice.
@@ -243,17 +242,18 @@ R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
-- locally produces any result at all, then right parser is
-- not used.
R f <++ q =
- do s <- look
- probe (f return) s 0
- where
- probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int)
- probe (Look f') s n = probe (f' s) s n
- probe p@(Result _ _) _ n = discard n >> R (p >>=)
- probe (Final r) _ _ = R (Final r >>=)
- probe _ _ _ = q
-
- discard 0 = return ()
- discard n = get >> discard (n-1 :: Int)
+ do
+ s <- look
+ probe (f return) s 0
+ where
+ probe (Get f') (c : s) n = probe (f' c) s (n + 1 :: Int)
+ probe (Look f') s n = probe (f' s) s n
+ probe p@(Result _ _) _ n = discard n >> R (p >>=)
+ probe (Final r) _ _ = R (Final r >>=)
+ probe _ _ _ = q
+
+ discard 0 = return ()
+ discard n = get >> discard (n - 1 :: Int)
gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
-- ^ Transforms a parser into one that does the same, but
@@ -261,13 +261,13 @@ gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
-- is built using any occurrences of readS_to_P.
gather (R m) =
- R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
- where
- gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
- gath _ Fail = Fail
- gath l (Look f) = Look (gath l . f)
- gath l (Result k p) = k (l []) `mplus` gath l p
- gath _ (Final _) = error "do not use readS_to_P in gather!"
+ R (\k -> gath id (m (\a -> return (\s -> k (s, a)))))
+ where
+ gath l (Get f) = Get (\c -> gath (l . (c :)) (f c))
+ gath _ Fail = Fail
+ gath l (Look f) = Look (gath l . f)
+ gath l (Result k p) = k (l []) `mplus` gath l p
+ gath _ (Final _) = error "do not use readS_to_P in gather!"
-- ---------------------------------------------------------------------------
-- Derived operations
@@ -284,41 +284,45 @@ char c = satisfy (c ==)
string :: String -> ReadP r String
-- ^ Parses and returns the specified string.
string this = do s <- look; scan this s
- where
- scan [] _ = return this
- scan (x:xs) (y:ys) | x == y = get >> scan xs ys
- scan _ _ = pfail
+ where
+ scan [] _ = return this
+ scan (x : xs) (y : ys) | x == y = get >> scan xs ys
+ scan _ _ = pfail
munch :: (Char -> Bool) -> ReadP r String
-- ^ Parses the first zero or more characters satisfying the predicate.
munch p =
- do s <- look
- scan s
- where
- scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
- scan _ = do return ""
+ do
+ s <- look
+ scan s
+ where
+ scan (c : cs) | p c = do _ <- get; s <- scan cs; return (c : s)
+ scan _ = do return ""
munch1 :: (Char -> Bool) -> ReadP r String
-- ^ Parses the first one or more characters satisfying the predicate.
munch1 p =
- do c <- get
- if p c then do s <- munch p; return (c:s)
- else pfail
+ do
+ c <- get
+ if p c
+ then do s <- munch p; return (c : s)
+ else pfail
choice :: [ReadP r a] -> ReadP r a
-- ^ Combines all parsers in the specified list.
-choice [] = pfail
-choice [p] = p
-choice (p:ps) = p +++ choice ps
+choice [] = pfail
+choice [p] = p
+choice (p : ps) = p +++ choice ps
skipSpaces :: ReadP r ()
-- ^ Skips all whitespace.
skipSpaces =
- do s <- look
- skip s
- where
- skip (c:s) | isSpace c = do _ <- get; skip s
- skip _ = do return ()
+ do
+ s <- look
+ skip s
+ where
+ skip (c : s) | isSpace c = do _ <- get; skip s
+ skip _ = do return ()
skipSpaces1 :: ReadP r ()
-- ^ Like 'skipSpaces' but succeeds only if there is at least one
@@ -333,10 +337,11 @@ count n p = replicateM n p
between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
-- ^ @ between open close p @ parses @open@, followed by @p@ and finally
-- @close@. Only the value of @p@ is returned.
-between open close p = do _ <- open
- x <- p
- _ <- close
- return x
+between open close p = do
+ _ <- open
+ x <- p
+ _ <- close
+ return x
option :: a -> ReadP r a -> ReadP r a
-- ^ @option x p@ will either parse @p@ or return @x@ without consuming
@@ -376,12 +381,12 @@ sepBy1 p sep = liftM2 (:) p (many (sep >> p))
endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
-- by @sep@.
-endBy p sep = many (do x <- p ; _ <- sep ; return x)
+endBy p sep = many (do x <- p; _ <- sep; return x)
endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
-- by @sep@.
-endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
+endBy1 p sep = many1 (do x <- p; _ <- sep; return x)
chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
@@ -400,25 +405,32 @@ chainl p op x = chainl1 p op +++ return x
chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
-- ^ Like 'chainr', but parses one or more occurrences of @p@.
chainr1 p op = scan
- where scan = p >>= rest
- rest x = do f <- op
- y <- scan
- return (f x y)
- +++ return x
+ where
+ scan = p >>= rest
+ rest x =
+ do
+ f <- op
+ y <- scan
+ return (f x y)
+ +++ return x
chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
-- ^ Like 'chainl', but parses one or more occurrences of @p@.
chainl1 p op = p >>= rest
- where rest x = do f <- op
- y <- p
- rest (f x y)
- +++ return x
+ where
+ rest x =
+ do
+ f <- op
+ y <- p
+ rest (f x y)
+ +++ return x
manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
-- succeeds. Returns a list of values returned by @p@.
manyTill p end = scan
- where scan = (end >> return []) <++ (liftM2 (:) p scan)
+ where
+ scan = (end >> return []) <++ (liftM2 (:) p scan)
-- ---------------------------------------------------------------------------
-- Converting between ReadP and Read
@@ -435,7 +447,7 @@ readS_to_P :: ReadS a -> ReadP r a
-- Warning: This introduces local backtracking in the resulting
-- parser, and therefore a possible inefficiency.
readS_to_P r =
- R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
+ R (\k -> Look (\s -> final [bs'' | (a, s') <- r s, bs'' <- run (k a) s']))
-------------------------------------------------------------------------------
-- ReadE
@@ -443,7 +455,7 @@ readS_to_P r =
readP_to_E :: (String -> String) -> ReadP a a -> ReadE a
readP_to_E err r =
- ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt
- , all isSpace s ]
- of [] -> Left (err txt)
- (p:_) -> Right p
+ ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt, all isSpace s
+ ] of
+ [] -> Left (err txt)
+ (p : _) -> Right p
diff --git a/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs b/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs
index 6129109d58e38fc456261a65fdd51f4897bb8193..35c2564e53150d751a255ee064ee905b5d34aad2 100644
--- a/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs
+++ b/cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs
@@ -1,15 +1,15 @@
-module Distribution.Deprecated.ViewAsFieldDescr (
- viewAsFieldDescr
- ) where
+module Distribution.Deprecated.ViewAsFieldDescr
+ ( viewAsFieldDescr
+ ) where
import Distribution.Client.Compat.Prelude hiding (get)
import Prelude ()
import qualified Data.List.NonEmpty as NE
-import Distribution.ReadE (parsecToReadE)
+import Distribution.ReadE (parsecToReadE)
import Distribution.Simple.Command
-import Text.PrettyPrint (cat, comma, punctuate, text)
-import Text.PrettyPrint as PP (empty)
+import Text.PrettyPrint (cat, comma, punctuate, text)
+import Text.PrettyPrint as PP (empty)
import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError)
@@ -18,66 +18,62 @@ import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError)
viewAsFieldDescr :: OptionField a -> FieldDescr a
viewAsFieldDescr (OptionField _n []) =
error "Distribution.command.viewAsFieldDescr: unexpected"
-viewAsFieldDescr (OptionField n (d:dd)) = FieldDescr n get set
-
- where
- optDescr = head $ NE.sortBy cmp (d:|dd)
-
- cmp :: OptDescr a -> OptDescr a -> Ordering
- ReqArg{} `cmp` ReqArg{} = EQ
- ReqArg{} `cmp` _ = GT
- BoolOpt{} `cmp` ReqArg{} = LT
- BoolOpt{} `cmp` BoolOpt{} = EQ
- BoolOpt{} `cmp` _ = GT
- ChoiceOpt{} `cmp` ReqArg{} = LT
- ChoiceOpt{} `cmp` BoolOpt{} = LT
- ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
- ChoiceOpt{} `cmp` _ = GT
- OptArg{} `cmp` OptArg{} = EQ
- OptArg{} `cmp` _ = LT
-
--- get :: a -> Doc
- get t = case optDescr of
- ReqArg _ _ _ _ ppr ->
- (cat . punctuate comma . map text . ppr) t
-
- OptArg _ _ _ _ _ ppr ->
- case ppr t of [] -> PP.empty
- (Nothing : _) -> text "True"
- (Just a : _) -> text a
-
- ChoiceOpt alts ->
- fromMaybe PP.empty $ listToMaybe
- [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]
-
- BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t
-
--- set :: LineNo -> String -> a -> ParseResult a
- set line val a =
- case optDescr of
- ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
- -- We parse for a single value instead of a
- -- list, as one can't really implement
- -- parseList :: ReadE a -> ReadE [a] with
- -- the current ReadE definition
- ChoiceOpt{} ->
- case getChoiceByLongFlag optDescr val of
- Just f -> return (f a)
- _ -> syntaxError line val
-
- BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val
-
- OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
- -- Optional arguments are parsed just like
- -- required arguments here; we don't
- -- provide a method to set an OptArg field
- -- to the default value.
+viewAsFieldDescr (OptionField n (d : dd)) = FieldDescr n get set
+ where
+ optDescr = head $ NE.sortBy cmp (d :| dd)
+
+ cmp :: OptDescr a -> OptDescr a -> Ordering
+ ReqArg{} `cmp` ReqArg{} = EQ
+ ReqArg{} `cmp` _ = GT
+ BoolOpt{} `cmp` ReqArg{} = LT
+ BoolOpt{} `cmp` BoolOpt{} = EQ
+ BoolOpt{} `cmp` _ = GT
+ ChoiceOpt{} `cmp` ReqArg{} = LT
+ ChoiceOpt{} `cmp` BoolOpt{} = LT
+ ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
+ ChoiceOpt{} `cmp` _ = GT
+ OptArg{} `cmp` OptArg{} = EQ
+ OptArg{} `cmp` _ = LT
+
+ -- get :: a -> Doc
+ get t = case optDescr of
+ ReqArg _ _ _ _ ppr ->
+ (cat . punctuate comma . map text . ppr) t
+ OptArg _ _ _ _ _ ppr ->
+ case ppr t of
+ [] -> PP.empty
+ (Nothing : _) -> text "True"
+ (Just a : _) -> text a
+ ChoiceOpt alts ->
+ fromMaybe PP.empty $
+ listToMaybe
+ [text lf | (_, (_, lf : _), _, enabled) <- alts, enabled t]
+ BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t
+
+ -- set :: LineNo -> String -> a -> ParseResult a
+ set line val a =
+ case optDescr of
+ ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
+ -- We parse for a single value instead of a
+ -- list, as one can't really implement
+ -- parseList :: ReadE a -> ReadE [a] with
+ -- the current ReadE definition
+ ChoiceOpt{} ->
+ case getChoiceByLongFlag optDescr val of
+ Just f -> return (f a)
+ _ -> syntaxError line val
+ BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val
+ OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
+
+-- Optional arguments are parsed just like
+-- required arguments here; we don't
+-- provide a method to set an OptArg field
+-- to the default value.
getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a)
-getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe
- [ set | (_,(_sf,lf:_), set, _) <- alts
- , lf == val]
-
+getChoiceByLongFlag (ChoiceOpt alts) val =
+ listToMaybe
+ [ set | (_, (_sf, lf : _), set, _) <- alts, lf == val
+ ]
getChoiceByLongFlag _ _ =
error "Distribution.command.getChoiceByLongFlag: expected a choice option"
-
diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs
index 2f6825f983eeb7739ead4f415fe720184c771894..399fcecdc7c3e44e14e875c24aded363865e10db 100644
--- a/cabal-install/tests/IntegrationTests2.hs
+++ b/cabal-install/tests/IntegrationTests2.hs
@@ -1,3 +1,4 @@
+{- FOURMOLU_DISABLE -}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
diff --git a/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs b/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs
index 9a994af677b0dfd41b4e3b76b3e7e604003d64e1..e8ef27dbba9992f80d9271a60892aadc63c9ef36 100644
--- a/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs
+++ b/cabal-install/tests/IntegrationTests2/build/ignore-project/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain
diff --git a/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs b/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs
index ebab708a32954b74b49b288cfdf8c6d54f42cfc7..4258d9b61ef131aad744ff6781b4bcbac6c001bb 100644
--- a/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs
+++ b/cabal-install/tests/IntegrationTests2/build/setup-custom1/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain >> writeFile "marker" "ok"
diff --git a/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs b/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs
index ebab708a32954b74b49b288cfdf8c6d54f42cfc7..4258d9b61ef131aad744ff6781b4bcbac6c001bb 100644
--- a/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs
+++ b/cabal-install/tests/IntegrationTests2/build/setup-custom2/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain >> writeFile "marker" "ok"
diff --git a/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs b/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs
index 9a994af677b0dfd41b4e3b76b3e7e604003d64e1..e8ef27dbba9992f80d9271a60892aadc63c9ef36 100644
--- a/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs
+++ b/cabal-install/tests/IntegrationTests2/build/setup-simple/Setup.hs
@@ -1,2 +1,3 @@
import Distribution.Simple
+
main = defaultMain
diff --git a/cabal-install/tests/LongTests.hs b/cabal-install/tests/LongTests.hs
index db036bdf57c4d72add8711fd3035f50f8a2b794c..0c315046780b72260e392d9d1185cdfe605dd1ea 100644
--- a/cabal-install/tests/LongTests.hs
+++ b/cabal-install/tests/LongTests.hs
@@ -1,46 +1,49 @@
module Main (main) where
-
import Test.Tasty
+import Distribution.Compat.Time
import Distribution.Simple.Utils
import Distribution.Verbosity
-import Distribution.Compat.Time
+import qualified UnitTests.Distribution.Client.Described
import qualified UnitTests.Distribution.Client.FileMonitor
import qualified UnitTests.Distribution.Client.VCS
import qualified UnitTests.Distribution.Solver.Modular.QuickCheck
-import qualified UnitTests.Distribution.Client.Described
import UnitTests.Options
-
main :: IO ()
main = do
(mtimeChange, mtimeChange') <- calibrateMtimeChangeDelay
let toMillis :: Int -> Double
toMillis x = fromIntegral x / 1000.0
- notice normal $ "File modification time resolution calibration completed, "
- ++ "maximum delay observed: "
- ++ (show . toMillis $ mtimeChange ) ++ " ms. "
- ++ "Will be using delay of " ++ (show . toMillis $ mtimeChange')
- ++ " for test runs."
+ notice normal $
+ "File modification time resolution calibration completed, "
+ ++ "maximum delay observed: "
+ ++ (show . toMillis $ mtimeChange)
+ ++ " ms. "
+ ++ "Will be using delay of "
+ ++ (show . toMillis $ mtimeChange')
+ ++ " for test runs."
defaultMainWithIngredients
- (includingOptions extraOptions : defaultIngredients)
- (tests mtimeChange')
-
+ (includingOptions extraOptions : defaultIngredients)
+ (tests mtimeChange')
tests :: Int -> TestTree
tests mtimeChangeCalibrated =
askOption $ \(OptionMtimeChangeDelay mtimeChangeProvided) ->
- let mtimeChange = if mtimeChangeProvided /= 0
- then mtimeChangeProvided
- else mtimeChangeCalibrated
- in testGroup "Long-running tests"
- [ testGroup "Solver QuickCheck"
- UnitTests.Distribution.Solver.Modular.QuickCheck.tests
- , testGroup "UnitTests.Distribution.Client.VCS" $
- UnitTests.Distribution.Client.VCS.tests mtimeChange
- , testGroup "UnitTests.Distribution.Client.FileMonitor" $
- UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
- , UnitTests.Distribution.Client.Described.tests
- ]
+ let mtimeChange =
+ if mtimeChangeProvided /= 0
+ then mtimeChangeProvided
+ else mtimeChangeCalibrated
+ in testGroup
+ "Long-running tests"
+ [ testGroup
+ "Solver QuickCheck"
+ UnitTests.Distribution.Solver.Modular.QuickCheck.tests
+ , testGroup "UnitTests.Distribution.Client.VCS" $
+ UnitTests.Distribution.Client.VCS.tests mtimeChange
+ , testGroup "UnitTests.Distribution.Client.FileMonitor" $
+ UnitTests.Distribution.Client.FileMonitor.tests mtimeChange
+ , UnitTests.Distribution.Client.Described.tests
+ ]
diff --git a/cabal-install/tests/MemoryUsageTests.hs b/cabal-install/tests/MemoryUsageTests.hs
index 0012feab1160a050aeabb5e0ba9620447ef2f174..3d9b594959050442f4bf88a2a577f473a9dade4c 100644
--- a/cabal-install/tests/MemoryUsageTests.hs
+++ b/cabal-install/tests/MemoryUsageTests.hs
@@ -6,10 +6,12 @@ import qualified UnitTests.Distribution.Solver.Modular.MemoryUsage
tests :: TestTree
tests =
- testGroup "Memory Usage"
- [ testGroup "UnitTests.Distribution.Solver.Modular.MemoryUsage"
+ testGroup
+ "Memory Usage"
+ [ testGroup
+ "UnitTests.Distribution.Solver.Modular.MemoryUsage"
UnitTests.Distribution.Solver.Modular.MemoryUsage.tests
- ]
+ ]
main :: IO ()
main = defaultMain tests
diff --git a/cabal-install/tests/UnitTests.hs b/cabal-install/tests/UnitTests.hs
index c321f07eb379045adecaa3b693929a506ab4ac29..8434f623e82084988e7b8e5d18b5dc9e966dc618 100644
--- a/cabal-install/tests/UnitTests.hs
+++ b/cabal-install/tests/UnitTests.hs
@@ -1,14 +1,13 @@
module Main (main) where
-
import Test.Tasty
import qualified UnitTests.Distribution.Client.BuildReport
import qualified UnitTests.Distribution.Client.Configure
import qualified UnitTests.Distribution.Client.FetchUtils
+import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.Get
import qualified UnitTests.Distribution.Client.Glob
-import qualified UnitTests.Distribution.Client.GZipUtils
import qualified UnitTests.Distribution.Client.IndexUtils
import qualified UnitTests.Distribution.Client.IndexUtils.Timestamp
import qualified UnitTests.Distribution.Client.Init
@@ -29,49 +28,73 @@ import qualified UnitTests.Distribution.Solver.Types.OptionalStanza
main :: IO ()
main = do
initTests <- UnitTests.Distribution.Client.Init.tests
- defaultMain $ testGroup "Unit Tests"
- [ testGroup "UnitTests.Distribution.Client.BuildReport"
- UnitTests.Distribution.Client.BuildReport.tests
- , testGroup "UnitTests.Distribution.Client.Configure"
- UnitTests.Distribution.Client.Configure.tests
- , testGroup "UnitTests.Distribution.Client.FetchUtils"
- UnitTests.Distribution.Client.FetchUtils.tests
- , testGroup "UnitTests.Distribution.Client.Get"
- UnitTests.Distribution.Client.Get.tests
- , testGroup "UnitTests.Distribution.Client.Glob"
- UnitTests.Distribution.Client.Glob.tests
- , testGroup "Distribution.Client.GZipUtils"
- UnitTests.Distribution.Client.GZipUtils.tests
- , testGroup "UnitTests.Distribution.Client.IndexUtils"
- UnitTests.Distribution.Client.IndexUtils.tests
- , testGroup "UnitTests.Distribution.Client.IndexUtils.Timestamp"
- UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
- , testGroup "Distribution.Client.Init"
- initTests
- , testGroup "UnitTests.Distribution.Client.InstallPlan"
- UnitTests.Distribution.Client.InstallPlan.tests
- , testGroup "UnitTests.Distribution.Client.JobControl"
- UnitTests.Distribution.Client.JobControl.tests
- , testGroup "UnitTests.Distribution.Client.ProjectConfig"
- UnitTests.Distribution.Client.ProjectConfig.tests
- , testGroup "UnitTests.Distribution.Client.ProjectPlanning"
- UnitTests.Distribution.Client.ProjectPlanning.tests
- , testGroup "Distribution.Client.Store"
- UnitTests.Distribution.Client.Store.tests
- , testGroup "Distribution.Client.Tar"
- UnitTests.Distribution.Client.Tar.tests
- , testGroup "Distribution.Client.Targets"
- UnitTests.Distribution.Client.Targets.tests
- , testGroup "UnitTests.Distribution.Client.UserConfig"
- UnitTests.Distribution.Client.UserConfig.tests
- , testGroup "UnitTests.Distribution.Solver.Modular.Builder"
- UnitTests.Distribution.Solver.Modular.Builder.tests
- , testGroup "UnitTests.Distribution.Solver.Modular.RetryLog"
- UnitTests.Distribution.Solver.Modular.RetryLog.tests
- , testGroup "UnitTests.Distribution.Solver.Modular.Solver"
- UnitTests.Distribution.Solver.Modular.Solver.tests
- , testGroup "UnitTests.Distribution.Solver.Modular.WeightedPSQ"
- UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests
- , testGroup "UnitTests.Distribution.Solver.Types.OptionalStanza"
- UnitTests.Distribution.Solver.Types.OptionalStanza.tests
- ]
+ defaultMain $
+ testGroup
+ "Unit Tests"
+ [ testGroup
+ "UnitTests.Distribution.Client.BuildReport"
+ UnitTests.Distribution.Client.BuildReport.tests
+ , testGroup
+ "UnitTests.Distribution.Client.Configure"
+ UnitTests.Distribution.Client.Configure.tests
+ , testGroup
+ "UnitTests.Distribution.Client.FetchUtils"
+ UnitTests.Distribution.Client.FetchUtils.tests
+ , testGroup
+ "UnitTests.Distribution.Client.Get"
+ UnitTests.Distribution.Client.Get.tests
+ , testGroup
+ "UnitTests.Distribution.Client.Glob"
+ UnitTests.Distribution.Client.Glob.tests
+ , testGroup
+ "Distribution.Client.GZipUtils"
+ UnitTests.Distribution.Client.GZipUtils.tests
+ , testGroup
+ "UnitTests.Distribution.Client.IndexUtils"
+ UnitTests.Distribution.Client.IndexUtils.tests
+ , testGroup
+ "UnitTests.Distribution.Client.IndexUtils.Timestamp"
+ UnitTests.Distribution.Client.IndexUtils.Timestamp.tests
+ , testGroup
+ "Distribution.Client.Init"
+ initTests
+ , testGroup
+ "UnitTests.Distribution.Client.InstallPlan"
+ UnitTests.Distribution.Client.InstallPlan.tests
+ , testGroup
+ "UnitTests.Distribution.Client.JobControl"
+ UnitTests.Distribution.Client.JobControl.tests
+ , testGroup
+ "UnitTests.Distribution.Client.ProjectConfig"
+ UnitTests.Distribution.Client.ProjectConfig.tests
+ , testGroup
+ "UnitTests.Distribution.Client.ProjectPlanning"
+ UnitTests.Distribution.Client.ProjectPlanning.tests
+ , testGroup
+ "Distribution.Client.Store"
+ UnitTests.Distribution.Client.Store.tests
+ , testGroup
+ "Distribution.Client.Tar"
+ UnitTests.Distribution.Client.Tar.tests
+ , testGroup
+ "Distribution.Client.Targets"
+ UnitTests.Distribution.Client.Targets.tests
+ , testGroup
+ "UnitTests.Distribution.Client.UserConfig"
+ UnitTests.Distribution.Client.UserConfig.tests
+ , testGroup
+ "UnitTests.Distribution.Solver.Modular.Builder"
+ UnitTests.Distribution.Solver.Modular.Builder.tests
+ , testGroup
+ "UnitTests.Distribution.Solver.Modular.RetryLog"
+ UnitTests.Distribution.Solver.Modular.RetryLog.tests
+ , testGroup
+ "UnitTests.Distribution.Solver.Modular.Solver"
+ UnitTests.Distribution.Solver.Modular.Solver.tests
+ , testGroup
+ "UnitTests.Distribution.Solver.Modular.WeightedPSQ"
+ UnitTests.Distribution.Solver.Modular.WeightedPSQ.tests
+ , testGroup
+ "UnitTests.Distribution.Solver.Types.OptionalStanza"
+ UnitTests.Distribution.Solver.Types.OptionalStanza.tests
+ ]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
index 3a26ca2e56049ae7a677350ee44a59f90f83d56e..d6a85d960ca471cdae1cd65cd82b65ece3eb4093 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ArbitraryInstances.hs
@@ -1,22 +1,24 @@
{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module UnitTests.Distribution.Client.ArbitraryInstances (
- adjustSize,
- shortListOf,
- shortListOf1,
- arbitraryFlag,
- ShortToken(..),
- arbitraryShortToken,
- NonMEmpty(..),
- NoShrink(..),
+
+module UnitTests.Distribution.Client.ArbitraryInstances
+ ( adjustSize
+ , shortListOf
+ , shortListOf1
+ , arbitraryFlag
+ , ShortToken (..)
+ , arbitraryShortToken
+ , NonMEmpty (..)
+ , NoShrink (..)
+
-- * Shrinker
- Shrinker,
- runShrinker,
- shrinker,
- shrinkerPP,
- shrinkerAla,
+ , Shrinker
+ , runShrinker
+ , shrinker
+ , shrinkerPP
+ , shrinkerAla
) where
import Distribution.Client.Compat.Prelude
@@ -26,23 +28,23 @@ import Data.Char (isLetter)
import Data.List ((\\))
import Distribution.Simple.Setup
-import Distribution.Types.Flag (mkFlagAssignment)
+import Distribution.Types.Flag (mkFlagAssignment)
-import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..))
+import Distribution.Client.BuildReports.Types (BuildReport, InstallOutcome, Outcome, ReportLevel (..))
import Distribution.Client.CmdInstall.ClientInstallFlags (InstallMethod)
-import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..))
-import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
-import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
-import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
+import Distribution.Client.Glob (FilePathGlob (..), FilePathGlobRel (..), FilePathRoot (..), GlobPiece (..))
+import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry (..), ActiveRepos (..), CombineStrategy (..))
+import Distribution.Client.IndexUtils.IndexState (RepoIndexState (..), TotalIndexState, makeTotalIndexState)
+import Distribution.Client.IndexUtils.Timestamp (Timestamp, epochTimeToTimestamp)
import Distribution.Client.Targets
-import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy)
+import Distribution.Client.Types (RepoName (..), WriteGhcEnvironmentFilesPolicy)
import Distribution.Client.Types.AllowNewer
-import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
-import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate)
-import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
+import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
+import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..), OptionalStanzaMap, OptionalStanzaSet, optStanzaSetFromList, optStanzaTabulate)
+import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
-import Data.Coerce (Coercible, coerce)
-import Network.URI (URI (..), URIAuth (..), isUnreserved)
+import Data.Coerce (Coercible, coerce)
+import Network.URI (URI (..), URIAuth (..), isUnreserved)
import Test.QuickCheck
import Test.QuickCheck.GenericArbitrary
import Test.QuickCheck.Instances.Cabal ()
@@ -57,12 +59,12 @@ import Test.QuickCheck.Instances.Cabal ()
data Shrinker a = Shrinker a [a]
instance Functor Shrinker where
- fmap f (Shrinker x xs) = Shrinker (f x) (map f xs)
+ fmap f (Shrinker x xs) = Shrinker (f x) (map f xs)
instance Applicative Shrinker where
- pure x = Shrinker x []
+ pure x = Shrinker x []
- Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs)
+ Shrinker f fs <*> Shrinker x xs = Shrinker (f x) (map f xs ++ map ($ x) fs)
runShrinker :: Shrinker a -> [a]
runShrinker (Shrinker _ xs) = xs
@@ -82,26 +84,28 @@ shrinkerPP pack unpack x = Shrinker x (map unpack (shrink (pack x)))
-------------------------------------------------------------------------------
instance Arbitrary URI where
- arbitrary =
- URI <$> elements ["file:", "http:", "https:"]
- <*> (Just <$> arbitrary)
- <*> (('/':) <$> arbitraryURIToken)
- <*> (('?':) <$> arbitraryURIToken)
- <*> pure ""
+ arbitrary =
+ URI
+ <$> elements ["file:", "http:", "https:"]
+ <*> (Just <$> arbitrary)
+ <*> (('/' :) <$> arbitraryURIToken)
+ <*> (('?' :) <$> arbitraryURIToken)
+ <*> pure ""
instance Arbitrary URIAuth where
- arbitrary =
- URIAuth <$> pure "" -- no password as this does not roundtrip
- <*> arbitraryURIToken
- <*> arbitraryURIPort
+ arbitrary =
+ URIAuth
+ <$> pure "" -- no password as this does not roundtrip
+ <*> arbitraryURIToken
+ <*> arbitraryURIPort
arbitraryURIToken :: Gen String
arbitraryURIToken =
- shortListOf1 6 (elements (filter isUnreserved ['\0'..'\255']))
+ shortListOf1 6 (elements (filter isUnreserved ['\0' .. '\255']))
arbitraryURIPort :: Gen String
arbitraryURIPort =
- oneof [ pure "", (':':) <$> shortListOf1 4 (choose ('0','9')) ]
+ oneof [pure "", (':' :) <$> shortListOf1 4 (choose ('0', '9'))]
-------------------------------------------------------------------------------
-- cabal-install (and Cabal) types
@@ -109,228 +113,244 @@ arbitraryURIPort =
shrinkBoundedEnum :: (Eq a, Enum a, Bounded a) => a -> [a]
shrinkBoundedEnum x
- | x == minBound = []
- | otherwise = [pred x]
+ | x == minBound = []
+ | otherwise = [pred x]
adjustSize :: (Int -> Int) -> Gen a -> Gen a
adjustSize adjust gen = sized (\n -> resize (adjust n) gen)
shortListOf :: Int -> Gen a -> Gen [a]
shortListOf bound gen =
- sized $ \n -> do
- k <- choose (0, (n `div` 2) `min` bound)
- vectorOf k gen
+ sized $ \n -> do
+ k <- choose (0, (n `div` 2) `min` bound)
+ vectorOf k gen
shortListOf1 :: Int -> Gen a -> Gen [a]
shortListOf1 bound gen =
- sized $ \n -> do
- k <- choose (1, 1 `max` ((n `div` 2) `min` bound))
- vectorOf k gen
+ sized $ \n -> do
+ k <- choose (1, 1 `max` ((n `div` 2) `min` bound))
+ vectorOf k gen
-newtype ShortToken = ShortToken { getShortToken :: String }
- deriving Show
+newtype ShortToken = ShortToken {getShortToken :: String}
+ deriving (Show)
instance Arbitrary ShortToken where
arbitrary =
- ShortToken <$>
- (shortListOf1 5 (choose ('#', '~'))
- `suchThat` (all (`notElem` "{}"))
- `suchThat` (not . ("[]" `isPrefixOf`)))
- --TODO: [code cleanup] need to replace parseHaskellString impl to stop
- -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.
- -- Workaround, don't generate [] as this does not round trip.
+ ShortToken
+ <$> ( shortListOf1 5 (choose ('#', '~'))
+ `suchThat` (all (`notElem` "{}"))
+ `suchThat` (not . ("[]" `isPrefixOf`))
+ )
+
+ -- TODO: [code cleanup] need to replace parseHaskellString impl to stop
+ -- accepting Haskell list syntax [], ['a'] etc, just allow String syntax.
+ -- Workaround, don't generate [] as this does not round trip.
shrink (ShortToken cs) =
- [ ShortToken cs' | cs' <- shrink cs, not (null cs') ]
+ [ShortToken cs' | cs' <- shrink cs, not (null cs')]
arbitraryShortToken :: Gen String
arbitraryShortToken = getShortToken <$> arbitrary
-newtype NonMEmpty a = NonMEmpty { getNonMEmpty :: a }
+newtype NonMEmpty a = NonMEmpty {getNonMEmpty :: a}
deriving (Eq, Ord, Show)
instance (Arbitrary a, Monoid a, Eq a) => Arbitrary (NonMEmpty a) where
arbitrary = NonMEmpty <$> (arbitrary `suchThat` (/= mempty))
- shrink (NonMEmpty x) = [ NonMEmpty x' | x' <- shrink x, x' /= mempty ]
+ shrink (NonMEmpty x) = [NonMEmpty x' | x' <- shrink x, x' /= mempty]
-newtype NoShrink a = NoShrink { getNoShrink :: a }
+newtype NoShrink a = NoShrink {getNoShrink :: a}
deriving (Eq, Ord, Show)
instance Arbitrary a => Arbitrary (NoShrink a) where
- arbitrary = NoShrink <$> arbitrary
- shrink _ = []
+ arbitrary = NoShrink <$> arbitrary
+ shrink _ = []
instance Arbitrary Timestamp where
- -- note: no negative timestamps
- --
- -- >>> utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 100000 01 01) 0
- -- >>> 3093527980800s
- --
- arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary
+ -- note: no negative timestamps
+ --
+ -- >>> utcTimeToPOSIXSeconds $ UTCTime (fromGregorian 100000 01 01) 0
+ -- >>> 3093527980800s
+ --
+ arbitrary = maybe (toEnum 0) id . epochTimeToTimestamp . (`mod` 3093527980800) . abs <$> arbitrary
instance Arbitrary RepoIndexState where
- arbitrary = frequency [ (1, pure IndexStateHead)
- , (50, IndexStateTime <$> arbitrary)
- ]
+ arbitrary =
+ frequency
+ [ (1, pure IndexStateHead)
+ , (50, IndexStateTime <$> arbitrary)
+ ]
instance Arbitrary TotalIndexState where
- arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary
+ arbitrary = makeTotalIndexState <$> arbitrary <*> arbitrary
instance Arbitrary WriteGhcEnvironmentFilesPolicy where
- arbitrary = arbitraryBoundedEnum
+ arbitrary = arbitraryBoundedEnum
arbitraryFlag :: Gen a -> Gen (Flag a)
arbitraryFlag = liftArbitrary
instance Arbitrary RepoName where
- -- TODO: rename refinement?
- arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x) where
+ -- TODO: rename refinement?
+ arbitrary = RepoName <$> (mk `suchThat` \x -> not $ "--" `isPrefixOf` x)
+ where
mk = (:) <$> lead <*> rest
- lead = elements
- [ c | c <- [ '\NUL' .. '\255' ], isAlpha c || c `elem` "_-."]
- rest = listOf (elements
- [ c | c <- [ '\NUL' .. '\255' ], isAlphaNum c || c `elem` "_-."])
+ lead =
+ elements
+ [c | c <- ['\NUL' .. '\255'], isAlpha c || c `elem` "_-."]
+ rest =
+ listOf
+ ( elements
+ [c | c <- ['\NUL' .. '\255'], isAlphaNum c || c `elem` "_-."]
+ )
instance Arbitrary ReportLevel where
- arbitrary = arbitraryBoundedEnum
+ arbitrary = arbitraryBoundedEnum
instance Arbitrary OverwritePolicy where
- arbitrary = arbitraryBoundedEnum
+ arbitrary = arbitraryBoundedEnum
instance Arbitrary InstallMethod where
- arbitrary = arbitraryBoundedEnum
+ arbitrary = arbitraryBoundedEnum
-------------------------------------------------------------------------------
-- ActiveRepos
-------------------------------------------------------------------------------
instance Arbitrary ActiveRepos where
- arbitrary = ActiveRepos <$> shortListOf 5 arbitrary
+ arbitrary = ActiveRepos <$> shortListOf 5 arbitrary
instance Arbitrary ActiveRepoEntry where
- arbitrary = frequency
- [ (10, ActiveRepo <$> arbitrary <*> arbitrary)
- , (1, ActiveRepoRest <$> arbitrary)
- ]
+ arbitrary =
+ frequency
+ [ (10, ActiveRepo <$> arbitrary <*> arbitrary)
+ , (1, ActiveRepoRest <$> arbitrary)
+ ]
instance Arbitrary CombineStrategy where
- arbitrary = arbitraryBoundedEnum
- shrink = shrinkBoundedEnum
+ arbitrary = arbitraryBoundedEnum
+ shrink = shrinkBoundedEnum
-------------------------------------------------------------------------------
-- AllowNewer
-------------------------------------------------------------------------------
instance Arbitrary AllowNewer where
- arbitrary = AllowNewer <$> arbitrary
+ arbitrary = AllowNewer <$> arbitrary
instance Arbitrary AllowOlder where
- arbitrary = AllowOlder <$> arbitrary
+ arbitrary = AllowOlder <$> arbitrary
instance Arbitrary RelaxDeps where
- arbitrary = oneof [ pure mempty
- , mkRelaxDepSome <$> shortListOf1 3 arbitrary
- , pure RelaxDepsAll
- ]
+ arbitrary =
+ oneof
+ [ pure mempty
+ , mkRelaxDepSome <$> shortListOf1 3 arbitrary
+ , pure RelaxDepsAll
+ ]
instance Arbitrary RelaxDepMod where
- arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
+ arbitrary = elements [RelaxDepModNone, RelaxDepModCaret]
- shrink RelaxDepModCaret = [RelaxDepModNone]
- shrink _ = []
+ shrink RelaxDepModCaret = [RelaxDepModNone]
+ shrink _ = []
instance Arbitrary RelaxDepScope where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
instance Arbitrary RelaxDepSubject where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
instance Arbitrary RelaxedDep where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
-------------------------------------------------------------------------------
-- UserConstraint
-------------------------------------------------------------------------------
instance Arbitrary UserConstraintScope where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
instance Arbitrary UserQualifier where
- arbitrary = oneof [ pure UserQualToplevel
- , UserQualSetup <$> arbitrary
-
- -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
- -- , UserQualExe <$> arbitrary <*> arbitrary
- ]
-
+ arbitrary =
+ oneof
+ [ pure UserQualToplevel
+ , UserQualSetup <$> arbitrary
+ -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
+ -- , UserQualExe <$> arbitrary <*> arbitrary
+ ]
instance Arbitrary UserConstraint where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
instance Arbitrary PackageProperty where
- arbitrary = oneof [ PackagePropertyVersion <$> arbitrary
- , pure PackagePropertyInstalled
- , pure PackagePropertySource
- , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary
- , PackagePropertyStanzas . (\x->[x]) <$> arbitrary
- ]
+ arbitrary =
+ oneof
+ [ PackagePropertyVersion <$> arbitrary
+ , pure PackagePropertyInstalled
+ , pure PackagePropertySource
+ , PackagePropertyFlags . mkFlagAssignment <$> shortListOf1 3 arbitrary
+ , PackagePropertyStanzas . (\x -> [x]) <$> arbitrary
+ ]
instance Arbitrary OptionalStanza where
- arbitrary = elements [minBound..maxBound]
+ arbitrary = elements [minBound .. maxBound]
instance Arbitrary OptionalStanzaSet where
- arbitrary = fmap optStanzaSetFromList arbitrary
+ arbitrary = fmap optStanzaSetFromList arbitrary
instance Arbitrary a => Arbitrary (OptionalStanzaMap a) where
- arbitrary = do
- x1 <- arbitrary
- x2 <- arbitrary
- return $ optStanzaTabulate $ \x -> case x of
- TestStanzas -> x1
- BenchStanzas -> x2
+ arbitrary = do
+ x1 <- arbitrary
+ x2 <- arbitrary
+ return $ optStanzaTabulate $ \x -> case x of
+ TestStanzas -> x1
+ BenchStanzas -> x2
-------------------------------------------------------------------------------
-- BuildReport
-------------------------------------------------------------------------------
instance Arbitrary BuildReport where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
instance Arbitrary InstallOutcome where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
instance Arbitrary Outcome where
- arbitrary = genericArbitrary
- shrink = genericShrink
+ arbitrary = genericArbitrary
+ shrink = genericShrink
-------------------------------------------------------------------------------
-- Glob
-------------------------------------------------------------------------------
instance Arbitrary FilePathGlob where
- arbitrary = (FilePathGlob <$> arbitrary <*> arbitrary)
- `suchThat` validFilePathGlob
+ arbitrary =
+ (FilePathGlob <$> arbitrary <*> arbitrary)
+ `suchThat` validFilePathGlob
shrink (FilePathGlob root pathglob) =
[ FilePathGlob root' pathglob'
| (root', pathglob') <- shrink (root, pathglob)
- , validFilePathGlob (FilePathGlob root' pathglob') ]
+ , validFilePathGlob (FilePathGlob root' pathglob')
+ ]
validFilePathGlob :: FilePathGlob -> Bool
validFilePathGlob (FilePathGlob FilePathRelative pathglob) =
case pathglob of
- GlobDirTrailing -> False
- GlobDir [Literal "~"] _ -> False
- GlobDir [Literal (d:":")] _
- | isLetter d -> False
- _ -> True
+ GlobDirTrailing -> False
+ GlobDir [Literal "~"] _ -> False
+ GlobDir [Literal (d : ":")] _
+ | isLetter d -> False
+ _ -> True
validFilePathGlob _ = True
instance Arbitrary FilePathRoot where
@@ -345,45 +365,49 @@ instance Arbitrary FilePathRoot where
unixroot = "/"
windrive = do d <- choose ('A', 'Z'); return (d : ":\\")
- shrink FilePathRelative = []
- shrink (FilePathRoot _) = [FilePathRelative]
- shrink FilePathHomeDir = [FilePathRelative]
-
+ shrink FilePathRelative = []
+ shrink (FilePathRoot _) = [FilePathRelative]
+ shrink FilePathHomeDir = [FilePathRelative]
instance Arbitrary FilePathGlobRel where
arbitrary = sized $ \sz ->
- oneof $ take (max 1 sz)
- [ pure GlobDirTrailing
- , GlobFile <$> (getGlobPieces <$> arbitrary)
- , GlobDir <$> (getGlobPieces <$> arbitrary)
- <*> resize (sz `div` 2) arbitrary
- ]
+ oneof $
+ take
+ (max 1 sz)
+ [ pure GlobDirTrailing
+ , GlobFile <$> (getGlobPieces <$> arbitrary)
+ , GlobDir
+ <$> (getGlobPieces <$> arbitrary)
+ <*> resize (sz `div` 2) arbitrary
+ ]
shrink GlobDirTrailing = []
shrink (GlobFile glob) =
- GlobDirTrailing
- : [ GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob) ]
+ GlobDirTrailing
+ : [GlobFile (getGlobPieces glob') | glob' <- shrink (GlobPieces glob)]
shrink (GlobDir glob pathglob) =
- pathglob
- : GlobFile glob
- : [ GlobDir (getGlobPieces glob') pathglob'
- | (glob', pathglob') <- shrink (GlobPieces glob, pathglob) ]
+ pathglob
+ : GlobFile glob
+ : [ GlobDir (getGlobPieces glob') pathglob'
+ | (glob', pathglob') <- shrink (GlobPieces glob, pathglob)
+ ]
-newtype GlobPieces = GlobPieces { getGlobPieces :: [GlobPiece] }
- deriving Eq
+newtype GlobPieces = GlobPieces {getGlobPieces :: [GlobPiece]}
+ deriving (Eq)
instance Arbitrary GlobPieces where
arbitrary = GlobPieces . mergeLiterals <$> shortListOf1 5 arbitrary
shrink (GlobPieces glob) =
[ GlobPieces (mergeLiterals (getNonEmpty glob'))
- | glob' <- shrink (NonEmpty glob) ]
+ | glob' <- shrink (NonEmpty glob)
+ ]
mergeLiterals :: [GlobPiece] -> [GlobPiece]
-mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a++b) : ps)
+mergeLiterals (Literal a : Literal b : ps) = mergeLiterals (Literal (a ++ b) : ps)
mergeLiterals (Union as : ps) = Union (map mergeLiterals as) : mergeLiterals ps
-mergeLiterals (p:ps) = p : mergeLiterals ps
-mergeLiterals [] = []
+mergeLiterals (p : ps) = p : mergeLiterals ps
+mergeLiterals [] = []
instance Arbitrary GlobPiece where
arbitrary = sized $ \sz ->
@@ -393,13 +417,17 @@ instance Arbitrary GlobPiece where
, (1, Union <$> resize (sz `div` 2) (shortListOf1 5 (shortListOf1 5 arbitrary)))
]
- shrink (Literal str) = [ Literal str'
- | str' <- shrink str
- , not (null str')
- , all (`elem` globLiteralChars) str' ]
- shrink WildCard = []
- shrink (Union as) = [ Union (map getGlobPieces (getNonEmpty as'))
- | as' <- shrink (NonEmpty (map GlobPieces as)) ]
+ shrink (Literal str) =
+ [ Literal str'
+ | str' <- shrink str
+ , not (null str')
+ , all (`elem` globLiteralChars) str'
+ ]
+ shrink WildCard = []
+ shrink (Union as) =
+ [ Union (map getGlobPieces (getNonEmpty as'))
+ | as' <- shrink (NonEmpty (map GlobPieces as))
+ ]
globLiteralChars :: [Char]
-globLiteralChars = ['\0'..'\128'] \\ "*{},/\\"
+globLiteralChars = ['\0' .. '\128'] \\ "*{},/\\"
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs b/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs
index 169a8c6b9b5cc242324cb505792c094bb42b3d56..639e51c100ce1443c2d9d4d59625c056920bb2ac 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/BuildReport.hs
@@ -1,31 +1,31 @@
-module UnitTests.Distribution.Client.BuildReport (
- tests,
-) where
+module UnitTests.Distribution.Client.BuildReport
+ ( tests
+ ) where
import Distribution.Client.Compat.Prelude
-import Prelude ()
import UnitTests.Distribution.Client.ArbitraryInstances ()
import UnitTests.Distribution.Client.TreeDiffInstances ()
+import Prelude ()
import Data.TreeDiff.QuickCheck (ediffEq)
-import Test.QuickCheck (Property, counterexample)
-import Test.Tasty (TestTree)
-import Test.Tasty.QuickCheck (testProperty)
+import Test.QuickCheck (Property, counterexample)
+import Test.Tasty (TestTree)
+import Test.Tasty.QuickCheck (testProperty)
import Distribution.Client.BuildReports.Anonymous (BuildReport, parseBuildReport, showBuildReport)
-import Distribution.Simple.Utils (toUTF8BS)
+import Distribution.Simple.Utils (toUTF8BS)
-- instances
import Test.QuickCheck.Instances.Cabal ()
tests :: [TestTree]
tests =
- [ testProperty "test" roundtrip
- ]
+ [ testProperty "test" roundtrip
+ ]
roundtrip :: BuildReport -> Property
roundtrip br =
- counterexample str $
+ counterexample str $
Right br `ediffEq` parseBuildReport (toUTF8BS str)
where
str :: String
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs b/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs
index 91a61358adebb41d1b1254103c1249c9fd267db9..c570d7a738ac192f07ac6f55a16c69dd4e16fa6c 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Configure.hs
@@ -1,90 +1,114 @@
{-# LANGUAGE RecordWildCards #-}
+
module UnitTests.Distribution.Client.Configure (tests) where
import Distribution.Client.CmdConfigure
-import Test.Tasty
-import Test.Tasty.HUnit
import Control.Monad
import qualified Data.Map as Map
-import System.Directory
-import System.FilePath
-import Distribution.Verbosity
-import Distribution.Client.Setup
import Distribution.Client.NixStyleOptions
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.ProjectFlags
+import Distribution.Client.Setup
import Distribution.Simple
import Distribution.Simple.Flag
+import Distribution.Verbosity
+import System.Directory
+import System.FilePath
+import Test.Tasty
+import Test.Tasty.HUnit
tests :: [TestTree]
tests =
- [ configureTests
- ]
+ [ configureTests
+ ]
configureTests :: TestTree
-configureTests = testGroup "Configure tests"
+configureTests =
+ testGroup
+ "Configure tests"
[ testCase "New config" $ do
- let flags = (defaultNixStyleFlags ())
- { configFlags = mempty
- { configOptimization = Flag MaximumOptimisation
- , configVerbosity = Flag silent
- }
- }
+ let flags =
+ (defaultNixStyleFlags ())
+ { configFlags =
+ mempty
+ { configOptimization = Flag MaximumOptimisation
+ , configVerbosity = Flag silent
+ }
+ }
projConfig <- configureAction' flags [] defaultGlobalFlags
- Flag MaximumOptimisation @=?
- (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig)
-
+ Flag MaximumOptimisation
+ @=? (packageConfigOptimization . projectConfigLocalPackages $ snd projConfig)
, testCase "Replacement + new config" $ do
- let flags = (defaultNixStyleFlags ())
- { configExFlags = mempty
- { configAppend = Flag True }
- , configFlags = mempty
- { configOptimization = Flag NoOptimisation
- , configVerbosity = Flag silent
- }
- , projectFlags = mempty
- { flagProjectDir = Flag projectDir }
- }
- (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags
+ let flags =
+ (defaultNixStyleFlags ())
+ { configExFlags =
+ mempty
+ { configAppend = Flag True
+ }
+ , configFlags =
+ mempty
+ { configOptimization = Flag NoOptimisation
+ , configVerbosity = Flag silent
+ }
+ , projectFlags =
+ mempty
+ { flagProjectDir = Flag projectDir
+ }
+ }
+ (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags
Flag NoOptimisation @=? packageConfigOptimization projectConfigLocalPackages
- Flag silent @=? projectConfigVerbosity projectConfigBuildOnly
-
+ Flag silent @=? projectConfigVerbosity projectConfigBuildOnly
, testCase "Old + new config" $ do
- let flags = (defaultNixStyleFlags ())
- { configExFlags = mempty
- { configAppend = Flag True }
- , configFlags = mempty
- { configVerbosity = Flag silent }
- , projectFlags = mempty
- { flagProjectDir = Flag projectDir }
- }
- (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags
+ let flags =
+ (defaultNixStyleFlags ())
+ { configExFlags =
+ mempty
+ { configAppend = Flag True
+ }
+ , configFlags =
+ mempty
+ { configVerbosity = Flag silent
+ }
+ , projectFlags =
+ mempty
+ { flagProjectDir = Flag projectDir
+ }
+ }
+ (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags
Flag MaximumOptimisation @=? packageConfigOptimization projectConfigLocalPackages
- Flag silent @=? projectConfigVerbosity projectConfigBuildOnly
-
+ Flag silent @=? projectConfigVerbosity projectConfigBuildOnly
, testCase "Old + new config, no appending" $ do
- let flags = (defaultNixStyleFlags ())
- { configFlags = mempty
- { configVerbosity = Flag silent }
- , projectFlags = mempty
- { flagProjectDir = Flag projectDir }
- }
- (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags
-
- NoFlag @=? packageConfigOptimization projectConfigLocalPackages
+ let flags =
+ (defaultNixStyleFlags ())
+ { configFlags =
+ mempty
+ { configVerbosity = Flag silent
+ }
+ , projectFlags =
+ mempty
+ { flagProjectDir = Flag projectDir
+ }
+ }
+ (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags
+
+ NoFlag @=? packageConfigOptimization projectConfigLocalPackages
Flag silent @=? projectConfigVerbosity projectConfigBuildOnly
-
, testCase "Old + new config, backup check" $ do
- let flags = (defaultNixStyleFlags ())
- { configFlags = mempty
- { configVerbosity = Flag silent }
- , projectFlags = mempty
- { flagProjectDir = Flag projectDir }
- }
+ let flags =
+ (defaultNixStyleFlags ())
+ { configFlags =
+ mempty
+ { configVerbosity = Flag silent
+ }
+ , projectFlags =
+ mempty
+ { flagProjectDir = Flag projectDir
+ }
+ }
backup = projectDir </> "cabal.project.local~"
exists <- doesFileExist backup
@@ -93,29 +117,33 @@ configureTests = testGroup "Configure tests"
_ <- configureAction' flags [] defaultGlobalFlags
- doesFileExist backup >>=
- assertBool ("No file found, expected: " ++ backup)
-
+ doesFileExist backup
+ >>= assertBool ("No file found, expected: " ++ backup)
, testCase "Local program options" $ do
let ghcFlags = ["-fno-full-laziness"]
- flags = (defaultNixStyleFlags ())
- { configFlags = mempty
- { configVerbosity = Flag silent
- , configProgramArgs = [("ghc", ghcFlags)]
- }
- , projectFlags = mempty
- { flagProjectDir = Flag projectDir }
- }
- (_, ProjectConfig {..}) <- configureAction' flags [] defaultGlobalFlags
-
-
- assertEqual "global"
- Nothing
- (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigAllPackages)))
-
- assertEqual "local"
- (Just ghcFlags)
- (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigLocalPackages)))
+ flags =
+ (defaultNixStyleFlags ())
+ { configFlags =
+ mempty
+ { configVerbosity = Flag silent
+ , configProgramArgs = [("ghc", ghcFlags)]
+ }
+ , projectFlags =
+ mempty
+ { flagProjectDir = Flag projectDir
+ }
+ }
+ (_, ProjectConfig{..}) <- configureAction' flags [] defaultGlobalFlags
+
+ assertEqual
+ "global"
+ Nothing
+ (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigAllPackages)))
+
+ assertEqual
+ "local"
+ (Just ghcFlags)
+ (Map.lookup "ghc" (getMapMappend (packageConfigProgramArgs projectConfigLocalPackages)))
]
projectDir :: FilePath
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs
index 820cdf95a705e427b2eca3ebce8f998898150d9e..fbd544a9a0b33b008bb865fcb2845e7ee21ed196 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Described.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Described.hs
@@ -1,26 +1,29 @@
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
+
module UnitTests.Distribution.Client.Described where
import Distribution.Client.Compat.Prelude
-import Prelude ()
import Test.QuickCheck.Instances.Cabal ()
import UnitTests.Distribution.Client.ArbitraryInstances ()
import UnitTests.Distribution.Client.DescribedInstances ()
+import Prelude ()
import Distribution.Described (testDescribed)
-import Test.Tasty (TestTree, testGroup)
+import Test.Tasty (TestTree, testGroup)
-import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome)
+import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome)
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepos)
-import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
-import Distribution.Client.IndexUtils.Timestamp (Timestamp)
-import Distribution.Client.Targets (UserConstraint)
-import Distribution.Client.Types (RepoName)
-import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep)
+import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
+import Distribution.Client.IndexUtils.Timestamp (Timestamp)
+import Distribution.Client.Targets (UserConstraint)
+import Distribution.Client.Types (RepoName)
+import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep)
tests :: TestTree
-tests = testGroup "Described"
+tests =
+ testGroup
+ "Described"
[ testDescribed (Proxy :: Proxy Timestamp)
, testDescribed (Proxy :: Proxy RepoIndexState)
, testDescribed (Proxy :: Proxy TotalIndexState)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs
index d0e2ad43a84efef8613bfefabc2aabd9b5a72cc3..66b9649db1147eb3d0cc2f60d520f44acaa6790e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/DescribedInstances.hs
@@ -1,47 +1,50 @@
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module UnitTests.Distribution.Client.DescribedInstances where
import Distribution.Client.Compat.Prelude
-import Distribution.Described
import Data.List ((\\))
+import Distribution.Described
-import Distribution.Types.PackageId (PackageIdentifier)
-import Distribution.Types.PackageName (PackageName)
+import Distribution.Types.PackageId (PackageIdentifier)
+import Distribution.Types.PackageName (PackageName)
import Distribution.Types.VersionRange (VersionRange)
-import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome)
+import Distribution.Client.BuildReports.Types (InstallOutcome, Outcome)
+import Distribution.Client.Glob (FilePathGlob)
import Distribution.Client.IndexUtils.ActiveRepos (ActiveRepoEntry, ActiveRepos, CombineStrategy)
-import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
-import Distribution.Client.IndexUtils.Timestamp (Timestamp)
-import Distribution.Client.Targets (UserConstraint)
-import Distribution.Client.Types (RepoName)
-import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep)
-import Distribution.Client.Glob (FilePathGlob)
+import Distribution.Client.IndexUtils.IndexState (RepoIndexState, TotalIndexState)
+import Distribution.Client.IndexUtils.Timestamp (Timestamp)
+import Distribution.Client.Targets (UserConstraint)
+import Distribution.Client.Types (RepoName)
+import Distribution.Client.Types.AllowNewer (RelaxDepSubject, RelaxDeps, RelaxedDep)
-------------------------------------------------------------------------------
-- BuildReport
-------------------------------------------------------------------------------
instance Described InstallOutcome where
- describe _ = REUnion
- [ "PlanningFailed"
- , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier)
- , "DownloadFailed"
- , "UnpackFailed"
- , "SetupFailed"
- , "ConfigureFailed"
- , "BuildFailed"
- , "TestsFailed"
- , "InstallFailed"
- , "InstallOk"
- ]
+ describe _ =
+ REUnion
+ [ "PlanningFailed"
+ , "DependencyFailed" <> RESpaces1 <> describe (Proxy :: Proxy PackageIdentifier)
+ , "DownloadFailed"
+ , "UnpackFailed"
+ , "SetupFailed"
+ , "ConfigureFailed"
+ , "BuildFailed"
+ , "TestsFailed"
+ , "InstallFailed"
+ , "InstallOk"
+ ]
instance Described Outcome where
- describe _ = REUnion
- [ fromString (prettyShow o)
- | o <- [minBound .. maxBound :: Outcome]
- ]
+ describe _ =
+ REUnion
+ [ fromString (prettyShow o)
+ | o <- [minBound .. maxBound :: Outcome]
+ ]
-------------------------------------------------------------------------------
-- Glob
@@ -49,258 +52,293 @@ instance Described Outcome where
-- This instance is incorrect as it may generate C:\dir\{foo,bar}
instance Described FilePathGlob where
- describe _ = REUnion [ root, relative, homedir ] where
- root = REUnion
- [ fromString "/"
- , reChars (['a'..'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\"
- ] <> REOpt pieces
- homedir = "~/" <> REOpt pieces
- relative = pieces
-
- pieces :: GrammarRegex void
- pieces = REMunch1 sep piece <> REOpt "/"
-
- piece :: GrammarRegex void
- piece = RERec "glob" $ REMunch1 mempty $ REUnion
- [ normal
- , escape
- , wildcard
- , "{" <> REMunch1 "," (REVar Nothing) <> "}"
- ]
-
- sep :: GrammarRegex void
- sep = reChars "/\\"
-
- wildcard :: GrammarRegex void
- wildcard = "*"
-
- normal = reChars $ ['\0'..'\128'] \\ "*{},/\\"
- escape = fromString "\\" <> reChars "*{},"
+ describe _ = REUnion [root, relative, homedir]
+ where
+ root =
+ REUnion
+ [ fromString "/"
+ , reChars (['a' .. 'z'] ++ ['A' .. 'Z']) <> ":" <> reChars "/\\"
+ ]
+ <> REOpt pieces
+ homedir = "~/" <> REOpt pieces
+ relative = pieces
+
+ pieces :: GrammarRegex void
+ pieces = REMunch1 sep piece <> REOpt "/"
+
+ piece :: GrammarRegex void
+ piece =
+ RERec "glob" $
+ REMunch1 mempty $
+ REUnion
+ [ normal
+ , escape
+ , wildcard
+ , "{" <> REMunch1 "," (REVar Nothing) <> "}"
+ ]
+
+ sep :: GrammarRegex void
+ sep = reChars "/\\"
+
+ wildcard :: GrammarRegex void
+ wildcard = "*"
+
+ normal = reChars $ ['\0' .. '\128'] \\ "*{},/\\"
+ escape = fromString "\\" <> reChars "*{},"
-------------------------------------------------------------------------------
-- AllowNewer
-------------------------------------------------------------------------------
instance Described RelaxedDep where
- describe _ =
- REOpt (describeRelaxDepScope <> ":" <> REOpt ("^"))
- <> describe (Proxy :: Proxy RelaxDepSubject)
- where
- describeRelaxDepScope = REUnion
- [ "*"
- , "all"
- , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
- , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))
- ]
+ describe _ =
+ REOpt (describeRelaxDepScope <> ":" <> REOpt ("^"))
+ <> describe (Proxy :: Proxy RelaxDepSubject)
+ where
+ describeRelaxDepScope =
+ REUnion
+ [ "*"
+ , "all"
+ , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
+ , RENamed "package-id" (describe (Proxy :: Proxy PackageIdentifier))
+ ]
instance Described RelaxDepSubject where
- describe _ = REUnion
- [ "*"
- , "all"
- , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
- ]
+ describe _ =
+ REUnion
+ [ "*"
+ , "all"
+ , RENamed "package-name" (describe (Proxy :: Proxy PackageName))
+ ]
instance Described RelaxDeps where
- describe _ = REUnion
- [ "*"
- , "all"
- , "none"
- , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))
- ]
+ describe _ =
+ REUnion
+ [ "*"
+ , "all"
+ , "none"
+ , RECommaNonEmpty (describe (Proxy :: Proxy RelaxedDep))
+ ]
-------------------------------------------------------------------------------
-- ActiveRepos
-------------------------------------------------------------------------------
instance Described ActiveRepos where
- describe _ = REUnion
- [ ":none"
- , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry))
- ]
+ describe _ =
+ REUnion
+ [ ":none"
+ , RECommaNonEmpty (describe (Proxy :: Proxy ActiveRepoEntry))
+ ]
instance Described ActiveRepoEntry where
- describe _ = REUnion
- [ ":rest" <> strategy
- , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy
- ]
- where
- strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy)
+ describe _ =
+ REUnion
+ [ ":rest" <> strategy
+ , REOpt ":repo:" <> describe (Proxy :: Proxy RepoName) <> strategy
+ ]
+ where
+ strategy = REOpt $ ":" <> describe (Proxy :: Proxy CombineStrategy)
instance Described CombineStrategy where
- describe _ = REUnion
- [ "skip"
- , "merge"
- , "override"
- ]
+ describe _ =
+ REUnion
+ [ "skip"
+ , "merge"
+ , "override"
+ ]
-------------------------------------------------------------------------------
-- UserConstraint
-------------------------------------------------------------------------------
instance Described UserConstraint where
- describe _ = REAppend
- [ describeConstraintScope
- , describeConstraintProperty
- ]
- where
- describeConstraintScope :: GrammarRegex void
- describeConstraintScope = REUnion
- [ "any." <> describePN
- , "setup." <> describePN
- , describePN
- , describePN <> ":setup." <> describePN
- ]
-
- describeConstraintProperty :: GrammarRegex void
- describeConstraintProperty = REUnion
- [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
- , RESpaces1 <> describeConstraintProperty'
- ]
-
- describeConstraintProperty' :: GrammarRegex void
- describeConstraintProperty' = REUnion
- [ "installed"
- , "source"
- , "test"
- , "bench"
- , describeFlagAssignmentNonEmpty
- ]
-
- describePN :: GrammarRegex void
- describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName))
+ describe _ =
+ REAppend
+ [ describeConstraintScope
+ , describeConstraintProperty
+ ]
+ where
+ describeConstraintScope :: GrammarRegex void
+ describeConstraintScope =
+ REUnion
+ [ "any." <> describePN
+ , "setup." <> describePN
+ , describePN
+ , describePN <> ":setup." <> describePN
+ ]
+
+ describeConstraintProperty :: GrammarRegex void
+ describeConstraintProperty =
+ REUnion
+ [ RESpaces <> RENamed "version-range" (describe (Proxy :: Proxy VersionRange))
+ , RESpaces1 <> describeConstraintProperty'
+ ]
+
+ describeConstraintProperty' :: GrammarRegex void
+ describeConstraintProperty' =
+ REUnion
+ [ "installed"
+ , "source"
+ , "test"
+ , "bench"
+ , describeFlagAssignmentNonEmpty
+ ]
+
+ describePN :: GrammarRegex void
+ describePN = RENamed "package-name" (describe (Proxy :: Proxy PackageName))
-------------------------------------------------------------------------------
-- IndexState
-------------------------------------------------------------------------------
instance Described TotalIndexState where
- describe _ = reCommaNonEmpty $ REUnion
+ describe _ =
+ reCommaNonEmpty $
+ REUnion
[ describe (Proxy :: Proxy RepoName) <> RESpaces1 <> ris
, ris
]
- where
- ris = describe (Proxy :: Proxy RepoIndexState)
+ where
+ ris = describe (Proxy :: Proxy RepoIndexState)
instance Described RepoName where
- describe _ = lead <> rest where
- lead = RECharSet $ csAlpha <> "_-."
- rest = reMunchCS $ csAlphaNum <> "_-."
+ describe _ = lead <> rest
+ where
+ lead = RECharSet $ csAlpha <> "_-."
+ rest = reMunchCS $ csAlphaNum <> "_-."
instance Described RepoIndexState where
- describe _ = REUnion
- [ "HEAD"
- , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp))
- ]
+ describe _ =
+ REUnion
+ [ "HEAD"
+ , RENamed "timestamp" (describe (Proxy :: Proxy Timestamp))
+ ]
instance Described Timestamp where
- describe _ = REUnion
- [ posix
- , utc
- ]
- where
- posix = reChar '@' <> reMunch1CS "0123456789"
- utc = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z'
-
- date = REOpt digit <> REUnion
- [ leapYear <> reChar '-' <> leapMD
+ describe _ =
+ REUnion
+ [ posix
+ , utc
+ ]
+ where
+ posix = reChar '@' <> reMunch1CS "0123456789"
+ utc = RENamed "date" date <> reChar 'T' <> RENamed "time" time <> reChar 'Z'
+
+ date =
+ REOpt digit
+ <> REUnion
+ [ leapYear <> reChar '-' <> leapMD
, commonYear <> reChar '-' <> commonMD
]
- -- leap year: either
- -- * divisible by 400
- -- * not divisible by 100 and divisible by 4
- leapYear = REUnion
- [ div4 <> "00"
- , digit <> digit <> div4not0
- ]
-
- -- common year: either
- -- * not divisible by 400 but divisible by 100
- -- * not divisible by 4
- commonYear = REUnion
- [ notDiv4 <> "00"
- , digit <> digit <> notDiv4
- ]
-
- div4 = REUnion
- [ "0" <> reChars "048"
- , "1" <> reChars "26"
- , "2" <> reChars "048"
- , "3" <> reChars "26"
- , "4" <> reChars "048"
- , "5" <> reChars "26"
- , "6" <> reChars "048"
- , "7" <> reChars "26"
- , "8" <> reChars "048"
- , "9" <> reChars "26"
- ]
-
- div4not0 = REUnion
- [ "0" <> reChars "48" -- no zero
- , "1" <> reChars "26"
- , "2" <> reChars "048"
- , "3" <> reChars "26"
- , "4" <> reChars "048"
- , "5" <> reChars "26"
- , "6" <> reChars "048"
- , "7" <> reChars "26"
- , "8" <> reChars "048"
- , "9" <> reChars "26"
- ]
-
- notDiv4 = REUnion
- [ "0" <> reChars "1235679"
- , "1" <> reChars "01345789"
- , "2" <> reChars "1235679"
- , "3" <> reChars "01345789"
- , "4" <> reChars "1235679"
- , "5" <> reChars "01345789"
- , "6" <> reChars "1235679"
- , "7" <> reChars "01345789"
- , "8" <> reChars "1235679"
- , "9" <> reChars "01345789"
- ]
-
- leapMD = REUnion
- [ jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec ]
-
- commonMD = REUnion
- [ jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec ]
-
- jan = "01-" <> d31
- feb = "02-" <> d28
- fe' = "02-" <> d29
- mar = "03-" <> d31
- apr = "04-" <> d30
- may = "05-" <> d31
- jun = "06-" <> d30
- jul = "07-" <> d31
- aug = "08-" <> d31
- sep = "09-" <> d30
- oct = "10-" <> d31
- nov = "11-" <> d30
- dec = "12-" <> d31
-
- d28 = REUnion
- [ "0" <> digit1, "1" <> digit, "2" <> reChars "012345678" ]
- d29 = REUnion
- [ "0" <> digit1, "1" <> digit, "2" <> digit ]
- d30 = REUnion
- [ "0" <> digit1, "1" <> digit, "2" <> digit, "30" ]
- d31 = REUnion
- [ "0" <> digit1, "1" <> digit, "2" <> digit, "30", "31" ]
-
- time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec
-
- -- 0..23
- ho = REUnion
- [ "0" <> digit
- , "1" <> digit
- , "2" <> reChars "0123"
- ]
-
- -- 0..59
- minSec = reChars "012345" <> digit
-
- digit = reChars "0123456789"
- digit1 = reChars "123456789"
+ -- leap year: either
+ -- \* divisible by 400
+ -- \* not divisible by 100 and divisible by 4
+ leapYear =
+ REUnion
+ [ div4 <> "00"
+ , digit <> digit <> div4not0
+ ]
+
+ -- common year: either
+ -- \* not divisible by 400 but divisible by 100
+ -- \* not divisible by 4
+ commonYear =
+ REUnion
+ [ notDiv4 <> "00"
+ , digit <> digit <> notDiv4
+ ]
+
+ div4 =
+ REUnion
+ [ "0" <> reChars "048"
+ , "1" <> reChars "26"
+ , "2" <> reChars "048"
+ , "3" <> reChars "26"
+ , "4" <> reChars "048"
+ , "5" <> reChars "26"
+ , "6" <> reChars "048"
+ , "7" <> reChars "26"
+ , "8" <> reChars "048"
+ , "9" <> reChars "26"
+ ]
+
+ div4not0 =
+ REUnion
+ [ "0" <> reChars "48" -- no zero
+ , "1" <> reChars "26"
+ , "2" <> reChars "048"
+ , "3" <> reChars "26"
+ , "4" <> reChars "048"
+ , "5" <> reChars "26"
+ , "6" <> reChars "048"
+ , "7" <> reChars "26"
+ , "8" <> reChars "048"
+ , "9" <> reChars "26"
+ ]
+
+ notDiv4 =
+ REUnion
+ [ "0" <> reChars "1235679"
+ , "1" <> reChars "01345789"
+ , "2" <> reChars "1235679"
+ , "3" <> reChars "01345789"
+ , "4" <> reChars "1235679"
+ , "5" <> reChars "01345789"
+ , "6" <> reChars "1235679"
+ , "7" <> reChars "01345789"
+ , "8" <> reChars "1235679"
+ , "9" <> reChars "01345789"
+ ]
+
+ leapMD =
+ REUnion
+ [jan, fe', mar, apr, may, jun, jul, aug, sep, oct, nov, dec]
+
+ commonMD =
+ REUnion
+ [jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec]
+
+ jan = "01-" <> d31
+ feb = "02-" <> d28
+ fe' = "02-" <> d29
+ mar = "03-" <> d31
+ apr = "04-" <> d30
+ may = "05-" <> d31
+ jun = "06-" <> d30
+ jul = "07-" <> d31
+ aug = "08-" <> d31
+ sep = "09-" <> d30
+ oct = "10-" <> d31
+ nov = "11-" <> d30
+ dec = "12-" <> d31
+
+ d28 =
+ REUnion
+ ["0" <> digit1, "1" <> digit, "2" <> reChars "012345678"]
+ d29 =
+ REUnion
+ ["0" <> digit1, "1" <> digit, "2" <> digit]
+ d30 =
+ REUnion
+ ["0" <> digit1, "1" <> digit, "2" <> digit, "30"]
+ d31 =
+ REUnion
+ ["0" <> digit1, "1" <> digit, "2" <> digit, "30", "31"]
+
+ time = ho <> reChar ':' <> minSec <> reChar ':' <> minSec
+
+ -- 0..23
+ ho =
+ REUnion
+ [ "0" <> digit
+ , "1" <> digit
+ , "2" <> reChars "0123"
+ ]
+
+ -- 0..59
+ minSec = reChars "012345" <> digit
+
+ digit = reChars "0123456789"
+ digit1 = reChars "123456789"
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs
index 7ecd5f7ad0583035384d735781db78947cc18888..d8c21aa3b17f2905654847b8cfab72997ad82f89 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/FetchUtils.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
+
module UnitTests.Distribution.Client.FetchUtils
- ( tests,
+ ( tests
)
where
@@ -26,13 +27,13 @@ tests :: [TestTree]
tests =
[ testGroup
"asyncFetchPackages"
- [ testCase "handles an empty package list" testEmpty,
- testCase "passes an unpacked local package through" testPassLocalPackage,
- testCase "handles http" testHttp,
- testCase "aborts on interrupt in GET" $ testGetInterrupt,
- testCase "aborts on other exception in GET" $ testGetException,
- testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt,
- testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException
+ [ testCase "handles an empty package list" testEmpty
+ , testCase "passes an unpacked local package through" testPassLocalPackage
+ , testCase "handles http" testHttp
+ , testCase "aborts on interrupt in GET" $ testGetInterrupt
+ , testCase "aborts on other exception in GET" $ testGetException
+ , testCase "aborts on interrupt in GET (uncollected download)" $ testUncollectedInterrupt
+ , testCase "continues on other exception in GET (uncollected download)" $ testUncollectedException
]
]
@@ -175,24 +176,24 @@ mkPkgId :: String -> PackageIdentifier
mkPkgId name = PackageIdentifier (mkPackageName name) (mkVersion [1, 0])
-- | Provide a repo and a repo context with the given GET handler.
-withFakeRepoCtxt ::
- (URI -> IO HttpCode) ->
- (RepoContext -> Repo -> IO a) ->
- IO a
+withFakeRepoCtxt
+ :: (URI -> IO HttpCode)
+ -> (RepoContext -> Repo -> IO a)
+ -> IO a
withFakeRepoCtxt handleGet action =
withTestDir verbosity "fake repo" $ \tmpDir ->
let repo =
RepoRemote
- { repoRemote = emptyRemoteRepo $ RepoName "fake",
- repoLocalDir = tmpDir
+ { repoRemote = emptyRemoteRepo $ RepoName "fake"
+ , repoLocalDir = tmpDir
}
repoCtxt =
RepoContext
- { repoContextRepos = [repo],
- repoContextGetTransport = return httpTransport,
- repoContextWithSecureRepo = \_ _ ->
- error "fake repo ctxt: repoContextWithSecureRepo not implemented",
- repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented"
+ { repoContextRepos = [repo]
+ , repoContextGetTransport = return httpTransport
+ , repoContextWithSecureRepo = \_ _ ->
+ error "fake repo ctxt: repoContextWithSecureRepo not implemented"
+ , repoContextIgnoreExpiry = error "fake repo ctxt: repoContextIgnoreExpiry not implemented"
}
in action repoCtxt repo
where
@@ -200,10 +201,10 @@ withFakeRepoCtxt handleGet action =
HttpTransport
{ getHttp = \_verbosity uri _etag _filepath _headers -> do
code <- handleGet uri
- return (code, Nothing),
- postHttp = error "fake transport: postHttp not implemented",
- postHttpFile = error "fake transport: postHttpFile not implemented",
- putHttpFile = error "fake transport: putHttp not implemented",
- transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented",
- transportManuallySelected = True
+ return (code, Nothing)
+ , postHttp = error "fake transport: postHttp not implemented"
+ , postHttpFile = error "fake transport: postHttpFile not implemented"
+ , putHttpFile = error "fake transport: putHttp not implemented"
+ , transportSupportsHttps = error "fake transport: transportSupportsHttps not implemented"
+ , transportManuallySelected = True
}
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
index 629265acb8c86ba860fd5afcc2dec36af22870e4..39f508040c32b574ce0692e2545d47c9f780f8f0 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/FileMonitor.hs
@@ -2,91 +2,89 @@ module UnitTests.Distribution.Client.FileMonitor (tests) where
import Distribution.Parsec (simpleParsec)
-import Data.Proxy (Proxy (..))
-import Control.Monad
-import Control.Exception
import Control.Concurrent (threadDelay)
+import Control.Exception
+import Control.Monad
+import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
-import System.FilePath
import qualified System.Directory as IO
+import System.FilePath
import Prelude hiding (writeFile)
import qualified Prelude as IO (writeFile)
import Distribution.Compat.Binary
import Distribution.Simple.Utils (withTempDirectory)
-import Distribution.System (buildOS, OS (Windows))
+import Distribution.System (OS (Windows), buildOS)
import Distribution.Verbosity (silent)
import Distribution.Client.FileMonitor
import Distribution.Compat.Time
-import Distribution.Utils.Structured (structureHash, Structured)
+import Distribution.Utils.Structured (Structured, structureHash)
import GHC.Fingerprint (Fingerprint (..))
import Test.Tasty
import Test.Tasty.ExpectedFailure
import Test.Tasty.HUnit
-
tests :: Int -> [TestTree]
tests mtimeChange =
- [ testGroup "Structured hashes"
- [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13
- , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint 0xfd8f6be0e8258fe7 0xdb5fac737139bca6
- , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint 0xb745f4ea498389a5 0x70db6adb5078aa27
- ]
- , testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange
- , testCase "sanity check dirs" $ testDirChangeSanity mtimeChange
- , testCase "no monitor cache" testNoMonitorCache
+ [ testGroup
+ "Structured hashes"
+ [ testCase "MonitorStateFile" $ structureHash (Proxy :: Proxy MonitorStateFile) @?= Fingerprint 0xe4108804c34962f6 0x06e94f8fc9e48e13
+ , testCase "MonitorStateGlob" $ structureHash (Proxy :: Proxy MonitorStateGlob) @?= Fingerprint 0xfd8f6be0e8258fe7 0xdb5fac737139bca6
+ , testCase "MonitorStateFileSet" $ structureHash (Proxy :: Proxy MonitorStateFileSet) @?= Fingerprint 0xb745f4ea498389a5 0x70db6adb5078aa27
+ ]
+ , testCase "sanity check mtimes" $ testFileMTimeSanity mtimeChange
+ , testCase "sanity check dirs" $ testDirChangeSanity mtimeChange
+ , testCase "no monitor cache" testNoMonitorCache
, testCaseSteps "corrupt monitor cache" testCorruptMonitorCache
- , testCase "empty monitor" testEmptyMonitor
- , testCase "missing file" testMissingFile
- , testCase "change file" $ testChangedFile mtimeChange
+ , testCase "empty monitor" testEmptyMonitor
+ , testCase "missing file" testMissingFile
+ , testCase "change file" $ testChangedFile mtimeChange
, testCase "file mtime vs content" $ testChangedFileMtimeVsContent mtimeChange
- , testCase "update during action" $ testUpdateDuringAction mtimeChange
- , testCase "remove file" testRemoveFile
- , testCase "non-existent file" testNonExistentFile
- , testCase "changed file type" $ testChangedFileType mtimeChange
+ , testCase "update during action" $ testUpdateDuringAction mtimeChange
+ , testCase "remove file" testRemoveFile
+ , testCase "non-existent file" testNonExistentFile
+ , testCase "changed file type" $ testChangedFileType mtimeChange
, testCase "several monitor kinds" $ testMultipleMonitorKinds mtimeChange
-
- , testGroup "glob matches"
- [ testCase "no change" testGlobNoChange
- , testCase "add match" $ testGlobAddMatch mtimeChange
- , testCase "remove match" $ testGlobRemoveMatch mtimeChange
- , testCase "change match" $ testGlobChangeMatch mtimeChange
-
- , testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange
- , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange
- , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange
-
- , testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange
- , testCase "add non-match" $ testGlobAddNonMatch mtimeChange
- , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange
-
- , knownBrokenInWindows "See issue #3126" $
- testCase "add non-match subdir" $ testGlobAddNonMatchSubdir mtimeChange
- , testCase "remove non-match subdir" $ testGlobRemoveNonMatchSubdir mtimeChange
-
- , testCase "invariant sorted 1" $ testInvariantMonitorStateGlobFiles
- mtimeChange
- , testCase "invariant sorted 2" $ testInvariantMonitorStateGlobDirs
- mtimeChange
-
- , testCase "match dirs" $ testGlobMatchDir mtimeChange
- , knownBrokenInWindows "See issue #3126" $
- testCase "match dirs only" $ testGlobMatchDirOnly mtimeChange
- , testCase "change file type" $ testGlobChangeFileType mtimeChange
- , testCase "absolute paths" $ testGlobAbsolutePath mtimeChange
- ]
-
- , testCase "value unchanged" testValueUnchanged
- , testCase "value changed" testValueChanged
- , testCase "value & file changed" $ testValueAndFileChanged mtimeChange
- , testCase "value updated" testValueUpdated
+ , testGroup
+ "glob matches"
+ [ testCase "no change" testGlobNoChange
+ , testCase "add match" $ testGlobAddMatch mtimeChange
+ , testCase "remove match" $ testGlobRemoveMatch mtimeChange
+ , testCase "change match" $ testGlobChangeMatch mtimeChange
+ , testCase "add match subdir" $ testGlobAddMatchSubdir mtimeChange
+ , testCase "remove match subdir" $ testGlobRemoveMatchSubdir mtimeChange
+ , testCase "change match subdir" $ testGlobChangeMatchSubdir mtimeChange
+ , testCase "match toplevel dir" $ testGlobMatchTopDir mtimeChange
+ , testCase "add non-match" $ testGlobAddNonMatch mtimeChange
+ , testCase "remove non-match" $ testGlobRemoveNonMatch mtimeChange
+ , knownBrokenInWindows "See issue #3126" $
+ testCase "add non-match subdir" $
+ testGlobAddNonMatchSubdir mtimeChange
+ , testCase "remove non-match subdir" $ testGlobRemoveNonMatchSubdir mtimeChange
+ , testCase "invariant sorted 1" $
+ testInvariantMonitorStateGlobFiles
+ mtimeChange
+ , testCase "invariant sorted 2" $
+ testInvariantMonitorStateGlobDirs
+ mtimeChange
+ , testCase "match dirs" $ testGlobMatchDir mtimeChange
+ , knownBrokenInWindows "See issue #3126" $
+ testCase "match dirs only" $
+ testGlobMatchDirOnly mtimeChange
+ , testCase "change file type" $ testGlobChangeFileType mtimeChange
+ , testCase "absolute paths" $ testGlobAbsolutePath mtimeChange
+ ]
+ , testCase "value unchanged" testValueUnchanged
+ , testCase "value changed" testValueChanged
+ , testCase "value & file changed" $ testValueAndFileChanged mtimeChange
+ , testCase "value updated" testValueUpdated
]
-
- where knownBrokenInWindows msg = case buildOS of
- Windows -> expectFailBecause msg
- _ -> id
+ where
+ knownBrokenInWindows msg = case buildOS of
+ Windows -> expectFailBecause msg
+ _ -> id
-- Check the file system behaves the way we expect it to
@@ -106,7 +104,6 @@ testFileMTimeSanity mtimeChange =
testDirChangeSanity :: Int -> Assertion
testDirChangeSanity mtimeChange =
withTempDirectory silent "." "dir-mtime-" $ \dir -> do
-
expectMTimeChange dir "file add" $
IO.writeFile (dir </> "file") "content"
@@ -136,26 +133,28 @@ testDirChangeSanity mtimeChange =
expectMTimeChange dir "subdir dir move out" $
IO.renameDirectory (dir </> "subdir") (dir </> "dir" </> "subdir")
-
where
- expectMTimeChange, expectMTimeSame :: FilePath -> String -> IO ()
- -> Assertion
+ expectMTimeChange
+ , expectMTimeSame
+ :: FilePath
+ -> String
+ -> IO ()
+ -> Assertion
expectMTimeChange dir descr action = do
- t <- getModTime dir
+ t <- getModTime dir
threadDelay mtimeChange
action
t' <- getModTime dir
assertBool ("expected dir mtime change on " ++ descr) (t' > t)
expectMTimeSame dir descr action = do
- t <- getModTime dir
+ t <- getModTime dir
threadDelay mtimeChange
action
t' <- getModTime dir
assertBool ("expected same dir mtime on " ++ descr) (t' == t)
-
-- Now for the FileMonitor tests proper...
-- first run, where we don't even call updateMonitor
@@ -177,7 +176,7 @@ testCorruptMonitorCache step =
step "Updating file monitor"
updateMonitor root monitor [] () ()
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= []
step "Writing broken file again"
@@ -193,23 +192,24 @@ testEmptyMonitor =
updateMonitor root monitor [] () ()
touchFile root "b"
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= []
-- monitor a file that is expected to exist
testMissingFile :: Assertion
testMissingFile = do
- test monitorFile touchFile "a"
- test monitorFileHashed touchFile "a"
- test monitorFile touchFile ("dir" </> "a")
- test monitorFileHashed touchFile ("dir" </> "a")
- test monitorDirectory touchDir "a"
- test monitorDirectory touchDir ("dir" </> "a")
+ test monitorFile touchFile "a"
+ test monitorFileHashed touchFile "a"
+ test monitorFile touchFile ("dir" </> "a")
+ test monitorFileHashed touchFile ("dir" </> "a")
+ test monitorDirectory touchDir "a"
+ test monitorDirectory touchDir ("dir" </> "a")
where
- test :: (FilePath -> MonitorFilePath)
- -> (RootPath -> FilePath -> IO ())
- -> FilePath
- -> IO ()
+ test
+ :: (FilePath -> MonitorFilePath)
+ -> (RootPath -> FilePath -> IO ())
+ -> FilePath
+ -> IO ()
test monitorKind touch file =
withFileMonitor $ \root monitor -> do
-- a file that doesn't exist at snapshot time is considered to have
@@ -225,21 +225,21 @@ testMissingFile = do
reason2 <- expectMonitorChanged root monitor ()
reason2 @?= MonitoredFileChanged file
-
testChangedFile :: Int -> Assertion
testChangedFile mtimeChange = do
- test monitorFile touchFile touchFile "a"
- test monitorFileHashed touchFile touchFileContent "a"
- test monitorFile touchFile touchFile ("dir" </> "a")
- test monitorFileHashed touchFile touchFileContent ("dir" </> "a")
- test monitorDirectory touchDir touchDir "a"
- test monitorDirectory touchDir touchDir ("dir" </> "a")
+ test monitorFile touchFile touchFile "a"
+ test monitorFileHashed touchFile touchFileContent "a"
+ test monitorFile touchFile touchFile ("dir" </> "a")
+ test monitorFileHashed touchFile touchFileContent ("dir" </> "a")
+ test monitorDirectory touchDir touchDir "a"
+ test monitorDirectory touchDir touchDir ("dir" </> "a")
where
- test :: (FilePath -> MonitorFilePath)
- -> (RootPath -> FilePath -> IO ())
- -> (RootPath -> FilePath -> IO ())
- -> FilePath
- -> IO ()
+ test
+ :: (FilePath -> MonitorFilePath)
+ -> (RootPath -> FilePath -> IO ())
+ -> (RootPath -> FilePath -> IO ())
+ -> FilePath
+ -> IO ()
test monitorKind touch touch' file =
withFileMonitor $ \root monitor -> do
touch root file
@@ -249,7 +249,6 @@ testChangedFile mtimeChange = do
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged file
-
testChangedFileMtimeVsContent :: Int -> Assertion
testChangedFileMtimeVsContent mtimeChange =
withFileMonitor $ \root monitor -> do
@@ -257,7 +256,7 @@ testChangedFileMtimeVsContent mtimeChange =
touchFile root "a"
updateMonitor root monitor [monitorFile "a"] () ()
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFile "a"]
-- if we do touch the file, it's changed if we only consider mtime
@@ -272,7 +271,7 @@ testChangedFileMtimeVsContent mtimeChange =
threadDelay mtimeChange
touchFile root "a"
(res2, files2) <- expectMonitorUnchanged root monitor ()
- res2 @?= ()
+ res2 @?= ()
files2 @?= [monitorFileHashed "a"]
-- finally if we change the content it's changed
@@ -282,20 +281,22 @@ testChangedFileMtimeVsContent mtimeChange =
reason2 <- expectMonitorChanged root monitor ()
reason2 @?= MonitoredFileChanged "a"
-
testUpdateDuringAction :: Int -> Assertion
testUpdateDuringAction mtimeChange = do
- test (monitorFile "a") touchFile "a"
- test (monitorFileHashed "a") touchFile "a"
- test (monitorDirectory "a") touchDir "a"
- test (monitorFileGlobStr "*") touchFile "a"
- test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }
- touchDir "a"
+ test (monitorFile "a") touchFile "a"
+ test (monitorFileHashed "a") touchFile "a"
+ test (monitorDirectory "a") touchDir "a"
+ test (monitorFileGlobStr "*") touchFile "a"
+ test
+ (monitorFileGlobStr "*"){monitorKindDir = DirModTime}
+ touchDir
+ "a"
where
- test :: MonitorFilePath
- -> (RootPath -> FilePath -> IO ())
- -> FilePath
- -> IO ()
+ test
+ :: MonitorFilePath
+ -> (RootPath -> FilePath -> IO ())
+ -> FilePath
+ -> IO ()
test monitorSpec touch file =
withFileMonitor $ \root monitor -> do
touch root file
@@ -303,19 +304,19 @@ testUpdateDuringAction mtimeChange = do
-- start doing an update action...
threadDelay mtimeChange -- some time passes
- touch root file -- a file gets updates during the action
+ touch root file -- a file gets updates during the action
threadDelay mtimeChange -- some time passes then we finish
updateMonitor root monitor [monitorSpec] () ()
-- we don't notice this change since we took the timestamp after the
-- action finished
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorSpec]
-- Let's try again, this time taking the timestamp before the action
timestamp' <- beginUpdateFileMonitor
threadDelay mtimeChange -- some time passes
- touch root file -- a file gets updates during the action
+ touch root file -- a file gets updates during the action
threadDelay mtimeChange -- some time passes then we finish
updateMonitorWithTimestamp root monitor timestamp' [monitorSpec] () ()
-- now we do notice the change since we took the snapshot before the
@@ -323,21 +324,21 @@ testUpdateDuringAction mtimeChange = do
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged file
-
testRemoveFile :: Assertion
testRemoveFile = do
- test monitorFile touchFile removeFile "a"
- test monitorFileHashed touchFile removeFile "a"
- test monitorFile touchFile removeFile ("dir" </> "a")
- test monitorFileHashed touchFile removeFile ("dir" </> "a")
- test monitorDirectory touchDir removeDir "a"
- test monitorDirectory touchDir removeDir ("dir" </> "a")
+ test monitorFile touchFile removeFile "a"
+ test monitorFileHashed touchFile removeFile "a"
+ test monitorFile touchFile removeFile ("dir" </> "a")
+ test monitorFileHashed touchFile removeFile ("dir" </> "a")
+ test monitorDirectory touchDir removeDir "a"
+ test monitorDirectory touchDir removeDir ("dir" </> "a")
where
- test :: (FilePath -> MonitorFilePath)
- -> (RootPath -> FilePath -> IO ())
- -> (RootPath -> FilePath -> IO ())
- -> FilePath
- -> IO ()
+ test
+ :: (FilePath -> MonitorFilePath)
+ -> (RootPath -> FilePath -> IO ())
+ -> (RootPath -> FilePath -> IO ())
+ -> FilePath
+ -> IO ()
test monitorKind touch remove file =
withFileMonitor $ \root monitor -> do
touch root file
@@ -346,7 +347,6 @@ testRemoveFile = do
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged file
-
-- monitor a file that we expect not to exist
testNonExistentFile :: Assertion
testNonExistentFile =
@@ -354,7 +354,7 @@ testNonExistentFile =
-- a file that doesn't exist at snapshot time or check time is unchanged
updateMonitor root monitor [monitorNonExistentFile "a"] () ()
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorNonExistentFile "a"]
-- if the file then exists it has changed
@@ -376,31 +376,37 @@ testNonExistentFile =
updateMonitor root monitor [monitorNonExistentFile "a"] () ()
removeFile root "a"
(res2, files2) <- expectMonitorUnchanged root monitor ()
- res2 @?= ()
+ res2 @?= ()
files2 @?= [monitorNonExistentFile "a"]
-
-testChangedFileType :: Int-> Assertion
+testChangedFileType :: Int -> Assertion
testChangedFileType mtimeChange = do
- test (monitorFile "a") touchFile removeFile createDir
- test (monitorFileHashed "a") touchFile removeFile createDir
-
- test (monitorDirectory "a") createDir removeDir touchFile
- test (monitorFileOrDirectory "a") createDir removeDir touchFile
-
- test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }
- touchFile removeFile createDir
- test (monitorFileGlobStr "*") { monitorKindDir = DirModTime }
- createDir removeDir touchFile
+ test (monitorFile "a") touchFile removeFile createDir
+ test (monitorFileHashed "a") touchFile removeFile createDir
+
+ test (monitorDirectory "a") createDir removeDir touchFile
+ test (monitorFileOrDirectory "a") createDir removeDir touchFile
+
+ test
+ (monitorFileGlobStr "*"){monitorKindDir = DirModTime}
+ touchFile
+ removeFile
+ createDir
+ test
+ (monitorFileGlobStr "*"){monitorKindDir = DirModTime}
+ createDir
+ removeDir
+ touchFile
where
- test :: MonitorFilePath
- -> (RootPath -> String -> IO ())
- -> (RootPath -> String -> IO ())
- -> (RootPath -> String -> IO ())
- -> IO ()
+ test
+ :: MonitorFilePath
+ -> (RootPath -> String -> IO ())
+ -> (RootPath -> String -> IO ())
+ -> (RootPath -> String -> IO ())
+ -> IO ()
test monitorKind touch remove touch' =
withFileMonitor $ \root monitor -> do
- touch root "a"
+ touch root "a"
updateMonitor root monitor [monitorKind] () ()
threadDelay mtimeChange
remove root "a"
@@ -418,7 +424,7 @@ testMultipleMonitorKinds mtimeChange =
touchFile root "a"
updateMonitor root monitor [monitorFile "a", monitorFileHashed "a"] () ()
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFile "a", monitorFileHashed "a"]
threadDelay mtimeChange
touchFile root "a" -- not changing content, just mtime
@@ -426,17 +432,22 @@ testMultipleMonitorKinds mtimeChange =
reason @?= MonitoredFileChanged "a"
createDir root "dir"
- updateMonitor root monitor [monitorDirectory "dir",
- monitorDirectoryExistence "dir"] () ()
+ updateMonitor
+ root
+ monitor
+ [ monitorDirectory "dir"
+ , monitorDirectoryExistence "dir"
+ ]
+ ()
+ ()
(res2, files2) <- expectMonitorUnchanged root monitor ()
- res2 @?= ()
+ res2 @?= ()
files2 @?= [monitorDirectory "dir", monitorDirectoryExistence "dir"]
threadDelay mtimeChange
touchFile root ("dir" </> "a") -- changing dir mtime, not existence
reason2 <- expectMonitorChanged root monitor ()
reason2 @?= MonitoredFileChanged "dir"
-
------------------
-- globs
--
@@ -448,7 +459,7 @@ testGlobNoChange =
touchFile root ("dir" </> "good-b")
updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/good-*"]
testGlobAddMatch :: Int -> Assertion
@@ -457,7 +468,7 @@ testGlobAddMatch mtimeChange =
touchFile root ("dir" </> "good-a")
updateMonitor root monitor [monitorFileGlobStr "dir/good-*"] () ()
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/good-*"]
threadDelay mtimeChange
touchFile root ("dir" </> "good-b")
@@ -484,7 +495,7 @@ testGlobChangeMatch mtimeChange =
threadDelay mtimeChange
touchFile root ("dir" </> "good-b")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/good-*"]
touchFileContent root ("dir" </> "good-b")
@@ -521,7 +532,7 @@ testGlobChangeMatchSubdir mtimeChange =
threadDelay mtimeChange
touchFile root ("dir" </> "b" </> "good-b")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*/good-*"]
touchFileContent root "dir/b/good-b"
@@ -546,7 +557,7 @@ testGlobAddNonMatch mtimeChange =
threadDelay mtimeChange
touchFile root ("dir" </> "bad")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/good-*"]
testGlobRemoveNonMatch :: Int -> Assertion
@@ -558,7 +569,7 @@ testGlobRemoveNonMatch mtimeChange =
threadDelay mtimeChange
removeFile root "dir/bad"
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/good-*"]
testGlobAddNonMatchSubdir :: Int -> Assertion
@@ -569,7 +580,7 @@ testGlobAddNonMatchSubdir mtimeChange =
threadDelay mtimeChange
touchFile root ("dir" </> "b" </> "bad")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*/good-*"]
testGlobRemoveNonMatchSubdir :: Int -> Assertion
@@ -581,10 +592,9 @@ testGlobRemoveNonMatchSubdir mtimeChange =
threadDelay mtimeChange
removeDir root ("dir" </> "b")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*/good-*"]
-
-- try and tickle a bug that happens if we don't maintain the invariant that
-- MonitorStateGlobFiles entries are sorted
testInvariantMonitorStateGlobFiles :: Int -> Assertion
@@ -609,7 +619,7 @@ testInvariantMonitorStateGlobFiles mtimeChange =
touchFile root ("dir" </> "b")
touchFile root ("dir" </> "a")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*"]
-- same thing for the subdirs case
@@ -631,7 +641,7 @@ testInvariantMonitorStateGlobDirs mtimeChange =
touchFile root ("dir" </> "b" </> "file")
touchFile root ("dir" </> "a" </> "file")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*/file"]
-- ensure that a glob can match a directory as well as a file
@@ -643,7 +653,7 @@ testGlobMatchDir mtimeChange =
threadDelay mtimeChange
-- nothing changed yet
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*"]
-- expect dir/b to match and be detected as changed
createDir root ("dir" </> "b")
@@ -664,7 +674,7 @@ testGlobMatchDirOnly mtimeChange =
-- expect file dir/a to not match, so not detected as changed
touchFile root ("dir" </> "a")
(res, files) <- expectMonitorUnchanged root monitor ()
- res @?= ()
+ res @?= ()
files @?= [monitorFileGlobStr "dir/*/"]
-- note that checking the file monitor for changes can updates the
-- cached dir mtimes (when it has to record that there's new matches)
@@ -683,7 +693,7 @@ testGlobChangeFileType mtimeChange =
updateMonitor root monitor [monitorFileGlobStr "dir/*"] () ()
threadDelay mtimeChange
removeFile root ("dir" </> "a")
- createDir root ("dir" </> "a")
+ createDir root ("dir" </> "a")
reason <- expectMonitorChanged root monitor ()
reason @?= MonitoredFileChanged ("dir" </> "a")
-- change dir to file
@@ -719,7 +729,6 @@ testGlobAbsolutePath mtimeChange =
reason3 <- expectMonitorChanged root monitor ()
reason3 @?= MonitoredFileChanged (root' </> "dir" </> "good-b")
-
------------------
-- value changes
--
@@ -730,7 +739,7 @@ testValueUnchanged =
touchFile root "a"
updateMonitor root monitor [monitorFile "a"] (42 :: Int) "ok"
(res, files) <- expectMonitorUnchanged root monitor 42
- res @?= "ok"
+ res @?= "ok"
files @?= [monitorFile "a"]
testValueChanged :: Assertion
@@ -756,7 +765,7 @@ testValueAndFileChanged mtimeChange =
-- if fileMonitorCheckIfOnlyValueChanged then if only the value changed
-- then it's reported as MonitoredValueChanged
let monitor' :: FileMonitor Int String
- monitor' = monitor { fileMonitorCheckIfOnlyValueChanged = True }
+ monitor' = monitor{fileMonitorCheckIfOnlyValueChanged = True}
updateMonitor root monitor' [monitorFile "a"] 42 "ok"
reason2 <- expectMonitorChanged root monitor' 43
reason2 @?= MonitoredValueChanged 42
@@ -774,18 +783,18 @@ testValueUpdated =
touchFile root "a"
let monitor' :: FileMonitor (Set.Set Int) String
- monitor' = (monitor :: FileMonitor (Set.Set Int) String) {
- fileMonitorCheckIfOnlyValueChanged = True,
- fileMonitorKeyValid = Set.isSubsetOf
- }
-
- updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42,43]) "ok"
- (res,_files) <- expectMonitorUnchanged root monitor' (Set.fromList [42])
+ monitor' =
+ (monitor :: FileMonitor (Set.Set Int) String)
+ { fileMonitorCheckIfOnlyValueChanged = True
+ , fileMonitorKeyValid = Set.isSubsetOf
+ }
+
+ updateMonitor root monitor' [monitorFile "a"] (Set.fromList [42, 43]) "ok"
+ (res, _files) <- expectMonitorUnchanged root monitor' (Set.fromList [42])
res @?= "ok"
- reason <- expectMonitorChanged root monitor' (Set.fromList [42,44])
- reason @?= MonitoredValueChanged (Set.fromList [42,43])
-
+ reason <- expectMonitorChanged root monitor' (Set.fromList [42, 44])
+ reason @?= MonitoredValueChanged (Set.fromList [42, 43])
-------------
-- Utils
@@ -810,7 +819,7 @@ removeFile (RootPath root) fname = IO.removeFile (root </> fname)
touchDir :: RootPath -> FilePath -> IO ()
touchDir root@(RootPath rootdir) dname = do
IO.createDirectoryIfMissing True (rootdir </> dname)
- touchFile root (dname </> "touch")
+ touchFile root (dname </> "touch")
removeFile root (dname </> "touch")
createDir :: RootPath -> FilePath -> IO ()
@@ -828,49 +837,68 @@ absoluteRoot (RootPath root) = IO.canonicalizePath root
monitorFileGlobStr :: String -> MonitorFilePath
monitorFileGlobStr globstr
| Just glob <- simpleParsec globstr = monitorFileGlob glob
- | otherwise = error $ "Failed to parse " ++ globstr
-
-
-expectMonitorChanged :: (Binary a, Structured a, Binary b, Structured b)
- => RootPath -> FileMonitor a b -> a
- -> IO (MonitorChangedReason a)
+ | otherwise = error $ "Failed to parse " ++ globstr
+
+expectMonitorChanged
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => RootPath
+ -> FileMonitor a b
+ -> a
+ -> IO (MonitorChangedReason a)
expectMonitorChanged root monitor key = do
res <- checkChanged root monitor key
case res of
MonitorChanged reason -> return reason
- MonitorUnchanged _ _ -> throwIO $ HUnitFailure Nothing "expected change"
-
-expectMonitorUnchanged :: (Binary a, Structured a, Binary b, Structured b)
- => RootPath -> FileMonitor a b -> a
- -> IO (b, [MonitorFilePath])
+ MonitorUnchanged _ _ -> throwIO $ HUnitFailure Nothing "expected change"
+
+expectMonitorUnchanged
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => RootPath
+ -> FileMonitor a b
+ -> a
+ -> IO (b, [MonitorFilePath])
expectMonitorUnchanged root monitor key = do
res <- checkChanged root monitor key
case res of
- MonitorChanged _reason -> throwIO $ HUnitFailure Nothing "expected no change"
+ MonitorChanged _reason -> throwIO $ HUnitFailure Nothing "expected no change"
MonitorUnchanged b files -> return (b, files)
-checkChanged :: (Binary a, Structured a, Binary b, Structured b)
- => RootPath -> FileMonitor a b
- -> a -> IO (MonitorChanged a b)
+checkChanged
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => RootPath
+ -> FileMonitor a b
+ -> a
+ -> IO (MonitorChanged a b)
checkChanged (RootPath root) monitor key =
checkFileMonitorChanged monitor root key
-updateMonitor :: (Binary a, Structured a, Binary b, Structured b)
- => RootPath -> FileMonitor a b
- -> [MonitorFilePath] -> a -> b -> IO ()
+updateMonitor
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => RootPath
+ -> FileMonitor a b
+ -> [MonitorFilePath]
+ -> a
+ -> b
+ -> IO ()
updateMonitor (RootPath root) monitor files key result =
updateFileMonitor monitor root Nothing files key result
-updateMonitorWithTimestamp :: (Binary a, Structured a, Binary b, Structured b)
- => RootPath -> FileMonitor a b -> MonitorTimestamp
- -> [MonitorFilePath] -> a -> b -> IO ()
+updateMonitorWithTimestamp
+ :: (Binary a, Structured a, Binary b, Structured b)
+ => RootPath
+ -> FileMonitor a b
+ -> MonitorTimestamp
+ -> [MonitorFilePath]
+ -> a
+ -> b
+ -> IO ()
updateMonitorWithTimestamp (RootPath root) monitor timestamp files key result =
updateFileMonitor monitor root (Just timestamp) files key result
withFileMonitor :: Eq a => (RootPath -> FileMonitor a b -> IO c) -> IO c
withFileMonitor action = do
withTempDirectory silent "." "file-status-" $ \root -> do
- let file = root <.> "monitor"
+ let file = root <.> "monitor"
monitor = newFileMonitor file
finally (action (RootPath root) monitor) $ do
exists <- IO.doesFileExist file
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs
index f2ddce463a351eb500b11cc33852c4d3fb9eb317..1ba189fe16afda8344ce04c505deecc6fed686e9 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/GZipUtils.hs
@@ -1,40 +1,41 @@
-module UnitTests.Distribution.Client.GZipUtils (
- tests
+module UnitTests.Distribution.Client.GZipUtils
+ ( tests
) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
-import Codec.Compression.GZip as GZip
-import Codec.Compression.Zlib as Zlib
-import Control.Exception (try)
-import Data.ByteString as BS (null)
-import Data.ByteString.Lazy as BSL (pack, toChunks)
-import Data.ByteString.Lazy.Char8 as BSLL (pack, init, length)
-import Distribution.Client.GZipUtils (maybeDecompress)
+import Codec.Compression.GZip as GZip
+import Codec.Compression.Zlib as Zlib
+import Control.Exception (try)
+import Data.ByteString as BS (null)
+import Data.ByteString.Lazy as BSL (pack, toChunks)
+import Data.ByteString.Lazy.Char8 as BSLL (init, length, pack)
+import Distribution.Client.GZipUtils (maybeDecompress)
import Test.Tasty
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
tests :: [TestTree]
-tests = [ testCase "maybeDecompress" maybeDecompressUnitTest
- -- "decompress plain" property is non-trivial to state,
- -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process
- -- generating such input would essentially duplicate maybeDecompress implementation
- , testProperty "decompress zlib" prop_maybeDecompress_zlib
- , testProperty "decompress gzip" prop_maybeDecompress_gzip
- ]
+tests =
+ [ testCase "maybeDecompress" maybeDecompressUnitTest
+ , -- "decompress plain" property is non-trivial to state,
+ -- maybeDecompress returns input bytestring only if error occurs right at the beginning of the decompression process
+ -- generating such input would essentially duplicate maybeDecompress implementation
+ testProperty "decompress zlib" prop_maybeDecompress_zlib
+ , testProperty "decompress gzip" prop_maybeDecompress_gzip
+ ]
maybeDecompressUnitTest :: Assertion
maybeDecompressUnitTest =
- assertBool "decompress plain" (maybeDecompress original == original)
- >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original)
- >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original)
- >> assertBool "decompress zlib" (maybeDecompress compressedZlib == original)
- >> assertBool "decompress gzip" (maybeDecompress compressedGZip == original)
- >> assertBool "have no empty chunks" (all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib)
- >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft)
+ assertBool "decompress plain" (maybeDecompress original == original)
+ >> assertBool "decompress zlib (with show)" (show (maybeDecompress compressedZlib) == show original)
+ >> assertBool "decompress gzip (with show)" (show (maybeDecompress compressedGZip) == show original)
+ >> assertBool "decompress zlib" (maybeDecompress compressedZlib == original)
+ >> assertBool "decompress gzip" (maybeDecompress compressedGZip == original)
+ >> assertBool "have no empty chunks" (all (not . BS.null) . BSL.toChunks . maybeDecompress $ compressedZlib)
+ >> (runBrokenStream >>= assertBool "decompress broken stream" . isLeft)
where
original = BSLL.pack "original uncompressed input"
compressedZlib = Zlib.compress original
@@ -45,13 +46,15 @@ maybeDecompressUnitTest =
prop_maybeDecompress_zlib :: [Word8] -> Property
prop_maybeDecompress_zlib ws = property $ maybeDecompress compressedZlib === original
- where original = BSL.pack ws
- compressedZlib = Zlib.compress original
+ where
+ original = BSL.pack ws
+ compressedZlib = Zlib.compress original
prop_maybeDecompress_gzip :: [Word8] -> Property
prop_maybeDecompress_gzip ws = property $ maybeDecompress compressedGZip === original
- where original = BSL.pack ws
- compressedGZip = GZip.compress original
+ where
+ original = BSL.pack ws
+ compressedGZip = GZip.compress original
-- (Only available from "Data.Either" since 7.8.)
isLeft :: Either a b -> Bool
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
index e5527a6364772efa063d78b0332217e80c42641d..11b073d2ebfab07c9b04f9029e051348d31c19a1 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Get.hs
@@ -1,21 +1,23 @@
-{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
module UnitTests.Distribution.Client.Get (tests) where
import Distribution.Client.Get
+import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..))
import Distribution.Types.PackageId
import Distribution.Types.PackageName
-import Distribution.Types.SourceRepo (SourceRepo (..), emptySourceRepo, RepoKind (..), RepoType (..), KnownRepoType (..))
-import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..))
+import Distribution.Types.SourceRepo (KnownRepoType (..), RepoKind (..), RepoType (..), SourceRepo (..), emptySourceRepo)
import Distribution.Verbosity as Verbosity
import Distribution.Version
-import Control.Monad
import Control.Exception
+import Control.Monad
import Data.Typeable
-import System.FilePath
import System.Directory
import System.Exit
+import System.FilePath
import System.IO.Error
import Test.Tasty
@@ -23,230 +25,253 @@ import Test.Tasty.HUnit
import UnitTests.Options (RunNetworkTests (..))
import UnitTests.TempTestDir (withTestDir)
-
tests :: [TestTree]
tests =
- [ testGroup "forkPackages"
- [ testCase "no repos" testNoRepos
- , testCase "no repos of requested kind" testNoReposOfKind
- , testCase "no repo type specified" testNoRepoType
- , testCase "unsupported repo type" testUnsupportedRepoType
- , testCase "no repo location specified" testNoRepoLocation
- , testCase "correct repo kind selection" testSelectRepoKind
- , testCase "repo destination exists" testRepoDestinationExists
- , testCase "git fetch failure" testGitFetchFailed
- ]
+ [ testGroup
+ "forkPackages"
+ [ testCase "no repos" testNoRepos
+ , testCase "no repos of requested kind" testNoReposOfKind
+ , testCase "no repo type specified" testNoRepoType
+ , testCase "unsupported repo type" testUnsupportedRepoType
+ , testCase "no repo location specified" testNoRepoLocation
+ , testCase "correct repo kind selection" testSelectRepoKind
+ , testCase "repo destination exists" testRepoDestinationExists
+ , testCase "git fetch failure" testGitFetchFailed
+ ]
, askOption $ \(RunNetworkTests doRunNetTests) ->
- testGroup "forkPackages, network tests" $
- includeTestsIf doRunNetTests $
- [ testCase "git clone" testNetworkGitClone
- ]
+ testGroup "forkPackages, network tests" $
+ includeTestsIf doRunNetTests $
+ [ testCase "git clone" testNetworkGitClone
+ ]
]
where
includeTestsIf True xs = xs
includeTestsIf False _ = []
-
-
verbosity :: Verbosity
verbosity = Verbosity.silent -- for debugging try verbose
pkgidfoo :: PackageId
-pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1,0])
-
+pkgidfoo = PackageIdentifier (mkPackageName "foo") (mkVersion [1, 0])
-- ------------------------------------------------------------
+
-- * Unit tests
+
-- ------------------------------------------------------------
testNoRepos :: Assertion
testNoRepos = do
- e <- assertException $
- clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
- e @?= ClonePackageNoSourceRepos pkgidfoo
+ e <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
+ e @?= ClonePackageNoSourceRepos pkgidfoo
where
pkgrepos = [(pkgidfoo, [])]
-
testNoReposOfKind :: Assertion
testNoReposOfKind = do
- e <- assertException $
- clonePackagesFromSourceRepo verbosity "." repokind pkgrepos
- e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind
+ e <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity "." repokind pkgrepos
+ e @?= ClonePackageNoSourceReposOfKind pkgidfoo repokind
where
pkgrepos = [(pkgidfoo, [repo])]
- repo = emptySourceRepo RepoHead
+ repo = emptySourceRepo RepoHead
repokind = Just RepoThis
-
testNoRepoType :: Assertion
testNoRepoType = do
- e <- assertException $
- clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
- e @?= ClonePackageNoRepoType pkgidfoo repo
+ e <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
+ e @?= ClonePackageNoRepoType pkgidfoo repo
where
pkgrepos = [(pkgidfoo, [repo])]
- repo = emptySourceRepo RepoHead
-
+ repo = emptySourceRepo RepoHead
testUnsupportedRepoType :: Assertion
testUnsupportedRepoType = do
- e <- assertException $
- clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
- e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype
+ e <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
+ e @?= ClonePackageUnsupportedRepoType pkgidfoo repo' repotype
where
pkgrepos = [(pkgidfoo, [repo])]
- repo = (emptySourceRepo RepoHead)
- { repoType = Just repotype
- , repoLocation = Just "loc"
- }
- repo' = SourceRepositoryPackage
- { srpType = repotype
- , srpLocation = "loc"
- , srpTag = Nothing
- , srpBranch = Nothing
- , srpSubdir = Proxy
- , srpCommand = []
- }
+ repo =
+ (emptySourceRepo RepoHead)
+ { repoType = Just repotype
+ , repoLocation = Just "loc"
+ }
+ repo' =
+ SourceRepositoryPackage
+ { srpType = repotype
+ , srpLocation = "loc"
+ , srpTag = Nothing
+ , srpBranch = Nothing
+ , srpSubdir = Proxy
+ , srpCommand = []
+ }
repotype = OtherRepoType "baz"
-
testNoRepoLocation :: Assertion
testNoRepoLocation = do
- e <- assertException $
- clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
- e @?= ClonePackageNoRepoLocation pkgidfoo repo
+ e <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity "." Nothing pkgrepos
+ e @?= ClonePackageNoRepoLocation pkgidfoo repo
where
pkgrepos = [(pkgidfoo, [repo])]
- repo = (emptySourceRepo RepoHead) {
- repoType = Just repotype
- }
+ repo =
+ (emptySourceRepo RepoHead)
+ { repoType = Just repotype
+ }
repotype = KnownRepoType Darcs
-
testSelectRepoKind :: Assertion
testSelectRepoKind =
- sequence_
- [ do e <- test requestedRepoType pkgrepos
- e @?= ClonePackageNoRepoType pkgidfoo expectedRepo
-
- e' <- test requestedRepoType (reverse pkgrepos)
- e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo
- | let test rt rs = assertException $
- clonePackagesFromSourceRepo verbosity "." rt rs
- , (requestedRepoType, expectedRepo) <- cases
- ]
+ sequence_
+ [ do
+ e <- test requestedRepoType pkgrepos
+ e @?= ClonePackageNoRepoType pkgidfoo expectedRepo
+
+ e' <- test requestedRepoType (reverse pkgrepos)
+ e' @?= ClonePackageNoRepoType pkgidfoo expectedRepo
+ | let test rt rs =
+ assertException $
+ clonePackagesFromSourceRepo verbosity "." rt rs
+ , (requestedRepoType, expectedRepo) <- cases
+ ]
where
pkgrepos = [(pkgidfoo, [repo1, repo2, repo3])]
- repo1 = emptySourceRepo RepoThis
- repo2 = emptySourceRepo RepoHead
- repo3 = emptySourceRepo (RepoKindUnknown "bar")
- cases = [ (Nothing, repo1)
- , (Just RepoThis, repo1)
- , (Just RepoHead, repo2)
- , (Just (RepoKindUnknown "bar"), repo3)
- ]
-
+ repo1 = emptySourceRepo RepoThis
+ repo2 = emptySourceRepo RepoHead
+ repo3 = emptySourceRepo (RepoKindUnknown "bar")
+ cases =
+ [ (Nothing, repo1)
+ , (Just RepoThis, repo1)
+ , (Just RepoHead, repo2)
+ , (Just (RepoKindUnknown "bar"), repo3)
+ ]
testRepoDestinationExists :: Assertion
testRepoDestinationExists =
- withTestDir verbosity "repos" $ \tmpdir -> do
- let pkgdir = tmpdir </> "foo"
- createDirectory pkgdir
- e1 <- assertException $
- clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
- e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -}
-
- removeDirectory pkgdir
-
- writeFile pkgdir ""
- e2 <- assertException $
- clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
- e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -}
+ withTestDir verbosity "repos" $ \tmpdir -> do
+ let pkgdir = tmpdir </> "foo"
+ createDirectory pkgdir
+ e1 <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
+ e1 @?= ClonePackageDestinationExists pkgidfoo pkgdir True {- isdir -}
+ removeDirectory pkgdir
+
+ writeFile pkgdir ""
+ e2 <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
+ e2 @?= ClonePackageDestinationExists pkgidfoo pkgdir False {- isfile -}
where
pkgrepos = [(pkgidfoo, [repo])]
- repo = (emptySourceRepo RepoHead) {
- repoType = Just (KnownRepoType Darcs),
- repoLocation = Just ""
- }
-
+ repo =
+ (emptySourceRepo RepoHead)
+ { repoType = Just (KnownRepoType Darcs)
+ , repoLocation = Just ""
+ }
testGitFetchFailed :: Assertion
testGitFetchFailed =
- withTestDir verbosity "repos" $ \tmpdir -> do
- let srcdir = tmpdir </> "src"
- repo = (emptySourceRepo RepoHead) {
- repoType = Just (KnownRepoType Git),
- repoLocation = Just srcdir
- }
- repo' = SourceRepositoryPackage
- { srpType = KnownRepoType Git
- , srpLocation = srcdir
- , srpTag = Nothing
- , srpBranch = Nothing
- , srpSubdir = Proxy
- , srpCommand = []
- }
- pkgrepos = [(pkgidfoo, [repo])]
- e1 <- assertException $
- clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
- e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128)
-
+ withTestDir verbosity "repos" $ \tmpdir -> do
+ let srcdir = tmpdir </> "src"
+ repo =
+ (emptySourceRepo RepoHead)
+ { repoType = Just (KnownRepoType Git)
+ , repoLocation = Just srcdir
+ }
+ repo' =
+ SourceRepositoryPackage
+ { srpType = KnownRepoType Git
+ , srpLocation = srcdir
+ , srpTag = Nothing
+ , srpBranch = Nothing
+ , srpSubdir = Proxy
+ , srpCommand = []
+ }
+ pkgrepos = [(pkgidfoo, [repo])]
+ e1 <-
+ assertException $
+ clonePackagesFromSourceRepo verbosity tmpdir Nothing pkgrepos
+ e1 @?= ClonePackageFailedWithExitCode pkgidfoo repo' "git" (ExitFailure 128)
testNetworkGitClone :: Assertion
testNetworkGitClone =
- withTestDir verbosity "repos" $ \tmpdir -> do
- let repo1 = (emptySourceRepo RepoHead) {
- repoType = Just (KnownRepoType Git),
- repoLocation = Just "https://github.com/haskell/zlib.git"
- }
- clonePackagesFromSourceRepo verbosity tmpdir Nothing
- [(mkpkgid "zlib1", [repo1])]
- assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]
-
- let repo2 = (emptySourceRepo RepoHead) {
- repoType = Just (KnownRepoType Git),
- repoLocation = Just (tmpdir </> "zlib1")
- }
- clonePackagesFromSourceRepo verbosity tmpdir Nothing
- [(mkpkgid "zlib2", [repo2])]
- assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]
-
- let repo3 = (emptySourceRepo RepoHead) {
- repoType = Just (KnownRepoType Git),
- repoLocation = Just (tmpdir </> "zlib1"),
- repoTag = Just "0.5.0.0"
- }
- clonePackagesFromSourceRepo verbosity tmpdir Nothing
- [(mkpkgid "zlib3", [repo3])]
- assertFileContains (tmpdir </> "zlib3/zlib.cabal") ["version:", "0.5.0.0"]
+ withTestDir verbosity "repos" $ \tmpdir -> do
+ let repo1 =
+ (emptySourceRepo RepoHead)
+ { repoType = Just (KnownRepoType Git)
+ , repoLocation = Just "https://github.com/haskell/zlib.git"
+ }
+ clonePackagesFromSourceRepo
+ verbosity
+ tmpdir
+ Nothing
+ [(mkpkgid "zlib1", [repo1])]
+ assertFileContains (tmpdir </> "zlib1/zlib.cabal") ["name:", "zlib"]
+
+ let repo2 =
+ (emptySourceRepo RepoHead)
+ { repoType = Just (KnownRepoType Git)
+ , repoLocation = Just (tmpdir </> "zlib1")
+ }
+ clonePackagesFromSourceRepo
+ verbosity
+ tmpdir
+ Nothing
+ [(mkpkgid "zlib2", [repo2])]
+ assertFileContains (tmpdir </> "zlib2/zlib.cabal") ["name:", "zlib"]
+
+ let repo3 =
+ (emptySourceRepo RepoHead)
+ { repoType = Just (KnownRepoType Git)
+ , repoLocation = Just (tmpdir </> "zlib1")
+ , repoTag = Just "0.5.0.0"
+ }
+ clonePackagesFromSourceRepo
+ verbosity
+ tmpdir
+ Nothing
+ [(mkpkgid "zlib3", [repo3])]
+ assertFileContains (tmpdir </> "zlib3/zlib.cabal") ["version:", "0.5.0.0"]
where
mkpkgid nm = PackageIdentifier (mkPackageName nm) (mkVersion [])
-
-- ------------------------------------------------------------
+
-- * HUnit utils
+
-- ------------------------------------------------------------
assertException :: forall e a. (Exception e, HasCallStack) => IO a -> IO e
assertException action = do
- r <- try action
- case r of
- Left e -> return e
- Right _ -> assertFailure $ "expected exception of type "
- ++ show (typeOf (undefined :: e))
-
+ r <- try action
+ case r of
+ Left e -> return e
+ Right _ ->
+ assertFailure $
+ "expected exception of type "
+ ++ show (typeOf (undefined :: e))
-- | Expect that one line in a file matches exactly the given words (i.e. at
-- least insensitive to whitespace)
---
assertFileContains :: HasCallStack => FilePath -> [String] -> Assertion
assertFileContains file expected = do
- c <- readFile file `catch` \e ->
- if isDoesNotExistError e
- then assertFailure $ "expected a file to exist: " ++ file
- else throwIO e
- unless (expected `elem` map words (lines c)) $
- assertFailure $ "expected the file " ++ file ++ " to contain "
- ++ show (take 100 expected)
-
+ c <-
+ readFile file `catch` \e ->
+ if isDoesNotExistError e
+ then assertFailure $ "expected a file to exist: " ++ file
+ else throwIO e
+ unless (expected `elem` map words (lines c)) $
+ assertFailure $
+ "expected the file "
+ ++ file
+ ++ " to contain "
+ ++ show (take 100 expected)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
index 427516e332d5bdb3b7c273a251a64aa81d4bc439..8d77b6784ef3f4762e37997b1e852408a0c561d9 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Glob.hs
@@ -10,85 +10,118 @@ import Distribution.Client.Glob
import Distribution.Utils.Structured (structureHash)
import UnitTests.Distribution.Client.ArbitraryInstances ()
+import GHC.Fingerprint (Fingerprint (..))
import Test.Tasty
-import Test.Tasty.QuickCheck
import Test.Tasty.HUnit
-import GHC.Fingerprint (Fingerprint (..))
+import Test.Tasty.QuickCheck
tests :: [TestTree]
tests =
[ testProperty "print/parse roundtrip" prop_roundtrip_printparse
- , testCase "parse examples" testParseCases
- , testGroup "Structured hashes"
- [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782
- , testCase "FilePathGlobRel" $ structureHash (Proxy :: Proxy FilePathGlobRel) @?= Fingerprint 0x76fa5bcb865a8501 0xb152f68915316f98
- , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5
- , testCase "FilePathGlob" $ structureHash (Proxy :: Proxy FilePathGlob) @?= Fingerprint 0x3c11c41f3f03a1f0 0x96e69d85c37d0024
- ]
+ , testCase "parse examples" testParseCases
+ , testGroup
+ "Structured hashes"
+ [ testCase "GlobPiece" $ structureHash (Proxy :: Proxy GlobPiece) @?= Fingerprint 0xd5e5361866a30ea2 0x31fbfe7b58864782
+ , testCase "FilePathGlobRel" $ structureHash (Proxy :: Proxy FilePathGlobRel) @?= Fingerprint 0x76fa5bcb865a8501 0xb152f68915316f98
+ , testCase "FilePathRoot" $ structureHash (Proxy :: Proxy FilePathRoot) @?= Fingerprint 0x713373d51426ec64 0xda7376a38ecee5a5
+ , testCase "FilePathGlob" $ structureHash (Proxy :: Proxy FilePathGlob) @?= Fingerprint 0x3c11c41f3f03a1f0 0x96e69d85c37d0024
+ ]
]
---TODO: [nice to have] tests for trivial globs, tests for matching,
+-- TODO: [nice to have] tests for trivial globs, tests for matching,
-- tests for windows style file paths
prop_roundtrip_printparse :: FilePathGlob -> Property
prop_roundtrip_printparse pathglob =
- counterexample (prettyShow pathglob) $
+ counterexample (prettyShow pathglob) $
eitherParsec (prettyShow pathglob) === Right pathglob
-- first run, where we don't even call updateMonitor
testParseCases :: Assertion
testParseCases = do
-
FilePathGlob (FilePathRoot "/") GlobDirTrailing <- testparse "/"
- FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
+ FilePathGlob FilePathHomeDir GlobDirTrailing <- testparse "~/"
FilePathGlob (FilePathRoot "A:\\") GlobDirTrailing <- testparse "A:/"
FilePathGlob (FilePathRoot "Z:\\") GlobDirTrailing <- testparse "z:/"
FilePathGlob (FilePathRoot "C:\\") GlobDirTrailing <- testparse "C:\\"
FilePathGlob FilePathRelative (GlobFile [Literal "_:"]) <- testparse "_:"
- FilePathGlob FilePathRelative
- (GlobFile [Literal "."]) <- testparse "."
-
- FilePathGlob FilePathRelative
- (GlobFile [Literal "~"]) <- testparse "~"
-
- FilePathGlob FilePathRelative
- (GlobDir [Literal "."] GlobDirTrailing) <- testparse "./"
-
- FilePathGlob FilePathRelative
- (GlobFile [Literal "foo"]) <- testparse "foo"
-
- FilePathGlob FilePathRelative
- (GlobDir [Literal "foo"]
- (GlobFile [Literal "bar"])) <- testparse "foo/bar"
-
- FilePathGlob FilePathRelative
- (GlobDir [Literal "foo"]
- (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "foo/bar/"
-
- FilePathGlob (FilePathRoot "/")
- (GlobDir [Literal "foo"]
- (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "/foo/bar/"
-
- FilePathGlob (FilePathRoot "C:\\")
- (GlobDir [Literal "foo"]
- (GlobDir [Literal "bar"] GlobDirTrailing)) <- testparse "C:\\foo\\bar\\"
-
- FilePathGlob FilePathRelative
- (GlobFile [WildCard]) <- testparse "*"
-
- FilePathGlob FilePathRelative
- (GlobFile [WildCard,WildCard]) <- testparse "**" -- not helpful but valid
-
- FilePathGlob FilePathRelative
- (GlobFile [WildCard, Literal "foo", WildCard]) <- testparse "*foo*"
-
- FilePathGlob FilePathRelative
- (GlobFile [Literal "foo", WildCard, Literal "bar"]) <- testparse "foo*bar"
-
- FilePathGlob FilePathRelative
- (GlobFile [Union [[WildCard], [Literal "foo"]]]) <- testparse "{*,foo}"
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [Literal "."]) <-
+ testparse "."
+
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [Literal "~"]) <-
+ testparse "~"
+
+ FilePathGlob
+ FilePathRelative
+ (GlobDir [Literal "."] GlobDirTrailing) <-
+ testparse "./"
+
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [Literal "foo"]) <-
+ testparse "foo"
+
+ FilePathGlob
+ FilePathRelative
+ ( GlobDir
+ [Literal "foo"]
+ (GlobFile [Literal "bar"])
+ ) <-
+ testparse "foo/bar"
+
+ FilePathGlob
+ FilePathRelative
+ ( GlobDir
+ [Literal "foo"]
+ (GlobDir [Literal "bar"] GlobDirTrailing)
+ ) <-
+ testparse "foo/bar/"
+
+ FilePathGlob
+ (FilePathRoot "/")
+ ( GlobDir
+ [Literal "foo"]
+ (GlobDir [Literal "bar"] GlobDirTrailing)
+ ) <-
+ testparse "/foo/bar/"
+
+ FilePathGlob
+ (FilePathRoot "C:\\")
+ ( GlobDir
+ [Literal "foo"]
+ (GlobDir [Literal "bar"] GlobDirTrailing)
+ ) <-
+ testparse "C:\\foo\\bar\\"
+
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [WildCard]) <-
+ testparse "*"
+
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [WildCard, WildCard]) <-
+ testparse "**" -- not helpful but valid
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [WildCard, Literal "foo", WildCard]) <-
+ testparse "*foo*"
+
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [Literal "foo", WildCard, Literal "bar"]) <-
+ testparse "foo*bar"
+
+ FilePathGlob
+ FilePathRelative
+ (GlobFile [Union [[WildCard], [Literal "foo"]]]) <-
+ testparse "{*,foo}"
parseFail "{"
parseFail "}"
@@ -104,12 +137,12 @@ testParseCases = do
testparse :: String -> IO FilePathGlob
testparse s =
- case eitherParsec s of
- Right p -> return p
- Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err)
+ case eitherParsec s of
+ Right p -> return p
+ Left err -> throwIO $ HUnitFailure Nothing ("expected parse of: " ++ s ++ " -- " ++ err)
parseFail :: String -> Assertion
parseFail s =
- case eitherParsec s :: Either String FilePathGlob of
- Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p)
- Left _ -> return ()
+ case eitherParsec s :: Either String FilePathGlob of
+ Right p -> throwIO $ HUnitFailure Nothing ("expected no parse of: " ++ s ++ " -- " ++ show p)
+ Left _ -> return ()
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs
index 52369cbc4a48b2d23209f4c38dab4912e81f5044..fbd5952019a382d223c92f422d439230aef878f0 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils.hs
@@ -3,77 +3,80 @@ module UnitTests.Distribution.Client.IndexUtils where
import Distribution.Client.IndexUtils
import qualified Distribution.Compat.NonEmptySet as NES
import Distribution.Simple.Utils (toUTF8LBS)
-import Distribution.Version
import Distribution.Types.Dependency
-import Distribution.Types.PackageName
import Distribution.Types.LibraryName
-
+import Distribution.Types.PackageName
+import Distribution.Version
import Test.Tasty
import Test.Tasty.HUnit
tests :: [TestTree]
tests =
- [ simpleVersionsParserTests
- ]
+ [ simpleVersionsParserTests
+ ]
simpleVersionsParserTests :: TestTree
-simpleVersionsParserTests = testGroup "Simple preferred-versions Parser Tests"
+simpleVersionsParserTests =
+ testGroup
+ "Simple preferred-versions Parser Tests"
[ testCase "simple deprecation dependency" $ do
let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0")
- prefs @?=
- [ Right
- (Dependency
- (mkPackageName "binary")
- (unionVersionRanges
- (earlierVersion $ mkVersion [0,9,0,0])
- (laterVersion $ mkVersion [0,9,0,0])
- )
- (NES.singleton LMainLibName)
- )
- ]
+ prefs
+ @?= [ Right
+ ( Dependency
+ (mkPackageName "binary")
+ ( unionVersionRanges
+ (earlierVersion $ mkVersion [0, 9, 0, 0])
+ (laterVersion $ mkVersion [0, 9, 0, 0])
+ )
+ (NES.singleton LMainLibName)
+ )
+ ]
, testCase "multiple deprecation dependency" $ do
let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary < 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1")
- prefs @?=
- [ Right
- (Dependency
- (mkPackageName "binary")
- (unionVersionRanges
- (earlierVersion $ mkVersion [0,9,0,0])
- (laterVersion $ mkVersion [0,9,0,0])
- )
- (NES.singleton LMainLibName)
- )
- , Right
- (Dependency
- (mkPackageName "containers")
- (thisVersion $ mkVersion [0,6,4,1])
- (NES.singleton LMainLibName)
- )
- ]
+ prefs
+ @?= [ Right
+ ( Dependency
+ (mkPackageName "binary")
+ ( unionVersionRanges
+ (earlierVersion $ mkVersion [0, 9, 0, 0])
+ (laterVersion $ mkVersion [0, 9, 0, 0])
+ )
+ (NES.singleton LMainLibName)
+ )
+ , Right
+ ( Dependency
+ (mkPackageName "containers")
+ (thisVersion $ mkVersion [0, 6, 4, 1])
+ (NES.singleton LMainLibName)
+ )
+ ]
, testCase "unparsable dependency" $ do
let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0")
- prefs @?=
- [ Left binaryDepParseError
- ]
+ prefs
+ @?= [ Left binaryDepParseError
+ ]
, testCase "partial parse" $ do
let prefs = parsePreferredVersionsWarnings (toUTF8LBS "binary 0.9.0.0 || > 0.9.0.0\ncontainers == 0.6.4.1")
- prefs @?=
- [ Left binaryDepParseError
- , Right
- (Dependency
- (mkPackageName "containers")
- (thisVersion $ mkVersion [0,6,4,1])
- (NES.singleton LMainLibName)
- )
- ]
+ prefs
+ @?= [ Left binaryDepParseError
+ , Right
+ ( Dependency
+ (mkPackageName "containers")
+ (thisVersion $ mkVersion [0, 6, 4, 1])
+ (NES.singleton LMainLibName)
+ )
+ ]
]
- where
- binaryDepParseError = PreferredVersionsParseError
- { preferredVersionsParsecError = mconcat
- [ "\"<eitherParsec>\" (line 1, column 8):\n"
- , "unexpected '0'\n"
- , "expecting space, white space, opening paren, operator or end of input"
- ]
- , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0"
- }
+ where
+ binaryDepParseError =
+ PreferredVersionsParseError
+ { preferredVersionsParsecError =
+ mconcat
+ [ "\"<eitherParsec>\" (line 1, column 8):\n"
+ , "unexpected '0'\n"
+ , "expecting space, white space, opening paren, operator or end of input"
+ ]
+ , preferredVersionsOriginalDependency = "binary 0.9.0.0 || > 0.9.0.0"
+ }
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs
index a7a0b7d7e3e672cc9fe47e4f888ecf7dba01bc5c..3b53e66c219734036492a001e3bd12f49d489b2e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/IndexUtils/Timestamp.hs
@@ -1,9 +1,9 @@
module UnitTests.Distribution.Client.IndexUtils.Timestamp (tests) where
-import Distribution.Parsec (simpleParsec)
-import Distribution.Pretty (prettyShow)
import Data.Time
import Data.Time.Clock.POSIX
+import Distribution.Parsec (simpleParsec)
+import Distribution.Pretty (prettyShow)
import Distribution.Client.IndexUtils.Timestamp
@@ -12,50 +12,51 @@ import Test.Tasty.QuickCheck
tests :: [TestTree]
tests =
- [ testProperty "Timestamp1" prop_timestamp1
- , testProperty "Timestamp2" prop_timestamp2
- , testProperty "Timestamp3" prop_timestamp3
- , testProperty "Timestamp4" prop_timestamp4
- , testProperty "Timestamp5" prop_timestamp5
- ]
+ [ testProperty "Timestamp1" prop_timestamp1
+ , testProperty "Timestamp2" prop_timestamp2
+ , testProperty "Timestamp3" prop_timestamp3
+ , testProperty "Timestamp4" prop_timestamp4
+ , testProperty "Timestamp5" prop_timestamp5
+ ]
-- test unixtime format parsing
prop_timestamp1 :: NonNegative Int -> Bool
-prop_timestamp1 (NonNegative t0) = Just t == simpleParsec ('@':show t0)
+prop_timestamp1 (NonNegative t0) = Just t == simpleParsec ('@' : show t0)
where
t = toEnum t0 :: Timestamp
-- test prettyShow/simpleParse roundtrip
prop_timestamp2 :: Int -> Bool
prop_timestamp2 t0
- | t /= nullTimestamp = simpleParsec (prettyShow t) == Just t
- | otherwise = prettyShow t == ""
+ | t /= nullTimestamp = simpleParsec (prettyShow t) == Just t
+ | otherwise = prettyShow t == ""
where
t = toEnum t0 :: Timestamp
-- test prettyShow against reference impl
prop_timestamp3 :: Int -> Bool
prop_timestamp3 t0
- | t /= nullTimestamp = refDisp t == prettyShow t
- | otherwise = prettyShow t == ""
+ | t /= nullTimestamp = refDisp t == prettyShow t
+ | otherwise = prettyShow t == ""
where
t = toEnum t0 :: Timestamp
- refDisp = maybe undefined (formatTime undefined "%FT%TZ")
- . timestampToUTCTime
+ refDisp =
+ maybe undefined (formatTime undefined "%FT%TZ")
+ . timestampToUTCTime
-- test utcTimeToTimestamp/timestampToUTCTime roundtrip
prop_timestamp4 :: Int -> Bool
prop_timestamp4 t0
- | t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t
- | otherwise = timestampToUTCTime t == Nothing
+ | t /= nullTimestamp = (utcTimeToTimestamp =<< timestampToUTCTime t) == Just t
+ | otherwise = timestampToUTCTime t == Nothing
where
t = toEnum t0 :: Timestamp
prop_timestamp5 :: Int -> Bool
prop_timestamp5 t0
| t /= nullTimestamp = timestampToUTCTime t == Just ut
- | otherwise = timestampToUTCTime t == Nothing
+ | otherwise = timestampToUTCTime t == Nothing
where
t = toEnum t0 :: Timestamp
ut = posixSecondsToUTCTime (fromIntegral t0)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs
index b50a9ab5fa141fbab498f4f578da9e60f9423ddf..b06faef53127665c778835681c430b238b91d650 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init.hs
@@ -1,14 +1,14 @@
module UnitTests.Distribution.Client.Init
-( tests
-) where
+ ( tests
+ ) where
import Test.Tasty
-import qualified UnitTests.Distribution.Client.Init.Interactive as Interactive
+import qualified UnitTests.Distribution.Client.Init.FileCreators as FileCreators
+import qualified UnitTests.Distribution.Client.Init.Golden as Golden
+import qualified UnitTests.Distribution.Client.Init.Interactive as Interactive
import qualified UnitTests.Distribution.Client.Init.NonInteractive as NonInteractive
-import qualified UnitTests.Distribution.Client.Init.Golden as Golden
-import qualified UnitTests.Distribution.Client.Init.Simple as Simple
-import qualified UnitTests.Distribution.Client.Init.FileCreators as FileCreators
+import qualified UnitTests.Distribution.Client.Init.Simple as Simple
import UnitTests.Distribution.Client.Init.Utils
@@ -19,33 +19,32 @@ import Distribution.Client.Sandbox
import Distribution.Client.Setup
import Distribution.Verbosity
-
tests :: IO [TestTree]
tests = do
- confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags
+ confFlags <- loadConfigOrSandboxConfig v defaultGlobalFlags
- let confFlags' = savedConfigureFlags confFlags `mappend` compFlags
- initFlags' = savedInitFlags confFlags `mappend` emptyFlags
- globalFlags' = savedGlobalFlags confFlags `mappend` defaultGlobalFlags
+ let confFlags' = savedConfigureFlags confFlags `mappend` compFlags
+ initFlags' = savedInitFlags confFlags `mappend` emptyFlags
+ globalFlags' = savedGlobalFlags confFlags `mappend` defaultGlobalFlags
- (comp, _, progdb) <- configCompilerAux' confFlags'
+ (comp, _, progdb) <- configCompilerAux' confFlags'
- withRepoContext v globalFlags' $ \repoCtx -> do
- let pkgDb = configPackageDB' confFlags'
+ withRepoContext v globalFlags' $ \repoCtx -> do
+ let pkgDb = configPackageDB' confFlags'
- pkgIx <- getInstalledPackages v comp pkgDb progdb
- srcDb <- getSourcePackages v repoCtx
+ pkgIx <- getInstalledPackages v comp pkgDb progdb
+ srcDb <- getSourcePackages v repoCtx
- return
- [ Interactive.tests v initFlags' pkgIx srcDb
- , NonInteractive.tests v initFlags' comp pkgIx srcDb
- , Golden.tests v initFlags' pkgIx srcDb
- , Simple.tests v initFlags' pkgIx srcDb
- , FileCreators.tests v initFlags' comp pkgIx srcDb
- ]
+ return
+ [ Interactive.tests v initFlags' pkgIx srcDb
+ , NonInteractive.tests v initFlags' comp pkgIx srcDb
+ , Golden.tests v initFlags' pkgIx srcDb
+ , Simple.tests v initFlags' pkgIx srcDb
+ , FileCreators.tests v initFlags' comp pkgIx srcDb
+ ]
where
v :: Verbosity
v = normal
compFlags :: ConfigFlags
- compFlags = mempty { configHcPath = initHcPath emptyFlags }
+ compFlags = mempty{configHcPath = initHcPath emptyFlags}
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs
index 2c0ab93666964b7393359d5e1fdc53418e77ff77..38c488dd3a7017300705cb3803182142d61f6a18 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/FileCreators.hs
@@ -1,5 +1,6 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+
module UnitTests.Distribution.Client.Init.FileCreators
( tests
) where
@@ -19,71 +20,70 @@ import Distribution.Simple.PackageIndex
import Distribution.Verbosity
tests
- :: Verbosity
- -> InitFlags
- -> Compiler
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> TestTree
+ :: Verbosity
+ -> InitFlags
+ -> Compiler
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> TestTree
tests _v _initFlags comp pkgIx srcDb =
- testGroup "Distribution.Client.Init.FileCreators"
+ testGroup
+ "Distribution.Client.Init.FileCreators"
[ testCase "Check . as source directory" $ do
- let dummyFlags' = dummyFlags
- { packageType = Flag LibraryAndExecutable
- , minimal = Flag False
- , overwrite = Flag False
- , packageDir = Flag "/home/test/test-package"
- , extraDoc = Flag ["CHANGELOG.md"]
- , exposedModules = Flag []
- , otherModules = Flag []
- , otherExts = Flag []
- , buildTools = Flag []
- , mainIs = Flag "quxApp/Main.hs"
- , dependencies = Flag []
- , sourceDirs = Flag ["."]
- }
+ let dummyFlags' =
+ dummyFlags
+ { packageType = Flag LibraryAndExecutable
+ , minimal = Flag False
+ , overwrite = Flag False
+ , packageDir = Flag "/home/test/test-package"
+ , extraDoc = Flag ["CHANGELOG.md"]
+ , exposedModules = Flag []
+ , otherModules = Flag []
+ , otherExts = Flag []
+ , buildTools = Flag []
+ , mainIs = Flag "quxApp/Main.hs"
+ , dependencies = Flag []
+ , sourceDirs = Flag ["."]
+ }
inputs =
-- createProject stuff
[ "Foobar"
, "foobar@qux.com"
, "True"
, "[\"quxTest/Main.hs\"]"
- -- writeProject stuff
- -- writeLicense
- , "2021"
- -- writeFileSafe
- , "True"
- -- findNewPath
- , "False"
- -- writeChangeLog
- -- writeFileSafe
- , "False"
- -- prepareLibTarget
- -- writeDirectoriesSafe
- , "True"
- -- findNewPath
- , "False"
- -- prepareExeTarget
- -- writeDirectoriesSafe
- , "False"
- -- writeFileSafe
- , "False"
- -- prepareTestTarget
- -- writeDirectoriesSafe
- , "False"
- -- writeFileSafe
- , "False"
- -- writeCabalFile
- -- writeFileSafe
- , "False"
+ , -- writeProject stuff
+ -- writeLicense
+ "2021"
+ , -- writeFileSafe
+ "True"
+ , -- findNewPath
+ "False"
+ , -- writeChangeLog
+ -- writeFileSafe
+ "False"
+ , -- prepareLibTarget
+ -- writeDirectoriesSafe
+ "True"
+ , -- findNewPath
+ "False"
+ , -- prepareExeTarget
+ -- writeDirectoriesSafe
+ "False"
+ , -- writeFileSafe
+ "False"
+ , -- prepareTestTarget
+ -- writeDirectoriesSafe
+ "False"
+ , -- writeFileSafe
+ "False"
+ , -- writeCabalFile
+ -- writeFileSafe
+ "False"
]
case flip _runPrompt inputs $ do
- projSettings <- createProject comp silent pkgIx srcDb dummyFlags'
- writeProject projSettings of
-
+ projSettings <- createProject comp silent pkgIx srcDb dummyFlags'
+ writeProject projSettings of
Left (BreakException ex) -> assertFailure $ show ex
Right _ -> return ()
-
-
]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs
index 1a14e1f69b84d1ce659b40b42c40fa9459a3da73..0ad087c2535b386db6b79620597a2fd7417fe520 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Golden.hs
@@ -1,9 +1,9 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
-module UnitTests.Distribution.Client.Init.Golden
-( tests
-) where
+module UnitTests.Distribution.Client.Init.Golden
+ ( tests
+ ) where
import Test.Tasty
import Test.Tasty.Golden
@@ -16,22 +16,22 @@ import Data.List.NonEmpty as NEL (NonEmpty, drop)
import Data.Semigroup ((<>))
#endif
+import Distribution.CabalSpecVersion
+import Distribution.Client.Init.FlagExtractors
+import Distribution.Client.Init.Format
+import Distribution.Client.Init.Interactive.Command
import Distribution.Client.Init.Types
-import Distribution.Simple.PackageIndex hiding (fromList)
-import Distribution.Verbosity
import Distribution.Client.Types.SourcePackageDb
-import Distribution.Client.Init.Interactive.Command
-import Distribution.Client.Init.Format
import Distribution.Fields.Pretty
-import Distribution.Types.PackageName (PackageName)
-import Distribution.Client.Init.FlagExtractors
import Distribution.Simple.Flag
-import Distribution.CabalSpecVersion
+import Distribution.Simple.PackageIndex hiding (fromList)
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Verbosity
import System.FilePath
-import UnitTests.Distribution.Client.Init.Utils
import Distribution.Client.Init.Defaults
+import UnitTests.Distribution.Client.Init.Utils
-- -------------------------------------------------------------------- --
-- golden test suite
@@ -50,14 +50,15 @@ import Distribution.Client.Init.Defaults
-- Additionally, we test whole @.cabal@ file generation for every combination
-- of library, lib + tests, exe, exe + tests, exe + lib, exe + lib + tests
-- and so on against the same options.
---
tests
- :: Verbosity
- -> InitFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> TestTree
-tests v initFlags pkgIx srcDb = testGroup "golden"
+ :: Verbosity
+ -> InitFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> TestTree
+tests v initFlags pkgIx srcDb =
+ testGroup
+ "golden"
[ goldenLibTests v pkgIx pkgDir pkgName
, goldenExeTests v pkgIx pkgDir pkgName
, goldenTestTests v pkgIx pkgDir pkgName
@@ -65,37 +66,42 @@ tests v initFlags pkgIx srcDb = testGroup "golden"
, goldenCabalTests v pkgIx srcDb
]
where
- pkgDir = evalPrompt (getPackageDir initFlags)
- $ fromList ["."]
- pkgName = evalPrompt (packageNamePrompt srcDb initFlags)
- $ fromList ["test-package", "test-package", "y"]
+ pkgDir =
+ evalPrompt (getPackageDir initFlags) $
+ fromList ["."]
+ pkgName =
+ evalPrompt (packageNamePrompt srcDb initFlags) $
+ fromList ["test-package", "test-package", "y"]
goldenPkgDescTests
- :: Verbosity
- -> SourcePackageDb
- -> FilePath
- -> PackageName
- -> TestTree
-goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golden tests"
- [ goldenVsString "Empty flags, non-simple, no comments"
- (goldenPkgDesc "pkg.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runPkgDesc opts emptyFlags pkgArgs
-
- , goldenVsString "Empty flags, non-simple, with comments"
- (goldenPkgDesc "pkg-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runPkgDesc opts emptyFlags pkgArgs
-
- , goldenVsString "Dummy flags, >= cabal version syntax, with comments"
- (goldenPkgDesc "pkg-with-flags.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV1_0}) pkgArgs
-
- , goldenVsString "Dummy flags, old cabal version, with comments"
- (goldenPkgDesc "pkg-old-cabal-with-flags.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runPkgDesc opts (dummyFlags {cabalVersion = Flag CabalSpecV2_0}) pkgArgs
+ :: Verbosity
+ -> SourcePackageDb
+ -> FilePath
+ -> PackageName
+ -> TestTree
+goldenPkgDescTests v srcDb pkgDir pkgName =
+ testGroup
+ "package description golden tests"
+ [ goldenVsString
+ "Empty flags, non-simple, no comments"
+ (goldenPkgDesc "pkg.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runPkgDesc opts emptyFlags pkgArgs
+ , goldenVsString
+ "Empty flags, non-simple, with comments"
+ (goldenPkgDesc "pkg-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runPkgDesc opts emptyFlags pkgArgs
+ , goldenVsString
+ "Dummy flags, >= cabal version syntax, with comments"
+ (goldenPkgDesc "pkg-with-flags.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV1_0}) pkgArgs
+ , goldenVsString
+ "Dummy flags, old cabal version, with comments"
+ (goldenPkgDesc "pkg-old-cabal-with-flags.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runPkgDesc opts (dummyFlags{cabalVersion = Flag CabalSpecV2_0}) pkgArgs
]
where
runPkgDesc opts flags args = do
@@ -104,207 +110,220 @@ goldenPkgDescTests v srcDb pkgDir pkgName = testGroup "package description golde
Right (pkg, _) -> mkStanza $ mkPkgDescription opts pkg
goldenExeTests
- :: Verbosity
- -> InstalledPackageIndex
- -> FilePath
- -> PackageName
- -> TestTree
-goldenExeTests v pkgIx pkgDir pkgName = testGroup "exe golden tests"
- [ goldenVsString "Empty flags, not simple, no options, no comments"
- (goldenExe "exe-no-comments.golden") $
- let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion
- in runGoldenExe opts exeArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with comments + no minimal"
- (goldenExe "exe-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion
- in runGoldenExe opts exeArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with minimal + no comments"
- (goldenExe "exe-minimal-no-comments.golden") $
- let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion
- in runGoldenExe opts exeArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with minimal + comments"
- (goldenExe "exe-simple-minimal-with-comments.golden") $
- let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion
- in runGoldenExe opts exeArgs emptyFlags
-
- , goldenVsString "Build tools flag, not simple, with comments + no minimal"
- (goldenExe "exe-build-tools-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion
- in runGoldenExe opts exeArgs (emptyFlags {buildTools = Flag ["happy"]})
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> FilePath
+ -> PackageName
+ -> TestTree
+goldenExeTests v pkgIx pkgDir pkgName =
+ testGroup
+ "exe golden tests"
+ [ goldenVsString
+ "Empty flags, not simple, no options, no comments"
+ (goldenExe "exe-no-comments.golden")
+ $ let opts = WriteOpts False False True v pkgDir Executable pkgName defaultCabalVersion
+ in runGoldenExe opts exeArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with comments + no minimal"
+ (goldenExe "exe-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion
+ in runGoldenExe opts exeArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with minimal + no comments"
+ (goldenExe "exe-minimal-no-comments.golden")
+ $ let opts = WriteOpts False True True v pkgDir Executable pkgName defaultCabalVersion
+ in runGoldenExe opts exeArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with minimal + comments"
+ (goldenExe "exe-simple-minimal-with-comments.golden")
+ $ let opts = WriteOpts False True False v pkgDir Executable pkgName defaultCabalVersion
+ in runGoldenExe opts exeArgs emptyFlags
+ , goldenVsString
+ "Build tools flag, not simple, with comments + no minimal"
+ (goldenExe "exe-build-tools-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Executable pkgName defaultCabalVersion
+ in runGoldenExe opts exeArgs (emptyFlags{buildTools = Flag ["happy"]})
]
where
runGoldenExe opts args flags =
case _runPrompt (genExeTarget flags pkgIx) args of
- Right (t, _) -> mkStanza [mkExeStanza opts $ t {_exeDependencies = mangleBaseDep t _exeDependencies}]
+ Right (t, _) -> mkStanza [mkExeStanza opts $ t{_exeDependencies = mangleBaseDep t _exeDependencies}]
Left e -> assertFailure $ show e
goldenLibTests
- :: Verbosity
- -> InstalledPackageIndex
- -> FilePath
- -> PackageName
- -> TestTree
-goldenLibTests v pkgIx pkgDir pkgName = testGroup "lib golden tests"
- [ goldenVsString "Empty flags, not simple, no options, no comments"
- (goldenLib "lib-no-comments.golden") $
- let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion
- in runGoldenLib opts libArgs emptyFlags
-
- , goldenVsString "Empty flags, simple, no options, no comments"
- (goldenLib "lib-simple-no-comments.golden") $
- let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion
- in runGoldenLib opts libArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with comments + no minimal"
- (goldenLib "lib-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runGoldenLib opts libArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with minimal + no comments"
- (goldenLib "lib-minimal-no-comments.golden") $
- let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion
- in runGoldenLib opts libArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with minimal + comments"
- (goldenLib "lib-simple-minimal-with-comments.golden") $
- let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion
- in runGoldenLib opts libArgs emptyFlags
-
- , goldenVsString "Build tools flag, not simple, with comments + no minimal"
- (goldenLib "lib-build-tools-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runGoldenLib opts libArgs (emptyFlags {buildTools = Flag ["happy"]})
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> FilePath
+ -> PackageName
+ -> TestTree
+goldenLibTests v pkgIx pkgDir pkgName =
+ testGroup
+ "lib golden tests"
+ [ goldenVsString
+ "Empty flags, not simple, no options, no comments"
+ (goldenLib "lib-no-comments.golden")
+ $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenLib opts libArgs emptyFlags
+ , goldenVsString
+ "Empty flags, simple, no options, no comments"
+ (goldenLib "lib-simple-no-comments.golden")
+ $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenLib opts libArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with comments + no minimal"
+ (goldenLib "lib-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenLib opts libArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with minimal + no comments"
+ (goldenLib "lib-minimal-no-comments.golden")
+ $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenLib opts libArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with minimal + comments"
+ (goldenLib "lib-simple-minimal-with-comments.golden")
+ $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenLib opts libArgs emptyFlags
+ , goldenVsString
+ "Build tools flag, not simple, with comments + no minimal"
+ (goldenLib "lib-build-tools-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenLib opts libArgs (emptyFlags{buildTools = Flag ["happy"]})
]
where
runGoldenLib opts args flags =
case _runPrompt (genLibTarget flags pkgIx) args of
- Right (t, _) -> mkStanza [mkLibStanza opts $ t {_libDependencies = mangleBaseDep t _libDependencies}]
+ Right (t, _) -> mkStanza [mkLibStanza opts $ t{_libDependencies = mangleBaseDep t _libDependencies}]
Left e -> assertFailure $ show e
goldenTestTests
- :: Verbosity
- -> InstalledPackageIndex
- -> FilePath
- -> PackageName
- -> TestTree
-goldenTestTests v pkgIx pkgDir pkgName = testGroup "test golden tests"
- [ goldenVsString "Empty flags, not simple, no options, no comments"
- (goldenTest "test-no-comments.golden") $
- let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion
- in runGoldenTest opts testArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with comments + no minimal"
- (goldenTest "test-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runGoldenTest opts testArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with minimal + no comments"
- (goldenTest "test-minimal-no-comments.golden") $
- let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion
- in runGoldenTest opts testArgs emptyFlags
-
- , goldenVsString "Empty flags, not simple, with minimal + comments"
- (goldenTest "test-simple-minimal-with-comments.golden") $
- let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion
- in runGoldenTest opts testArgs emptyFlags
-
- , goldenVsString "Build tools flag, not simple, with comments + no minimal"
- (goldenTest "test-build-tools-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
- in runGoldenTest opts testArgs (emptyFlags {buildTools = Flag ["happy"]})
-
- , goldenVsString "Standalone tests, empty flags, not simple, no options, no comments"
- (goldenTest "standalone-test-no-comments.golden") $
- let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion
- in runGoldenTest opts testArgs emptyFlags
-
- , goldenVsString "Standalone tests, empty flags, not simple, with comments + no minimal"
- (goldenTest "standalone-test-with-comments.golden") $
- let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion
- in runGoldenTest opts testArgs emptyFlags
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> FilePath
+ -> PackageName
+ -> TestTree
+goldenTestTests v pkgIx pkgDir pkgName =
+ testGroup
+ "test golden tests"
+ [ goldenVsString
+ "Empty flags, not simple, no options, no comments"
+ (goldenTest "test-no-comments.golden")
+ $ let opts = WriteOpts False False True v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with comments + no minimal"
+ (goldenTest "test-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with minimal + no comments"
+ (goldenTest "test-minimal-no-comments.golden")
+ $ let opts = WriteOpts False True True v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs emptyFlags
+ , goldenVsString
+ "Empty flags, not simple, with minimal + comments"
+ (goldenTest "test-simple-minimal-with-comments.golden")
+ $ let opts = WriteOpts False True False v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs emptyFlags
+ , goldenVsString
+ "Build tools flag, not simple, with comments + no minimal"
+ (goldenTest "test-build-tools-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir Library pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs (emptyFlags{buildTools = Flag ["happy"]})
+ , goldenVsString
+ "Standalone tests, empty flags, not simple, no options, no comments"
+ (goldenTest "standalone-test-no-comments.golden")
+ $ let opts = WriteOpts False False True v pkgDir TestSuite pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs emptyFlags
+ , goldenVsString
+ "Standalone tests, empty flags, not simple, with comments + no minimal"
+ (goldenTest "standalone-test-with-comments.golden")
+ $ let opts = WriteOpts False False False v pkgDir TestSuite pkgName defaultCabalVersion
+ in runGoldenTest opts testArgs emptyFlags
]
where
runGoldenTest opts args flags =
case _runPrompt (genTestTarget flags pkgIx) args of
Left e -> assertFailure $ show e
- Right (Nothing, _) -> assertFailure
- "goldenTestTests: Tests not enabled."
- Right (Just t, _) -> mkStanza [mkTestStanza opts $ t {_testDependencies = mangleBaseDep t _testDependencies}]
+ Right (Nothing, _) ->
+ assertFailure
+ "goldenTestTests: Tests not enabled."
+ Right (Just t, _) -> mkStanza [mkTestStanza opts $ t{_testDependencies = mangleBaseDep t _testDependencies}]
-- | Full cabal file golden tests
goldenCabalTests
- :: Verbosity
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> TestTree
-goldenCabalTests v pkgIx srcDb = testGroup ".cabal file golden tests"
- [ goldenVsString "Library and executable, empty flags, not simple, with comments + no minimal"
- (goldenCabal "cabal-lib-and-exe-with-comments.golden") $
- runGoldenTest (fullProjArgs "Y") emptyFlags
-
- , goldenVsString "Library and executable, empty flags, not simple, no comments + no minimal"
- (goldenCabal "cabal-lib-and-exe-no-comments.golden") $
- runGoldenTest (fullProjArgs "N") emptyFlags
-
- , goldenVsString "Library, empty flags, not simple, with comments + no minimal"
- (goldenCabal "cabal-lib-with-comments.golden") $
- runGoldenTest (libProjArgs "Y") emptyFlags
-
- , goldenVsString "Library, empty flags, not simple, no comments + no minimal"
- (goldenCabal "cabal-lib-no-comments.golden") $
- runGoldenTest (libProjArgs "N") emptyFlags
-
- , goldenVsString "Test suite, empty flags, not simple, with comments + no minimal"
- (goldenCabal "cabal-test-suite-with-comments.golden") $
- runGoldenTest (testProjArgs "Y") emptyFlags
-
- , goldenVsString "Test suite, empty flags, not simple, no comments + no minimal"
- (goldenCabal "cabal-test-suite-no-comments.golden") $
- runGoldenTest (testProjArgs "N") emptyFlags
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> TestTree
+goldenCabalTests v pkgIx srcDb =
+ testGroup
+ ".cabal file golden tests"
+ [ goldenVsString
+ "Library and executable, empty flags, not simple, with comments + no minimal"
+ (goldenCabal "cabal-lib-and-exe-with-comments.golden")
+ $ runGoldenTest (fullProjArgs "Y") emptyFlags
+ , goldenVsString
+ "Library and executable, empty flags, not simple, no comments + no minimal"
+ (goldenCabal "cabal-lib-and-exe-no-comments.golden")
+ $ runGoldenTest (fullProjArgs "N") emptyFlags
+ , goldenVsString
+ "Library, empty flags, not simple, with comments + no minimal"
+ (goldenCabal "cabal-lib-with-comments.golden")
+ $ runGoldenTest (libProjArgs "Y") emptyFlags
+ , goldenVsString
+ "Library, empty flags, not simple, no comments + no minimal"
+ (goldenCabal "cabal-lib-no-comments.golden")
+ $ runGoldenTest (libProjArgs "N") emptyFlags
+ , goldenVsString
+ "Test suite, empty flags, not simple, with comments + no minimal"
+ (goldenCabal "cabal-test-suite-with-comments.golden")
+ $ runGoldenTest (testProjArgs "Y") emptyFlags
+ , goldenVsString
+ "Test suite, empty flags, not simple, no comments + no minimal"
+ (goldenCabal "cabal-test-suite-no-comments.golden")
+ $ runGoldenTest (testProjArgs "N") emptyFlags
]
where
runGoldenTest args flags =
case _runPrompt (createProject v pkgIx srcDb flags) args of
Left e -> assertFailure $ show e
-
(Right (ProjectSettings opts pkgDesc (Just libTarget) (Just exeTarget) (Just testTarget), _)) -> do
let pkgFields = mkPkgDescription opts pkgDesc
commonStanza = mkCommonStanza opts
- libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies}
- exeStanza = mkExeStanza opts $ exeTarget {_exeDependencies = mangleBaseDep exeTarget _exeDependencies}
- testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies}
+ libStanza = mkLibStanza opts $ libTarget{_libDependencies = mangleBaseDep libTarget _libDependencies}
+ exeStanza = mkExeStanza opts $ exeTarget{_exeDependencies = mangleBaseDep exeTarget _exeDependencies}
+ testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies}
mkStanza $ pkgFields ++ [commonStanza, libStanza, exeStanza, testStanza]
-
(Right (ProjectSettings opts pkgDesc (Just libTarget) Nothing (Just testTarget), _)) -> do
let pkgFields = mkPkgDescription opts pkgDesc
commonStanza = mkCommonStanza opts
- libStanza = mkLibStanza opts $ libTarget {_libDependencies = mangleBaseDep libTarget _libDependencies}
- testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies}
+ libStanza = mkLibStanza opts $ libTarget{_libDependencies = mangleBaseDep libTarget _libDependencies}
+ testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies}
mkStanza $ pkgFields ++ [commonStanza, libStanza, testStanza]
-
(Right (ProjectSettings opts pkgDesc Nothing Nothing (Just testTarget), _)) -> do
let pkgFields = mkPkgDescription opts pkgDesc
commonStanza = mkCommonStanza opts
- testStanza = mkTestStanza opts $ testTarget {_testDependencies = mangleBaseDep testTarget _testDependencies}
+ testStanza = mkTestStanza opts $ testTarget{_testDependencies = mangleBaseDep testTarget _testDependencies}
mkStanza $ pkgFields ++ [commonStanza, testStanza]
-
- (Right (ProjectSettings _ _ l e t, _)) -> assertFailure $
- show l ++ "\n" ++ show e ++ "\n" ++ show t
-
+ (Right (ProjectSettings _ _ l e t, _)) ->
+ assertFailure $
+ show l ++ "\n" ++ show e ++ "\n" ++ show t
-- -------------------------------------------------------------------- --
-- utils
mkStanza :: [PrettyField FieldAnnotation] -> IO BS8.ByteString
-mkStanza fields = return . BS8.pack $ showFields'
- annCommentLines postProcessFieldLines
- 4 fields
+mkStanza fields =
+ return . BS8.pack $
+ showFields'
+ annCommentLines
+ postProcessFieldLines
+ 4
+ fields
golden :: FilePath
golden = "tests" </> "fixtures" </> "init" </> "golden"
@@ -334,7 +353,8 @@ testArgs :: NonEmpty String
testArgs = fromList ["y", "1", "test", "1"]
pkgArgs :: NonEmpty String
-pkgArgs = fromList
+pkgArgs =
+ fromList
[ "5"
, "foo-package"
, "foo-package"
@@ -351,22 +371,25 @@ pkgArgs = fromList
]
testProjArgs :: String -> NonEmpty String
-testProjArgs comments = fromList ["4", "n", "foo-package"]
- <> pkgArgs
- <> fromList (NEL.drop 1 testArgs)
- <> fromList [comments]
+testProjArgs comments =
+ fromList ["4", "n", "foo-package"]
+ <> pkgArgs
+ <> fromList (NEL.drop 1 testArgs)
+ <> fromList [comments]
libProjArgs :: String -> NonEmpty String
-libProjArgs comments = fromList ["1", "n", "foo-package"]
- <> pkgArgs
- <> libArgs
- <> testArgs
- <> fromList [comments]
+libProjArgs comments =
+ fromList ["1", "n", "foo-package"]
+ <> pkgArgs
+ <> libArgs
+ <> testArgs
+ <> fromList [comments]
fullProjArgs :: String -> NonEmpty String
-fullProjArgs comments = fromList ["3", "n", "foo-package"]
- <> pkgArgs
- <> libArgs
- <> exeArgs
- <> testArgs
- <> fromList [comments]
+fullProjArgs comments =
+ fromList ["3", "n", "foo-package"]
+ <> pkgArgs
+ <> libArgs
+ <> exeArgs
+ <> testArgs
+ <> fromList [comments]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs
index 4a2d000cb4799c9482a8658e85650954630a46d4..24f68255cdee490da4e43e42f0d36c3eecb612c2 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Interactive.hs
@@ -1,11 +1,10 @@
module UnitTests.Distribution.Client.Init.Interactive
-( tests
-) where
+ ( tests
+ ) where
-
-import Prelude as P
import Test.Tasty
import Test.Tasty.HUnit
+import Prelude as P
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.Interactive.Command
@@ -22,1003 +21,1104 @@ import Distribution.Verbosity
import Language.Haskell.Extension
-import UnitTests.Distribution.Client.Init.Utils
-import Distribution.Client.Init.FlagExtractors
-import Distribution.Simple.Setup
-import Distribution.CabalSpecVersion
import qualified Data.Set as Set
+import Distribution.CabalSpecVersion
+import Distribution.Client.Init.FlagExtractors
import Distribution.FieldGrammar.Newtypes
-
+import Distribution.Simple.Setup
+import UnitTests.Distribution.Client.Init.Utils
-- -------------------------------------------------------------------- --
-- Init Test main
tests
- :: Verbosity
- -> InitFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> TestTree
+ :: Verbosity
+ -> InitFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> TestTree
tests _v initFlags pkgIx srcDb =
- testGroup "Distribution.Client.Init.Interactive.Command.hs"
+ testGroup
+ "Distribution.Client.Init.Interactive.Command.hs"
[ createProjectTest pkgIx srcDb
, fileCreatorTests pkgIx srcDb pkgName
, interactiveTests srcDb
]
where
- pkgName = evalPrompt (packageNamePrompt srcDb initFlags) $
+ pkgName =
+ evalPrompt (packageNamePrompt srcDb initFlags) $
fromList ["test-package", "y"]
- -- pkgNm = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"]
+-- pkgNm = evalPrompt (getPackageName srcDb initFlags) $ fromList ["test-package", "y"]
createProjectTest
:: InstalledPackageIndex
-> SourcePackageDb
-> TestTree
-createProjectTest pkgIx srcDb = testGroup "createProject tests"
- [ testGroup "with flags"
- [ testCase "Check the interactive workflow" $ do
- let dummyFlags' = dummyFlags
- { packageType = Flag LibraryAndExecutable
- , minimal = Flag False
- , overwrite = Flag False
- , packageDir = Flag "/home/test/test-package"
- , extraSrc = NoFlag
- , exposedModules = Flag []
- , otherModules = Flag []
- , otherExts = Flag []
- , buildTools = Flag []
- , mainIs = Flag "quxApp/Main.hs"
- , dependencies = Flag []
- }
-
- case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["n", "3", "quxTest/Main.hs"]) of
- Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= True
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "QuxPackage"
-
- _pkgCabalVersion desc @?= CabalSpecV2_2
- _pkgName desc @?= mkPackageName "QuxPackage"
- _pkgVersion desc @?= mkVersion [4,2,6]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "We are Qux, and this is our package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["quxSrc"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule :| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?= []
- _libBuildTools lib @?= []
-
- _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard
- _exeApplicationDirs exe @?= ["quxApp"]
- _exeLanguage exe @?= Haskell98
- _exeOtherModules exe @?= []
- _exeOtherExts exe @?= []
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= []
-
- _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard
- _testDirs test @?= ["quxTest"]
- _testLanguage test @?= Haskell98
- _testOtherModules test @?= []
- _testOtherExts test @?= []
- _testDependencies test @?! []
- _testBuildTools test @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
- ]
-
- , testGroup "with tests"
- [ testCase "Check the interactive library and executable workflow" $ do
- let inputs = fromList
- -- package type
- [ "3"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- library target
- -- source dir
- , "1"
- -- language
- , "2"
- -- executable target
- -- main file
- , "1"
- -- application dir
- , "2"
- -- language
- , "2"
- -- test target
- , "y"
- -- main file
- , "1"
- -- test dir
- , "test"
- -- language
- , "1"
- -- comments
- , "y"
- ]
-
- case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV2_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule :| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?! []
- _libBuildTools lib @?= []
-
- _exeMainIs exe @?= HsFilePath "Main.hs" Standard
- _exeApplicationDirs exe @?= ["exe"]
- _exeLanguage exe @?= Haskell98
- _exeOtherModules exe @?= []
- _exeOtherExts exe @?= []
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= []
-
- _testMainIs test @?= HsFilePath "Main.hs" Standard
- _testDirs test @?= ["test"]
- _testLanguage test @?= Haskell2010
- _testOtherModules test @?= []
- _testOtherExts test @?= []
- _testDependencies test @?! []
- _testBuildTools test @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the interactive library workflow" $ do
- let inputs = fromList
- -- package type
- [ "1"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- library target
- -- source dir
- , "1"
- -- language
- , "2"
- -- test target
- , "y"
- -- main file
- , "1"
- -- test dir
- , "test"
- -- language
- , "1"
- -- comments
- , "y"
- ]
-
- case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Library
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV2_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule :| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?! []
- _libBuildTools lib @?= []
-
- _testMainIs test @?= HsFilePath "Main.hs" Standard
- _testDirs test @?= ["test"]
- _testLanguage test @?= Haskell2010
- _testOtherModules test @?= []
- _testOtherExts test @?= []
- _testDependencies test @?! []
- _testBuildTools test @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?= Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the interactive library workflow" $ do
- let inputs = fromList
- -- package type
- [ "4"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- test target
- -- main file
- , "1"
- -- test dir
- , "test"
- -- language
- , "1"
- -- comments
- , "y"
- ]
-
- case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= TestSuite
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV2_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _testMainIs test @?= HsFilePath "Main.hs" Standard
- _testDirs test @?= ["test"]
- _testLanguage test @?= Haskell2010
- _testOtherModules test @?= []
- _testOtherExts test @?= []
- _testDependencies test @?! []
- _testBuildTools test @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?= Nothing
- exe @?= Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
- ]
- , testGroup "without tests"
- [ testCase "Check the interactive library and executable workflow" $ do
- let inputs = fromList
- -- package type
- [ "3"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- library target
- -- source dir
- , "1"
- -- language
- , "2"
- -- executable target
- -- main file
- , "1"
- -- application dir
- , "2"
- -- language
- , "2"
- -- test suite
- , "n"
- -- comments
- , "y"
- ]
-
- case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV2_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule :| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?! []
- _libBuildTools lib @?= []
-
- _exeMainIs exe @?= HsFilePath "Main.hs" Standard
- _exeApplicationDirs exe @?= ["exe"]
- _exeLanguage exe @?= Haskell98
- _exeOtherModules exe @?= []
- _exeOtherExts exe @?= []
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the interactive library workflow" $ do
- let inputs = fromList
- -- package type
- [ "1"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- library target
- -- source dir
- , "1"
- -- language
- , "2"
- -- test suite
- , "n"
- -- comments
- , "y"
- ]
-
- case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Library
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV2_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule :| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?! []
- _libBuildTools lib @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?= Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the interactive library workflow - cabal < 1.18" $ do
- let inputs = fromList
- -- package type
- [ "1"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- library target
- -- source dir
- , "1"
- -- language
- , "2"
- -- test suite
- , "n"
- -- comments
- , "y"
- ]
-
- flags = emptyFlags
- { cabalVersion = Flag CabalSpecV1_10
- , extraDoc = Flag [defaultChangelog]
- , extraSrc = Flag ["README.md"]
- }
-
- case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of
- Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Library
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV1_10
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"]
- _pkgExtraDocFiles desc @?= Nothing
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule :| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?! []
- _libBuildTools lib @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?= Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the interactive executable workflow" $ do
- let inputs = fromList
- -- package type
- [ "2"
- -- overwrite
- , "n"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "4"
- -- package name
- , "test-package"
- , "test-package"
- , "test-package"
- -- version
- , "3.1.2.3"
- -- license
- , "3"
- -- author
- , "git username"
- , "Foobar"
- -- email
- , "git email"
- , "foobar@qux.com"
- -- homepage
- , "qux.com"
- -- synopsis
- , "Qux's package"
- -- category
- , "3"
- -- executable target
- -- main file
- , "1"
- -- application dir
- , "2"
- -- language
- , "2"
- -- comments
- , "y"
- ]
-
- case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Executable
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV2_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [3,1,2,3]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "Qux's package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _exeMainIs exe @?= HsFilePath "Main.hs" Standard
- _exeApplicationDirs exe @?= ["exe"]
- _exeLanguage exe @?= Haskell98
- _exeOtherModules exe @?= []
- _exeOtherExts exe @?= []
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= []
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?= Nothing
- exe @?! Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
+createProjectTest pkgIx srcDb =
+ testGroup
+ "createProject tests"
+ [ testGroup
+ "with flags"
+ [ testCase "Check the interactive workflow" $ do
+ let dummyFlags' =
+ dummyFlags
+ { packageType = Flag LibraryAndExecutable
+ , minimal = Flag False
+ , overwrite = Flag False
+ , packageDir = Flag "/home/test/test-package"
+ , extraSrc = NoFlag
+ , exposedModules = Flag []
+ , otherModules = Flag []
+ , otherExts = Flag []
+ , buildTools = Flag []
+ , mainIs = Flag "quxApp/Main.hs"
+ , dependencies = Flag []
+ }
+
+ case (_runPrompt $ createProject silent pkgIx srcDb dummyFlags') (fromList ["n", "3", "quxTest/Main.hs"]) of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= True
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "QuxPackage"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_2
+ _pkgName desc @?= mkPackageName "QuxPackage"
+ _pkgVersion desc @?= mkVersion [4, 2, 6]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "We are Qux, and this is our package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["quxSrc"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule :| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?= []
+ _libBuildTools lib @?= []
+
+ _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard
+ _exeApplicationDirs exe @?= ["quxApp"]
+ _exeLanguage exe @?= Haskell98
+ _exeOtherModules exe @?= []
+ _exeOtherExts exe @?= []
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= []
+
+ _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard
+ _testDirs test @?= ["quxTest"]
+ _testLanguage test @?= Haskell98
+ _testOtherModules test @?= []
+ _testOtherExts test @?= []
+ _testDependencies test @?! []
+ _testBuildTools test @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ ]
+ , testGroup
+ "with tests"
+ [ testCase "Check the interactive library and executable workflow" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "3"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- library target
+ -- source dir
+ "1"
+ , -- language
+ "2"
+ , -- executable target
+ -- main file
+ "1"
+ , -- application dir
+ "2"
+ , -- language
+ "2"
+ , -- test target
+ "y"
+ , -- main file
+ "1"
+ , -- test dir
+ "test"
+ , -- language
+ "1"
+ , -- comments
+ "y"
+ ]
+
+ case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule :| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= []
+
+ _exeMainIs exe @?= HsFilePath "Main.hs" Standard
+ _exeApplicationDirs exe @?= ["exe"]
+ _exeLanguage exe @?= Haskell98
+ _exeOtherModules exe @?= []
+ _exeOtherExts exe @?= []
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= []
+
+ _testMainIs test @?= HsFilePath "Main.hs" Standard
+ _testDirs test @?= ["test"]
+ _testLanguage test @?= Haskell2010
+ _testOtherModules test @?= []
+ _testOtherExts test @?= []
+ _testDependencies test @?! []
+ _testBuildTools test @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the interactive library workflow" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "1"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- library target
+ -- source dir
+ "1"
+ , -- language
+ "2"
+ , -- test target
+ "y"
+ , -- main file
+ "1"
+ , -- test dir
+ "test"
+ , -- language
+ "1"
+ , -- comments
+ "y"
+ ]
+
+ case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Library
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule :| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= []
+
+ _testMainIs test @?= HsFilePath "Main.hs" Standard
+ _testDirs test @?= ["test"]
+ _testLanguage test @?= Haskell2010
+ _testOtherModules test @?= []
+ _testOtherExts test @?= []
+ _testDependencies test @?! []
+ _testBuildTools test @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?= Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the interactive library workflow" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "4"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- test target
+ -- main file
+ "1"
+ , -- test dir
+ "test"
+ , -- language
+ "1"
+ , -- comments
+ "y"
+ ]
+
+ case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc Nothing Nothing (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= TestSuite
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _testMainIs test @?= HsFilePath "Main.hs" Standard
+ _testDirs test @?= ["test"]
+ _testLanguage test @?= Haskell2010
+ _testOtherModules test @?= []
+ _testOtherExts test @?= []
+ _testDependencies test @?! []
+ _testBuildTools test @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?= Nothing
+ exe @?= Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ ]
+ , testGroup
+ "without tests"
+ [ testCase "Check the interactive library and executable workflow" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "3"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- library target
+ -- source dir
+ "1"
+ , -- language
+ "2"
+ , -- executable target
+ -- main file
+ "1"
+ , -- application dir
+ "2"
+ , -- language
+ "2"
+ , -- test suite
+ "n"
+ , -- comments
+ "y"
+ ]
+
+ case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule :| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= []
+
+ _exeMainIs exe @?= HsFilePath "Main.hs" Standard
+ _exeApplicationDirs exe @?= ["exe"]
+ _exeLanguage exe @?= Haskell98
+ _exeOtherModules exe @?= []
+ _exeOtherExts exe @?= []
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the interactive library workflow" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "1"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- library target
+ -- source dir
+ "1"
+ , -- language
+ "2"
+ , -- test suite
+ "n"
+ , -- comments
+ "y"
+ ]
+
+ case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Library
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule :| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?= Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the interactive library workflow - cabal < 1.18" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "1"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- library target
+ -- source dir
+ "1"
+ , -- language
+ "2"
+ , -- test suite
+ "n"
+ , -- comments
+ "y"
+ ]
+
+ flags =
+ emptyFlags
+ { cabalVersion = Flag CabalSpecV1_10
+ , extraDoc = Flag [defaultChangelog]
+ , extraSrc = Flag ["README.md"]
+ }
+
+ case (_runPrompt $ createProject silent pkgIx srcDb flags) inputs of
+ Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Library
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV1_10
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= Set.fromList [defaultChangelog, "README.md"]
+ _pkgExtraDocFiles desc @?= Nothing
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule :| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?= Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the interactive executable workflow" $ do
+ let inputs =
+ fromList
+ -- package type
+ [ "2"
+ , -- overwrite
+ "n"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "4"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , "test-package"
+ , -- version
+ "3.1.2.3"
+ , -- license
+ "3"
+ , -- author
+ "git username"
+ , "Foobar"
+ , -- email
+ "git email"
+ , "foobar@qux.com"
+ , -- homepage
+ "qux.com"
+ , -- synopsis
+ "Qux's package"
+ , -- category
+ "3"
+ , -- executable target
+ -- main file
+ "1"
+ , -- application dir
+ "2"
+ , -- language
+ "2"
+ , -- comments
+ "y"
+ ]
+
+ case (_runPrompt $ createProject silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Executable
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [3, 1, 2, 3]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "Qux's package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _exeMainIs exe @?= HsFilePath "Main.hs" Standard
+ _exeApplicationDirs exe @?= ["exe"]
+ _exeLanguage exe @?= Haskell98
+ _exeOtherModules exe @?= []
+ _exeOtherExts exe @?= []
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= []
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?= Nothing
+ exe @?! Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ ]
]
- ]
fileCreatorTests :: InstalledPackageIndex -> SourcePackageDb -> PackageName -> TestTree
-fileCreatorTests pkgIx srcDb _pkgName = testGroup "generators"
- [ testGroup "genPkgDescription"
- [ testCase "Check common package flags workflow" $ do
- let inputs = fromList
- [ "1" -- pick the first cabal version in the list
- , "my-test-package" -- package name
- , "my-test-package" -- current dir for the purpose of guessing the package name
- , "y" -- "yes to prompt internal to package name"
- , "0.2.0.1" -- package version
- , "2" -- pick the second license in the list
- , "git username" -- name guessed by calling "git config user.name"
- , "Foobar" -- author name
- , "git email" -- email guessed by calling "git config user.email"
- , "foobar@qux.com" -- maintainer email
- , "qux.com" -- package homepage
- , "Qux's package" -- package synopsis
- , "3" -- pick the third category in the list
- ]
- runGenTest inputs $ genPkgDescription emptyFlags srcDb
- ]
- , testGroup "genLibTarget"
- [ testCase "Check library package flags workflow" $ do
- let inputs = fromList
- [ "1" -- pick the first source directory in the list
- , "2" -- pick the second language in the list
- ]
-
- runGenTest inputs $ genLibTarget emptyFlags pkgIx
- ]
- , testGroup "genExeTarget"
- [ testCase "Check executable package flags workflow" $ do
- let inputs = fromList
- [ "1" -- pick the first main file option in the list
- , "2" -- pick the second application directory in the list
- , "1" -- pick the first language in the list
- ]
-
- runGenTest inputs $ genExeTarget emptyFlags pkgIx
- ]
- , testGroup "genTestTarget"
- [ testCase "Check test package flags workflow" $ do
- let inputs = fromList
- [ "y" -- say yes to tests
- , "1" -- pick the first main file option in the list
- , "test" -- package test dir
- , "1" -- pick the first language in the list
- ]
-
- runGenTest inputs $ genTestTarget emptyFlags pkgIx
+fileCreatorTests pkgIx srcDb _pkgName =
+ testGroup
+ "generators"
+ [ testGroup
+ "genPkgDescription"
+ [ testCase "Check common package flags workflow" $ do
+ let inputs =
+ fromList
+ [ "1" -- pick the first cabal version in the list
+ , "my-test-package" -- package name
+ , "my-test-package" -- current dir for the purpose of guessing the package name
+ , "y" -- "yes to prompt internal to package name"
+ , "0.2.0.1" -- package version
+ , "2" -- pick the second license in the list
+ , "git username" -- name guessed by calling "git config user.name"
+ , "Foobar" -- author name
+ , "git email" -- email guessed by calling "git config user.email"
+ , "foobar@qux.com" -- maintainer email
+ , "qux.com" -- package homepage
+ , "Qux's package" -- package synopsis
+ , "3" -- pick the third category in the list
+ ]
+ runGenTest inputs $ genPkgDescription emptyFlags srcDb
+ ]
+ , testGroup
+ "genLibTarget"
+ [ testCase "Check library package flags workflow" $ do
+ let inputs =
+ fromList
+ [ "1" -- pick the first source directory in the list
+ , "2" -- pick the second language in the list
+ ]
+
+ runGenTest inputs $ genLibTarget emptyFlags pkgIx
+ ]
+ , testGroup
+ "genExeTarget"
+ [ testCase "Check executable package flags workflow" $ do
+ let inputs =
+ fromList
+ [ "1" -- pick the first main file option in the list
+ , "2" -- pick the second application directory in the list
+ , "1" -- pick the first language in the list
+ ]
+
+ runGenTest inputs $ genExeTarget emptyFlags pkgIx
+ ]
+ , testGroup
+ "genTestTarget"
+ [ testCase "Check test package flags workflow" $ do
+ let inputs =
+ fromList
+ [ "y" -- say yes to tests
+ , "1" -- pick the first main file option in the list
+ , "test" -- package test dir
+ , "1" -- pick the first language in the list
+ ]
+
+ runGenTest inputs $ genTestTarget emptyFlags pkgIx
+ ]
]
- ]
where
runGenTest inputs go = case _runPrompt go inputs of
Left e -> assertFailure $ show e
Right{} -> return ()
interactiveTests :: SourcePackageDb -> TestTree
-interactiveTests srcDb = testGroup "Check top level getter functions"
- [ testGroup "Simple prompt tests"
- [ testGroup "Check packageNamePrompt output"
- [ testSimplePrompt "New package name 1"
- (packageNamePrompt srcDb) (mkPackageName "test-package")
- [ "test-package"
- , "test-package"
- , "test-package"
- ]
- , testSimplePrompt "New package name 2"
- (packageNamePrompt srcDb) (mkPackageName "test-package")
- [ "test-package"
- , "test-package"
- , ""
- ]
- , testSimplePrompt "Existing package name 1"
- (packageNamePrompt srcDb) (mkPackageName "test-package")
- [ "test-package"
- , "test-package"
- , "cabal-install"
- , "y"
- , "test-package"
- ]
- , testSimplePrompt "Existing package name 2"
- (packageNamePrompt srcDb) (mkPackageName "cabal-install")
- [ "test-package"
- , "test-package"
- , "cabal-install"
- , "n"
- ]
- ]
- , testGroup "Check mainFilePrompt output"
- [ testSimplePrompt "New valid main file"
- mainFilePrompt defaultMainIs
- [ "1"
- ]
- , testSimplePrompt "New valid other main file"
- mainFilePrompt (HsFilePath "Main.hs" Standard)
- [ "3"
- , "Main.hs"
- ]
- , testSimplePrompt "Invalid other main file"
- mainFilePrompt (HsFilePath "Main.lhs" Literate)
- [ "3"
- , "Yoink.jl"
- , "2"
- ]
- ]
- , testGroup "Check versionPrompt output"
- [ testSimplePrompt "Proper PVP"
- versionPrompt (mkVersion [0,3,1,0])
- [ "0.3.1.0"
- ]
- , testSimplePrompt "No PVP"
- versionPrompt (mkVersion [0,3,1,0])
- [ "yee-haw"
- , "0.3.1.0"
- ]
- ]
- , testGroup "Check synopsisPrompt output"
- [ testSimplePrompt "1" synopsisPrompt
- "We are Qux, and this is our package" ["We are Qux, and this is our package"]
- , testSimplePrompt "2" synopsisPrompt
- "Resistance is futile, you will be assimilated" ["Resistance is futile, you will be assimilated"]
- ]
- , testSimplePrompt "Check authorPrompt output (name supplied by the user)" authorPrompt
- "Foobar" ["git username", "Foobar"]
- , testSimplePrompt "Check authorPrompt output (name guessed from git config)" authorPrompt
- "git username" ["git username", ""]
- , testSimplePrompt "Check emailPrompt output (email supplied by the user)" emailPrompt
- "foobar@qux.com" ["git email", "foobar@qux.com"]
- , testSimplePrompt "Check emailPrompt output (email guessed from git config)" emailPrompt
- "git@email" ["git@email", ""]
- , testSimplePrompt "Check homepagePrompt output" homepagePrompt
- "qux.com" ["qux.com"]
- , testSimplePrompt "Check testDirsPrompt output" testDirsPrompt
- ["quxTest"] ["quxTest"]
- -- this tests 4) other, and can be used to model more inputs in case of failure
- , testSimplePrompt "Check srcDirsPrompt output" srcDirsPrompt
- ["app"] ["4", "app"]
- ]
- , testGroup "Numbered prompt tests"
- [ testGroup "Check categoryPrompt output"
- [ testNumberedPrompt "Category indices" categoryPrompt
- defaultCategories
- , testSimplePrompt "Other category"
- categoryPrompt "Unlisted"
- [ show $ P.length defaultCategories + 1
- , "Unlisted"
- ]
- , testSimplePrompt "No category"
- categoryPrompt ""
- [ ""
- ]
- ]
- , testGroup "Check licensePrompt output" $ let other = show (1 + P.length defaultLicenseIds) in
- [ testNumberedPrompt "License indices" licensePrompt $
- fmap (\l -> SpecLicense . Left . SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds
- , testSimplePrompt "Other license 1"
- licensePrompt (SpecLicense . Left $ mkLicense SPDX.CC_BY_NC_ND_4_0)
- [ other
- , "CC-BY-NC-ND-4.0"
- ]
- , testSimplePrompt "Other license 2"
- licensePrompt (SpecLicense . Left $ mkLicense SPDX.D_FSL_1_0)
- [ other
- , "D-FSL-1.0"
+interactiveTests srcDb =
+ testGroup
+ "Check top level getter functions"
+ [ testGroup
+ "Simple prompt tests"
+ [ testGroup
+ "Check packageNamePrompt output"
+ [ testSimplePrompt
+ "New package name 1"
+ (packageNamePrompt srcDb)
+ (mkPackageName "test-package")
+ [ "test-package"
+ , "test-package"
+ , "test-package"
+ ]
+ , testSimplePrompt
+ "New package name 2"
+ (packageNamePrompt srcDb)
+ (mkPackageName "test-package")
+ [ "test-package"
+ , "test-package"
+ , ""
+ ]
+ , testSimplePrompt
+ "Existing package name 1"
+ (packageNamePrompt srcDb)
+ (mkPackageName "test-package")
+ [ "test-package"
+ , "test-package"
+ , "cabal-install"
+ , "y"
+ , "test-package"
+ ]
+ , testSimplePrompt
+ "Existing package name 2"
+ (packageNamePrompt srcDb)
+ (mkPackageName "cabal-install")
+ [ "test-package"
+ , "test-package"
+ , "cabal-install"
+ , "n"
+ ]
]
- , testSimplePrompt "Other license 3"
- licensePrompt (SpecLicense . Left $ mkLicense SPDX.NPOSL_3_0)
- [ other
- , "NPOSL-3.0"
+ , testGroup
+ "Check mainFilePrompt output"
+ [ testSimplePrompt
+ "New valid main file"
+ mainFilePrompt
+ defaultMainIs
+ [ "1"
+ ]
+ , testSimplePrompt
+ "New valid other main file"
+ mainFilePrompt
+ (HsFilePath "Main.hs" Standard)
+ [ "3"
+ , "Main.hs"
+ ]
+ , testSimplePrompt
+ "Invalid other main file"
+ mainFilePrompt
+ (HsFilePath "Main.lhs" Literate)
+ [ "3"
+ , "Yoink.jl"
+ , "2"
+ ]
]
- , testSimplePrompt "Invalid license"
- licensePrompt (SpecLicense $ Left SPDX.NONE)
- [ other
- , "yay"
- , other
- , "NONE"
+ , testGroup
+ "Check versionPrompt output"
+ [ testSimplePrompt
+ "Proper PVP"
+ versionPrompt
+ (mkVersion [0, 3, 1, 0])
+ [ "0.3.1.0"
+ ]
+ , testSimplePrompt
+ "No PVP"
+ versionPrompt
+ (mkVersion [0, 3, 1, 0])
+ [ "yee-haw"
+ , "0.3.1.0"
+ ]
]
- , testPromptBreak "Invalid index"
- licensePrompt
- [ "42"
+ , testGroup
+ "Check synopsisPrompt output"
+ [ testSimplePrompt
+ "1"
+ synopsisPrompt
+ "We are Qux, and this is our package"
+ ["We are Qux, and this is our package"]
+ , testSimplePrompt
+ "2"
+ synopsisPrompt
+ "Resistance is futile, you will be assimilated"
+ ["Resistance is futile, you will be assimilated"]
]
+ , testSimplePrompt
+ "Check authorPrompt output (name supplied by the user)"
+ authorPrompt
+ "Foobar"
+ ["git username", "Foobar"]
+ , testSimplePrompt
+ "Check authorPrompt output (name guessed from git config)"
+ authorPrompt
+ "git username"
+ ["git username", ""]
+ , testSimplePrompt
+ "Check emailPrompt output (email supplied by the user)"
+ emailPrompt
+ "foobar@qux.com"
+ ["git email", "foobar@qux.com"]
+ , testSimplePrompt
+ "Check emailPrompt output (email guessed from git config)"
+ emailPrompt
+ "git@email"
+ ["git@email", ""]
+ , testSimplePrompt
+ "Check homepagePrompt output"
+ homepagePrompt
+ "qux.com"
+ ["qux.com"]
+ , testSimplePrompt
+ "Check testDirsPrompt output"
+ testDirsPrompt
+ ["quxTest"]
+ ["quxTest"]
+ , -- this tests 4) other, and can be used to model more inputs in case of failure
+ testSimplePrompt
+ "Check srcDirsPrompt output"
+ srcDirsPrompt
+ ["app"]
+ ["4", "app"]
]
- , testGroup "Check languagePrompt output"
- [ testNumberedPrompt "Language indices" (`languagePrompt` "test")
- [Haskell2010, Haskell98, GHC2021]
- , testSimplePrompt "Other language"
- (`languagePrompt` "test") (UnknownLanguage "Haskell2022")
- [ "4"
- , "Haskell2022"
+ , testGroup
+ "Numbered prompt tests"
+ [ testGroup
+ "Check categoryPrompt output"
+ [ testNumberedPrompt
+ "Category indices"
+ categoryPrompt
+ defaultCategories
+ , testSimplePrompt
+ "Other category"
+ categoryPrompt
+ "Unlisted"
+ [ show $ P.length defaultCategories + 1
+ , "Unlisted"
+ ]
+ , testSimplePrompt
+ "No category"
+ categoryPrompt
+ ""
+ [ ""
+ ]
]
- , testSimplePrompt "Invalid language"
- (`languagePrompt` "test") (UnknownLanguage "Lang_TS!")
- [ "4"
- , "Lang_TS!"
+ , testGroup "Check licensePrompt output" $
+ let other = show (1 + P.length defaultLicenseIds)
+ in [ testNumberedPrompt "License indices" licensePrompt $
+ fmap (\l -> SpecLicense . Left . SPDX.License $ SPDX.ELicense (SPDX.ELicenseId l) Nothing) defaultLicenseIds
+ , testSimplePrompt
+ "Other license 1"
+ licensePrompt
+ (SpecLicense . Left $ mkLicense SPDX.CC_BY_NC_ND_4_0)
+ [ other
+ , "CC-BY-NC-ND-4.0"
+ ]
+ , testSimplePrompt
+ "Other license 2"
+ licensePrompt
+ (SpecLicense . Left $ mkLicense SPDX.D_FSL_1_0)
+ [ other
+ , "D-FSL-1.0"
+ ]
+ , testSimplePrompt
+ "Other license 3"
+ licensePrompt
+ (SpecLicense . Left $ mkLicense SPDX.NPOSL_3_0)
+ [ other
+ , "NPOSL-3.0"
+ ]
+ , testSimplePrompt
+ "Invalid license"
+ licensePrompt
+ (SpecLicense $ Left SPDX.NONE)
+ [ other
+ , "yay"
+ , other
+ , "NONE"
+ ]
+ , testPromptBreak
+ "Invalid index"
+ licensePrompt
+ [ "42"
+ ]
+ ]
+ , testGroup
+ "Check languagePrompt output"
+ [ testNumberedPrompt
+ "Language indices"
+ (`languagePrompt` "test")
+ [Haskell2010, Haskell98, GHC2021]
+ , testSimplePrompt
+ "Other language"
+ (`languagePrompt` "test")
+ (UnknownLanguage "Haskell2022")
+ [ "4"
+ , "Haskell2022"
+ ]
+ , testSimplePrompt
+ "Invalid language"
+ (`languagePrompt` "test")
+ (UnknownLanguage "Lang_TS!")
+ [ "4"
+ , "Lang_TS!"
+ ]
]
- ]
- , testGroup "Check srcDirsPrompt output"
- [ testNumberedPrompt "Source dirs indices" srcDirsPrompt
- [[defaultSourceDir], ["lib"], ["src-lib"]]
- , testSimplePrompt "Other source dir"
- srcDirsPrompt ["src"]
- [ "4"
- , "src"
+ , testGroup
+ "Check srcDirsPrompt output"
+ [ testNumberedPrompt
+ "Source dirs indices"
+ srcDirsPrompt
+ [[defaultSourceDir], ["lib"], ["src-lib"]]
+ , testSimplePrompt
+ "Other source dir"
+ srcDirsPrompt
+ ["src"]
+ [ "4"
+ , "src"
+ ]
]
- ]
- , testGroup "Check appDirsPrompt output"
- [ testNumberedPrompt "App dirs indices" appDirsPrompt
- [[defaultApplicationDir], ["exe"], ["src-exe"]]
- , testSimplePrompt "Other app dir"
- appDirsPrompt ["app"]
- [ "4"
- , "app"
+ , testGroup
+ "Check appDirsPrompt output"
+ [ testNumberedPrompt
+ "App dirs indices"
+ appDirsPrompt
+ [[defaultApplicationDir], ["exe"], ["src-exe"]]
+ , testSimplePrompt
+ "Other app dir"
+ appDirsPrompt
+ ["app"]
+ [ "4"
+ , "app"
+ ]
]
+ , testNumberedPrompt
+ "Check packageTypePrompt output"
+ packageTypePrompt
+ [Library, Executable, LibraryAndExecutable]
+ , testNumberedPrompt
+ "Check cabalVersionPrompt output"
+ cabalVersionPrompt
+ defaultCabalVersions
+ ]
+ , testGroup
+ "Bool prompt tests"
+ [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y"
+ , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y"
+ , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n"
+ , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N"
]
- , testNumberedPrompt "Check packageTypePrompt output" packageTypePrompt
- [Library, Executable, LibraryAndExecutable]
- , testNumberedPrompt "Check cabalVersionPrompt output" cabalVersionPrompt
- defaultCabalVersions
- ]
- , testGroup "Bool prompt tests"
- [ testBoolPrompt "Check noCommentsPrompt output - y" noCommentsPrompt False "y"
- , testBoolPrompt "Check noCommentsPrompt output - Y" noCommentsPrompt False "Y"
- , testBoolPrompt "Check noCommentsPrompt output - n" noCommentsPrompt True "n"
- , testBoolPrompt "Check noCommentsPrompt output - N" noCommentsPrompt True "N"
]
- ]
-
-
-- -------------------------------------------------------------------- --
-- Prompt test utils
-
testSimplePrompt
- :: Eq a
- => Show a
- => String
- -> (InitFlags -> PurePrompt a)
- -> a
- -> [String]
- -> TestTree
+ :: Eq a
+ => Show a
+ => String
+ -> (InitFlags -> PurePrompt a)
+ -> a
+ -> [String]
+ -> TestTree
testSimplePrompt label f target =
- testPrompt label f (assertFailure . show) (\(a,_) -> target @=? a)
+ testPrompt label f (assertFailure . show) (\(a, _) -> target @=? a)
testPromptBreak
- :: Eq a
- => Show a
- => String
- -> (InitFlags -> PurePrompt a)
- -> [String]
- -> TestTree
+ :: Eq a
+ => Show a
+ => String
+ -> (InitFlags -> PurePrompt a)
+ -> [String]
+ -> TestTree
testPromptBreak label f =
- testPrompt label f go (assertFailure . show)
+ testPrompt label f go (assertFailure . show)
where
go BreakException{} =
return ()
testPrompt
- :: Eq a
- => Show a
- => String
- -> (InitFlags -> PurePrompt a)
- -> (BreakException -> Assertion)
- -> ((a, NonEmpty String) -> Assertion)
- -> [String]
- -> TestTree
+ :: Eq a
+ => Show a
+ => String
+ -> (InitFlags -> PurePrompt a)
+ -> (BreakException -> Assertion)
+ -> ((a, NonEmpty String) -> Assertion)
+ -> [String]
+ -> TestTree
testPrompt label f g h input = testCase label $
- case (_runPrompt $ f emptyFlags) (fromList input) of
- Left x -> g x -- :: BreakException
- Right x -> h x -- :: (a, other inputs)
+ case (_runPrompt $ f emptyFlags) (fromList input) of
+ Left x -> g x -- :: BreakException
+ Right x -> h x -- :: (a, other inputs)
testNumberedPrompt :: (Eq a, Show a) => String -> (InitFlags -> PurePrompt a) -> [a] -> TestTree
testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexed1
where
indexed1 = zip [1 :: Int ..]
- mkLabel a n = "testing index "
- ++ show n
- ++ ") with: "
- ++ show a
+ mkLabel a n =
+ "testing index "
+ ++ show n
+ ++ ") with: "
+ ++ show a
go (n, a) =
testSimplePrompt (mkLabel a n) act a [show n]
@@ -1028,10 +1128,10 @@ testNumberedPrompt label act = testGroup label . (++ goBreak) . fmap go . indexe
]
testBoolPrompt
- :: String
- -> (InitFlags -> PurePrompt Bool)
- -> Bool
- -> String
- -> TestTree
+ :: String
+ -> (InitFlags -> PurePrompt Bool)
+ -> Bool
+ -> String
+ -> TestTree
testBoolPrompt label act target b =
- testSimplePrompt label act target [b]
+ testSimplePrompt label act target [b]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
index d63e81105495e583853b5b02c8ceae08e142a536..d35ab35a659ee31d4dbcd59356d1d29fdc1acbdc 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE LambdaCase #-}
+
module UnitTests.Distribution.Client.Init.NonInteractive
( tests
) where
@@ -9,46 +10,51 @@ import Test.Tasty.HUnit
import UnitTests.Distribution.Client.Init.Utils
import qualified Data.List.NonEmpty as NEL
-import qualified Distribution.SPDX as SPDX
+import qualified Distribution.SPDX as SPDX
+import Data.List (foldl')
+import qualified Data.Set as Set
+import Distribution.CabalSpecVersion
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.NonInteractive.Command
import Distribution.Client.Init.Types
+import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep)
+import Distribution.Client.Setup (initCommand)
import Distribution.Client.Types
+import Distribution.FieldGrammar.Newtypes
+import Distribution.ModuleName (fromString)
import Distribution.Simple
+import Distribution.Simple.Command
+import Distribution.Simple.Flag
import Distribution.Simple.PackageIndex
import Distribution.Verbosity
-import Distribution.CabalSpecVersion
-import Distribution.ModuleName (fromString)
-import Distribution.Simple.Flag
-import Data.List (foldl')
-import qualified Data.Set as Set
-import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep)
-import Distribution.FieldGrammar.Newtypes
-import Distribution.Simple.Command
-import Distribution.Client.Setup (initCommand)
tests
- :: Verbosity
- -> InitFlags
- -> Compiler
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> TestTree
+ :: Verbosity
+ -> InitFlags
+ -> Compiler
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> TestTree
tests _v _initFlags comp pkgIx srcDb =
- testGroup "Distribution.Client.Init.NonInteractive.Command"
- [ testGroup "driver function test"
- [ driverFunctionTest pkgIx srcDb comp
- ]
- , testGroup "target creator tests"
- [ fileCreatorTests pkgIx srcDb comp
- ]
- , testGroup "non-interactive tests"
- [ nonInteractiveTests pkgIx srcDb comp
- ]
- , testGroup "cli parser tests"
- [ cliListParserTests
- ]
+ testGroup
+ "Distribution.Client.Init.NonInteractive.Command"
+ [ testGroup
+ "driver function test"
+ [ driverFunctionTest pkgIx srcDb comp
+ ]
+ , testGroup
+ "target creator tests"
+ [ fileCreatorTests pkgIx srcDb comp
+ ]
+ , testGroup
+ "non-interactive tests"
+ [ nonInteractiveTests pkgIx srcDb comp
+ ]
+ , testGroup
+ "cli parser tests"
+ [ cliListParserTests
+ ]
]
driverFunctionTest
@@ -56,1191 +62,1312 @@ driverFunctionTest
-> SourcePackageDb
-> Compiler
-> TestTree
-driverFunctionTest pkgIx srcDb comp = testGroup "createProject"
- [ testGroup "with flags"
- [ testCase "Check the non-interactive workflow 1" $ do
- let dummyFlags' = dummyFlags
- { packageType = Flag LibraryAndExecutable
- , minimal = Flag False
- , overwrite = Flag False
- , packageDir = Flag "/home/test/test-package"
- , extraDoc = Flag ["CHANGELOG.md"]
- , exposedModules = Flag []
- , otherModules = Flag []
- , otherExts = Flag []
- , buildTools = Flag []
- , mainIs = Flag "quxApp/Main.hs"
- , dependencies = Flag []
- }
- inputs = NEL.fromList
- ["Foobar"
- , "foobar@qux.com"
- , "True"
- , "[\"quxTest/Main.hs\"]"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of
- Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= True
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "QuxPackage"
-
- _pkgCabalVersion desc @?= CabalSpecV2_2
- _pkgName desc @?= mkPackageName "QuxPackage"
- _pkgVersion desc @?= mkVersion [4,2,6]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "We are Qux, and this is our package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["quxSrc"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule NEL.:| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?= []
- _libBuildTools lib @?= []
-
- _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard
- _exeApplicationDirs exe @?= ["quxApp"]
- _exeLanguage exe @?= Haskell98
- _exeOtherModules exe @?= []
- _exeOtherExts exe @?= []
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= []
-
- _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard
- _testDirs test @?= ["quxTest"]
- _testLanguage test @?= Haskell98
- _testOtherModules test @?= []
- _testOtherExts test @?= []
- _testDependencies test @?! []
- _testBuildTools test @?= []
-
- assertBool "The library should be a dependency of the executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
- assertBool "The library should be a dependency of the test executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the non-interactive workflow 2" $ do
- let dummyFlags' = dummyFlags
- { packageType = Flag LibraryAndExecutable
- , minimal = Flag False
- , overwrite = Flag False
- , packageDir = Flag "/home/test/test-package"
- , extraSrc = Flag []
- , exposedModules = Flag []
- , otherModules = NoFlag
- , otherExts = Flag []
- , buildTools = Flag []
- , mainIs = Flag "quxApp/Main.hs"
- , dependencies = Flag []
- }
- inputs = NEL.fromList
-
- [ "Foobar"
- , "foobar@qux.com"
- -- extra sources
- , "[\"CHANGELOG.md\"]"
- -- lib other modules
- , "False"
- -- exe other modules
- , "False"
- -- test main file
- , "True"
- , "[\"quxTest/Main.hs\"]"
- -- test other modules
- , "False"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of
- Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= True
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "QuxPackage"
-
- _pkgCabalVersion desc @?= CabalSpecV2_2
- _pkgName desc @?= mkPackageName "QuxPackage"
- _pkgVersion desc @?= mkVersion [4,2,6]
- _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= "qux.com"
- _pkgSynopsis desc @?= "We are Qux, and this is our package"
- _pkgCategory desc @?= "Control"
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["quxSrc"]
- _libLanguage lib @?= Haskell98
- _libExposedModules lib @?= myLibModule NEL.:| []
- _libOtherModules lib @?= []
- _libOtherExts lib @?= []
- _libDependencies lib @?= []
- _libBuildTools lib @?= []
-
- _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard
- _exeApplicationDirs exe @?= ["quxApp"]
- _exeLanguage exe @?= Haskell98
- _exeOtherModules exe @?= []
- _exeOtherExts exe @?= []
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= []
-
- _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard
- _testDirs test @?= ["quxTest"]
- _testLanguage test @?= Haskell98
- _testOtherModules test @?= []
- _testOtherExts test @?= []
- _testDependencies test @?! []
- _testBuildTools test @?= []
-
- assertBool "The library should be a dependency of the executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
- assertBool "The library should be a dependency of the test executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
- ]
- , testGroup "with tests"
- [ testCase "Check the non-interactive library and executable workflow" $ do
- let inputs = NEL.fromList
- -- package dir
- [ "test-package"
- -- package description
- -- cabal version
- , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
- -- package name
- , "test-package"
- , "test-package"
- -- author name
- , ""
- , "Foobar"
- -- author email
- , ""
- , "foobar@qux.com"
- -- extra source files
- , "test-package"
- , "[]"
- -- library target
- -- source dirs
- , "src"
- , "True"
- -- exposed modules
- , "src"
- , "True"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other modules
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "module Baz.Internal where"
- -- other extensions
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"src/Foo.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- -- executable target
- -- application dirs
- , "app"
- , "[]"
- -- main file
- , "test-package"
- , "[\"test-package/app/\"]"
- , "True"
- , "[]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"app/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- -- test target
- -- main file
- , "True"
- , "[\"test-package/test/\"]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"test/Foo.hs\", \"test/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"test/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Test.Tasty\nimport Test.Tasty.HUnit"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags
- { initializeTestSuite = Flag True
- , packageType = Flag LibraryAndExecutable
- })) inputs of
- Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV3_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [0,1,0,0]
- _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= ""
- _pkgSynopsis desc @?= ""
- _pkgCategory desc @?= ""
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell2010
- _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
- _libOtherModules lib @?= map fromString ["Baz.Internal"]
- _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _libDependencies lib @?! []
- _libBuildTools lib @?= [mkStringyDep "happy:happy"]
-
- _exeMainIs exe @?= HsFilePath "Main.hs" Standard
- _exeApplicationDirs exe @?= ["app"]
- _exeLanguage exe @?= Haskell2010
- _exeOtherModules exe @?= map fromString ["Foo", "Bar"]
- _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= [mkStringyDep "happy:happy"]
-
- _testMainIs test @?= HsFilePath "Main.hs" Standard
- _testDirs test @?= ["test"]
- _testLanguage test @?= Haskell2010
- _testOtherModules test @?= map fromString ["Foo", "Bar"]
- _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _testDependencies test @?! []
- _testBuildTools test @?= [mkStringyDep "happy:happy"]
-
- assertBool "The library should be a dependency of the executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
- assertBool "The library should be a dependency of the test executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the non-interactive library workflow" $ do
- let inputs = NEL.fromList
- -- package dir
- [ "test-package"
- -- package description
- -- cabal version
- , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
- -- package name
- , "test-package"
- , "test-package"
- -- author name
- , "Foobar"
- -- author email
- , "foobar@qux.com"
- -- extra source files
- , "test-package"
- , "[]"
- -- library target
- -- source dirs
- , "src"
- , "True"
- -- exposed modules
- , "src"
- , "True"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other modules
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "module Baz.Internal where"
- -- other extensions
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"src/Foo.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- -- test target
- -- main file
- , "True"
- , "[\"test-package/test/\"]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"test/Foo.hs\", \"test/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"test/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Test.Tasty\nimport Test.Tasty.HUnit"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb (emptyFlags
- { initializeTestSuite = Flag True
- , packageType = Flag Library
- })) inputs of
- Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Library
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV3_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [0,1,0,0]
- _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= ""
- _pkgSynopsis desc @?= ""
- _pkgCategory desc @?= ""
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell2010
- _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
- _libOtherModules lib @?= map fromString ["Baz.Internal"]
- _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _libDependencies lib @?! []
- _libBuildTools lib @?= [mkStringyDep "happy:happy"]
-
- _testMainIs test @?= HsFilePath "Main.hs" Standard
- _testDirs test @?= ["test"]
- _testLanguage test @?= Haskell2010
- _testOtherModules test @?= map fromString ["Foo", "Bar"]
- _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _testDependencies test @?! []
- _testBuildTools test @?= [mkStringyDep "happy:happy"]
-
- assertBool "The library should be a dependency of the test executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?= Nothing
- test @?! Nothing
- Left e -> assertFailure $ show e
- ]
- , testGroup "without tests"
- [ testCase "Check the non-interactive library and executable workflow" $ do
- let inputs = NEL.fromList
- -- package type
- [ "test-package"
- , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
- , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
- -- package name
- , "test-package"
- , "test-package"
- -- author name
- , ""
- , "Foobar"
- -- author email
- , ""
- , "foobar@qux.com"
- -- extra source files
- , "test-package"
- , "[]"
- -- library target
- -- source dirs
- , "src"
- , "True"
- -- exposed modules
- , "src"
- , "True"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other modules
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "module Baz.Internal where"
- -- other extensions
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"src/Foo.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- -- executable target
- -- application dirs
- , "app"
- , "[]"
- -- main file
- , "test-package"
- , "[\"test-package/app/\"]"
- , "True"
- , "[]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"app/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= LibraryAndExecutable
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV3_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [0,1,0,0]
- _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= ""
- _pkgSynopsis desc @?= ""
- _pkgCategory desc @?= ""
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell2010
- _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
- _libOtherModules lib @?= map fromString ["Baz.Internal"]
- _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _libDependencies lib @?! []
- _libBuildTools lib @?= [mkStringyDep "happy:happy"]
-
- _exeMainIs exe @?= HsFilePath "Main.hs" Standard
- _exeApplicationDirs exe @?= ["app"]
- _exeLanguage exe @?= Haskell2010
- _exeOtherModules exe @?= map fromString ["Foo", "Bar"]
- _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= [mkStringyDep "happy:happy"]
-
- assertBool "The library should be a dependency of the executable" $
- mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?! Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the non-interactive library workflow" $ do
- let inputs = NEL.fromList
- -- package type
- [ "test-package"
- , "[\".\", \"..\", \"src/\"]"
- , "[\".\", \"..\", \"src/\"]"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
- -- package name
- , "test-package"
- , "test-package"
- -- author name
- , ""
- , "Foobar"
- -- author email
- , ""
- , "foobar@qux.com"
- -- extra source files
- , "test-package"
- , "[]"
- -- library target
- -- source dirs
- , "src"
- , "True"
- -- exposed modules
- , "src"
- , "True"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other modules
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "module Baz.Internal where"
- -- other extensions
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"src/Foo.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Library
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV3_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [0,1,0,0]
- _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= ""
- _pkgSynopsis desc @?= ""
- _pkgCategory desc @?= ""
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _libSourceDirs lib @?= ["src"]
- _libLanguage lib @?= Haskell2010
- _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
- _libOtherModules lib @?= map fromString ["Baz.Internal"]
- _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _libDependencies lib @?! []
- _libBuildTools lib @?= [mkStringyDep "happy:happy"]
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?! Nothing
- exe @?= Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
-
- , testCase "Check the non-interactive executable workflow" $ do
- let inputs = NEL.fromList
- -- package type
- [ "test-package"
- , "[\".\", \"..\", \"app/Main.hs\"]"
- , "[\".\", \"..\", \"app/Main.hs\"]"
- -- package dir
- , "test-package"
- -- package description
- -- cabal version
- , "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
- -- package name
- , "test-package"
- , "test-package"
- -- author name
- , ""
- , "Foobar"
- -- author email
- , ""
- , "foobar@qux.com"
- -- extra source files
- , "test-package"
- , "[]"
- -- executable target
- -- application dirs
- , "app"
- , "[]"
- -- main file
- , "test-package"
- , "[\"test-package/app/\"]"
- , "True"
- , "[]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"app/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- ]
-
- case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of
- Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do
- _optOverwrite opts @?= False
- _optMinimal opts @?= False
- _optNoComments opts @?= False
- _optVerbosity opts @?= silent
- _optPkgDir opts @?= "/home/test/test-package"
- _optPkgType opts @?= Executable
- _optPkgName opts @?= mkPackageName "test-package"
-
- _pkgCabalVersion desc @?= CabalSpecV3_4
- _pkgName desc @?= mkPackageName "test-package"
- _pkgVersion desc @?= mkVersion [0,1,0,0]
- _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
- _pkgAuthor desc @?= "Foobar"
- _pkgEmail desc @?= "foobar@qux.com"
- _pkgHomePage desc @?= ""
- _pkgSynopsis desc @?= ""
- _pkgCategory desc @?= ""
- _pkgExtraSrcFiles desc @?= mempty
- _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
-
- _exeMainIs exe @?= HsFilePath "Main.hs" Standard
- _exeApplicationDirs exe @?= ["app"]
- _exeLanguage exe @?= Haskell2010
- _exeOtherModules exe @?= map fromString ["Foo", "Bar"]
- _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
- _exeDependencies exe @?! []
- _exeBuildTools exe @?= [mkStringyDep "happy:happy"]
-
- Right (ProjectSettings _ _ lib exe test, _) -> do
- lib @?= Nothing
- exe @?! Nothing
- test @?= Nothing
- Left e -> assertFailure $ show e
+driverFunctionTest pkgIx srcDb comp =
+ testGroup
+ "createProject"
+ [ testGroup
+ "with flags"
+ [ testCase "Check the non-interactive workflow 1" $ do
+ let dummyFlags' =
+ dummyFlags
+ { packageType = Flag LibraryAndExecutable
+ , minimal = Flag False
+ , overwrite = Flag False
+ , packageDir = Flag "/home/test/test-package"
+ , extraDoc = Flag ["CHANGELOG.md"]
+ , exposedModules = Flag []
+ , otherModules = Flag []
+ , otherExts = Flag []
+ , buildTools = Flag []
+ , mainIs = Flag "quxApp/Main.hs"
+ , dependencies = Flag []
+ }
+ inputs =
+ NEL.fromList
+ [ "Foobar"
+ , "foobar@qux.com"
+ , "True"
+ , "[\"quxTest/Main.hs\"]"
+ ]
+
+ case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= True
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "QuxPackage"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_2
+ _pkgName desc @?= mkPackageName "QuxPackage"
+ _pkgVersion desc @?= mkVersion [4, 2, 6]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "We are Qux, and this is our package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["quxSrc"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule NEL.:| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?= []
+ _libBuildTools lib @?= []
+
+ _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard
+ _exeApplicationDirs exe @?= ["quxApp"]
+ _exeLanguage exe @?= Haskell98
+ _exeOtherModules exe @?= []
+ _exeOtherExts exe @?= []
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= []
+
+ _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard
+ _testDirs test @?= ["quxTest"]
+ _testLanguage test @?= Haskell98
+ _testOtherModules test @?= []
+ _testOtherExts test @?= []
+ _testDependencies test @?! []
+ _testBuildTools test @?= []
+
+ assertBool "The library should be a dependency of the executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
+ assertBool "The library should be a dependency of the test executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the non-interactive workflow 2" $ do
+ let dummyFlags' =
+ dummyFlags
+ { packageType = Flag LibraryAndExecutable
+ , minimal = Flag False
+ , overwrite = Flag False
+ , packageDir = Flag "/home/test/test-package"
+ , extraSrc = Flag []
+ , exposedModules = Flag []
+ , otherModules = NoFlag
+ , otherExts = Flag []
+ , buildTools = Flag []
+ , mainIs = Flag "quxApp/Main.hs"
+ , dependencies = Flag []
+ }
+ inputs =
+ NEL.fromList
+ [ "Foobar"
+ , "foobar@qux.com"
+ , -- extra sources
+ "[\"CHANGELOG.md\"]"
+ , -- lib other modules
+ "False"
+ , -- exe other modules
+ "False"
+ , -- test main file
+ "True"
+ , "[\"quxTest/Main.hs\"]"
+ , -- test other modules
+ "False"
+ ]
+
+ case (_runPrompt $ createProject comp silent pkgIx srcDb dummyFlags') inputs of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= True
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "QuxPackage"
+
+ _pkgCabalVersion desc @?= CabalSpecV2_2
+ _pkgName desc @?= mkPackageName "QuxPackage"
+ _pkgVersion desc @?= mkVersion [4, 2, 6]
+ _pkgLicense desc @?! (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= "qux.com"
+ _pkgSynopsis desc @?= "We are Qux, and this is our package"
+ _pkgCategory desc @?= "Control"
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["quxSrc"]
+ _libLanguage lib @?= Haskell98
+ _libExposedModules lib @?= myLibModule NEL.:| []
+ _libOtherModules lib @?= []
+ _libOtherExts lib @?= []
+ _libDependencies lib @?= []
+ _libBuildTools lib @?= []
+
+ _exeMainIs exe @?= HsFilePath "quxApp/Main.hs" Standard
+ _exeApplicationDirs exe @?= ["quxApp"]
+ _exeLanguage exe @?= Haskell98
+ _exeOtherModules exe @?= []
+ _exeOtherExts exe @?= []
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= []
+
+ _testMainIs test @?= HsFilePath "quxTest/Main.hs" Standard
+ _testDirs test @?= ["quxTest"]
+ _testLanguage test @?= Haskell98
+ _testOtherModules test @?= []
+ _testOtherExts test @?= []
+ _testDependencies test @?! []
+ _testBuildTools test @?= []
+
+ assertBool "The library should be a dependency of the executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
+ assertBool "The library should be a dependency of the test executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ ]
+ , testGroup
+ "with tests"
+ [ testCase "Check the non-interactive library and executable workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- package dir
+ [ "test-package"
+ , -- package description
+ -- cabal version
+ "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , -- author name
+ ""
+ , "Foobar"
+ , -- author email
+ ""
+ , "foobar@qux.com"
+ , -- extra source files
+ "test-package"
+ , "[]"
+ , -- library target
+ -- source dirs
+ "src"
+ , "True"
+ , -- exposed modules
+ "src"
+ , "True"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "module Baz.Internal where"
+ , -- other extensions
+ "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"src/Foo.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ , -- executable target
+ -- application dirs
+ "app"
+ , "[]"
+ , -- main file
+ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"app/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ , -- test target
+ -- main file
+ "True"
+ , "[\"test-package/test/\"]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"test/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Test.Tasty\nimport Test.Tasty.HUnit"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"
+ ]
+
+ case ( _runPrompt $
+ createProject
+ comp
+ silent
+ pkgIx
+ srcDb
+ ( emptyFlags
+ { initializeTestSuite = Flag True
+ , packageType = Flag LibraryAndExecutable
+ }
+ )
+ )
+ inputs of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV3_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [0, 1, 0, 0]
+ _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= ""
+ _pkgSynopsis desc @?= ""
+ _pkgCategory desc @?= ""
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell2010
+ _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
+ _libOtherModules lib @?= map fromString ["Baz.Internal"]
+ _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= [mkStringyDep "happy:happy"]
+
+ _exeMainIs exe @?= HsFilePath "Main.hs" Standard
+ _exeApplicationDirs exe @?= ["app"]
+ _exeLanguage exe @?= Haskell2010
+ _exeOtherModules exe @?= map fromString ["Foo", "Bar"]
+ _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= [mkStringyDep "happy:happy"]
+
+ _testMainIs test @?= HsFilePath "Main.hs" Standard
+ _testDirs test @?= ["test"]
+ _testLanguage test @?= Haskell2010
+ _testOtherModules test @?= map fromString ["Foo", "Bar"]
+ _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _testDependencies test @?! []
+ _testBuildTools test @?= [mkStringyDep "happy:happy"]
+
+ assertBool "The library should be a dependency of the executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
+ assertBool "The library should be a dependency of the test executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the non-interactive library workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- package dir
+ [ "test-package"
+ , -- package description
+ -- cabal version
+ "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , -- author name
+ "Foobar"
+ , -- author email
+ "foobar@qux.com"
+ , -- extra source files
+ "test-package"
+ , "[]"
+ , -- library target
+ -- source dirs
+ "src"
+ , "True"
+ , -- exposed modules
+ "src"
+ , "True"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "module Baz.Internal where"
+ , -- other extensions
+ "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"src/Foo.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ , -- test target
+ -- main file
+ "True"
+ , "[\"test-package/test/\"]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"test/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Test.Tasty\nimport Test.Tasty.HUnit"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"
+ ]
+
+ case ( _runPrompt $
+ createProject
+ comp
+ silent
+ pkgIx
+ srcDb
+ ( emptyFlags
+ { initializeTestSuite = Flag True
+ , packageType = Flag Library
+ }
+ )
+ )
+ inputs of
+ Right (ProjectSettings opts desc (Just lib) Nothing (Just test), _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Library
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV3_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [0, 1, 0, 0]
+ _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= ""
+ _pkgSynopsis desc @?= ""
+ _pkgCategory desc @?= ""
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell2010
+ _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
+ _libOtherModules lib @?= map fromString ["Baz.Internal"]
+ _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= [mkStringyDep "happy:happy"]
+
+ _testMainIs test @?= HsFilePath "Main.hs" Standard
+ _testDirs test @?= ["test"]
+ _testLanguage test @?= Haskell2010
+ _testOtherModules test @?= map fromString ["Foo", "Bar"]
+ _testOtherExts test @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _testDependencies test @?! []
+ _testBuildTools test @?= [mkStringyDep "happy:happy"]
+
+ assertBool "The library should be a dependency of the test executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _testDependencies test
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?= Nothing
+ test @?! Nothing
+ Left e -> assertFailure $ show e
+ ]
+ , testGroup
+ "without tests"
+ [ testCase "Check the non-interactive library and executable workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- package type
+ [ "test-package"
+ , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
+ , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , -- author name
+ ""
+ , "Foobar"
+ , -- author email
+ ""
+ , "foobar@qux.com"
+ , -- extra source files
+ "test-package"
+ , "[]"
+ , -- library target
+ -- source dirs
+ "src"
+ , "True"
+ , -- exposed modules
+ "src"
+ , "True"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "module Baz.Internal where"
+ , -- other extensions
+ "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"src/Foo.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ , -- executable target
+ -- application dirs
+ "app"
+ , "[]"
+ , -- main file
+ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"app/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ ]
+
+ case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc (Just lib) (Just exe) Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= LibraryAndExecutable
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV3_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [0, 1, 0, 0]
+ _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= ""
+ _pkgSynopsis desc @?= ""
+ _pkgCategory desc @?= ""
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell2010
+ _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
+ _libOtherModules lib @?= map fromString ["Baz.Internal"]
+ _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= [mkStringyDep "happy:happy"]
+
+ _exeMainIs exe @?= HsFilePath "Main.hs" Standard
+ _exeApplicationDirs exe @?= ["app"]
+ _exeLanguage exe @?= Haskell2010
+ _exeOtherModules exe @?= map fromString ["Foo", "Bar"]
+ _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= [mkStringyDep "happy:happy"]
+
+ assertBool "The library should be a dependency of the executable" $
+ mkPackageNameDep (_optPkgName opts) `elem` _exeDependencies exe
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?! Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the non-interactive library workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- package type
+ [ "test-package"
+ , "[\".\", \"..\", \"src/\"]"
+ , "[\".\", \"..\", \"src/\"]"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , -- author name
+ ""
+ , "Foobar"
+ , -- author email
+ ""
+ , "foobar@qux.com"
+ , -- extra source files
+ "test-package"
+ , "[]"
+ , -- library target
+ -- source dirs
+ "src"
+ , "True"
+ , -- exposed modules
+ "src"
+ , "True"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "module Baz.Internal where"
+ , -- other extensions
+ "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"src/Foo.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ ]
+
+ case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc (Just lib) Nothing Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Library
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV3_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [0, 1, 0, 0]
+ _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= ""
+ _pkgSynopsis desc @?= ""
+ _pkgCategory desc @?= ""
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _libSourceDirs lib @?= ["src"]
+ _libLanguage lib @?= Haskell2010
+ _libExposedModules lib @?= NEL.fromList (map fromString ["Foo", "Bar"])
+ _libOtherModules lib @?= map fromString ["Baz.Internal"]
+ _libOtherExts lib @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _libDependencies lib @?! []
+ _libBuildTools lib @?= [mkStringyDep "happy:happy"]
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?! Nothing
+ exe @?= Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ , testCase "Check the non-interactive executable workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- package type
+ [ "test-package"
+ , "[\".\", \"..\", \"app/Main.hs\"]"
+ , "[\".\", \"..\", \"app/Main.hs\"]"
+ , -- package dir
+ "test-package"
+ , -- package description
+ -- cabal version
+ "cabal-install version 3.4.0.0\ncompiled using version 3.4.0.0 of the Cabal library \n"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , -- author name
+ ""
+ , "Foobar"
+ , -- author email
+ ""
+ , "foobar@qux.com"
+ , -- extra source files
+ "test-package"
+ , "[]"
+ , -- executable target
+ -- application dirs
+ "app"
+ , "[]"
+ , -- main file
+ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"app/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, DataKinds #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ ]
+
+ case (_runPrompt $ createProject comp silent pkgIx srcDb emptyFlags) inputs of
+ Right (ProjectSettings opts desc Nothing (Just exe) Nothing, _) -> do
+ _optOverwrite opts @?= False
+ _optMinimal opts @?= False
+ _optNoComments opts @?= False
+ _optVerbosity opts @?= silent
+ _optPkgDir opts @?= "/home/test/test-package"
+ _optPkgType opts @?= Executable
+ _optPkgName opts @?= mkPackageName "test-package"
+
+ _pkgCabalVersion desc @?= CabalSpecV3_4
+ _pkgName desc @?= mkPackageName "test-package"
+ _pkgVersion desc @?= mkVersion [0, 1, 0, 0]
+ _pkgLicense desc @?= (SpecLicense . Left $ SPDX.NONE)
+ _pkgAuthor desc @?= "Foobar"
+ _pkgEmail desc @?= "foobar@qux.com"
+ _pkgHomePage desc @?= ""
+ _pkgSynopsis desc @?= ""
+ _pkgCategory desc @?= ""
+ _pkgExtraSrcFiles desc @?= mempty
+ _pkgExtraDocFiles desc @?= pure (Set.singleton "CHANGELOG.md")
+
+ _exeMainIs exe @?= HsFilePath "Main.hs" Standard
+ _exeApplicationDirs exe @?= ["app"]
+ _exeLanguage exe @?= Haskell2010
+ _exeOtherModules exe @?= map fromString ["Foo", "Bar"]
+ _exeOtherExts exe @?= map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards]
+ _exeDependencies exe @?! []
+ _exeBuildTools exe @?= [mkStringyDep "happy:happy"]
+ Right (ProjectSettings _ _ lib exe test, _) -> do
+ lib @?= Nothing
+ exe @?! Nothing
+ test @?= Nothing
+ Left e -> assertFailure $ show e
+ ]
]
- ]
fileCreatorTests
:: InstalledPackageIndex
-> SourcePackageDb
-> Compiler
-> TestTree
-fileCreatorTests pkgIx srcDb comp = testGroup "generators"
- [ testGroup "genPkgDescription"
- [ testCase "Check common package flags workflow" $ do
- let inputs = NEL.fromList
- -- cabal version
- [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"
- -- package name
- , "test-package"
- , "test-package"
- -- author name
- , ""
- , "Foobar"
- -- author email
- , ""
- , "foobar@qux.com"
- -- extra source files
- , "test-package"
- , "[]"
- ]
-
- case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of
- Left e -> assertFailure $ show e
- Right{} -> return ()
- ]
- , testGroup "genLibTarget"
- [ testCase "Check library package flags workflow" $ do
- let inputs = NEL.fromList
- -- source dirs
- [ "src"
- , "True"
- -- exposed modules
- , "src"
- , "True"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other modules
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "module Baz.Internal where"
- -- other extensions
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"src/Foo.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- ]
-
- case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of
- Left e -> assertFailure $ show e
- Right{} -> return ()
- ]
- , testGroup "genExeTarget"
- [ testCase "Check executable package flags workflow" $ do
- let inputs = NEL.fromList
- -- application dirs
- [ "app"
- , "[]"
- -- main file
- , "test-package"
- , "[\"test-package/app/\"]"
- , "True"
- , "[]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"app/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Control.Monad.Extra"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- ]
-
- case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of
- Left e -> assertFailure $ show e
- Right{} -> return ()
- ]
- , testGroup "genTestTarget"
- [ testCase "Check test package flags workflow" $ do
- let inputs = NEL.fromList
- -- main file
- [ "True"
- , "[]"
- -- other modules
- , "test-package"
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- -- other extensions
- , "True"
- , "[\"test/Foo.hs\", \"test/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- -- dependencies
- , "True"
- , "[\"test/Main.hs\"]"
- , "True"
- , "test-package"
- , "module Main where"
- , "import Test.Tasty\nimport Test.Tasty.HUnit"
- , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
- -- build tools
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"
- ]
- flags = emptyFlags {initializeTestSuite = Flag True}
-
- case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of
- Left e -> assertFailure $ show e
- Right{} -> return ()
+fileCreatorTests pkgIx srcDb comp =
+ testGroup
+ "generators"
+ [ testGroup
+ "genPkgDescription"
+ [ testCase "Check common package flags workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- cabal version
+ [ "cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"
+ , -- package name
+ "test-package"
+ , "test-package"
+ , -- author name
+ ""
+ , "Foobar"
+ , -- author email
+ ""
+ , "foobar@qux.com"
+ , -- extra source files
+ "test-package"
+ , "[]"
+ ]
+
+ case (_runPrompt $ genPkgDescription emptyFlags srcDb) inputs of
+ Left e -> assertFailure $ show e
+ Right{} -> return ()
+ ]
+ , testGroup
+ "genLibTarget"
+ [ testCase "Check library package flags workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- source dirs
+ [ "src"
+ , "True"
+ , -- exposed modules
+ "src"
+ , "True"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "module Baz.Internal where"
+ , -- other extensions
+ "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"src/Foo.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ ]
+
+ case (_runPrompt $ genLibTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of
+ Left e -> assertFailure $ show e
+ Right{} -> return ()
+ ]
+ , testGroup
+ "genExeTarget"
+ [ testCase "Check executable package flags workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- application dirs
+ [ "app"
+ , "[]"
+ , -- main file
+ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"app/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Control.Monad.Extra"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
+ ]
+
+ case (_runPrompt $ genExeTarget emptyFlags comp pkgIx defaultCabalVersion) inputs of
+ Left e -> assertFailure $ show e
+ Right{} -> return ()
+ ]
+ , testGroup
+ "genTestTarget"
+ [ testCase "Check test package flags workflow" $ do
+ let inputs =
+ NEL.fromList
+ -- main file
+ [ "True"
+ , "[]"
+ , -- other modules
+ "test-package"
+ , "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , -- other extensions
+ "True"
+ , "[\"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ , -- dependencies
+ "True"
+ , "[\"test/Main.hs\"]"
+ , "True"
+ , "test-package"
+ , "module Main where"
+ , "import Test.Tasty\nimport Test.Tasty.HUnit"
+ , "{-# LANGUAGE OverloadedStrings, LambdaCase #-}"
+ , -- build tools
+ "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/bar.y\"]"
+ ]
+ flags = emptyFlags{initializeTestSuite = Flag True}
+
+ case (_runPrompt $ genTestTarget flags comp pkgIx defaultCabalVersion) inputs of
+ Left e -> assertFailure $ show e
+ Right{} -> return ()
+ ]
]
- ]
nonInteractiveTests
:: InstalledPackageIndex
-> SourcePackageDb
-> Compiler
-> TestTree
-nonInteractiveTests pkgIx srcDb comp = testGroup "Check top level getter functions"
- [ testGroup "Simple heuristics tests"
- [ testGroup "Check packageNameHeuristics output"
- [ testSimple "New package name" (packageNameHeuristics srcDb)
- (mkPackageName "test-package")
- [ "test-package"
- , "test-package"
- ]
- , testSimple "Existing package name" (packageNameHeuristics srcDb)
- (mkPackageName "cabal-install")
- [ "test-package"
- , "cabal-install"
- ]
- ]
- , testSimple "Check authorHeuristics output" authorHeuristics "Foobar"
- [ ""
- , "Foobar"
- ]
- , testSimple "Check emailHeuristics output" emailHeuristics "foobar@qux.com"
- [ ""
- , "foobar@qux.com"
- ]
- , testSimple "Check srcDirsHeuristics output" srcDirsHeuristics ["src"]
- [ "src"
- , "True"
- ]
- , testSimple "Check appDirsHeuristics output" appDirsHeuristics ["app"]
- [ "test-package"
- , "[\"test-package/app/\"]"
- ]
- , testGroup "Check packageTypeHeuristics output"
- [ testSimple "Library" packageTypeHeuristics Library
- [ "test-package"
- , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]"
- , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]"
+nonInteractiveTests pkgIx srcDb comp =
+ testGroup
+ "Check top level getter functions"
+ [ testGroup
+ "Simple heuristics tests"
+ [ testGroup
+ "Check packageNameHeuristics output"
+ [ testSimple
+ "New package name"
+ (packageNameHeuristics srcDb)
+ (mkPackageName "test-package")
+ [ "test-package"
+ , "test-package"
+ ]
+ , testSimple
+ "Existing package name"
+ (packageNameHeuristics srcDb)
+ (mkPackageName "cabal-install")
+ [ "test-package"
+ , "cabal-install"
+ ]
]
- , testSimple "Executable" packageTypeHeuristics Executable
- [ "test-package"
- , "[\".\", \"..\", \"app/Main.hs\"]"
- , "[\".\", \"..\", \"app/Main.hs\"]"
+ , testSimple
+ "Check authorHeuristics output"
+ authorHeuristics
+ "Foobar"
+ [ ""
+ , "Foobar"
]
- , testSimple "Library and Executable" packageTypeHeuristics LibraryAndExecutable
- [ "test-package"
- , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
- , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
- ]
- , testSimple "TestSuite" packageTypeHeuristics TestSuite
- [ "test-package"
- , "[\".\", \"..\", \"test/Main.hs\"]"
- , "[\".\", \"..\", \"test/Main.hs\"]"
- ]
- ]
- , testGroup "Check cabalVersionHeuristics output"
- [ testSimple "Broken command" cabalVersionHeuristics defaultCabalVersion
- [""]
- , testSimple "Proper answer" cabalVersionHeuristics CabalSpecV2_4
- ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"]
- ]
- , testGroup "Check languageHeuristics output"
- [ testSimple "Non GHC compiler"
- (`languageHeuristics` (comp {compilerId = CompilerId Helium $ mkVersion [1,8,1]}))
- Haskell2010 []
- , testSimple "Higher version compiler"
- (`languageHeuristics` (comp {compilerId = CompilerId GHC $ mkVersion [8,10,4]}))
- Haskell2010 []
- , testSimple "Lower version compiler"
- (`languageHeuristics` (comp {compilerId = CompilerId GHC $ mkVersion [6,0,1]}))
- Haskell98 []
- ]
- , testGroup "Check extraDocFileHeuristics output"
- [ testSimple "No extra sources" extraDocFileHeuristics
- (pure (Set.singleton "CHANGELOG.md"))
- [ "test-package"
- , "[]"
+ , testSimple
+ "Check emailHeuristics output"
+ emailHeuristics
+ "foobar@qux.com"
+ [ ""
+ , "foobar@qux.com"
]
- , testSimple "Extra doc files present" extraDocFileHeuristics
- (pure $ Set.singleton "README.md")
- [ "test-package"
- , "[\"README.md\"]"
- ]
- ]
- , testGroup "Check mainFileHeuristics output"
- [ testSimple "No main file defined" mainFileHeuristics
- (toHsFilePath "Main.hs")
- [ "test-package"
- , "[\"test-package/app/\"]"
+ , testSimple
+ "Check srcDirsHeuristics output"
+ srcDirsHeuristics
+ ["src"]
+ [ "src"
, "True"
- , "[]"
]
- , testSimple "Main file already defined" mainFileHeuristics
- (toHsFilePath "app/Main.hs")
+ , testSimple
+ "Check appDirsHeuristics output"
+ appDirsHeuristics
+ ["app"]
[ "test-package"
, "[\"test-package/app/\"]"
- , "True"
- , "[\"app/Main.hs\"]"
]
- , testSimple "Main lhs file already defined" mainFileHeuristics
- (toHsFilePath "app/Main.lhs")
- [ "test-package"
- , "[\"test-package/app/\"]"
- , "True"
- , "[\"app/Main.lhs\"]"
+ , testGroup
+ "Check packageTypeHeuristics output"
+ [ testSimple
+ "Library"
+ packageTypeHeuristics
+ Library
+ [ "test-package"
+ , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]"
+ , "[\".\", \"..\", \"test/Main.hs\", \"src/\"]"
+ ]
+ , testSimple
+ "Executable"
+ packageTypeHeuristics
+ Executable
+ [ "test-package"
+ , "[\".\", \"..\", \"app/Main.hs\"]"
+ , "[\".\", \"..\", \"app/Main.hs\"]"
+ ]
+ , testSimple
+ "Library and Executable"
+ packageTypeHeuristics
+ LibraryAndExecutable
+ [ "test-package"
+ , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
+ , "[\".\", \"..\", \"src/\", \"app/Main.hs\"]"
+ ]
+ , testSimple
+ "TestSuite"
+ packageTypeHeuristics
+ TestSuite
+ [ "test-package"
+ , "[\".\", \"..\", \"test/Main.hs\"]"
+ , "[\".\", \"..\", \"test/Main.hs\"]"
+ ]
]
- ]
- , testGroup "Check exposedModulesHeuristics output"
- [ testSimple "Default exposed modules" exposedModulesHeuristics
- (myLibModule NEL.:| [])
- [ "src"
- , "True"
- , "True"
- , "[]"
- , "test-package"
- , "True"
- , "[]"
+ , testGroup
+ "Check cabalVersionHeuristics output"
+ [ testSimple
+ "Broken command"
+ cabalVersionHeuristics
+ defaultCabalVersion
+ [""]
+ , testSimple
+ "Proper answer"
+ cabalVersionHeuristics
+ CabalSpecV2_4
+ ["cabal-install version 2.4.0.0\ncompiled using version 2.4.0.0 of the Cabal library \n"]
]
- , testSimple "Contains exposed modules" exposedModulesHeuristics
- (NEL.fromList $ map fromString ["Foo", "Bar"])
- [ "src"
- , "True"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
+ , testGroup
+ "Check languageHeuristics output"
+ [ testSimple
+ "Non GHC compiler"
+ (`languageHeuristics` (comp{compilerId = CompilerId Helium $ mkVersion [1, 8, 1]}))
+ Haskell2010
+ []
+ , testSimple
+ "Higher version compiler"
+ (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [8, 10, 4]}))
+ Haskell2010
+ []
+ , testSimple
+ "Lower version compiler"
+ (`languageHeuristics` (comp{compilerId = CompilerId GHC $ mkVersion [6, 0, 1]}))
+ Haskell98
+ []
]
- ]
- , testGroup "Check libOtherModulesHeuristics output"
- [ testSimple "Library directory exists" libOtherModulesHeuristics
- (map fromString ["Baz.Internal"])
- [ "test-package"
- , "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
- , "module Foo where"
- , "module Bar where"
- , "module Baz.Internal where"
+ , testGroup
+ "Check extraDocFileHeuristics output"
+ [ testSimple
+ "No extra sources"
+ extraDocFileHeuristics
+ (pure (Set.singleton "CHANGELOG.md"))
+ [ "test-package"
+ , "[]"
+ ]
+ , testSimple
+ "Extra doc files present"
+ extraDocFileHeuristics
+ (pure $ Set.singleton "README.md")
+ [ "test-package"
+ , "[\"README.md\"]"
+ ]
]
- , testSimple "Library directory doesn't exist" libOtherModulesHeuristics []
- [ "test-package"
- , "False"
+ , testGroup
+ "Check mainFileHeuristics output"
+ [ testSimple
+ "No main file defined"
+ mainFileHeuristics
+ (toHsFilePath "Main.hs")
+ [ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[]"
+ ]
+ , testSimple
+ "Main file already defined"
+ mainFileHeuristics
+ (toHsFilePath "app/Main.hs")
+ [ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[\"app/Main.hs\"]"
+ ]
+ , testSimple
+ "Main lhs file already defined"
+ mainFileHeuristics
+ (toHsFilePath "app/Main.lhs")
+ [ "test-package"
+ , "[\"test-package/app/\"]"
+ , "True"
+ , "[\"app/Main.lhs\"]"
+ ]
]
- ]
- , testGroup "Check exeOtherModulesHeuristics output"
- [ testSimple "Executable directory exists" exeOtherModulesHeuristics
- (map fromString ["Foo", "Bar"])
- [ "test-package"
- , "True"
- , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
+ , testGroup
+ "Check exposedModulesHeuristics output"
+ [ testSimple
+ "Default exposed modules"
+ exposedModulesHeuristics
+ (myLibModule NEL.:| [])
+ [ "src"
+ , "True"
+ , "True"
+ , "[]"
+ , "test-package"
+ , "True"
+ , "[]"
+ ]
+ , testSimple
+ "Contains exposed modules"
+ exposedModulesHeuristics
+ (NEL.fromList $ map fromString ["Foo", "Bar"])
+ [ "src"
+ , "True"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ ]
]
- , testSimple "Executable directory doesn't exist" exeOtherModulesHeuristics []
- [ "test-package"
- , "False"
+ , testGroup
+ "Check libOtherModulesHeuristics output"
+ [ testSimple
+ "Library directory exists"
+ libOtherModulesHeuristics
+ (map fromString ["Baz.Internal"])
+ [ "test-package"
+ , "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\", \"src/Baz/Internal.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ , "module Baz.Internal where"
+ ]
+ , testSimple
+ "Library directory doesn't exist"
+ libOtherModulesHeuristics
+ []
+ [ "test-package"
+ , "False"
+ ]
]
- ]
- , testGroup "Check testOtherModulesHeuristics output"
- [ testSimple "Test directory exists" testOtherModulesHeuristics
- (map fromString ["Foo", "Bar"])
- [ "test-package"
- , "True"
- , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
- , "module Foo where"
- , "module Bar where"
+ , testGroup
+ "Check exeOtherModulesHeuristics output"
+ [ testSimple
+ "Executable directory exists"
+ exeOtherModulesHeuristics
+ (map fromString ["Foo", "Bar"])
+ [ "test-package"
+ , "True"
+ , "[\"app/Main.hs\", \"app/Foo.hs\", \"app/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ ]
+ , testSimple
+ "Executable directory doesn't exist"
+ exeOtherModulesHeuristics
+ []
+ [ "test-package"
+ , "False"
+ ]
]
- , testSimple "Test directory doesn't exist" testOtherModulesHeuristics []
- [ "test-package"
- , "False"
+ , testGroup
+ "Check testOtherModulesHeuristics output"
+ [ testSimple
+ "Test directory exists"
+ testOtherModulesHeuristics
+ (map fromString ["Foo", "Bar"])
+ [ "test-package"
+ , "True"
+ , "[\"test/Main.hs\", \"test/Foo.hs\", \"test/Bar.hs\"]"
+ , "module Foo where"
+ , "module Bar where"
+ ]
+ , testSimple
+ "Test directory doesn't exist"
+ testOtherModulesHeuristics
+ []
+ [ "test-package"
+ , "False"
+ ]
]
- ]
- , testGroup "Check dependenciesHeuristics output"
- [ testSimple "base version bounds is correct"
- (fmap
- (flip foldl' anyVersion $ \a (Dependency n v _) ->
- if unPackageName n == "base" && baseVersion comp /= anyVersion
- then v else a)
- . (\x -> dependenciesHeuristics x "" pkgIx))
- (baseVersion comp)
+ , testGroup
+ "Check dependenciesHeuristics output"
+ [ testSimple
+ "base version bounds is correct"
+ ( fmap
+ ( flip foldl' anyVersion $ \a (Dependency n v _) ->
+ if unPackageName n == "base" && baseVersion comp /= anyVersion
+ then v
+ else a
+ )
+ . (\x -> dependenciesHeuristics x "" pkgIx)
+ )
+ (baseVersion comp)
+ [ "True"
+ , "[]"
+ ]
+ ]
+ , testSimple
+ "Check buildToolsHeuristics output"
+ (\a -> buildToolsHeuristics a "" defaultCabalVersion)
+ [mkStringyDep "happy:happy"]
[ "True"
- , "[]"
+ , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
]
- ]
- , testSimple "Check buildToolsHeuristics output" (\a -> buildToolsHeuristics a "" defaultCabalVersion)
- [mkStringyDep "happy:happy"]
- [ "True"
- , "[\"app/Main.hs\", \"src/Foo.hs\", \"src/bar.y\"]"
- ]
- , testSimple "Check otherExtsHeuristics output" (`otherExtsHeuristics` "")
- (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards])
- [ "True"
- , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
- , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
- , "\"{-# LANGUAGE RecordWildCards #-}\""
- ]
-
- , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0,1,0,0]) [""]
- , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""]
- , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""]
- , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""]
- , testSimple "Check categoryHeuristics output" categoryHeuristics "" [""]
- , testSimple "Check minimalHeuristics output" minimalHeuristics False [""]
- , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""]
- , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""]
- , testSimple "Check licenseHeuristics output" licenseHeuristics (SpecLicense $ Left SPDX.NONE) [""]
- ]
- , testGroup "Bool heuristics tests"
- [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False ""
- ]
+ , testSimple
+ "Check otherExtsHeuristics output"
+ (`otherExtsHeuristics` "")
+ (map EnableExtension [OverloadedStrings, LambdaCase, RankNTypes, RecordWildCards])
+ [ "True"
+ , "[\"src/Foo.hs\", \"src/Bar.hs\"]"
+ , "\"{-# LANGUAGE OverloadedStrings, LambdaCase #-}\n{-# LANGUAGE RankNTypes #-}\""
+ , "\"{-# LANGUAGE RecordWildCards #-}\""
+ ]
+ , testSimple "Check versionHeuristics output" versionHeuristics (mkVersion [0, 1, 0, 0]) [""]
+ , testSimple "Check homepageHeuristics output" homepageHeuristics "" [""]
+ , testSimple "Check synopsisHeuristics output" synopsisHeuristics "" [""]
+ , testSimple "Check testDirsHeuristics output" testDirsHeuristics ["test"] [""]
+ , testSimple "Check categoryHeuristics output" categoryHeuristics "" [""]
+ , testSimple "Check minimalHeuristics output" minimalHeuristics False [""]
+ , testSimple "Check overwriteHeuristics output" overwriteHeuristics False [""]
+ , testSimple "Check initializeTestSuiteHeuristics output" initializeTestSuiteHeuristics False [""]
+ , testSimple "Check licenseHeuristics output" licenseHeuristics (SpecLicense $ Left SPDX.NONE) [""]
+ ]
+ , testGroup
+ "Bool heuristics tests"
+ [ testBool "Check noCommentsHeuristics output" noCommentsHeuristics False ""
+ ]
]
testSimple
@@ -1274,132 +1401,192 @@ testGo
-> TestTree
testGo label f g h inputs = testCase label $
case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of
- Left x -> g x
+ Left x -> g x
Right x -> h x
cliListParserTests :: TestTree
-cliListParserTests = testGroup "cli list parser"
- [ testCase "Single extraSrc" $ do
- flags <- runParserTest ["-x", "Generated.hs"]
- flags @?= emptyFlags
- { extraSrc = Flag ["Generated.hs"]
- }
- , testCase "Multiple extraSrc" $ do
- flags <- runParserTest ["-x", "Gen1.hs", "-x", "Gen2.hs", "-x", "Gen3.hs"]
- flags @?= emptyFlags
- { extraSrc = Flag ["Gen1.hs", "Gen2.hs", "Gen3.hs"]
- }
- , testCase "Single extraDoc" $ do
- flags <- runParserTest ["--extra-doc-file", "README"]
- flags @?= emptyFlags
- { extraDoc = Flag $ ["README"]
- }
- , testCase "Multiple extraDoc" $ do
- flags <- runParserTest ["--extra-doc-file", "README",
- "--extra-doc-file", "CHANGELOG",
- "--extra-doc-file", "LICENSE"]
- flags @?= emptyFlags
- { extraDoc = Flag $ map fromString ["README", "CHANGELOG", "LICENSE"]
- }
- , testCase "Single exposedModules" $ do
- flags <- runParserTest ["-o", "Test"]
- flags @?= emptyFlags
- { exposedModules = Flag $ map fromString ["Test"]
- }
- , testCase "Multiple exposedModules" $ do
- flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
- flags @?= emptyFlags
- { exposedModules = Flag $ map fromString ["Test", "Test2", "Test3"]
- }
- -- there is no otherModules cli flag
- -- , testCase "Single otherModules" $ do
- -- flags <- runParserTest ["-o", "Test"]
- -- flags @?= dummyFlags
- -- { otherModules = Flag $ map fromString ["Test"]
- -- }
- -- , testCase "Multiple otherModules" $ do
- -- flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
- -- flags @?= dummyFlags
- -- { otherModules = Flag $ map fromString ["Test", "Test2", "Test3"]
- -- }
- , testCase "Single otherExts" $ do
- flags <- runParserTest ["--extension", "OverloadedStrings"]
- flags @?= emptyFlags
- { otherExts = Flag [EnableExtension OverloadedStrings]
- }
- , testCase "Multiple otherExts" $ do
- flags <- runParserTest ["--extension", "OverloadedStrings",
- "--extension", "FlexibleInstances",
- "--extension", "FlexibleContexts"]
- flags @?= emptyFlags
- { otherExts = Flag [EnableExtension OverloadedStrings,
- EnableExtension FlexibleInstances,
- EnableExtension FlexibleContexts]
- }
- , testCase "Single dependency" $ do
- flags <- runParserTest ["-d", "base"]
- flags @?= emptyFlags
- { dependencies = Flag [mkStringyDep "base"]
- }
- , testCase "Multiple dependency flags" $ do
- flags <- runParserTest ["-d", "base", "-d", "vector"]
- flags @?= emptyFlags
- { dependencies = Flag $ fmap mkStringyDep ["base", "vector"]
- }
- , testCase "Comma separated list of dependencies" $ do
- flags <- runParserTest ["-d", "base,vector"]
- flags @?= emptyFlags
- { dependencies = Flag $ fmap mkStringyDep ["base", "vector"]
- }
- , testCase "Single applicationDirs" $ do
- flags <- runParserTest ["--application-dir", "app"]
- flags @?= emptyFlags
- { applicationDirs = Flag ["app"]
- }
- , testCase "Multiple applicationDirs" $ do
- flags <- runParserTest ["--application-dir", "app",
- "--application-dir", "exe",
- "--application-dir", "srcapp"]
- flags @?= emptyFlags
- { applicationDirs = Flag ["app", "exe", "srcapp"]
- }
- , testCase "Single sourceDirs" $ do
- flags <- runParserTest ["--source-dir", "src"]
- flags @?= emptyFlags
- { sourceDirs = Flag ["src"]
- }
- , testCase "Multiple sourceDirs" $ do
- flags <- runParserTest ["--source-dir", "src",
- "--source-dir", "lib",
- "--source-dir", "sources"]
- flags @?= emptyFlags
- { sourceDirs = Flag ["src", "lib", "sources"]
- }
- , testCase "Single buildTools" $ do
- flags <- runParserTest ["--build-tool", "happy"]
- flags @?= emptyFlags
- { buildTools = Flag ["happy"]
- }
- , testCase "Multiple buildTools" $ do
- flags <- runParserTest ["--build-tool", "happy",
- "--build-tool", "alex",
- "--build-tool", "make"]
- flags @?= emptyFlags
- { buildTools = Flag ["happy", "alex", "make"]
- }
- , testCase "Single testDirs" $ do
- flags <- runParserTest ["--test-dir", "test"]
- flags @?= emptyFlags
- { testDirs = Flag ["test"]
- }
- , testCase "Multiple testDirs" $ do
- flags <- runParserTest ["--test-dir", "test",
- "--test-dir", "tests",
- "--test-dir", "testsuite"]
- flags @?= emptyFlags
- { testDirs = Flag ["test", "tests", "testsuite"]
- }
- ]
+cliListParserTests =
+ testGroup
+ "cli list parser"
+ [ testCase "Single extraSrc" $ do
+ flags <- runParserTest ["-x", "Generated.hs"]
+ flags
+ @?= emptyFlags
+ { extraSrc = Flag ["Generated.hs"]
+ }
+ , testCase "Multiple extraSrc" $ do
+ flags <- runParserTest ["-x", "Gen1.hs", "-x", "Gen2.hs", "-x", "Gen3.hs"]
+ flags
+ @?= emptyFlags
+ { extraSrc = Flag ["Gen1.hs", "Gen2.hs", "Gen3.hs"]
+ }
+ , testCase "Single extraDoc" $ do
+ flags <- runParserTest ["--extra-doc-file", "README"]
+ flags
+ @?= emptyFlags
+ { extraDoc = Flag $ ["README"]
+ }
+ , testCase "Multiple extraDoc" $ do
+ flags <-
+ runParserTest
+ [ "--extra-doc-file"
+ , "README"
+ , "--extra-doc-file"
+ , "CHANGELOG"
+ , "--extra-doc-file"
+ , "LICENSE"
+ ]
+ flags
+ @?= emptyFlags
+ { extraDoc = Flag $ map fromString ["README", "CHANGELOG", "LICENSE"]
+ }
+ , testCase "Single exposedModules" $ do
+ flags <- runParserTest ["-o", "Test"]
+ flags
+ @?= emptyFlags
+ { exposedModules = Flag $ map fromString ["Test"]
+ }
+ , testCase "Multiple exposedModules" $ do
+ flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
+ flags
+ @?= emptyFlags
+ { exposedModules = Flag $ map fromString ["Test", "Test2", "Test3"]
+ }
+ , -- there is no otherModules cli flag
+ -- , testCase "Single otherModules" $ do
+ -- flags <- runParserTest ["-o", "Test"]
+ -- flags @?= dummyFlags
+ -- { otherModules = Flag $ map fromString ["Test"]
+ -- }
+ -- , testCase "Multiple otherModules" $ do
+ -- flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
+ -- flags @?= dummyFlags
+ -- { otherModules = Flag $ map fromString ["Test", "Test2", "Test3"]
+ -- }
+ testCase "Single otherExts" $ do
+ flags <- runParserTest ["--extension", "OverloadedStrings"]
+ flags
+ @?= emptyFlags
+ { otherExts = Flag [EnableExtension OverloadedStrings]
+ }
+ , testCase "Multiple otherExts" $ do
+ flags <-
+ runParserTest
+ [ "--extension"
+ , "OverloadedStrings"
+ , "--extension"
+ , "FlexibleInstances"
+ , "--extension"
+ , "FlexibleContexts"
+ ]
+ flags
+ @?= emptyFlags
+ { otherExts =
+ Flag
+ [ EnableExtension OverloadedStrings
+ , EnableExtension FlexibleInstances
+ , EnableExtension FlexibleContexts
+ ]
+ }
+ , testCase "Single dependency" $ do
+ flags <- runParserTest ["-d", "base"]
+ flags
+ @?= emptyFlags
+ { dependencies = Flag [mkStringyDep "base"]
+ }
+ , testCase "Multiple dependency flags" $ do
+ flags <- runParserTest ["-d", "base", "-d", "vector"]
+ flags
+ @?= emptyFlags
+ { dependencies = Flag $ fmap mkStringyDep ["base", "vector"]
+ }
+ , testCase "Comma separated list of dependencies" $ do
+ flags <- runParserTest ["-d", "base,vector"]
+ flags
+ @?= emptyFlags
+ { dependencies = Flag $ fmap mkStringyDep ["base", "vector"]
+ }
+ , testCase "Single applicationDirs" $ do
+ flags <- runParserTest ["--application-dir", "app"]
+ flags
+ @?= emptyFlags
+ { applicationDirs = Flag ["app"]
+ }
+ , testCase "Multiple applicationDirs" $ do
+ flags <-
+ runParserTest
+ [ "--application-dir"
+ , "app"
+ , "--application-dir"
+ , "exe"
+ , "--application-dir"
+ , "srcapp"
+ ]
+ flags
+ @?= emptyFlags
+ { applicationDirs = Flag ["app", "exe", "srcapp"]
+ }
+ , testCase "Single sourceDirs" $ do
+ flags <- runParserTest ["--source-dir", "src"]
+ flags
+ @?= emptyFlags
+ { sourceDirs = Flag ["src"]
+ }
+ , testCase "Multiple sourceDirs" $ do
+ flags <-
+ runParserTest
+ [ "--source-dir"
+ , "src"
+ , "--source-dir"
+ , "lib"
+ , "--source-dir"
+ , "sources"
+ ]
+ flags
+ @?= emptyFlags
+ { sourceDirs = Flag ["src", "lib", "sources"]
+ }
+ , testCase "Single buildTools" $ do
+ flags <- runParserTest ["--build-tool", "happy"]
+ flags
+ @?= emptyFlags
+ { buildTools = Flag ["happy"]
+ }
+ , testCase "Multiple buildTools" $ do
+ flags <-
+ runParserTest
+ [ "--build-tool"
+ , "happy"
+ , "--build-tool"
+ , "alex"
+ , "--build-tool"
+ , "make"
+ ]
+ flags
+ @?= emptyFlags
+ { buildTools = Flag ["happy", "alex", "make"]
+ }
+ , testCase "Single testDirs" $ do
+ flags <- runParserTest ["--test-dir", "test"]
+ flags
+ @?= emptyFlags
+ { testDirs = Flag ["test"]
+ }
+ , testCase "Multiple testDirs" $ do
+ flags <-
+ runParserTest
+ [ "--test-dir"
+ , "test"
+ , "--test-dir"
+ , "tests"
+ , "--test-dir"
+ , "testsuite"
+ ]
+ flags
+ @?= emptyFlags
+ { testDirs = Flag ["test", "tests", "testsuite"]
+ }
+ ]
where
assumeAllParse :: CommandParse (InitFlags -> InitFlags, [String]) -> IO InitFlags
assumeAllParse = \case
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs
index 2100859e67860d17401d765481d016685bc7701e..13a12ba0827907bfd272af220f1351a6c331be6e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Simple.hs
@@ -1,133 +1,147 @@
module UnitTests.Distribution.Client.Init.Simple
-( tests
-) where
+ ( tests
+ ) where
-
-import Prelude as P
import Test.Tasty
import Test.Tasty.HUnit
+import Prelude as P
import Distribution.Client.Init.Defaults
import Distribution.Client.Init.Simple
import Distribution.Client.Init.Types
-
import Data.List.NonEmpty hiding (zip)
import Distribution.Client.Types
import Distribution.Simple.PackageIndex hiding (fromList)
import Distribution.Types.PackageName
import Distribution.Verbosity
-
-import UnitTests.Distribution.Client.Init.Utils
-import Distribution.Simple.Setup
import qualified Data.List.NonEmpty as NEL
-import Distribution.Types.Dependency
-import Distribution.Client.Init.Utils (mkPackageNameDep, getBaseDep)
import qualified Data.Set as Set
import Distribution.Client.Init.FlagExtractors (getCabalVersionNoPrompt)
+import Distribution.Client.Init.Utils (getBaseDep, mkPackageNameDep)
+import Distribution.Simple.Setup
+import Distribution.Types.Dependency
+import UnitTests.Distribution.Client.Init.Utils
tests
- :: Verbosity
- -> InitFlags
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> TestTree
-tests v _initFlags pkgIx srcDb = testGroup "Distribution.Client.Init.Simple.hs"
+ :: Verbosity
+ -> InitFlags
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> TestTree
+tests v _initFlags pkgIx srcDb =
+ testGroup
+ "Distribution.Client.Init.Simple.hs"
[ simpleCreateProjectTests v pkgIx srcDb pkgName
]
where
pkgName = mkPackageName "simple-test"
simpleCreateProjectTests
- :: Verbosity
- -> InstalledPackageIndex
- -> SourcePackageDb
- -> PackageName
- -> TestTree
+ :: Verbosity
+ -> InstalledPackageIndex
+ -> SourcePackageDb
+ -> PackageName
+ -> TestTree
simpleCreateProjectTests v pkgIx srcDb pkgName =
- testGroup "Simple createProject tests"
+ testGroup
+ "Simple createProject tests"
[ testCase "Simple lib createProject - no tests" $ do
- let inputs = fromList
- [ "1" -- package type: Library
- , "simple.test" -- package dir: used for determining package name;
- -- note that . will be replaced with - in a sanitization step,
- -- and we get the expected "simple-test" -- regression test for #8404
- , "simple.test" -- package dir again: the prompt monad needs extra parameter for every
- -- IO call, and this one will be used for canonicalizePath,
- -- which is called as a part of sanitization
- , "n" -- no tests
- ]
-
- flags = emptyFlags { packageType = Flag Library }
- settings = ProjectSettings
- (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)
- (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)
- Nothing Nothing
-
- case _runPrompt (createProject v pkgIx srcDb flags) inputs of
- Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e
- Right (settings', _) -> settings @=? settings'
-
+ let inputs =
+ fromList
+ [ "1" -- package type: Library
+ , "simple.test" -- package dir: used for determining package name;
+ -- note that . will be replaced with - in a sanitization step,
+ -- and we get the expected "simple-test" -- regression test for #8404
+ , "simple.test" -- package dir again: the prompt monad needs extra parameter for every
+ -- IO call, and this one will be used for canonicalizePath,
+ -- which is called as a part of sanitization
+ , "n" -- no tests
+ ]
+
+ flags = emptyFlags{packageType = Flag Library}
+ settings =
+ ProjectSettings
+ (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)
+ (simplePkgDesc pkgName)
+ (Just $ simpleLibTarget baseDep)
+ Nothing
+ Nothing
+
+ case _runPrompt (createProject v pkgIx srcDb flags) inputs of
+ Left e -> assertFailure $ "Failed to create simple lib project: " ++ show e
+ Right (settings', _) -> settings @=? settings'
, testCase "Simple lib createProject - with tests" $ do
- let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"]
- flags = emptyFlags { packageType = Flag Library }
- settings = ProjectSettings
- (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)
- (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)
- Nothing (Just $ simpleTestTarget (Just pkgName) baseDep)
-
- case _runPrompt (createProject v pkgIx srcDb flags) inputs of
- Left e -> assertFailure $ "Failed to create simple lib (with tests)project: " ++ show e
- Right (settings', _) -> settings @=? settings'
-
+ let inputs = fromList ["1", "simple-test", "simple-test", "y", "1"]
+ flags = emptyFlags{packageType = Flag Library}
+ settings =
+ ProjectSettings
+ (WriteOpts False False False v "/home/test/1" Library pkgName defaultCabalVersion)
+ (simplePkgDesc pkgName)
+ (Just $ simpleLibTarget baseDep)
+ Nothing
+ (Just $ simpleTestTarget (Just pkgName) baseDep)
+
+ case _runPrompt (createProject v pkgIx srcDb flags) inputs of
+ Left e -> assertFailure $ "Failed to create simple lib (with tests)project: " ++ show e
+ Right (settings', _) -> settings @=? settings'
, testCase "Simple exe createProject" $ do
- let inputs = fromList ["2", "simple-test", "simple-test"]
- flags = emptyFlags { packageType = Flag Executable }
- settings = ProjectSettings
- (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion)
- (simplePkgDesc pkgName) Nothing
- (Just $ simpleExeTarget Nothing baseDep) Nothing
-
- case _runPrompt (createProject v pkgIx srcDb flags) inputs of
- Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e
- Right (settings', _) -> settings @=? settings'
-
+ let inputs = fromList ["2", "simple-test", "simple-test"]
+ flags = emptyFlags{packageType = Flag Executable}
+ settings =
+ ProjectSettings
+ (WriteOpts False False False v "/home/test/2" Executable pkgName defaultCabalVersion)
+ (simplePkgDesc pkgName)
+ Nothing
+ (Just $ simpleExeTarget Nothing baseDep)
+ Nothing
+
+ case _runPrompt (createProject v pkgIx srcDb flags) inputs of
+ Left e -> assertFailure $ "Failed to create simple exe project: " ++ show e
+ Right (settings', _) -> settings @=? settings'
, testCase "Simple lib+exe createProject - no tests" $ do
- let inputs = fromList ["2", "simple-test", "simple-test", "n"]
- flags = emptyFlags { packageType = Flag LibraryAndExecutable }
- settings = ProjectSettings
- (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)
- (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)
- (Just $ simpleExeTarget (Just pkgName) baseDep) Nothing
-
- case _runPrompt (createProject v pkgIx srcDb flags) inputs of
- Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e
- Right (settings', _) -> settings @=? settings'
+ let inputs = fromList ["2", "simple-test", "simple-test", "n"]
+ flags = emptyFlags{packageType = Flag LibraryAndExecutable}
+ settings =
+ ProjectSettings
+ (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)
+ (simplePkgDesc pkgName)
+ (Just $ simpleLibTarget baseDep)
+ (Just $ simpleExeTarget (Just pkgName) baseDep)
+ Nothing
+
+ case _runPrompt (createProject v pkgIx srcDb flags) inputs of
+ Left e -> assertFailure $ "Failed to create simple lib+exe project: " ++ show e
+ Right (settings', _) -> settings @=? settings'
, testCase "Simple lib+exe createProject - with tests" $ do
- let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"]
- flags = emptyFlags { packageType = Flag LibraryAndExecutable }
- settings = ProjectSettings
- (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)
- (simplePkgDesc pkgName) (Just $ simpleLibTarget baseDep)
- (Just $ simpleExeTarget (Just pkgName) baseDep)
- (Just $ simpleTestTarget (Just pkgName) baseDep)
-
- case _runPrompt (createProject v pkgIx srcDb flags) inputs of
- Left e -> assertFailure $ "Failed to create simple lib+exe (with tests) project: " ++ show e
- Right (settings', _) -> settings @=? settings'
-
+ let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"]
+ flags = emptyFlags{packageType = Flag LibraryAndExecutable}
+ settings =
+ ProjectSettings
+ (WriteOpts False False False v "/home/test/2" LibraryAndExecutable pkgName defaultCabalVersion)
+ (simplePkgDesc pkgName)
+ (Just $ simpleLibTarget baseDep)
+ (Just $ simpleExeTarget (Just pkgName) baseDep)
+ (Just $ simpleTestTarget (Just pkgName) baseDep)
+
+ case _runPrompt (createProject v pkgIx srcDb flags) inputs of
+ Left e -> assertFailure $ "Failed to create simple lib+exe (with tests) project: " ++ show e
+ Right (settings', _) -> settings @=? settings'
, testCase "Simple standalone tests" $ do
- let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"]
- flags = emptyFlags { packageType = Flag TestSuite }
- settings = ProjectSettings
- (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion)
- (simplePkgDesc pkgName) Nothing Nothing
- (Just $ simpleTestTarget Nothing baseDep)
-
- case _runPrompt (createProject v pkgIx srcDb flags) inputs of
- Left e -> assertFailure $ "Failed to create simple standalone test project: " ++ show e
- Right (settings', _) -> settings @=? settings'
+ let inputs = fromList ["2", "simple-test", "simple-test", "y", "1"]
+ flags = emptyFlags{packageType = Flag TestSuite}
+ settings =
+ ProjectSettings
+ (WriteOpts False False False v "/home/test/2" TestSuite pkgName defaultCabalVersion)
+ (simplePkgDesc pkgName)
+ Nothing
+ Nothing
+ (Just $ simpleTestTarget Nothing baseDep)
+
+ case _runPrompt (createProject v pkgIx srcDb flags) inputs of
+ Left e -> assertFailure $ "Failed to create simple standalone test project: " ++ show e
+ Right (settings', _) -> settings @=? settings'
]
where
baseDep = case _runPrompt (getBaseDep pkgIx emptyFlags) $ fromList [] of
@@ -142,32 +156,49 @@ mkPkgDep Nothing = []
mkPkgDep (Just pn) = [mkPackageNameDep pn]
simplePkgDesc :: PackageName -> PkgDescription
-simplePkgDesc pkgName = PkgDescription
+simplePkgDesc pkgName =
+ PkgDescription
defaultCabalVersion
pkgName
defaultVersion
(defaultLicense $ getCabalVersionNoPrompt dummyFlags)
- "" "" "" "" ""
+ ""
+ ""
+ ""
+ ""
+ ""
mempty
(Just $ Set.singleton defaultChangelog)
simpleLibTarget :: [Dependency] -> LibTarget
-simpleLibTarget baseDep = LibTarget
+simpleLibTarget baseDep =
+ LibTarget
[defaultSourceDir]
defaultLanguage
(myLibModule NEL.:| [])
- [] [] baseDep []
+ []
+ []
+ baseDep
+ []
simpleExeTarget :: Maybe PackageName -> [Dependency] -> ExeTarget
-simpleExeTarget pn baseDep = ExeTarget
+simpleExeTarget pn baseDep =
+ ExeTarget
defaultMainIs
[defaultApplicationDir]
defaultLanguage
- [] [] (baseDep ++ mkPkgDep pn) []
+ []
+ []
+ (baseDep ++ mkPkgDep pn)
+ []
simpleTestTarget :: Maybe PackageName -> [Dependency] -> TestTarget
-simpleTestTarget pn baseDep = TestTarget
+simpleTestTarget pn baseDep =
+ TestTarget
defaultMainIs
[defaultTestDir]
defaultLanguage
- [] [] (baseDep ++ mkPkgDep pn) []
+ []
+ []
+ (baseDep ++ mkPkgDep pn)
+ []
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs
index 0729e507765914551f19bdf01d1ea46ac7fa2517..e5ed0748a458fc13e9d0ac5739271048772c85a6 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Init/Utils.hs
@@ -1,75 +1,74 @@
module UnitTests.Distribution.Client.Init.Utils
-( dummyFlags
-, emptyFlags
-, mkLicense
-, baseVersion
-, mangleBaseDep
-, (@?!)
-, (@!?)
-) where
-
+ ( dummyFlags
+ , emptyFlags
+ , mkLicense
+ , baseVersion
+ , mangleBaseDep
+ , (@?!)
+ , (@!?)
+ ) where
import Distribution.Client.Init.Types
import qualified Distribution.SPDX as SPDX
import Distribution.CabalSpecVersion
+import Distribution.FieldGrammar.Newtypes
+import Distribution.Pretty
+import Distribution.Simple.Compiler
import Distribution.Simple.Setup
+import Distribution.Types.Dependency
import Distribution.Types.PackageName
import Distribution.Types.Version
+import Distribution.Types.VersionRange
import Language.Haskell.Extension
import Test.Tasty.HUnit
-import Distribution.Types.Dependency
-import Distribution.Types.VersionRange
-import Distribution.Simple.Compiler
-import Distribution.Pretty
-import Distribution.FieldGrammar.Newtypes
-
-- -------------------------------------------------------------------- --
-- Test flags
dummyFlags :: InitFlags
-dummyFlags = emptyFlags
- { noComments = Flag True
- , packageName = Flag (mkPackageName "QuxPackage")
- , version = Flag (mkVersion [4,2,6])
- , cabalVersion = Flag CabalSpecV2_2
- , license = Flag $ SpecLicense $ Left $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing
- , author = Flag "Foobar"
- , email = Flag "foobar@qux.com"
- , homepage = Flag "qux.com"
- , synopsis = Flag "We are Qux, and this is our package"
- , category = Flag "Control"
- , language = Flag Haskell98
- , initializeTestSuite = Flag True
- , sourceDirs = Flag ["quxSrc"]
- , testDirs = Flag ["quxTest"]
- , applicationDirs = Flag ["quxApp"]
- }
+dummyFlags =
+ emptyFlags
+ { noComments = Flag True
+ , packageName = Flag (mkPackageName "QuxPackage")
+ , version = Flag (mkVersion [4, 2, 6])
+ , cabalVersion = Flag CabalSpecV2_2
+ , license = Flag $ SpecLicense $ Left $ SPDX.License $ SPDX.ELicense (SPDX.ELicenseId SPDX.MIT) Nothing
+ , author = Flag "Foobar"
+ , email = Flag "foobar@qux.com"
+ , homepage = Flag "qux.com"
+ , synopsis = Flag "We are Qux, and this is our package"
+ , category = Flag "Control"
+ , language = Flag Haskell98
+ , initializeTestSuite = Flag True
+ , sourceDirs = Flag ["quxSrc"]
+ , testDirs = Flag ["quxTest"]
+ , applicationDirs = Flag ["quxApp"]
+ }
emptyFlags :: InitFlags
emptyFlags = mempty
-- | Retrieves the proper base version based on the GHC version
baseVersion :: Compiler -> VersionRange
-baseVersion Compiler {compilerId = CompilerId GHC ver} =
- let ghcToBase = baseVersion' . prettyShow $ ver in
- if null ghcToBase
- then anyVersion
- else majorBoundVersion $ mkVersion ghcToBase
+baseVersion Compiler{compilerId = CompilerId GHC ver} =
+ let ghcToBase = baseVersion' . prettyShow $ ver
+ in if null ghcToBase
+ then anyVersion
+ else majorBoundVersion $ mkVersion ghcToBase
baseVersion _ = anyVersion
baseVersion' :: String -> [Int]
-baseVersion' "9.0.1" = [4,15,0,0]
-baseVersion' "8.10.4" = [4,14,1,0]
-baseVersion' "8.8.4" = [4,13,0,0]
-baseVersion' "8.6.5" = [4,12,0,0]
-baseVersion' "8.4.4" = [4,11,1,0]
-baseVersion' "8.2.2" = [4,10,1,0]
-baseVersion' "7.10.3" = [4,9,0,0]
-baseVersion' "7.8.4" = [4,8,0,0]
-baseVersion' "7.6.3" = [4,7,0,0]
+baseVersion' "9.0.1" = [4, 15, 0, 0]
+baseVersion' "8.10.4" = [4, 14, 1, 0]
+baseVersion' "8.8.4" = [4, 13, 0, 0]
+baseVersion' "8.6.5" = [4, 12, 0, 0]
+baseVersion' "8.4.4" = [4, 11, 1, 0]
+baseVersion' "8.2.2" = [4, 10, 1, 0]
+baseVersion' "7.10.3" = [4, 9, 0, 0]
+baseVersion' "7.8.4" = [4, 8, 0, 0]
+baseVersion' "7.6.3" = [4, 7, 0, 0]
baseVersion' _ = []
-- -------------------------------------------------------------------- --
@@ -80,11 +79,11 @@ mkLicense lid = SPDX.License (SPDX.ELicense (SPDX.ELicenseId lid) Nothing)
mangleBaseDep :: a -> (a -> [Dependency]) -> [Dependency]
mangleBaseDep target f =
- [ if unPackageName x == "base"
- then Dependency x anyVersion z
- else dep
- | dep@(Dependency x _ z) <- f target
- ]
+ [ if unPackageName x == "base"
+ then Dependency x anyVersion z
+ else dep
+ | dep@(Dependency x _ z) <- f target
+ ]
infix 1 @?!, @!?
@@ -94,9 +93,10 @@ infix 1 @?!, @!?
=> a
-> a
-> Assertion
-actual @?! unexpected = assertBool
- ("unexpected: " ++ show unexpected)
- (actual /= unexpected)
+actual @?! unexpected =
+ assertBool
+ ("unexpected: " ++ show unexpected)
+ (actual /= unexpected)
-- | Just like @'@=?'@, except it checks for difference rather than equality.
(@!?)
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
index 34c4d54d7e8087a351826f2a357444a599b126d5..b708ea80302d6654a6bd615a6a40286629e85771 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/InstallPlan.hs
@@ -1,105 +1,114 @@
+{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoMonoLocalBinds #-}
-{-# LANGUAGE ConstraintKinds #-}
+
module UnitTests.Distribution.Client.InstallPlan (tests) where
import Distribution.Client.Compat.Prelude
import qualified Prelude as Unsafe (tail)
-import Distribution.Package
-import Distribution.Version
+import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)
import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan (GenericInstallPlan, IsUnit)
+import Distribution.Client.JobControl
+import Distribution.Client.Types
+import Distribution.Compat.Graph (IsNode (..))
import qualified Distribution.Compat.Graph as Graph
-import Distribution.Compat.Graph (IsNode(..))
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.PackageFixedDeps
+import Distribution.Package
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Client.Types
-import Distribution.Client.JobControl
+import Distribution.Solver.Types.PackageFixedDeps
+import Distribution.Solver.Types.Settings
+import Distribution.Version
-import Data.Graph
+import Control.Concurrent (threadDelay)
+import Control.Monad (replicateM)
import Data.Array hiding (index)
+import Data.Graph
+import Data.IORef
import Data.List ()
-import Control.Monad (replicateM)
import qualified Data.Map as Map
import qualified Data.Set as Set
-import Data.IORef
-import Control.Concurrent (threadDelay)
import System.Random
import Test.QuickCheck
import Test.Tasty
import Test.Tasty.QuickCheck
-
tests :: [TestTree]
tests =
[ testProperty "reverseTopologicalOrder" prop_reverseTopologicalOrder
- , testProperty "executionOrder" prop_executionOrder
- , testProperty "execute serial" prop_execute_serial
- , testProperty "execute parallel" prop_execute_parallel
- , testProperty "execute/executionOrder" prop_execute_vs_executionOrder
+ , testProperty "executionOrder" prop_executionOrder
+ , testProperty "execute serial" prop_execute_serial
+ , testProperty "execute parallel" prop_execute_parallel
+ , testProperty "execute/executionOrder" prop_execute_vs_executionOrder
]
prop_reverseTopologicalOrder :: TestInstallPlan -> Bool
prop_reverseTopologicalOrder (TestInstallPlan plan graph toVertex _) =
- isReverseTopologicalOrder
- graph
- (map (toVertex . installedUnitId)
- (InstallPlan.reverseTopologicalOrder plan))
+ isReverseTopologicalOrder
+ graph
+ ( map
+ (toVertex . installedUnitId)
+ (InstallPlan.reverseTopologicalOrder plan)
+ )
-- | @executionOrder@ is in reverse topological order
prop_executionOrder :: TestInstallPlan -> Bool
prop_executionOrder (TestInstallPlan plan graph toVertex _) =
- isReversePartialTopologicalOrder graph (map toVertex pkgids)
- && allConfiguredPackages plan == Set.fromList pkgids
+ isReversePartialTopologicalOrder graph (map toVertex pkgids)
+ && allConfiguredPackages plan == Set.fromList pkgids
where
pkgids = map installedUnitId (InstallPlan.executionOrder plan)
-- | @execute@ is in reverse topological order
prop_execute_serial :: TestInstallPlan -> Property
prop_execute_serial tplan@(TestInstallPlan plan graph toVertex _) =
- ioProperty $ do
- jobCtl <- newSerialJobControl
- pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
- return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)
- && allConfiguredPackages plan == Set.fromList pkgids
+ ioProperty $ do
+ jobCtl <- newSerialJobControl
+ pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
+ return $
+ isReversePartialTopologicalOrder graph (map toVertex pkgids)
+ && allConfiguredPackages plan == Set.fromList pkgids
prop_execute_parallel :: Positive (Small Int) -> TestInstallPlan -> Property
-prop_execute_parallel (Positive (Small maxJobLimit))
- tplan@(TestInstallPlan plan graph toVertex _) =
+prop_execute_parallel
+ (Positive (Small maxJobLimit))
+ tplan@(TestInstallPlan plan graph toVertex _) =
ioProperty $ do
jobCtl <- newParallelJobControl maxJobLimit
pkgids <- executeTestInstallPlan jobCtl tplan $ \_ -> do
- delay <- randomRIO (0,1000)
- threadDelay delay
- return $ isReversePartialTopologicalOrder graph (map toVertex pkgids)
- && allConfiguredPackages plan == Set.fromList pkgids
+ delay <- randomRIO (0, 1000)
+ threadDelay delay
+ return $
+ isReversePartialTopologicalOrder graph (map toVertex pkgids)
+ && allConfiguredPackages plan == Set.fromList pkgids
-- | return the packages that are visited by execute, in order.
-executeTestInstallPlan :: JobControl IO (UnitId, Either () ())
- -> TestInstallPlan
- -> (TestPkg -> IO ())
- -> IO [UnitId]
+executeTestInstallPlan
+ :: JobControl IO (UnitId, Either () ())
+ -> TestInstallPlan
+ -> (TestPkg -> IO ())
+ -> IO [UnitId]
executeTestInstallPlan jobCtl (TestInstallPlan plan _ _ _) visit = do
- resultsRef <- newIORef []
- _ <- InstallPlan.execute jobCtl False (const ())
- plan $ \(ReadyPackage pkg) -> do
- visit pkg
- atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg:pkgs, ())
- return (Right ())
- fmap reverse (readIORef resultsRef)
+ resultsRef <- newIORef []
+ _ <- InstallPlan.execute
+ jobCtl
+ False
+ (const ())
+ plan
+ $ \(ReadyPackage pkg) -> do
+ visit pkg
+ atomicModifyIORef resultsRef $ \pkgs -> (installedUnitId pkg : pkgs, ())
+ return (Right ())
+ fmap reverse (readIORef resultsRef)
-- | @execute@ visits the packages in the same order as @executionOrder@
prop_execute_vs_executionOrder :: TestInstallPlan -> Property
prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =
- ioProperty $ do
- jobCtl <- newSerialJobControl
- pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
- let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)
- return (pkgids == pkgids')
-
+ ioProperty $ do
+ jobCtl <- newSerialJobControl
+ pkgids <- executeTestInstallPlan jobCtl tplan (\_ -> return ())
+ let pkgids' = map installedUnitId (InstallPlan.executionOrder plan)
+ return (pkgids == pkgids')
--------------------------
-- Property helper utils
@@ -111,40 +120,49 @@ prop_execute_vs_executionOrder tplan@(TestInstallPlan plan _ _ _) =
--
-- A reverse topological ordering is the swapped: for every directed edge uv
-- from vertex u to vertex v, v comes before u in the ordering.
---
isReverseTopologicalOrder :: Graph -> [Vertex] -> Bool
isReverseTopologicalOrder g vs =
- and [ ixs ! u > ixs ! v
- | let ixs = array (bounds g) (zip vs [0::Int ..])
- , (u,v) <- edges g ]
+ and
+ [ ixs ! u > ixs ! v
+ | let ixs = array (bounds g) (zip vs [0 :: Int ..])
+ , (u, v) <- edges g
+ ]
isReversePartialTopologicalOrder :: Graph -> [Vertex] -> Bool
isReversePartialTopologicalOrder g vs =
- and [ case (ixs ! u, ixs ! v) of
- (Just ixu, Just ixv) -> ixu > ixv
- _ -> True
- | let ixs = array (bounds g)
- (zip (range (bounds g)) (repeat Nothing) ++
- zip vs (map Just [0::Int ..]))
- , (u,v) <- edges g ]
-
-allConfiguredPackages :: HasUnitId srcpkg
- => GenericInstallPlan ipkg srcpkg -> Set UnitId
+ and
+ [ case (ixs ! u, ixs ! v) of
+ (Just ixu, Just ixv) -> ixu > ixv
+ _ -> True
+ | let ixs =
+ array
+ (bounds g)
+ ( zip (range (bounds g)) (repeat Nothing)
+ ++ zip vs (map Just [0 :: Int ..])
+ )
+ , (u, v) <- edges g
+ ]
+
+allConfiguredPackages
+ :: HasUnitId srcpkg
+ => GenericInstallPlan ipkg srcpkg
+ -> Set UnitId
allConfiguredPackages plan =
- Set.fromList
- [ installedUnitId pkg
- | InstallPlan.Configured pkg <- InstallPlan.toList plan ]
-
+ Set.fromList
+ [ installedUnitId pkg
+ | InstallPlan.Configured pkg <- InstallPlan.toList plan
+ ]
--------------------
-- Test generators
--
-data TestInstallPlan = TestInstallPlan
- (GenericInstallPlan TestPkg TestPkg)
- Graph
- (UnitId -> Vertex)
- (Vertex -> UnitId)
+data TestInstallPlan
+ = TestInstallPlan
+ (GenericInstallPlan TestPkg TestPkg)
+ Graph
+ (UnitId -> Vertex)
+ (Vertex -> UnitId)
instance Show TestInstallPlan where
show (TestInstallPlan plan _ _ _) = InstallPlan.showInstallPlan plan
@@ -157,7 +175,6 @@ instance IsNode TestPkg where
nodeKey (TestPkg _ ipkgid _) = ipkgid
nodeNeighbors (TestPkg _ _ deps) = deps
-
instance Package TestPkg where
packageId (TestPkg pkgid _ _) = pkgid
@@ -175,71 +192,82 @@ instance Arbitrary TestInstallPlan where
arbitraryTestInstallPlan :: Gen TestInstallPlan
arbitraryTestInstallPlan = do
- graph <- arbitraryAcyclicGraph
- (choose (2,5))
- (choose (1,5))
- 0.3
+ graph <-
+ arbitraryAcyclicGraph
+ (choose (2, 5))
+ (choose (1, 5))
+ 0.3
- plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph
+ plan <- arbitraryInstallPlan mkTestPkg mkTestPkg 0.5 graph
- let toVertexMap = Map.fromList [ (mkUnitIdV v, v) | v <- vertices graph ]
- fromVertexMap = Map.fromList [ (v, mkUnitIdV v) | v <- vertices graph ]
- toVertex = (toVertexMap Map.!)
- fromVertex = (fromVertexMap Map.!)
+ let toVertexMap = Map.fromList [(mkUnitIdV v, v) | v <- vertices graph]
+ fromVertexMap = Map.fromList [(v, mkUnitIdV v) | v <- vertices graph]
+ toVertex = (toVertexMap Map.!)
+ fromVertex = (fromVertexMap Map.!)
- return (TestInstallPlan plan graph toVertex fromVertex)
+ return (TestInstallPlan plan graph toVertex fromVertex)
where
mkTestPkg pkgv depvs =
- return (TestPkg pkgid ipkgid deps)
+ return (TestPkg pkgid ipkgid deps)
where
- pkgid = mkPkgId pkgv
+ pkgid = mkPkgId pkgv
ipkgid = mkUnitIdV pkgv
- deps = map mkUnitIdV depvs
+ deps = map mkUnitIdV depvs
mkUnitIdV = mkUnitId . show
- mkPkgId v = PackageIdentifier (mkPackageName ("pkg" ++ show v))
- (mkVersion [1])
-
+ mkPkgId v =
+ PackageIdentifier
+ (mkPackageName ("pkg" ++ show v))
+ (mkVersion [1])
-- | Generate a random 'InstallPlan' following the structure of an existing
-- 'Graph'.
--
-- It takes generators for installed and source packages and the chance that
-- each package is installed (for those packages with no prerequisites).
---
-arbitraryInstallPlan :: (IsUnit ipkg,
- IsUnit srcpkg)
- => (Vertex -> [Vertex] -> Gen ipkg)
- -> (Vertex -> [Vertex] -> Gen srcpkg)
- -> Float
- -> Graph
- -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg)
+arbitraryInstallPlan
+ :: ( IsUnit ipkg
+ , IsUnit srcpkg
+ )
+ => (Vertex -> [Vertex] -> Gen ipkg)
+ -> (Vertex -> [Vertex] -> Gen srcpkg)
+ -> Float
+ -> Graph
+ -> Gen (InstallPlan.GenericInstallPlan ipkg srcpkg)
arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do
+ (ipkgvs, srcpkgvs) <-
+ fmap
+ ( (\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs))
+ . partition snd
+ )
+ $ sequenceA
+ [ do
+ isipkg <-
+ if isRoot
+ then pick ipkgProportion
+ else return False
+ return (v, isipkg)
+ | (v, n) <- assocs (outdegree graph)
+ , let isRoot = n == 0
+ ]
- (ipkgvs, srcpkgvs) <-
- fmap ((\(ipkgs, srcpkgs) -> (map fst ipkgs, map fst srcpkgs))
- . partition snd) $
- sequenceA
- [ do isipkg <- if isRoot then pick ipkgProportion
- else return False
- return (v, isipkg)
- | (v,n) <- assocs (outdegree graph)
- , let isRoot = n == 0 ]
-
- ipkgs <- sequenceA
- [ mkIPkg pkgv depvs
- | pkgv <- ipkgvs
- , let depvs = graph ! pkgv
- ]
- srcpkgs <- sequenceA
- [ mkSrcPkg pkgv depvs
- | pkgv <- srcpkgvs
- , let depvs = graph ! pkgv
- ]
- let index = Graph.fromDistinctList
- (map InstallPlan.PreExisting ipkgs
- ++ map InstallPlan.Configured srcpkgs)
- return $ InstallPlan.new (IndependentGoals False) index
-
+ ipkgs <-
+ sequenceA
+ [ mkIPkg pkgv depvs
+ | pkgv <- ipkgvs
+ , let depvs = graph ! pkgv
+ ]
+ srcpkgs <-
+ sequenceA
+ [ mkSrcPkg pkgv depvs
+ | pkgv <- srcpkgvs
+ , let depvs = graph ! pkgv
+ ]
+ let index =
+ Graph.fromDistinctList
+ ( map InstallPlan.PreExisting ipkgs
+ ++ map InstallPlan.Configured srcpkgs
+ )
+ return $ InstallPlan.new (IndependentGoals False) index
-- | Generate a random directed acyclic graph, based on the algorithm presented
-- here <http://stackoverflow.com/questions/12790337/generating-a-random-dag>
@@ -252,30 +280,29 @@ arbitraryInstallPlan mkIPkg mkSrcPkg ipkgProportion graph = do
-- chance that each node in each rank will have an edge from each node in
-- each previous rank. Thus a higher chance will produce a more densely
-- connected graph.
---
arbitraryAcyclicGraph :: Gen Int -> Gen Int -> Float -> Gen Graph
arbitraryAcyclicGraph genNRanks genNPerRank edgeChance = do
- nranks <- genNRanks
- rankSizes <- replicateM nranks genNPerRank
- let rankStarts = scanl (+) 0 rankSizes
- rankRanges = drop 1 (zip rankStarts (Unsafe.tail rankStarts))
- totalRange = sum rankSizes
- rankEdges <- traverse (uncurry genRank) rankRanges
- return $ buildG (0, totalRange-1) (concat rankEdges)
+ nranks <- genNRanks
+ rankSizes <- replicateM nranks genNPerRank
+ let rankStarts = scanl (+) 0 rankSizes
+ rankRanges = drop 1 (zip rankStarts (Unsafe.tail rankStarts))
+ totalRange = sum rankSizes
+ rankEdges <- traverse (uncurry genRank) rankRanges
+ return $ buildG (0, totalRange - 1) (concat rankEdges)
where
genRank :: Vertex -> Vertex -> Gen [Edge]
genRank rankStart rankEnd =
- filterM (const (pick edgeChance))
- [ (i,j)
- | i <- [0..rankStart-1]
- , j <- [rankStart..rankEnd-1]
+ filterM
+ (const (pick edgeChance))
+ [ (i, j)
+ | i <- [0 .. rankStart - 1]
+ , j <- [rankStart .. rankEnd - 1]
]
pick :: Float -> Gen Bool
pick chance = do
- p <- choose (0,1)
- return (p < chance)
-
+ p <- choose (0, 1)
+ return (p < chance)
--------------------------------
-- Inspecting generated graphs
@@ -302,7 +329,6 @@ renderDotGraph graph =
renderEdge (n, n') = "\t" ++ show n ++ " -> " ++ show n' ++ "[];"
-
header, footer, graphDefaultAtribs, nodeDefaultAtribs, edgeDefaultAtribs :: String
header = "digraph packages {"
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs b/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs
index 05250ff180caeec414b35eb88f93ff3578875c3f..73769f91b183c526a21a5275ba5806f380d352ef 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/JobControl.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE DeriveDataTypeable #-}
+
module UnitTests.Distribution.Client.JobControl (tests) where
import Distribution.Client.JobControl
@@ -6,37 +7,37 @@ import Distribution.Client.JobControl
import Distribution.Client.Compat.Prelude
import Prelude ()
-import Data.IORef (newIORef, atomicModifyIORef)
-import Control.Monad (replicateM_, replicateM)
import Control.Concurrent (threadDelay)
-import Control.Exception (try)
+import Control.Exception (try)
+import Control.Monad (replicateM, replicateM_)
+import Data.IORef (atomicModifyIORef, newIORef)
import qualified Data.Set as Set
import Test.Tasty
import Test.Tasty.QuickCheck hiding (collect)
-
tests :: [TestTree]
tests =
- [ testGroup "serial"
- [ testProperty "submit batch" prop_submit_serial
- , testProperty "submit batch" prop_remaining_serial
+ [ testGroup
+ "serial"
+ [ testProperty "submit batch" prop_submit_serial
+ , testProperty "submit batch" prop_remaining_serial
, testProperty "submit interleaved" prop_interleaved_serial
- , testProperty "concurrent jobs" prop_concurrent_serial
- , testProperty "cancel" prop_cancel_serial
- , testProperty "exceptions" prop_exception_serial
+ , testProperty "concurrent jobs" prop_concurrent_serial
+ , testProperty "cancel" prop_cancel_serial
+ , testProperty "exceptions" prop_exception_serial
]
- , testGroup "parallel"
- [ testProperty "submit batch" prop_submit_parallel
- , testProperty "submit batch" prop_remaining_parallel
+ , testGroup
+ "parallel"
+ [ testProperty "submit batch" prop_submit_parallel
+ , testProperty "submit batch" prop_remaining_parallel
, testProperty "submit interleaved" prop_interleaved_parallel
- , testProperty "concurrent jobs" prop_concurrent_parallel
- , testProperty "cancel" prop_cancel_parallel
- , testProperty "exceptions" prop_exception_parallel
+ , testProperty "concurrent jobs" prop_concurrent_parallel
+ , testProperty "cancel" prop_cancel_parallel
+ , testProperty "exceptions" prop_exception_parallel
]
]
-
prop_submit_serial :: [Int] -> Property
prop_submit_serial xs =
ioProperty $ do
@@ -75,15 +76,15 @@ prop_interleaved_parallel (Positive (Small maxJobLimit)) xs =
prop_submit :: JobControl IO Int -> [Int] -> IO Bool
prop_submit jobCtl xs = do
- traverse_ (\x -> spawnJob jobCtl (return x)) xs
- xs' <- traverse (\_ -> collectJob jobCtl) xs
- return (sort xs == sort xs')
+ traverse_ (\x -> spawnJob jobCtl (return x)) xs
+ xs' <- traverse (\_ -> collectJob jobCtl) xs
+ return (sort xs == sort xs')
prop_remaining :: JobControl IO Int -> [Int] -> IO Bool
prop_remaining jobCtl xs = do
- traverse_ (\x -> spawnJob jobCtl (return x)) xs
- xs' <- collectRemainingJobs jobCtl
- return (sort xs == sort xs')
+ traverse_ (\x -> spawnJob jobCtl (return x)) xs
+ xs' <- collectRemainingJobs jobCtl
+ return (sort xs == sort xs')
collectRemainingJobs :: Monad m => JobControl m a -> m [a]
collectRemainingJobs jobCtl = go []
@@ -91,64 +92,76 @@ collectRemainingJobs jobCtl = go []
go xs = do
remaining <- remainingJobs jobCtl
if remaining
- then do x <- collectJob jobCtl
- go (x:xs)
+ then do
+ x <- collectJob jobCtl
+ go (x : xs)
else return xs
prop_submit_interleaved :: JobControl IO (Maybe Int) -> [Int] -> IO Bool
prop_submit_interleaved jobCtl xs = do
- xs' <- sequenceA
+ xs' <-
+ sequenceA
[ spawn >> collect
- | let spawns = map (\x -> spawnJob jobCtl (return (Just x))) xs
- ++ repeat (return ())
- collects = replicate 5 (return Nothing)
- ++ map (\_ -> collectJob jobCtl) xs
+ | let spawns =
+ map (\x -> spawnJob jobCtl (return (Just x))) xs
+ ++ repeat (return ())
+ collects =
+ replicate 5 (return Nothing)
+ ++ map (\_ -> collectJob jobCtl) xs
, (spawn, collect) <- zip spawns collects
]
- return (sort xs == sort (catMaybes xs'))
+ return (sort xs == sort (catMaybes xs'))
prop_concurrent_serial :: NonNegative (Small Int) -> Property
prop_concurrent_serial (NonNegative (Small ntasks)) =
ioProperty $ do
- jobCtl <- newSerialJobControl
+ jobCtl <- newSerialJobControl
countRef <- newIORef (0 :: Int)
replicateM_ ntasks (spawnJob jobCtl (task countRef))
- counts <- replicateM ntasks (collectJob jobCtl)
- return $ length counts == ntasks
- && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts
+ counts <- replicateM ntasks (collectJob jobCtl)
+ return $
+ length counts == ntasks
+ && all (\(n0, n1) -> n0 == 0 && n1 == 1) counts
where
task countRef = do
- n0 <- atomicModifyIORef countRef (\n -> (n+1, n))
+ n0 <- atomicModifyIORef countRef (\n -> (n + 1, n))
threadDelay 100
- n1 <- atomicModifyIORef countRef (\n -> (n-1, n))
+ n1 <- atomicModifyIORef countRef (\n -> (n - 1, n))
return (n0, n1)
prop_concurrent_parallel :: Positive (Small Int) -> NonNegative Int -> Property
prop_concurrent_parallel (Positive (Small maxJobLimit)) (NonNegative ntasks) =
ioProperty $ do
- jobCtl <- newParallelJobControl maxJobLimit
+ jobCtl <- newParallelJobControl maxJobLimit
countRef <- newIORef (0 :: Int)
replicateM_ ntasks (spawnJob jobCtl (task countRef))
- counts <- replicateM ntasks (collectJob jobCtl)
- return $ length counts == ntasks
- && all (\(n0, n1) -> n0 >= 0 && n0 < maxJobLimit
- && n1 > 0 && n1 <= maxJobLimit) counts
- -- we do hit the concurrency limit (in the right circumstances)
- && if ntasks >= maxJobLimit*2 -- give us enough of a margin
- then any (\(_,n1) -> n1 == maxJobLimit) counts
- else True
+ counts <- replicateM ntasks (collectJob jobCtl)
+ return $
+ length counts == ntasks
+ && all
+ ( \(n0, n1) ->
+ n0 >= 0
+ && n0 < maxJobLimit
+ && n1 > 0
+ && n1 <= maxJobLimit
+ )
+ counts
+ -- we do hit the concurrency limit (in the right circumstances)
+ && if ntasks >= maxJobLimit * 2 -- give us enough of a margin
+ then any (\(_, n1) -> n1 == maxJobLimit) counts
+ else True
where
task countRef = do
- n0 <- atomicModifyIORef countRef (\n -> (n+1, n))
+ n0 <- atomicModifyIORef countRef (\n -> (n + 1, n))
threadDelay 100
- n1 <- atomicModifyIORef countRef (\n -> (n-1, n))
+ n1 <- atomicModifyIORef countRef (\n -> (n - 1, n))
return (n0, n1)
prop_cancel_serial :: [Int] -> [Int] -> Property
prop_cancel_serial xs ys =
ioProperty $ do
jobCtl <- newSerialJobControl
- traverse_ (\x -> spawnJob jobCtl (return x)) (xs++ys)
+ traverse_ (\x -> spawnJob jobCtl (return x)) (xs ++ ys)
xs' <- traverse (\_ -> collectJob jobCtl) xs
cancelJobs jobCtl
ys' <- collectRemainingJobs jobCtl
@@ -158,11 +171,11 @@ prop_cancel_parallel :: Positive (Small Int) -> [Int] -> [Int] -> Property
prop_cancel_parallel (Positive (Small maxJobLimit)) xs ys = do
ioProperty $ do
jobCtl <- newParallelJobControl maxJobLimit
- traverse_ (\x -> spawnJob jobCtl (threadDelay 100 >> return x)) (xs++ys)
+ traverse_ (\x -> spawnJob jobCtl (threadDelay 100 >> return x)) (xs ++ ys)
xs' <- traverse (\_ -> collectJob jobCtl) xs
cancelJobs jobCtl
ys' <- collectRemainingJobs jobCtl
- return $ Set.fromList (xs'++ys') `Set.isSubsetOf` Set.fromList (xs++ys)
+ return $ Set.fromList (xs' ++ ys') `Set.isSubsetOf` Set.fromList (xs ++ ys)
data TestException = TestException Int
deriving (Typeable, Show)
@@ -183,11 +196,10 @@ prop_exception_parallel (Positive (Small maxJobLimit)) xs =
prop_exception :: JobControl IO Int -> [Either Int Int] -> IO Bool
prop_exception jobCtl xs = do
- traverse_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs
- xs' <- replicateM (length xs) $ do
- mx <- try (collectJob jobCtl)
- return $ case mx of
- Left (TestException n) -> Left n
- Right n -> Right n
- return (sort xs == sort xs')
-
+ traverse_ (\x -> spawnJob jobCtl (either (throwIO . TestException) return x)) xs
+ xs' <- replicateM (length xs) $ do
+ mx <- try (collectJob jobCtl)
+ return $ case mx of
+ Left (TestException n) -> Left n
+ Right n -> Right n
+ return (sort xs == sort xs')
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
index 8fcd15b13109d86ed705adcdf084f0ac507bec15..7a925c97f49e0edf9330e21feb8d77cb6049b851 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectConfig.hs
@@ -17,42 +17,42 @@ import Control.Applicative
import Control.Monad
import Data.Either (isRight)
import Data.Foldable (for_)
+import Data.List (intercalate, isPrefixOf, (\\))
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.List (isPrefixOf, intercalate, (\\))
import Data.Maybe (fromMaybe)
import Network.URI (URI)
-import System.Directory (withCurrentDirectory, canonicalizePath)
+import System.Directory (canonicalizePath, withCurrentDirectory)
import System.FilePath
import System.IO.Unsafe (unsafePerformIO)
import Distribution.Deprecated.ParseUtils
import qualified Distribution.Deprecated.ReadP as Parse
+import Distribution.Compiler
import Distribution.Package
import Distribution.PackageDescription
-import Distribution.Compiler
-import Distribution.Version
-import Distribution.Simple.Program.Types
+import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.Program.Db
+import Distribution.Simple.Program.Types
import Distribution.Simple.Utils (toUTF8BS)
-import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Types.PackageVersionConstraint
+import Distribution.Version
import Distribution.Parsec
import Distribution.Pretty
-import Distribution.Client.DistDirLayout (defaultProjectFile)
-import Distribution.Client.Types
import Distribution.Client.CmdInstall.ClientInstallFlags
import Distribution.Client.Dependency.Types
+import Distribution.Client.DistDirLayout (defaultProjectFile)
import Distribution.Client.Targets
+import Distribution.Client.Types
import Distribution.Client.Types.SourceRepo
import Distribution.Utils.NubList
import Distribution.Verbosity (silent)
-import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.PackageConstraint
import Distribution.Solver.Types.Settings
import Distribution.Client.ProjectConfig
@@ -70,77 +70,74 @@ import Test.Tasty.QuickCheck
tests :: [TestTree]
tests =
[ testGroup "ProjectConfig <-> LegacyProjectConfig round trip" $
- [ testProperty "packages" prop_roundtrip_legacytypes_packages
- , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly
- , testProperty "specific" prop_roundtrip_legacytypes_specific
- ] ++
- -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older
- -- unclear why as of yet
- concat
- [ [ testProperty "shared" prop_roundtrip_legacytypes_shared
- , testProperty "local" prop_roundtrip_legacytypes_local
- , testProperty "all" prop_roundtrip_legacytypes_all
+ [ testProperty "packages" prop_roundtrip_legacytypes_packages
+ , testProperty "buildonly" prop_roundtrip_legacytypes_buildonly
+ , testProperty "specific" prop_roundtrip_legacytypes_specific
+ ]
+ ++
+ -- a couple tests seem to trigger a RTS fault in ghc-7.6 and older
+ -- unclear why as of yet
+ concat
+ [ [ testProperty "shared" prop_roundtrip_legacytypes_shared
+ , testProperty "local" prop_roundtrip_legacytypes_local
+ , testProperty "all" prop_roundtrip_legacytypes_all
+ ]
+ | not usingGhc76orOlder
+ ]
+ , testGroup
+ "individual parser tests"
+ [ testProperty "package location" prop_parsePackageLocationTokenQ
+ , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep
+ , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps
+ , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps'
+ ]
+ , testGroup
+ "ProjectConfig printing/parsing round trip"
+ [ testProperty "packages" prop_roundtrip_printparse_packages
+ , testProperty "buildonly" prop_roundtrip_printparse_buildonly
+ , testProperty "shared" prop_roundtrip_printparse_shared
+ , testProperty "local" prop_roundtrip_printparse_local
+ , testProperty "specific" prop_roundtrip_printparse_specific
+ , testProperty "all" prop_roundtrip_printparse_all
]
- | not usingGhc76orOlder
- ]
-
- , testGroup "individual parser tests"
- [ testProperty "package location" prop_parsePackageLocationTokenQ
- , testProperty "RelaxedDep" prop_roundtrip_printparse_RelaxedDep
- , testProperty "RelaxDeps" prop_roundtrip_printparse_RelaxDeps
- , testProperty "RelaxDeps'" prop_roundtrip_printparse_RelaxDeps'
- ]
-
- , testGroup "ProjectConfig printing/parsing round trip"
- [ testProperty "packages" prop_roundtrip_printparse_packages
- , testProperty "buildonly" prop_roundtrip_printparse_buildonly
- , testProperty "shared" prop_roundtrip_printparse_shared
- , testProperty "local" prop_roundtrip_printparse_local
- , testProperty "specific" prop_roundtrip_printparse_specific
- , testProperty "all" prop_roundtrip_printparse_all
- ]
, testFindProjectRoot
]
where
usingGhc76orOlder =
case buildCompilerId of
- CompilerId GHC v -> v < mkVersion [7,7]
- _ -> False
+ CompilerId GHC v -> v < mkVersion [7, 7]
+ _ -> False
testFindProjectRoot :: TestTree
-testFindProjectRoot = testGroup "findProjectRoot"
- [ test "defaults" (cd dir) Nothing Nothing (succeeds dir file)
- , test "defaults in lib" (cd libDir) Nothing Nothing (succeeds dir file)
-
- , test "explicit file" (cd dir) Nothing (Just file) (succeeds dir file)
- , test "explicit file in lib" (cd libDir) Nothing (Just file) (succeeds dir file)
-
- , test "other file" (cd dir) Nothing (Just fileOther) (succeeds dir fileOther)
- , test "other file in lib" (cd libDir) Nothing (Just fileOther) (succeeds dir fileOther)
-
- -- Deprecated use-case
- , test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file)
-
- , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile)
- , test "nested file in lib" (cd libDir) Nothing (Just nixFile) (succeeds dir nixFile)
-
- , test "explicit dir" Nothing (Just dir) Nothing (succeeds dir file)
- , test "explicit dir & file" Nothing (Just dir) (Just file) (succeeds dir file)
- , test "explicit dir & nested file" Nothing (Just dir) (Just nixFile) (succeeds dir nixFile)
- , test "explicit dir & nested other file" Nothing (Just dir) (Just nixOther) (succeeds dir nixOther)
-
- , test "explicit dir & absolute file" Nothing (Just dir) (Just absFile) (succeedsWith ProjectRootExplicitAbsolute dir absFile)
- ]
+testFindProjectRoot =
+ testGroup
+ "findProjectRoot"
+ [ test "defaults" (cd dir) Nothing Nothing (succeeds dir file)
+ , test "defaults in lib" (cd libDir) Nothing Nothing (succeeds dir file)
+ , test "explicit file" (cd dir) Nothing (Just file) (succeeds dir file)
+ , test "explicit file in lib" (cd libDir) Nothing (Just file) (succeeds dir file)
+ , test "other file" (cd dir) Nothing (Just fileOther) (succeeds dir fileOther)
+ , test "other file in lib" (cd libDir) Nothing (Just fileOther) (succeeds dir fileOther)
+ , -- Deprecated use-case
+ test "absolute file" Nothing Nothing (Just absFile) (succeeds dir file)
+ , test "nested file" (cd dir) Nothing (Just nixFile) (succeeds dir nixFile)
+ , test "nested file in lib" (cd libDir) Nothing (Just nixFile) (succeeds dir nixFile)
+ , test "explicit dir" Nothing (Just dir) Nothing (succeeds dir file)
+ , test "explicit dir & file" Nothing (Just dir) (Just file) (succeeds dir file)
+ , test "explicit dir & nested file" Nothing (Just dir) (Just nixFile) (succeeds dir nixFile)
+ , test "explicit dir & nested other file" Nothing (Just dir) (Just nixOther) (succeeds dir nixOther)
+ , test "explicit dir & absolute file" Nothing (Just dir) (Just absFile) (succeedsWith ProjectRootExplicitAbsolute dir absFile)
+ ]
where
- dir = fixturesDir </> "project-root"
+ dir = fixturesDir </> "project-root"
libDir = dir </> "lib"
- file = defaultProjectFile
+ file = defaultProjectFile
fileOther = file <.> "other"
- absFile = dir </> file
+ absFile = dir </> file
- nixFile = "nix" </> file
- nixOther = nixFile <.> "other"
+ nixFile = "nix" </> file
+ nixOther = nixFile <.> "other"
missing path = Just (path <.> "does_not_exist")
@@ -167,12 +164,13 @@ testFindProjectRoot = testGroup "findProjectRoot"
Right pr -> pr @?= mk projectDir projectFile
fails result = case result of
- Left _ -> pure ()
+ Left _ -> pure ()
Right x -> assertFailure $ "Expected an error, but found " <> show x
fixturesDir :: FilePath
-fixturesDir = unsafePerformIO $
- canonicalizePath ("tests" </> "fixtures")
+fixturesDir =
+ unsafePerformIO $
+ canonicalizePath ("tests" </> "fixtures")
{-# NOINLINE fixturesDir #-}
------------------------------------------------
@@ -181,55 +179,54 @@ fixturesDir = unsafePerformIO $
roundtrip :: (Eq a, ToExpr a, Show b) => (a -> b) -> (b -> a) -> a -> Property
roundtrip f f_inv x =
- counterexample (show y) $
+ counterexample (show y) $
x `ediffEq` f_inv y -- no counterexample with y, as they not have ToExpr
where
y = f x
roundtrip_legacytypes :: ProjectConfig -> Property
roundtrip_legacytypes =
- roundtrip convertToLegacyProjectConfig
- convertLegacyProjectConfig
-
+ roundtrip
+ convertToLegacyProjectConfig
+ convertLegacyProjectConfig
prop_roundtrip_legacytypes_all :: ProjectConfig -> Property
prop_roundtrip_legacytypes_all config =
- roundtrip_legacytypes
- config {
- projectConfigProvenance = mempty
+ roundtrip_legacytypes
+ config
+ { projectConfigProvenance = mempty
}
prop_roundtrip_legacytypes_packages :: ProjectConfig -> Property
prop_roundtrip_legacytypes_packages config =
- roundtrip_legacytypes
- config {
- projectConfigBuildOnly = mempty,
- projectConfigShared = mempty,
- projectConfigProvenance = mempty,
- projectConfigLocalPackages = mempty,
- projectConfigSpecificPackage = mempty
+ roundtrip_legacytypes
+ config
+ { projectConfigBuildOnly = mempty
+ , projectConfigShared = mempty
+ , projectConfigProvenance = mempty
+ , projectConfigLocalPackages = mempty
+ , projectConfigSpecificPackage = mempty
}
prop_roundtrip_legacytypes_buildonly :: ProjectConfigBuildOnly -> Property
prop_roundtrip_legacytypes_buildonly config =
- roundtrip_legacytypes
- mempty { projectConfigBuildOnly = config }
+ roundtrip_legacytypes
+ mempty{projectConfigBuildOnly = config}
prop_roundtrip_legacytypes_shared :: ProjectConfigShared -> Property
prop_roundtrip_legacytypes_shared config =
- roundtrip_legacytypes
- mempty { projectConfigShared = config }
+ roundtrip_legacytypes
+ mempty{projectConfigShared = config}
prop_roundtrip_legacytypes_local :: PackageConfig -> Property
prop_roundtrip_legacytypes_local config =
- roundtrip_legacytypes
- mempty { projectConfigLocalPackages = config }
+ roundtrip_legacytypes
+ mempty{projectConfigLocalPackages = config}
prop_roundtrip_legacytypes_specific :: Map PackageName PackageConfig -> Property
prop_roundtrip_legacytypes_specific config =
- roundtrip_legacytypes
- mempty { projectConfigSpecificPackage = MapMappend config }
-
+ roundtrip_legacytypes
+ mempty{projectConfigSpecificPackage = MapMappend config}
--------------------------------------------
-- Round trip: printing and parsing config
@@ -237,96 +234,97 @@ prop_roundtrip_legacytypes_specific config =
roundtrip_printparse :: ProjectConfig -> Property
roundtrip_printparse config =
- case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of
- ParseOk _ x -> counterexample ("shown:\n" ++ str) $
- x `ediffEq` config { projectConfigProvenance = mempty }
- ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False
+ case fmap convertLegacyProjectConfig (parseLegacyProjectConfig "unused" (toUTF8BS str)) of
+ ParseOk _ x ->
+ counterexample ("shown:\n" ++ str) $
+ x `ediffEq` config{projectConfigProvenance = mempty}
+ ParseFailed err -> counterexample ("shown:\n" ++ str ++ "\nERROR: " ++ show err) False
where
str :: String
str = showLegacyProjectConfig (convertToLegacyProjectConfig config)
-
prop_roundtrip_printparse_all :: ProjectConfig -> Property
prop_roundtrip_printparse_all config =
- roundtrip_printparse config {
- projectConfigBuildOnly =
- hackProjectConfigBuildOnly (projectConfigBuildOnly config),
-
- projectConfigShared =
- hackProjectConfigShared (projectConfigShared config)
- }
+ roundtrip_printparse
+ config
+ { projectConfigBuildOnly =
+ hackProjectConfigBuildOnly (projectConfigBuildOnly config)
+ , projectConfigShared =
+ hackProjectConfigShared (projectConfigShared config)
+ }
-prop_roundtrip_printparse_packages :: [PackageLocationString]
- -> [PackageLocationString]
- -> [SourceRepoList]
- -> [PackageVersionConstraint]
- -> Property
+prop_roundtrip_printparse_packages
+ :: [PackageLocationString]
+ -> [PackageLocationString]
+ -> [SourceRepoList]
+ -> [PackageVersionConstraint]
+ -> Property
prop_roundtrip_printparse_packages pkglocstrs1 pkglocstrs2 repos named =
- roundtrip_printparse
- mempty {
- projectPackages = map getPackageLocationString pkglocstrs1,
- projectPackagesOptional = map getPackageLocationString pkglocstrs2,
- projectPackagesRepo = repos,
- projectPackagesNamed = named
+ roundtrip_printparse
+ mempty
+ { projectPackages = map getPackageLocationString pkglocstrs1
+ , projectPackagesOptional = map getPackageLocationString pkglocstrs2
+ , projectPackagesRepo = repos
+ , projectPackagesNamed = named
}
prop_roundtrip_printparse_buildonly :: ProjectConfigBuildOnly -> Property
prop_roundtrip_printparse_buildonly config =
- roundtrip_printparse
- mempty {
- projectConfigBuildOnly = hackProjectConfigBuildOnly config
+ roundtrip_printparse
+ mempty
+ { projectConfigBuildOnly = hackProjectConfigBuildOnly config
}
hackProjectConfigBuildOnly :: ProjectConfigBuildOnly -> ProjectConfigBuildOnly
hackProjectConfigBuildOnly config =
- config {
- -- These fields are only command line transitory things, not
+ config
+ { -- These fields are only command line transitory things, not
-- something to be recorded persistently in a config file
- projectConfigOnlyDeps = mempty,
- projectConfigOnlyDownload = mempty,
- projectConfigDryRun = mempty
+ projectConfigOnlyDeps = mempty
+ , projectConfigOnlyDownload = mempty
+ , projectConfigDryRun = mempty
}
prop_roundtrip_printparse_shared :: ProjectConfigShared -> Property
prop_roundtrip_printparse_shared config =
- roundtrip_printparse
- mempty {
- projectConfigShared = hackProjectConfigShared config
+ roundtrip_printparse
+ mempty
+ { projectConfigShared = hackProjectConfigShared config
}
hackProjectConfigShared :: ProjectConfigShared -> ProjectConfigShared
hackProjectConfigShared config =
- config {
- projectConfigProjectFile = mempty, -- not present within project files
- projectConfigProjectDir = mempty, -- ditto
- projectConfigConfigFile = mempty, -- ditto
- projectConfigConstraints =
- --TODO: [required eventually] parse ambiguity in constraint
- -- "pkgname -any" as either any version or disabled flag "any".
+ config
+ { projectConfigProjectFile = mempty -- not present within project files
+ , projectConfigProjectDir = mempty -- ditto
+ , projectConfigConfigFile = mempty -- ditto
+ , projectConfigConstraints =
+ -- TODO: [required eventually] parse ambiguity in constraint
+ -- "pkgname -any" as either any version or disabled flag "any".
let ambiguous (UserConstraint _ (PackagePropertyFlags flags), _) =
- (not . null) [ () | (name, False) <- unFlagAssignment flags
- , "any" `isPrefixOf` unFlagName name ]
+ (not . null)
+ [ () | (name, False) <- unFlagAssignment flags, "any" `isPrefixOf` unFlagName name
+ ]
ambiguous _ = False
in filter (not . ambiguous) (projectConfigConstraints config)
}
-
prop_roundtrip_printparse_local :: PackageConfig -> Property
prop_roundtrip_printparse_local config =
- roundtrip_printparse
- mempty {
- projectConfigLocalPackages = config
+ roundtrip_printparse
+ mempty
+ { projectConfigLocalPackages = config
}
-prop_roundtrip_printparse_specific :: Map PackageName (NonMEmpty PackageConfig)
- -> Property
+prop_roundtrip_printparse_specific
+ :: Map PackageName (NonMEmpty PackageConfig)
+ -> Property
prop_roundtrip_printparse_specific config =
- roundtrip_printparse
- mempty {
- projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)
+ roundtrip_printparse
+ mempty
+ { projectConfigSpecificPackage = MapMappend (fmap getNonMEmpty config)
}
-
----------------------------
-- Individual Parser tests
--
@@ -335,27 +333,27 @@ prop_roundtrip_printparse_specific config =
--
-- Succeeds only if there is a unique complete parse
runReadP :: Parse.ReadP a a -> String -> Maybe a
-runReadP parser s = case [ x | (x,"") <- Parse.readP_to_S parser s ] of
- [x'] -> Just x'
- _ -> Nothing
+runReadP parser s = case [x | (x, "") <- Parse.readP_to_S parser s] of
+ [x'] -> Just x'
+ _ -> Nothing
prop_parsePackageLocationTokenQ :: PackageLocationString -> Bool
prop_parsePackageLocationTokenQ (PackageLocationString str) =
- runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str
+ runReadP parsePackageLocationTokenQ (renderPackageLocationToken str) == Just str
prop_roundtrip_printparse_RelaxedDep :: RelaxedDep -> Property
prop_roundtrip_printparse_RelaxedDep rdep =
- counterexample (prettyShow rdep) $
+ counterexample (prettyShow rdep) $
eitherParsec (prettyShow rdep) == Right rdep
prop_roundtrip_printparse_RelaxDeps :: RelaxDeps -> Property
prop_roundtrip_printparse_RelaxDeps rdep =
- counterexample (prettyShow rdep) $
+ counterexample (prettyShow rdep) $
Right rdep `ediffEq` eitherParsec (prettyShow rdep)
prop_roundtrip_printparse_RelaxDeps' :: RelaxDeps -> Property
prop_roundtrip_printparse_RelaxDeps' rdep =
- counterexample rdep' $
+ counterexample rdep' $
Right rdep `ediffEq` eitherParsec rdep'
where
rdep' = go (prettyShow rdep)
@@ -364,213 +362,244 @@ prop_roundtrip_printparse_RelaxDeps' rdep =
go :: String -> String
go [] = []
go "all" = "*"
- go ('a':'l':'l':c:rest) | c `elem` ":," = '*' : go (c:rest)
- go rest = let (x,y) = break (`elem` ":,") rest
- (x',y') = span (`elem` ":,^") y
- in x++x'++go y'
+ go ('a' : 'l' : 'l' : c : rest) | c `elem` ":," = '*' : go (c : rest)
+ go rest =
+ let (x, y) = break (`elem` ":,") rest
+ (x', y') = span (`elem` ":,^") y
+ in x ++ x' ++ go y'
------------------------
-- Arbitrary instances
--
instance Arbitrary ProjectConfig where
- arbitrary =
- ProjectConfig
- <$> (map getPackageLocationString <$> arbitrary)
- <*> (map getPackageLocationString <$> arbitrary)
- <*> shortListOf 3 arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> (MapMappend . fmap getNonMEmpty . Map.fromList
- <$> shortListOf 3 arbitrary)
- -- package entries with no content are equivalent to
- -- the entry not existing at all, so exclude empty
-
- shrink ProjectConfig { projectPackages = x0
- , projectPackagesOptional = x1
- , projectPackagesRepo = x2
- , projectPackagesNamed = x3
- , projectConfigBuildOnly = x4
- , projectConfigShared = x5
- , projectConfigProvenance = x6
- , projectConfigLocalPackages = x7
- , projectConfigSpecificPackage = x8
- , projectConfigAllPackages = x9 } =
- [ ProjectConfig { projectPackages = x0'
- , projectPackagesOptional = x1'
- , projectPackagesRepo = x2'
- , projectPackagesNamed = x3'
- , projectConfigBuildOnly = x4'
- , projectConfigShared = x5'
- , projectConfigProvenance = x6'
- , projectConfigLocalPackages = x7'
- , projectConfigSpecificPackage = (MapMappend
- (fmap getNonMEmpty x8'))
- , projectConfigAllPackages = x9' }
- | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9'))
- <- shrink ((x0, x1, x2, x3),
- (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9))
+ arbitrary =
+ ProjectConfig
+ <$> (map getPackageLocationString <$> arbitrary)
+ <*> (map getPackageLocationString <$> arbitrary)
+ <*> shortListOf 3 arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> ( MapMappend . fmap getNonMEmpty . Map.fromList
+ <$> shortListOf 3 arbitrary
+ )
+
+ -- package entries with no content are equivalent to
+ -- the entry not existing at all, so exclude empty
+
+ shrink
+ ProjectConfig
+ { projectPackages = x0
+ , projectPackagesOptional = x1
+ , projectPackagesRepo = x2
+ , projectPackagesNamed = x3
+ , projectConfigBuildOnly = x4
+ , projectConfigShared = x5
+ , projectConfigProvenance = x6
+ , projectConfigLocalPackages = x7
+ , projectConfigSpecificPackage = x8
+ , projectConfigAllPackages = x9
+ } =
+ [ ProjectConfig
+ { projectPackages = x0'
+ , projectPackagesOptional = x1'
+ , projectPackagesRepo = x2'
+ , projectPackagesNamed = x3'
+ , projectConfigBuildOnly = x4'
+ , projectConfigShared = x5'
+ , projectConfigProvenance = x6'
+ , projectConfigLocalPackages = x7'
+ , projectConfigSpecificPackage =
+ ( MapMappend
+ (fmap getNonMEmpty x8')
+ )
+ , projectConfigAllPackages = x9'
+ }
+ | ((x0', x1', x2', x3'), (x4', x5', x6', x7', x8', x9')) <-
+ shrink
+ ( (x0, x1, x2, x3)
+ , (x4, x5, x6, x7, fmap NonMEmpty (getMapMappend x8), x9)
+ )
]
-newtype PackageLocationString
- = PackageLocationString { getPackageLocationString :: String }
- deriving Show
+newtype PackageLocationString = PackageLocationString {getPackageLocationString :: String}
+ deriving (Show)
instance Arbitrary PackageLocationString where
arbitrary =
- PackageLocationString <$>
- oneof
- [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))
- , arbitraryGlobLikeStr
- , show <$> (arbitrary :: Gen URI)
- ]
- `suchThat` (\xs -> not ("{" `isPrefixOf` xs))
+ PackageLocationString
+ <$> oneof
+ [ show . getNonEmpty <$> (arbitrary :: Gen (NonEmptyList String))
+ , arbitraryGlobLikeStr
+ , show <$> (arbitrary :: Gen URI)
+ ]
+ `suchThat` (\xs -> not ("{" `isPrefixOf` xs))
arbitraryGlobLikeStr :: Gen String
arbitraryGlobLikeStr = outerTerm
where
- outerTerm = concat <$> shortListOf1 4
- (frequency [ (2, token)
- , (1, braces <$> innerTerm) ])
- innerTerm = intercalate "," <$> shortListOf1 3
- (frequency [ (3, token)
- , (1, braces <$> innerTerm) ])
- token = shortListOf1 4 (elements (['#'..'~'] \\ "{,}"))
- braces s = "{" ++ s ++ "}"
-
+ outerTerm =
+ concat
+ <$> shortListOf1
+ 4
+ ( frequency
+ [ (2, token)
+ , (1, braces <$> innerTerm)
+ ]
+ )
+ innerTerm =
+ intercalate ","
+ <$> shortListOf1
+ 3
+ ( frequency
+ [ (3, token)
+ , (1, braces <$> innerTerm)
+ ]
+ )
+ token = shortListOf1 4 (elements (['#' .. '~'] \\ "{,}"))
+ braces s = "{" ++ s ++ "}"
instance Arbitrary ClientInstallFlags where
- arbitrary =
- ClientInstallFlags
- <$> arbitrary
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitrary
- <*> arbitrary
- <*> arbitraryFlag arbitraryShortToken
+ arbitrary =
+ ClientInstallFlags
+ <$> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
instance Arbitrary ProjectConfigBuildOnly where
- arbitrary =
- ProjectConfigBuildOnly
- <$> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> (toNubList <$> shortListOf 2 arbitrary)
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> (fmap getShortToken <$> arbitrary)
- <*> arbitraryNumJobs
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> (fmap getShortToken <$> arbitrary)
- <*> arbitrary
- <*> (fmap getShortToken <$> arbitrary)
- <*> (fmap getShortToken <$> arbitrary)
- <*> arbitrary
- where
- arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary
-
- shrink ProjectConfigBuildOnly { projectConfigVerbosity = x00
- , projectConfigDryRun = x01
- , projectConfigOnlyDeps = x02
- , projectConfigOnlyDownload = x18
- , projectConfigSummaryFile = x03
- , projectConfigLogFile = x04
- , projectConfigBuildReports = x05
- , projectConfigReportPlanningFailure = x06
- , projectConfigSymlinkBinDir = x07
- , projectConfigNumJobs = x09
- , projectConfigKeepGoing = x10
- , projectConfigOfflineMode = x11
- , projectConfigKeepTempFiles = x12
- , projectConfigHttpTransport = x13
- , projectConfigIgnoreExpiry = x14
- , projectConfigCacheDir = x15
- , projectConfigLogsDir = x16
- , projectConfigClientInstallFlags = x17 } =
- [ ProjectConfigBuildOnly { projectConfigVerbosity = x00'
- , projectConfigDryRun = x01'
- , projectConfigOnlyDeps = x02'
- , projectConfigOnlyDownload = x18'
- , projectConfigSummaryFile = x03'
- , projectConfigLogFile = x04'
- , projectConfigBuildReports = x05'
- , projectConfigReportPlanningFailure = x06'
- , projectConfigSymlinkBinDir = x07'
- , projectConfigNumJobs = postShrink_NumJobs x09'
- , projectConfigKeepGoing = x10'
- , projectConfigOfflineMode = x11'
- , projectConfigKeepTempFiles = x12'
- , projectConfigHttpTransport = x13
- , projectConfigIgnoreExpiry = x14'
- , projectConfigCacheDir = x15
- , projectConfigLogsDir = x16
- , projectConfigClientInstallFlags = x17' }
- | ((x00', x01', x02', x03', x04'),
- (x05', x06', x07', x09'),
- (x10', x11', x12', x14'),
- ( x17', x18' ))
- <- shrink
- ((x00, x01, x02, x03, x04),
- (x05, x06, x07, preShrink_NumJobs x09),
- (x10, x11, x12, x14),
- ( x17, x18 ))
+ arbitrary =
+ ProjectConfigBuildOnly
+ <$> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> (toNubList <$> shortListOf 2 arbitrary)
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> (fmap getShortToken <$> arbitrary)
+ <*> arbitraryNumJobs
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> (fmap getShortToken <$> arbitrary)
+ <*> arbitrary
+ <*> (fmap getShortToken <$> arbitrary)
+ <*> (fmap getShortToken <$> arbitrary)
+ <*> arbitrary
+ where
+ arbitraryNumJobs = fmap (fmap getPositive) <$> arbitrary
+
+ shrink
+ ProjectConfigBuildOnly
+ { projectConfigVerbosity = x00
+ , projectConfigDryRun = x01
+ , projectConfigOnlyDeps = x02
+ , projectConfigOnlyDownload = x18
+ , projectConfigSummaryFile = x03
+ , projectConfigLogFile = x04
+ , projectConfigBuildReports = x05
+ , projectConfigReportPlanningFailure = x06
+ , projectConfigSymlinkBinDir = x07
+ , projectConfigNumJobs = x09
+ , projectConfigKeepGoing = x10
+ , projectConfigOfflineMode = x11
+ , projectConfigKeepTempFiles = x12
+ , projectConfigHttpTransport = x13
+ , projectConfigIgnoreExpiry = x14
+ , projectConfigCacheDir = x15
+ , projectConfigLogsDir = x16
+ , projectConfigClientInstallFlags = x17
+ } =
+ [ ProjectConfigBuildOnly
+ { projectConfigVerbosity = x00'
+ , projectConfigDryRun = x01'
+ , projectConfigOnlyDeps = x02'
+ , projectConfigOnlyDownload = x18'
+ , projectConfigSummaryFile = x03'
+ , projectConfigLogFile = x04'
+ , projectConfigBuildReports = x05'
+ , projectConfigReportPlanningFailure = x06'
+ , projectConfigSymlinkBinDir = x07'
+ , projectConfigNumJobs = postShrink_NumJobs x09'
+ , projectConfigKeepGoing = x10'
+ , projectConfigOfflineMode = x11'
+ , projectConfigKeepTempFiles = x12'
+ , projectConfigHttpTransport = x13
+ , projectConfigIgnoreExpiry = x14'
+ , projectConfigCacheDir = x15
+ , projectConfigLogsDir = x16
+ , projectConfigClientInstallFlags = x17'
+ }
+ | ( (x00', x01', x02', x03', x04')
+ , (x05', x06', x07', x09')
+ , (x10', x11', x12', x14')
+ , (x17', x18')
+ ) <-
+ shrink
+ ( (x00, x01, x02, x03, x04)
+ , (x05, x06, x07, preShrink_NumJobs x09)
+ , (x10, x11, x12, x14)
+ , (x17, x18)
+ )
]
where
- preShrink_NumJobs = fmap (fmap Positive)
+ preShrink_NumJobs = fmap (fmap Positive)
postShrink_NumJobs = fmap (fmap getPositive)
instance Arbitrary ProjectConfigShared where
- arbitrary = do
- projectConfigDistDir <- arbitraryFlag arbitraryShortToken
- projectConfigConfigFile <- arbitraryFlag arbitraryShortToken
- projectConfigProjectDir <- arbitraryFlag arbitraryShortToken
- projectConfigProjectFile <- arbitraryFlag arbitraryShortToken
- projectConfigIgnoreProject <- arbitrary
- projectConfigHcFlavor <- arbitrary
- projectConfigHcPath <- arbitraryFlag arbitraryShortToken
- projectConfigHcPkg <- arbitraryFlag arbitraryShortToken
- projectConfigHaddockIndex <- arbitrary
- projectConfigInstallDirs <- fixInstallDirs <$> arbitrary
- projectConfigPackageDBs <- shortListOf 2 arbitrary
- projectConfigRemoteRepos <- arbitrary
- projectConfigLocalNoIndexRepos <- arbitrary
- projectConfigActiveRepos <- arbitrary
- projectConfigIndexState <- arbitrary
- projectConfigStoreDir <- arbitraryFlag arbitraryShortToken
- projectConfigConstraints <- arbitraryConstraints
- projectConfigPreferences <- shortListOf 2 arbitrary
- projectConfigCabalVersion <- arbitrary
- projectConfigSolver <- arbitrary
- projectConfigAllowOlder <- arbitrary
- projectConfigAllowNewer <- arbitrary
- projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary
- projectConfigMaxBackjumps <- arbitrary
- projectConfigReorderGoals <- arbitrary
- projectConfigCountConflicts <- arbitrary
- projectConfigFineGrainedConflicts <- arbitrary
- projectConfigMinimizeConflictSet <- arbitrary
- projectConfigStrongFlags <- arbitrary
- projectConfigAllowBootLibInstalls <- arbitrary
- projectConfigOnlyConstrained <- arbitrary
- projectConfigPerComponent <- arbitrary
- projectConfigIndependentGoals <- arbitrary
- projectConfigPreferOldest <- arbitrary
- projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken
- return ProjectConfigShared {..}
- where
- arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]
- arbitraryConstraints =
- fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary
- fixInstallDirs x = x {InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty}
-
- shrink ProjectConfigShared {..} = runShrinker $ pure ProjectConfigShared
+ arbitrary = do
+ projectConfigDistDir <- arbitraryFlag arbitraryShortToken
+ projectConfigConfigFile <- arbitraryFlag arbitraryShortToken
+ projectConfigProjectDir <- arbitraryFlag arbitraryShortToken
+ projectConfigProjectFile <- arbitraryFlag arbitraryShortToken
+ projectConfigIgnoreProject <- arbitrary
+ projectConfigHcFlavor <- arbitrary
+ projectConfigHcPath <- arbitraryFlag arbitraryShortToken
+ projectConfigHcPkg <- arbitraryFlag arbitraryShortToken
+ projectConfigHaddockIndex <- arbitrary
+ projectConfigInstallDirs <- fixInstallDirs <$> arbitrary
+ projectConfigPackageDBs <- shortListOf 2 arbitrary
+ projectConfigRemoteRepos <- arbitrary
+ projectConfigLocalNoIndexRepos <- arbitrary
+ projectConfigActiveRepos <- arbitrary
+ projectConfigIndexState <- arbitrary
+ projectConfigStoreDir <- arbitraryFlag arbitraryShortToken
+ projectConfigConstraints <- arbitraryConstraints
+ projectConfigPreferences <- shortListOf 2 arbitrary
+ projectConfigCabalVersion <- arbitrary
+ projectConfigSolver <- arbitrary
+ projectConfigAllowOlder <- arbitrary
+ projectConfigAllowNewer <- arbitrary
+ projectConfigWriteGhcEnvironmentFilesPolicy <- arbitrary
+ projectConfigMaxBackjumps <- arbitrary
+ projectConfigReorderGoals <- arbitrary
+ projectConfigCountConflicts <- arbitrary
+ projectConfigFineGrainedConflicts <- arbitrary
+ projectConfigMinimizeConflictSet <- arbitrary
+ projectConfigStrongFlags <- arbitrary
+ projectConfigAllowBootLibInstalls <- arbitrary
+ projectConfigOnlyConstrained <- arbitrary
+ projectConfigPerComponent <- arbitrary
+ projectConfigIndependentGoals <- arbitrary
+ projectConfigPreferOldest <- arbitrary
+ projectConfigProgPathExtra <- toNubList <$> listOf arbitraryShortToken
+ return ProjectConfigShared{..}
+ where
+ arbitraryConstraints :: Gen [(UserConstraint, ConstraintSource)]
+ arbitraryConstraints =
+ fmap (\uc -> (uc, projectConfigConstraintSource)) <$> arbitrary
+ fixInstallDirs x = x{InstallDirs.includedir = mempty, InstallDirs.mandir = mempty, InstallDirs.flibdir = mempty}
+
+ shrink ProjectConfigShared{..} =
+ runShrinker $
+ pure ProjectConfigShared
<*> shrinker projectConfigDistDir
<*> shrinker projectConfigConfigFile
<*> shrinker projectConfigProjectDir
@@ -606,250 +635,302 @@ instance Arbitrary ProjectConfigShared where
<*> shrinker projectConfigIndependentGoals
<*> shrinker projectConfigPreferOldest
<*> shrinker projectConfigProgPathExtra
- where
- preShrink_Constraints = map fst
- postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))
+ where
+ preShrink_Constraints = map fst
+ postShrink_Constraints = map (\uc -> (uc, projectConfigConstraintSource))
projectConfigConstraintSource :: ConstraintSource
projectConfigConstraintSource =
- ConstraintSourceProjectConfig "unused"
+ ConstraintSourceProjectConfig "unused"
instance Arbitrary ProjectConfigProvenance where
- arbitrary = elements [Implicit, Explicit "cabal.project"]
+ arbitrary = elements [Implicit, Explicit "cabal.project"]
instance Arbitrary PackageConfig where
- arbitrary =
- PackageConfig
- <$> (MapLast . Map.fromList <$> shortListOf 10
- ((,) <$> arbitraryProgramName
- <*> arbitraryShortToken))
- <*> (MapMappend . Map.fromList <$> shortListOf 10
- ((,) <$> arbitraryProgramName
- <*> listOf arbitraryShortToken))
- <*> (toNubList <$> listOf arbitraryShortToken)
- <*> arbitrary
- <*> arbitrary <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> shortListOf 5 arbitraryShortToken
- <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> shortListOf 5 arbitraryShortToken
- <*> shortListOf 5 arbitraryShortToken
- <*> shortListOf 5 arbitraryShortToken
- <*> shortListOf 5 arbitraryShortToken
- <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary <*> arbitrary
- <*> arbitrary
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitrary
- <*> arbitrary
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitrary
- <*> arbitrary
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitrary
- <*> arbitraryFlag arbitraryShortToken
- <*> arbitrary
- <*> shortListOf 5 arbitrary
- <*> shortListOf 5 arbitrary
- where
- arbitraryProgramName :: Gen String
- arbitraryProgramName =
- elements [ programName prog
- | (prog, _) <- knownPrograms (defaultProgramDb) ]
-
- shrink PackageConfig { packageConfigProgramPaths = x00
- , packageConfigProgramArgs = x01
- , packageConfigProgramPathExtra = x02
- , packageConfigFlagAssignment = x03
- , packageConfigVanillaLib = x04
- , packageConfigSharedLib = x05
- , packageConfigStaticLib = x42
- , packageConfigDynExe = x06
- , packageConfigFullyStaticExe = x50
- , packageConfigProf = x07
- , packageConfigProfLib = x08
- , packageConfigProfExe = x09
- , packageConfigProfDetail = x10
- , packageConfigProfLibDetail = x11
- , packageConfigConfigureArgs = x12
- , packageConfigOptimization = x13
- , packageConfigProgPrefix = x14
- , packageConfigProgSuffix = x15
- , packageConfigExtraLibDirs = x16
- , packageConfigExtraLibDirsStatic = x53
- , packageConfigExtraFrameworkDirs = x17
- , packageConfigExtraIncludeDirs = x18
- , packageConfigGHCiLib = x19
- , packageConfigSplitSections = x20
- , packageConfigSplitObjs = x20_1
- , packageConfigStripExes = x21
- , packageConfigStripLibs = x22
- , packageConfigTests = x23
- , packageConfigBenchmarks = x24
- , packageConfigCoverage = x25
- , packageConfigRelocatable = x26
- , packageConfigDebugInfo = x27
- , packageConfigDumpBuildInfo = x27_1
- , packageConfigRunTests = x28
- , packageConfigDocumentation = x29
- , packageConfigHaddockHoogle = x30
- , packageConfigHaddockHtml = x31
- , packageConfigHaddockHtmlLocation = x32
- , packageConfigHaddockForeignLibs = x33
- , packageConfigHaddockExecutables = x33_1
- , packageConfigHaddockTestSuites = x34
- , packageConfigHaddockBenchmarks = x35
- , packageConfigHaddockInternal = x36
- , packageConfigHaddockCss = x37
- , packageConfigHaddockLinkedSource = x38
- , packageConfigHaddockQuickJump = x43
- , packageConfigHaddockHscolourCss = x39
- , packageConfigHaddockContents = x40
- , packageConfigHaddockForHackage = x41
- , packageConfigHaddockIndex = x54
- , packageConfigHaddockBaseUrl = x55
- , packageConfigHaddockLib = x56
- , packageConfigHaddockOutputDir = x57
- , packageConfigTestHumanLog = x44
- , packageConfigTestMachineLog = x45
- , packageConfigTestShowDetails = x46
- , packageConfigTestKeepTix = x47
- , packageConfigTestWrapper = x48
- , packageConfigTestFailWhenNoTestSuites = x49
- , packageConfigTestTestOptions = x51
- , packageConfigBenchmarkOptions = x52 } =
- [ PackageConfig { packageConfigProgramPaths = postShrink_Paths x00'
- , packageConfigProgramArgs = postShrink_Args x01'
- , packageConfigProgramPathExtra = x02'
- , packageConfigFlagAssignment = x03'
- , packageConfigVanillaLib = x04'
- , packageConfigSharedLib = x05'
- , packageConfigStaticLib = x42'
- , packageConfigDynExe = x06'
- , packageConfigFullyStaticExe = x50'
- , packageConfigProf = x07'
- , packageConfigProfLib = x08'
- , packageConfigProfExe = x09'
- , packageConfigProfDetail = x10'
- , packageConfigProfLibDetail = x11'
- , packageConfigConfigureArgs = map getNonEmpty x12'
- , packageConfigOptimization = x13'
- , packageConfigProgPrefix = x14'
- , packageConfigProgSuffix = x15'
- , packageConfigExtraLibDirs = map getNonEmpty x16'
- , packageConfigExtraLibDirsStatic = map getNonEmpty x53'
- , packageConfigExtraFrameworkDirs = map getNonEmpty x17'
- , packageConfigExtraIncludeDirs = map getNonEmpty x18'
- , packageConfigGHCiLib = x19'
- , packageConfigSplitSections = x20'
- , packageConfigSplitObjs = x20_1'
- , packageConfigStripExes = x21'
- , packageConfigStripLibs = x22'
- , packageConfigTests = x23'
- , packageConfigBenchmarks = x24'
- , packageConfigCoverage = x25'
- , packageConfigRelocatable = x26'
- , packageConfigDebugInfo = x27'
- , packageConfigDumpBuildInfo = x27_1'
- , packageConfigRunTests = x28'
- , packageConfigDocumentation = x29'
- , packageConfigHaddockHoogle = x30'
- , packageConfigHaddockHtml = x31'
- , packageConfigHaddockHtmlLocation = x32'
- , packageConfigHaddockForeignLibs = x33'
- , packageConfigHaddockExecutables = x33_1'
- , packageConfigHaddockTestSuites = x34'
- , packageConfigHaddockBenchmarks = x35'
- , packageConfigHaddockInternal = x36'
- , packageConfigHaddockCss = fmap getNonEmpty x37'
- , packageConfigHaddockLinkedSource = x38'
- , packageConfigHaddockQuickJump = x43'
- , packageConfigHaddockHscolourCss = fmap getNonEmpty x39'
- , packageConfigHaddockContents = x40'
- , packageConfigHaddockForHackage = x41'
- , packageConfigHaddockIndex = x54'
- , packageConfigHaddockBaseUrl = x55'
- , packageConfigHaddockLib = x56'
- , packageConfigHaddockOutputDir = x57'
- , packageConfigTestHumanLog = x44'
- , packageConfigTestMachineLog = x45'
- , packageConfigTestShowDetails = x46'
- , packageConfigTestKeepTix = x47'
- , packageConfigTestWrapper = x48'
- , packageConfigTestFailWhenNoTestSuites = x49'
- , packageConfigTestTestOptions = x51'
- , packageConfigBenchmarkOptions = x52' }
- | (((x00', x01', x02', x03', x04'),
- (x05', x42', x06', x50', x07', x08', x09'),
- (x10', x11', x12', x13', x14'),
- (x15', x16', x53', x17', x18', x19')),
- ((x20', x20_1', x21', x22', x23', x24'),
- (x25', x26', x27', x27_1', x28', x29'),
- (x30', x31', x32', (x33', x33_1'), x34'),
- (x35', x36', x37', x38', x43', x39'),
- (x40', x41'),
- (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55'),
- x56', x57'))
- <- shrink
- (((preShrink_Paths x00, preShrink_Args x01, x02, x03, x04),
- (x05, x42, x06, x50, x07, x08, x09),
- (x10, x11, map NonEmpty x12, x13, x14),
- (x15, map NonEmpty x16, map NonEmpty x53,
- map NonEmpty x17,
- map NonEmpty x18,
- x19)),
- ((x20, x20_1, x21, x22, x23, x24),
- (x25, x26, x27, x27_1, x28, x29),
- (x30, x31, x32, (x33, x33_1), x34),
- (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39),
- (x40, x41),
- (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55), x56, x57))
+ arbitrary =
+ PackageConfig
+ <$> ( MapLast . Map.fromList
+ <$> shortListOf
+ 10
+ ( (,)
+ <$> arbitraryProgramName
+ <*> arbitraryShortToken
+ )
+ )
+ <*> ( MapMappend . Map.fromList
+ <$> shortListOf
+ 10
+ ( (,)
+ <$> arbitraryProgramName
+ <*> listOf arbitraryShortToken
+ )
+ )
+ <*> (toNubList <$> listOf arbitraryShortToken)
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> shortListOf 5 arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> shortListOf 5 arbitraryShortToken
+ <*> shortListOf 5 arbitraryShortToken
+ <*> shortListOf 5 arbitraryShortToken
+ <*> shortListOf 5 arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitrary
+ <*> arbitraryFlag arbitraryShortToken
+ <*> arbitrary
+ <*> shortListOf 5 arbitrary
+ <*> shortListOf 5 arbitrary
+ where
+ arbitraryProgramName :: Gen String
+ arbitraryProgramName =
+ elements
+ [ programName prog
+ | (prog, _) <- knownPrograms (defaultProgramDb)
+ ]
+
+ shrink
+ PackageConfig
+ { packageConfigProgramPaths = x00
+ , packageConfigProgramArgs = x01
+ , packageConfigProgramPathExtra = x02
+ , packageConfigFlagAssignment = x03
+ , packageConfigVanillaLib = x04
+ , packageConfigSharedLib = x05
+ , packageConfigStaticLib = x42
+ , packageConfigDynExe = x06
+ , packageConfigFullyStaticExe = x50
+ , packageConfigProf = x07
+ , packageConfigProfLib = x08
+ , packageConfigProfExe = x09
+ , packageConfigProfDetail = x10
+ , packageConfigProfLibDetail = x11
+ , packageConfigConfigureArgs = x12
+ , packageConfigOptimization = x13
+ , packageConfigProgPrefix = x14
+ , packageConfigProgSuffix = x15
+ , packageConfigExtraLibDirs = x16
+ , packageConfigExtraLibDirsStatic = x53
+ , packageConfigExtraFrameworkDirs = x17
+ , packageConfigExtraIncludeDirs = x18
+ , packageConfigGHCiLib = x19
+ , packageConfigSplitSections = x20
+ , packageConfigSplitObjs = x20_1
+ , packageConfigStripExes = x21
+ , packageConfigStripLibs = x22
+ , packageConfigTests = x23
+ , packageConfigBenchmarks = x24
+ , packageConfigCoverage = x25
+ , packageConfigRelocatable = x26
+ , packageConfigDebugInfo = x27
+ , packageConfigDumpBuildInfo = x27_1
+ , packageConfigRunTests = x28
+ , packageConfigDocumentation = x29
+ , packageConfigHaddockHoogle = x30
+ , packageConfigHaddockHtml = x31
+ , packageConfigHaddockHtmlLocation = x32
+ , packageConfigHaddockForeignLibs = x33
+ , packageConfigHaddockExecutables = x33_1
+ , packageConfigHaddockTestSuites = x34
+ , packageConfigHaddockBenchmarks = x35
+ , packageConfigHaddockInternal = x36
+ , packageConfigHaddockCss = x37
+ , packageConfigHaddockLinkedSource = x38
+ , packageConfigHaddockQuickJump = x43
+ , packageConfigHaddockHscolourCss = x39
+ , packageConfigHaddockContents = x40
+ , packageConfigHaddockForHackage = x41
+ , packageConfigHaddockIndex = x54
+ , packageConfigHaddockBaseUrl = x55
+ , packageConfigHaddockLib = x56
+ , packageConfigHaddockOutputDir = x57
+ , packageConfigTestHumanLog = x44
+ , packageConfigTestMachineLog = x45
+ , packageConfigTestShowDetails = x46
+ , packageConfigTestKeepTix = x47
+ , packageConfigTestWrapper = x48
+ , packageConfigTestFailWhenNoTestSuites = x49
+ , packageConfigTestTestOptions = x51
+ , packageConfigBenchmarkOptions = x52
+ } =
+ [ PackageConfig
+ { packageConfigProgramPaths = postShrink_Paths x00'
+ , packageConfigProgramArgs = postShrink_Args x01'
+ , packageConfigProgramPathExtra = x02'
+ , packageConfigFlagAssignment = x03'
+ , packageConfigVanillaLib = x04'
+ , packageConfigSharedLib = x05'
+ , packageConfigStaticLib = x42'
+ , packageConfigDynExe = x06'
+ , packageConfigFullyStaticExe = x50'
+ , packageConfigProf = x07'
+ , packageConfigProfLib = x08'
+ , packageConfigProfExe = x09'
+ , packageConfigProfDetail = x10'
+ , packageConfigProfLibDetail = x11'
+ , packageConfigConfigureArgs = map getNonEmpty x12'
+ , packageConfigOptimization = x13'
+ , packageConfigProgPrefix = x14'
+ , packageConfigProgSuffix = x15'
+ , packageConfigExtraLibDirs = map getNonEmpty x16'
+ , packageConfigExtraLibDirsStatic = map getNonEmpty x53'
+ , packageConfigExtraFrameworkDirs = map getNonEmpty x17'
+ , packageConfigExtraIncludeDirs = map getNonEmpty x18'
+ , packageConfigGHCiLib = x19'
+ , packageConfigSplitSections = x20'
+ , packageConfigSplitObjs = x20_1'
+ , packageConfigStripExes = x21'
+ , packageConfigStripLibs = x22'
+ , packageConfigTests = x23'
+ , packageConfigBenchmarks = x24'
+ , packageConfigCoverage = x25'
+ , packageConfigRelocatable = x26'
+ , packageConfigDebugInfo = x27'
+ , packageConfigDumpBuildInfo = x27_1'
+ , packageConfigRunTests = x28'
+ , packageConfigDocumentation = x29'
+ , packageConfigHaddockHoogle = x30'
+ , packageConfigHaddockHtml = x31'
+ , packageConfigHaddockHtmlLocation = x32'
+ , packageConfigHaddockForeignLibs = x33'
+ , packageConfigHaddockExecutables = x33_1'
+ , packageConfigHaddockTestSuites = x34'
+ , packageConfigHaddockBenchmarks = x35'
+ , packageConfigHaddockInternal = x36'
+ , packageConfigHaddockCss = fmap getNonEmpty x37'
+ , packageConfigHaddockLinkedSource = x38'
+ , packageConfigHaddockQuickJump = x43'
+ , packageConfigHaddockHscolourCss = fmap getNonEmpty x39'
+ , packageConfigHaddockContents = x40'
+ , packageConfigHaddockForHackage = x41'
+ , packageConfigHaddockIndex = x54'
+ , packageConfigHaddockBaseUrl = x55'
+ , packageConfigHaddockLib = x56'
+ , packageConfigHaddockOutputDir = x57'
+ , packageConfigTestHumanLog = x44'
+ , packageConfigTestMachineLog = x45'
+ , packageConfigTestShowDetails = x46'
+ , packageConfigTestKeepTix = x47'
+ , packageConfigTestWrapper = x48'
+ , packageConfigTestFailWhenNoTestSuites = x49'
+ , packageConfigTestTestOptions = x51'
+ , packageConfigBenchmarkOptions = x52'
+ }
+ | ( ( (x00', x01', x02', x03', x04')
+ , (x05', x42', x06', x50', x07', x08', x09')
+ , (x10', x11', x12', x13', x14')
+ , (x15', x16', x53', x17', x18', x19')
+ )
+ , ( (x20', x20_1', x21', x22', x23', x24')
+ , (x25', x26', x27', x27_1', x28', x29')
+ , (x30', x31', x32', (x33', x33_1'), x34')
+ , (x35', x36', x37', x38', x43', x39')
+ , (x40', x41')
+ , (x44', x45', x46', x47', x48', x49', x51', x52', x54', x55')
+ , x56'
+ , x57'
+ )
+ ) <-
+ shrink
+ (
+ ( (preShrink_Paths x00, preShrink_Args x01, x02, x03, x04)
+ , (x05, x42, x06, x50, x07, x08, x09)
+ , (x10, x11, map NonEmpty x12, x13, x14)
+ ,
+ ( x15
+ , map NonEmpty x16
+ , map NonEmpty x53
+ , map NonEmpty x17
+ , map NonEmpty x18
+ , x19
+ )
+ )
+ ,
+ ( (x20, x20_1, x21, x22, x23, x24)
+ , (x25, x26, x27, x27_1, x28, x29)
+ , (x30, x31, x32, (x33, x33_1), x34)
+ , (x35, x36, fmap NonEmpty x37, x38, x43, fmap NonEmpty x39)
+ , (x40, x41)
+ , (x44, x45, x46, x47, x48, x49, x51, x52, x54, x55)
+ , x56
+ , x57
+ )
+ )
]
where
- preShrink_Paths = Map.map NonEmpty
- . Map.mapKeys NoShrink
- . getMapLast
- postShrink_Paths = MapLast
- . Map.map getNonEmpty
- . Map.mapKeys getNoShrink
- preShrink_Args = Map.map (NonEmpty . map NonEmpty)
- . Map.mapKeys NoShrink
- . getMapMappend
- postShrink_Args = MapMappend
- . Map.map (map getNonEmpty . getNonEmpty)
- . Map.mapKeys getNoShrink
-
-
+ preShrink_Paths =
+ Map.map NonEmpty
+ . Map.mapKeys NoShrink
+ . getMapLast
+ postShrink_Paths =
+ MapLast
+ . Map.map getNonEmpty
+ . Map.mapKeys getNoShrink
+ preShrink_Args =
+ Map.map (NonEmpty . map NonEmpty)
+ . Map.mapKeys NoShrink
+ . getMapMappend
+ postShrink_Args =
+ MapMappend
+ . Map.map (map getNonEmpty . getNonEmpty)
+ . Map.mapKeys getNoShrink
instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where
- arbitrary = SourceRepositoryPackage
- <$> arbitrary
- <*> (getShortToken <$> arbitrary)
- <*> (fmap getShortToken <$> arbitrary)
- <*> (fmap getShortToken <$> arbitrary)
- <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
- <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
-
- shrink SourceRepositoryPackage {..} = runShrinker $ pure SourceRepositoryPackage
+ arbitrary =
+ SourceRepositoryPackage
+ <$> arbitrary
+ <*> (getShortToken <$> arbitrary)
+ <*> (fmap getShortToken <$> arbitrary)
+ <*> (fmap getShortToken <$> arbitrary)
+ <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
+ <*> (fmap getShortToken <$> shortListOf 3 arbitrary)
+
+ shrink SourceRepositoryPackage{..} =
+ runShrinker $
+ pure SourceRepositoryPackage
<*> shrinker srpType
<*> shrinkerAla ShortToken srpLocation
<*> shrinkerAla (fmap ShortToken) srpTag
@@ -858,53 +939,61 @@ instance f ~ [] => Arbitrary (SourceRepositoryPackage f) where
<*> shrinkerAla (fmap ShortToken) srpCommand
instance Arbitrary RemoteRepo where
- arbitrary =
- RemoteRepo
- <$> arbitrary
- <*> arbitrary -- URI
- <*> arbitrary
- <*> listOf arbitraryRootKey
- <*> fmap getNonNegative arbitrary
- <*> pure False
- where
- arbitraryRootKey =
- shortListOf1 5 (oneof [ choose ('0', '9')
- , choose ('a', 'f') ])
+ arbitrary =
+ RemoteRepo
+ <$> arbitrary
+ <*> arbitrary -- URI
+ <*> arbitrary
+ <*> listOf arbitraryRootKey
+ <*> fmap getNonNegative arbitrary
+ <*> pure False
+ where
+ arbitraryRootKey =
+ shortListOf1
+ 5
+ ( oneof
+ [ choose ('0', '9')
+ , choose ('a', 'f')
+ ]
+ )
instance Arbitrary LocalRepo where
- arbitrary = LocalRepo
- <$> arbitrary
- <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths
- <*> arbitrary
+ arbitrary =
+ LocalRepo
+ <$> arbitrary
+ <*> elements ["/tmp/foo", "/tmp/bar"] -- TODO: generate valid absolute paths
+ <*> arbitrary
instance Arbitrary PreSolver where
- arbitrary = elements [minBound..maxBound]
+ arbitrary = elements [minBound .. maxBound]
instance Arbitrary ReorderGoals where
- arbitrary = ReorderGoals <$> arbitrary
+ arbitrary = ReorderGoals <$> arbitrary
instance Arbitrary CountConflicts where
- arbitrary = CountConflicts <$> arbitrary
+ arbitrary = CountConflicts <$> arbitrary
instance Arbitrary FineGrainedConflicts where
- arbitrary = FineGrainedConflicts <$> arbitrary
+ arbitrary = FineGrainedConflicts <$> arbitrary
instance Arbitrary MinimizeConflictSet where
- arbitrary = MinimizeConflictSet <$> arbitrary
+ arbitrary = MinimizeConflictSet <$> arbitrary
instance Arbitrary IndependentGoals where
- arbitrary = IndependentGoals <$> arbitrary
+ arbitrary = IndependentGoals <$> arbitrary
instance Arbitrary PreferOldest where
- arbitrary = PreferOldest <$> arbitrary
+ arbitrary = PreferOldest <$> arbitrary
instance Arbitrary StrongFlags where
- arbitrary = StrongFlags <$> arbitrary
+ arbitrary = StrongFlags <$> arbitrary
instance Arbitrary AllowBootLibInstalls where
- arbitrary = AllowBootLibInstalls <$> arbitrary
+ arbitrary = AllowBootLibInstalls <$> arbitrary
instance Arbitrary OnlyConstrained where
- arbitrary = oneof [ pure OnlyConstrainedAll
- , pure OnlyConstrainedNone
- ]
+ arbitrary =
+ oneof
+ [ pure OnlyConstrainedAll
+ , pure OnlyConstrainedNone
+ ]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs b/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs
index 11eab4e9d828e6b5ff3f659e0d45703c0387ea2f..184cfef5bdfaba7261a803442a405f610f99d01a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/ProjectPlanning.hs
@@ -35,8 +35,8 @@ nubComponentTargetsTests =
@?= [(mainLibWholeCompTarget, 1 :| [2])]
, testCase "Merges whole component targets" $
nubComponentTargets [(mainLibFileTarget, 2), (mainLibWholeCompTarget, 1 :: Int)]
- @?= [(mainLibWholeCompTarget, 2 :| [1])],
- testCase "Don't merge unrelated targets" $
+ @?= [(mainLibWholeCompTarget, 2 :| [1])]
+ , testCase "Don't merge unrelated targets" $
nubComponentTargets
[ (mainLibWholeCompTarget, 1 :: Int)
, (exeWholeCompTarget, 2)
@@ -58,11 +58,10 @@ nubComponentTargetsTests =
, (exeFileTarget, 3)
, (exe2FileTarget, 5)
]
- @?=
- [ (mainLibWholeCompTarget, 1 :| [4])
- , (exeWholeCompTarget, 2 :| [3])
- , (exe2WholeCompTarget, 5 :| [])
- ]
+ @?= [ (mainLibWholeCompTarget, 1 :| [4])
+ , (exeWholeCompTarget, 2 :| [3])
+ , (exe2WholeCompTarget, 5 :| [])
+ ]
]
-- ----------------------------------------------------------------------------
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Store.hs b/cabal-install/tests/UnitTests/Distribution/Client/Store.hs
index e949b818ec39d3f7d8270ed36190d8d76973833e..7268b4c8c344cb2b6b5f19cd2c0b9efa800ca95b 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Store.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Store.hs
@@ -1,47 +1,45 @@
module UnitTests.Distribution.Client.Store (tests) where
---import Control.Monad
---import Control.Concurrent (forkIO, threadDelay)
---import Control.Concurrent.MVar
+-- import Control.Monad
+-- import Control.Concurrent (forkIO, threadDelay)
+-- import Control.Concurrent.MVar
import qualified Data.Set as Set
-import System.FilePath
import System.Directory
---import System.Random
+import System.FilePath
+
+-- import System.Random
+import Distribution.Compiler (CompilerFlavor (..), CompilerId (..))
import Distribution.Package (UnitId, mkUnitId)
-import Distribution.Compiler (CompilerId(..), CompilerFlavor(..))
-import Distribution.Version (mkVersion)
-import Distribution.Verbosity (Verbosity, silent)
import Distribution.Simple.Utils (withTempDirectory)
+import Distribution.Verbosity (Verbosity, silent)
+import Distribution.Version (mkVersion)
-import Distribution.Client.Store
import Distribution.Client.RebuildMonad
+import Distribution.Client.Store
import Test.Tasty
import Test.Tasty.HUnit
-
tests :: [TestTree]
tests =
- [ testCase "list content empty" testListEmpty
- , testCase "install serial" testInstallSerial
---, testCase "install parallel" testInstallParallel
- --TODO: figure out some way to do a parallel test, see issue below
+ [ testCase "list content empty" testListEmpty
+ , testCase "install serial" testInstallSerial
+ -- , testCase "install parallel" testInstallParallel
+ -- TODO: figure out some way to do a parallel test, see issue below
]
-
testListEmpty :: Assertion
testListEmpty =
withTempDirectory verbosity "." "store-" $ \tmp -> do
let storeDirLayout = defaultStoreDirLayout (tmp </> "store")
assertStoreEntryExists storeDirLayout compid unitid False
- assertStoreContent tmp storeDirLayout compid Set.empty
+ assertStoreContent tmp storeDirLayout compid Set.empty
where
- compid = CompilerId GHC (mkVersion [1,0])
+ compid = CompilerId GHC (mkVersion [1, 0])
unitid = mkUnitId "foo-1.0-xyz"
-
testInstallSerial :: Assertion
testInstallSerial =
withTempDirectory verbosity "." "store-" $ \tmp -> do
@@ -51,30 +49,44 @@ testInstallSerial =
let destprefix = dir </> "prefix"
createDirectory destprefix
writeFile (destprefix </> file) content
- return (destprefix,[])
-
- assertNewStoreEntry tmp storeDirLayout compid unitid1
- (copyFiles "file1" "content-foo") (return ())
- UseNewStoreEntry
-
- assertNewStoreEntry tmp storeDirLayout compid unitid1
- (copyFiles "file1" "content-foo") (return ())
- UseExistingStoreEntry
-
- assertNewStoreEntry tmp storeDirLayout compid unitid2
- (copyFiles "file2" "content-bar") (return ())
- UseNewStoreEntry
+ return (destprefix, [])
+
+ assertNewStoreEntry
+ tmp
+ storeDirLayout
+ compid
+ unitid1
+ (copyFiles "file1" "content-foo")
+ (return ())
+ UseNewStoreEntry
+
+ assertNewStoreEntry
+ tmp
+ storeDirLayout
+ compid
+ unitid1
+ (copyFiles "file1" "content-foo")
+ (return ())
+ UseExistingStoreEntry
+
+ assertNewStoreEntry
+ tmp
+ storeDirLayout
+ compid
+ unitid2
+ (copyFiles "file2" "content-bar")
+ (return ())
+ UseNewStoreEntry
let pkgDir :: UnitId -> FilePath
pkgDir = storePackageDirectory storeDirLayout compid
assertFileEqual (pkgDir unitid1 </> "file1") "content-foo"
assertFileEqual (pkgDir unitid2 </> "file2") "content-bar"
where
- compid = CompilerId GHC (mkVersion [1,0])
+ compid = CompilerId GHC (mkVersion [1, 0])
unitid1 = mkUnitId "foo-1.0-xyz"
unitid2 = mkUnitId "bar-2.0-xyz"
-
{-
-- unfortunately a parallel test like the one below is thwarted by the normal
-- process-internal file locking. If that locking were not in place then we
@@ -135,47 +147,63 @@ testInstallParallel =
-------------
-- Utils
-assertNewStoreEntry :: FilePath -> StoreDirLayout
- -> CompilerId -> UnitId
- -> (FilePath -> IO (FilePath,[FilePath])) -> IO ()
- -> NewStoreEntryOutcome
- -> Assertion
-assertNewStoreEntry tmp storeDirLayout compid unitid
- copyFiles register expectedOutcome = do
+assertNewStoreEntry
+ :: FilePath
+ -> StoreDirLayout
+ -> CompilerId
+ -> UnitId
+ -> (FilePath -> IO (FilePath, [FilePath]))
+ -> IO ()
+ -> NewStoreEntryOutcome
+ -> Assertion
+assertNewStoreEntry
+ tmp
+ storeDirLayout
+ compid
+ unitid
+ copyFiles
+ register
+ expectedOutcome = do
entries <- runRebuild tmp $ getStoreEntries storeDirLayout compid
- outcome <- newStoreEntry verbosity storeDirLayout
- compid unitid
- copyFiles register
+ outcome <-
+ newStoreEntry
+ verbosity
+ storeDirLayout
+ compid
+ unitid
+ copyFiles
+ register
assertEqual "newStoreEntry outcome" expectedOutcome outcome
assertStoreEntryExists storeDirLayout compid unitid True
let expected = Set.insert unitid entries
assertStoreContent tmp storeDirLayout compid expected
-
-assertStoreEntryExists :: StoreDirLayout
- -> CompilerId -> UnitId -> Bool
- -> Assertion
+assertStoreEntryExists
+ :: StoreDirLayout
+ -> CompilerId
+ -> UnitId
+ -> Bool
+ -> Assertion
assertStoreEntryExists storeDirLayout compid unitid expected = do
- actual <- doesStoreEntryExist storeDirLayout compid unitid
- assertEqual "store entry exists" expected actual
-
-
-assertStoreContent :: FilePath -> StoreDirLayout
- -> CompilerId -> Set.Set UnitId
- -> Assertion
+ actual <- doesStoreEntryExist storeDirLayout compid unitid
+ assertEqual "store entry exists" expected actual
+
+assertStoreContent
+ :: FilePath
+ -> StoreDirLayout
+ -> CompilerId
+ -> Set.Set UnitId
+ -> Assertion
assertStoreContent tmp storeDirLayout compid expected = do
- actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid
- assertEqual "store content" actual expected
-
+ actual <- runRebuild tmp $ getStoreEntries storeDirLayout compid
+ assertEqual "store content" actual expected
assertFileEqual :: FilePath -> String -> Assertion
assertFileEqual path expected = do
- exists <- doesFileExist path
- assertBool ("file does not exist:\n" ++ path) exists
- actual <- readFile path
- assertEqual ("file content for:\n" ++ path) expected actual
-
+ exists <- doesFileExist path
+ assertBool ("file does not exist:\n" ++ path) exists
+ actual <- readFile path
+ assertEqual ("file content for:\n" ++ path) expected actual
verbosity :: Verbosity
verbosity = silent
-
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs b/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs
index 8b70dd89e4cb9c18016dc5f4e40845432dce5d65..6295de6ace82ff32d2e126467a1f2bceb62cbafc 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Tar.hs
@@ -1,54 +1,73 @@
-module UnitTests.Distribution.Client.Tar (
- tests
+module UnitTests.Distribution.Client.Tar
+ ( tests
) where
-import Distribution.Client.Tar ( filterEntries
- , filterEntriesM
- )
-import Codec.Archive.Tar ( Entries(..)
- , foldEntries
- )
-import Codec.Archive.Tar.Entry ( EntryContent(..)
- , simpleEntry
- , Entry(..)
- , toTarPath
- )
+import Codec.Archive.Tar
+ ( Entries (..)
+ , foldEntries
+ )
+import Codec.Archive.Tar.Entry
+ ( Entry (..)
+ , EntryContent (..)
+ , simpleEntry
+ , toTarPath
+ )
+import Distribution.Client.Tar
+ ( filterEntries
+ , filterEntriesM
+ )
import Test.Tasty
import Test.Tasty.HUnit
+import Control.Monad.Writer.Lazy (runWriterT, tell)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BS.Char8
-import Control.Monad.Writer.Lazy (runWriterT, tell)
tests :: [TestTree]
-tests = [ testCase "filterEntries" filterTest
- , testCase "filterEntriesM" filterMTest
- ]
+tests =
+ [ testCase "filterEntries" filterTest
+ , testCase "filterEntriesM" filterMTest
+ ]
filterTest :: Assertion
filterTest = do
let e1 = getFileEntry "file1" "x"
e2 = getFileEntry "file2" "y"
- p = (\e -> let str = BS.Char8.unpack $ case entryContent e of
- NormalFile dta _ -> dta
- _ -> error "Invalid entryContent"
- in str /= "y")
+ p =
+ ( \e ->
+ let str = BS.Char8.unpack $ case entryContent e of
+ NormalFile dta _ -> dta
+ _ -> error "Invalid entryContent"
+ in str /= "y"
+ )
assertEqual "Unexpected result for filter" "xz" $
- entriesToString $ filterEntries p $ Next e1 $ Next e2 Done
+ entriesToString $
+ filterEntries p $
+ Next e1 $
+ Next e2 Done
assertEqual "Unexpected result for filter" "z" $
- entriesToString $ filterEntries p $ Done
+ entriesToString $
+ filterEntries p $
+ Done
assertEqual "Unexpected result for filter" "xf" $
- entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f"
+ entriesToString $
+ filterEntries p $
+ Next e1 $
+ Next e2 $
+ Fail "f"
filterMTest :: Assertion
filterMTest = do
let e1 = getFileEntry "file1" "x"
e2 = getFileEntry "file2" "y"
- p = (\e -> let str = BS.Char8.unpack $ case entryContent e of
- NormalFile dta _ -> dta
- _ -> error "Invalid entryContent"
- in tell "t" >> return (str /= "y"))
+ p =
+ ( \e ->
+ let str = BS.Char8.unpack $ case entryContent e of
+ NormalFile dta _ -> dta
+ _ -> error "Invalid entryContent"
+ in tell "t" >> return (str /= "y")
+ )
(r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done
assertEqual "Unexpected result for filterM" "xz" $ entriesToString r
@@ -65,14 +84,20 @@ filterMTest = do
getFileEntry :: FilePath -> [Char] -> Entry
getFileEntry pth dta =
simpleEntry tp $ NormalFile dta' $ BS.length dta'
- where tp = case toTarPath False pth of
- Right tp' -> tp'
- Left e -> error e
- dta' = BS.Char8.pack dta
+ where
+ tp = case toTarPath False pth of
+ Right tp' -> tp'
+ Left e -> error e
+ dta' = BS.Char8.pack dta
entriesToString :: Entries String -> String
entriesToString =
- foldEntries (\e acc -> let str = BS.Char8.unpack $ case entryContent e of
- NormalFile dta _ -> dta
- _ -> error "Invalid entryContent"
- in str ++ acc) "z" id
+ foldEntries
+ ( \e acc ->
+ let str = BS.Char8.unpack $ case entryContent e of
+ NormalFile dta _ -> dta
+ _ -> error "Invalid entryContent"
+ in str ++ acc
+ )
+ "z"
+ id
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
index 0e4e93b8aab0963905a3a462ebd1b5ad149fd78a..060dbdffe4f0584ef9b218f44b10435985c50234 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs
@@ -1,82 +1,107 @@
-module UnitTests.Distribution.Client.Targets (
- tests
+module UnitTests.Distribution.Client.Targets
+ ( tests
) where
-import Distribution.Client.Targets (UserQualifier(..)
- ,UserConstraintScope(..)
- ,UserConstraint(..), readUserConstraint)
-import Distribution.Package (mkPackageName)
-import Distribution.PackageDescription (mkFlagName, mkFlagAssignment)
-import Distribution.Version (anyVersion, thisVersion, mkVersion)
+import Distribution.Client.Targets
+ ( UserConstraint (..)
+ , UserConstraintScope (..)
+ , UserQualifier (..)
+ , readUserConstraint
+ )
+import Distribution.Package (mkPackageName)
+import Distribution.PackageDescription (mkFlagAssignment, mkFlagName)
+import Distribution.Version (anyVersion, mkVersion, thisVersion)
import Distribution.Parsec (explicitEitherParsec, parsec, parsecCommaList)
-import Distribution.Solver.Types.PackageConstraint (PackageProperty(..))
-import Distribution.Solver.Types.OptionalStanza (OptionalStanza(..))
+import Distribution.Solver.Types.OptionalStanza (OptionalStanza (..))
+import Distribution.Solver.Types.PackageConstraint (PackageProperty (..))
import Test.Tasty
import Test.Tasty.HUnit
-import Data.List (intercalate)
+import Data.List (intercalate)
-- Helper function: makes a test group by mapping each element
-- of a list to a test case.
makeGroup :: String -> (a -> Assertion) -> [a] -> TestTree
-makeGroup name f xs = testGroup name $
- zipWith testCase (map show [0 :: Integer ..]) (map f xs)
+makeGroup name f xs =
+ testGroup name $
+ zipWith testCase (map show [0 :: Integer ..]) (map f xs)
tests :: [TestTree]
tests =
- [ makeGroup "readUserConstraint" (uncurry readUserConstraintTest)
+ [ makeGroup
+ "readUserConstraint"
+ (uncurry readUserConstraintTest)
exampleConstraints
-
- , makeGroup "parseUserConstraint" (uncurry parseUserConstraintTest)
+ , makeGroup
+ "parseUserConstraint"
+ (uncurry parseUserConstraintTest)
exampleConstraints
-
- , makeGroup "readUserConstraints" (uncurry readUserConstraintsTest)
- [-- First example only.
- (head exampleStrs, take 1 exampleUcs),
- -- All examples separated by commas.
- (intercalate ", " exampleStrs, exampleUcs)]
+ , makeGroup
+ "readUserConstraints"
+ (uncurry readUserConstraintsTest)
+ [ -- First example only.
+ (head exampleStrs, take 1 exampleUcs)
+ , -- All examples separated by commas.
+ (intercalate ", " exampleStrs, exampleUcs)
+ ]
]
where
(exampleStrs, exampleUcs) = unzip exampleConstraints
exampleConstraints :: [(String, UserConstraint)]
exampleConstraints =
- [ ("template-haskell installed",
- UserConstraint (UserQualified UserQualToplevel (pn "template-haskell"))
- PackagePropertyInstalled)
-
- , ("bytestring >= 0",
- UserConstraint (UserQualified UserQualToplevel (pn "bytestring"))
- (PackagePropertyVersion anyVersion))
-
- , ("any.directory test",
- UserConstraint (UserAnyQualifier (pn "directory"))
- (PackagePropertyStanzas [TestStanzas]))
-
- , ("setup.Cabal installed",
- UserConstraint (UserAnySetupQualifier (pn "Cabal"))
- PackagePropertyInstalled)
-
- , ("process:setup.bytestring ==5.2",
- UserConstraint (UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))
- (PackagePropertyVersion (thisVersion (mkVersion [5, 2]))))
-
- -- flag MUST be prefixed with - or +
- , ("network:setup.containers +foo -bar +baz",
- UserConstraint (UserQualified (UserQualSetup (pn "network")) (pn "containers"))
- (PackagePropertyFlags (mkFlagAssignment
- [(fn "foo", True),
- (fn "bar", False),
- (fn "baz", True)])))
-
- -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
- --
- -- , ("foo:happy:exe.template-haskell test",
- -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell"))
- -- (PackagePropertyStanzas [TestStanzas]))
+ [
+ ( "template-haskell installed"
+ , UserConstraint
+ (UserQualified UserQualToplevel (pn "template-haskell"))
+ PackagePropertyInstalled
+ )
+ ,
+ ( "bytestring >= 0"
+ , UserConstraint
+ (UserQualified UserQualToplevel (pn "bytestring"))
+ (PackagePropertyVersion anyVersion)
+ )
+ ,
+ ( "any.directory test"
+ , UserConstraint
+ (UserAnyQualifier (pn "directory"))
+ (PackagePropertyStanzas [TestStanzas])
+ )
+ ,
+ ( "setup.Cabal installed"
+ , UserConstraint
+ (UserAnySetupQualifier (pn "Cabal"))
+ PackagePropertyInstalled
+ )
+ ,
+ ( "process:setup.bytestring ==5.2"
+ , UserConstraint
+ (UserQualified (UserQualSetup (pn "process")) (pn "bytestring"))
+ (PackagePropertyVersion (thisVersion (mkVersion [5, 2])))
+ )
+ , -- flag MUST be prefixed with - or +
+
+ ( "network:setup.containers +foo -bar +baz"
+ , UserConstraint
+ (UserQualified (UserQualSetup (pn "network")) (pn "containers"))
+ ( PackagePropertyFlags
+ ( mkFlagAssignment
+ [ (fn "foo", True)
+ , (fn "bar", False)
+ , (fn "baz", True)
+ ]
+ )
+ )
+ )
+ -- -- TODO: Re-enable UserQualExe tests once we decide on a syntax.
+ --
+ -- , ("foo:happy:exe.template-haskell test",
+ -- UserConstraint (UserQualified (UserQualExe (pn "foo") (pn "happy")) (pn "template-haskell"))
+ -- (PackagePropertyStanzas [TestStanzas]))
]
where
pn = mkPackageName
@@ -87,18 +112,18 @@ readUserConstraintTest str uc =
assertEqual ("Couldn't read constraint: '" ++ str ++ "'") expected actual
where
expected = Right uc
- actual = readUserConstraint str
+ actual = readUserConstraint str
parseUserConstraintTest :: String -> UserConstraint -> Assertion
parseUserConstraintTest str uc =
assertEqual ("Couldn't parse constraint: '" ++ str ++ "'") expected actual
where
expected = Right uc
- actual = explicitEitherParsec parsec str
+ actual = explicitEitherParsec parsec str
readUserConstraintsTest :: String -> [UserConstraint] -> Assertion
readUserConstraintsTest str ucs =
assertEqual ("Couldn't read constraints: '" ++ str ++ "'") expected actual
where
expected = Right ucs
- actual = explicitEitherParsec (parsecCommaList parsec) str
+ actual = explicitEitherParsec (parsecCommaList parsec) str
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
index e7e0c3671baf68ce80cea81333d5f98d631b5df9..495c4cbf402365082149ec3e2e9b51b128d2702d 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/TreeDiffInstances.hs
@@ -17,10 +17,10 @@ import Distribution.Client.IndexUtils.Timestamp
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Targets
import Distribution.Client.Types
-import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
-import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage)
+import Distribution.Client.Types.OverwritePolicy (OverwritePolicy)
+import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage)
-import Distribution.Simple.Compiler (PackageDB)
+import Distribution.Simple.Compiler (PackageDB)
import Data.TreeDiff.Class
import Data.TreeDiff.Instances.Cabal ()
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs
index 3bb92121f62bcc2ce5066a171cc7b156759162f3..17adc1b75b418ea882a9f9f5c04125ae07525b1e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/UserConfig.hs
@@ -1,112 +1,110 @@
{-# LANGUAGE CPP #-}
+
module UnitTests.Distribution.Client.UserConfig
- ( tests
- ) where
+ ( tests
+ ) where
import Control.Exception (bracket)
import Control.Monad (replicateM_)
-import Data.List (sort, nub)
+import Data.List (nub, sort)
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid
#endif
-import System.Directory (doesFileExist,
- getCurrentDirectory, getTemporaryDirectory)
+import System.Directory
+ ( doesFileExist
+ , getCurrentDirectory
+ , getTemporaryDirectory
+ )
import System.FilePath ((</>))
import Test.Tasty
import Test.Tasty.HUnit
import Distribution.Client.Config
-import Distribution.Utils.NubList (fromNubList)
import Distribution.Client.Setup (GlobalFlags (..), InstallFlags (..))
import Distribution.Client.Utils (removeExistingFile)
-import Distribution.Simple.Setup (Flag (..), ConfigFlags (..), fromFlag)
+import Distribution.Simple.Setup (ConfigFlags (..), Flag (..), fromFlag)
import Distribution.Simple.Utils (withTempDirectory)
+import Distribution.Utils.NubList (fromNubList)
import Distribution.Verbosity (silent)
tests :: [TestTree]
-tests = [ testCase "nullDiffOnCreate" nullDiffOnCreateTest
- , testCase "canDetectDifference" canDetectDifference
- , testCase "canUpdateConfig" canUpdateConfig
- , testCase "doubleUpdateConfig" doubleUpdateConfig
- , testCase "newDefaultConfig" newDefaultConfig
- ]
+tests =
+ [ testCase "nullDiffOnCreate" nullDiffOnCreateTest
+ , testCase "canDetectDifference" canDetectDifference
+ , testCase "canUpdateConfig" canUpdateConfig
+ , testCase "doubleUpdateConfig" doubleUpdateConfig
+ , testCase "newDefaultConfig" newDefaultConfig
+ ]
nullDiffOnCreateTest :: Assertion
nullDiffOnCreateTest = bracketTest $ \configFile -> do
- -- Create a new default config file in our test directory.
- _ <- createDefaultConfigFile silent [] configFile
- -- Now we read it in and compare it against the default.
- diff <- userConfigDiff silent (globalFlags configFile) []
- assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff
-
+ -- Create a new default config file in our test directory.
+ _ <- createDefaultConfigFile silent [] configFile
+ -- Now we read it in and compare it against the default.
+ diff <- userConfigDiff silent (globalFlags configFile) []
+ assertBool (unlines $ "Following diff should be empty:" : diff) $ null diff
canDetectDifference :: Assertion
canDetectDifference = bracketTest $ \configFile -> do
- -- Create a new default config file in our test directory.
- _ <- createDefaultConfigFile silent [] configFile
- appendFile configFile "verbose: 0\n"
- diff <- userConfigDiff silent (globalFlags configFile) []
- assertBool (unlines $ "Should detect a difference:" : diff) $
- diff == [ "+ verbose: 0" ]
-
+ -- Create a new default config file in our test directory.
+ _ <- createDefaultConfigFile silent [] configFile
+ appendFile configFile "verbose: 0\n"
+ diff <- userConfigDiff silent (globalFlags configFile) []
+ assertBool (unlines $ "Should detect a difference:" : diff) $
+ diff == ["+ verbose: 0"]
canUpdateConfig :: Assertion
canUpdateConfig = bracketTest $ \configFile -> do
- -- Write a trivial cabal file.
- writeFile configFile "tests: True\n"
- -- Update the config file.
- userConfigUpdate silent (globalFlags configFile) []
- -- Load it again.
- updated <- loadConfig silent (Flag configFile)
- assertBool ("Field 'tests' should be True") $
- fromFlag (configTests $ savedConfigureFlags updated)
-
+ -- Write a trivial cabal file.
+ writeFile configFile "tests: True\n"
+ -- Update the config file.
+ userConfigUpdate silent (globalFlags configFile) []
+ -- Load it again.
+ updated <- loadConfig silent (Flag configFile)
+ assertBool ("Field 'tests' should be True") $
+ fromFlag (configTests $ savedConfigureFlags updated)
doubleUpdateConfig :: Assertion
doubleUpdateConfig = bracketTest $ \configFile -> do
- -- Create a new default config file in our test directory.
- _ <- createDefaultConfigFile silent [] configFile
- -- Update it twice.
- replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) []
- -- Load it again.
- updated <- loadConfig silent (Flag configFile)
-
- assertBool ("Field 'remote-repo' doesn't contain duplicates") $
- listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)
- assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $
- listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated)
- assertBool ("Field 'build-summary' doesn't contain duplicates") $
- listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)
-
+ -- Create a new default config file in our test directory.
+ _ <- createDefaultConfigFile silent [] configFile
+ -- Update it twice.
+ replicateM_ 2 $ userConfigUpdate silent (globalFlags configFile) []
+ -- Load it again.
+ updated <- loadConfig silent (Flag configFile)
+
+ assertBool ("Field 'remote-repo' doesn't contain duplicates") $
+ listUnique (map show . fromNubList . globalRemoteRepos $ savedGlobalFlags updated)
+ assertBool ("Field 'extra-prog-path' doesn't contain duplicates") $
+ listUnique (map show . fromNubList . configProgramPathExtra $ savedConfigureFlags updated)
+ assertBool ("Field 'build-summary' doesn't contain duplicates") $
+ listUnique (map show . fromNubList . installSummaryFile $ savedInstallFlags updated)
newDefaultConfig :: Assertion
newDefaultConfig = do
- sysTmpDir <- getTemporaryDirectory
- withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do
- let configFile = tmpDir </> "tmp.config"
- _ <- createDefaultConfigFile silent [] configFile
- exists <- doesFileExist configFile
- assertBool ("Config file should be written to " ++ configFile) exists
-
+ sysTmpDir <- getTemporaryDirectory
+ withTempDirectory silent sysTmpDir "cabal-test" $ \tmpDir -> do
+ let configFile = tmpDir </> "tmp.config"
+ _ <- createDefaultConfigFile silent [] configFile
+ exists <- doesFileExist configFile
+ assertBool ("Config file should be written to " ++ configFile) exists
globalFlags :: FilePath -> GlobalFlags
-globalFlags configFile = mempty { globalConfigFile = Flag configFile }
-
+globalFlags configFile = mempty{globalConfigFile = Flag configFile}
listUnique :: Ord a => [a] -> Bool
listUnique xs =
- let sorted = sort xs
- in nub sorted == xs
-
+ let sorted = sort xs
+ in nub sorted == xs
bracketTest :: (FilePath -> IO ()) -> Assertion
bracketTest =
- bracket testSetup testTearDown
+ bracket testSetup testTearDown
where
testSetup :: IO FilePath
testSetup = fmap (</> "test-user-config") getCurrentDirectory
testTearDown :: FilePath -> IO ()
testTearDown configFile =
- mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
+ mapM_ removeExistingFile [configFile, configFile ++ ".backup"]
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
index b361bdd8ff381211f3e4f1fbab2bbaa7dc47cb73..6aeadfd2c4eafeb07a43228e9b2a8771b9c14b7a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs
@@ -1,37 +1,43 @@
-{-# LANGUAGE RecordWildCards, NamedFieldPuns, KindSignatures, DataKinds #-}
-{-# LANGUAGE AllowAmbiguousTypes, TypeApplications, ScopedTypeVariables #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+
module UnitTests.Distribution.Client.VCS (tests) where
import Distribution.Client.Compat.Prelude
-import Distribution.Client.VCS
import Distribution.Client.RebuildMonad
- ( execRebuild )
+ ( execRebuild
+ )
+import Distribution.Client.Types.SourceRepo (SourceRepoProxy, SourceRepositoryPackage (..))
+import Distribution.Client.VCS
import Distribution.Simple.Program
-import Distribution.System ( buildOS, OS (Windows) )
+import Distribution.System (OS (Windows), buildOS)
import Distribution.Verbosity as Verbosity
-import Distribution.Client.Types.SourceRepo (SourceRepositoryPackage (..), SourceRepoProxy)
import Data.List (mapAccumL)
-import Data.Tuple
import qualified Data.Map as Map
import qualified Data.Set as Set
+import Data.Tuple
-import qualified Control.Monad.State as State
-import Control.Monad.State (StateT, liftIO, execStateT)
-import Control.Exception
import Control.Concurrent (threadDelay)
+import Control.Exception
+import Control.Monad.State (StateT, execStateT, liftIO)
+import qualified Control.Monad.State as State
-import System.IO
-import System.FilePath
import System.Directory
+import System.FilePath
+import System.IO
import System.Random
import Test.Tasty
-import Test.Tasty.QuickCheck
import Test.Tasty.ExpectedFailure
+import Test.Tasty.QuickCheck
import UnitTests.Distribution.Client.ArbitraryInstances
-import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack)
-
+import UnitTests.TempTestDir (removeDirectoryRecursiveHack, withTestDir)
-- | These tests take the following approach: we generate a pure representation
-- of a repository plus a corresponding real repository, and then run various
@@ -47,248 +53,317 @@ import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack)
-- directories. It picks a number of tags or commits from the source repo and
-- synchronises the destination directories to those target states, and then
-- checks that the working state is as expected (given the pure representation).
---
tests :: MTimeChange -> [TestTree]
-tests mtimeChange = map (localOption $ QuickCheckTests 10)
- [ ignoreInWindows "See issue #8048" $
- testGroup "git"
- [ testProperty "check VCS test framework" prop_framework_git
- , testProperty "cloneSourceRepo" prop_cloneRepo_git
- , testProperty "syncSourceRepos" prop_syncRepos_git
+tests mtimeChange =
+ map
+ (localOption $ QuickCheckTests 10)
+ [ ignoreInWindows "See issue #8048" $
+ testGroup
+ "git"
+ [ testProperty "check VCS test framework" prop_framework_git
+ , testProperty "cloneSourceRepo" prop_cloneRepo_git
+ , testProperty "syncSourceRepos" prop_syncRepos_git
+ ]
+ , --
+ ignoreTestBecause "for the moment they're not yet working" $
+ testGroup
+ "darcs"
+ [ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange
+ , testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange
+ , testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange
+ ]
+ , ignoreTestBecause "for the moment they're not yet working" $
+ testGroup
+ "pijul"
+ [ testProperty "check VCS test framework" prop_framework_pijul
+ , testProperty "cloneSourceRepo" prop_cloneRepo_pijul
+ , testProperty "syncSourceRepos" prop_syncRepos_pijul
+ ]
+ , ignoreTestBecause "for the moment they're not yet working" $
+ testGroup
+ "mercurial"
+ [ testProperty "check VCS test framework" prop_framework_hg
+ , testProperty "cloneSourceRepo" prop_cloneRepo_hg
+ , testProperty "syncSourceRepos" prop_syncRepos_hg
+ ]
]
-
- --
- , ignoreTestBecause "for the moment they're not yet working" $
- testGroup "darcs"
- [ testProperty "check VCS test framework" $ prop_framework_darcs mtimeChange
- , testProperty "cloneSourceRepo" $ prop_cloneRepo_darcs mtimeChange
- , testProperty "syncSourceRepos" $ prop_syncRepos_darcs mtimeChange
- ]
-
- , ignoreTestBecause "for the moment they're not yet working" $
- testGroup "pijul"
- [ testProperty "check VCS test framework" prop_framework_pijul
- , testProperty "cloneSourceRepo" prop_cloneRepo_pijul
- , testProperty "syncSourceRepos" prop_syncRepos_pijul
- ]
-
- , ignoreTestBecause "for the moment they're not yet working" $
- testGroup "mercurial"
- [ testProperty "check VCS test framework" prop_framework_hg
- , testProperty "cloneSourceRepo" prop_cloneRepo_hg
- , testProperty "syncSourceRepos" prop_syncRepos_hg
- ]
-
- ]
-
- where ignoreInWindows msg = case buildOS of
- Windows -> ignoreTestBecause msg
- _ -> id
+ where
+ ignoreInWindows msg = case buildOS of
+ Windows -> ignoreTestBecause msg
+ _ -> id
prop_framework_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property
prop_framework_git =
- ioProperty
- . prop_framework vcsGit vcsTestDriverGit
- . WithBranchingSupport
+ ioProperty
+ . prop_framework vcsGit vcsTestDriverGit
+ . WithBranchingSupport
prop_framework_darcs :: MTimeChange -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property
prop_framework_darcs mtimeChange =
- ioProperty
- . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)
- . WithoutBranchingSupport
+ ioProperty
+ . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)
+ . WithoutBranchingSupport
prop_framework_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
prop_framework_pijul =
- ioProperty
- . prop_framework vcsPijul vcsTestDriverPijul
- . WithBranchingSupport
+ ioProperty
+ . prop_framework vcsPijul vcsTestDriverPijul
+ . WithBranchingSupport
prop_framework_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
prop_framework_hg =
- ioProperty
- . prop_framework vcsHg vcsTestDriverHg
- . WithBranchingSupport
+ ioProperty
+ . prop_framework vcsHg vcsTestDriverHg
+ . WithBranchingSupport
prop_cloneRepo_git :: BranchingRepoRecipe 'SubmodulesSupported -> Property
prop_cloneRepo_git =
- ioProperty
- . prop_cloneRepo vcsGit vcsTestDriverGit
- . WithBranchingSupport
-
-prop_cloneRepo_darcs :: MTimeChange
- -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property
+ ioProperty
+ . prop_cloneRepo vcsGit vcsTestDriverGit
+ . WithBranchingSupport
+
+prop_cloneRepo_darcs
+ :: MTimeChange
+ -> NonBranchingRepoRecipe 'SubmodulesNotSupported
+ -> Property
prop_cloneRepo_darcs mtimeChange =
- ioProperty
- . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)
- . WithoutBranchingSupport
+ ioProperty
+ . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)
+ . WithoutBranchingSupport
prop_cloneRepo_pijul :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
prop_cloneRepo_pijul =
- ioProperty
- . prop_cloneRepo vcsPijul vcsTestDriverPijul
- . WithBranchingSupport
+ ioProperty
+ . prop_cloneRepo vcsPijul vcsTestDriverPijul
+ . WithBranchingSupport
prop_cloneRepo_hg :: BranchingRepoRecipe 'SubmodulesNotSupported -> Property
prop_cloneRepo_hg =
- ioProperty
- . prop_cloneRepo vcsHg vcsTestDriverHg
- . WithBranchingSupport
+ ioProperty
+ . prop_cloneRepo vcsHg vcsTestDriverHg
+ . WithBranchingSupport
-prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed
- -> BranchingRepoRecipe 'SubmodulesSupported -> Property
+prop_syncRepos_git
+ :: RepoDirSet
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> BranchingRepoRecipe 'SubmodulesSupported
+ -> Property
prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =
- ioProperty
- . prop_syncRepos vcsGit vcsTestDriverGit
- destRepoDirs syncTargetSetIterations seed
- . WithBranchingSupport
-
-prop_syncRepos_darcs :: MTimeChange
- -> RepoDirSet -> SyncTargetIterations -> PrngSeed
- -> NonBranchingRepoRecipe 'SubmodulesNotSupported -> Property
-prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed =
- ioProperty
- . prop_syncRepos vcsDarcs (vcsTestDriverDarcs mtimeChange)
- destRepoDirs syncTargetSetIterations seed
- . WithoutBranchingSupport
-
-prop_syncRepos_pijul :: RepoDirSet -> SyncTargetIterations -> PrngSeed
- -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property
+ ioProperty
+ . prop_syncRepos
+ vcsGit
+ vcsTestDriverGit
+ destRepoDirs
+ syncTargetSetIterations
+ seed
+ . WithBranchingSupport
+
+prop_syncRepos_darcs
+ :: MTimeChange
+ -> RepoDirSet
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> NonBranchingRepoRecipe 'SubmodulesNotSupported
+ -> Property
+prop_syncRepos_darcs mtimeChange destRepoDirs syncTargetSetIterations seed =
+ ioProperty
+ . prop_syncRepos
+ vcsDarcs
+ (vcsTestDriverDarcs mtimeChange)
+ destRepoDirs
+ syncTargetSetIterations
+ seed
+ . WithoutBranchingSupport
+
+prop_syncRepos_pijul
+ :: RepoDirSet
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> BranchingRepoRecipe 'SubmodulesNotSupported
+ -> Property
prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed =
- ioProperty
- . prop_syncRepos vcsPijul vcsTestDriverPijul
- destRepoDirs syncTargetSetIterations seed
- . WithBranchingSupport
-
-prop_syncRepos_hg :: RepoDirSet -> SyncTargetIterations -> PrngSeed
- -> BranchingRepoRecipe 'SubmodulesNotSupported -> Property
+ ioProperty
+ . prop_syncRepos
+ vcsPijul
+ vcsTestDriverPijul
+ destRepoDirs
+ syncTargetSetIterations
+ seed
+ . WithBranchingSupport
+
+prop_syncRepos_hg
+ :: RepoDirSet
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> BranchingRepoRecipe 'SubmodulesNotSupported
+ -> Property
prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed =
- ioProperty
- . prop_syncRepos vcsHg vcsTestDriverHg
- destRepoDirs syncTargetSetIterations seed
- . WithBranchingSupport
+ ioProperty
+ . prop_syncRepos
+ vcsHg
+ vcsTestDriverHg
+ destRepoDirs
+ syncTargetSetIterations
+ seed
+ . WithBranchingSupport
-- ------------------------------------------------------------
+
-- * General test setup
+
-- ------------------------------------------------------------
-testSetup :: VCS Program
- -> (Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver)
- -> RepoRecipe submodules
- -> (VCSTestDriver -> FilePath -> RepoState -> IO a)
- -> IO a
+testSetup
+ :: VCS Program
+ -> ( Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
+ )
+ -> RepoRecipe submodules
+ -> (VCSTestDriver -> FilePath -> RepoState -> IO a)
+ -> IO a
testSetup vcs mkVCSTestDriver repoRecipe theTest = do
- -- test setup
- vcs' <- configureVCS verbosity vcs
- withTestDir verbosity "vcstest" $ \tmpdir -> do
- let srcRepoPath = tmpdir </> "src"
- submodulesPath = tmpdir </> "submodules"
- vcsDriver = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath
- repoState <- createRepo vcsDriver repoRecipe
-
- -- actual test
- result <- theTest vcsDriver tmpdir repoState
-
- return result
+ -- test setup
+ vcs' <- configureVCS verbosity vcs
+ withTestDir verbosity "vcstest" $ \tmpdir -> do
+ let srcRepoPath = tmpdir </> "src"
+ submodulesPath = tmpdir </> "submodules"
+ vcsDriver = mkVCSTestDriver verbosity vcs' submodulesPath srcRepoPath
+ repoState <- createRepo vcsDriver repoRecipe
+
+ -- actual test
+ result <- theTest vcsDriver tmpdir repoState
+
+ return result
where
verbosity = silent
-- ------------------------------------------------------------
+
-- * Test 1: VCS infrastructure
+
-- ------------------------------------------------------------
-- | This test simply checks that the test infrastructure works. It constructs
-- a repository on disk and then checks out every tag or commit and checks that
-- the working state is the same as the pure representation.
---
-prop_framework :: VCS Program
- -> (Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver)
- -> RepoRecipe submodules
- -> IO ()
+prop_framework
+ :: VCS Program
+ -> ( Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
+ )
+ -> RepoRecipe submodules
+ -> IO ()
prop_framework vcs mkVCSTestDriver repoRecipe =
- testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
- mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
+ testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
+ mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
where
-- Check for any given tag/commit in the 'RepoState' that the working state
-- matches the actual working state from the repository at that tag/commit.
- checkAtTag VCSTestDriver {..} tmpdir (tagname, expectedState) =
+ checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) =
case vcsCheckoutTag of
-- We handle two cases: inplace checkouts for VCSs that support it
-- (e.g. git) and separate dir otherwise (e.g. darcs)
Left checkoutInplace -> do
checkoutInplace tagname
checkExpectedWorkingState vcsIgnoreFiles vcsRepoRoot expectedState
-
Right checkoutCloneTo -> do
checkoutCloneTo tagname destRepoPath
checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
removeDirectoryRecursiveHack silent destRepoPath
- where
- destRepoPath = tmpdir </> "dest"
-
+ where
+ destRepoPath = tmpdir </> "dest"
-- ------------------------------------------------------------
+
-- * Test 2: 'cloneSourceRepo'
+
-- ------------------------------------------------------------
-prop_cloneRepo :: VCS Program
- -> (Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver)
- -> RepoRecipe submodules
- -> IO ()
+prop_cloneRepo
+ :: VCS Program
+ -> ( Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
+ )
+ -> RepoRecipe submodules
+ -> IO ()
prop_cloneRepo vcs mkVCSTestDriver repoRecipe =
- testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
- mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
+ testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
+ mapM_ (checkAtTag vcsDriver tmpdir) (Map.toList (allTags repoState))
where
checkAtTag VCSTestDriver{..} tmpdir (tagname, expectedState) = do
- cloneSourceRepo verbosity vcsVCS repo destRepoPath
- checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
- removeDirectoryRecursiveHack verbosity destRepoPath
+ cloneSourceRepo verbosity vcsVCS repo destRepoPath
+ checkExpectedWorkingState vcsIgnoreFiles destRepoPath expectedState
+ removeDirectoryRecursiveHack verbosity destRepoPath
where
destRepoPath = tmpdir </> "dest"
- repo = SourceRepositoryPackage
- { srpType = vcsRepoType vcsVCS
+ repo =
+ SourceRepositoryPackage
+ { srpType = vcsRepoType vcsVCS
, srpLocation = vcsRepoRoot
- , srpTag = Just tagname
- , srpBranch = Nothing
- , srpSubdir = []
- , srpCommand = []
+ , srpTag = Just tagname
+ , srpBranch = Nothing
+ , srpSubdir = []
+ , srpCommand = []
}
verbosity = silent
-
-- ------------------------------------------------------------
+
-- * Test 3: 'syncSourceRepos'
+
-- ------------------------------------------------------------
-newtype RepoDirSet = RepoDirSet Int deriving Show
-newtype SyncTargetIterations = SyncTargetIterations Int deriving Show
-newtype PrngSeed = PrngSeed Int deriving Show
-
-prop_syncRepos :: VCS Program
- -> (Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver)
- -> RepoDirSet
- -> SyncTargetIterations
- -> PrngSeed
- -> RepoRecipe submodules
- -> IO ()
-prop_syncRepos vcs mkVCSTestDriver
- repoDirs syncTargetSetIterations seed repoRecipe =
+newtype RepoDirSet = RepoDirSet Int deriving (Show)
+newtype SyncTargetIterations = SyncTargetIterations Int deriving (Show)
+newtype PrngSeed = PrngSeed Int deriving (Show)
+
+prop_syncRepos
+ :: VCS Program
+ -> ( Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
+ )
+ -> RepoDirSet
+ -> SyncTargetIterations
+ -> PrngSeed
+ -> RepoRecipe submodules
+ -> IO ()
+prop_syncRepos
+ vcs
+ mkVCSTestDriver
+ repoDirs
+ syncTargetSetIterations
+ seed
+ repoRecipe =
testSetup vcs mkVCSTestDriver repoRecipe $ \vcsDriver tmpdir repoState ->
- let srcRepoPath = vcsRepoRoot vcsDriver
+ let srcRepoPath = vcsRepoRoot vcsDriver
destRepoPaths = map (tmpdir </>) (getRepoDirs repoDirs)
- in checkSyncRepos verbosity vcsDriver repoState
- srcRepoPath destRepoPaths
- syncTargetSetIterations seed
- where
- verbosity = silent
-
- getRepoDirs :: RepoDirSet -> [FilePath]
- getRepoDirs (RepoDirSet n) =
- [ "dest" ++ show i | i <- [1..n] ]
+ in checkSyncRepos
+ verbosity
+ vcsDriver
+ repoState
+ srcRepoPath
+ destRepoPaths
+ syncTargetSetIterations
+ seed
+ where
+ verbosity = silent
+ getRepoDirs :: RepoDirSet -> [FilePath]
+ getRepoDirs (RepoDirSet n) =
+ ["dest" ++ show i | i <- [1 .. n]]
-- | The purpose of this test is to check that irrespective of the local cached
-- repo dir we can sync it to an arbitrary target state. So we do that by
@@ -303,7 +378,6 @@ prop_syncRepos vcs mkVCSTestDriver
-- target repo dirs, pick a sequence of (lists of) sync targets from the
-- 'RepoState' and synchronise the target dirs with those targets, checking for
-- each one that the actual working state matches the expected repo state.
---
checkSyncRepos
:: Verbosity
-> VCSTestDriver
@@ -313,32 +387,49 @@ checkSyncRepos
-> SyncTargetIterations
-> PrngSeed
-> IO ()
-checkSyncRepos verbosity VCSTestDriver { vcsVCS = vcs, vcsIgnoreFiles }
- repoState srcRepoPath destRepoPath
- (SyncTargetIterations syncTargetSetIterations) (PrngSeed seed) =
+checkSyncRepos
+ verbosity
+ VCSTestDriver{vcsVCS = vcs, vcsIgnoreFiles}
+ repoState
+ srcRepoPath
+ destRepoPath
+ (SyncTargetIterations syncTargetSetIterations)
+ (PrngSeed seed) =
mapM_ checkSyncTargetSet syncTargetSets
- where
- checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO ()
- checkSyncTargetSet syncTargets = do
- _ <- execRebuild "root-unused" $
- syncSourceRepos verbosity vcs
- [ (repo, repoPath)
- | (repo, repoPath, _) <- syncTargets ]
- sequence_
- [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState
- | (_, repoPath, workingState) <- syncTargets ]
-
- syncTargetSets = take syncTargetSetIterations
- $ pickSyncTargetSets (vcsRepoType vcs) repoState
- srcRepoPath destRepoPath
- (mkStdGen seed)
-
-pickSyncTargetSets :: RepoType -> RepoState
- -> FilePath -> [FilePath]
- -> StdGen
- -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]]
+ where
+ checkSyncTargetSet :: [(SourceRepoProxy, FilePath, RepoWorkingState)] -> IO ()
+ checkSyncTargetSet syncTargets = do
+ _ <-
+ execRebuild "root-unused" $
+ syncSourceRepos
+ verbosity
+ vcs
+ [ (repo, repoPath)
+ | (repo, repoPath, _) <- syncTargets
+ ]
+ sequence_
+ [ checkExpectedWorkingState vcsIgnoreFiles repoPath workingState
+ | (_, repoPath, workingState) <- syncTargets
+ ]
+
+ syncTargetSets =
+ take syncTargetSetIterations $
+ pickSyncTargetSets
+ (vcsRepoType vcs)
+ repoState
+ srcRepoPath
+ destRepoPath
+ (mkStdGen seed)
+
+pickSyncTargetSets
+ :: RepoType
+ -> RepoState
+ -> FilePath
+ -> [FilePath]
+ -> StdGen
+ -> [[(SourceRepoProxy, FilePath, RepoWorkingState)]]
pickSyncTargetSets repoType repoState srcRepoPath dstReposPath =
- assert (Map.size (allTags repoState) > 0) $
+ assert (Map.size (allTags repoState) > 0) $
unfoldr (Just . swap . pickSyncTargetSet)
where
pickSyncTargetSet :: Rand [(SourceRepoProxy, FilePath, RepoWorkingState)]
@@ -346,40 +437,44 @@ pickSyncTargetSets repoType repoState srcRepoPath dstReposPath =
pickSyncTarget :: FilePath -> Rand (SourceRepoProxy, FilePath, RepoWorkingState)
pickSyncTarget destRepoPath prng =
- (prng', (repo, destRepoPath, workingState))
+ (prng', (repo, destRepoPath, workingState))
where
- repo = SourceRepositoryPackage
- { srpType = repoType
- , srpLocation = srcRepoPath
- , srpTag = Just tag
- , srpBranch = Nothing
- , srpSubdir = Proxy
- , srpCommand = []
- }
+ repo =
+ SourceRepositoryPackage
+ { srpType = repoType
+ , srpLocation = srcRepoPath
+ , srpTag = Just tag
+ , srpBranch = Nothing
+ , srpSubdir = Proxy
+ , srpCommand = []
+ }
(tag, workingState) = Map.elemAt tagIdx (allTags repoState)
- (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng
+ (tagIdx, prng') = randomR (0, Map.size (allTags repoState) - 1) prng
type Rand a = StdGen -> (StdGen, a)
instance Arbitrary RepoDirSet where
arbitrary =
- sized $ \n -> oneof $ [ RepoDirSet <$> pure 1 ]
- ++ [ RepoDirSet <$> choose (2,5) | n >= 3 ]
+ sized $ \n ->
+ oneof $
+ [RepoDirSet <$> pure 1]
+ ++ [RepoDirSet <$> choose (2, 5) | n >= 3]
shrink (RepoDirSet n) =
- [ RepoDirSet i | i <- shrink n, i > 0 ]
+ [RepoDirSet i | i <- shrink n, i > 0]
instance Arbitrary SyncTargetIterations where
arbitrary =
- sized $ \n -> SyncTargetIterations <$> elements [ 1 .. min 20 (n + 1) ]
+ sized $ \n -> SyncTargetIterations <$> elements [1 .. min 20 (n + 1)]
shrink (SyncTargetIterations n) =
- [ SyncTargetIterations i | i <- shrink n, i > 0 ]
+ [SyncTargetIterations i | i <- shrink n, i > 0]
instance Arbitrary PrngSeed where
arbitrary = PrngSeed <$> arbitraryBoundedRandom
-
-- ------------------------------------------------------------
+
-- * Instructions for constructing repositories
+
-- ------------------------------------------------------------
-- These instructions for constructing a repository can be interpreted in two
@@ -397,42 +492,42 @@ instance KnownSubmodulesSupport 'SubmodulesSupported where
instance KnownSubmodulesSupport 'SubmodulesNotSupported where
submoduleSupport = SubmodulesNotSupported
-data FileUpdate = FileUpdate FilePath String
- deriving Show
+data FileUpdate = FileUpdate FilePath String
+ deriving (Show)
data SubmoduleAdd = SubmoduleAdd FilePath FilePath (Commit 'SubmodulesSupported)
- deriving Show
+ deriving (Show)
newtype Commit (submodules :: SubmodulesSupport)
= Commit [Either FileUpdate SubmoduleAdd]
- deriving Show
+ deriving (Show)
data TaggedCommits (submodules :: SubmodulesSupport)
- = TaggedCommits TagName [Commit submodules]
- deriving Show
+ = TaggedCommits TagName [Commit submodules]
+ deriving (Show)
data BranchCommits (submodules :: SubmodulesSupport)
= BranchCommits BranchName [Commit submodules]
- deriving Show
+ deriving (Show)
type BranchName = String
-type TagName = String
+type TagName = String
-- | Instructions to make a repository without branches, for VCSs that do not
-- support branches (e.g. darcs).
newtype NonBranchingRepoRecipe submodules
= NonBranchingRepoRecipe [TaggedCommits submodules]
- deriving Show
+ deriving (Show)
-- | Instructions to make a repository with branches, for VCSs that do
-- support branches (e.g. git).
newtype BranchingRepoRecipe submodules
= BranchingRepoRecipe [Either (TaggedCommits submodules) (BranchCommits submodules)]
- deriving Show
+ deriving (Show)
data RepoRecipe submodules
- = WithBranchingSupport (BranchingRepoRecipe submodules)
+ = WithBranchingSupport (BranchingRepoRecipe submodules)
| WithoutBranchingSupport (NonBranchingRepoRecipe submodules)
- deriving Show
+ deriving (Show)
-- ---------------------------------------------------------------------------
-- Arbitrary instances for them
@@ -443,28 +538,30 @@ genFileName = (\c -> "file" </> [c]) <$> choose ('A', 'E')
instance Arbitrary FileUpdate where
arbitrary = genOnlyFileUpdate
where
- genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent
- genFileContent = vectorOf 10 (choose ('#', '~'))
+ genOnlyFileUpdate = FileUpdate <$> genFileName <*> genFileContent
+ genFileContent = vectorOf 10 (choose ('#', '~'))
instance Arbitrary SubmoduleAdd where
arbitrary = genOnlySubmoduleAdd
where
genOnlySubmoduleAdd = SubmoduleAdd <$> genFileName <*> genSubmoduleSrc <*> arbitrary
- genSubmoduleSrc = vectorOf 20 (choose ('a', 'z'))
+ genSubmoduleSrc = vectorOf 20 (choose ('a', 'z'))
-instance forall submodules.KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where
+instance forall submodules. KnownSubmodulesSupport submodules => Arbitrary (Commit submodules) where
arbitrary = Commit <$> shortListOf1 5 fileUpdateOrSubmoduleAdd
where
fileUpdateOrSubmoduleAdd =
case submoduleSupport @submodules of
- SubmodulesSupported -> frequency [ (10, Left <$> arbitrary)
- , (1, Right <$> arbitrary)
- ]
+ SubmodulesSupported ->
+ frequency
+ [ (10, Left <$> arbitrary)
+ , (1, Right <$> arbitrary)
+ ]
SubmodulesNotSupported -> Left <$> arbitrary
shrink (Commit writes) = Commit <$> filter (not . null) (shrink writes)
instance KnownSubmodulesSupport submodules => Arbitrary (TaggedCommits submodules) where
- arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary
+ arbitrary = TaggedCommits <$> genTagName <*> shortListOf1 5 arbitrary
where
genTagName = ("tag_" ++) <$> shortListOf1 5 (choose ('A', 'Z'))
shrink (TaggedCommits tag commits) =
@@ -475,7 +572,7 @@ instance KnownSubmodulesSupport submodules => Arbitrary (BranchCommits submodule
where
genBranchName =
sized $ \n ->
- (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A'..'E'])
+ (\c -> "branch_" ++ [c]) <$> elements (take (max 1 n) ['A' .. 'E'])
shrink (BranchCommits branch commits) =
BranchCommits branch <$> filter (not . null) (shrink commits)
@@ -488,15 +585,18 @@ instance KnownSubmodulesSupport submodules => Arbitrary (NonBranchingRepoRecipe
instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe submodules) where
arbitrary = BranchingRepoRecipe <$> shortListOf1 15 taggedOrBranch
where
- taggedOrBranch = frequency [ (3, Left <$> arbitrary)
- , (1, Right <$> arbitrary)
- ]
+ taggedOrBranch =
+ frequency
+ [ (3, Left <$> arbitrary)
+ , (1, Right <$> arbitrary)
+ ]
shrink (BranchingRepoRecipe xs) =
BranchingRepoRecipe <$> filter (not . null) (shrink xs)
-
-- ------------------------------------------------------------
+
-- * A pure model of repository state
+
-- ------------------------------------------------------------
-- | The full state of a repository. In particular it records the full working
@@ -506,115 +606,124 @@ instance KnownSubmodulesSupport submodules => Arbitrary (BranchingRepoRecipe sub
--
-- This allows us to compare expected working states with the actual files in
-- the working directory of a repository. See 'checkExpectedWorkingState'.
---
-data RepoState =
- RepoState {
- currentBranch :: BranchName,
- currentWorking :: RepoWorkingState,
- allTags :: Map TagOrCommitId RepoWorkingState,
- allBranches :: Map BranchName RepoWorkingState
- }
- deriving Show
+data RepoState = RepoState
+ { currentBranch :: BranchName
+ , currentWorking :: RepoWorkingState
+ , allTags :: Map TagOrCommitId RepoWorkingState
+ , allBranches :: Map BranchName RepoWorkingState
+ }
+ deriving (Show)
type RepoWorkingState = Map FilePath String
-type CommitId = String
-type TagOrCommitId = String
-
+type CommitId = String
+type TagOrCommitId = String
------------------------------------------------------------------------------
-- Functions used to interpret instructions for constructing repositories
initialRepoState :: RepoState
initialRepoState =
- RepoState {
- currentBranch = "branch_master",
- currentWorking = Map.empty,
- allTags = Map.empty,
- allBranches = Map.empty
+ RepoState
+ { currentBranch = "branch_master"
+ , currentWorking = Map.empty
+ , allTags = Map.empty
+ , allBranches = Map.empty
}
updateFile :: FilePath -> String -> RepoState -> RepoState
updateFile filename content state@RepoState{currentWorking} =
let removeSubmodule = Map.filterWithKey (\path _ -> not $ filename `isPrefixOf` path) currentWorking
- in state { currentWorking = Map.insert filename content removeSubmodule }
+ in state{currentWorking = Map.insert filename content removeSubmodule}
addSubmodule :: FilePath -> RepoState -> RepoState -> RepoState
addSubmodule submodulePath submoduleState mainState =
let newFiles = Map.mapKeys (submodulePath </>) (currentWorking submoduleState)
- removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path ) (currentWorking mainState)
+ removeSubmodule = Map.filterWithKey (\path _ -> not $ submodulePath `isPrefixOf` path) (currentWorking mainState)
newWorking = Map.union removeSubmodule newFiles
- in mainState { currentWorking = newWorking}
+ in mainState{currentWorking = newWorking}
addTagOrCommit :: TagOrCommitId -> RepoState -> RepoState
addTagOrCommit commit state@RepoState{currentWorking, allTags} =
- state { allTags = Map.insert commit currentWorking allTags }
+ state{allTags = Map.insert commit currentWorking allTags}
switchBranch :: BranchName -> RepoState -> RepoState
switchBranch branch state@RepoState{currentWorking, currentBranch, allBranches} =
-- Use updated allBranches to cover case of switching to the same branch
- let allBranches' = Map.insert currentBranch currentWorking allBranches in
- state {
- currentBranch = branch,
- currentWorking = case Map.lookup branch allBranches' of
- Just working -> working
- -- otherwise we're creating a new branch, which starts
- -- from our current branch state
- Nothing -> currentWorking,
- allBranches = allBranches'
- }
-
+ let allBranches' = Map.insert currentBranch currentWorking allBranches
+ in state
+ { currentBranch = branch
+ , currentWorking = case Map.lookup branch allBranches' of
+ Just working -> working
+ -- otherwise we're creating a new branch, which starts
+ -- from our current branch state
+ Nothing -> currentWorking
+ , allBranches = allBranches'
+ }
-- ------------------------------------------------------------
+
-- * Comparing on-disk with expected 'RepoWorkingState'
+
-- ------------------------------------------------------------
-- | Compare expected working states with the actual files in
-- the working directory of a repository.
---
-checkExpectedWorkingState :: Set FilePath
- -> FilePath -> RepoWorkingState -> IO ()
+checkExpectedWorkingState
+ :: Set FilePath
+ -> FilePath
+ -> RepoWorkingState
+ -> IO ()
checkExpectedWorkingState ignore repoPath expectedState = do
- currentState <- getCurrentWorkingState ignore repoPath
- unless (currentState == expectedState) $
- throwIO (WorkingStateMismatch expectedState currentState)
+ currentState <- getCurrentWorkingState ignore repoPath
+ unless (currentState == expectedState) $
+ throwIO (WorkingStateMismatch expectedState currentState)
-data WorkingStateMismatch =
- WorkingStateMismatch RepoWorkingState -- expected
- RepoWorkingState -- actual
- deriving Show
+data WorkingStateMismatch
+ = WorkingStateMismatch
+ RepoWorkingState -- expected
+ RepoWorkingState -- actual
+ deriving (Show)
instance Exception WorkingStateMismatch
getCurrentWorkingState :: Set FilePath -> FilePath -> IO RepoWorkingState
getCurrentWorkingState ignore repoRoot = do
- entries <- getDirectoryContentsRecursive ignore repoRoot ""
- Map.fromList <$> mapM getFileEntry
- [ file | (file, isDir) <- entries, not isDir ]
+ entries <- getDirectoryContentsRecursive ignore repoRoot ""
+ Map.fromList
+ <$> mapM
+ getFileEntry
+ [file | (file, isDir) <- entries, not isDir]
where
- getFileEntry name =
- withBinaryFile (repoRoot </> name) ReadMode $ \h -> do
- str <- hGetContents h
- _ <- evaluate (length str)
- return (name, str)
-
-getDirectoryContentsRecursive :: Set FilePath -> FilePath -> FilePath
- -> IO [(FilePath, Bool)]
+ getFileEntry name =
+ withBinaryFile (repoRoot </> name) ReadMode $ \h -> do
+ str <- hGetContents h
+ _ <- evaluate (length str)
+ return (name, str)
+
+getDirectoryContentsRecursive
+ :: Set FilePath
+ -> FilePath
+ -> FilePath
+ -> IO [(FilePath, Bool)]
getDirectoryContentsRecursive ignore dir0 dir = do
- entries <- getDirectoryContents (dir0 </> dir)
- entries' <- sequence
- [ do isdir <- doesDirectoryExist (dir0 </> dir </> entry)
- return (dir </> entry, isdir)
- | entry <- entries
- , not (isPrefixOf "." entry)
- , (dir </> entry) `Set.notMember` ignore
- ]
- let subdirs = [ d | (d, True) <- entries' ]
- subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs
- return (concat (entries' : subdirEntries))
-
+ entries <- getDirectoryContents (dir0 </> dir)
+ entries' <-
+ sequence
+ [ do
+ isdir <- doesDirectoryExist (dir0 </> dir </> entry)
+ return (dir </> entry, isdir)
+ | entry <- entries
+ , not (isPrefixOf "." entry)
+ , (dir </> entry) `Set.notMember` ignore
+ ]
+ let subdirs = [d | (d, True) <- entries']
+ subdirEntries <- mapM (getDirectoryContentsRecursive ignore dir0) subdirs
+ return (concat (entries' : subdirEntries))
-- ------------------------------------------------------------
+
-- * Executing instructions to make on-disk VCS repos
+
-- ------------------------------------------------------------
-- | Execute the instructions in a 'RepoRecipe' using the given 'VCSTestDriver'
@@ -623,47 +732,51 @@ getDirectoryContentsRecursive ignore dir0 dir = do
-- This also returns a 'RepoState'. This is done as part of construction to
-- support VCSs like git that have commit ids, so that those commit ids can be
-- included in the 'RepoState's 'allTags' set.
---
createRepo :: VCSTestDriver -> RepoRecipe submodules -> IO RepoState
createRepo vcsDriver@VCSTestDriver{vcsRepoRoot, vcsInit} recipe = do
- createDirectoryIfMissing True vcsRepoRoot
- createDirectoryIfMissing True (vcsRepoRoot </> "file")
- vcsInit
- execStateT createRepoAction initialRepoState
+ createDirectoryIfMissing True vcsRepoRoot
+ createDirectoryIfMissing True (vcsRepoRoot </> "file")
+ vcsInit
+ execStateT createRepoAction initialRepoState
where
createRepoAction :: StateT RepoState IO ()
createRepoAction = case recipe of
WithoutBranchingSupport r -> execNonBranchingRepoRecipe vcsDriver r
- WithBranchingSupport r -> execBranchingRepoRecipe vcsDriver r
+ WithBranchingSupport r -> execBranchingRepoRecipe vcsDriver r
type CreateRepoAction a = VCSTestDriver -> a -> StateT RepoState IO ()
execNonBranchingRepoRecipe :: CreateRepoAction (NonBranchingRepoRecipe submodules)
execNonBranchingRepoRecipe vcsDriver (NonBranchingRepoRecipe taggedCommits) =
- mapM_ (execTaggdCommits vcsDriver) taggedCommits
+ mapM_ (execTaggdCommits vcsDriver) taggedCommits
execBranchingRepoRecipe :: CreateRepoAction (BranchingRepoRecipe submodules)
execBranchingRepoRecipe vcsDriver (BranchingRepoRecipe taggedCommits) =
- mapM_ (either (execTaggdCommits vcsDriver)
- (execBranchCommits vcsDriver))
- taggedCommits
+ mapM_
+ ( either
+ (execTaggdCommits vcsDriver)
+ (execBranchCommits vcsDriver)
+ )
+ taggedCommits
execBranchCommits :: CreateRepoAction (BranchCommits submodules)
-execBranchCommits vcsDriver@VCSTestDriver{vcsSwitchBranch}
- (BranchCommits branch commits) = do
+execBranchCommits
+ vcsDriver@VCSTestDriver{vcsSwitchBranch}
+ (BranchCommits branch commits) = do
mapM_ (execCommit vcsDriver) commits
-- add commits and then switch branch
State.modify (switchBranch branch)
state <- State.get -- repo state after the commits and branch switch
liftIO $ vcsSwitchBranch state branch
- -- It may seem odd that we add commits on the existing branch and then
- -- switch branch. In part this is because git cannot branch from an empty
- -- repo state, it complains that the master branch doesn't exist yet.
+-- It may seem odd that we add commits on the existing branch and then
+-- switch branch. In part this is because git cannot branch from an empty
+-- repo state, it complains that the master branch doesn't exist yet.
execTaggdCommits :: CreateRepoAction (TaggedCommits submodules)
-execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState}
- (TaggedCommits tagname commits) = do
+execTaggdCommits
+ vcsDriver@VCSTestDriver{vcsTagState}
+ (TaggedCommits tagname commits) = do
mapM_ (execCommit vcsDriver) commits
-- add commits then tag
state <- State.get -- repo state after the commits
@@ -672,31 +785,33 @@ execTaggdCommits vcsDriver@VCSTestDriver{vcsTagState}
execCommit :: CreateRepoAction (Commit submodules)
execCommit vcsDriver@VCSTestDriver{..} (Commit fileUpdates) = do
- mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates
- state <- State.get -- existing state, not updated
- mcommit <- liftIO $ vcsCommitChanges state
- State.modify (maybe id addTagOrCommit mcommit)
+ mapM_ (either (execFileUpdate vcsDriver) (execSubmoduleAdd vcsDriver)) fileUpdates
+ state <- State.get -- existing state, not updated
+ mcommit <- liftIO $ vcsCommitChanges state
+ State.modify (maybe id addTagOrCommit mcommit)
execFileUpdate :: CreateRepoAction FileUpdate
execFileUpdate VCSTestDriver{..} (FileUpdate filename content) = do
- isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot </> filename)
- liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot </> filename)
- liftIO $ writeFile (vcsRepoRoot </> filename) content
- state <- State.get -- existing state, not updated
- liftIO $ vcsAddFile state filename
- State.modify (updateFile filename content)
+ isDir <- liftIO $ doesDirectoryExist (vcsRepoRoot </> filename)
+ liftIO . when isDir $ removeDirectoryRecursive (vcsRepoRoot </> filename)
+ liftIO $ writeFile (vcsRepoRoot </> filename) content
+ state <- State.get -- existing state, not updated
+ liftIO $ vcsAddFile state filename
+ State.modify (updateFile filename content)
execSubmoduleAdd :: CreateRepoAction SubmoduleAdd
execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) = do
- submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source
- let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]]
- submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe
- mainState <- State.get -- existing state, not updated
- liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath
- State.modify $ addSubmodule submodulePath submoduleState
+ submoduleVcsDriver <- liftIO $ vcsSubmoduleDriver vcsDriver source
+ let submoduleRecipe = WithoutBranchingSupport $ NonBranchingRepoRecipe [TaggedCommits "submodule-tag" [submoduleCommit]]
+ submoduleState <- liftIO $ createRepo submoduleVcsDriver submoduleRecipe
+ mainState <- State.get -- existing state, not updated
+ liftIO $ vcsAddSubmodule vcsDriver mainState (vcsRepoRoot submoduleVcsDriver) submodulePath
+ State.modify $ addSubmodule submodulePath submoduleState
-- ------------------------------------------------------------
+
-- * VCSTestDriver for various VCSs
+
-- ------------------------------------------------------------
-- | Extends 'VCS' with extra methods to construct a repository. Used by
@@ -707,57 +822,62 @@ execSubmoduleAdd vcsDriver (SubmoduleAdd submodulePath source submoduleCommit) =
-- (like adding a file to the tracked set, or creating a new branch).
--
-- The driver instance knows the particular repo directory.
---
-data VCSTestDriver = VCSTestDriver {
- vcsVCS :: VCS ConfiguredProgram,
- vcsRepoRoot :: FilePath,
- vcsIgnoreFiles :: Set FilePath,
- vcsInit :: IO (),
- vcsAddFile :: RepoState -> FilePath -> IO (),
- vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver,
- vcsAddSubmodule :: RepoState -> FilePath -> FilePath -> IO (),
- vcsCommitChanges :: RepoState -> IO (Maybe CommitId),
- vcsTagState :: RepoState -> TagName -> IO (),
- vcsSwitchBranch :: RepoState -> BranchName -> IO (),
- vcsCheckoutTag :: Either (TagName -> IO ())
- (TagName -> FilePath -> IO ())
- }
-
-
-vcsTestDriverGit :: Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver
-vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
- VCSTestDriver {
- vcsVCS = vcs
+data VCSTestDriver = VCSTestDriver
+ { vcsVCS :: VCS ConfiguredProgram
+ , vcsRepoRoot :: FilePath
+ , vcsIgnoreFiles :: Set FilePath
+ , vcsInit :: IO ()
+ , vcsAddFile :: RepoState -> FilePath -> IO ()
+ , vcsSubmoduleDriver :: FilePath -> IO VCSTestDriver
+ , vcsAddSubmodule :: RepoState -> FilePath -> FilePath -> IO ()
+ , vcsCommitChanges :: RepoState -> IO (Maybe CommitId)
+ , vcsTagState :: RepoState -> TagName -> IO ()
+ , vcsSwitchBranch :: RepoState -> BranchName -> IO ()
+ , vcsCheckoutTag
+ :: Either
+ (TagName -> IO ())
+ (TagName -> FilePath -> IO ())
+ }
+vcsTestDriverGit
+ :: Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
+vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
+ VCSTestDriver
+ { vcsVCS = vcs
, vcsRepoRoot = repoRoot
-
, vcsIgnoreFiles = Set.empty
-
, vcsInit =
- git $ ["init"] ++ verboseArg
-
+ git $ ["init"] ++ verboseArg
, vcsAddFile = \_ filename ->
git ["add", filename]
-
, vcsCommitChanges = \_state -> do
- git $ [ "-c", "user.name=A", "-c", "user.email=a@example.com"
- , "commit", "--all", "--message=a patch"
- , "--author=A <a@example.com>"
- ] ++ verboseArg
+ git $
+ [ "-c"
+ , "user.name=A"
+ , "-c"
+ , "user.email=a@example.com"
+ , "commit"
+ , "--all"
+ , "--message=a patch"
+ , "--author=A <a@example.com>"
+ ]
+ ++ verboseArg
commit <- git' ["log", "--format=%H", "-1"]
let commit' = takeWhile (not . isSpace) commit
return (Just commit')
-
, vcsTagState = \_ tagname ->
git ["tag", "--force", "--no-sign", tagname]
-
, vcsSubmoduleDriver =
pure . vcsTestDriverGit verbosity vcs submoduleDir . (submoduleDir </>)
-
, vcsAddSubmodule = \_ source dest -> do
- destExists <- (||) <$> doesFileExist (repoRoot </> dest)
- <*> doesDirectoryExist (repoRoot </> dest)
+ destExists <-
+ (||)
+ <$> doesFileExist (repoRoot </> dest)
+ <*> doesDirectoryExist (repoRoot </> dest)
when destExists $ git ["rm", "-f", dest]
-- If there is an old submodule git dir with the same name, remove it.
-- It most likely has a different URL and `git submodule add` will fai.
@@ -765,26 +885,25 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
when submoduleGitDirExists $ removeDirectoryRecursive (submoduleGitDir dest)
git ["submodule", "add", source, dest]
git ["submodule", "update", "--init", "--recursive", "--force"]
-
, vcsSwitchBranch = \RepoState{allBranches} branchname -> do
deinitAndRemoveCachedSubmodules
unless (branchname `Map.member` allBranches) $
git ["branch", branchname]
git $ ["checkout", branchname] ++ verboseArg
updateSubmodulesAndCleanup
-
, vcsCheckoutTag = Left $ \tagname -> do
deinitAndRemoveCachedSubmodules
git $ ["checkout", "--detach", "--force", tagname] ++ verboseArg
updateSubmodulesAndCleanup
}
where
- gitInvocation args = (programInvocation (vcsProgram vcs) args) {
- progInvokeCwd = Just repoRoot
- }
- git = runProgramInvocation verbosity . gitInvocation
+ gitInvocation args =
+ (programInvocation (vcsProgram vcs) args)
+ { progInvokeCwd = Just repoRoot
+ }
+ git = runProgramInvocation verbosity . gitInvocation
git' = getProgramInvocationOutput verbosity . gitInvocation
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
submoduleGitDir path = repoRoot </> ".git" </> "modules" </> path
deinitAndRemoveCachedSubmodules = do
git $ ["submodule", "deinit", "--force", "--all"] ++ verboseArg
@@ -797,151 +916,142 @@ vcsTestDriverGit verbosity vcs submoduleDir repoRoot =
git $ ["submodule", "foreach", "--recursive"] ++ verboseArg ++ ["git clean -ffxdq"]
git $ ["clean", "-ffxdq"] ++ verboseArg
-
type MTimeChange = Int
-vcsTestDriverDarcs :: MTimeChange -> Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver
+vcsTestDriverDarcs
+ :: MTimeChange
+ -> Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
vcsTestDriverDarcs mtimeChange verbosity vcs _ repoRoot =
- VCSTestDriver {
- vcsVCS = vcs
-
+ VCSTestDriver
+ { vcsVCS = vcs
, vcsRepoRoot = repoRoot
-
, vcsIgnoreFiles = Set.singleton "_darcs"
-
, vcsInit =
darcs ["initialize"]
-
, vcsAddFile = \state filename -> do
threadDelay mtimeChange
unless (filename `Map.member` currentWorking state) $
darcs ["add", filename]
- -- Darcs's file change tracking relies on mtime changes,
- -- so we have to be careful with doing stuff too quickly:
+ , -- Darcs's file change tracking relies on mtime changes,
+ -- so we have to be careful with doing stuff too quickly:
- , vcsSubmoduleDriver = \_->
+ vcsSubmoduleDriver = \_ ->
fail "vcsSubmoduleDriver: darcs does not support submodules"
-
, vcsAddSubmodule = \_ _ _ ->
fail "vcsAddSubmodule: darcs does not support submodules"
-
, vcsCommitChanges = \_state -> do
threadDelay mtimeChange
darcs ["record", "--all", "--author=author", "--name=a patch"]
return Nothing
-
, vcsTagState = \_ tagname ->
darcs ["tag", "--author=author", tagname]
-
, vcsSwitchBranch = \_ _ ->
fail "vcsSwitchBranch: darcs does not support branches within a repo"
-
, vcsCheckoutTag = Right $ \tagname dest ->
darcs ["clone", "--lazy", "--tag=^" ++ tagname ++ "$", ".", dest]
}
where
- darcsInvocation args = (programInvocation (vcsProgram vcs) args) {
- progInvokeCwd = Just repoRoot
- }
+ darcsInvocation args =
+ (programInvocation (vcsProgram vcs) args)
+ { progInvokeCwd = Just repoRoot
+ }
darcs = runProgramInvocation verbosity . darcsInvocation
-
-vcsTestDriverPijul :: Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver
+vcsTestDriverPijul
+ :: Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
vcsTestDriverPijul verbosity vcs _ repoRoot =
- VCSTestDriver {
- vcsVCS = vcs
-
+ VCSTestDriver
+ { vcsVCS = vcs
, vcsRepoRoot = repoRoot
-
, vcsIgnoreFiles = Set.empty
-
, vcsInit =
pijul $ ["init"]
-
, vcsAddFile = \_ filename ->
pijul ["add", filename]
-
, vcsSubmoduleDriver = \_ ->
fail "vcsSubmoduleDriver: pijul does not support submodules"
-
, vcsAddSubmodule = \_ _ _ ->
fail "vcsAddSubmodule: pijul does not support submodules"
-
, vcsCommitChanges = \_state -> do
- pijul $ ["record", "-a", "-m 'a patch'"
- , "-A 'A <a@example.com>'"
- ]
+ pijul $
+ [ "record"
+ , "-a"
+ , "-m 'a patch'"
+ , "-A 'A <a@example.com>'"
+ ]
commit <- pijul' ["log"]
let commit' = takeWhile (not . isSpace) commit
return (Just commit')
-
- -- tags work differently in pijul...
- -- so this is wrong
- , vcsTagState = \_ tagname ->
+ , -- tags work differently in pijul...
+ -- so this is wrong
+ vcsTagState = \_ tagname ->
pijul ["tag", tagname]
-
, vcsSwitchBranch = \_ branchname -> do
--- unless (branchname `Map.member` allBranches) $
--- pijul ["from-branch", branchname]
+ -- unless (branchname `Map.member` allBranches) $
+ -- pijul ["from-branch", branchname]
pijul $ ["checkout", branchname]
-
, vcsCheckoutTag = Left $ \tagname ->
pijul $ ["checkout", tagname]
}
where
- gitInvocation args = (programInvocation (vcsProgram vcs) args) {
- progInvokeCwd = Just repoRoot
- }
- pijul = runProgramInvocation verbosity . gitInvocation
+ gitInvocation args =
+ (programInvocation (vcsProgram vcs) args)
+ { progInvokeCwd = Just repoRoot
+ }
+ pijul = runProgramInvocation verbosity . gitInvocation
pijul' = getProgramInvocationOutput verbosity . gitInvocation
-vcsTestDriverHg :: Verbosity -> VCS ConfiguredProgram
- -> FilePath -> FilePath -> VCSTestDriver
+vcsTestDriverHg
+ :: Verbosity
+ -> VCS ConfiguredProgram
+ -> FilePath
+ -> FilePath
+ -> VCSTestDriver
vcsTestDriverHg verbosity vcs _ repoRoot =
- VCSTestDriver {
- vcsVCS = vcs
-
+ VCSTestDriver
+ { vcsVCS = vcs
, vcsRepoRoot = repoRoot
-
, vcsIgnoreFiles = Set.empty
-
, vcsInit =
- hg $ ["init"] ++ verboseArg
-
+ hg $ ["init"] ++ verboseArg
, vcsAddFile = \_ filename ->
hg ["add", filename]
-
, vcsSubmoduleDriver = \_ ->
fail "vcsSubmoduleDriver: hg submodules not supported"
-
, vcsAddSubmodule = \_ _ _ ->
fail "vcsAddSubmodule: hg submodules not supported"
-
, vcsCommitChanges = \_state -> do
- hg $ [ "--user='A <a@example.com>'"
- , "commit", "--message=a patch"
- ] ++ verboseArg
+ hg $
+ [ "--user='A <a@example.com>'"
+ , "commit"
+ , "--message=a patch"
+ ]
+ ++ verboseArg
commit <- hg' ["log", "--template='{node}\\n' -l1"]
let commit' = takeWhile (not . isSpace) commit
return (Just commit')
-
, vcsTagState = \_ tagname ->
hg ["tag", "--force", tagname]
-
, vcsSwitchBranch = \RepoState{allBranches} branchname -> do
unless (branchname `Map.member` allBranches) $
hg ["branch", branchname]
hg $ ["checkout", branchname] ++ verboseArg
-
, vcsCheckoutTag = Left $ \tagname ->
hg $ ["checkout", "--rev", tagname] ++ verboseArg
}
where
- hgInvocation args = (programInvocation (vcsProgram vcs) args) {
- progInvokeCwd = Just repoRoot
- }
- hg = runProgramInvocation verbosity . hgInvocation
+ hgInvocation args =
+ (programInvocation (vcsProgram vcs) args)
+ { progInvokeCwd = Just repoRoot
+ }
+ hg = runProgramInvocation verbosity . hgInvocation
hg' = getProgramInvocationOutput verbosity . hgInvocation
- verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+ verboseArg = ["--quiet" | verbosity < Verbosity.normal]
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs
index b8509834a2bad37502dc5357512f71c5798c9388..6eb27d39c3bf651b8aff4611b15fcf9de7dc9a83 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Builder.hs
@@ -1,5 +1,5 @@
-module UnitTests.Distribution.Solver.Modular.Builder (
- tests
+module UnitTests.Distribution.Solver.Modular.Builder
+ ( tests
) where
import Distribution.Solver.Modular.Builder
@@ -8,13 +8,14 @@ import Test.Tasty
import Test.Tasty.QuickCheck
tests :: [TestTree]
-tests = [ testProperty "splitsAltImplementation" splitsTest
- ]
+tests =
+ [ testProperty "splitsAltImplementation" splitsTest
+ ]
-- | Simpler splits implementation
splits' :: [a] -> [(a, [a])]
splits' [] = []
-splits' (x : xs) = (x, xs) : map (\ (y, ys) -> (y, x : ys)) (splits' xs)
+splits' (x : xs) = (x, xs) : map (\(y, ys) -> (y, x : ys)) (splits' xs)
splitsTest :: [Int] -> Property
splitsTest xs = splits' xs === splits xs
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
index 0d22d5fe7585cfb4a04957cff042bbb136d762c0..ba6dd2e14f4b7c429ce8d3f0336e7a52b5aa66fd 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs
@@ -1,27 +1,28 @@
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
-- | DSL for testing the modular solver
-module UnitTests.Distribution.Solver.Modular.DSL (
- ExampleDependency(..)
- , Dependencies(..)
- , ExSubLib(..)
- , ExTest(..)
- , ExExe(..)
- , ExConstraint(..)
- , ExPreference(..)
+module UnitTests.Distribution.Solver.Modular.DSL
+ ( ExampleDependency (..)
+ , Dependencies (..)
+ , ExSubLib (..)
+ , ExTest (..)
+ , ExExe (..)
+ , ExConstraint (..)
+ , ExPreference (..)
, ExampleDb
, ExampleVersionRange
, ExamplePkgVersion
, ExamplePkgName
, ExampleFlagName
- , ExFlag(..)
- , ExampleAvailable(..)
- , ExampleInstalled(..)
- , ExampleQualifier(..)
- , ExampleVar(..)
- , EnableAllTests(..)
+ , ExFlag (..)
+ , ExampleAvailable (..)
+ , ExampleInstalled (..)
+ , ExampleQualifier (..)
+ , ExampleVar (..)
+ , EnableAllTests (..)
, dependencies
, publicDependencies
, unbuildableDependencies
@@ -47,9 +48,9 @@ module UnitTests.Distribution.Solver.Modular.DSL (
, mkVersionRange
) where
-import Prelude ()
import Distribution.Solver.Compat.Prelude
import Distribution.Utils.Generic
+import Prelude ()
-- base
import Control.Arrow (second)
@@ -57,53 +58,45 @@ import qualified Data.Map as Map
import qualified Distribution.Compat.NonEmptySet as NonEmptySet
-- Cabal
-import qualified Distribution.CabalSpecVersion as C
-import qualified Distribution.Compiler as C
-import qualified Distribution.InstalledPackageInfo as IPI
-import Distribution.License (License(..))
-import qualified Distribution.ModuleName as Module
-import qualified Distribution.Package as C
- hiding (HasUnitId(..))
-import qualified Distribution.Types.ExeDependency as C
-import qualified Distribution.Types.ForeignLib as C
-import qualified Distribution.Types.LegacyExeDependency as C
-import qualified Distribution.Types.LibraryVisibility as C
-import qualified Distribution.Types.PkgconfigDependency as C
-import qualified Distribution.Types.PkgconfigVersion as C
-import qualified Distribution.Types.PkgconfigVersionRange as C
-import qualified Distribution.Types.UnqualComponentName as C
-import qualified Distribution.Types.CondTree as C
-import qualified Distribution.PackageDescription as C
-import qualified Distribution.PackageDescription.Check as C
-import qualified Distribution.Simple.PackageIndex as C.PackageIndex
-import Distribution.Simple.Setup (BooleanFlag(..))
-import qualified Distribution.System as C
-import Distribution.Text (display)
-import qualified Distribution.Verbosity as C
-import qualified Distribution.Version as C
-import qualified Distribution.Utils.Path as C
-import Language.Haskell.Extension (Extension(..), Language(..))
+import qualified Distribution.CabalSpecVersion as C
+import qualified Distribution.Compiler as C
+import qualified Distribution.InstalledPackageInfo as IPI
+import Distribution.License (License (..))
+import qualified Distribution.ModuleName as Module
+import qualified Distribution.Package as C hiding
+ ( HasUnitId (..)
+ )
+import qualified Distribution.PackageDescription as C
+import qualified Distribution.PackageDescription.Check as C
+import qualified Distribution.Simple.PackageIndex as C.PackageIndex
+import Distribution.Simple.Setup (BooleanFlag (..))
+import qualified Distribution.System as C
+import Distribution.Text (display)
+import qualified Distribution.Utils.Path as C
+import qualified Distribution.Verbosity as C
+import qualified Distribution.Version as C
+import Language.Haskell.Extension (Extension (..), Language (..))
-- cabal-install
import Distribution.Client.Dependency
import Distribution.Client.Dependency.Types
-import Distribution.Client.Types
import qualified Distribution.Client.SolverInstallPlan as CI.SolverInstallPlan
+import Distribution.Client.Types
-import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
+import Distribution.Solver.Types.ComponentDeps (ComponentDeps)
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ConstraintSource
-import Distribution.Solver.Types.Flag
-import Distribution.Solver.Types.LabeledPackageConstraint
-import Distribution.Solver.Types.OptionalStanza
-import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex
-import Distribution.Solver.Types.PackageConstraint
+import Distribution.Solver.Types.ConstraintSource
+import Distribution.Solver.Types.Flag
+import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackageConstraint
+import qualified Distribution.Solver.Types.PackageIndex as CI.PackageIndex
import qualified Distribution.Solver.Types.PackagePath as P
import qualified Distribution.Solver.Types.PkgConfigDb as PC
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.SolverPackage
-import Distribution.Solver.Types.SourcePackage
-import Distribution.Solver.Types.Variable
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.SolverPackage
+import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.Variable
{-------------------------------------------------------------------------------
Example package database DSL
@@ -147,94 +140,86 @@ import Distribution.Solver.Types.Variable
optional.
-------------------------------------------------------------------------------}
-type ExamplePkgName = String
+type ExamplePkgName = String
type ExamplePkgVersion = Int
-type ExamplePkgHash = String -- for example "installed" packages
-type ExampleFlagName = String
+type ExamplePkgHash = String -- for example "installed" packages
+type ExampleFlagName = String
type ExampleSubLibName = String
-type ExampleTestName = String
-type ExampleExeName = String
+type ExampleTestName = String
+type ExampleExeName = String
type ExampleVersionRange = C.VersionRange
-data Dependencies = Dependencies {
- depsVisibility :: C.LibraryVisibility
+data Dependencies = Dependencies
+ { depsVisibility :: C.LibraryVisibility
, depsIsBuildable :: Bool
, depsExampleDependencies :: [ExampleDependency]
- } deriving Show
+ }
+ deriving (Show)
instance Semigroup Dependencies where
- deps1 <> deps2 = Dependencies {
- depsVisibility = depsVisibility deps1 <> depsVisibility deps2
- , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2
- , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2
- }
+ deps1 <> deps2 =
+ Dependencies
+ { depsVisibility = depsVisibility deps1 <> depsVisibility deps2
+ , depsIsBuildable = depsIsBuildable deps1 && depsIsBuildable deps2
+ , depsExampleDependencies = depsExampleDependencies deps1 ++ depsExampleDependencies deps2
+ }
instance Monoid Dependencies where
- mempty = Dependencies {
- depsVisibility = mempty
- , depsIsBuildable = True
- , depsExampleDependencies = []
- }
+ mempty =
+ Dependencies
+ { depsVisibility = mempty
+ , depsIsBuildable = True
+ , depsExampleDependencies = []
+ }
mappend = (<>)
dependencies :: [ExampleDependency] -> Dependencies
-dependencies deps = mempty { depsExampleDependencies = deps }
+dependencies deps = mempty{depsExampleDependencies = deps}
publicDependencies :: Dependencies
-publicDependencies = mempty { depsVisibility = C.LibraryVisibilityPublic }
+publicDependencies = mempty{depsVisibility = C.LibraryVisibilityPublic}
unbuildableDependencies :: Dependencies
-unbuildableDependencies = mempty { depsIsBuildable = False }
+unbuildableDependencies = mempty{depsIsBuildable = False}
-data ExampleDependency =
- -- | Simple dependency on any version
+data ExampleDependency
+ = -- | Simple dependency on any version
ExAny ExamplePkgName
-
- -- | Simple dependency on a fixed version
- | ExFix ExamplePkgName ExamplePkgVersion
-
- -- | Simple dependency on a range of versions, with an inclusive lower bound
+ | -- | Simple dependency on a fixed version
+ ExFix ExamplePkgName ExamplePkgVersion
+ | -- | Simple dependency on a range of versions, with an inclusive lower bound
-- and an exclusive upper bound.
- | ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion
-
- -- | Sub-library dependency
- | ExSubLibAny ExamplePkgName ExampleSubLibName
-
- -- | Sub-library dependency on a fixed version
- | ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion
-
- -- | Build-tool-depends dependency
- | ExBuildToolAny ExamplePkgName ExampleExeName
-
- -- | Build-tool-depends dependency on a fixed version
- | ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion
-
- -- | Legacy build-tools dependency
- | ExLegacyBuildToolAny ExamplePkgName
-
- -- | Legacy build-tools dependency on a fixed version
- | ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion
-
- -- | Dependencies indexed by a flag
- | ExFlagged ExampleFlagName Dependencies Dependencies
-
- -- | Dependency on a language extension
- | ExExt Extension
-
- -- | Dependency on a language version
- | ExLang Language
-
- -- | Dependency on a pkg-config package
- | ExPkg (ExamplePkgName, ExamplePkgVersion)
- deriving Show
+ ExRange ExamplePkgName ExamplePkgVersion ExamplePkgVersion
+ | -- | Sub-library dependency
+ ExSubLibAny ExamplePkgName ExampleSubLibName
+ | -- | Sub-library dependency on a fixed version
+ ExSubLibFix ExamplePkgName ExampleSubLibName ExamplePkgVersion
+ | -- | Build-tool-depends dependency
+ ExBuildToolAny ExamplePkgName ExampleExeName
+ | -- | Build-tool-depends dependency on a fixed version
+ ExBuildToolFix ExamplePkgName ExampleExeName ExamplePkgVersion
+ | -- | Legacy build-tools dependency
+ ExLegacyBuildToolAny ExamplePkgName
+ | -- | Legacy build-tools dependency on a fixed version
+ ExLegacyBuildToolFix ExamplePkgName ExamplePkgVersion
+ | -- | Dependencies indexed by a flag
+ ExFlagged ExampleFlagName Dependencies Dependencies
+ | -- | Dependency on a language extension
+ ExExt Extension
+ | -- | Dependency on a language version
+ ExLang Language
+ | -- | Dependency on a pkg-config package
+ ExPkg (ExamplePkgName, ExamplePkgVersion)
+ deriving (Show)
-- | Simplified version of D.Types.GenericPackageDescription.Flag for use in
-- example source packages.
-data ExFlag = ExFlag {
- exFlagName :: ExampleFlagName
+data ExFlag = ExFlag
+ { exFlagName :: ExampleFlagName
, exFlagDefault :: Bool
- , exFlagType :: FlagType
- } deriving Show
+ , exFlagType :: FlagType
+ }
+ deriving (Show)
data ExSubLib = ExSubLib ExampleSubLibName Dependencies
@@ -251,52 +236,53 @@ exTest name deps = ExTest name (dependencies deps)
exExe :: ExampleExeName -> [ExampleDependency] -> ExExe
exExe name deps = ExExe name (dependencies deps)
-exFlagged :: ExampleFlagName -> [ExampleDependency] -> [ExampleDependency]
- -> ExampleDependency
+exFlagged
+ :: ExampleFlagName
+ -> [ExampleDependency]
+ -> [ExampleDependency]
+ -> ExampleDependency
exFlagged n t e = ExFlagged n (dependencies t) (dependencies e)
-data ExConstraint =
- ExVersionConstraint ConstraintScope ExampleVersionRange
+data ExConstraint
+ = ExVersionConstraint ConstraintScope ExampleVersionRange
| ExFlagConstraint ConstraintScope ExampleFlagName Bool
| ExStanzaConstraint ConstraintScope [OptionalStanza]
- deriving Show
+ deriving (Show)
-data ExPreference =
- ExPkgPref ExamplePkgName ExampleVersionRange
+data ExPreference
+ = ExPkgPref ExamplePkgName ExampleVersionRange
| ExStanzaPref ExamplePkgName [OptionalStanza]
- deriving Show
+ deriving (Show)
-data ExampleAvailable = ExAv {
- exAvName :: ExamplePkgName
+data ExampleAvailable = ExAv
+ { exAvName :: ExamplePkgName
, exAvVersion :: ExamplePkgVersion
- , exAvDeps :: ComponentDeps Dependencies
-
- -- Setting flags here is only necessary to override the default values of
- -- the fields in C.Flag.
- , exAvFlags :: [ExFlag]
- } deriving Show
+ , exAvDeps :: ComponentDeps Dependencies
+ , -- Setting flags here is only necessary to override the default values of
+ -- the fields in C.Flag.
+ exAvFlags :: [ExFlag]
+ }
+ deriving (Show)
-data ExampleVar =
- P ExampleQualifier ExamplePkgName
+data ExampleVar
+ = P ExampleQualifier ExamplePkgName
| F ExampleQualifier ExamplePkgName ExampleFlagName
| S ExampleQualifier ExamplePkgName OptionalStanza
-data ExampleQualifier =
- QualNone
+data ExampleQualifier
+ = QualNone
| QualIndep ExamplePkgName
| QualSetup ExamplePkgName
-
- -- The two package names are the build target and the package containing the
+ | -- The two package names are the build target and the package containing the
-- setup script.
- | QualIndepSetup ExamplePkgName ExamplePkgName
-
- -- The two package names are the package depending on the exe and the
+ QualIndepSetup ExamplePkgName ExamplePkgName
+ | -- The two package names are the package depending on the exe and the
-- package containing the exe.
- | QualExe ExamplePkgName ExamplePkgName
+ QualExe ExamplePkgName ExamplePkgName
-- | Whether to enable tests in all packages in a test case.
newtype EnableAllTests = EnableAllTests Bool
- deriving BooleanFlag
+ deriving (BooleanFlag)
-- | Constructs an 'ExampleAvailable' package for the 'ExampleDb',
-- given:
@@ -306,24 +292,30 @@ newtype EnableAllTests = EnableAllTests Bool
-- 3. The list of dependency constraints ('ExampleDependency')
-- for this package's library component. 'ExampleDependency'
-- provides a number of pre-canned dependency types to look at.
---
-exAv :: ExamplePkgName -> ExamplePkgVersion -> [ExampleDependency]
- -> ExampleAvailable
-exAv n v ds = (exAvNoLibrary n v) { exAvDeps = CD.fromLibraryDeps (dependencies ds) }
+exAv
+ :: ExamplePkgName
+ -> ExamplePkgVersion
+ -> [ExampleDependency]
+ -> ExampleAvailable
+exAv n v ds = (exAvNoLibrary n v){exAvDeps = CD.fromLibraryDeps (dependencies ds)}
-- | Constructs an 'ExampleAvailable' package without a default library
-- component.
exAvNoLibrary :: ExamplePkgName -> ExamplePkgVersion -> ExampleAvailable
-exAvNoLibrary n v = ExAv { exAvName = n
- , exAvVersion = v
- , exAvDeps = CD.empty
- , exAvFlags = [] }
+exAvNoLibrary n v =
+ ExAv
+ { exAvName = n
+ , exAvVersion = v
+ , exAvDeps = CD.empty
+ , exAvFlags = []
+ }
-- | Override the default settings (e.g., manual vs. automatic) for a subset of
-- a package's flags.
declareFlags :: [ExFlag] -> ExampleAvailable -> ExampleAvailable
-declareFlags flags ex = ex {
- exAvFlags = flags
+declareFlags flags ex =
+ ex
+ { exAvFlags = flags
}
withSubLibrary :: ExampleAvailable -> ExSubLib -> ExampleAvailable
@@ -331,13 +323,17 @@ withSubLibrary ex lib = withSubLibraries ex [lib]
withSubLibraries :: ExampleAvailable -> [ExSubLib] -> ExampleAvailable
withSubLibraries ex libs =
- let subLibCDs = CD.fromList [(CD.ComponentSubLib $ C.mkUnqualComponentName name, deps)
- | ExSubLib name deps <- libs]
- in ex { exAvDeps = exAvDeps ex <> subLibCDs }
+ let subLibCDs =
+ CD.fromList
+ [ (CD.ComponentSubLib $ C.mkUnqualComponentName name, deps)
+ | ExSubLib name deps <- libs
+ ]
+ in ex{exAvDeps = exAvDeps ex <> subLibCDs}
withSetupDeps :: ExampleAvailable -> [ExampleDependency] -> ExampleAvailable
-withSetupDeps ex setupDeps = ex {
- exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps)
+withSetupDeps ex setupDeps =
+ ex
+ { exAvDeps = exAvDeps ex <> CD.fromSetupDeps (dependencies setupDeps)
}
withTest :: ExampleAvailable -> ExTest -> ExampleAvailable
@@ -345,26 +341,33 @@ withTest ex test = withTests ex [test]
withTests :: ExampleAvailable -> [ExTest] -> ExampleAvailable
withTests ex tests =
- let testCDs = CD.fromList [(CD.ComponentTest $ C.mkUnqualComponentName name, deps)
- | ExTest name deps <- tests]
- in ex { exAvDeps = exAvDeps ex <> testCDs }
+ let testCDs =
+ CD.fromList
+ [ (CD.ComponentTest $ C.mkUnqualComponentName name, deps)
+ | ExTest name deps <- tests
+ ]
+ in ex{exAvDeps = exAvDeps ex <> testCDs}
withExe :: ExampleAvailable -> ExExe -> ExampleAvailable
withExe ex exe = withExes ex [exe]
withExes :: ExampleAvailable -> [ExExe] -> ExampleAvailable
withExes ex exes =
- let exeCDs = CD.fromList [(CD.ComponentExe $ C.mkUnqualComponentName name, deps)
- | ExExe name deps <- exes]
- in ex { exAvDeps = exAvDeps ex <> exeCDs }
+ let exeCDs =
+ CD.fromList
+ [ (CD.ComponentExe $ C.mkUnqualComponentName name, deps)
+ | ExExe name deps <- exes
+ ]
+ in ex{exAvDeps = exAvDeps ex <> exeCDs}
-- | An installed package in 'ExampleDb'; construct me with 'exInst'.
-data ExampleInstalled = ExInst {
- exInstName :: ExamplePkgName
- , exInstVersion :: ExamplePkgVersion
- , exInstHash :: ExamplePkgHash
+data ExampleInstalled = ExInst
+ { exInstName :: ExamplePkgName
+ , exInstVersion :: ExamplePkgVersion
+ , exInstHash :: ExamplePkgHash
, exInstBuildAgainst :: [ExamplePkgHash]
- } deriving Show
+ }
+ deriving (Show)
-- | Constructs an example installed package given:
--
@@ -374,9 +377,12 @@ data ExampleInstalled = ExInst {
-- (just some unique identifier for the package.)
-- 4. The 'ExampleInstalled' packages which this package was
-- compiled against.)
---
-exInst :: ExamplePkgName -> ExamplePkgVersion -> ExamplePkgHash
- -> [ExampleInstalled] -> ExampleInstalled
+exInst
+ :: ExamplePkgName
+ -> ExamplePkgVersion
+ -> ExamplePkgHash
+ -> [ExampleInstalled]
+ -> ExampleInstalled
exInst pn v hash deps = ExInst pn v hash (map exInstHash deps)
-- | An example package database is a list of installed packages
@@ -394,201 +400,219 @@ exDbPkgs = map (either exInstName exAvName)
exAvSrcPkg :: ExampleAvailable -> UnresolvedSourcePackage
exAvSrcPkg ex =
- let pkgId = exAvPkgId ex
-
- flags :: [C.PackageFlag]
- flags =
- let declaredFlags :: Map ExampleFlagName C.PackageFlag
- declaredFlags =
- Map.fromListWith
- (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2])
- [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex]
-
- usedFlags :: Map ExampleFlagName C.PackageFlag
- usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]
- where
- names = extractFlags $ CD.flatDeps (exAvDeps ex)
- in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:
- Map.elems $ declaredFlags `Map.union` usedFlags
-
- subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)]
- foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)]
- testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
- benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)]
- executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
- setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of
- [] -> Nothing
- deps -> Just C.SetupBuildInfo {
- C.setupDepends = mkSetupDeps deps,
- C.defaultSetupDepends = False
- }
- package = SourcePackage
- { srcpkgPackageId = pkgId
- , srcpkgSource = LocalTarballPackage "<<path>>"
- , srcpkgDescrOverride = Nothing
- , srcpkgDescription = C.GenericPackageDescription {
- C.packageDescription = C.emptyPackageDescription {
- C.package = pkgId
- , C.setupBuildInfo = setup
- , C.licenseRaw = Right BSD3
- , C.buildTypeRaw = if isNothing setup
- then Just C.Simple
- else Just C.Custom
- , C.category = "category"
- , C.maintainer = "maintainer"
- , C.description = "description"
- , C.synopsis = "synopsis"
- , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"]
- -- Version 2.0 is required for internal libraries.
- , C.specVersion = C.CabalSpecV2_0
- }
- , C.gpdScannedVersion = Nothing
- , C.genPackageFlags = flags
- , C.condLibrary =
- let mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi }
- -- Avoid using the Monoid instance for [a] when getting
- -- the library dependencies, to allow for the possibility
- -- that the package doesn't have a library:
- libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex))
- in mkTopLevelCondTree defaultLib mkLib <$> libDeps
- , C.condSubLibraries =
- let mkTree = mkTopLevelCondTree defaultSubLib mkLib
- mkLib v bi = mempty { C.libVisibility = v, C.libBuildInfo = bi }
- in map (second mkTree) subLibraries
- , C.condForeignLibs =
- let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib)
- mkLib bi = mempty { C.foreignLibBuildInfo = bi }
- in map (second mkTree) foreignLibraries
- , C.condExecutables =
- let mkTree = mkTopLevelCondTree defaultExe (const mkExe)
- mkExe bi = mempty { C.buildInfo = bi }
- in map (second mkTree) executables
- , C.condTestSuites =
- let mkTree = mkTopLevelCondTree defaultTest (const mkTest)
- mkTest bi = mempty { C.testBuildInfo = bi }
- in map (second mkTree) testSuites
- , C.condBenchmarks =
- let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench)
- mkBench bi = mempty { C.benchmarkBuildInfo = bi }
- in map (second mkTree) benchmarks
+ let pkgId = exAvPkgId ex
+
+ flags :: [C.PackageFlag]
+ flags =
+ let declaredFlags :: Map ExampleFlagName C.PackageFlag
+ declaredFlags =
+ Map.fromListWith
+ (\f1 f2 -> error $ "duplicate flag declarations: " ++ show [f1, f2])
+ [(exFlagName flag, mkFlag flag) | flag <- exAvFlags ex]
+
+ usedFlags :: Map ExampleFlagName C.PackageFlag
+ usedFlags = Map.fromList [(fn, mkDefaultFlag fn) | fn <- names]
+ where
+ names = extractFlags $ CD.flatDeps (exAvDeps ex)
+ in -- 'declaredFlags' overrides 'usedFlags' to give flags non-default settings:
+ Map.elems $ declaredFlags `Map.union` usedFlags
+
+ subLibraries = [(name, deps) | (CD.ComponentSubLib name, deps) <- CD.toList (exAvDeps ex)]
+ foreignLibraries = [(name, deps) | (CD.ComponentFLib name, deps) <- CD.toList (exAvDeps ex)]
+ testSuites = [(name, deps) | (CD.ComponentTest name, deps) <- CD.toList (exAvDeps ex)]
+ benchmarks = [(name, deps) | (CD.ComponentBench name, deps) <- CD.toList (exAvDeps ex)]
+ executables = [(name, deps) | (CD.ComponentExe name, deps) <- CD.toList (exAvDeps ex)]
+ setup = case depsExampleDependencies $ CD.setupDeps (exAvDeps ex) of
+ [] -> Nothing
+ deps ->
+ Just
+ C.SetupBuildInfo
+ { C.setupDepends = mkSetupDeps deps
+ , C.defaultSetupDepends = False
}
- }
- pkgCheckErrors =
- -- We ignore unknown extensions/languages warnings because
- -- some there are some unit tests test in which the solver allows
- -- unknown extensions/languages when the compiler supports them.
- -- Furthermore we ignore missing upper bound warnings because
- -- they are not related to this test suite, and are tested
- -- with golden tests.
- let checks = C.checkPackage (srcpkgDescription package) Nothing
- in filter (\x -> not (isMissingUpperBound x) && not (isUnknownLangExt x)) checks
- in if null pkgCheckErrors
- then package
- else error $ "invalid GenericPackageDescription for package "
- ++ display pkgId ++ ": " ++ show pkgCheckErrors
+ package =
+ SourcePackage
+ { srcpkgPackageId = pkgId
+ , srcpkgSource = LocalTarballPackage "<<path>>"
+ , srcpkgDescrOverride = Nothing
+ , srcpkgDescription =
+ C.GenericPackageDescription
+ { C.packageDescription =
+ C.emptyPackageDescription
+ { C.package = pkgId
+ , C.setupBuildInfo = setup
+ , C.licenseRaw = Right BSD3
+ , C.buildTypeRaw =
+ if isNothing setup
+ then Just C.Simple
+ else Just C.Custom
+ , C.category = "category"
+ , C.maintainer = "maintainer"
+ , C.description = "description"
+ , C.synopsis = "synopsis"
+ , C.licenseFiles = [C.unsafeMakeSymbolicPath "LICENSE"]
+ , -- Version 2.0 is required for internal libraries.
+ C.specVersion = C.CabalSpecV2_0
+ }
+ , C.gpdScannedVersion = Nothing
+ , C.genPackageFlags = flags
+ , C.condLibrary =
+ let mkLib v bi = mempty{C.libVisibility = v, C.libBuildInfo = bi}
+ -- Avoid using the Monoid instance for [a] when getting
+ -- the library dependencies, to allow for the possibility
+ -- that the package doesn't have a library:
+ libDeps = lookup CD.ComponentLib (CD.toList (exAvDeps ex))
+ in mkTopLevelCondTree defaultLib mkLib <$> libDeps
+ , C.condSubLibraries =
+ let mkTree = mkTopLevelCondTree defaultSubLib mkLib
+ mkLib v bi = mempty{C.libVisibility = v, C.libBuildInfo = bi}
+ in map (second mkTree) subLibraries
+ , C.condForeignLibs =
+ let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib)
+ mkLib bi = mempty{C.foreignLibBuildInfo = bi}
+ in map (second mkTree) foreignLibraries
+ , C.condExecutables =
+ let mkTree = mkTopLevelCondTree defaultExe (const mkExe)
+ mkExe bi = mempty{C.buildInfo = bi}
+ in map (second mkTree) executables
+ , C.condTestSuites =
+ let mkTree = mkTopLevelCondTree defaultTest (const mkTest)
+ mkTest bi = mempty{C.testBuildInfo = bi}
+ in map (second mkTree) testSuites
+ , C.condBenchmarks =
+ let mkTree = mkTopLevelCondTree defaultBenchmark (const mkBench)
+ mkBench bi = mempty{C.benchmarkBuildInfo = bi}
+ in map (second mkTree) benchmarks
+ }
+ }
+ pkgCheckErrors =
+ -- We ignore unknown extensions/languages warnings because
+ -- some there are some unit tests test in which the solver allows
+ -- unknown extensions/languages when the compiler supports them.
+ -- Furthermore we ignore missing upper bound warnings because
+ -- they are not related to this test suite, and are tested
+ -- with golden tests.
+ let checks = C.checkPackage (srcpkgDescription package) Nothing
+ in filter (\x -> not (isMissingUpperBound x) && not (isUnknownLangExt x)) checks
+ in if null pkgCheckErrors
+ then package
+ else
+ error $
+ "invalid GenericPackageDescription for package "
+ ++ display pkgId
+ ++ ": "
+ ++ show pkgCheckErrors
where
defaultTopLevelBuildInfo :: C.BuildInfo
- defaultTopLevelBuildInfo = mempty { C.defaultLanguage = Just Haskell98 }
+ defaultTopLevelBuildInfo = mempty{C.defaultLanguage = Just Haskell98}
defaultLib :: C.Library
- defaultLib = mempty {
- C.libBuildInfo = defaultTopLevelBuildInfo
- , C.exposedModules = [Module.fromString "Module"]
- , C.libVisibility = C.LibraryVisibilityPublic
- }
+ defaultLib =
+ mempty
+ { C.libBuildInfo = defaultTopLevelBuildInfo
+ , C.exposedModules = [Module.fromString "Module"]
+ , C.libVisibility = C.LibraryVisibilityPublic
+ }
defaultSubLib :: C.Library
- defaultSubLib = mempty {
- C.libBuildInfo = defaultTopLevelBuildInfo
- , C.exposedModules = [Module.fromString "Module"]
- }
+ defaultSubLib =
+ mempty
+ { C.libBuildInfo = defaultTopLevelBuildInfo
+ , C.exposedModules = [Module.fromString "Module"]
+ }
defaultExe :: C.Executable
- defaultExe = mempty {
- C.buildInfo = defaultTopLevelBuildInfo
- , C.modulePath = "Main.hs"
- }
+ defaultExe =
+ mempty
+ { C.buildInfo = defaultTopLevelBuildInfo
+ , C.modulePath = "Main.hs"
+ }
defaultTest :: C.TestSuite
- defaultTest = mempty {
- C.testBuildInfo = defaultTopLevelBuildInfo
- , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1,0]) "Test.hs"
- }
+ defaultTest =
+ mempty
+ { C.testBuildInfo = defaultTopLevelBuildInfo
+ , C.testInterface = C.TestSuiteExeV10 (C.mkVersion [1, 0]) "Test.hs"
+ }
defaultBenchmark :: C.Benchmark
- defaultBenchmark = mempty {
- C.benchmarkBuildInfo = defaultTopLevelBuildInfo
- , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1,0]) "Benchmark.hs"
- }
+ defaultBenchmark =
+ mempty
+ { C.benchmarkBuildInfo = defaultTopLevelBuildInfo
+ , C.benchmarkInterface = C.BenchmarkExeV10 (C.mkVersion [1, 0]) "Benchmark.hs"
+ }
-- Split the set of dependencies into the set of dependencies of the library,
-- the dependencies of the test suites and extensions.
- splitTopLevel :: [ExampleDependency]
- -> ( [ExampleDependency]
- , [Extension]
- , Maybe Language
- , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config
- , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools
- , [(ExamplePkgName, C.VersionRange)] -- legacy build tools
- )
+ splitTopLevel
+ :: [ExampleDependency]
+ -> ( [ExampleDependency]
+ , [Extension]
+ , Maybe Language
+ , [(ExamplePkgName, ExamplePkgVersion)] -- pkg-config
+ , [(ExamplePkgName, ExampleExeName, C.VersionRange)] -- build tools
+ , [(ExamplePkgName, C.VersionRange)] -- legacy build tools
+ )
splitTopLevel [] =
- ([], [], Nothing, [], [], [])
- splitTopLevel (ExBuildToolAny p e:deps) =
+ ([], [], Nothing, [], [], [])
+ splitTopLevel (ExBuildToolAny p e : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (other, exts, lang, pcpkgs, (p, e, C.anyVersion):exes, legacyExes)
- splitTopLevel (ExBuildToolFix p e v:deps) =
+ in (other, exts, lang, pcpkgs, (p, e, C.anyVersion) : exes, legacyExes)
+ splitTopLevel (ExBuildToolFix p e v : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)):exes, legacyExes)
- splitTopLevel (ExLegacyBuildToolAny p:deps) =
+ in (other, exts, lang, pcpkgs, (p, e, C.thisVersion (mkSimpleVersion v)) : exes, legacyExes)
+ splitTopLevel (ExLegacyBuildToolAny p : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion):legacyExes)
- splitTopLevel (ExLegacyBuildToolFix p v:deps) =
+ in (other, exts, lang, pcpkgs, exes, (p, C.anyVersion) : legacyExes)
+ splitTopLevel (ExLegacyBuildToolFix p v : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)):legacyExes)
- splitTopLevel (ExExt ext:deps) =
+ in (other, exts, lang, pcpkgs, exes, (p, C.thisVersion (mkSimpleVersion v)) : legacyExes)
+ splitTopLevel (ExExt ext : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (other, ext:exts, lang, pcpkgs, exes, legacyExes)
- splitTopLevel (ExLang lang:deps) =
- case splitTopLevel deps of
- (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes)
- _ -> error "Only 1 Language dependency is supported"
- splitTopLevel (ExPkg pkg:deps) =
+ in (other, ext : exts, lang, pcpkgs, exes, legacyExes)
+ splitTopLevel (ExLang lang : deps) =
+ case splitTopLevel deps of
+ (other, exts, Nothing, pcpkgs, exes, legacyExes) -> (other, exts, Just lang, pcpkgs, exes, legacyExes)
+ _ -> error "Only 1 Language dependency is supported"
+ splitTopLevel (ExPkg pkg : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (other, exts, lang, pkg:pcpkgs, exes, legacyExes)
- splitTopLevel (dep:deps) =
+ in (other, exts, lang, pkg : pcpkgs, exes, legacyExes)
+ splitTopLevel (dep : deps) =
let (other, exts, lang, pcpkgs, exes, legacyExes) = splitTopLevel deps
- in (dep:other, exts, lang, pcpkgs, exes, legacyExes)
+ in (dep : other, exts, lang, pcpkgs, exes, legacyExes)
-- Extract the total set of flags used
extractFlags :: Dependencies -> [ExampleFlagName]
extractFlags deps = concatMap go (depsExampleDependencies deps)
where
go :: ExampleDependency -> [ExampleFlagName]
- go (ExAny _) = []
- go (ExFix _ _) = []
- go (ExRange _ _ _) = []
- go (ExSubLibAny _ _) = []
- go (ExSubLibFix _ _ _) = []
- go (ExBuildToolAny _ _) = []
- go (ExBuildToolFix _ _ _) = []
- go (ExLegacyBuildToolAny _) = []
+ go (ExAny _) = []
+ go (ExFix _ _) = []
+ go (ExRange _ _ _) = []
+ go (ExSubLibAny _ _) = []
+ go (ExSubLibFix _ _ _) = []
+ go (ExBuildToolAny _ _) = []
+ go (ExBuildToolFix _ _ _) = []
+ go (ExLegacyBuildToolAny _) = []
go (ExLegacyBuildToolFix _ _) = []
- go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b
- go (ExExt _) = []
- go (ExLang _) = []
- go (ExPkg _) = []
+ go (ExFlagged f a b) = f : extractFlags a ++ extractFlags b
+ go (ExExt _) = []
+ go (ExLang _) = []
+ go (ExPkg _) = []
-- Convert 'Dependencies' into a tree of a specific component type, using
-- the given top level component and function for creating a component at
-- any level.
- mkTopLevelCondTree :: forall a. Semigroup a =>
- a
- -> (C.LibraryVisibility -> C.BuildInfo -> a)
- -> Dependencies
- -> DependencyTree a
+ mkTopLevelCondTree
+ :: forall a
+ . Semigroup a
+ => a
+ -> (C.LibraryVisibility -> C.BuildInfo -> a)
+ -> Dependencies
+ -> DependencyTree a
mkTopLevelCondTree defaultTopLevel mkComponent deps =
let condNode = mkCondTree mkComponent deps
- in condNode { C.condTreeData = defaultTopLevel <> C.condTreeData condNode }
+ in condNode{C.condTreeData = defaultTopLevel <> C.condTreeData condNode}
-- Convert 'Dependencies' into a tree of a specific component type, using
-- the given function to generate each component.
@@ -597,88 +621,97 @@ exAvSrcPkg ex =
let (libraryDeps, exts, mlang, pcpkgs, buildTools, legacyBuildTools) = splitTopLevel (depsExampleDependencies deps)
(directDeps, flaggedDeps) = splitDeps libraryDeps
component = mkComponent (depsVisibility deps) bi
- bi = mempty {
- C.otherExtensions = exts
- , C.defaultLanguage = mlang
- , C.buildToolDepends = [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr
- | (p, e, vr) <- buildTools]
- , C.buildTools = [ C.LegacyExeDependency n vr
- | (n,vr) <- legacyBuildTools]
- , C.pkgconfigDepends = [ C.PkgconfigDependency n' v'
- | (n,v) <- pcpkgs
- , let n' = C.mkPkgconfigName n
- , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v) ]
- , C.buildable = depsIsBuildable deps
+ bi =
+ mempty
+ { C.otherExtensions = exts
+ , C.defaultLanguage = mlang
+ , C.buildToolDepends =
+ [ C.ExeDependency (C.mkPackageName p) (C.mkUnqualComponentName e) vr
+ | (p, e, vr) <- buildTools
+ ]
+ , C.buildTools =
+ [ C.LegacyExeDependency n vr
+ | (n, vr) <- legacyBuildTools
+ ]
+ , C.pkgconfigDepends =
+ [ C.PkgconfigDependency n' v'
+ | (n, v) <- pcpkgs
+ , let n' = C.mkPkgconfigName n
+ , let v' = C.PcThisVersion (mkSimplePkgconfigVersion v)
+ ]
+ , C.buildable = depsIsBuildable deps
}
- in C.CondNode {
- C.condTreeData = component
- -- TODO: Arguably, build-tools dependencies should also
- -- effect constraints on conditional tree. But no way to
- -- distinguish between them
- , C.condTreeConstraints = map mkDirect directDeps
- , C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps
- }
+ in C.CondNode
+ { C.condTreeData = component
+ , -- TODO: Arguably, build-tools dependencies should also
+ -- effect constraints on conditional tree. But no way to
+ -- distinguish between them
+ C.condTreeConstraints = map mkDirect directDeps
+ , C.condTreeComponents = map (mkFlagged mkComponent) flaggedDeps
+ }
mkDirect :: (ExamplePkgName, C.LibraryName, C.VersionRange) -> C.Dependency
mkDirect (dep, name, vr) = C.Dependency (C.mkPackageName dep) vr (NonEmptySet.singleton name)
- mkFlagged :: (C.LibraryVisibility -> C.BuildInfo -> a)
- -> (ExampleFlagName, Dependencies, Dependencies)
- -> DependencyComponent a
+ mkFlagged
+ :: (C.LibraryVisibility -> C.BuildInfo -> a)
+ -> (ExampleFlagName, Dependencies, Dependencies)
+ -> DependencyComponent a
mkFlagged mkComponent (f, a, b) =
- C.CondBranch (C.Var (C.PackageFlag (C.mkFlagName f)))
- (mkCondTree mkComponent a)
- (Just (mkCondTree mkComponent b))
+ C.CondBranch
+ (C.Var (C.PackageFlag (C.mkFlagName f)))
+ (mkCondTree mkComponent a)
+ (Just (mkCondTree mkComponent b))
-- Split a set of dependencies into direct dependencies and flagged
-- dependencies. A direct dependency is a tuple of the name of package and
-- its version range meant to be converted to a 'C.Dependency' with
-- 'mkDirect' for example. A flagged dependency is the set of dependencies
-- guarded by a flag.
- splitDeps :: [ExampleDependency]
- -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)]
- , [(ExampleFlagName, Dependencies, Dependencies)]
- )
+ splitDeps
+ :: [ExampleDependency]
+ -> ( [(ExamplePkgName, C.LibraryName, C.VersionRange)]
+ , [(ExampleFlagName, Dependencies, Dependencies)]
+ )
splitDeps [] =
([], [])
- splitDeps (ExAny p:deps) =
+ splitDeps (ExAny p : deps) =
let (directDeps, flaggedDeps) = splitDeps deps
- in ((p, C.LMainLibName, C.anyVersion):directDeps, flaggedDeps)
- splitDeps (ExFix p v:deps) =
+ in ((p, C.LMainLibName, C.anyVersion) : directDeps, flaggedDeps)
+ splitDeps (ExFix p v : deps) =
let (directDeps, flaggedDeps) = splitDeps deps
- in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps)
- splitDeps (ExRange p v1 v2:deps) =
+ in ((p, C.LMainLibName, C.thisVersion $ mkSimpleVersion v) : directDeps, flaggedDeps)
+ splitDeps (ExRange p v1 v2 : deps) =
let (directDeps, flaggedDeps) = splitDeps deps
- in ((p, C.LMainLibName, mkVersionRange v1 v2):directDeps, flaggedDeps)
- splitDeps (ExSubLibAny p lib:deps) =
+ in ((p, C.LMainLibName, mkVersionRange v1 v2) : directDeps, flaggedDeps)
+ splitDeps (ExSubLibAny p lib : deps) =
let (directDeps, flaggedDeps) = splitDeps deps
- in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion):directDeps, flaggedDeps)
- splitDeps (ExSubLibFix p lib v:deps) =
+ in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.anyVersion) : directDeps, flaggedDeps)
+ splitDeps (ExSubLibFix p lib v : deps) =
let (directDeps, flaggedDeps) = splitDeps deps
- in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v):directDeps, flaggedDeps)
- splitDeps (ExFlagged f a b:deps) =
+ in ((p, C.LSubLibName (C.mkUnqualComponentName lib), C.thisVersion $ mkSimpleVersion v) : directDeps, flaggedDeps)
+ splitDeps (ExFlagged f a b : deps) =
let (directDeps, flaggedDeps) = splitDeps deps
- in (directDeps, (f, a, b):flaggedDeps)
- splitDeps (dep:_) = error $ "Unexpected dependency: " ++ show dep
+ in (directDeps, (f, a, b) : flaggedDeps)
+ splitDeps (dep : _) = error $ "Unexpected dependency: " ++ show dep
-- custom-setup only supports simple dependencies
mkSetupDeps :: [ExampleDependency] -> [C.Dependency]
mkSetupDeps deps =
case splitDeps deps of
(directDeps, []) -> map mkDirect directDeps
- _ -> error "mkSetupDeps: custom setup has non-simple deps"
+ _ -> error "mkSetupDeps: custom setup has non-simple deps"
-- Check for `UnknownLanguages` and `UnknownExtensions`. See
isUnknownLangExt :: C.PackageCheck -> Bool
isUnknownLangExt pc = case C.explanation pc of
- C.UnknownExtensions {} -> True
- C.UnknownLanguages {} -> True
- _ -> False
+ C.UnknownExtensions{} -> True
+ C.UnknownLanguages{} -> True
+ _ -> False
isMissingUpperBound :: C.PackageCheck -> Bool
isMissingUpperBound pc = case C.explanation pc of
- C.MissingUpperBounds {} -> True
- _ -> False
-
+ C.MissingUpperBounds{} -> True
+ _ -> False
mkSimpleVersion :: ExamplePkgVersion -> C.Version
mkSimpleVersion n = C.mkVersion [n, 0, 0]
@@ -688,44 +721,50 @@ mkSimplePkgconfigVersion = C.versionToPkgconfigVersion . mkSimpleVersion
mkVersionRange :: ExamplePkgVersion -> ExamplePkgVersion -> C.VersionRange
mkVersionRange v1 v2 =
- C.intersectVersionRanges (C.orLaterVersion $ mkSimpleVersion v1)
- (C.earlierVersion $ mkSimpleVersion v2)
+ C.intersectVersionRanges
+ (C.orLaterVersion $ mkSimpleVersion v1)
+ (C.earlierVersion $ mkSimpleVersion v2)
mkFlag :: ExFlag -> C.PackageFlag
-mkFlag flag = C.MkPackageFlag {
- C.flagName = C.mkFlagName $ exFlagName flag
- , C.flagDescription = ""
- , C.flagDefault = exFlagDefault flag
- , C.flagManual =
- case exFlagType flag of
- Manual -> True
- Automatic -> False
- }
+mkFlag flag =
+ C.MkPackageFlag
+ { C.flagName = C.mkFlagName $ exFlagName flag
+ , C.flagDescription = ""
+ , C.flagDefault = exFlagDefault flag
+ , C.flagManual =
+ case exFlagType flag of
+ Manual -> True
+ Automatic -> False
+ }
mkDefaultFlag :: ExampleFlagName -> C.PackageFlag
-mkDefaultFlag flag = C.MkPackageFlag {
- C.flagName = C.mkFlagName flag
- , C.flagDescription = ""
- , C.flagDefault = True
- , C.flagManual = False
- }
+mkDefaultFlag flag =
+ C.MkPackageFlag
+ { C.flagName = C.mkFlagName flag
+ , C.flagDescription = ""
+ , C.flagDefault = True
+ , C.flagManual = False
+ }
exAvPkgId :: ExampleAvailable -> C.PackageIdentifier
-exAvPkgId ex = C.PackageIdentifier {
- pkgName = C.mkPackageName (exAvName ex)
+exAvPkgId ex =
+ C.PackageIdentifier
+ { pkgName = C.mkPackageName (exAvName ex)
, pkgVersion = C.mkVersion [exAvVersion ex, 0, 0]
}
exInstInfo :: ExampleInstalled -> IPI.InstalledPackageInfo
-exInstInfo ex = IPI.emptyInstalledPackageInfo {
- IPI.installedUnitId = C.mkUnitId (exInstHash ex)
- , IPI.sourcePackageId = exInstPkgId ex
- , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex)
+exInstInfo ex =
+ IPI.emptyInstalledPackageInfo
+ { IPI.installedUnitId = C.mkUnitId (exInstHash ex)
+ , IPI.sourcePackageId = exInstPkgId ex
+ , IPI.depends = map C.mkUnitId (exInstBuildAgainst ex)
}
exInstPkgId :: ExampleInstalled -> C.PackageIdentifier
-exInstPkgId ex = C.PackageIdentifier {
- pkgName = C.mkPackageName (exInstName ex)
+exInstPkgId ex =
+ C.PackageIdentifier
+ { pkgName = C.mkPackageName (exInstName ex)
, pkgVersion = C.mkVersion [exInstVersion ex, 0, 0]
}
@@ -735,94 +774,122 @@ exAvIdx = CI.PackageIndex.fromList . map exAvSrcPkg
exInstIdx :: [ExampleInstalled] -> C.PackageIndex.InstalledPackageIndex
exInstIdx = C.PackageIndex.fromList . map exInstInfo
-exResolve :: ExampleDb
- -- List of extensions supported by the compiler, or Nothing if unknown.
- -> Maybe [Extension]
- -- List of languages supported by the compiler, or Nothing if unknown.
- -> Maybe [Language]
- -> PC.PkgConfigDb
- -> [ExamplePkgName]
- -> Maybe Int
- -> CountConflicts
- -> FineGrainedConflicts
- -> MinimizeConflictSet
- -> IndependentGoals
- -> PreferOldest
- -> ReorderGoals
- -> AllowBootLibInstalls
- -> OnlyConstrained
- -> EnableBackjumping
- -> SolveExecutables
- -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
- -> [ExConstraint]
- -> [ExPreference]
- -> C.Verbosity
- -> EnableAllTests
- -> Progress String String CI.SolverInstallPlan.SolverInstallPlan
-exResolve db exts langs pkgConfigDb targets mbj countConflicts
- fineGrainedConflicts minimizeConflictSet indepGoals prefOldest reorder
- allowBootLibInstalls onlyConstrained enableBj solveExes goalOrder
- constraints prefs verbosity enableAllTests
- = resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params
- where
- defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
- compiler = defaultCompiler { C.compilerInfoExtensions = exts
- , C.compilerInfoLanguages = langs
- }
- (inst, avai) = partitionEithers db
- instIdx = exInstIdx inst
- avaiIdx = SourcePackageDb {
- packageIndex = exAvIdx avai
- , packagePreferences = Map.empty
- }
- enableTests
- | asBool enableAllTests = fmap (\p -> PackageConstraint
- (scopeToplevel (C.mkPackageName p))
- (PackagePropertyStanzas [TestStanzas]))
- (exDbPkgs db)
- | otherwise = []
- targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
- params = addConstraints (fmap toConstraint constraints)
- $ addConstraints (fmap toLpc enableTests)
- $ addPreferences (fmap toPref prefs)
- $ setCountConflicts countConflicts
- $ setFineGrainedConflicts fineGrainedConflicts
- $ setMinimizeConflictSet minimizeConflictSet
- $ setIndependentGoals indepGoals
- $ (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id)
- $ setReorderGoals reorder
- $ setMaxBackjumps mbj
- $ setAllowBootLibInstalls allowBootLibInstalls
- $ setOnlyConstrained onlyConstrained
- $ setEnableBackjumping enableBj
- $ setSolveExecutables solveExes
- $ setGoalOrder goalOrder
- $ setSolverVerbosity verbosity
- $ standardInstallPolicy instIdx avaiIdx targets'
- toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
-
- toConstraint (ExVersionConstraint scope v) =
+exResolve
+ :: ExampleDb
+ -- List of extensions supported by the compiler, or Nothing if unknown.
+ -> Maybe [Extension]
+ -- List of languages supported by the compiler, or Nothing if unknown.
+ -> Maybe [Language]
+ -> PC.PkgConfigDb
+ -> [ExamplePkgName]
+ -> Maybe Int
+ -> CountConflicts
+ -> FineGrainedConflicts
+ -> MinimizeConflictSet
+ -> IndependentGoals
+ -> PreferOldest
+ -> ReorderGoals
+ -> AllowBootLibInstalls
+ -> OnlyConstrained
+ -> EnableBackjumping
+ -> SolveExecutables
+ -> Maybe (Variable P.QPN -> Variable P.QPN -> Ordering)
+ -> [ExConstraint]
+ -> [ExPreference]
+ -> C.Verbosity
+ -> EnableAllTests
+ -> Progress String String CI.SolverInstallPlan.SolverInstallPlan
+exResolve
+ db
+ exts
+ langs
+ pkgConfigDb
+ targets
+ mbj
+ countConflicts
+ fineGrainedConflicts
+ minimizeConflictSet
+ indepGoals
+ prefOldest
+ reorder
+ allowBootLibInstalls
+ onlyConstrained
+ enableBj
+ solveExes
+ goalOrder
+ constraints
+ prefs
+ verbosity
+ enableAllTests =
+ resolveDependencies C.buildPlatform compiler pkgConfigDb Modular params
+ where
+ defaultCompiler = C.unknownCompilerInfo C.buildCompilerId C.NoAbiTag
+ compiler =
+ defaultCompiler
+ { C.compilerInfoExtensions = exts
+ , C.compilerInfoLanguages = langs
+ }
+ (inst, avai) = partitionEithers db
+ instIdx = exInstIdx inst
+ avaiIdx =
+ SourcePackageDb
+ { packageIndex = exAvIdx avai
+ , packagePreferences = Map.empty
+ }
+ enableTests
+ | asBool enableAllTests =
+ fmap
+ ( \p ->
+ PackageConstraint
+ (scopeToplevel (C.mkPackageName p))
+ (PackagePropertyStanzas [TestStanzas])
+ )
+ (exDbPkgs db)
+ | otherwise = []
+ targets' = fmap (\p -> NamedPackage (C.mkPackageName p) []) targets
+ params =
+ addConstraints (fmap toConstraint constraints) $
+ addConstraints (fmap toLpc enableTests) $
+ addPreferences (fmap toPref prefs) $
+ setCountConflicts countConflicts $
+ setFineGrainedConflicts fineGrainedConflicts $
+ setMinimizeConflictSet minimizeConflictSet $
+ setIndependentGoals indepGoals $
+ (if asBool prefOldest then setPreferenceDefault PreferAllOldest else id) $
+ setReorderGoals reorder $
+ setMaxBackjumps mbj $
+ setAllowBootLibInstalls allowBootLibInstalls $
+ setOnlyConstrained onlyConstrained $
+ setEnableBackjumping enableBj $
+ setSolveExecutables solveExes $
+ setGoalOrder goalOrder $
+ setSolverVerbosity verbosity $
+ standardInstallPolicy instIdx avaiIdx targets'
+ toLpc pc = LabeledPackageConstraint pc ConstraintSourceUnknown
+
+ toConstraint (ExVersionConstraint scope v) =
toLpc $ PackageConstraint scope (PackagePropertyVersion v)
- toConstraint (ExFlagConstraint scope fn b) =
+ toConstraint (ExFlagConstraint scope fn b) =
toLpc $ PackageConstraint scope (PackagePropertyFlags (C.mkFlagAssignment [(C.mkFlagName fn, b)]))
- toConstraint (ExStanzaConstraint scope stanzas) =
+ toConstraint (ExStanzaConstraint scope stanzas) =
toLpc $ PackageConstraint scope (PackagePropertyStanzas stanzas)
- toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v
- toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas
+ toPref (ExPkgPref n v) = PackageVersionPreference (C.mkPackageName n) v
+ toPref (ExStanzaPref n stanzas) = PackageStanzasPreference (C.mkPackageName n) stanzas
-extractInstallPlan :: CI.SolverInstallPlan.SolverInstallPlan
- -> [(ExamplePkgName, ExamplePkgVersion)]
+extractInstallPlan
+ :: CI.SolverInstallPlan.SolverInstallPlan
+ -> [(ExamplePkgName, ExamplePkgVersion)]
extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList
where
confPkg :: CI.SolverInstallPlan.SolverPlanPackage -> Maybe (String, Int)
confPkg (CI.SolverInstallPlan.Configured pkg) = srcPkg pkg
- confPkg _ = Nothing
+ confPkg _ = Nothing
srcPkg :: SolverPackage UnresolvedPkgLoc -> Maybe (String, Int)
srcPkg cpkg =
let C.PackageIdentifier pn ver = C.packageId (solverPkgSource cpkg)
- in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver)
+ in (\vn -> (C.unPackageName pn, vn)) <$> safeHead (C.versionNumbers ver)
{-------------------------------------------------------------------------------
Auxiliary
@@ -832,6 +899,6 @@ extractInstallPlan = catMaybes . map confPkg . CI.SolverInstallPlan.toList
runProgress :: Progress step e a -> ([step], Either e a)
runProgress = go
where
- go (Step s p) = let (ss, result) = go p in (s:ss, result)
- go (Fail e) = ([], Left e)
- go (Done a) = ([], Right a)
+ go (Step s p) = let (ss, result) = go p in (s : ss, result)
+ go (Fail e) = ([], Left e)
+ go (Done a) = ([], Right a)
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
index 1d29baaad1246850bebc1142ecb4550606721ddb..91ec541f976e168a933060e14264b6cba260141f 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs
@@ -1,8 +1,9 @@
{-# LANGUAGE RecordWildCards #-}
+
-- | Utilities for creating HUnit test cases with the solver DSL.
-module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils (
- SolverTest
- , SolverResult(..)
+module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
+ ( SolverTest
+ , SolverResult (..)
, maxBackjumps
, disableFineGrainedConflicts
, minimizeConflictSet
@@ -28,119 +29,119 @@ module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils (
, runTest
) where
-import Prelude ()
import Distribution.Solver.Compat.Prelude
+import Prelude ()
import Data.List (elemIndex)
-- test-framework
import Test.Tasty as TF
-import Test.Tasty.HUnit (testCase, assertEqual, assertBool)
+import Test.Tasty.HUnit (assertBool, assertEqual, testCase)
-- Cabal
import qualified Distribution.PackageDescription as C
-import Language.Haskell.Extension (Extension(..), Language(..))
import Distribution.Verbosity
+import Language.Haskell.Extension (Extension (..), Language (..))
-- cabal-install
+
+import Distribution.Client.Dependency (foldProgress)
import qualified Distribution.Solver.Types.PackagePath as P
import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb (..), pkgConfigDbFromList)
import Distribution.Solver.Types.Settings
import Distribution.Solver.Types.Variable
-import Distribution.Client.Dependency (foldProgress)
import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Options
maxBackjumps :: Maybe Int -> SolverTest -> SolverTest
-maxBackjumps mbj test = test { testMaxBackjumps = mbj }
+maxBackjumps mbj test = test{testMaxBackjumps = mbj}
disableFineGrainedConflicts :: SolverTest -> SolverTest
disableFineGrainedConflicts test =
- test { testFineGrainedConflicts = FineGrainedConflicts False }
+ test{testFineGrainedConflicts = FineGrainedConflicts False}
minimizeConflictSet :: SolverTest -> SolverTest
minimizeConflictSet test =
- test { testMinimizeConflictSet = MinimizeConflictSet True }
+ test{testMinimizeConflictSet = MinimizeConflictSet True}
-- | Combinator to turn on --independent-goals behavior, i.e. solve
-- for the goals as if we were solving for each goal independently.
independentGoals :: SolverTest -> SolverTest
-independentGoals test = test { testIndepGoals = IndependentGoals True }
+independentGoals test = test{testIndepGoals = IndependentGoals True}
-- | Combinator to turn on --prefer-oldest
preferOldest :: SolverTest -> SolverTest
-preferOldest test = test { testPreferOldest = PreferOldest True }
+preferOldest test = test{testPreferOldest = PreferOldest True}
allowBootLibInstalls :: SolverTest -> SolverTest
allowBootLibInstalls test =
- test { testAllowBootLibInstalls = AllowBootLibInstalls True }
+ test{testAllowBootLibInstalls = AllowBootLibInstalls True}
onlyConstrained :: SolverTest -> SolverTest
onlyConstrained test =
- test { testOnlyConstrained = OnlyConstrainedAll }
+ test{testOnlyConstrained = OnlyConstrainedAll}
disableBackjumping :: SolverTest -> SolverTest
disableBackjumping test =
- test { testEnableBackjumping = EnableBackjumping False }
+ test{testEnableBackjumping = EnableBackjumping False}
disableSolveExecutables :: SolverTest -> SolverTest
disableSolveExecutables test =
- test { testSolveExecutables = SolveExecutables False }
+ test{testSolveExecutables = SolveExecutables False}
goalOrder :: [ExampleVar] -> SolverTest -> SolverTest
-goalOrder order test = test { testGoalOrder = Just order }
+goalOrder order test = test{testGoalOrder = Just order}
constraints :: [ExConstraint] -> SolverTest -> SolverTest
-constraints cs test = test { testConstraints = cs }
+constraints cs test = test{testConstraints = cs}
preferences :: [ExPreference] -> SolverTest -> SolverTest
-preferences prefs test = test { testSoftConstraints = prefs }
+preferences prefs test = test{testSoftConstraints = prefs}
-- | Increase the solver's verbosity. This is necessary for test cases that
-- check the contents of the verbose log.
setVerbose :: SolverTest -> SolverTest
-setVerbose test = test { testVerbosity = verbose }
+setVerbose test = test{testVerbosity = verbose}
enableAllTests :: SolverTest -> SolverTest
-enableAllTests test = test { testEnableAllTests = EnableAllTests True }
+enableAllTests test = test{testEnableAllTests = EnableAllTests True}
{-------------------------------------------------------------------------------
Solver tests
-------------------------------------------------------------------------------}
-data SolverTest = SolverTest {
- testLabel :: String
- , testTargets :: [String]
- , testResult :: SolverResult
- , testMaxBackjumps :: Maybe Int
+data SolverTest = SolverTest
+ { testLabel :: String
+ , testTargets :: [String]
+ , testResult :: SolverResult
+ , testMaxBackjumps :: Maybe Int
, testFineGrainedConflicts :: FineGrainedConflicts
- , testMinimizeConflictSet :: MinimizeConflictSet
- , testIndepGoals :: IndependentGoals
- , testPreferOldest :: PreferOldest
+ , testMinimizeConflictSet :: MinimizeConflictSet
+ , testIndepGoals :: IndependentGoals
+ , testPreferOldest :: PreferOldest
, testAllowBootLibInstalls :: AllowBootLibInstalls
- , testOnlyConstrained :: OnlyConstrained
- , testEnableBackjumping :: EnableBackjumping
- , testSolveExecutables :: SolveExecutables
- , testGoalOrder :: Maybe [ExampleVar]
- , testConstraints :: [ExConstraint]
- , testSoftConstraints :: [ExPreference]
- , testVerbosity :: Verbosity
- , testDb :: ExampleDb
- , testSupportedExts :: Maybe [Extension]
- , testSupportedLangs :: Maybe [Language]
- , testPkgConfigDb :: PkgConfigDb
- , testEnableAllTests :: EnableAllTests
+ , testOnlyConstrained :: OnlyConstrained
+ , testEnableBackjumping :: EnableBackjumping
+ , testSolveExecutables :: SolveExecutables
+ , testGoalOrder :: Maybe [ExampleVar]
+ , testConstraints :: [ExConstraint]
+ , testSoftConstraints :: [ExPreference]
+ , testVerbosity :: Verbosity
+ , testDb :: ExampleDb
+ , testSupportedExts :: Maybe [Extension]
+ , testSupportedLangs :: Maybe [Language]
+ , testPkgConfigDb :: PkgConfigDb
+ , testEnableAllTests :: EnableAllTests
}
-- | Expected result of a solver test.
-data SolverResult = SolverResult {
- -- | The solver's log should satisfy this predicate. Note that we also print
- -- the log, so evaluating a large log here can cause a space leak.
- resultLogPredicate :: [String] -> Bool,
-
- -- | Fails with an error message satisfying the predicate, or succeeds with
- -- the given plan.
- resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)]
+data SolverResult = SolverResult
+ { resultLogPredicate :: [String] -> Bool
+ -- ^ The solver's log should satisfy this predicate. Note that we also print
+ -- the log, so evaluating a large log here can cause a space leak.
+ , resultErrorMsgPredicateOrPlan :: Either (String -> Bool) [(String, Int)]
+ -- ^ Fails with an error message satisfying the predicate, or succeeds with
+ -- the given plan.
}
solverSuccess :: [(String, Int)] -> SolverResult
@@ -167,124 +168,159 @@ anySolverFailure = solverFailure (const True)
-- See 'UnitTests.Distribution.Solver.Modular.DSL' for how
-- to construct an 'ExampleDb', as well as definitions of 'db1' etc.
-- in this file.
-mkTest :: ExampleDb
- -> String
- -> [String]
- -> SolverResult
- -> SolverTest
+mkTest
+ :: ExampleDb
+ -> String
+ -> [String]
+ -> SolverResult
+ -> SolverTest
mkTest = mkTestExtLangPC Nothing Nothing (Just [])
-mkTestExts :: [Extension]
- -> ExampleDb
- -> String
- -> [String]
- -> SolverResult
- -> SolverTest
+mkTestExts
+ :: [Extension]
+ -> ExampleDb
+ -> String
+ -> [String]
+ -> SolverResult
+ -> SolverTest
mkTestExts exts = mkTestExtLangPC (Just exts) Nothing (Just [])
-mkTestLangs :: [Language]
- -> ExampleDb
- -> String
- -> [String]
- -> SolverResult
- -> SolverTest
+mkTestLangs
+ :: [Language]
+ -> ExampleDb
+ -> String
+ -> [String]
+ -> SolverResult
+ -> SolverTest
mkTestLangs langs = mkTestExtLangPC Nothing (Just langs) (Just [])
-mkTestPCDepends :: Maybe [(String, String)]
- -> ExampleDb
- -> String
- -> [String]
- -> SolverResult
- -> SolverTest
+mkTestPCDepends
+ :: Maybe [(String, String)]
+ -> ExampleDb
+ -> String
+ -> [String]
+ -> SolverResult
+ -> SolverTest
mkTestPCDepends mPkgConfigDb = mkTestExtLangPC Nothing Nothing mPkgConfigDb
-mkTestExtLangPC :: Maybe [Extension]
- -> Maybe [Language]
- -> Maybe [(String, String)]
- -> ExampleDb
- -> String
- -> [String]
- -> SolverResult
- -> SolverTest
-mkTestExtLangPC exts langs mPkgConfigDb db label targets result = SolverTest {
- testLabel = label
- , testTargets = targets
- , testResult = result
- , testMaxBackjumps = Nothing
- , testFineGrainedConflicts = FineGrainedConflicts True
- , testMinimizeConflictSet = MinimizeConflictSet False
- , testIndepGoals = IndependentGoals False
- , testPreferOldest = PreferOldest False
- , testAllowBootLibInstalls = AllowBootLibInstalls False
- , testOnlyConstrained = OnlyConstrainedNone
- , testEnableBackjumping = EnableBackjumping True
- , testSolveExecutables = SolveExecutables True
- , testGoalOrder = Nothing
- , testConstraints = []
- , testSoftConstraints = []
- , testVerbosity = normal
- , testDb = db
- , testSupportedExts = exts
- , testSupportedLangs = langs
- , testPkgConfigDb = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb
- , testEnableAllTests = EnableAllTests False
- }
+mkTestExtLangPC
+ :: Maybe [Extension]
+ -> Maybe [Language]
+ -> Maybe [(String, String)]
+ -> ExampleDb
+ -> String
+ -> [String]
+ -> SolverResult
+ -> SolverTest
+mkTestExtLangPC exts langs mPkgConfigDb db label targets result =
+ SolverTest
+ { testLabel = label
+ , testTargets = targets
+ , testResult = result
+ , testMaxBackjumps = Nothing
+ , testFineGrainedConflicts = FineGrainedConflicts True
+ , testMinimizeConflictSet = MinimizeConflictSet False
+ , testIndepGoals = IndependentGoals False
+ , testPreferOldest = PreferOldest False
+ , testAllowBootLibInstalls = AllowBootLibInstalls False
+ , testOnlyConstrained = OnlyConstrainedNone
+ , testEnableBackjumping = EnableBackjumping True
+ , testSolveExecutables = SolveExecutables True
+ , testGoalOrder = Nothing
+ , testConstraints = []
+ , testSoftConstraints = []
+ , testVerbosity = normal
+ , testDb = db
+ , testSupportedExts = exts
+ , testSupportedLangs = langs
+ , testPkgConfigDb = maybe NoPkgConfigDb pkgConfigDbFromList mPkgConfigDb
+ , testEnableAllTests = EnableAllTests False
+ }
runTest :: SolverTest -> TF.TestTree
runTest SolverTest{..} = askOption $ \(OptionShowSolverLog showSolverLog) ->
- testCase testLabel $ do
- let progress = exResolve testDb testSupportedExts
- testSupportedLangs testPkgConfigDb testTargets
- testMaxBackjumps (CountConflicts True)
- testFineGrainedConflicts testMinimizeConflictSet
- testIndepGoals testPreferOldest (ReorderGoals False) testAllowBootLibInstalls
- testOnlyConstrained testEnableBackjumping testSolveExecutables
- (sortGoals <$> testGoalOrder) testConstraints
- testSoftConstraints testVerbosity testEnableAllTests
- printMsg msg = when showSolverLog $ putStrLn msg
- msgs = foldProgress (:) (const []) (const []) progress
- assertBool ("Unexpected solver log:\n" ++ unlines msgs) $
- resultLogPredicate testResult $ concatMap lines msgs
- result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress
- case result of
- Left err -> assertBool ("Unexpected error:\n" ++ err)
- (checkErrorMsg testResult err)
- Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))
+ testCase testLabel $ do
+ let progress =
+ exResolve
+ testDb
+ testSupportedExts
+ testSupportedLangs
+ testPkgConfigDb
+ testTargets
+ testMaxBackjumps
+ (CountConflicts True)
+ testFineGrainedConflicts
+ testMinimizeConflictSet
+ testIndepGoals
+ testPreferOldest
+ (ReorderGoals False)
+ testAllowBootLibInstalls
+ testOnlyConstrained
+ testEnableBackjumping
+ testSolveExecutables
+ (sortGoals <$> testGoalOrder)
+ testConstraints
+ testSoftConstraints
+ testVerbosity
+ testEnableAllTests
+ printMsg msg = when showSolverLog $ putStrLn msg
+ msgs = foldProgress (:) (const []) (const []) progress
+ assertBool ("Unexpected solver log:\n" ++ unlines msgs) $
+ resultLogPredicate testResult $
+ concatMap lines msgs
+ result <- foldProgress ((>>) . printMsg) (return . Left) (return . Right) progress
+ case result of
+ Left err ->
+ assertBool
+ ("Unexpected error:\n" ++ err)
+ (checkErrorMsg testResult err)
+ Right plan -> assertEqual "" (toMaybe testResult) (Just (extractInstallPlan plan))
where
toMaybe :: SolverResult -> Maybe [(String, Int)]
toMaybe = either (const Nothing) Just . resultErrorMsgPredicateOrPlan
checkErrorMsg :: SolverResult -> String -> Bool
checkErrorMsg result msg =
- case resultErrorMsgPredicateOrPlan result of
- Left f -> f msg
- Right _ -> False
-
- sortGoals :: [ExampleVar]
- -> Variable P.QPN -> Variable P.QPN -> Ordering
+ case resultErrorMsgPredicateOrPlan result of
+ Left f -> f msg
+ Right _ -> False
+
+ sortGoals
+ :: [ExampleVar]
+ -> Variable P.QPN
+ -> Variable P.QPN
+ -> Ordering
sortGoals = orderFromList . map toVariable
-- Sort elements in the list ahead of elements not in the list. Otherwise,
-- follow the order in the list.
orderFromList :: Eq a => [a] -> a -> a -> Ordering
orderFromList xs =
- comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
+ comparing $ \x -> let i = elemIndex x xs in (isNothing i, i)
toVariable :: ExampleVar -> Variable P.QPN
- toVariable (P q pn) = PackageVar (toQPN q pn)
- toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn)
- toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
+ toVariable (P q pn) = PackageVar (toQPN q pn)
+ toVariable (F q pn fn) = FlagVar (toQPN q pn) (C.mkFlagName fn)
+ toVariable (S q pn stanza) = StanzaVar (toQPN q pn) stanza
toQPN :: ExampleQualifier -> ExamplePkgName -> P.QPN
toQPN q pn = P.Q pp (C.mkPackageName pn)
where
pp = case q of
- QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
- QualIndep p -> P.PackagePath (P.Independent $ C.mkPackageName p)
- P.QualToplevel
- QualSetup s -> P.PackagePath P.DefaultNamespace
- (P.QualSetup (C.mkPackageName s))
- QualIndepSetup p s -> P.PackagePath (P.Independent $ C.mkPackageName p)
- (P.QualSetup (C.mkPackageName s))
- QualExe p1 p2 -> P.PackagePath P.DefaultNamespace
- (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))
+ QualNone -> P.PackagePath P.DefaultNamespace P.QualToplevel
+ QualIndep p ->
+ P.PackagePath
+ (P.Independent $ C.mkPackageName p)
+ P.QualToplevel
+ QualSetup s ->
+ P.PackagePath
+ P.DefaultNamespace
+ (P.QualSetup (C.mkPackageName s))
+ QualIndepSetup p s ->
+ P.PackagePath
+ (P.Independent $ C.mkPackageName p)
+ (P.QualSetup (C.mkPackageName s))
+ QualExe p1 p2 ->
+ P.PackagePath
+ P.DefaultNamespace
+ (P.QualExe (C.mkPackageName p1) (C.mkPackageName p2))
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs
index 463e56bd7e6be33f049dcd9fc43a1ef9b9d6be91..ba63db84760c7e22c2f20e51004286c6ef3da67e 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/MemoryUsage.hs
@@ -7,13 +7,13 @@ import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
tests :: [TestTree]
-tests = [
- runTest $ basicTest "basic space leak test"
- , runTest $ flagsTest "package with many flags"
- , runTest $ issue2899 "issue #2899"
- , runTest $ duplicateDependencies "duplicate dependencies"
- , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies"
- ]
+tests =
+ [ runTest $ basicTest "basic space leak test"
+ , runTest $ flagsTest "package with many flags"
+ , runTest $ issue2899 "issue #2899"
+ , runTest $ duplicateDependencies "duplicate dependencies"
+ , runTest $ duplicateFlaggedDependencies "duplicate flagged dependencies"
+ ]
-- | This test solves for n packages that each have two versions. There is no
-- solution, because the nth package depends on another package that doesn't fit
@@ -22,19 +22,22 @@ tests = [
-- memory usage is proportional to the size of the tree.
basicTest :: String -> SolverTest
basicTest name =
- disableBackjumping $
+ disableBackjumping $
disableFineGrainedConflicts $
- mkTest pkgs name ["target"] anySolverFailure
+ mkTest pkgs name ["target"] anySolverFailure
where
n :: Int
n = 18
pkgs :: ExampleDb
- pkgs = map Right $
- [ exAv "target" 1 [ExAny $ pkgName 1]]
- ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4]
- | i <- [1..n], v <- [2, 3]]
- ++ [exAv (pkgName $ n + 1) 1 []]
+ pkgs =
+ map Right $
+ [exAv "target" 1 [ExAny $ pkgName 1]]
+ ++ [ exAv (pkgName i) v [ExRange (pkgName $ i + 1) 2 4]
+ | i <- [1 .. n]
+ , v <- [2, 3]
+ ]
+ ++ [exAv (pkgName $ n + 1) 1 []]
pkgName :: Int -> ExamplePkgName
pkgName x = "pkg-" ++ show x
@@ -45,23 +48,25 @@ basicTest name =
-- all of the flags. It has to explore the whole search tree.
flagsTest :: String -> SolverTest
flagsTest name =
- disableBackjumping $
+ disableBackjumping $
disableFineGrainedConflicts $
- goalOrder orderedFlags $ mkTest pkgs name ["pkg"] anySolverFailure
+ goalOrder orderedFlags $
+ mkTest pkgs name ["pkg"] anySolverFailure
where
n :: Int
n = 16
pkgs :: ExampleDb
- pkgs = [Right $ exAv "pkg" 1 $
- [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]]
-
- -- The remaining flags have no effect:
- ++ [exFlagged (numberedFlag i) [] [] | i <- [1..n - 1]]
- ]
+ pkgs =
+ [ Right $
+ exAv "pkg" 1 $
+ [exFlagged (numberedFlag n) [ExAny "unknown1"] [ExAny "unknown2"]]
+ -- The remaining flags have no effect:
+ ++ [exFlagged (numberedFlag i) [] [] | i <- [1 .. n - 1]]
+ ]
orderedFlags :: [ExampleVar]
- orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1..n]]
+ orderedFlags = [F QualNone "pkg" (numberedFlag i) | i <- [1 .. n]]
-- | Test for a space leak caused by sharing of search trees under packages with
-- link choices (issue #2899).
@@ -80,19 +85,24 @@ flagsTest name =
-- trees are shared, memory usage spikes.
issue2899 :: String -> SolverTest
issue2899 name =
- disableBackjumping $
+ disableBackjumping $
disableFineGrainedConflicts $
- goalOrder goals $ mkTest pkgs name ["target"] anySolverFailure
+ goalOrder goals $
+ mkTest pkgs name ["target"] anySolverFailure
where
n :: Int
n = 16
pkgs :: ExampleDb
- pkgs = map Right $
- [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"]
- , exAv "setup-dep" 1 [ExAny $ pkgName 1]]
- ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)]
- | i <- [1..n], v <- [1, 2]]
+ pkgs =
+ map Right $
+ [ exAv "target" 1 [ExAny "setup-dep"] `withSetupDeps` [ExAny "setup-dep"]
+ , exAv "setup-dep" 1 [ExAny $ pkgName 1]
+ ]
+ ++ [ exAv (pkgName i) v [ExAny $ pkgName (i + 1)]
+ | i <- [1 .. n]
+ , v <- [1, 2]
+ ]
pkgName :: Int -> ExamplePkgName
pkgName x = "pkg-" ++ show x
@@ -141,26 +151,31 @@ issue2899 name =
-- build-tool dependencies.
duplicateDependencies :: String -> SolverTest
duplicateDependencies name =
- mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
+ mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
where
copies, depth :: Int
copies = 50
depth = 50
pkgs :: ExampleDb
- pkgs = [
- Right $ exAv "A" 1 (dependencyTree 1)
+ pkgs =
+ [ Right $ exAv "A" 1 (dependencyTree 1)
, Right $ exAv "B" 1 [] `withExe` exExe "exe" []
]
dependencyTree :: Int -> [ExampleDependency]
dependencyTree n
- | n > depth = buildDepends
- | otherwise = [exFlagged (numberedFlag n) buildDepends
- (dependencyTree (n + 1))]
+ | n > depth = buildDepends
+ | otherwise =
+ [ exFlagged
+ (numberedFlag n)
+ buildDepends
+ (dependencyTree (n + 1))
+ ]
where
- buildDepends = replicate copies (ExFix "B" 1)
- ++ replicate copies (ExBuildToolFix "B" "exe" 1)
+ buildDepends =
+ replicate copies (ExFix "B" 1)
+ ++ replicate copies (ExBuildToolFix "B" "exe" 1)
-- | This test is similar to duplicateDependencies, except that every dependency
-- on B is replaced by a conditional that contains B in both branches. It tests
@@ -169,27 +184,34 @@ duplicateDependencies name =
-- are lifted out of conditionals.
duplicateFlaggedDependencies :: String -> SolverTest
duplicateFlaggedDependencies name =
- mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
+ mkTest pkgs name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
where
copies, depth :: Int
copies = 15
depth = 15
pkgs :: ExampleDb
- pkgs = [
- Right $ exAv "A" 1 (dependencyTree 1)
+ pkgs =
+ [ Right $ exAv "A" 1 (dependencyTree 1)
, Right $ exAv "B" 1 [] `withExe` exExe "exe" []
]
dependencyTree :: Int -> [ExampleDependency]
dependencyTree n
- | n > depth = flaggedDeps
- | otherwise = [exFlagged (numberedFlag n) flaggedDeps
- (dependencyTree (n + 1))]
+ | n > depth = flaggedDeps
+ | otherwise =
+ [ exFlagged
+ (numberedFlag n)
+ flaggedDeps
+ (dependencyTree (n + 1))
+ ]
where
flaggedDeps = zipWith ($) (replicate copies flaggedDep) [0 :: Int ..]
- flaggedDep m = exFlagged (numberedFlag n ++ "-" ++ show m) buildDepends
- buildDepends
+ flaggedDep m =
+ exFlagged
+ (numberedFlag n ++ "-" ++ show m)
+ buildDepends
+ buildDepends
buildDepends = [ExFix "B" 1, ExBuildToolFix "B" "exe" 1]
numberedFlag :: Int -> ExampleFlagName
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
index 7ac722f2e38171b881586678e0fe1c42759af4c5..114db775f2118208d76e56ce6f1f70a9cf71cac7 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs
@@ -5,114 +5,143 @@
module UnitTests.Distribution.Solver.Modular.QuickCheck (tests) where
-import Prelude ()
import Distribution.Client.Compat.Prelude
+import Prelude ()
import Control.Arrow ((&&&))
import Data.Either (lefts)
-import Data.Hashable (Hashable(..))
+import Data.Hashable (Hashable (..))
import Data.List (groupBy, isInfixOf)
import Text.Show.Pretty (parseValue, valToStr)
-import Test.Tasty (TestTree)
-import Test.QuickCheck (Arbitrary (..), Gen, Positive (..), frequency, oneof, shrinkList, shuffle, listOf, shrinkNothing, vectorOf, elements, sublistOf, counterexample, (===), (==>), Blind (..))
+import Test.QuickCheck (Arbitrary (..), Blind (..), Gen, Positive (..), counterexample, elements, frequency, listOf, oneof, shrinkList, shrinkNothing, shuffle, sublistOf, vectorOf, (===), (==>))
import Test.QuickCheck.Instances.Cabal ()
+import Test.Tasty (TestTree)
import Distribution.Types.Flag (FlagName)
import Distribution.Utils.ShortText (ShortText)
import Distribution.Client.Setup (defaultMaxBackjumps)
-import Distribution.Types.LibraryVisibility
-import Distribution.Types.PackageName
-import Distribution.Types.UnqualComponentName
+import Distribution.Types.LibraryVisibility
+import Distribution.Types.PackageName
+import Distribution.Types.UnqualComponentName
+import Distribution.Solver.Types.ComponentDeps
+ ( Component (..)
+ , ComponentDep
+ , ComponentDeps
+ )
import qualified Distribution.Solver.Types.ComponentDeps as CD
-import Distribution.Solver.Types.ComponentDeps
- ( Component(..), ComponentDep, ComponentDeps )
-import Distribution.Solver.Types.OptionalStanza
-import Distribution.Solver.Types.PackageConstraint
+import Distribution.Solver.Types.OptionalStanza
+import Distribution.Solver.Types.PackageConstraint
import qualified Distribution.Solver.Types.PackagePath as P
-import Distribution.Solver.Types.PkgConfigDb
- (pkgConfigDbFromList)
-import Distribution.Solver.Types.Settings
-import Distribution.Solver.Types.Variable
-import Distribution.Verbosity
-import Distribution.Version
+import Distribution.Solver.Types.PkgConfigDb
+ ( pkgConfigDbFromList
+ )
+import Distribution.Solver.Types.Settings
+import Distribution.Solver.Types.Variable
+import Distribution.Verbosity
+import Distribution.Version
import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Distribution.Solver.Modular.QuickCheck.Utils
- ( testPropertyWithSeed )
+ ( testPropertyWithSeed
+ )
tests :: [TestTree]
-tests = [
- -- This test checks that certain solver parameters do not affect the
- -- existence of a solution. It runs the solver twice, and only sets those
- -- parameters on the second run. The test also applies parameters that
- -- can affect the existence of a solution to both runs.
- testPropertyWithSeed "target and goal order do not affect solvability" $
- \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals ->
- let r1 = solve' mGoalOrder1 test
- r2 = solve' mGoalOrder2 test { testTargets = targets2 }
- solve' goalOrder =
- solve (EnableBackjumping True) (FineGrainedConflicts True)
- (ReorderGoals False) (CountConflicts True) indepGoals (PreferOldest False)
- (getBlind <$> goalOrder)
- targets = testTargets test
- targets2 = case targetOrder of
- SameOrder -> targets
- ReverseOrder -> reverse targets
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
- isRight (resultPlan r1) === isRight (resultPlan r2)
-
- , testPropertyWithSeed
- "solvable without --independent-goals => solvable with --independent-goals" $
- \test reorderGoals ->
- let r1 = solve' (IndependentGoals False) test
- r2 = solve' (IndependentGoals True) test
- solve' indep =
- solve (EnableBackjumping True) (FineGrainedConflicts True)
- reorderGoals (CountConflicts True) indep (PreferOldest False)Nothing
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
+tests =
+ [ -- This test checks that certain solver parameters do not affect the
+ -- existence of a solution. It runs the solver twice, and only sets those
+ -- parameters on the second run. The test also applies parameters that
+ -- can affect the existence of a solution to both runs.
+ testPropertyWithSeed "target and goal order do not affect solvability" $
+ \test targetOrder mGoalOrder1 mGoalOrder2 indepGoals ->
+ let r1 = solve' mGoalOrder1 test
+ r2 = solve' mGoalOrder2 test{testTargets = targets2}
+ solve' goalOrder =
+ solve
+ (EnableBackjumping True)
+ (FineGrainedConflicts True)
+ (ReorderGoals False)
+ (CountConflicts True)
+ indepGoals
+ (PreferOldest False)
+ (getBlind <$> goalOrder)
+ targets = testTargets test
+ targets2 = case targetOrder of
+ SameOrder -> targets
+ ReverseOrder -> reverse targets
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
+ isRight (resultPlan r1) === isRight (resultPlan r2)
+ , testPropertyWithSeed
+ "solvable without --independent-goals => solvable with --independent-goals"
+ $ \test reorderGoals ->
+ let r1 = solve' (IndependentGoals False) test
+ r2 = solve' (IndependentGoals True) test
+ solve' indep =
+ solve
+ (EnableBackjumping True)
+ (FineGrainedConflicts True)
+ reorderGoals
+ (CountConflicts True)
+ indep
+ (PreferOldest False)
+ Nothing
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
isRight (resultPlan r1) `implies` isRight (resultPlan r2)
-
- , testPropertyWithSeed "backjumping does not affect solvability" $
- \test reorderGoals indepGoals ->
- let r1 = solve' (EnableBackjumping True) test
- r2 = solve' (EnableBackjumping False) test
- solve' enableBj =
- solve enableBj (FineGrainedConflicts False) reorderGoals
- (CountConflicts True) indepGoals (PreferOldest False) Nothing
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
+ , testPropertyWithSeed "backjumping does not affect solvability" $
+ \test reorderGoals indepGoals ->
+ let r1 = solve' (EnableBackjumping True) test
+ r2 = solve' (EnableBackjumping False) test
+ solve' enableBj =
+ solve
+ enableBj
+ (FineGrainedConflicts False)
+ reorderGoals
+ (CountConflicts True)
+ indepGoals
+ (PreferOldest False)
+ Nothing
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
isRight (resultPlan r1) === isRight (resultPlan r2)
-
- , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $
- \test reorderGoals indepGoals ->
- let r1 = solve' (FineGrainedConflicts True) test
- r2 = solve' (FineGrainedConflicts False) test
- solve' fineGrainedConflicts =
- solve (EnableBackjumping True) fineGrainedConflicts
- reorderGoals (CountConflicts True) indepGoals (PreferOldest False) Nothing
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
+ , testPropertyWithSeed "fine-grained conflicts does not affect solvability" $
+ \test reorderGoals indepGoals ->
+ let r1 = solve' (FineGrainedConflicts True) test
+ r2 = solve' (FineGrainedConflicts False) test
+ solve' fineGrainedConflicts =
+ solve
+ (EnableBackjumping True)
+ fineGrainedConflicts
+ reorderGoals
+ (CountConflicts True)
+ indepGoals
+ (PreferOldest False)
+ Nothing
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
isRight (resultPlan r1) === isRight (resultPlan r2)
-
- , testPropertyWithSeed "prefer oldest does not affect solvability" $
- \test reorderGoals indepGoals ->
- let r1 = solve' (PreferOldest True) test
- r2 = solve' (PreferOldest False) test
- solve' prefOldest =
- solve (EnableBackjumping True) (FineGrainedConflicts True)
- reorderGoals (CountConflicts True) indepGoals prefOldest Nothing
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
+ , testPropertyWithSeed "prefer oldest does not affect solvability" $
+ \test reorderGoals indepGoals ->
+ let r1 = solve' (PreferOldest True) test
+ r2 = solve' (PreferOldest False) test
+ solve' prefOldest =
+ solve
+ (EnableBackjumping True)
+ (FineGrainedConflicts True)
+ reorderGoals
+ (CountConflicts True)
+ indepGoals
+ prefOldest
+ Nothing
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
isRight (resultPlan r1) === isRight (resultPlan r2)
-
- -- The next two tests use --no-count-conflicts, because the goal order used
+ , -- The next two tests use --no-count-conflicts, because the goal order used
-- with --count-conflicts depends on the total set of conflicts seen by the
-- solver. The solver explores more of the tree and encounters more
-- conflicts when it doesn't backjump. The different goal orders can lead to
@@ -120,94 +149,120 @@ tests = [
-- TODO: Find a faster way to randomly sort goals, and then use a random
-- goal order in these tests.
- , testPropertyWithSeed
- "backjumping does not affect the result (with static goal order)" $
- \test reorderGoals indepGoals ->
- let r1 = solve' (EnableBackjumping True) test
- r2 = solve' (EnableBackjumping False) test
- solve' enableBj =
- solve enableBj (FineGrainedConflicts False) reorderGoals
- (CountConflicts False) indepGoals (PreferOldest False) Nothing
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
+ testPropertyWithSeed
+ "backjumping does not affect the result (with static goal order)"
+ $ \test reorderGoals indepGoals ->
+ let r1 = solve' (EnableBackjumping True) test
+ r2 = solve' (EnableBackjumping False) test
+ solve' enableBj =
+ solve
+ enableBj
+ (FineGrainedConflicts False)
+ reorderGoals
+ (CountConflicts False)
+ indepGoals
+ (PreferOldest False)
+ Nothing
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
resultPlan r1 === resultPlan r2
-
- , testPropertyWithSeed
- "fine-grained conflicts does not affect the result (with static goal order)" $
- \test reorderGoals indepGoals ->
- let r1 = solve' (FineGrainedConflicts True) test
- r2 = solve' (FineGrainedConflicts False) test
- solve' fineGrainedConflicts =
- solve (EnableBackjumping True) fineGrainedConflicts
- reorderGoals (CountConflicts False) indepGoals (PreferOldest False) Nothing
- in counterexample (showResults r1 r2) $
- noneReachedBackjumpLimit [r1, r2] ==>
+ , testPropertyWithSeed
+ "fine-grained conflicts does not affect the result (with static goal order)"
+ $ \test reorderGoals indepGoals ->
+ let r1 = solve' (FineGrainedConflicts True) test
+ r2 = solve' (FineGrainedConflicts False) test
+ solve' fineGrainedConflicts =
+ solve
+ (EnableBackjumping True)
+ fineGrainedConflicts
+ reorderGoals
+ (CountConflicts False)
+ indepGoals
+ (PreferOldest False)
+ Nothing
+ in counterexample (showResults r1 r2) $
+ noneReachedBackjumpLimit [r1, r2] ==>
resultPlan r1 === resultPlan r2
- ]
+ ]
where
noneReachedBackjumpLimit :: [Result] -> Bool
noneReachedBackjumpLimit =
- not . any (\r -> resultPlan r == Left BackjumpLimitReached)
+ not . any (\r -> resultPlan r == Left BackjumpLimitReached)
showResults :: Result -> Result -> String
showResults r1 r2 = showResult 1 r1 ++ showResult 2 r2
showResult :: Int -> Result -> String
showResult n result =
- unlines $ ["", "Run " ++ show n ++ ":"]
- ++ resultLog result
- ++ ["result: " ++ show (resultPlan result)]
+ unlines $
+ ["", "Run " ++ show n ++ ":"]
+ ++ resultLog result
+ ++ ["result: " ++ show (resultPlan result)]
implies :: Bool -> Bool -> Bool
implies x y = not x || y
isRight :: Either a b -> Bool
isRight (Right _) = True
- isRight _ = False
-
-newtype VarOrdering = VarOrdering {
- unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering
- }
-
-solve :: EnableBackjumping
- -> FineGrainedConflicts
- -> ReorderGoals
- -> CountConflicts
- -> IndependentGoals
- -> PreferOldest
- -> Maybe VarOrdering
- -> SolverTest
- -> Result
+ isRight _ = False
+
+newtype VarOrdering = VarOrdering
+ { unVarOrdering :: Variable P.QPN -> Variable P.QPN -> Ordering
+ }
+
+solve
+ :: EnableBackjumping
+ -> FineGrainedConflicts
+ -> ReorderGoals
+ -> CountConflicts
+ -> IndependentGoals
+ -> PreferOldest
+ -> Maybe VarOrdering
+ -> SolverTest
+ -> Result
solve enableBj fineGrainedConflicts reorder countConflicts indep prefOldest goalOrder test =
let (lg, result) =
- runProgress $ exResolve (unTestDb (testDb test)) Nothing Nothing
- (pkgConfigDbFromList [])
- (map unPN (testTargets test))
- -- The backjump limit prevents individual tests from using
- -- too much time and memory.
- (Just defaultMaxBackjumps)
- countConflicts fineGrainedConflicts
- (MinimizeConflictSet False) indep prefOldest reorder
- (AllowBootLibInstalls False) OnlyConstrainedNone enableBj
- (SolveExecutables True) (unVarOrdering <$> goalOrder)
- (testConstraints test) (testPreferences test) normal
- (EnableAllTests False)
+ runProgress $
+ exResolve
+ (unTestDb (testDb test))
+ Nothing
+ Nothing
+ (pkgConfigDbFromList [])
+ (map unPN (testTargets test))
+ -- The backjump limit prevents individual tests from using
+ -- too much time and memory.
+ (Just defaultMaxBackjumps)
+ countConflicts
+ fineGrainedConflicts
+ (MinimizeConflictSet False)
+ indep
+ prefOldest
+ reorder
+ (AllowBootLibInstalls False)
+ OnlyConstrainedNone
+ enableBj
+ (SolveExecutables True)
+ (unVarOrdering <$> goalOrder)
+ (testConstraints test)
+ (testPreferences test)
+ normal
+ (EnableAllTests False)
failure :: String -> Failure
failure msg
| "Backjump limit reached" `isInfixOf` msg = BackjumpLimitReached
- | otherwise = OtherFailure
- in Result {
- resultLog = lg
- , resultPlan =
- -- Force the result so that we check for internal errors when we check
- -- for success or failure. See D.C.Dependency.validateSolverResult.
- force $ either (Left . failure) (Right . extractInstallPlan) result
- }
+ | otherwise = OtherFailure
+ in Result
+ { resultLog = lg
+ , resultPlan =
+ -- Force the result so that we check for internal errors when we check
+ -- for success or failure. See D.C.Dependency.validateSolverResult.
+ force $ either (Left . failure) (Right . extractInstallPlan) result
+ }
-- | How to modify the order of the input targets.
data TargetOrder = SameOrder | ReverseOrder
- deriving Show
+ deriving (Show)
instance Arbitrary TargetOrder where
arbitrary = elements [SameOrder, ReverseOrder]
@@ -215,8 +270,8 @@ instance Arbitrary TargetOrder where
shrink SameOrder = []
shrink ReverseOrder = [SameOrder]
-data Result = Result {
- resultLog :: [String]
+data Result = Result
+ { resultLog :: [String]
, resultPlan :: Either Failure [(ExamplePkgName, ExamplePkgVersion)]
}
@@ -226,18 +281,18 @@ data Failure = BackjumpLimitReached | OtherFailure
instance NFData Failure
-- | Package name.
-newtype PN = PN { unPN :: String }
+newtype PN = PN {unPN :: String}
deriving (Eq, Ord, Show)
instance Arbitrary PN where
- arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A'..'G']])
+ arbitrary = PN <$> elements ("base" : [[pn] | pn <- ['A' .. 'G']])
-- | Package version.
-newtype PV = PV { unPV :: Int }
+newtype PV = PV {unPV :: Int}
deriving (Eq, Ord, Show)
instance Arbitrary PV where
- arbitrary = PV <$> elements [1..10]
+ arbitrary = PV <$> elements [1 .. 10]
type TestPackage = Either ExampleInstalled ExampleAvailable
@@ -247,8 +302,8 @@ getName = PN . either exInstName exAvName
getVersion :: TestPackage -> PV
getVersion = PV . either exInstVersion exAvVersion
-data SolverTest = SolverTest {
- testDb :: TestDb
+data SolverTest = SolverTest
+ { testDb :: TestDb
, testTargets :: [PN]
, testConstraints :: [ExConstraint]
, testPreferences :: [ExPreference]
@@ -257,12 +312,17 @@ data SolverTest = SolverTest {
-- | Pretty-print the test when quickcheck calls 'show'.
instance Show SolverTest where
show test =
- let str = "SolverTest {testDb = " ++ show (testDb test)
- ++ ", testTargets = " ++ show (testTargets test)
- ++ ", testConstraints = " ++ show (testConstraints test)
- ++ ", testPreferences = " ++ show (testPreferences test)
- ++ "}"
- in maybe str valToStr $ parseValue str
+ let str =
+ "SolverTest {testDb = "
+ ++ show (testDb test)
+ ++ ", testTargets = "
+ ++ show (testTargets test)
+ ++ ", testConstraints = "
+ ++ show (testConstraints test)
+ ++ ", testPreferences = "
+ ++ show (testPreferences test)
+ ++ "}"
+ in maybe str valToStr $ parseValue str
instance Arbitrary SolverTest where
arbitrary = do
@@ -272,31 +332,32 @@ instance Arbitrary SolverTest where
Positive n <- arbitrary
targets <- randomSubset n pkgs
constraints <- case pkgVersions of
- [] -> return []
- _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions
+ [] -> return []
+ _ -> boundedListOf 1 $ arbitraryConstraint pkgVersions
prefs <- case pkgVersions of
- [] -> return []
- _ -> boundedListOf 3 $ arbitraryPreference pkgVersions
+ [] -> return []
+ _ -> boundedListOf 3 $ arbitraryPreference pkgVersions
return (SolverTest db targets constraints prefs)
shrink test =
- [test { testDb = db } | db <- shrink (testDb test)]
- ++ [test { testTargets = targets } | targets <- shrink (testTargets test)]
- ++ [test { testConstraints = cs } | cs <- shrink (testConstraints test)]
- ++ [test { testPreferences = prefs } | prefs <- shrink (testPreferences test)]
+ [test{testDb = db} | db <- shrink (testDb test)]
+ ++ [test{testTargets = targets} | targets <- shrink (testTargets test)]
+ ++ [test{testConstraints = cs} | cs <- shrink (testConstraints test)]
+ ++ [test{testPreferences = prefs} | prefs <- shrink (testPreferences test)]
-- | Collection of source and installed packages.
-newtype TestDb = TestDb { unTestDb :: ExampleDb }
- deriving Show
+newtype TestDb = TestDb {unTestDb :: ExampleDb}
+ deriving (Show)
instance Arbitrary TestDb where
arbitrary = do
- -- Avoid cyclic dependencies by grouping packages by name and only
- -- allowing each package to depend on packages in the groups before it.
- groupedPkgs <- shuffle . groupBy ((==) `on` fst) . nub . sort =<<
- boundedListOf 10 arbitrary
- db <- foldM nextPkgs (TestDb []) groupedPkgs
- TestDb <$> shuffle (unTestDb db)
+ -- Avoid cyclic dependencies by grouping packages by name and only
+ -- allowing each package to depend on packages in the groups before it.
+ groupedPkgs <-
+ shuffle . groupBy ((==) `on` fst) . nub . sort
+ =<< boundedListOf 10 arbitrary
+ db <- foldM nextPkgs (TestDb []) groupedPkgs
+ TestDb <$> shuffle (unTestDb db)
where
nextPkgs :: TestDb -> [(PN, PV)] -> Gen TestDb
nextPkgs db pkgs = TestDb . (++ unTestDb db) <$> traverse (nextPkg db) pkgs
@@ -305,140 +366,145 @@ instance Arbitrary TestDb where
nextPkg db (pn, v) = do
installed <- arbitrary
if installed
- then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)
- else Right <$> arbitraryExAv pn v db
+ then Left <$> arbitraryExInst pn v (lefts $ unTestDb db)
+ else Right <$> arbitraryExAv pn v db
shrink (TestDb pkgs) = map TestDb $ shrink pkgs
arbitraryExAv :: PN -> PV -> TestDb -> Gen ExampleAvailable
arbitraryExAv pn v db =
- (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db
+ (\cds -> ExAv (unPN pn) (unPV v) cds []) <$> arbitraryComponentDeps pn db
arbitraryExInst :: PN -> PV -> [ExampleInstalled] -> Gen ExampleInstalled
arbitraryExInst pn v pkgs = do
- pkgHash <- vectorOf 10 $ elements $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
+ pkgHash <- vectorOf 10 $ elements $ ['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9']
numDeps <- min 3 <$> arbitrary
deps <- randomSubset numDeps pkgs
return $ ExInst (unPN pn) (unPV v) pkgHash (map exInstHash deps)
arbitraryComponentDeps :: PN -> TestDb -> Gen (ComponentDeps Dependencies)
-arbitraryComponentDeps _ (TestDb []) = return $ CD.fromLibraryDeps (dependencies [])
-arbitraryComponentDeps pn db = do
+arbitraryComponentDeps _ (TestDb []) = return $ CD.fromLibraryDeps (dependencies [])
+arbitraryComponentDeps pn db = do
-- dedupComponentNames removes components with duplicate names, for example,
-- 'ComponentExe x' and 'ComponentTest x', and then CD.fromList combines
-- duplicate unnamed components.
- cds <- CD.fromList . dedupComponentNames . filter (isValid . fst)
- <$> boundedListOf 5 (arbitraryComponentDep db)
- return $ if isCompleteComponentDeps cds
- then cds
- else -- Add a library if the ComponentDeps isn't complete.
- CD.fromLibraryDeps (dependencies []) <> cds
+ cds <-
+ CD.fromList . dedupComponentNames . filter (isValid . fst)
+ <$> boundedListOf 5 (arbitraryComponentDep db)
+ return $
+ if isCompleteComponentDeps cds
+ then cds
+ else -- Add a library if the ComponentDeps isn't complete.
+ CD.fromLibraryDeps (dependencies []) <> cds
where
isValid :: Component -> Bool
isValid (ComponentSubLib name) = name /= mkUnqualComponentName (unPN pn)
- isValid _ = True
+ isValid _ = True
dedupComponentNames =
- nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)
+ nubBy ((\x y -> isJust x && isJust y && x == y) `on` componentName . fst)
componentName :: Component -> Maybe UnqualComponentName
- componentName ComponentLib = Nothing
- componentName ComponentSetup = Nothing
+ componentName ComponentLib = Nothing
+ componentName ComponentSetup = Nothing
componentName (ComponentSubLib n) = Just n
- componentName (ComponentFLib n) = Just n
- componentName (ComponentExe n) = Just n
- componentName (ComponentTest n) = Just n
- componentName (ComponentBench n) = Just n
+ componentName (ComponentFLib n) = Just n
+ componentName (ComponentExe n) = Just n
+ componentName (ComponentTest n) = Just n
+ componentName (ComponentBench n) = Just n
-- | Returns true if the ComponentDeps forms a complete package, i.e., it
-- contains a library, exe, test, or benchmark.
isCompleteComponentDeps :: ComponentDeps a -> Bool
isCompleteComponentDeps = any (completesPkg . fst) . CD.toList
where
- completesPkg ComponentLib = True
- completesPkg (ComponentExe _) = True
- completesPkg (ComponentTest _) = True
- completesPkg (ComponentBench _) = True
+ completesPkg ComponentLib = True
+ completesPkg (ComponentExe _) = True
+ completesPkg (ComponentTest _) = True
+ completesPkg (ComponentBench _) = True
completesPkg (ComponentSubLib _) = False
- completesPkg (ComponentFLib _) = False
- completesPkg ComponentSetup = False
+ completesPkg (ComponentFLib _) = False
+ completesPkg ComponentSetup = False
arbitraryComponentDep :: TestDb -> Gen (ComponentDep Dependencies)
arbitraryComponentDep db = do
comp <- arbitrary
deps <- case comp of
- ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)
- _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep)
- return ( comp
- , Dependencies {
- depsExampleDependencies = deps
-
- -- TODO: Test different values for visibility and buildability.
- , depsVisibility = LibraryVisibilityPublic
- , depsIsBuildable = True
- } )
+ ComponentSetup -> smallListOf (arbitraryExDep db SetupDep)
+ _ -> boundedListOf 5 (arbitraryExDep db NonSetupDep)
+ return
+ ( comp
+ , Dependencies
+ { depsExampleDependencies = deps
+ , -- TODO: Test different values for visibility and buildability.
+ depsVisibility = LibraryVisibilityPublic
+ , depsIsBuildable = True
+ }
+ )
-- | Location of an 'ExampleDependency'. It determines which values are valid.
data ExDepLocation = SetupDep | NonSetupDep
arbitraryExDep :: TestDb -> ExDepLocation -> Gen ExampleDependency
arbitraryExDep db@(TestDb pkgs) level =
- let flag = ExFlagged <$> arbitraryFlagName
- <*> arbitraryDeps db
- <*> arbitraryDeps db
+ let flag =
+ ExFlagged
+ <$> arbitraryFlagName
+ <*> arbitraryDeps db
+ <*> arbitraryDeps db
other =
- -- Package checks require dependencies on "base" to have bounds.
+ -- Package checks require dependencies on "base" to have bounds.
let notBase = filter ((/= PN "base") . getName) pkgs
- in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]
- ++ [
- -- existing version
- let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)
- in fixed <$> elements pkgs
-
- -- random version of an existing package
- , ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)
- ]
- in oneof $
- case level of
- NonSetupDep -> flag : other
- SetupDep -> other
+ in [ExAny . unPN <$> elements (map getName notBase) | not (null notBase)]
+ ++ [
+ -- existing version
+ let fixed pkg = ExFix (unPN $ getName pkg) (unPV $ getVersion pkg)
+ in fixed <$> elements pkgs
+ , -- random version of an existing package
+ ExFix . unPN . getName <$> elements pkgs <*> (unPV <$> arbitrary)
+ ]
+ in oneof $
+ case level of
+ NonSetupDep -> flag : other
+ SetupDep -> other
arbitraryDeps :: TestDb -> Gen Dependencies
-arbitraryDeps db = frequency
+arbitraryDeps db =
+ frequency
[ (1, return unbuildableDependencies)
, (20, dependencies <$> smallListOf (arbitraryExDep db NonSetupDep))
]
arbitraryFlagName :: Gen String
-arbitraryFlagName = (:[]) <$> elements ['A'..'E']
+arbitraryFlagName = (: []) <$> elements ['A' .. 'E']
arbitraryConstraint :: [(PN, PV)] -> Gen ExConstraint
arbitraryConstraint pkgs = do
(PN pn, v) <- elements pkgs
let anyQualifier = ScopeAnyQualifier (mkPackageName pn)
- oneof [
- ExVersionConstraint anyQualifier <$> arbitraryVersionRange v
+ oneof
+ [ ExVersionConstraint anyQualifier <$> arbitraryVersionRange v
, ExStanzaConstraint anyQualifier <$> sublistOf [TestStanzas, BenchStanzas]
]
arbitraryPreference :: [(PN, PV)] -> Gen ExPreference
arbitraryPreference pkgs = do
(PN pn, v) <- elements pkgs
- oneof [
- ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas]
+ oneof
+ [ ExStanzaPref pn <$> sublistOf [TestStanzas, BenchStanzas]
, ExPkgPref pn <$> arbitraryVersionRange v
]
arbitraryVersionRange :: PV -> Gen VersionRange
arbitraryVersionRange (PV v) =
let version = mkSimpleVersion v
- in elements [
- thisVersion version
- , notThisVersion version
- , earlierVersion version
- , orLaterVersion version
- , noVersion
- ]
+ in elements
+ [ thisVersion version
+ , notThisVersion version
+ , earlierVersion version
+ , orLaterVersion version
+ , noVersion
+ ]
instance Arbitrary ReorderGoals where
arbitrary = ReorderGoals <$> arbitrary
@@ -451,14 +517,16 @@ instance Arbitrary IndependentGoals where
shrink (IndependentGoals indep) = [IndependentGoals False | indep]
instance Arbitrary Component where
- arbitrary = oneof [ return ComponentLib
- , ComponentSubLib <$> arbitraryUQN
- , ComponentExe <$> arbitraryUQN
- , ComponentFLib <$> arbitraryUQN
- , ComponentTest <$> arbitraryUQN
- , ComponentBench <$> arbitraryUQN
- , return ComponentSetup
- ]
+ arbitrary =
+ oneof
+ [ return ComponentLib
+ , ComponentSubLib <$> arbitraryUQN
+ , ComponentExe <$> arbitraryUQN
+ , ComponentFLib <$> arbitraryUQN
+ , ComponentTest <$> arbitraryUQN
+ , ComponentBench <$> arbitraryUQN
+ , return ComponentSetup
+ ]
shrink ComponentLib = []
shrink _ = [ComponentLib]
@@ -469,18 +537,20 @@ instance Arbitrary Component where
-- internal libraries.
arbitraryUQN :: Gen UnqualComponentName
arbitraryUQN =
- mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"
+ mkUnqualComponentName <$> (\c -> "component-" ++ [c]) <$> elements "ABC"
instance Arbitrary ExampleInstalled where
arbitrary = error "arbitrary not implemented: ExampleInstalled"
- shrink ei = [ ei { exInstBuildAgainst = deps }
- | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)]
+ shrink ei =
+ [ ei{exInstBuildAgainst = deps}
+ | deps <- shrinkList shrinkNothing (exInstBuildAgainst ei)
+ ]
instance Arbitrary ExampleAvailable where
arbitrary = error "arbitrary not implemented: ExampleAvailable"
- shrink ea = [ea { exAvDeps = deps } | deps <- shrink (exAvDeps ea)]
+ shrink ea = [ea{exAvDeps = deps} | deps <- shrink (exAvDeps ea)]
instance (Arbitrary a, Monoid a) => Arbitrary (ComponentDeps a) where
arbitrary = error "arbitrary not implemented: ComponentDeps"
@@ -494,7 +564,8 @@ instance Arbitrary ExampleDependency where
shrink (ExFix "base" _) = [] -- preserve bounds on base
shrink (ExFix pn _) = [ExAny pn]
shrink (ExFlagged flag th el) =
- depsExampleDependencies th ++ depsExampleDependencies el
+ depsExampleDependencies th
+ ++ depsExampleDependencies el
++ [ExFlagged flag th' el | th' <- shrink th]
++ [ExFlagged flag th el' | el' <- shrink el]
shrink dep = error $ "Dependency not handled: " ++ show dep
@@ -503,38 +574,38 @@ instance Arbitrary Dependencies where
arbitrary = error "arbitrary not implemented: Dependencies"
shrink deps =
- [ deps { depsVisibility = v } | v <- shrink $ depsVisibility deps ]
- ++ [ deps { depsIsBuildable = b } | b <- shrink $ depsIsBuildable deps ]
- ++ [ deps { depsExampleDependencies = ds } | ds <- shrink $ depsExampleDependencies deps ]
+ [deps{depsVisibility = v} | v <- shrink $ depsVisibility deps]
+ ++ [deps{depsIsBuildable = b} | b <- shrink $ depsIsBuildable deps]
+ ++ [deps{depsExampleDependencies = ds} | ds <- shrink $ depsExampleDependencies deps]
instance Arbitrary ExConstraint where
arbitrary = error "arbitrary not implemented: ExConstraint"
shrink (ExStanzaConstraint scope stanzas) =
- [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas]
+ [ExStanzaConstraint scope stanzas' | stanzas' <- shrink stanzas]
shrink (ExVersionConstraint scope vr) =
- [ExVersionConstraint scope vr' | vr' <- shrink vr]
+ [ExVersionConstraint scope vr' | vr' <- shrink vr]
shrink _ = []
instance Arbitrary ExPreference where
arbitrary = error "arbitrary not implemented: ExPreference"
shrink (ExStanzaPref pn stanzas) =
- [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas]
+ [ExStanzaPref pn stanzas' | stanzas' <- shrink stanzas]
shrink (ExPkgPref pn vr) = [ExPkgPref pn vr' | vr' <- shrink vr]
instance Arbitrary OptionalStanza where
arbitrary = error "arbitrary not implemented: OptionalStanza"
shrink BenchStanzas = [TestStanzas]
- shrink TestStanzas = []
+ shrink TestStanzas = []
-- Randomly sorts solver variables using 'hash'.
-- TODO: Sorting goals with this function is very slow.
instance Arbitrary VarOrdering where
arbitrary = do
- f <- arbitrary :: Gen (Int -> Int)
- return $ VarOrdering (comparing (f . hash))
+ f <- arbitrary :: Gen (Int -> Int)
+ return $ VarOrdering (comparing (f . hash))
instance Hashable pn => Hashable (Variable pn)
instance Hashable a => Hashable (P.Qualified a)
@@ -561,5 +632,7 @@ boundedListOf n gen = take n <$> listOf gen
-- | Generates lists with average length less than 1.
smallListOf :: Gen a -> Gen [a]
smallListOf gen =
- frequency [ (fr, vectorOf n gen)
- | (fr, n) <- [(3, 0), (5, 1), (2, 2)]]
+ frequency
+ [ (fr, vectorOf n gen)
+ | (fr, n) <- [(3, 0), (5, 1), (2, 2)]
+ ]
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs
index facc64cedd3358275828054eae9d4493922d12fe..72283639cd9554df800fb9cbaedeec65cadd716f 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck/Utils.hs
@@ -1,5 +1,5 @@
-module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils (
- testPropertyWithSeed
+module UnitTests.Distribution.Solver.Modular.QuickCheck.Utils
+ ( testPropertyWithSeed
) where
import Data.Tagged (Tagged, retag)
@@ -9,7 +9,11 @@ import Test.Tasty (TestTree)
import Test.Tasty.Options (OptionDescription, lookupOption, setOption)
import Test.Tasty.Providers (IsTest (..), singleTest)
import Test.Tasty.QuickCheck
- ( QC (..), QuickCheckReplay (..), Testable, property )
+ ( QC (..)
+ , QuickCheckReplay (..)
+ , Testable
+ , property
+ )
import Distribution.Simple.Utils
import Distribution.Verbosity
@@ -27,7 +31,7 @@ instance IsTest QCWithSeed where
run options (QCWithSeed test) progress = do
replay <- case lookupOption options of
- QuickCheckReplay (Just override) -> return override
- QuickCheckReplay Nothing -> getStdRandom random
+ QuickCheckReplay (Just override) -> return override
+ QuickCheckReplay Nothing -> getStdRandom random
notice normal $ "Using --quickcheck-replay=" ++ show replay
run (setOption (QuickCheckReplay (Just replay)) options) test progress
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs
index d64802c183ab68856dc8435787b191814175472c..8b0744a4aabdac73a32de5e9e0bf7f5eabc4da24 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/RetryLog.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module UnitTests.Distribution.Solver.Modular.RetryLog (
- tests
+
+module UnitTests.Distribution.Solver.Modular.RetryLog
+ ( tests
) where
import Distribution.Solver.Modular.Message
@@ -11,53 +12,54 @@ import Distribution.Solver.Types.Progress
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase, (@?=))
import Test.Tasty.QuickCheck
- ( Arbitrary(..), Blind(..), listOf, oneof, testProperty, (===))
+ ( Arbitrary (..)
+ , Blind (..)
+ , listOf
+ , oneof
+ , testProperty
+ , (===)
+ )
type Log a = Progress a String String
tests :: [TestTree]
-tests = [
- testProperty "'toProgress . fromProgress' is identity" $ \p ->
- toProgress (fromProgress p) === (p :: Log Int)
-
+tests =
+ [ testProperty "'toProgress . fromProgress' is identity" $ \p ->
+ toProgress (fromProgress p) === (p :: Log Int)
, testProperty "'mapFailure f' is like 'foldProgress Step (Fail . f) Done'" $
- let mapFailureProgress f = foldProgress Step (Fail . f) Done
- in \(Blind f) p ->
- toProgress (mapFailure f (fromProgress p))
- === mapFailureProgress (f :: String -> Int) (p :: Log Int)
-
+ let mapFailureProgress f = foldProgress Step (Fail . f) Done
+ in \(Blind f) p ->
+ toProgress (mapFailure f (fromProgress p))
+ === mapFailureProgress (f :: String -> Int) (p :: Log Int)
, testProperty "'retry p f' is like 'foldProgress Step f Done p'" $
\p (Blind f) ->
toProgress (retry (fromProgress p) (fromProgress . f))
- === (foldProgress Step f Done (p :: Log Int) :: Log Int)
-
+ === (foldProgress Step f Done (p :: Log Int) :: Log Int)
, testProperty "failWith" $ \step failure ->
- toProgress (failWith step failure)
+ toProgress (failWith step failure)
=== (Step step (Fail failure) :: Log Int)
-
, testProperty "succeedWith" $ \step success ->
- toProgress (succeedWith step success)
+ toProgress (succeedWith step success)
=== (Step step (Done success) :: Log Int)
-
, testProperty "continueWith" $ \step p ->
- toProgress (continueWith step (fromProgress p))
+ toProgress (continueWith step (fromProgress p))
=== (Step step p :: Log Int)
-
, testCase "tryWith with failure" $
- let failure = Fail "Error"
- s = Step Success
- in toProgress (tryWith Success $ fromProgress (s (s failure)))
- @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)
-
+ let failure = Fail "Error"
+ s = Step Success
+ in toProgress (tryWith Success $ fromProgress (s (s failure)))
+ @?= (s (Step Enter (s (s (Step Leave failure)))) :: Log Message)
, testCase "tryWith with success" $
- let done = Done "Done"
- s = Step Success
- in toProgress (tryWith Success $ fromProgress (s (s done)))
- @?= (s (Step Enter (s (s done))) :: Log Message)
+ let done = Done "Done"
+ s = Step Success
+ in toProgress (tryWith Success $ fromProgress (s (s done)))
+ @?= (s (Step Enter (s (s done))) :: Log Message)
]
-instance (Arbitrary step, Arbitrary fail, Arbitrary done)
- => Arbitrary (Progress step fail done) where
+instance
+ (Arbitrary step, Arbitrary fail, Arbitrary done)
+ => Arbitrary (Progress step fail done)
+ where
arbitrary = do
steps <- listOf arbitrary
end <- oneof [Fail `fmap` arbitrary, Done `fmap` arbitrary]
@@ -65,8 +67,9 @@ instance (Arbitrary step, Arbitrary fail, Arbitrary done)
deriving instance (Eq step, Eq fail, Eq done) => Eq (Progress step fail done)
-deriving instance (Show step, Show fail, Show done)
- => Show (Progress step fail done)
+deriving instance
+ (Show step, Show fail, Show done)
+ => Show (Progress step fail done)
deriving instance Eq Message
deriving instance Show Message
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
index 1101e05aff94d8f4ea8c6970738366c218c9a6c5..dedb20bc70c92a2cdf926e377ac545972257a10a 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/Solver.hs
@@ -1,9 +1,10 @@
{-# LANGUAGE OverloadedStrings #-}
+
-- | This is a set of unit tests for the dependency solver,
-- which uses the solver DSL ("UnitTests.Distribution.Solver.Modular.DSL")
-- to more conveniently create package databases to run the solver tests on.
module UnitTests.Distribution.Solver.Modular.Solver (tests)
- where
+where
-- base
import Data.List (isInfixOf)
@@ -14,8 +15,11 @@ import qualified Distribution.Version as V
import Test.Tasty as TF
-- Cabal
-import Language.Haskell.Extension ( Extension(..)
- , KnownExtension(..), Language(..))
+import Language.Haskell.Extension
+ ( Extension (..)
+ , KnownExtension (..)
+ , Language (..)
+ )
-- cabal-install
import Distribution.Solver.Types.Flag
@@ -26,773 +30,901 @@ import UnitTests.Distribution.Solver.Modular.DSL
import UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
tests :: [TF.TestTree]
-tests = [
- testGroup "Simple dependencies" [
- runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess [])
- , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)])
- , runTest $ preferOldest
- $ mkTest db1 "installOldest" ["B"] (solverSuccess [("B", 1)])
- , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)])
- , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)])
- , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure
- , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)])
- , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)])
- , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)])
- , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
- , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)])
- , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)])
- , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure
- , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)])
- , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C"))
- , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B"))
- , runTest $ mkTest [] "unknown target" ["A"] (solverFailure (isInfixOf "unknown package: A"))
- ]
- , testGroup "Flagged dependencies" [
- runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)])
- , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure
- , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure
- , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])
- ]
- , testGroup "Lifting dependencies out of conditionals" [
- runTest $ commonDependencyLogMessage "common dependency log message"
- , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message"
- , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency"
- ]
- , testGroup "Manual flags" [
- runTest $ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $
- solverSuccess [("pkg", 1), ("true-dep", 1)]
-
- , let checkFullLog =
- any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)"
- in runTest $ setVerbose $
- constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $
- mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $
- -- TODO: We should check the summarized log instead of the full log
- -- for the manual flags error message, but it currently only
- -- appears in the full log.
- SolverResult checkFullLog (Left $ const True)
-
- , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False]
- in runTest $ constraints cs $
- mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $
- solverSuccess [("false-dep", 1), ("pkg", 1)]
- ]
- , testGroup "Qualified manual flag constraints" [
- let name = "Top-level flag constraint does not constrain setup dep's flag"
- cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
- in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $
- solverSuccess [ ("A", 1), ("B", 1), ("B", 2)
- , ("b-1-false-dep", 1), ("b-2-true-dep", 1) ]
-
- , let name = "Solver can toggle setup dep's flag to match top-level constraint"
- cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False
- , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion ]
- in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $
- solverSuccess [ ("A", 1), ("B", 1), ("B", 2)
- , ("b-1-false-dep", 1), ("b-2-false-dep", 1) ]
-
- , let name = "User can constrain flags separately with qualified constraints"
- cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
- , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]
- in runTest $ constraints cs $ mkTest dbSetupDepWithManualFlag name ["A"] $
- solverSuccess [ ("A", 1), ("B", 1), ("B", 2)
- , ("b-1-true-dep", 1), ("b-2-false-dep", 1) ]
-
- -- Regression test for #4299
- , let name = "Solver can link deps when only one has constrained manual flag"
- cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
- in runTest $ constraints cs $ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $
- solverSuccess [ ("A", 1), ("B", 1), ("b-1-false-dep", 1) ]
-
- , let name = "Solver cannot link deps that have conflicting manual flag constraints"
- cs = [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
- , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False ]
- failureReason = "(constraint from unknown source requires opposite flag selection)"
- checkFullLog lns =
- all (\msg -> any (msg `isInfixOf`) lns)
- [ "rejecting: B:-flag " ++ failureReason
- , "rejecting: A:setup.B:+flag " ++ failureReason ]
- in runTest $ constraints cs $ setVerbose $
- mkTest dbLinkedSetupDepWithManualFlag name ["A"] $
- SolverResult checkFullLog (Left $ const True)
- ]
- , testGroup "Stanzas" [
- runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)])
- , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure
- , runTest $ enableAllTests $ mkTest db5 "simpleTest3" ["E"] (solverSuccess [("A", 1), ("E", 1)])
- , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO
- , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)])
- , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure
- , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])
- , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
- , runTest $ testTestSuiteWithFlag "test suite with flag"
- ]
- , testGroup "Setup dependencies" [
- runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])
- , runTest $ mkTest db7 "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)])
- , runTest $ mkTest db7 "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)])
- , runTest $ mkTest db7 "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)])
- , runTest $ mkTest db7 "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)])
- , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
- , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B",2 ), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])
- , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)])
- , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])
- ]
- , testGroup "Base shim" [
- runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)])
- , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)])
- , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)])
- , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure
- , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)])
- ]
- , testGroup "Base and Nonupgradable" [
- runTest $ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $
- solverFailure (isInfixOf "only already installed instances can be used")
- , runTest $ allowBootLibInstalls $ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $
- solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]
- , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $
- solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-upgradeable package requires installed instance)")
- , runTest $ mkTest dbNonupgrade "Refuse to install newer ghci requested by another library" ["B"] $
- solverFailure (isInfixOf "rejecting: ghci-2.0.0 (constraint from non-upgradeable package requires installed instance)")
- , runTest $ mkTest dbNonupgrade "Refuse to install newer ghc-boot requested by another library" ["C"] $
- solverFailure (isInfixOf "rejecting: ghc-boot-2.0.0 (constraint from non-upgradeable package requires installed instance)")
- ]
- , testGroup "reject-unconstrained" [
- runTest $ onlyConstrained $ mkTest db12 "missing syb" ["E"] $
- solverFailure (isInfixOf "not a user-provided goal")
- , runTest $ onlyConstrained $ mkTest db12 "all goals" ["E", "syb"] $
- solverSuccess [("E", 1), ("syb", 2)]
- , runTest $ onlyConstrained $ mkTest db17 "backtracking" ["A", "B"] $
- solverSuccess [("A", 2), ("B", 1)]
- , runTest $ onlyConstrained $ mkTest db17 "failure message" ["A"] $
- solverFailure $ isInfixOf $
- "Could not resolve dependencies:\n"
- ++ "[__0] trying: A-3.0.0 (user goal)\n"
- ++ "[__1] next goal: C (dependency of A)\n"
- ++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, "
- ++ "but reject-unconstrained-dependencies was set)\n"
- ++ "[__1] fail (backjumping, conflict set: A, C)\n"
- ++ "After searching the rest of the dependency tree exhaustively, "
- ++ "these were the goals I've had most trouble fulfilling: A, C, B"
- ]
- , testGroup "Cycles" [
- runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure
- , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure
- , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (solverSuccess [("C", 1), ("E", 1)])
- , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure
- , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure
- , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)])
- , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)])
- , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)])
- , runTest $ issue4161 "detect cycle between package and its setup script"
- , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages"
- ]
- , testGroup "Extensions" [
- runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure
- , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure
- , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A",1)])
- , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A",1),("B",1), ("C",1)])
- , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure
- , runTest $ mkTestExts (map EnableExtension [CPP,RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure
- , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP,RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A",1),("B",1),("C",1),("E",1)])
- ]
- , testGroup "Languages" [
- runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure
- , runTest $ mkTestLangs [Haskell98,Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A",1)])
- , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure
- , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A",1),("B",1),("C",1)])
- ]
- , testGroup "Qualified Package Constraints" [
- runTest $ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $
- solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)]
-
- , let cs = [ ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4 ]
- in runTest $ constraints cs $
- mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $
- solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]
-
- , let cs = [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4
- , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7
- ]
- in runTest $ constraints cs $
- mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $
- solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)]
-
- , let cs = [ ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4 ]
- in runTest $ constraints cs $
- mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $
- solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)]
- ]
- , testGroup "Package Preferences" [
- runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])
- , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])
- , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 2
- , ExPkgPref "A" $ mkvrOrEarlier 1] $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])
- , runTest $ preferences [ ExPkgPref "A" $ mkvrOrEarlier 1
- , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])
- , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1
- , ExPkgPref "A" $ mkvrThis 2] $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])
- , runTest $ preferences [ ExPkgPref "A" $ mkvrThis 1
- , ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])
- ]
- , testGroup "Stanza Preferences" [
- runTest $
- mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $
- solverSuccess [("pkg", 1)]
-
- , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $
- mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $
- solverSuccess [("pkg", 1), ("test-dep", 1)]
-
- , runTest $ preferences [ExStanzaPref "pkg" [TestStanzas]] $
- mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $
- solverSuccess [("pkg", 1)]
-
- , testStanzaPreference "test stanza preference"
- ]
- , testGroup "Buildable Field" [
- testBuildable "avoid building component with unknown dependency" (ExAny "unknown")
- , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))
- , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))
- , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])
- , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])
- ]
- , testGroup "Pkg-config dependencies" [
- runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure
- , runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure
- , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])
- , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure
- , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D",1)])
- ]
- , testGroup "Independent goals" [
- runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])
- , runTest $ testIndepGoals2 "indepGoals2"
- , runTest $ testIndepGoals3 "indepGoals3"
- , runTest $ testIndepGoals4 "indepGoals4"
- , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder
- , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder
- , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder
- , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder
- ]
- -- Tests designed for the backjumping blog post
- , testGroup "Backjumping" [
- runTest $ mkTest dbBJ1a "bj1a" ["A"] (solverSuccess [("A", 1), ("B", 1)])
- , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)])
- , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)])
- , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)])
- , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)])
- , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)])
- , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
- ]
- , testGroup "main library dependencies" [
- let db = [Right $ exAvNoLibrary "A" 1 `withExe` exExe "exe" []]
- in runTest $ mkTest db "install build target without a library" ["A"] $
- solverSuccess [("A", 1)]
-
- , let db = [ Right $ exAv "A" 1 [ExAny "B"]
- , Right $ exAvNoLibrary "B" 1 `withExe` exExe "exe" [] ]
- in runTest $ mkTest db "reject build-depends dependency with no library" ["A"] $
- solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)")
-
- , let exe = exExe "exe" []
- db = [ Right $ exAv "A" 1 [ExAny "B"]
- , Right $ exAvNoLibrary "B" 2 `withExe` exe
- , Right $ exAv "B" 1 [] `withExe` exe ]
- in runTest $ mkTest db "choose version of build-depends dependency that has a library" ["A"] $
- solverSuccess [("A", 1), ("B", 1)]
- ]
- , testGroup "sub-library dependencies" [
- let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
- , Right $ exAv "B" 1 [] ]
- in runTest $
- mkTest db "reject package that is missing required sub-library" ["A"] $
- solverFailure $ isInfixOf $
- "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)"
-
- , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
- , Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" [] ]
- in runTest $
- mkTest db "reject package with private but required sub-library" ["A"] $
- solverFailure $ isInfixOf $
- "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"
-
- , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
- , Right $ exAvNoLibrary "B" 1
- `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ]
- in runTest $ constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $
- mkTest db "reject package with sub-library made private by flag constraint" ["A"] $
- solverFailure $ isInfixOf $
- "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"
-
- , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
- , Right $ exAvNoLibrary "B" 1
- `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies] ]
- in runTest $
- mkTest db "treat sub-library as visible even though flag choice could make it private" ["A"] $
- solverSuccess [("A", 1), ("B", 1)]
-
- , let db = [ Right $ exAv "A" 1 [ExAny "B"]
- , Right $ exAv "B" 1 [] `withSubLibrary` exSubLib "sub-lib" []
- , Right $ exAv "C" 1 [ExSubLibAny "B" "sub-lib"] ]
- goals :: [ExampleVar]
- goals = [
- P QualNone "A"
- , P QualNone "B"
- , P QualNone "C"
- ]
- in runTest $ goalOrder goals $
- mkTest db "reject package that requires a private sub-library" ["A", "C"] $
- solverFailure $ isInfixOf $
- "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)"
-
- , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"]
- , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies
- , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib-v1" publicDependencies ]
- in runTest $ mkTest db "choose version of package containing correct sub-library" ["A"] $
- solverSuccess [("A", 1), ("B", 1)]
-
- , let db = [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
- , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib" (dependencies [])
- , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib" publicDependencies ]
- in runTest $ mkTest db "choose version of package with public sub-library" ["A"] $
- solverSuccess [("A", 1), ("B", 1)]
- ]
- -- build-tool-depends dependencies
- , testGroup "build-tool-depends" [
- runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)])
-
- , runTest $ disableSolveExecutables $
- mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])
-
- , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)])
-
- , runTest $ enableAllTests $
- mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)])
-
- , runTest $ mkTest dbBuildTools "unknown exe" ["D"] $
- solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by D")
-
- , runTest $ disableSolveExecutables $
- mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $ solverSuccess [("D", 1)]
-
- , runTest $ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $
- solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)")
-
- , runTest $ mkTest dbBuildTools "unknown flagged exe" ["F"] $
- solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by F +flagF")
-
- , runTest $ enableAllTests $ mkTest dbBuildTools "unknown test suite exe" ["G"] $
- solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by G *test")
-
- , runTest $ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $
- solverFailure $ isInfixOf $
- -- The solver reports the version conflict when a version conflict
- -- and an executable conflict apply to the same package version.
- "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n"
- ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n"
- ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)"
-
- , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success"
-
- , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure"
-
- , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency"
-
- , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package"
- ]
- -- build-tools dependencies
- , testGroup "legacy build-tools" [
- runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])
-
- , runTest $ disableSolveExecutables $
- mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])
-
- , runTest $ mkTest dbLegacyBuildTools2 "bt2" ["A"] $
- solverFailure (isInfixOf "does not contain executable 'alex', which is required by A")
-
- , runTest $ disableSolveExecutables $
- mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)])
-
- , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)])
-
- , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])
-
- , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])
-
- , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])
- ]
- -- internal dependencies
- , testGroup "internal dependencies" [
- runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])
- ]
- -- tests for partial fix for issue #5325
- , testGroup "Components that are unbuildable in the current environment" $
- let flagConstraint = ExFlagConstraint . ScopeAnyQualifier
- in [
- let db = [ Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] ]
- in runTest $ constraints [flagConstraint "A" "build-lib" False] $
- mkTest db "install unbuildable library" ["A"] $
- solverSuccess [("A", 1)]
-
- , let db = [ Right $ exAvNoLibrary "A" 1
- `withExe` exExe "exe" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] ]
- in runTest $ constraints [flagConstraint "A" "build-exe" False] $
- mkTest db "install unbuildable exe" ["A"] $
- solverSuccess [("A", 1)]
-
- , let db = [ Right $ exAv "A" 1 [ExAny "B"]
- , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies] ]
- in runTest $ constraints [flagConstraint "B" "build-lib" False] $
- mkTest db "reject library dependency with unbuildable library" ["A"] $
- solverFailure $ isInfixOf $
- "rejecting: B-1.0.0 (library is not buildable in the "
- ++ "current environment, but it is required by A)"
-
- , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]
- , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]
- `withExe` exExe "bt" [] ]
- in runTest $ constraints [flagConstraint "B" "build-lib" False] $
- mkTest db "allow build-tool dependency with unbuildable library" ["A"] $
- solverSuccess [("A", 1), ("B", 1)]
-
- , let db = [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]
- , Right $ exAv "B" 1 []
- `withExe` exExe "bt" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies] ]
- in runTest $ constraints [flagConstraint "B" "build-exe" False] $
- mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $
- solverFailure $ isInfixOf $
- "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not "
- ++ "buildable in the current environment, but it is required by A)"
- , runTest $
- chooseUnbuildableExeAfterBuildToolsPackage
- "choose unbuildable exe after choosing its package"
- ]
-
- , testGroup "--fine-grained-conflicts" [
-
- -- Skipping a version because of a problematic dependency:
- --
- -- When the solver explores A-4, it finds that it cannot satisfy B's
- -- dependencies. This allows the solver to skip the subsequent
- -- versions of A that also depend on B.
- runTest $
- let db = [
- Right $ exAv "A" 4 [ExAny "B"]
- , Right $ exAv "A" 3 [ExAny "B"]
- , Right $ exAv "A" 2 [ExAny "B"]
- , Right $ exAv "A" 1 []
- , Right $ exAv "B" 2 [ExAny "unknown1"]
- , Right $ exAv "B" 1 [ExAny "unknown2"]
- ]
- msg = [
- "[__0] trying: A-4.0.0 (user goal)"
- , "[__1] trying: B-2.0.0 (dependency of A)"
- , "[__2] unknown package: unknown1 (dependency of B)"
- , "[__2] fail (backjumping, conflict set: B, unknown1)"
- , "[__1] trying: B-1.0.0"
- , "[__2] unknown package: unknown2 (dependency of B)"
- , "[__2] fail (backjumping, conflict set: B, unknown2)"
- , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)"
- , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "
- ++ "caused the previous version to fail: depends on 'B')"
- , "[__0] trying: A-1.0.0"
- , "[__1] done"
- ]
- in setVerbose $
- mkTest db "skip version due to problematic dependency" ["A"] $
- SolverResult (isInfixOf msg) $ Right [("A", 1)]
-
- , -- Skipping a version because of a restrictive constraint on a
- -- dependency:
- --
- -- The solver rejects A-4 because its constraint on B excludes B-1.
- -- Then the solver is able to skip A-3 and A-2 because they also
- -- exclude B-1, even though they don't have the exact same constraints
- -- on B.
- runTest $
- let db = [
- Right $ exAv "A" 4 [ExFix "B" 14]
- , Right $ exAv "A" 3 [ExFix "B" 13]
- , Right $ exAv "A" 2 [ExFix "B" 12]
- , Right $ exAv "A" 1 [ExFix "B" 11]
- , Right $ exAv "B" 11 []
- ]
- msg = [
- "[__0] trying: A-4.0.0 (user goal)"
- , "[__1] next goal: B (dependency of A)"
- , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)"
- , "[__1] fail (backjumping, conflict set: A, B)"
- , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "
- ++ "caused the previous version to fail: depends on 'B' but excludes "
- ++ "version 11.0.0)"
- , "[__0] trying: A-1.0.0"
- , "[__1] next goal: B (dependency of A)"
- , "[__1] trying: B-11.0.0"
- , "[__2] done"
- ]
- in setVerbose $
- mkTest db "skip version due to restrictive constraint on its dependency" ["A"] $
- SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 11)]
-
- , -- This test tests the case where the solver chooses a version for one
- -- package, B, before choosing a version for one of its reverse
- -- dependencies, C. While the solver is exploring the subtree rooted
- -- at B-3, it finds that C-2's dependency on B conflicts with B-3.
- -- Then the solver is able to skip C-1, because it also excludes B-3.
- --
- -- --fine-grained-conflicts could have a benefit in this case even
- -- though the solver would have found the conflict between B-3 and C-1
- -- immediately after trying C-1 anyway. It prevents C-1 from
- -- introducing any other conflicts which could increase the size of
- -- the conflict set.
- runTest $
- let db = [
- Right $ exAv "A" 1 [ExAny "B", ExAny "C"]
- , Right $ exAv "B" 3 []
- , Right $ exAv "B" 2 []
- , Right $ exAv "B" 1 []
- , Right $ exAv "C" 2 [ExFix "B" 2]
- , Right $ exAv "C" 1 [ExFix "B" 1]
- ]
- goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]
- expectedMsg = [
- "[__0] trying: A-1.0.0 (user goal)"
- , "[__1] trying: B-3.0.0 (dependency of A)"
- , "[__2] next goal: C (dependency of A)"
- , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)"
- , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the "
- ++ "previous version to fail: excludes 'B' version 3.0.0)"
- , "[__2] fail (backjumping, conflict set: A, B, C)"
- , "[__1] trying: B-2.0.0"
- , "[__2] next goal: C (dependency of A)"
- , "[__2] trying: C-2.0.0"
- , "[__3] done"
- ]
- in setVerbose $ goalOrder goals $
- mkTest db "skip version that excludes dependency that was already chosen" ["A"] $
- SolverResult (isInfixOf expectedMsg) $ Right [("A", 1), ("B", 2), ("C", 2)]
-
- , -- This test tests how the solver merges conflicts when it has
- -- multiple reasons to add a variable to the conflict set. In this
- -- case, package A conflicts with B and C. The solver should take the
- -- union of the conflicts and then only skip a version if it does not
- -- resolve any of the conflicts.
- --
- -- The solver rejects A-3 because it can't find consistent versions for
- -- its two dependencies, B and C. Then it skips A-2 because A-2 also
- -- depends on B and C. This test ensures that the solver considers
- -- A-1 even though A-1 only resolves one of the conflicts (A-1 removes
- -- the dependency on C).
- runTest $
- let db = [
- Right $ exAv "A" 3 [ExAny "B", ExAny "C"]
- , Right $ exAv "A" 2 [ExAny "B", ExAny "C"]
- , Right $ exAv "A" 1 [ExAny "B"]
- , Right $ exAv "B" 1 [ExFix "D" 1]
- , Right $ exAv "C" 1 [ExFix "D" 2]
- , Right $ exAv "D" 1 []
- , Right $ exAv "D" 2 []
- ]
- goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]
- msg = [
- "[__0] trying: A-3.0.0 (user goal)"
- , "[__1] trying: B-1.0.0 (dependency of A)"
- , "[__2] trying: C-1.0.0 (dependency of A)"
- , "[__3] next goal: D (dependency of B)"
- , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"
- , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)"
- , "[__3] fail (backjumping, conflict set: B, C, D)"
- , "[__2] fail (backjumping, conflict set: A, B, C, D)"
- , "[__1] fail (backjumping, conflict set: A, B, C, D)"
- , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the "
- ++ "previous version to fail: depends on 'B'; depends on 'C')"
- , "[__0] trying: A-1.0.0"
- , "[__1] trying: B-1.0.0 (dependency of A)"
- , "[__2] next goal: D (dependency of B)"
- , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"
- , "[__2] trying: D-1.0.0"
- , "[__3] done"
- ]
- in setVerbose $ goalOrder goals $
- mkTest db "only skip a version if it resolves none of the previous conflicts" ["A"] $
- SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1), ("D", 1)]
-
- , -- This test ensures that the solver log doesn't show all conflicts
- -- that the solver encountered in a subtree. The solver should only
- -- show the conflicts that are contained in the current conflict set.
- --
- -- The goal order forces the solver to try A-4, encounter a conflict
- -- with B-2, try B-1, and then try C. A-4 conflicts with the only
- -- version of C, so the solver backjumps with a conflict set of
- -- {A, C}. When the solver skips the next version of A, the log should
- -- mention the conflict with C but not B.
- runTest $
- let db = [
- Right $ exAv "A" 4 [ExFix "B" 1, ExFix "C" 1]
- , Right $ exAv "A" 3 [ExFix "B" 1, ExFix "C" 1]
- , Right $ exAv "A" 2 [ExFix "C" 1]
- , Right $ exAv "A" 1 [ExFix "C" 2]
- , Right $ exAv "B" 2 []
- , Right $ exAv "B" 1 []
- , Right $ exAv "C" 2 []
- ]
- goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]
- msg = [
- "[__0] trying: A-4.0.0 (user goal)"
- , "[__1] next goal: B (dependency of A)"
- , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"
- , "[__1] trying: B-1.0.0"
- , "[__2] next goal: C (dependency of A)"
- , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)"
- , "[__2] fail (backjumping, conflict set: A, C)"
- , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that caused the "
- ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)"
- , "[__0] trying: A-1.0.0"
- , "[__1] next goal: C (dependency of A)"
- , "[__1] trying: C-2.0.0"
- , "[__2] done"
- ]
- in setVerbose $ goalOrder goals $
- mkTest db "don't show conflicts that aren't part of the conflict set" ["A"] $
- SolverResult (isInfixOf msg) $ Right [("A", 1), ("C", 2)]
-
- , -- Tests that the conflict set is properly updated when a version is
- -- skipped due to being excluded by one of its reverse dependencies'
- -- constraints.
- runTest $
- let db = [
- Right $ exAv "A" 2 [ExFix "B" 3]
- , Right $ exAv "A" 1 [ExFix "B" 1]
- , Right $ exAv "B" 2 []
- , Right $ exAv "B" 1 []
- ]
- msg = [
- "[__0] trying: A-2.0.0 (user goal)"
- , "[__1] next goal: B (dependency of A)"
-
- -- During this step, the solver adds A and B to the
- -- conflict set, with the details of each package's
- -- conflict:
- --
- -- A: A's constraint rejected B-2.
- -- B: B was rejected by A's B==3 constraint
- , "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)"
-
- -- When the solver skips B-1, it cannot simply reuse the
- -- previous conflict set. It also needs to update A's
- -- entry to say that A also rejected B-1. Otherwise, the
- -- solver wouldn't know that A-1 could resolve one of
- -- the conflicts encountered while exploring A-2. The
- -- solver would skip A-1, even though it leads to the
- -- solution.
- , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "
- ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')"
-
- , "[__1] fail (backjumping, conflict set: A, B)"
- , "[__0] trying: A-1.0.0"
- , "[__1] next goal: B (dependency of A)"
- , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"
- , "[__1] trying: B-1.0.0"
- , "[__2] done"
+tests =
+ [ testGroup
+ "Simple dependencies"
+ [ runTest $ mkTest db1 "alreadyInstalled" ["A"] (solverSuccess [])
+ , runTest $ mkTest db1 "installLatest" ["B"] (solverSuccess [("B", 2)])
+ , runTest $
+ preferOldest $
+ mkTest db1 "installOldest" ["B"] (solverSuccess [("B", 1)])
+ , runTest $ mkTest db1 "simpleDep1" ["C"] (solverSuccess [("B", 1), ("C", 1)])
+ , runTest $ mkTest db1 "simpleDep2" ["D"] (solverSuccess [("B", 2), ("D", 1)])
+ , runTest $ mkTest db1 "failTwoVersions" ["C", "D"] anySolverFailure
+ , runTest $ indep $ mkTest db1 "indepTwoVersions" ["C", "D"] (solverSuccess [("B", 1), ("B", 2), ("C", 1), ("D", 1)])
+ , runTest $ indep $ mkTest db1 "aliasWhenPossible1" ["C", "E"] (solverSuccess [("B", 1), ("C", 1), ("E", 1)])
+ , runTest $ indep $ mkTest db1 "aliasWhenPossible2" ["D", "E"] (solverSuccess [("B", 2), ("D", 1), ("E", 1)])
+ , runTest $ indep $ mkTest db2 "aliasWhenPossible3" ["C", "D"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
+ , runTest $ mkTest db1 "buildDepAgainstOld" ["F"] (solverSuccess [("B", 1), ("E", 1), ("F", 1)])
+ , runTest $ mkTest db1 "buildDepAgainstNew" ["G"] (solverSuccess [("B", 2), ("E", 1), ("G", 1)])
+ , runTest $ indep $ mkTest db1 "multipleInstances" ["F", "G"] anySolverFailure
+ , runTest $ mkTest db21 "unknownPackage1" ["A"] (solverSuccess [("A", 1), ("B", 1)])
+ , runTest $ mkTest db22 "unknownPackage2" ["A"] (solverFailure (isInfixOf "unknown package: C"))
+ , runTest $ mkTest db23 "unknownPackage3" ["A"] (solverFailure (isInfixOf "unknown package: B"))
+ , runTest $ mkTest [] "unknown target" ["A"] (solverFailure (isInfixOf "unknown package: A"))
+ ]
+ , testGroup
+ "Flagged dependencies"
+ [ runTest $ mkTest db3 "forceFlagOn" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTest db3 "forceFlagOff" ["D"] (solverSuccess [("A", 2), ("B", 1), ("D", 1)])
+ , runTest $ indep $ mkTest db3 "linkFlags1" ["C", "D"] anySolverFailure
+ , runTest $ indep $ mkTest db4 "linkFlags2" ["C", "D"] anySolverFailure
+ , runTest $ indep $ mkTest db18 "linkFlags3" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("F", 1)])
+ ]
+ , testGroup
+ "Lifting dependencies out of conditionals"
+ [ runTest $ commonDependencyLogMessage "common dependency log message"
+ , runTest $ twoLevelDeepCommonDependencyLogMessage "two level deep common dependency log message"
+ , runTest $ testBackjumpingWithCommonDependency "backjumping with common dependency"
+ ]
+ , testGroup
+ "Manual flags"
+ [ runTest $
+ mkTest dbManualFlags "Use default value for manual flag" ["pkg"] $
+ solverSuccess [("pkg", 1), ("true-dep", 1)]
+ , let checkFullLog =
+ any $ isInfixOf "rejecting: pkg:-flag (manual flag can only be changed explicitly)"
+ in runTest $
+ setVerbose $
+ constraints [ExVersionConstraint (ScopeAnyQualifier "true-dep") V.noVersion] $
+ mkTest dbManualFlags "Don't toggle manual flag to avoid conflict" ["pkg"] $
+ -- TODO: We should check the summarized log instead of the full log
+ -- for the manual flags error message, but it currently only
+ -- appears in the full log.
+ SolverResult checkFullLog (Left $ const True)
+ , let cs = [ExFlagConstraint (ScopeAnyQualifier "pkg") "flag" False]
+ in runTest $
+ constraints cs $
+ mkTest dbManualFlags "Toggle manual flag with flag constraint" ["pkg"] $
+ solverSuccess [("false-dep", 1), ("pkg", 1)]
+ ]
+ , testGroup
+ "Qualified manual flag constraints"
+ [ let name = "Top-level flag constraint does not constrain setup dep's flag"
+ cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
+ in runTest $
+ constraints cs $
+ mkTest dbSetupDepWithManualFlag name ["A"] $
+ solverSuccess
+ [ ("A", 1)
+ , ("B", 1)
+ , ("B", 2)
+ , ("b-1-false-dep", 1)
+ , ("b-2-true-dep", 1)
]
- in setVerbose $
- mkTest db "update conflict set after skipping version - 1" ["A"] $
- SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)]
-
- , -- Tests that the conflict set is properly updated when a version is
- -- skipped due to excluding a version of one of its dependencies.
- -- This test is similar the previous one, with the goal order reversed.
- runTest $
- let db = [
- Right $ exAv "A" 2 []
- , Right $ exAv "A" 1 []
- , Right $ exAv "B" 2 [ExFix "A" 3]
- , Right $ exAv "B" 1 [ExFix "A" 1]
+ , let name = "Solver can toggle setup dep's flag to match top-level constraint"
+ cs =
+ [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False
+ , ExVersionConstraint (ScopeAnyQualifier "b-2-true-dep") V.noVersion
+ ]
+ in runTest $
+ constraints cs $
+ mkTest dbSetupDepWithManualFlag name ["A"] $
+ solverSuccess
+ [ ("A", 1)
+ , ("B", 1)
+ , ("B", 2)
+ , ("b-1-false-dep", 1)
+ , ("b-2-false-dep", 1)
]
- goals = [P QualNone pkg | pkg <- ["A", "B"]]
- msg = [
- "[__0] trying: A-2.0.0 (user goal)"
- , "[__1] next goal: B (user goal)"
- , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)"
- , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "
- ++ "the previous version to fail: excludes 'A' version 2.0.0)"
- , "[__1] fail (backjumping, conflict set: A, B)"
- , "[__0] trying: A-1.0.0"
- , "[__1] next goal: B (user goal)"
- , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)"
- , "[__1] trying: B-1.0.0"
- , "[__2] done"
+ , let name = "User can constrain flags separately with qualified constraints"
+ cs =
+ [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
+ , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False
+ ]
+ in runTest $
+ constraints cs $
+ mkTest dbSetupDepWithManualFlag name ["A"] $
+ solverSuccess
+ [ ("A", 1)
+ , ("B", 1)
+ , ("B", 2)
+ , ("b-1-true-dep", 1)
+ , ("b-2-false-dep", 1)
]
- in setVerbose $ goalOrder goals $
- mkTest db "update conflict set after skipping version - 2" ["A", "B"] $
- SolverResult (isInfixOf msg) $ Right [("A", 1), ("B", 1)]
- ]
- -- Tests for the contents of the solver's log
- , testGroup "Solver log" [
- -- See issue #3203. The solver should only choose a version for A once.
- runTest $
- let db = [Right $ exAv "A" 1 []]
-
- p :: [String] -> Bool
- p lg = elem "targets: A" lg
- && length (filter ("trying: A" `isInfixOf`) lg) == 1
- in setVerbose $ mkTest db "deduplicate targets" ["A", "A"] $
- SolverResult p $ Right [("A", 1)]
- , runTest $
- let db = [Right $ exAv "A" 1 [ExAny "B"]]
- msg = "After searching the rest of the dependency tree exhaustively, "
- ++ "these were the goals I've had most trouble fulfilling: A, B"
- in mkTest db "exhaustive search failure message" ["A"] $
- solverFailure (isInfixOf msg)
- , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $
- "Could not resolve dependencies:\n"
- ++ "[__0] trying: A-1.0.0 (user goal)\n"
- ++ "[__1] unknown package: F (dependency of A)\n"
- ++ "[__1] fail (backjumping, conflict set: A, F)\n"
- ++ "After searching the rest of the dependency tree exhaustively, "
- ++ "these were the goals I've had most trouble fulfilling: A, F"
- , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $
- "Could not resolve dependencies:\n"
- ++ "[__0] trying: A-1.0.0 (user goal)\n"
- ++ "[__1] trying: B-3.0.0 (dependency of A)\n"
- ++ "[__2] unknown package: C (dependency of B)\n"
- ++ "[__2] fail (backjumping, conflict set: B, C)\n"
- ++ "Backjump limit reached (currently 3, change with --max-backjumps "
- ++ "or try to run with --reorder-goals).\n"
- , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $
- "Backjump limit reached (currently 1, change with --max-backjumps "
- ++ "or try to run with --reorder-goals).\n"
- ++ "Failed to generate a summarized dependency solver log due to low backjump limit."
- , testMinimizeConflictSet
- "minimize conflict set with --minimize-conflict-set"
- , testNoMinimizeConflictSet
- "show original conflict set with --no-minimize-conflict-set"
- , runTest $
- let db = [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]
- , Left $ exInst "other-package" 2 "other-package-2.0.0" []]
- msg = "rejecting: other-package-2.0.0/installed-2.0.0"
- in mkTest db "show full installed package version (issue #5892)" ["my-package"] $
- solverFailure (isInfixOf msg)
- , runTest $
- let db = [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]
- , Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" [] ]
- msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789"
- in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $
- solverFailure (isInfixOf msg)
- ]
- ]
+ , -- Regression test for #4299
+ let name = "Solver can link deps when only one has constrained manual flag"
+ cs = [ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" False]
+ in runTest $
+ constraints cs $
+ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $
+ solverSuccess [("A", 1), ("B", 1), ("b-1-false-dep", 1)]
+ , let name = "Solver cannot link deps that have conflicting manual flag constraints"
+ cs =
+ [ ExFlagConstraint (ScopeQualified P.QualToplevel "B") "flag" True
+ , ExFlagConstraint (ScopeQualified (P.QualSetup "A") "B") "flag" False
+ ]
+ failureReason = "(constraint from unknown source requires opposite flag selection)"
+ checkFullLog lns =
+ all
+ (\msg -> any (msg `isInfixOf`) lns)
+ [ "rejecting: B:-flag " ++ failureReason
+ , "rejecting: A:setup.B:+flag " ++ failureReason
+ ]
+ in runTest $
+ constraints cs $
+ setVerbose $
+ mkTest dbLinkedSetupDepWithManualFlag name ["A"] $
+ SolverResult checkFullLog (Left $ const True)
+ ]
+ , testGroup
+ "Stanzas"
+ [ runTest $ enableAllTests $ mkTest db5 "simpleTest1" ["C"] (solverSuccess [("A", 2), ("C", 1)])
+ , runTest $ enableAllTests $ mkTest db5 "simpleTest2" ["D"] anySolverFailure
+ , runTest $ enableAllTests $ mkTest db5 "simpleTest3" ["E"] (solverSuccess [("A", 1), ("E", 1)])
+ , runTest $ enableAllTests $ mkTest db5 "simpleTest4" ["F"] anySolverFailure -- TODO
+ , runTest $ enableAllTests $ mkTest db5 "simpleTest5" ["G"] (solverSuccess [("A", 2), ("G", 1)])
+ , runTest $ enableAllTests $ mkTest db5 "simpleTest6" ["E", "G"] anySolverFailure
+ , runTest $ indep $ enableAllTests $ mkTest db5 "simpleTest7" ["E", "G"] (solverSuccess [("A", 1), ("A", 2), ("E", 1), ("G", 1)])
+ , runTest $ enableAllTests $ mkTest db6 "depsWithTests1" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ indep $ enableAllTests $ mkTest db6 "depsWithTests2" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)])
+ , runTest $ testTestSuiteWithFlag "test suite with flag"
+ ]
+ , testGroup
+ "Setup dependencies"
+ [ runTest $ mkTest db7 "setupDeps1" ["B"] (solverSuccess [("A", 2), ("B", 1)])
+ , runTest $ mkTest db7 "setupDeps2" ["C"] (solverSuccess [("A", 2), ("C", 1)])
+ , runTest $ mkTest db7 "setupDeps3" ["D"] (solverSuccess [("A", 1), ("D", 1)])
+ , runTest $ mkTest db7 "setupDeps4" ["E"] (solverSuccess [("A", 1), ("A", 2), ("E", 1)])
+ , runTest $ mkTest db7 "setupDeps5" ["F"] (solverSuccess [("A", 1), ("A", 2), ("F", 1)])
+ , runTest $ mkTest db8 "setupDeps6" ["C", "D"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1)])
+ , runTest $ mkTest db9 "setupDeps7" ["F", "G"] (solverSuccess [("A", 1), ("B", 1), ("B", 2), ("C", 1), ("D", 1), ("E", 1), ("E", 2), ("F", 1), ("G", 1)])
+ , runTest $ mkTest db10 "setupDeps8" ["C"] (solverSuccess [("C", 1)])
+ , runTest $ indep $ mkTest dbSetupDeps "setupDeps9" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2)])
+ ]
+ , testGroup
+ "Base shim"
+ [ runTest $ mkTest db11 "baseShim1" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTest db12 "baseShim2" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTest db12 "baseShim3" ["B"] (solverSuccess [("B", 1)])
+ , runTest $ mkTest db12 "baseShim4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTest db12 "baseShim5" ["D"] anySolverFailure
+ , runTest $ mkTest db12 "baseShim6" ["E"] (solverSuccess [("E", 1), ("syb", 2)])
+ ]
+ , testGroup
+ "Base and Nonupgradable"
+ [ runTest $
+ mkTest dbBase "Refuse to install base without --allow-boot-library-installs" ["base"] $
+ solverFailure (isInfixOf "only already installed instances can be used")
+ , runTest $
+ allowBootLibInstalls $
+ mkTest dbBase "Install base with --allow-boot-library-installs" ["base"] $
+ solverSuccess [("base", 1), ("ghc-prim", 1), ("integer-gmp", 1), ("integer-simple", 1)]
+ , runTest $
+ mkTest dbNonupgrade "Refuse to install newer ghc requested by another library" ["A"] $
+ solverFailure (isInfixOf "rejecting: ghc-2.0.0 (constraint from non-upgradeable package requires installed instance)")
+ , runTest $
+ mkTest dbNonupgrade "Refuse to install newer ghci requested by another library" ["B"] $
+ solverFailure (isInfixOf "rejecting: ghci-2.0.0 (constraint from non-upgradeable package requires installed instance)")
+ , runTest $
+ mkTest dbNonupgrade "Refuse to install newer ghc-boot requested by another library" ["C"] $
+ solverFailure (isInfixOf "rejecting: ghc-boot-2.0.0 (constraint from non-upgradeable package requires installed instance)")
+ ]
+ , testGroup
+ "reject-unconstrained"
+ [ runTest $
+ onlyConstrained $
+ mkTest db12 "missing syb" ["E"] $
+ solverFailure (isInfixOf "not a user-provided goal")
+ , runTest $
+ onlyConstrained $
+ mkTest db12 "all goals" ["E", "syb"] $
+ solverSuccess [("E", 1), ("syb", 2)]
+ , runTest $
+ onlyConstrained $
+ mkTest db17 "backtracking" ["A", "B"] $
+ solverSuccess [("A", 2), ("B", 1)]
+ , runTest $
+ onlyConstrained $
+ mkTest db17 "failure message" ["A"] $
+ solverFailure $
+ isInfixOf $
+ "Could not resolve dependencies:\n"
+ ++ "[__0] trying: A-3.0.0 (user goal)\n"
+ ++ "[__1] next goal: C (dependency of A)\n"
+ ++ "[__1] fail (not a user-provided goal nor mentioned as a constraint, "
+ ++ "but reject-unconstrained-dependencies was set)\n"
+ ++ "[__1] fail (backjumping, conflict set: A, C)\n"
+ ++ "After searching the rest of the dependency tree exhaustively, "
+ ++ "these were the goals I've had most trouble fulfilling: A, C, B"
+ ]
+ , testGroup
+ "Cycles"
+ [ runTest $ mkTest db14 "simpleCycle1" ["A"] anySolverFailure
+ , runTest $ mkTest db14 "simpleCycle2" ["A", "B"] anySolverFailure
+ , runTest $ mkTest db14 "cycleWithFlagChoice1" ["C"] (solverSuccess [("C", 1), ("E", 1)])
+ , runTest $ mkTest db15 "cycleThroughSetupDep1" ["A"] anySolverFailure
+ , runTest $ mkTest db15 "cycleThroughSetupDep2" ["B"] anySolverFailure
+ , runTest $ mkTest db15 "cycleThroughSetupDep3" ["C"] (solverSuccess [("C", 2), ("D", 1)])
+ , runTest $ mkTest db15 "cycleThroughSetupDep4" ["D"] (solverSuccess [("D", 1)])
+ , runTest $ mkTest db15 "cycleThroughSetupDep5" ["E"] (solverSuccess [("C", 2), ("D", 1), ("E", 1)])
+ , runTest $ issue4161 "detect cycle between package and its setup script"
+ , runTest $ testCyclicDependencyErrorMessages "cyclic dependency error messages"
+ ]
+ , testGroup
+ "Extensions"
+ [ runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupported" ["A"] anySolverFailure
+ , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "unsupportedIndirect" ["B"] anySolverFailure
+ , runTest $ mkTestExts [EnableExtension RankNTypes] dbExts1 "supported" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTestExts (map EnableExtension [CPP, RankNTypes]) dbExts1 "supportedIndirect" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTestExts [EnableExtension CPP] dbExts1 "disabledExtension" ["D"] anySolverFailure
+ , runTest $ mkTestExts (map EnableExtension [CPP, RankNTypes]) dbExts1 "disabledExtension" ["D"] anySolverFailure
+ , runTest $ mkTestExts (UnknownExtension "custom" : map EnableExtension [CPP, RankNTypes]) dbExts1 "supportedUnknown" ["E"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("E", 1)])
+ ]
+ , testGroup
+ "Languages"
+ [ runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupported" ["A"] anySolverFailure
+ , runTest $ mkTestLangs [Haskell98, Haskell2010] dbLangs1 "supported" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTestLangs [Haskell98] dbLangs1 "unsupportedIndirect" ["B"] anySolverFailure
+ , runTest $ mkTestLangs [Haskell98, Haskell2010, UnknownLanguage "Haskell3000"] dbLangs1 "supportedUnknown" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ ]
+ , testGroup
+ "Qualified Package Constraints"
+ [ runTest $
+ mkTest dbConstraints "install latest versions without constraints" ["A", "B", "C"] $
+ solverSuccess [("A", 7), ("B", 8), ("C", 9), ("D", 7), ("D", 8), ("D", 9)]
+ , let cs = [ExVersionConstraint (ScopeAnyQualifier "D") $ mkVersionRange 1 4]
+ in runTest $
+ constraints cs $
+ mkTest dbConstraints "force older versions with unqualified constraint" ["A", "B", "C"] $
+ solverSuccess [("A", 1), ("B", 2), ("C", 3), ("D", 1), ("D", 2), ("D", 3)]
+ , let cs =
+ [ ExVersionConstraint (ScopeQualified P.QualToplevel "D") $ mkVersionRange 1 4
+ , ExVersionConstraint (ScopeQualified (P.QualSetup "B") "D") $ mkVersionRange 4 7
+ ]
+ in runTest $
+ constraints cs $
+ mkTest dbConstraints "force multiple versions with qualified constraints" ["A", "B", "C"] $
+ solverSuccess [("A", 1), ("B", 5), ("C", 9), ("D", 1), ("D", 5), ("D", 9)]
+ , let cs = [ExVersionConstraint (ScopeAnySetupQualifier "D") $ mkVersionRange 1 4]
+ in runTest $
+ constraints cs $
+ mkTest dbConstraints "constrain package across setup scripts" ["A", "B", "C"] $
+ solverSuccess [("A", 7), ("B", 2), ("C", 3), ("D", 2), ("D", 3), ("D", 7)]
+ ]
+ , testGroup
+ "Package Preferences"
+ [ runTest $ preferences [ExPkgPref "A" $ mkvrThis 1] $ mkTest db13 "selectPreferredVersionSimple" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ preferences [ExPkgPref "A" $ mkvrOrEarlier 2] $ mkTest db13 "selectPreferredVersionSimple2" ["A"] (solverSuccess [("A", 2)])
+ , runTest
+ $ preferences
+ [ ExPkgPref "A" $ mkvrOrEarlier 2
+ , ExPkgPref "A" $ mkvrOrEarlier 1
+ ]
+ $ mkTest db13 "selectPreferredVersionMultiple" ["A"] (solverSuccess [("A", 1)])
+ , runTest
+ $ preferences
+ [ ExPkgPref "A" $ mkvrOrEarlier 1
+ , ExPkgPref "A" $ mkvrOrEarlier 2
+ ]
+ $ mkTest db13 "selectPreferredVersionMultiple2" ["A"] (solverSuccess [("A", 1)])
+ , runTest
+ $ preferences
+ [ ExPkgPref "A" $ mkvrThis 1
+ , ExPkgPref "A" $ mkvrThis 2
+ ]
+ $ mkTest db13 "selectPreferredVersionMultiple3" ["A"] (solverSuccess [("A", 2)])
+ , runTest
+ $ preferences
+ [ ExPkgPref "A" $ mkvrThis 1
+ , ExPkgPref "A" $ mkvrOrEarlier 2
+ ]
+ $ mkTest db13 "selectPreferredVersionMultiple4" ["A"] (solverSuccess [("A", 1)])
+ ]
+ , testGroup
+ "Stanza Preferences"
+ [ runTest $
+ mkTest dbStanzaPreferences1 "disable tests by default" ["pkg"] $
+ solverSuccess [("pkg", 1)]
+ , runTest $
+ preferences [ExStanzaPref "pkg" [TestStanzas]] $
+ mkTest dbStanzaPreferences1 "enable tests with testing preference" ["pkg"] $
+ solverSuccess [("pkg", 1), ("test-dep", 1)]
+ , runTest $
+ preferences [ExStanzaPref "pkg" [TestStanzas]] $
+ mkTest dbStanzaPreferences2 "disable testing when it's not possible" ["pkg"] $
+ solverSuccess [("pkg", 1)]
+ , testStanzaPreference "test stanza preference"
+ ]
+ , testGroup
+ "Buildable Field"
+ [ testBuildable "avoid building component with unknown dependency" (ExAny "unknown")
+ , testBuildable "avoid building component with unknown extension" (ExExt (UnknownExtension "unknown"))
+ , testBuildable "avoid building component with unknown language" (ExLang (UnknownLanguage "unknown"))
+ , runTest $ mkTest dbBuildable1 "choose flags that set buildable to false" ["pkg"] (solverSuccess [("flag1-false", 1), ("flag2-true", 1), ("pkg", 1)])
+ , runTest $ mkTest dbBuildable2 "choose version that sets buildable to false" ["A"] (solverSuccess [("A", 1), ("B", 2)])
+ ]
+ , testGroup
+ "Pkg-config dependencies"
+ [ runTest $ mkTestPCDepends (Just []) dbPC1 "noPkgs" ["A"] anySolverFailure
+ , runTest $ mkTestPCDepends (Just [("pkgA", "0")]) dbPC1 "tooOld" ["A"] anySolverFailure
+ , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "1.0.0")]) dbPC1 "pruneNotFound" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTestPCDepends (Just [("pkgA", "1.0.0"), ("pkgB", "2.0.0")]) dbPC1 "chooseNewest" ["C"] (solverSuccess [("A", 1), ("B", 2), ("C", 1)])
+ , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigFailure" ["A"] anySolverFailure
+ , runTest $ mkTestPCDepends Nothing dbPC1 "noPkgConfigSuccess" ["D"] (solverSuccess [("D", 1)])
+ ]
+ , testGroup
+ "Independent goals"
+ [ runTest $ indep $ mkTest db16 "indepGoals1" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("D", 2), ("E", 1)])
+ , runTest $ testIndepGoals2 "indepGoals2"
+ , runTest $ testIndepGoals3 "indepGoals3"
+ , runTest $ testIndepGoals4 "indepGoals4"
+ , runTest $ testIndepGoals5 "indepGoals5 - fixed goal order" FixedGoalOrder
+ , runTest $ testIndepGoals5 "indepGoals5 - default goal order" DefaultGoalOrder
+ , runTest $ testIndepGoals6 "indepGoals6 - fixed goal order" FixedGoalOrder
+ , runTest $ testIndepGoals6 "indepGoals6 - default goal order" DefaultGoalOrder
+ ]
+ , -- Tests designed for the backjumping blog post
+ testGroup
+ "Backjumping"
+ [ runTest $ mkTest dbBJ1a "bj1a" ["A"] (solverSuccess [("A", 1), ("B", 1)])
+ , runTest $ mkTest dbBJ1b "bj1b" ["A"] (solverSuccess [("A", 1), ("B", 1)])
+ , runTest $ mkTest dbBJ1c "bj1c" ["A"] (solverSuccess [("A", 1), ("B", 1)])
+ , runTest $ mkTest dbBJ2 "bj2" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTest dbBJ3 "bj3" ["A"] (solverSuccess [("A", 1), ("Ba", 1), ("C", 1)])
+ , runTest $ mkTest dbBJ4 "bj4" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ mkTest dbBJ5 "bj5" ["A"] (solverSuccess [("A", 1), ("B", 1), ("D", 1)])
+ , runTest $ mkTest dbBJ6 "bj6" ["A"] (solverSuccess [("A", 1), ("B", 1)])
+ , runTest $ mkTest dbBJ7 "bj7" ["A"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ , runTest $ indep $ mkTest dbBJ8 "bj8" ["A", "B"] (solverSuccess [("A", 1), ("B", 1), ("C", 1)])
+ ]
+ , testGroup
+ "main library dependencies"
+ [ let db = [Right $ exAvNoLibrary "A" 1 `withExe` exExe "exe" []]
+ in runTest $
+ mkTest db "install build target without a library" ["A"] $
+ solverSuccess [("A", 1)]
+ , let db =
+ [ Right $ exAv "A" 1 [ExAny "B"]
+ , Right $ exAvNoLibrary "B" 1 `withExe` exExe "exe" []
+ ]
+ in runTest $
+ mkTest db "reject build-depends dependency with no library" ["A"] $
+ solverFailure (isInfixOf "rejecting: B-1.0.0 (does not contain library, which is required by A)")
+ , let exe = exExe "exe" []
+ db =
+ [ Right $ exAv "A" 1 [ExAny "B"]
+ , Right $ exAvNoLibrary "B" 2 `withExe` exe
+ , Right $ exAv "B" 1 [] `withExe` exe
+ ]
+ in runTest $
+ mkTest db "choose version of build-depends dependency that has a library" ["A"] $
+ solverSuccess [("A", 1), ("B", 1)]
+ ]
+ , testGroup
+ "sub-library dependencies"
+ [ let db =
+ [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
+ , Right $ exAv "B" 1 []
+ ]
+ in runTest $
+ mkTest db "reject package that is missing required sub-library" ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: B-1.0.0 (does not contain library 'sub-lib', which is required by A)"
+ , let db =
+ [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
+ , Right $ exAvNoLibrary "B" 1 `withSubLibrary` exSubLib "sub-lib" []
+ ]
+ in runTest $
+ mkTest db "reject package with private but required sub-library" ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"
+ , let db =
+ [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
+ , Right $
+ exAvNoLibrary "B" 1
+ `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies]
+ ]
+ in runTest $
+ constraints [ExFlagConstraint (ScopeAnyQualifier "B") "make-lib-private" True] $
+ mkTest db "reject package with sub-library made private by flag constraint" ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: B-1.0.0 (library 'sub-lib' is private, but it is required by A)"
+ , let db =
+ [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
+ , Right $
+ exAvNoLibrary "B" 1
+ `withSubLibrary` exSubLib "sub-lib" [ExFlagged "make-lib-private" (dependencies []) publicDependencies]
+ ]
+ in runTest $
+ mkTest db "treat sub-library as visible even though flag choice could make it private" ["A"] $
+ solverSuccess [("A", 1), ("B", 1)]
+ , let db =
+ [ Right $ exAv "A" 1 [ExAny "B"]
+ , Right $ exAv "B" 1 [] `withSubLibrary` exSubLib "sub-lib" []
+ , Right $ exAv "C" 1 [ExSubLibAny "B" "sub-lib"]
+ ]
+ goals :: [ExampleVar]
+ goals =
+ [ P QualNone "A"
+ , P QualNone "B"
+ , P QualNone "C"
+ ]
+ in runTest $
+ goalOrder goals $
+ mkTest db "reject package that requires a private sub-library" ["A", "C"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: C-1.0.0 (requires library 'sub-lib' from B, but the component is private)"
+ , let db =
+ [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib-v1"]
+ , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib-v2" publicDependencies
+ , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib-v1" publicDependencies
+ ]
+ in runTest $
+ mkTest db "choose version of package containing correct sub-library" ["A"] $
+ solverSuccess [("A", 1), ("B", 1)]
+ , let db =
+ [ Right $ exAv "A" 1 [ExSubLibAny "B" "sub-lib"]
+ , Right $ exAv "B" 2 [] `withSubLibrary` ExSubLib "sub-lib" (dependencies [])
+ , Right $ exAv "B" 1 [] `withSubLibrary` ExSubLib "sub-lib" publicDependencies
+ ]
+ in runTest $
+ mkTest db "choose version of package with public sub-library" ["A"] $
+ solverSuccess [("A", 1), ("B", 1)]
+ ]
+ , -- build-tool-depends dependencies
+ testGroup
+ "build-tool-depends"
+ [ runTest $ mkTest dbBuildTools "simple exe dependency" ["A"] (solverSuccess [("A", 1), ("bt-pkg", 2)])
+ , runTest $
+ disableSolveExecutables $
+ mkTest dbBuildTools "don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTest dbBuildTools "flagged exe dependency" ["B"] (solverSuccess [("B", 1), ("bt-pkg", 2)])
+ , runTest $
+ enableAllTests $
+ mkTest dbBuildTools "test suite exe dependency" ["C"] (solverSuccess [("C", 1), ("bt-pkg", 2)])
+ , runTest $
+ mkTest dbBuildTools "unknown exe" ["D"] $
+ solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by D")
+ , runTest $
+ disableSolveExecutables $
+ mkTest dbBuildTools "don't check for build tool executables in legacy mode" ["D"] $
+ solverSuccess [("D", 1)]
+ , runTest $
+ mkTest dbBuildTools "unknown build tools package error mentions package, not exe" ["E"] $
+ solverFailure (isInfixOf "unknown package: E:unknown-pkg:exe.unknown-pkg (dependency of E)")
+ , runTest $
+ mkTest dbBuildTools "unknown flagged exe" ["F"] $
+ solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by F +flagF")
+ , runTest $
+ enableAllTests $
+ mkTest dbBuildTools "unknown test suite exe" ["G"] $
+ solverFailure (isInfixOf "does not contain executable 'unknown-exe', which is required by G *test")
+ , runTest $
+ mkTest dbBuildTools "wrong exe for build tool package version" ["H"] $
+ solverFailure $
+ isInfixOf $
+ -- The solver reports the version conflict when a version conflict
+ -- and an executable conflict apply to the same package version.
+ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-4.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)\n"
+ ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-3.0.0 (does not contain executable 'exe1', which is required by H)\n"
+ ++ "[__1] rejecting: H:bt-pkg:exe.bt-pkg-2.0.0 (conflict: H => H:bt-pkg:exe.bt-pkg (exe exe1)==3.0.0)"
+ , runTest $ chooseExeAfterBuildToolsPackage True "choose exe after choosing its package - success"
+ , runTest $ chooseExeAfterBuildToolsPackage False "choose exe after choosing its package - failure"
+ , runTest $ rejectInstalledBuildToolPackage "reject installed package for build-tool dependency"
+ , runTest $ requireConsistentBuildToolVersions "build tool versions must be consistent within one package"
+ ]
+ , -- build-tools dependencies
+ testGroup
+ "legacy build-tools"
+ [ runTest $ mkTest dbLegacyBuildTools1 "bt1" ["A"] (solverSuccess [("A", 1), ("alex", 1)])
+ , runTest $
+ disableSolveExecutables $
+ mkTest dbLegacyBuildTools1 "bt1 - don't install build tool packages in legacy mode" ["A"] (solverSuccess [("A", 1)])
+ , runTest $
+ mkTest dbLegacyBuildTools2 "bt2" ["A"] $
+ solverFailure (isInfixOf "does not contain executable 'alex', which is required by A")
+ , runTest $
+ disableSolveExecutables $
+ mkTest dbLegacyBuildTools2 "bt2 - don't check for build tool executables in legacy mode" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTest dbLegacyBuildTools3 "bt3" ["A"] (solverSuccess [("A", 1)])
+ , runTest $ mkTest dbLegacyBuildTools4 "bt4" ["C"] (solverSuccess [("A", 1), ("B", 1), ("C", 1), ("alex", 1), ("alex", 2)])
+ , runTest $ mkTest dbLegacyBuildTools5 "bt5" ["B"] (solverSuccess [("A", 1), ("A", 2), ("B", 1), ("alex", 1)])
+ , runTest $ mkTest dbLegacyBuildTools6 "bt6" ["A"] (solverSuccess [("A", 1), ("alex", 1), ("happy", 1)])
+ ]
+ , -- internal dependencies
+ testGroup
+ "internal dependencies"
+ [ runTest $ mkTest dbIssue3775 "issue #3775" ["B"] (solverSuccess [("A", 2), ("B", 2), ("warp", 1)])
+ ]
+ , -- tests for partial fix for issue #5325
+ testGroup "Components that are unbuildable in the current environment" $
+ let flagConstraint = ExFlagConstraint . ScopeAnyQualifier
+ in [ let db = [Right $ exAv "A" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]]
+ in runTest $
+ constraints [flagConstraint "A" "build-lib" False] $
+ mkTest db "install unbuildable library" ["A"] $
+ solverSuccess [("A", 1)]
+ , let db =
+ [ Right $
+ exAvNoLibrary "A" 1
+ `withExe` exExe "exe" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies]
+ ]
+ in runTest $
+ constraints [flagConstraint "A" "build-exe" False] $
+ mkTest db "install unbuildable exe" ["A"] $
+ solverSuccess [("A", 1)]
+ , let db =
+ [ Right $ exAv "A" 1 [ExAny "B"]
+ , Right $ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]
+ ]
+ in runTest $
+ constraints [flagConstraint "B" "build-lib" False] $
+ mkTest db "reject library dependency with unbuildable library" ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: B-1.0.0 (library is not buildable in the "
+ ++ "current environment, but it is required by A)"
+ , let db =
+ [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]
+ , Right $
+ exAv "B" 1 [ExFlagged "build-lib" (dependencies []) unbuildableDependencies]
+ `withExe` exExe "bt" []
+ ]
+ in runTest $
+ constraints [flagConstraint "B" "build-lib" False] $
+ mkTest db "allow build-tool dependency with unbuildable library" ["A"] $
+ solverSuccess [("A", 1), ("B", 1)]
+ , let db =
+ [ Right $ exAv "A" 1 [ExBuildToolAny "B" "bt"]
+ , Right $
+ exAv "B" 1 []
+ `withExe` exExe "bt" [ExFlagged "build-exe" (dependencies []) unbuildableDependencies]
+ ]
+ in runTest $
+ constraints [flagConstraint "B" "build-exe" False] $
+ mkTest db "reject build-tool dependency with unbuildable exe" ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: A:B:exe.B-1.0.0 (executable 'bt' is not "
+ ++ "buildable in the current environment, but it is required by A)"
+ , runTest $
+ chooseUnbuildableExeAfterBuildToolsPackage
+ "choose unbuildable exe after choosing its package"
+ ]
+ , testGroup
+ "--fine-grained-conflicts"
+ [ -- Skipping a version because of a problematic dependency:
+ --
+ -- When the solver explores A-4, it finds that it cannot satisfy B's
+ -- dependencies. This allows the solver to skip the subsequent
+ -- versions of A that also depend on B.
+ runTest $
+ let db =
+ [ Right $ exAv "A" 4 [ExAny "B"]
+ , Right $ exAv "A" 3 [ExAny "B"]
+ , Right $ exAv "A" 2 [ExAny "B"]
+ , Right $ exAv "A" 1 []
+ , Right $ exAv "B" 2 [ExAny "unknown1"]
+ , Right $ exAv "B" 1 [ExAny "unknown2"]
+ ]
+ msg =
+ [ "[__0] trying: A-4.0.0 (user goal)"
+ , "[__1] trying: B-2.0.0 (dependency of A)"
+ , "[__2] unknown package: unknown1 (dependency of B)"
+ , "[__2] fail (backjumping, conflict set: B, unknown1)"
+ , "[__1] trying: B-1.0.0"
+ , "[__2] unknown package: unknown2 (dependency of B)"
+ , "[__2] fail (backjumping, conflict set: B, unknown2)"
+ , "[__1] fail (backjumping, conflict set: A, B, unknown1, unknown2)"
+ , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "
+ ++ "caused the previous version to fail: depends on 'B')"
+ , "[__0] trying: A-1.0.0"
+ , "[__1] done"
+ ]
+ in setVerbose $
+ mkTest db "skip version due to problematic dependency" ["A"] $
+ SolverResult (isInfixOf msg) $
+ Right [("A", 1)]
+ , -- Skipping a version because of a restrictive constraint on a
+ -- dependency:
+ --
+ -- The solver rejects A-4 because its constraint on B excludes B-1.
+ -- Then the solver is able to skip A-3 and A-2 because they also
+ -- exclude B-1, even though they don't have the exact same constraints
+ -- on B.
+ runTest $
+ let db =
+ [ Right $ exAv "A" 4 [ExFix "B" 14]
+ , Right $ exAv "A" 3 [ExFix "B" 13]
+ , Right $ exAv "A" 2 [ExFix "B" 12]
+ , Right $ exAv "A" 1 [ExFix "B" 11]
+ , Right $ exAv "B" 11 []
+ ]
+ msg =
+ [ "[__0] trying: A-4.0.0 (user goal)"
+ , "[__1] next goal: B (dependency of A)"
+ , "[__1] rejecting: B-11.0.0 (conflict: A => B==14.0.0)"
+ , "[__1] fail (backjumping, conflict set: A, B)"
+ , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that "
+ ++ "caused the previous version to fail: depends on 'B' but excludes "
+ ++ "version 11.0.0)"
+ , "[__0] trying: A-1.0.0"
+ , "[__1] next goal: B (dependency of A)"
+ , "[__1] trying: B-11.0.0"
+ , "[__2] done"
+ ]
+ in setVerbose $
+ mkTest db "skip version due to restrictive constraint on its dependency" ["A"] $
+ SolverResult (isInfixOf msg) $
+ Right [("A", 1), ("B", 11)]
+ , -- This test tests the case where the solver chooses a version for one
+ -- package, B, before choosing a version for one of its reverse
+ -- dependencies, C. While the solver is exploring the subtree rooted
+ -- at B-3, it finds that C-2's dependency on B conflicts with B-3.
+ -- Then the solver is able to skip C-1, because it also excludes B-3.
+ --
+ -- --fine-grained-conflicts could have a benefit in this case even
+ -- though the solver would have found the conflict between B-3 and C-1
+ -- immediately after trying C-1 anyway. It prevents C-1 from
+ -- introducing any other conflicts which could increase the size of
+ -- the conflict set.
+ runTest $
+ let db =
+ [ Right $ exAv "A" 1 [ExAny "B", ExAny "C"]
+ , Right $ exAv "B" 3 []
+ , Right $ exAv "B" 2 []
+ , Right $ exAv "B" 1 []
+ , Right $ exAv "C" 2 [ExFix "B" 2]
+ , Right $ exAv "C" 1 [ExFix "B" 1]
+ ]
+ goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]
+ expectedMsg =
+ [ "[__0] trying: A-1.0.0 (user goal)"
+ , "[__1] trying: B-3.0.0 (dependency of A)"
+ , "[__2] next goal: C (dependency of A)"
+ , "[__2] rejecting: C-2.0.0 (conflict: B==3.0.0, C => B==2.0.0)"
+ , "[__2] skipping: C-1.0.0 (has the same characteristics that caused the "
+ ++ "previous version to fail: excludes 'B' version 3.0.0)"
+ , "[__2] fail (backjumping, conflict set: A, B, C)"
+ , "[__1] trying: B-2.0.0"
+ , "[__2] next goal: C (dependency of A)"
+ , "[__2] trying: C-2.0.0"
+ , "[__3] done"
+ ]
+ in setVerbose $
+ goalOrder goals $
+ mkTest db "skip version that excludes dependency that was already chosen" ["A"] $
+ SolverResult (isInfixOf expectedMsg) $
+ Right [("A", 1), ("B", 2), ("C", 2)]
+ , -- This test tests how the solver merges conflicts when it has
+ -- multiple reasons to add a variable to the conflict set. In this
+ -- case, package A conflicts with B and C. The solver should take the
+ -- union of the conflicts and then only skip a version if it does not
+ -- resolve any of the conflicts.
+ --
+ -- The solver rejects A-3 because it can't find consistent versions for
+ -- its two dependencies, B and C. Then it skips A-2 because A-2 also
+ -- depends on B and C. This test ensures that the solver considers
+ -- A-1 even though A-1 only resolves one of the conflicts (A-1 removes
+ -- the dependency on C).
+ runTest $
+ let db =
+ [ Right $ exAv "A" 3 [ExAny "B", ExAny "C"]
+ , Right $ exAv "A" 2 [ExAny "B", ExAny "C"]
+ , Right $ exAv "A" 1 [ExAny "B"]
+ , Right $ exAv "B" 1 [ExFix "D" 1]
+ , Right $ exAv "C" 1 [ExFix "D" 2]
+ , Right $ exAv "D" 1 []
+ , Right $ exAv "D" 2 []
+ ]
+ goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]
+ msg =
+ [ "[__0] trying: A-3.0.0 (user goal)"
+ , "[__1] trying: B-1.0.0 (dependency of A)"
+ , "[__2] trying: C-1.0.0 (dependency of A)"
+ , "[__3] next goal: D (dependency of B)"
+ , "[__3] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"
+ , "[__3] rejecting: D-1.0.0 (conflict: C => D==2.0.0)"
+ , "[__3] fail (backjumping, conflict set: B, C, D)"
+ , "[__2] fail (backjumping, conflict set: A, B, C, D)"
+ , "[__1] fail (backjumping, conflict set: A, B, C, D)"
+ , "[__0] skipping: A-2.0.0 (has the same characteristics that caused the "
+ ++ "previous version to fail: depends on 'B'; depends on 'C')"
+ , "[__0] trying: A-1.0.0"
+ , "[__1] trying: B-1.0.0 (dependency of A)"
+ , "[__2] next goal: D (dependency of B)"
+ , "[__2] rejecting: D-2.0.0 (conflict: B => D==1.0.0)"
+ , "[__2] trying: D-1.0.0"
+ , "[__3] done"
+ ]
+ in setVerbose $
+ goalOrder goals $
+ mkTest db "only skip a version if it resolves none of the previous conflicts" ["A"] $
+ SolverResult (isInfixOf msg) $
+ Right [("A", 1), ("B", 1), ("D", 1)]
+ , -- This test ensures that the solver log doesn't show all conflicts
+ -- that the solver encountered in a subtree. The solver should only
+ -- show the conflicts that are contained in the current conflict set.
+ --
+ -- The goal order forces the solver to try A-4, encounter a conflict
+ -- with B-2, try B-1, and then try C. A-4 conflicts with the only
+ -- version of C, so the solver backjumps with a conflict set of
+ -- {A, C}. When the solver skips the next version of A, the log should
+ -- mention the conflict with C but not B.
+ runTest $
+ let db =
+ [ Right $ exAv "A" 4 [ExFix "B" 1, ExFix "C" 1]
+ , Right $ exAv "A" 3 [ExFix "B" 1, ExFix "C" 1]
+ , Right $ exAv "A" 2 [ExFix "C" 1]
+ , Right $ exAv "A" 1 [ExFix "C" 2]
+ , Right $ exAv "B" 2 []
+ , Right $ exAv "B" 1 []
+ , Right $ exAv "C" 2 []
+ ]
+ goals = [P QualNone pkg | pkg <- ["A", "B", "C"]]
+ msg =
+ [ "[__0] trying: A-4.0.0 (user goal)"
+ , "[__1] next goal: B (dependency of A)"
+ , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"
+ , "[__1] trying: B-1.0.0"
+ , "[__2] next goal: C (dependency of A)"
+ , "[__2] rejecting: C-2.0.0 (conflict: A => C==1.0.0)"
+ , "[__2] fail (backjumping, conflict set: A, C)"
+ , "[__0] skipping: A-3.0.0, A-2.0.0 (has the same characteristics that caused the "
+ ++ "previous version to fail: depends on 'C' but excludes version 2.0.0)"
+ , "[__0] trying: A-1.0.0"
+ , "[__1] next goal: C (dependency of A)"
+ , "[__1] trying: C-2.0.0"
+ , "[__2] done"
+ ]
+ in setVerbose $
+ goalOrder goals $
+ mkTest db "don't show conflicts that aren't part of the conflict set" ["A"] $
+ SolverResult (isInfixOf msg) $
+ Right [("A", 1), ("C", 2)]
+ , -- Tests that the conflict set is properly updated when a version is
+ -- skipped due to being excluded by one of its reverse dependencies'
+ -- constraints.
+ runTest $
+ let db =
+ [ Right $ exAv "A" 2 [ExFix "B" 3]
+ , Right $ exAv "A" 1 [ExFix "B" 1]
+ , Right $ exAv "B" 2 []
+ , Right $ exAv "B" 1 []
+ ]
+ msg =
+ [ "[__0] trying: A-2.0.0 (user goal)"
+ , "[__1] next goal: B (dependency of A)"
+ , -- During this step, the solver adds A and B to the
+ -- conflict set, with the details of each package's
+ -- conflict:
+ --
+ -- A: A's constraint rejected B-2.
+ -- B: B was rejected by A's B==3 constraint
+ "[__1] rejecting: B-2.0.0 (conflict: A => B==3.0.0)"
+ , -- When the solver skips B-1, it cannot simply reuse the
+ -- previous conflict set. It also needs to update A's
+ -- entry to say that A also rejected B-1. Otherwise, the
+ -- solver wouldn't know that A-1 could resolve one of
+ -- the conflicts encountered while exploring A-2. The
+ -- solver would skip A-1, even though it leads to the
+ -- solution.
+ "[__1] skipping: B-1.0.0 (has the same characteristics that caused "
+ ++ "the previous version to fail: excluded by constraint '==3.0.0' from 'A')"
+ , "[__1] fail (backjumping, conflict set: A, B)"
+ , "[__0] trying: A-1.0.0"
+ , "[__1] next goal: B (dependency of A)"
+ , "[__1] rejecting: B-2.0.0 (conflict: A => B==1.0.0)"
+ , "[__1] trying: B-1.0.0"
+ , "[__2] done"
+ ]
+ in setVerbose $
+ mkTest db "update conflict set after skipping version - 1" ["A"] $
+ SolverResult (isInfixOf msg) $
+ Right [("A", 1), ("B", 1)]
+ , -- Tests that the conflict set is properly updated when a version is
+ -- skipped due to excluding a version of one of its dependencies.
+ -- This test is similar the previous one, with the goal order reversed.
+ runTest $
+ let db =
+ [ Right $ exAv "A" 2 []
+ , Right $ exAv "A" 1 []
+ , Right $ exAv "B" 2 [ExFix "A" 3]
+ , Right $ exAv "B" 1 [ExFix "A" 1]
+ ]
+ goals = [P QualNone pkg | pkg <- ["A", "B"]]
+ msg =
+ [ "[__0] trying: A-2.0.0 (user goal)"
+ , "[__1] next goal: B (user goal)"
+ , "[__1] rejecting: B-2.0.0 (conflict: A==2.0.0, B => A==3.0.0)"
+ , "[__1] skipping: B-1.0.0 (has the same characteristics that caused "
+ ++ "the previous version to fail: excludes 'A' version 2.0.0)"
+ , "[__1] fail (backjumping, conflict set: A, B)"
+ , "[__0] trying: A-1.0.0"
+ , "[__1] next goal: B (user goal)"
+ , "[__1] rejecting: B-2.0.0 (conflict: A==1.0.0, B => A==3.0.0)"
+ , "[__1] trying: B-1.0.0"
+ , "[__2] done"
+ ]
+ in setVerbose $
+ goalOrder goals $
+ mkTest db "update conflict set after skipping version - 2" ["A", "B"] $
+ SolverResult (isInfixOf msg) $
+ Right [("A", 1), ("B", 1)]
+ ]
+ , -- Tests for the contents of the solver's log
+ testGroup
+ "Solver log"
+ [ -- See issue #3203. The solver should only choose a version for A once.
+ runTest $
+ let db = [Right $ exAv "A" 1 []]
+
+ p :: [String] -> Bool
+ p lg =
+ elem "targets: A" lg
+ && length (filter ("trying: A" `isInfixOf`) lg) == 1
+ in setVerbose $
+ mkTest db "deduplicate targets" ["A", "A"] $
+ SolverResult p $
+ Right [("A", 1)]
+ , runTest $
+ let db = [Right $ exAv "A" 1 [ExAny "B"]]
+ msg =
+ "After searching the rest of the dependency tree exhaustively, "
+ ++ "these were the goals I've had most trouble fulfilling: A, B"
+ in mkTest db "exhaustive search failure message" ["A"] $
+ solverFailure (isInfixOf msg)
+ , testSummarizedLog "show conflicts from final conflict set after exhaustive search" Nothing $
+ "Could not resolve dependencies:\n"
+ ++ "[__0] trying: A-1.0.0 (user goal)\n"
+ ++ "[__1] unknown package: F (dependency of A)\n"
+ ++ "[__1] fail (backjumping, conflict set: A, F)\n"
+ ++ "After searching the rest of the dependency tree exhaustively, "
+ ++ "these were the goals I've had most trouble fulfilling: A, F"
+ , testSummarizedLog "show first conflicts after inexhaustive search" (Just 3) $
+ "Could not resolve dependencies:\n"
+ ++ "[__0] trying: A-1.0.0 (user goal)\n"
+ ++ "[__1] trying: B-3.0.0 (dependency of A)\n"
+ ++ "[__2] unknown package: C (dependency of B)\n"
+ ++ "[__2] fail (backjumping, conflict set: B, C)\n"
+ ++ "Backjump limit reached (currently 3, change with --max-backjumps "
+ ++ "or try to run with --reorder-goals).\n"
+ , testSummarizedLog "don't show summarized log when backjump limit is too low" (Just 1) $
+ "Backjump limit reached (currently 1, change with --max-backjumps "
+ ++ "or try to run with --reorder-goals).\n"
+ ++ "Failed to generate a summarized dependency solver log due to low backjump limit."
+ , testMinimizeConflictSet
+ "minimize conflict set with --minimize-conflict-set"
+ , testNoMinimizeConflictSet
+ "show original conflict set with --no-minimize-conflict-set"
+ , runTest $
+ let db =
+ [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]
+ , Left $ exInst "other-package" 2 "other-package-2.0.0" []
+ ]
+ msg = "rejecting: other-package-2.0.0/installed-2.0.0"
+ in mkTest db "show full installed package version (issue #5892)" ["my-package"] $
+ solverFailure (isInfixOf msg)
+ , runTest $
+ let db =
+ [ Right $ exAv "my-package" 1 [ExFix "other-package" 3]
+ , Left $ exInst "other-package" 2 "other-package-AbCdEfGhIj0123456789" []
+ ]
+ msg = "rejecting: other-package-2.0.0/installed-AbCdEfGhIj0123456789"
+ in mkTest db "show full installed package ABI hash (issue #5892)" ["my-package"] $
+ solverFailure (isInfixOf msg)
+ ]
+ ]
where
- indep = independentGoals
- mkvrThis = V.thisVersion . makeV
- mkvrOrEarlier = V.orEarlierVersion . makeV
- makeV v = V.mkVersion [v,0,0]
+ indep = independentGoals
+ mkvrThis = V.thisVersion . makeV
+ mkvrOrEarlier = V.orEarlierVersion . makeV
+ makeV v = V.mkVersion [v, 0, 0]
data GoalOrder = FixedGoalOrder | DefaultGoalOrder
@@ -802,23 +934,23 @@ data GoalOrder = FixedGoalOrder | DefaultGoalOrder
db1 :: ExampleDb
db1 =
- let a = exInst "A" 1 "A-1" []
- in [ Left a
- , Right $ exAv "B" 1 [ExAny "A"]
- , Right $ exAv "B" 2 [ExAny "A"]
- , Right $ exAv "C" 1 [ExFix "B" 1]
- , Right $ exAv "D" 1 [ExFix "B" 2]
- , Right $ exAv "E" 1 [ExAny "B"]
- , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]
- , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]
- , Right $ exAv "Z" 1 []
- ]
+ let a = exInst "A" 1 "A-1" []
+ in [ Left a
+ , Right $ exAv "B" 1 [ExAny "A"]
+ , Right $ exAv "B" 2 [ExAny "A"]
+ , Right $ exAv "C" 1 [ExFix "B" 1]
+ , Right $ exAv "D" 1 [ExFix "B" 2]
+ , Right $ exAv "E" 1 [ExAny "B"]
+ , Right $ exAv "F" 1 [ExFix "B" 1, ExAny "E"]
+ , Right $ exAv "G" 1 [ExFix "B" 2, ExAny "E"]
+ , Right $ exAv "Z" 1 []
+ ]
-- In this example, we _can_ install C and D as independent goals, but we have
-- to pick two different versions for B (arbitrarily)
db2 :: ExampleDb
-db2 = [
- Right $ exAv "A" 1 []
+db2 =
+ [ Right $ exAv "A" 1 []
, Right $ exAv "A" 2 []
, Right $ exAv "B" 1 [ExAny "A"]
, Right $ exAv "B" 2 [ExAny "A"]
@@ -827,13 +959,13 @@ db2 = [
]
db3 :: ExampleDb
-db3 = [
- Right $ exAv "A" 1 []
- , Right $ exAv "A" 2 []
- , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]]
- , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
- , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]
- ]
+db3 =
+ [ Right $ exAv "A" 1 []
+ , Right $ exAv "A" 2 []
+ , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "A" 1] [ExFix "A" 2]]
+ , Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
+ , Right $ exAv "D" 1 [ExFix "A" 2, ExAny "B"]
+ ]
-- | Like db3, but the flag picks a different package rather than a
-- different package version
@@ -868,22 +1000,23 @@ db3 = [
-- We will insist that 0.Ay will be linked to 1.Ay, and 0.Ax to 1.Ax, but since
-- we only ever assign to one of these, these constraints are never broken.
db4 :: ExampleDb
-db4 = [
- Right $ exAv "Ax" 1 []
- , Right $ exAv "Ax" 2 []
- , Right $ exAv "Ay" 1 []
- , Right $ exAv "Ay" 2 []
- , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
- , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"]
- , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"]
- ]
+db4 =
+ [ Right $ exAv "Ax" 1 []
+ , Right $ exAv "Ax" 2 []
+ , Right $ exAv "Ay" 1 []
+ , Right $ exAv "Ay" 2 []
+ , Right $ exAv "B" 1 [exFlagged "flagB" [ExFix "Ax" 1] [ExFix "Ay" 1]]
+ , Right $ exAv "C" 1 [ExFix "Ax" 2, ExAny "B"]
+ , Right $ exAv "D" 1 [ExFix "Ay" 2, ExAny "B"]
+ ]
-- | Simple database containing one package with a manual flag.
dbManualFlags :: ExampleDb
-dbManualFlags = [
- Right $ declareFlags [ExFlag "flag" True Manual] $
+dbManualFlags =
+ [ Right $
+ declareFlags [ExFlag "flag" True Manual] $
exAv "pkg" 1 [exFlagged "flag" [ExAny "true-dep"] [ExAny "false-dep"]]
- , Right $ exAv "true-dep" 1 []
+ , Right $ exAv "true-dep" 1 []
, Right $ exAv "false-dep" 1 []
]
@@ -893,30 +1026,50 @@ dbManualFlags = [
dbSetupDepWithManualFlag :: ExampleDb
dbSetupDepWithManualFlag =
let bFlags = [ExFlag "flag" True Manual]
- in [
- Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2]
- , Right $ declareFlags bFlags $
- exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"]
- [ExAny "b-1-false-dep"]]
- , Right $ declareFlags bFlags $
- exAv "B" 2 [exFlagged "flag" [ExAny "b-2-true-dep"]
- [ExAny "b-2-false-dep"]]
- , Right $ exAv "b-1-true-dep" 1 []
- , Right $ exAv "b-1-false-dep" 1 []
- , Right $ exAv "b-2-true-dep" 1 []
- , Right $ exAv "b-2-false-dep" 1 []
- ]
+ in [ Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 2]
+ , Right $
+ declareFlags bFlags $
+ exAv
+ "B"
+ 1
+ [ exFlagged
+ "flag"
+ [ExAny "b-1-true-dep"]
+ [ExAny "b-1-false-dep"]
+ ]
+ , Right $
+ declareFlags bFlags $
+ exAv
+ "B"
+ 2
+ [ exFlagged
+ "flag"
+ [ExAny "b-2-true-dep"]
+ [ExAny "b-2-false-dep"]
+ ]
+ , Right $ exAv "b-1-true-dep" 1 []
+ , Right $ exAv "b-1-false-dep" 1 []
+ , Right $ exAv "b-2-true-dep" 1 []
+ , Right $ exAv "b-2-false-dep" 1 []
+ ]
-- | A database similar to 'dbSetupDepWithManualFlag', except that the library
-- and setup script both depend on B-1. B must be linked because of the Single
-- Instance Restriction, and its flag can only have one value.
dbLinkedSetupDepWithManualFlag :: ExampleDb
-dbLinkedSetupDepWithManualFlag = [
- Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1]
- , Right $ declareFlags [ExFlag "flag" True Manual] $
- exAv "B" 1 [exFlagged "flag" [ExAny "b-1-true-dep"]
- [ExAny "b-1-false-dep"]]
- , Right $ exAv "b-1-true-dep" 1 []
+dbLinkedSetupDepWithManualFlag =
+ [ Right $ exAv "A" 1 [ExFix "B" 1] `withSetupDeps` [ExFix "B" 1]
+ , Right $
+ declareFlags [ExFlag "flag" True Manual] $
+ exAv
+ "B"
+ 1
+ [ exFlagged
+ "flag"
+ [ExAny "b-1-true-dep"]
+ [ExAny "b-1-false-dep"]
+ ]
+ , Right $ exAv "b-1-true-dep" 1 []
, Right $ exAv "b-1-false-dep" 1 []
]
@@ -936,8 +1089,8 @@ dbLinkedSetupDepWithManualFlag = [
-- * G is like E, but for version A-2. This means that if we cannot install
-- E and G together, unless we regard them as independent goals.
db5 :: ExampleDb
-db5 = [
- Right $ exAv "A" 1 []
+db5 =
+ [ Right $ exAv "A" 1 []
, Right $ exAv "A" 2 []
, Right $ exAv "B" 1 []
, Right $ exAv "C" 1 [] `withTest` exTest "testC" [ExAny "A"]
@@ -949,15 +1102,19 @@ db5 = [
-- Now the _dependencies_ have test suites
--
+
-- * Installing C is a simple example. C wants version 1 of A, but depends on
+
-- B, and B's testsuite depends on an any version of A. In this case we prefer
-- to link (if we don't regard test suites as independent goals then of course
-- linking here doesn't even come into it).
+
-- * Installing [C, D] means that we prefer to link B -- depending on how we
+
-- set things up, this means that we should also link their test suites.
db6 :: ExampleDb
-db6 = [
- Right $ exAv "A" 1 []
+db6 =
+ [ Right $ exAv "A" 1 []
, Right $ exAv "A" 2 []
, Right $ exAv "B" 1 [] `withTest` exTest "testA" [ExAny "A"]
, Right $ exAv "C" 1 [ExFix "A" 1, ExAny "B"]
@@ -974,20 +1131,22 @@ db6 = [
-- dependency on B.
testTestSuiteWithFlag :: String -> SolverTest
testTestSuiteWithFlag name =
- goalOrder goals $ enableAllTests $ mkTest db name ["A", "B"] $
- solverSuccess [("A", 1), ("B", 1)]
+ goalOrder goals $
+ enableAllTests $
+ mkTest db name ["A", "B"] $
+ solverSuccess [("A", 1), ("B", 1)]
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 []
- `withTest`
- exTest "test" [exFlagged "flag" [ExFix "B" 2] []]
+ db =
+ [ Right $
+ exAv "A" 1 []
+ `withTest` exTest "test" [exFlagged "flag" [ExFix "B" 2] []]
, Right $ exAv "B" 1 []
]
goals :: [ExampleVar]
- goals = [
- P QualNone "B"
+ goals =
+ [ P QualNone "B"
, P QualNone "A"
, F QualNone "A" "flag"
, S QualNone "A" TestStanzas
@@ -996,13 +1155,20 @@ testTestSuiteWithFlag name =
-- Packages with setup dependencies
--
-- Install..
+
-- * B: Simple example, just make sure setup deps are taken into account at all
+
-- * C: Both the package and the setup script depend on any version of A.
+
-- In this case we prefer to link
+
-- * D: Variation on C.1 where the package requires a specific (not latest)
+
-- version but the setup dependency is not fixed. Again, we prefer to
-- link (picking the older version)
+
-- * E: Variation on C.2 with the setup dependency the more inflexible.
+
-- Currently, in this case we do not see the opportunity to link because
-- we consider setup dependencies after normal dependencies; we will
-- pick A.2 for E, then realize we cannot link E.setup.A to A.2, and pick
@@ -1012,24 +1178,26 @@ testTestSuiteWithFlag name =
-- setups to package deps, rather than the other way around. (For example,
-- if we change this ordering then the test for D would start to install
-- two versions of A).
+
-- * F: The package and the setup script depend on different versions of A.
+
-- This will only work if setup dependencies are considered independent.
db7 :: ExampleDb
-db7 = [
- Right $ exAv "A" 1 []
+db7 =
+ [ Right $ exAv "A" 1 []
, Right $ exAv "A" 2 []
- , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"]
- , Right $ exAv "C" 1 [ExAny "A" ] `withSetupDeps` [ExAny "A" ]
- , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A" ]
- , Right $ exAv "E" 1 [ExAny "A" ] `withSetupDeps` [ExFix "A" 1]
+ , Right $ exAv "B" 1 [] `withSetupDeps` [ExAny "A"]
+ , Right $ exAv "C" 1 [ExAny "A"] `withSetupDeps` [ExAny "A"]
+ , Right $ exAv "D" 1 [ExFix "A" 1] `withSetupDeps` [ExAny "A"]
+ , Right $ exAv "E" 1 [ExAny "A"] `withSetupDeps` [ExFix "A" 1]
, Right $ exAv "F" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
]
-- If we install C and D together (not as independent goals), we need to build
-- both B.1 and B.2, both of which depend on A.
db8 :: ExampleDb
-db8 = [
- Right $ exAv "A" 1 []
+db8 =
+ [ Right $ exAv "A" 1 []
, Right $ exAv "B" 1 [ExAny "A"]
, Right $ exAv "B" 2 [ExAny "A"]
, Right $ exAv "C" 1 [] `withSetupDeps` [ExFix "B" 1]
@@ -1038,31 +1206,31 @@ db8 = [
-- Extended version of `db8` so that we have nested setup dependencies
db9 :: ExampleDb
-db9 = db8 ++ [
- Right $ exAv "E" 1 [ExAny "C"]
- , Right $ exAv "E" 2 [ExAny "D"]
- , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]
- , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]
- ]
+db9 =
+ db8
+ ++ [ Right $ exAv "E" 1 [ExAny "C"]
+ , Right $ exAv "E" 2 [ExAny "D"]
+ , Right $ exAv "F" 1 [] `withSetupDeps` [ExFix "E" 1]
+ , Right $ exAv "G" 1 [] `withSetupDeps` [ExFix "E" 2]
+ ]
-- Multiple already-installed packages with inter-dependencies, and one package
-- (C) that depends on package A-1 for its setup script and package A-2 as a
-- library dependency.
db10 :: ExampleDb
db10 =
- let rts = exInst "rts" 1 "rts-inst" []
- ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts]
- base = exInst "base" 1 "base-inst" [rts, ghc_prim]
- a1 = exInst "A" 1 "A1-inst" [base]
- a2 = exInst "A" 2 "A2-inst" [base]
- in [
- Left rts
- , Left ghc_prim
- , Left base
- , Left a1
- , Left a2
- , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
- ]
+ let rts = exInst "rts" 1 "rts-inst" []
+ ghc_prim = exInst "ghc-prim" 1 "ghc-prim-inst" [rts]
+ base = exInst "base" 1 "base-inst" [rts, ghc_prim]
+ a1 = exInst "A" 1 "A1-inst" [base]
+ a2 = exInst "A" 2 "A2-inst" [base]
+ in [ Left rts
+ , Left ghc_prim
+ , Left base
+ , Left a1
+ , Left a2
+ , Right $ exAv "C" 1 [ExFix "A" 2] `withSetupDeps` [ExFix "A" 1]
+ ]
-- | This database tests that a package's setup dependencies are correctly
-- linked when the package is linked. See pull request #3268.
@@ -1074,8 +1242,8 @@ db10 =
-- independent. The solver should be able to choose D-1 for C's library and D-2
-- for C's setup script.
dbSetupDeps :: ExampleDb
-dbSetupDeps = [
- Right $ exAv "A" 1 [ExAny "C"]
+dbSetupDeps =
+ [ Right $ exAv "A" 1 [ExAny "C"]
, Right $ exAv "B" 1 [ExAny "C"]
, Right $ exAv "C" 1 [ExFix "D" 1] `withSetupDeps` [ExFix "D" 2]
, Right $ exAv "D" 1 []
@@ -1087,11 +1255,10 @@ db11 :: ExampleDb
db11 =
let base3 = exInst "base" 3 "base-3-inst" [base4]
base4 = exInst "base" 4 "base-4-inst" []
- in [
- Left base3
- , Left base4
- , Right $ exAv "A" 1 [ExFix "base" 3]
- ]
+ in [ Left base3
+ , Left base4
+ , Right $ exAv "A" 1 [ExFix "base" 3]
+ ]
-- | Slightly more realistic version of db11 where base-3 depends on syb
-- This means that if a package depends on base-3 and on syb, then they MUST
@@ -1107,31 +1274,33 @@ db12 :: ExampleDb
db12 =
let base3 = exInst "base" 3 "base-3-inst" [base4, syb1]
base4 = exInst "base" 4 "base-4-inst" []
- syb1 = exInst "syb" 1 "syb-1-inst" [base4]
- in [
- Left base3
- , Left base4
- , Left syb1
- , Right $ exAv "syb" 2 [ExFix "base" 4]
- , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]
- , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]
- , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
- , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]
- , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
- ]
+ syb1 = exInst "syb" 1 "syb-1-inst" [base4]
+ in [ Left base3
+ , Left base4
+ , Left syb1
+ , Right $ exAv "syb" 2 [ExFix "base" 4]
+ , Right $ exAv "A" 1 [ExFix "base" 3, ExAny "syb"]
+ , Right $ exAv "B" 1 [ExFix "base" 4, ExAny "syb"]
+ , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
+ , Right $ exAv "D" 1 [ExFix "base" 3, ExFix "syb" 2]
+ , Right $ exAv "E" 1 [ExFix "base" 4, ExFix "syb" 2]
+ ]
dbBase :: ExampleDb
-dbBase = [
- Right $ exAv "base" 1
- [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"]
- , Right $ exAv "ghc-prim" 1 []
- , Right $ exAv "integer-simple" 1 []
- , Right $ exAv "integer-gmp" 1 []
- ]
+dbBase =
+ [ Right $
+ exAv
+ "base"
+ 1
+ [ExAny "ghc-prim", ExAny "integer-simple", ExAny "integer-gmp"]
+ , Right $ exAv "ghc-prim" 1 []
+ , Right $ exAv "integer-simple" 1 []
+ , Right $ exAv "integer-gmp" 1 []
+ ]
dbNonupgrade :: ExampleDb
-dbNonupgrade = [
- Left $ exInst "ghc" 1 "ghc-1" []
+dbNonupgrade =
+ [ Left $ exInst "ghc" 1 "ghc-1" []
, Left $ exInst "ghci" 1 "ghci-1" []
, Left $ exInst "ghc-boot" 1 "ghc-boot-1" []
, Right $ exAv "ghc" 2 []
@@ -1143,8 +1312,8 @@ dbNonupgrade = [
]
db13 :: ExampleDb
-db13 = [
- Right $ exAv "A" 1 []
+db13 =
+ [ Right $ exAv "A" 1 []
, Right $ exAv "A" 2 []
, Right $ exAv "A" 3 []
]
@@ -1158,20 +1327,20 @@ db13 = [
-- behavior.
dbConstraints :: ExampleDb
dbConstraints =
- [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]]
- ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]]
- ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]]
- ++ [Right $ exAv "D" v [] | v <- [1..9]]
+ [Right $ exAv "A" v [ExFix "D" v] | v <- [1, 4, 7]]
+ ++ [Right $ exAv "B" v [] `withSetupDeps` [ExFix "D" v] | v <- [2, 5, 8]]
+ ++ [Right $ exAv "C" v [] `withSetupDeps` [ExFix "D" v] | v <- [3, 6, 9]]
+ ++ [Right $ exAv "D" v [] | v <- [1 .. 9]]
dbStanzaPreferences1 :: ExampleDb
-dbStanzaPreferences1 = [
- Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "test-dep"]
+dbStanzaPreferences1 =
+ [ Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "test-dep"]
, Right $ exAv "test-dep" 1 []
]
dbStanzaPreferences2 :: ExampleDb
-dbStanzaPreferences2 = [
- Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "unknown"]
+dbStanzaPreferences2 =
+ [ Right $ exAv "pkg" 1 [] `withTest` exTest "test" [ExAny "unknown"]
]
-- | This is a test case for a bug in stanza preferences (#3930). The solver
@@ -1183,22 +1352,32 @@ dbStanzaPreferences2 = [
-- testing and failed to find the solution.
testStanzaPreference :: String -> TestTree
testStanzaPreference name =
- let pkg = exAv "A" 1 [exFlagged "flag"
- []
- [ExAny "unknown-pkg1"]]
- `withTest`
- exTest "test" [exFlagged "flag"
- [ExAny "unknown-pkg2"]
- []]
- goals = [
- P QualNone "A"
+ let pkg =
+ exAv
+ "A"
+ 1
+ [ exFlagged
+ "flag"
+ []
+ [ExAny "unknown-pkg1"]
+ ]
+ `withTest` exTest
+ "test"
+ [ exFlagged
+ "flag"
+ [ExAny "unknown-pkg2"]
+ []
+ ]
+ goals =
+ [ P QualNone "A"
, F QualNone "A" "flag"
, S QualNone "A" TestStanzas
]
- in runTest $ goalOrder goals $
- preferences [ ExStanzaPref "A" [TestStanzas]] $
- mkTest [Right pkg] name ["A"] $
- solverSuccess [("A", 1)]
+ in runTest $
+ goalOrder goals $
+ preferences [ExStanzaPref "A" [TestStanzas]] $
+ mkTest [Right pkg] name ["A"] $
+ solverSuccess [("A", 1)]
-- | Database with some cycles
--
@@ -1206,8 +1385,8 @@ testStanzaPreference name =
-- * There is a cycle C -> D -> C, but it can be broken by picking the
-- right flag assignment.
db14 :: ExampleDb
-db14 = [
- Right $ exAv "A" 1 [ExAny "B"]
+db14 =
+ [ Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "B" 1 [ExAny "A"]
, Right $ exAv "C" 1 [exFlagged "flagC" [ExAny "D"] [ExAny "E"]]
, Right $ exAv "D" 1 [ExAny "C"]
@@ -1226,15 +1405,15 @@ db14 = [
-- Thus, we should be able to break this cycle even if we are installing package
-- E, which explicitly depends on C-2.0.
db15 :: ExampleDb
-db15 = [
- -- First example (real cycle, no solution)
- Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"]
- , Right $ exAv "B" 1 [ExAny "A"]
- -- Second example (cycle can be broken by picking versions carefully)
- , Left $ exInst "C" 1 "C-1-inst" []
- , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"]
- , Right $ exAv "D" 1 [ExAny "C" ]
- , Right $ exAv "E" 1 [ExFix "C" 2]
+db15 =
+ [ -- First example (real cycle, no solution)
+ Right $ exAv "A" 1 [] `withSetupDeps` [ExAny "B"]
+ , Right $ exAv "B" 1 [ExAny "A"]
+ , -- Second example (cycle can be broken by picking versions carefully)
+ Left $ exInst "C" 1 "C-1-inst" []
+ , Right $ exAv "C" 2 [] `withSetupDeps` [ExAny "D"]
+ , Right $ exAv "D" 1 [ExAny "C"]
+ , Right $ exAv "E" 1 [ExFix "C" 2]
]
-- | Detect a cycle between a package and its setup script.
@@ -1246,20 +1425,24 @@ db15 = [
-- package and then choose a different version for the setup dependency.
issue4161 :: String -> SolverTest
issue4161 name =
- setVerbose $ mkTest db name ["target"] $
- SolverResult checkFullLog $ Right [("target", 1), ("time", 1), ("time", 2)]
+ setVerbose $
+ mkTest db name ["target"] $
+ SolverResult checkFullLog $
+ Right [("target", 1), ("time", 1), ("time", 2)]
where
db :: ExampleDb
- db = [
- Right $ exAv "target" 1 [ExFix "time" 2]
- , Right $ exAv "time" 2 [] `withSetupDeps` [ExAny "time"]
- , Right $ exAv "time" 1 []
+ db =
+ [ Right $ exAv "target" 1 [ExFix "time" 2]
+ , Right $ exAv "time" 2 [] `withSetupDeps` [ExAny "time"]
+ , Right $ exAv "time" 1 []
]
checkFullLog :: [String] -> Bool
- checkFullLog = any $ isInfixOf $
- "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "
- ++ "conflict set: time:setup.time)"
+ checkFullLog =
+ any $
+ isInfixOf $
+ "rejecting: time:setup.time~>time-2.0.0 (cyclic dependencies; "
+ ++ "conflict set: time:setup.time)"
-- | Packages pkg-A, pkg-B, and pkg-C form a cycle. The solver should backtrack
-- as soon as it chooses the last package in the cycle, to avoid searching parts
@@ -1267,13 +1450,14 @@ issue4161 name =
-- it should fail with an error message describing the cycle.
testCyclicDependencyErrorMessages :: String -> SolverTest
testCyclicDependencyErrorMessages name =
- goalOrder goals $
+ goalOrder goals $
mkTest db name ["pkg-A"] $
- SolverResult checkFullLog $ Left checkSummarizedLog
+ SolverResult checkFullLog $
+ Left checkSummarizedLog
where
db :: ExampleDb
- db = [
- Right $ exAv "pkg-A" 1 [ExAny "pkg-B"]
+ db =
+ [ Right $ exAv "pkg-A" 1 [ExAny "pkg-B"]
, Right $ exAv "pkg-B" 1 [ExAny "pkg-C"]
, Right $ exAv "pkg-C" 1 [ExAny "pkg-A", ExAny "pkg-D"]
, Right $ exAv "pkg-D" 1 [ExAny "pkg-E"]
@@ -1284,15 +1468,15 @@ testCyclicDependencyErrorMessages name =
-- cycle. It shouldn't try pkg-D or pkg-E.
checkFullLog :: [String] -> Bool
checkFullLog =
- not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l)
+ not . any (\l -> "pkg-D" `isInfixOf` l || "pkg-E" `isInfixOf` l)
checkSummarizedLog :: String -> Bool
checkSummarizedLog =
- isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"
+ isInfixOf "rejecting: pkg-C-1.0.0 (cyclic dependencies; conflict set: pkg-A, pkg-B, pkg-C)"
-- Solve for pkg-D and pkg-E last.
goals :: [ExampleVar]
- goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A'..'E']]
+ goals = [P QualNone ("pkg-" ++ [c]) | c <- ['A' .. 'E']]
-- | Check that the solver can backtrack after encountering the SIR (issue #2843)
--
@@ -1312,28 +1496,35 @@ testCyclicDependencyErrorMessages name =
-- would need two instances of C: one built against D-1.0 and one built against
-- D-2.0.
db16 :: ExampleDb
-db16 = [
- Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
- , Right $ exAv "B" 1 [ ExFix "D" 2
- , exFlagged "flagA"
- [ExAny "C"]
- [exFlagged "flagB"
- [ExAny "E"]
- [ExAny "C"]]]
+db16 =
+ [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
+ , Right $
+ exAv
+ "B"
+ 1
+ [ ExFix "D" 2
+ , exFlagged
+ "flagA"
+ [ExAny "C"]
+ [ exFlagged
+ "flagB"
+ [ExAny "E"]
+ [ExAny "C"]
+ ]
+ ]
, Right $ exAv "C" 1 [ExAny "D"]
, Right $ exAv "D" 1 []
, Right $ exAv "D" 2 []
, Right $ exAv "E" 1 []
]
-
-- Try to get the solver to backtrack while satisfying
-- reject-unconstrained-dependencies: both the first and last versions of A
-- require packages outside the closed set, so it will have to try the
-- middle one.
db17 :: ExampleDb
-db17 = [
- Right $ exAv "A" 1 [ExAny "C"]
+db17 =
+ [ Right $ exAv "A" 1 [ExAny "C"]
, Right $ exAv "A" 2 [ExAny "B"]
, Right $ exAv "A" 3 [ExAny "C"]
, Right $ exAv "B" 1 []
@@ -1351,13 +1542,15 @@ db17 = [
-- solver must backtrack to try D-1 for both 0.D and 1.D.
testIndepGoals2 :: String -> SolverTest
testIndepGoals2 name =
- goalOrder goals $ independentGoals $
- enableAllTests $ mkTest db name ["A", "B"] $
- solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]
+ goalOrder goals $
+ independentGoals $
+ enableAllTests $
+ mkTest db name ["A", "B"] $
+ solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1)]
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1]
+ db =
+ [ Right $ exAv "A" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1]
, Right $ exAv "B" 1 [ExAny "C"] `withTest` exTest "test" [ExFix "D" 1]
, Right $ exAv "C" 1 [ExAny "D"]
, Right $ exAv "D" 1 []
@@ -1365,8 +1558,8 @@ testIndepGoals2 name =
]
goals :: [ExampleVar]
- goals = [
- P (QualIndep "A") "A"
+ goals =
+ [ P (QualIndep "A") "A"
, P (QualIndep "A") "C"
, P (QualIndep "A") "D"
, P (QualIndep "B") "B"
@@ -1393,14 +1586,22 @@ testIndepGoals2 name =
-- D-1, and B depends on C-2, it is therefore important that C cannot depend
-- on any version of D.
db18 :: ExampleDb
-db18 = [
- Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
+db18 =
+ [ Right $ exAv "A" 1 [ExAny "C", ExFix "D" 1]
, Right $ exAv "B" 1 [ExAny "C", ExFix "D" 2]
- , Right $ exAv "C" 1 [exFlagged "flagA"
- [ExFix "D" 1, ExAny "E"]
- [exFlagged "flagB"
- [ExAny "F"]
- [ExFix "D" 2, ExAny "G"]]]
+ , Right $
+ exAv
+ "C"
+ 1
+ [ exFlagged
+ "flagA"
+ [ExFix "D" 1, ExAny "E"]
+ [ exFlagged
+ "flagB"
+ [ExAny "F"]
+ [ExFix "D" 2, ExAny "G"]
+ ]
+ ]
, Right $ exAv "D" 1 []
, Right $ exAv "D" 2 []
, Right $ exAv "E" 1 []
@@ -1414,34 +1615,54 @@ db18 = [
-- and -flagA.
commonDependencyLogMessage :: String -> SolverTest
commonDependencyLogMessage name =
- mkTest db name ["A"] $ solverFailure $ isInfixOf $
+ mkTest db name ["A"] $
+ solverFailure $
+ isInfixOf $
"[__0] trying: A-1.0.0 (user goal)\n"
- ++ "[__1] next goal: B (dependency of A +/-flagA)\n"
- ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"
+ ++ "[__1] next goal: B (dependency of A +/-flagA)\n"
+ ++ "[__1] rejecting: B-2.0.0 (conflict: A +/-flagA => B==1.0.0 || ==3.0.0)"
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [exFlagged "flagA"
- [ExFix "B" 1]
- [ExFix "B" 3]]
+ db =
+ [ Right $
+ exAv
+ "A"
+ 1
+ [ exFlagged
+ "flagA"
+ [ExFix "B" 1]
+ [ExFix "B" 3]
+ ]
, Right $ exAv "B" 2 []
]
-- | Test lifting dependencies out of multiple levels of conditionals.
twoLevelDeepCommonDependencyLogMessage :: String -> SolverTest
twoLevelDeepCommonDependencyLogMessage name =
- mkTest db name ["A"] $ solverFailure $ isInfixOf $
+ mkTest db name ["A"] $
+ solverFailure $
+ isInfixOf $
"unknown package: B (dependency of A +/-flagA +/-flagB)"
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [exFlagged "flagA"
- [exFlagged "flagB"
- [ExAny "B"]
- [ExAny "B"]]
- [exFlagged "flagB"
- [ExAny "B"]
- [ExAny "B"]]]
+ db =
+ [ Right $
+ exAv
+ "A"
+ 1
+ [ exFlagged
+ "flagA"
+ [ exFlagged
+ "flagB"
+ [ExAny "B"]
+ [ExAny "B"]
+ ]
+ [ exFlagged
+ "flagB"
+ [ExAny "B"]
+ [ExAny "B"]
+ ]
+ ]
]
-- | Test handling nested conditionals that are controlled by the same flag.
@@ -1451,15 +1672,23 @@ twoLevelDeepCommonDependencyLogMessage name =
-- than backjumping past flagA.
testBackjumpingWithCommonDependency :: String -> SolverTest
testBackjumpingWithCommonDependency name =
- mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
+ mkTest db name ["A"] $ solverSuccess [("A", 1), ("B", 1)]
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [exFlagged "flagA"
- [exFlagged "flagA"
- [ExAny "unknown"]
- [ExAny "unknown"]]
- [ExAny "B"]]
+ db =
+ [ Right $
+ exAv
+ "A"
+ 1
+ [ exFlagged
+ "flagA"
+ [ exFlagged
+ "flagA"
+ [ExAny "unknown"]
+ [ExAny "unknown"]
+ ]
+ [ExAny "B"]
+ ]
, Right $ exAv "B" 1 []
]
@@ -1489,12 +1718,13 @@ testBackjumpingWithCommonDependency name =
-- > D F E
testIndepGoals3 :: String -> SolverTest
testIndepGoals3 name =
- goalOrder goals $ independentGoals $
- mkTest db name ["D", "E", "F"] anySolverFailure
+ goalOrder goals $
+ independentGoals $
+ mkTest db name ["D", "E", "F"] anySolverFailure
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ExAny "C"]
+ db =
+ [ Right $ exAv "A" 1 [ExAny "C"]
, Right $ exAv "B" 1 [ExAny "C"]
, Right $ exAv "C" 1 []
, Right $ exAv "C" 2 []
@@ -1504,8 +1734,8 @@ testIndepGoals3 name =
]
goals :: [ExampleVar]
- goals = [
- P (QualIndep "D") "D"
+ goals =
+ [ P (QualIndep "D") "D"
, P (QualIndep "D") "C"
, P (QualIndep "D") "A"
, P (QualIndep "E") "E"
@@ -1531,13 +1761,15 @@ testIndepGoals3 name =
-- changed.
testIndepGoals4 :: String -> SolverTest
testIndepGoals4 name =
- goalOrder goals $ independentGoals $
- enableAllTests $ mkTest db name ["A", "B", "C"] $
- solverSuccess [("A",1), ("B",1), ("C",1), ("D",1), ("E",1), ("E",2)]
+ goalOrder goals $
+ independentGoals $
+ enableAllTests $
+ mkTest db name ["A", "B", "C"] $
+ solverSuccess [("A", 1), ("B", 1), ("C", 1), ("D", 1), ("E", 1), ("E", 2)]
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ExFix "E" 2]
+ db =
+ [ Right $ exAv "A" 1 [ExFix "E" 2]
, Right $ exAv "B" 1 [ExAny "D"]
, Right $ exAv "C" 1 [ExAny "D"] `withTest` exTest "test" [ExFix "E" 1]
, Right $ exAv "D" 1 [ExAny "E"]
@@ -1546,8 +1778,8 @@ testIndepGoals4 name =
]
goals :: [ExampleVar]
- goals = [
- P (QualIndep "A") "A"
+ goals =
+ [ P (QualIndep "A") "A"
, P (QualIndep "A") "E"
, P (QualIndep "B") "B"
, P (QualIndep "B") "D"
@@ -1563,16 +1795,16 @@ testIndepGoals4 name =
-- TODO: Currently we don't actually test the trace messages, and this particular
-- test still succeeds. The trace can only be verified by hand.
db21 :: ExampleDb
-db21 = [
- Right $ exAv "A" 1 [ExAny "B"]
+db21 =
+ [ Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "A" 2 [ExAny "C"] -- A-2.0 will be tried first, but C unknown
, Right $ exAv "B" 1 []
]
-- | A variant of 'db21', which actually fails.
db22 :: ExampleDb
-db22 = [
- Right $ exAv "A" 1 [ExAny "B"]
+db22 =
+ [ Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "A" 2 [ExAny "C"]
]
@@ -1583,8 +1815,8 @@ db22 = [
-- is propagated up the tree to the level of A. Since the conflict set is the
-- same at both levels, the solver only keeps one of the backjumping messages.
db23 :: ExampleDb
-db23 = [
- Right $ exAv "A" 1 [ExAny "B"]
+db23 =
+ [ Right $ exAv "A" 1 [ExAny "B"]
]
-- | Database for (unsuccessfully) trying to expose a bug in the handling
@@ -1599,21 +1831,22 @@ db23 = [
-- Even if the SIR is not in place, if there is a solution, one will always
-- be found, because without the SIR, linking is always optional, but never
-- necessary.
---
testIndepGoals5 :: String -> GoalOrder -> SolverTest
testIndepGoals5 name fixGoalOrder =
- case fixGoalOrder of
- FixedGoalOrder -> goalOrder goals test
- DefaultGoalOrder -> test
+ case fixGoalOrder of
+ FixedGoalOrder -> goalOrder goals test
+ DefaultGoalOrder -> test
where
test :: SolverTest
- test = independentGoals $ mkTest db name ["X", "Y"] $
- solverSuccess
- [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)]
+ test =
+ independentGoals $
+ mkTest db name ["X", "Y"] $
+ solverSuccess
+ [("A", 1), ("A", 2), ("B", 1), ("C", 1), ("C", 2), ("X", 1), ("Y", 1)]
db :: ExampleDb
- db = [
- Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"]
+ db =
+ [ Right $ exAv "X" 1 [ExFix "C" 2, ExAny "A"]
, Right $ exAv "Y" 1 [ExFix "C" 1, ExFix "A" 2]
, Right $ exAv "A" 1 []
, Right $ exAv "A" 2 [ExAny "B"]
@@ -1623,8 +1856,8 @@ testIndepGoals5 name fixGoalOrder =
]
goals :: [ExampleVar]
- goals = [
- P (QualIndep "X") "X"
+ goals =
+ [ P (QualIndep "X") "X"
, P (QualIndep "X") "A"
, P (QualIndep "X") "B"
, P (QualIndep "X") "C"
@@ -1637,18 +1870,20 @@ testIndepGoals5 name fixGoalOrder =
-- | A simplified version of 'testIndepGoals5'.
testIndepGoals6 :: String -> GoalOrder -> SolverTest
testIndepGoals6 name fixGoalOrder =
- case fixGoalOrder of
- FixedGoalOrder -> goalOrder goals test
- DefaultGoalOrder -> test
+ case fixGoalOrder of
+ FixedGoalOrder -> goalOrder goals test
+ DefaultGoalOrder -> test
where
test :: SolverTest
- test = independentGoals $ mkTest db name ["X", "Y"] $
- solverSuccess
- [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)]
+ test =
+ independentGoals $
+ mkTest db name ["X", "Y"] $
+ solverSuccess
+ [("A", 1), ("A", 2), ("B", 1), ("B", 2), ("X", 1), ("Y", 1)]
db :: ExampleDb
- db = [
- Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"]
+ db =
+ [ Right $ exAv "X" 1 [ExFix "B" 2, ExAny "A"]
, Right $ exAv "Y" 1 [ExFix "B" 1, ExFix "A" 2]
, Right $ exAv "A" 1 []
, Right $ exAv "A" 2 [ExAny "B"]
@@ -1657,8 +1892,8 @@ testIndepGoals6 name fixGoalOrder =
]
goals :: [ExampleVar]
- goals = [
- P (QualIndep "X") "X"
+ goals =
+ [ P (QualIndep "X") "X"
, P (QualIndep "X") "A"
, P (QualIndep "X") "B"
, P (QualIndep "Y") "Y"
@@ -1667,8 +1902,8 @@ testIndepGoals6 name fixGoalOrder =
]
dbExts1 :: ExampleDb
-dbExts1 = [
- Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]
+dbExts1 =
+ [ Right $ exAv "A" 1 [ExExt (EnableExtension RankNTypes)]
, Right $ exAv "B" 1 [ExExt (EnableExtension CPP), ExAny "A"]
, Right $ exAv "C" 1 [ExAny "B"]
, Right $ exAv "D" 1 [ExExt (DisableExtension CPP), ExAny "B"]
@@ -1676,8 +1911,8 @@ dbExts1 = [
]
dbLangs1 :: ExampleDb
-dbLangs1 = [
- Right $ exAv "A" 1 [ExLang Haskell2010]
+dbLangs1 =
+ [ Right $ exAv "A" 1 [ExLang Haskell2010]
, Right $ exAv "B" 1 [ExLang Haskell98, ExAny "A"]
, Right $ exAv "C" 1 [ExLang (UnknownLanguage "Haskell3000"), ExAny "B"]
]
@@ -1687,17 +1922,25 @@ dbLangs1 = [
-- depend on "false-dep".
testBuildable :: String -> ExampleDependency -> TestTree
testBuildable testName unavailableDep =
- runTest $
+ runTest $
mkTestExtLangPC (Just []) (Just [Haskell98]) (Just []) db testName ["pkg"] expected
where
expected = solverSuccess [("false-dep", 1), ("pkg", 1)]
- db = [
- Right $ exAv "pkg" 1 [exFlagged "enable-exe"
- [ExAny "true-dep"]
- [ExAny "false-dep"]]
- `withExe`
- exExe "exe" [ unavailableDep
- , ExFlagged "enable-exe" (dependencies []) unbuildableDependencies ]
+ db =
+ [ Right $
+ exAv
+ "pkg"
+ 1
+ [ exFlagged
+ "enable-exe"
+ [ExAny "true-dep"]
+ [ExAny "false-dep"]
+ ]
+ `withExe` exExe
+ "exe"
+ [ unavailableDep
+ , ExFlagged "enable-exe" (dependencies []) unbuildableDependencies
+ ]
, Right $ exAv "true-dep" 1 []
, Right $ exAv "false-dep" 1 []
]
@@ -1705,21 +1948,29 @@ testBuildable testName unavailableDep =
-- | cabal must choose -flag1 +flag2 for "pkg", which requires packages
-- "flag1-false" and "flag2-true".
dbBuildable1 :: ExampleDb
-dbBuildable1 = [
- Right $ exAv "pkg" 1
+dbBuildable1 =
+ [ Right $
+ exAv
+ "pkg"
+ 1
[ exFlagged "flag1" [ExAny "flag1-true"] [ExAny "flag1-false"]
- , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]]
- `withExes`
- [ exExe "exe1"
- [ ExAny "unknown"
- , ExFlagged "flag1" (dependencies []) unbuildableDependencies
- , ExFlagged "flag2" (dependencies []) unbuildableDependencies]
- , exExe "exe2"
- [ ExAny "unknown"
- , ExFlagged "flag1"
- (dependencies [])
- (dependencies [ExFlagged "flag2" unbuildableDependencies (dependencies [])])]
- ]
+ , exFlagged "flag2" [ExAny "flag2-true"] [ExAny "flag2-false"]
+ ]
+ `withExes` [ exExe
+ "exe1"
+ [ ExAny "unknown"
+ , ExFlagged "flag1" (dependencies []) unbuildableDependencies
+ , ExFlagged "flag2" (dependencies []) unbuildableDependencies
+ ]
+ , exExe
+ "exe2"
+ [ ExAny "unknown"
+ , ExFlagged
+ "flag1"
+ (dependencies [])
+ (dependencies [ExFlagged "flag2" unbuildableDependencies (dependencies [])])
+ ]
+ ]
, Right $ exAv "flag1-true" 1 []
, Right $ exAv "flag1-false" 1 []
, Right $ exAv "flag2-true" 1 []
@@ -1728,23 +1979,24 @@ dbBuildable1 = [
-- | cabal must pick B-2 to avoid the unknown dependency.
dbBuildable2 :: ExampleDb
-dbBuildable2 = [
- Right $ exAv "A" 1 [ExAny "B"]
+dbBuildable2 =
+ [ Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "B" 1 [ExAny "unknown"]
- , Right $ exAv "B" 2 []
- `withExe`
- exExe "exe"
- [ ExAny "unknown"
- , ExFlagged "disable-exe" unbuildableDependencies (dependencies [])
- ]
+ , Right $
+ exAv "B" 2 []
+ `withExe` exExe
+ "exe"
+ [ ExAny "unknown"
+ , ExFlagged "disable-exe" unbuildableDependencies (dependencies [])
+ ]
, Right $ exAv "B" 3 [ExAny "unknown"]
]
-- | Package databases for testing @pkg-config@ dependencies.
-- when no pkgconfig db is present, cabal must pick flag1 false and flag2 true to avoid the pkg dependency.
dbPC1 :: ExampleDb
-dbPC1 = [
- Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]
+dbPC1 =
+ [ Right $ exAv "A" 1 [ExPkg ("pkgA", 1)]
, Right $ exAv "B" 1 [ExPkg ("pkgB", 1), ExAny "A"]
, Right $ exAv "B" 2 [ExPkg ("pkgB", 2), ExAny "A"]
, Right $ exAv "C" 1 [ExAny "B"]
@@ -1759,11 +2011,14 @@ dbPC1 = [
-- conflict set to only show the conflict between A and F in the summarized log.
testSummarizedLog :: String -> Maybe Int -> String -> TestTree
testSummarizedLog testName mbj expectedMsg =
- runTest $ maxBackjumps mbj $ goalOrder goals $ mkTest db testName ["A"] $
- solverFailure (== expectedMsg)
+ runTest $
+ maxBackjumps mbj $
+ goalOrder goals $
+ mkTest db testName ["A"] $
+ solverFailure (== expectedMsg)
where
- db = [
- Right $ exAv "A" 1 [ExAny "B", ExAny "F"]
+ db =
+ [ Right $ exAv "A" 1 [ExAny "B", ExAny "F"]
, Right $ exAv "B" 3 [ExAny "C"]
, Right $ exAv "B" 2 [ExAny "D"]
, Right $ exAv "B" 1 [ExAny "E"]
@@ -1774,8 +2029,8 @@ testSummarizedLog testName mbj expectedMsg =
goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D", "E", "F"]]
dbMinimizeConflictSet :: ExampleDb
-dbMinimizeConflictSet = [
- Right $ exAv "A" 3 [ExFix "B" 2, ExFix "C" 1, ExFix "D" 2]
+dbMinimizeConflictSet =
+ [ Right $ exAv "A" 3 [ExFix "B" 2, ExFix "C" 1, ExFix "D" 2]
, Right $ exAv "A" 2 [ExFix "B" 1, ExFix "C" 2, ExFix "D" 2]
, Right $ exAv "A" 1 [ExFix "B" 1, ExFix "C" 1, ExFix "D" 2]
, Right $ exAv "B" 1 []
@@ -1792,31 +2047,35 @@ dbMinimizeConflictSet = [
-- only mention A and D.
testMinimizeConflictSet :: String -> TestTree
testMinimizeConflictSet testName =
- runTest $ minimizeConflictSet $ goalOrder goals $ setVerbose $
- mkTest dbMinimizeConflictSet testName ["A"] $
- SolverResult checkFullLog (Left (== expectedMsg))
+ runTest $
+ minimizeConflictSet $
+ goalOrder goals $
+ setVerbose $
+ mkTest dbMinimizeConflictSet testName ["A"] $
+ SolverResult checkFullLog (Left (== expectedMsg))
where
checkFullLog :: [String] -> Bool
- checkFullLog = containsInOrder [
- "[__0] fail (backjumping, conflict set: A, B, C, D)"
- , "Found no solution after exhaustively searching the dependency tree. "
- ++ "Rerunning the dependency solver to minimize the conflict set ({A, B, C, D})."
- , "Trying to remove variable \"A\" from the conflict set."
- , "Failed to remove \"A\" from the conflict set. Continuing with {A, B, C, D}."
- , "Trying to remove variable \"B\" from the conflict set."
- , "Successfully removed \"B\" from the conflict set. Continuing with {A, D}."
- , "Trying to remove variable \"D\" from the conflict set."
- , "Failed to remove \"D\" from the conflict set. Continuing with {A, D}."
- ]
+ checkFullLog =
+ containsInOrder
+ [ "[__0] fail (backjumping, conflict set: A, B, C, D)"
+ , "Found no solution after exhaustively searching the dependency tree. "
+ ++ "Rerunning the dependency solver to minimize the conflict set ({A, B, C, D})."
+ , "Trying to remove variable \"A\" from the conflict set."
+ , "Failed to remove \"A\" from the conflict set. Continuing with {A, B, C, D}."
+ , "Trying to remove variable \"B\" from the conflict set."
+ , "Successfully removed \"B\" from the conflict set. Continuing with {A, D}."
+ , "Trying to remove variable \"D\" from the conflict set."
+ , "Failed to remove \"D\" from the conflict set. Continuing with {A, D}."
+ ]
expectedMsg =
- "Could not resolve dependencies:\n"
- ++ "[__0] trying: A-3.0.0 (user goal)\n"
- ++ "[__1] next goal: D (dependency of A)\n"
- ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n"
- ++ "[__1] fail (backjumping, conflict set: A, D)\n"
- ++ "After searching the rest of the dependency tree exhaustively, these "
- ++ "were the goals I've had most trouble fulfilling: A (5), D (4)"
+ "Could not resolve dependencies:\n"
+ ++ "[__0] trying: A-3.0.0 (user goal)\n"
+ ++ "[__1] next goal: D (dependency of A)\n"
+ ++ "[__1] rejecting: D-1.0.0 (conflict: A => D==2.0.0)\n"
+ ++ "[__1] fail (backjumping, conflict set: A, D)\n"
+ ++ "After searching the rest of the dependency tree exhaustively, these "
+ ++ "were the goals I've had most trouble fulfilling: A (5), D (4)"
goals :: [ExampleVar]
goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]
@@ -1827,20 +2086,22 @@ testMinimizeConflictSet testName =
-- suggest rerunning with --minimize-conflict-set.
testNoMinimizeConflictSet :: String -> TestTree
testNoMinimizeConflictSet testName =
- runTest $ goalOrder goals $ setVerbose $
- mkTest dbMinimizeConflictSet testName ["A"] $
- solverFailure (== expectedMsg)
+ runTest $
+ goalOrder goals $
+ setVerbose $
+ mkTest dbMinimizeConflictSet testName ["A"] $
+ solverFailure (== expectedMsg)
where
expectedMsg =
- "Could not resolve dependencies:\n"
- ++ "[__0] trying: A-3.0.0 (user goal)\n"
- ++ "[__1] next goal: B (dependency of A)\n"
- ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n"
- ++ "[__1] fail (backjumping, conflict set: A, B)\n"
- ++ "After searching the rest of the dependency tree exhaustively, "
- ++ "these were the goals I've had most trouble fulfilling: "
- ++ "A (7), B (2), C (2), D (2)\n"
- ++ "Try running with --minimize-conflict-set to improve the error message."
+ "Could not resolve dependencies:\n"
+ ++ "[__0] trying: A-3.0.0 (user goal)\n"
+ ++ "[__1] next goal: B (dependency of A)\n"
+ ++ "[__1] rejecting: B-1.0.0 (conflict: A => B==2.0.0)\n"
+ ++ "[__1] fail (backjumping, conflict set: A, B)\n"
+ ++ "After searching the rest of the dependency tree exhaustively, "
+ ++ "these were the goals I've had most trouble fulfilling: "
+ ++ "A (7), B (2), C (2), D (2)\n"
+ ++ "Try running with --minimize-conflict-set to improve the error message."
goals :: [ExampleVar]
goals = [P QualNone pkg | pkg <- ["A", "B", "C", "D"]]
@@ -1851,16 +2112,16 @@ testNoMinimizeConflictSet testName =
-- | Motivate conflict sets
dbBJ1a :: ExampleDb
-dbBJ1a = [
- Right $ exAv "A" 1 [ExFix "B" 1]
+dbBJ1a =
+ [ Right $ exAv "A" 1 [ExFix "B" 1]
, Right $ exAv "A" 2 [ExFix "B" 2]
, Right $ exAv "B" 1 []
]
-- | Show that we can skip some decisions
dbBJ1b :: ExampleDb
-dbBJ1b = [
- Right $ exAv "A" 1 [ExFix "B" 1]
+dbBJ1b =
+ [ Right $ exAv "A" 1 [ExFix "B" 1]
, Right $ exAv "A" 2 [ExFix "B" 2, ExAny "C"]
, Right $ exAv "B" 1 []
, Right $ exAv "C" 1 []
@@ -1869,36 +2130,36 @@ dbBJ1b = [
-- | Motivate why both A and B need to be in the conflict set
dbBJ1c :: ExampleDb
-dbBJ1c = [
- Right $ exAv "A" 1 [ExFix "B" 1]
+dbBJ1c =
+ [ Right $ exAv "A" 1 [ExFix "B" 1]
, Right $ exAv "B" 1 []
, Right $ exAv "B" 2 []
]
-- | Motivate the need for accumulating conflict sets while we walk the tree
dbBJ2 :: ExampleDb
-dbBJ2 = [
- Right $ exAv "A" 1 [ExFix "B" 1]
- , Right $ exAv "A" 2 [ExFix "B" 2]
- , Right $ exAv "B" 1 [ExFix "C" 1]
- , Right $ exAv "B" 2 [ExFix "C" 2]
- , Right $ exAv "C" 1 []
+dbBJ2 =
+ [ Right $ exAv "A" 1 [ExFix "B" 1]
+ , Right $ exAv "A" 2 [ExFix "B" 2]
+ , Right $ exAv "B" 1 [ExFix "C" 1]
+ , Right $ exAv "B" 2 [ExFix "C" 2]
+ , Right $ exAv "C" 1 []
]
-- | Motivate the need for `QGoalReason`
dbBJ3 :: ExampleDb
-dbBJ3 = [
- Right $ exAv "A" 1 [ExAny "Ba"]
- , Right $ exAv "A" 2 [ExAny "Bb"]
+dbBJ3 =
+ [ Right $ exAv "A" 1 [ExAny "Ba"]
+ , Right $ exAv "A" 2 [ExAny "Bb"]
, Right $ exAv "Ba" 1 [ExFix "C" 1]
, Right $ exAv "Bb" 1 [ExFix "C" 2]
- , Right $ exAv "C" 1 []
+ , Right $ exAv "C" 1 []
]
-- | `QGOalReason` not unique
dbBJ4 :: ExampleDb
-dbBJ4 = [
- Right $ exAv "A" 1 [ExAny "B", ExAny "C"]
+dbBJ4 =
+ [ Right $ exAv "A" 1 [ExAny "B", ExAny "C"]
, Right $ exAv "B" 1 [ExAny "C"]
, Right $ exAv "C" 1 []
]
@@ -1908,8 +2169,8 @@ dbBJ4 = [
-- This example probably won't be in the blog post itself but as a separate
-- bug report (#3409)
dbBJ5 :: ExampleDb
-dbBJ5 = [
- Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]]
+dbBJ5 =
+ [ Right $ exAv "A" 1 [exFlagged "flagA" [ExFix "B" 1] [ExFix "C" 1]]
, Right $ exAv "B" 1 [ExFix "D" 1]
, Right $ exAv "C" 1 [ExFix "D" 2]
, Right $ exAv "D" 1 []
@@ -1917,8 +2178,8 @@ dbBJ5 = [
-- | Conflict sets for cycles
dbBJ6 :: ExampleDb
-dbBJ6 = [
- Right $ exAv "A" 1 [ExAny "B"]
+dbBJ6 =
+ [ Right $ exAv "A" 1 [ExAny "B"]
, Right $ exAv "B" 1 []
, Right $ exAv "B" 2 [ExAny "C"]
, Right $ exAv "C" 1 [ExAny "A"]
@@ -1926,8 +2187,8 @@ dbBJ6 = [
-- | Conflicts not unique
dbBJ7 :: ExampleDb
-dbBJ7 = [
- Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1]
+dbBJ7 =
+ [ Right $ exAv "A" 1 [ExAny "B", ExFix "C" 1]
, Right $ exAv "B" 1 [ExFix "C" 1]
, Right $ exAv "C" 1 []
, Right $ exAv "C" 2 []
@@ -1935,8 +2196,8 @@ dbBJ7 = [
-- | Conflict sets for SIR (C shared subgoal of independent goals A, B)
dbBJ8 :: ExampleDb
-dbBJ8 = [
- Right $ exAv "A" 1 [ExAny "C"]
+dbBJ8 =
+ [ Right $ exAv "A" 1 [ExAny "C"]
, Right $ exAv "B" 1 [ExAny "C"]
, Right $ exAv "C" 1 []
]
@@ -1947,18 +2208,31 @@ dbBJ8 = [
-- | Multiple packages depending on exes from 'bt-pkg'.
dbBuildTools :: ExampleDb
-dbBuildTools = [
- Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"]
- , Right $ exAv "B" 1 [exFlagged "flagB" [ExAny "unknown"]
- [ExBuildToolAny "bt-pkg" "exe1"]]
+dbBuildTools =
+ [ Right $ exAv "A" 1 [ExBuildToolAny "bt-pkg" "exe1"]
+ , Right $
+ exAv
+ "B"
+ 1
+ [ exFlagged
+ "flagB"
+ [ExAny "unknown"]
+ [ExBuildToolAny "bt-pkg" "exe1"]
+ ]
, Right $ exAv "C" 1 [] `withTest` exTest "testC" [ExBuildToolAny "bt-pkg" "exe1"]
, Right $ exAv "D" 1 [ExBuildToolAny "bt-pkg" "unknown-exe"]
, Right $ exAv "E" 1 [ExBuildToolAny "unknown-pkg" "exe1"]
- , Right $ exAv "F" 1 [exFlagged "flagF" [ExBuildToolAny "bt-pkg" "unknown-exe"]
- [ExAny "unknown"]]
+ , Right $
+ exAv
+ "F"
+ 1
+ [ exFlagged
+ "flagF"
+ [ExBuildToolAny "bt-pkg" "unknown-exe"]
+ [ExAny "unknown"]
+ ]
, Right $ exAv "G" 1 [] `withTest` exTest "testG" [ExBuildToolAny "bt-pkg" "unknown-exe"]
, Right $ exAv "H" 1 [ExBuildToolFix "bt-pkg" "exe1" 3]
-
, Right $ exAv "bt-pkg" 4 []
, Right $ exAv "bt-pkg" 3 [] `withExe` exExe "exe2" []
, Right $ exAv "bt-pkg" 2 [] `withExe` exExe "exe1" []
@@ -1969,13 +2243,15 @@ dbBuildTools = [
-- dependency.
rejectInstalledBuildToolPackage :: String -> SolverTest
rejectInstalledBuildToolPackage name =
- mkTest db name ["A"] $ solverFailure $ isInfixOf $
- "rejecting: A:B:exe.B-1.0.0/installed-1 "
- ++ "(does not contain executable 'exe', which is required by A)"
+ mkTest db name ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: A:B:exe.B-1.0.0/installed-1 "
+ ++ "(does not contain executable 'exe', which is required by A)"
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"]
+ db =
+ [ Right $ exAv "A" 1 [ExBuildToolAny "B" "exe"]
, Left $ exInst "B" 1 "B-1" []
]
@@ -1991,26 +2267,36 @@ rejectInstalledBuildToolPackage name =
-- for B, one for exe1 and another for exe2.
chooseExeAfterBuildToolsPackage :: Bool -> String -> SolverTest
chooseExeAfterBuildToolsPackage shouldSucceed name =
- goalOrder goals $ mkTest db name ["A"] $
+ goalOrder goals $
+ mkTest db name ["A"] $
if shouldSucceed
- then solverSuccess [("A", 1), ("B", 1)]
- else solverFailure $ isInfixOf $
- "rejecting: A:+flagA (requires executable 'exe2' from A:B:exe.B, "
- ++ "but the component does not exist)"
+ then solverSuccess [("A", 1), ("B", 1)]
+ else
+ solverFailure $
+ isInfixOf $
+ "rejecting: A:+flagA (requires executable 'exe2' from A:B:exe.B, "
+ ++ "but the component does not exist)"
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ ExBuildToolAny "B" "exe1"
- , exFlagged "flagA" [ExBuildToolAny "B" "exe2"]
- [ExAny "unknown"]]
- , Right $ exAv "B" 1 []
- `withExes`
- [exExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]]
+ db =
+ [ Right $
+ exAv
+ "A"
+ 1
+ [ ExBuildToolAny "B" "exe1"
+ , exFlagged
+ "flagA"
+ [ExBuildToolAny "B" "exe2"]
+ [ExAny "unknown"]
+ ]
+ , Right $
+ exAv "B" 1 []
+ `withExes` [exExe exe [] | exe <- if shouldSucceed then ["exe1", "exe2"] else ["exe1"]]
]
goals :: [ExampleVar]
- goals = [
- P QualNone "A"
+ goals =
+ [ P QualNone "A"
, P (QualExe "A" "B") "B"
, F QualNone "A" "flagA"
]
@@ -2021,14 +2307,21 @@ chooseExeAfterBuildToolsPackage shouldSucceed name =
-- qualifier.
requireConsistentBuildToolVersions :: String -> SolverTest
requireConsistentBuildToolVersions name =
- mkTest db name ["A"] $ solverFailure $ isInfixOf $
+ mkTest db name ["A"] $
+ solverFailure $
+ isInfixOf $
"[__1] rejecting: A:B:exe.B-2.0.0 (conflict: A => A:B:exe.B (exe exe1)==1.0.0)\n"
- ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)"
+ ++ "[__1] rejecting: A:B:exe.B-1.0.0 (conflict: A => A:B:exe.B (exe exe2)==2.0.0)"
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ ExBuildToolFix "B" "exe1" 1
- , ExBuildToolFix "B" "exe2" 2 ]
+ db =
+ [ Right $
+ exAv
+ "A"
+ 1
+ [ ExBuildToolFix "B" "exe1" 1
+ , ExBuildToolFix "B" "exe2" 2
+ ]
, Right $ exAv "B" 2 [] `withExes` exes
, Right $ exAv "B" 1 [] `withExes` exes
]
@@ -2040,27 +2333,36 @@ requireConsistentBuildToolVersions name =
-- instead of missing.
chooseUnbuildableExeAfterBuildToolsPackage :: String -> SolverTest
chooseUnbuildableExeAfterBuildToolsPackage name =
- constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $
+ constraints [ExFlagConstraint (ScopeAnyQualifier "B") "build-bt2" False] $
goalOrder goals $
- mkTest db name ["A"] $ solverFailure $ isInfixOf $
- "rejecting: A:+use-bt2 (requires executable 'bt2' from A:B:exe.B, but "
- ++ "the component is not buildable in the current environment)"
+ mkTest db name ["A"] $
+ solverFailure $
+ isInfixOf $
+ "rejecting: A:+use-bt2 (requires executable 'bt2' from A:B:exe.B, but "
+ ++ "the component is not buildable in the current environment)"
where
db :: ExampleDb
- db = [
- Right $ exAv "A" 1 [ ExBuildToolAny "B" "bt1"
- , exFlagged "use-bt2" [ExBuildToolAny "B" "bt2"]
- [ExAny "unknown"]]
- , Right $ exAvNoLibrary "B" 1
- `withExes`
- [ exExe "bt1" []
- , exExe "bt2" [ExFlagged "build-bt2" (dependencies []) unbuildableDependencies]
- ]
+ db =
+ [ Right $
+ exAv
+ "A"
+ 1
+ [ ExBuildToolAny "B" "bt1"
+ , exFlagged
+ "use-bt2"
+ [ExBuildToolAny "B" "bt2"]
+ [ExAny "unknown"]
+ ]
+ , Right $
+ exAvNoLibrary "B" 1
+ `withExes` [ exExe "bt1" []
+ , exExe "bt2" [ExFlagged "build-bt2" (dependencies []) unbuildableDependencies]
+ ]
]
goals :: [ExampleVar]
- goals = [
- P QualNone "A"
+ goals =
+ [ P QualNone "A"
, P (QualExe "A" "B") "B"
, F QualNone "A" "use-bt2"
]
@@ -2069,70 +2371,70 @@ chooseUnbuildableExeAfterBuildToolsPackage name =
Databases for legacy build-tools
-------------------------------------------------------------------------------}
dbLegacyBuildTools1 :: ExampleDb
-dbLegacyBuildTools1 = [
- Right $ exAv "alex" 1 [] `withExe` exExe "alex" [],
- Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]
+dbLegacyBuildTools1 =
+ [ Right $ exAv "alex" 1 [] `withExe` exExe "alex" []
+ , Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]
]
-- Test that a recognized build tool dependency specifies the name of both the
-- package and the executable. This db has no solution.
dbLegacyBuildTools2 :: ExampleDb
-dbLegacyBuildTools2 = [
- Right $ exAv "alex" 1 [] `withExe` exExe "other-exe" [],
- Right $ exAv "other-package" 1 [] `withExe` exExe "alex" [],
- Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]
+dbLegacyBuildTools2 =
+ [ Right $ exAv "alex" 1 [] `withExe` exExe "other-exe" []
+ , Right $ exAv "other-package" 1 [] `withExe` exExe "alex" []
+ , Right $ exAv "A" 1 [ExLegacyBuildToolAny "alex"]
]
-- Test that build-tools on a random thing doesn't matter (only
-- the ones we recognize need to be in db)
dbLegacyBuildTools3 :: ExampleDb
-dbLegacyBuildTools3 = [
- Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"]
+dbLegacyBuildTools3 =
+ [ Right $ exAv "A" 1 [ExLegacyBuildToolAny "otherdude"]
]
-- Test that we can solve for different versions of executables
dbLegacyBuildTools4 :: ExampleDb
-dbLegacyBuildTools4 = [
- Right $ exAv "alex" 1 [] `withExe` exExe "alex" [],
- Right $ exAv "alex" 2 [] `withExe` exExe "alex" [],
- Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1],
- Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2],
- Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
+dbLegacyBuildTools4 =
+ [ Right $ exAv "alex" 1 [] `withExe` exExe "alex" []
+ , Right $ exAv "alex" 2 [] `withExe` exExe "alex" []
+ , Right $ exAv "A" 1 [ExLegacyBuildToolFix "alex" 1]
+ , Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 2]
+ , Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
]
-- Test that exe is not related to library choices
dbLegacyBuildTools5 :: ExampleDb
-dbLegacyBuildTools5 = [
- Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` exExe "alex" [],
- Right $ exAv "A" 1 [],
- Right $ exAv "A" 2 [],
- Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2]
+dbLegacyBuildTools5 =
+ [ Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` exExe "alex" []
+ , Right $ exAv "A" 1 []
+ , Right $ exAv "A" 2 []
+ , Right $ exAv "B" 1 [ExLegacyBuildToolFix "alex" 1, ExFix "A" 2]
]
-- Test that build-tools on build-tools works
dbLegacyBuildTools6 :: ExampleDb
-dbLegacyBuildTools6 = [
- Right $ exAv "alex" 1 [] `withExe` exExe "alex" [],
- Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` exExe "happy" [],
- Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"]
+dbLegacyBuildTools6 =
+ [ Right $ exAv "alex" 1 [] `withExe` exExe "alex" []
+ , Right $ exAv "happy" 1 [ExLegacyBuildToolAny "alex"] `withExe` exExe "happy" []
+ , Right $ exAv "A" 1 [ExLegacyBuildToolAny "happy"]
]
-- Test that build-depends on library/executable package works.
-- Extracted from https://github.com/haskell/cabal/issues/3775
dbIssue3775 :: ExampleDb
-dbIssue3775 = [
- Right $ exAv "warp" 1 [],
- -- NB: the warp build-depends refers to the package, not the internal
+dbIssue3775 =
+ [ Right $ exAv "warp" 1 []
+ , -- NB: the warp build-depends refers to the package, not the internal
-- executable!
- Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` exExe "warp" [ExAny "A"],
- Right $ exAv "B" 2 [ExAny "A", ExAny "warp"]
+ Right $ exAv "A" 2 [ExFix "warp" 1] `withExe` exExe "warp" [ExAny "A"]
+ , Right $ exAv "B" 2 [ExAny "A", ExAny "warp"]
]
-- | Returns true if the second list contains all elements of the first list, in
-- order.
containsInOrder :: Eq a => [a] -> [a] -> Bool
-containsInOrder [] _ = True
-containsInOrder _ [] = False
-containsInOrder (x:xs) (y:ys)
+containsInOrder [] _ = True
+containsInOrder _ [] = False
+containsInOrder (x : xs) (y : ys)
| x == y = containsInOrder xs ys
- | otherwise = containsInOrder (x:xs) ys
+ | otherwise = containsInOrder (x : xs) ys
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs
index 9c4f60b2f7b1955b828e90d2ce8f3904f259e860..5cab4f1bdd810b51526fc700a14aa3306b91dc95 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/WeightedPSQ.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE ParallelListComp #-}
-module UnitTests.Distribution.Solver.Modular.WeightedPSQ (
- tests
+
+module UnitTests.Distribution.Solver.Modular.WeightedPSQ
+ ( tests
) where
import qualified Distribution.Solver.Modular.WeightedPSQ as W
@@ -9,44 +10,43 @@ import Data.List (sort)
import Test.Tasty (TestTree)
import Test.Tasty.HUnit (testCase, (@?=))
-import Test.Tasty.QuickCheck (Blind(..), testProperty)
+import Test.Tasty.QuickCheck (Blind (..), testProperty)
tests :: [TestTree]
-tests = [
- testProperty "'toList . fromList' preserves elements" $ \xs ->
- sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs))
-
+tests =
+ [ testProperty "'toList . fromList' preserves elements" $ \xs ->
+ sort (xs :: [(Int, Char, Bool)]) == sort (W.toList (W.fromList xs))
, testProperty "'toList . fromList' sorts stably" $ \xs ->
- let indexAsValue :: [(Int, (), Int)]
- indexAsValue = [(x, (), i) | x <- xs | i <- [0..]]
- in isSorted $ W.toList $ W.fromList indexAsValue
-
+ let indexAsValue :: [(Int, (), Int)]
+ indexAsValue = [(x, (), i) | x <- xs | i <- [0 ..]]
+ in isSorted $ W.toList $ W.fromList indexAsValue
, testProperty "'mapWeightsWithKey' sorts by weight" $ \xs (Blind f) ->
- isSorted $ W.weights $
- W.mapWeightsWithKey (f :: Int -> Int -> Int) $
- W.fromList (xs :: [(Int, Int, Int)])
-
+ isSorted $
+ W.weights $
+ W.mapWeightsWithKey (f :: Int -> Int -> Int) $
+ W.fromList (xs :: [(Int, Int, Int)])
, testCase "applying 'mapWeightsWithKey' twice sorts twice" $
- let indexAsKey :: [((), Int, ())]
- indexAsKey = [((), i, ()) | i <- [0..10]]
- actual = W.toList $
- W.mapWeightsWithKey (\_ _ -> ()) $
- W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored
- W.fromList indexAsKey
- in reverse indexAsKey @?= actual
-
+ let indexAsKey :: [((), Int, ())]
+ indexAsKey = [((), i, ()) | i <- [0 .. 10]]
+ actual =
+ W.toList $
+ W.mapWeightsWithKey (\_ _ -> ()) $
+ W.mapWeightsWithKey (\i _ -> -i) $ -- should not be ignored
+ W.fromList indexAsKey
+ in reverse indexAsKey @?= actual
, testProperty "'union' sorts by weight" $ \xs ys ->
- isSorted $ W.weights $
- W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)]))
-
+ isSorted $
+ W.weights $
+ W.union (W.fromList xs) (W.fromList (ys :: [(Int, Int, Int)]))
, testProperty "'union' preserves elements" $ \xs ys ->
- let union = W.union (W.fromList xs)
- (W.fromList (ys :: [(Int, Int, Int)]))
- in sort (xs ++ ys) == sort (W.toList union)
-
+ let union =
+ W.union
+ (W.fromList xs)
+ (W.fromList (ys :: [(Int, Int, Int)]))
+ in sort (xs ++ ys) == sort (W.toList union)
, testCase "'lookup' returns first occurrence" $
- let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')]
- in Just 'C' @?= W.lookup True xs
+ let xs = W.fromList [((), False, 'A'), ((), True, 'C'), ((), True, 'B')]
+ in Just 'C' @?= W.lookup True xs
]
isSorted :: Ord a => [a] -> Bool
diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs
index 96679e60011128cb3af4835f2a12eb7bcd730c27..8f068d2ae5361e63fc363641cf1043b0f0b1a7d4 100644
--- a/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs
+++ b/cabal-install/tests/UnitTests/Distribution/Solver/Types/OptionalStanza.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE CPP #-}
-module UnitTests.Distribution.Solver.Types.OptionalStanza (
- tests,
-) where
+
+module UnitTests.Distribution.Solver.Types.OptionalStanza
+ ( tests
+ ) where
import Distribution.Solver.Types.OptionalStanza
import UnitTests.Distribution.Client.ArbitraryInstances ()
@@ -15,19 +16,18 @@ import Data.Monoid
tests :: [TestTree]
tests =
- [ testProperty "fromList . toList = id" $ \xs ->
- optStanzaSetFromList (optStanzaSetToList xs) === xs
- , testProperty "member x (insert x xs) = True" $ \x xs ->
- optStanzaSetMember x (optStanzaSetInsert x xs) === True
- , testProperty "member x (singleton y) = (x == y)" $ \x y ->
- optStanzaSetMember x (optStanzaSetSingleton y) === (x == y)
- , testProperty "(subset xs ys, member x xs) ==> member x ys" $ \x xs ys ->
- optStanzaSetIsSubset xs ys && optStanzaSetMember x xs ==>
+ [ testProperty "fromList . toList = id" $ \xs ->
+ optStanzaSetFromList (optStanzaSetToList xs) === xs
+ , testProperty "member x (insert x xs) = True" $ \x xs ->
+ optStanzaSetMember x (optStanzaSetInsert x xs) === True
+ , testProperty "member x (singleton y) = (x == y)" $ \x y ->
+ optStanzaSetMember x (optStanzaSetSingleton y) === (x == y)
+ , testProperty "(subset xs ys, member x xs) ==> member x ys" $ \x xs ys ->
+ optStanzaSetIsSubset xs ys && optStanzaSetMember x xs ==>
optStanzaSetMember x ys
-
- , testProperty "tabulate index = id" $ \xs ->
- optStanzaTabulate (optStanzaIndex xs) === (xs :: OptionalStanzaMap Int)
- , testProperty "keysFilteredByValue" $ \xs ->
- let set i = if optStanzaIndex xs i then optStanzaSetSingleton i else mempty
- in optStanzaKeysFilteredByValue id xs === set TestStanzas `mappend` set BenchStanzas
- ]
+ , testProperty "tabulate index = id" $ \xs ->
+ optStanzaTabulate (optStanzaIndex xs) === (xs :: OptionalStanzaMap Int)
+ , testProperty "keysFilteredByValue" $ \xs ->
+ let set i = if optStanzaIndex xs i then optStanzaSetSingleton i else mempty
+ in optStanzaKeysFilteredByValue id xs === set TestStanzas `mappend` set BenchStanzas
+ ]
diff --git a/cabal-install/tests/UnitTests/Options.hs b/cabal-install/tests/UnitTests/Options.hs
index 1edce0355426a1ade192b42466eabcfcc5bbb5d2..232f80a271147cbeab56580a3ca96c788e2e38aa 100644
--- a/cabal-install/tests/UnitTests/Options.hs
+++ b/cabal-install/tests/UnitTests/Options.hs
@@ -1,10 +1,12 @@
{-# LANGUAGE DeriveDataTypeable #-}
-module UnitTests.Options ( OptionShowSolverLog(..)
- , OptionMtimeChangeDelay(..)
- , RunNetworkTests(..)
- , extraOptions )
- where
+module UnitTests.Options
+ ( OptionShowSolverLog (..)
+ , OptionMtimeChangeDelay (..)
+ , RunNetworkTests (..)
+ , extraOptions
+ )
+where
import Data.Proxy
import Data.Typeable
@@ -23,30 +25,32 @@ extraOptions =
]
newtype OptionShowSolverLog = OptionShowSolverLog Bool
- deriving Typeable
+ deriving (Typeable)
instance IsOption OptionShowSolverLog where
- defaultValue = OptionShowSolverLog False
- parseValue = fmap OptionShowSolverLog . safeReadBool
- optionName = return "show-solver-log"
- optionHelp = return "Show full log from the solver"
+ defaultValue = OptionShowSolverLog False
+ parseValue = fmap OptionShowSolverLog . safeReadBool
+ optionName = return "show-solver-log"
+ optionHelp = return "Show full log from the solver"
optionCLParser = flagCLParser Nothing (OptionShowSolverLog True)
newtype OptionMtimeChangeDelay = OptionMtimeChangeDelay Int
- deriving Typeable
+ deriving (Typeable)
instance IsOption OptionMtimeChangeDelay where
- defaultValue = OptionMtimeChangeDelay 0
- parseValue = fmap OptionMtimeChangeDelay . safeRead
- optionName = return "mtime-change-delay"
- optionHelp = return $ "How long to wait before attempting to detect"
- ++ "file modification, in microseconds"
+ defaultValue = OptionMtimeChangeDelay 0
+ parseValue = fmap OptionMtimeChangeDelay . safeRead
+ optionName = return "mtime-change-delay"
+ optionHelp =
+ return $
+ "How long to wait before attempting to detect"
+ ++ "file modification, in microseconds"
newtype RunNetworkTests = RunNetworkTests Bool
- deriving Typeable
+ deriving (Typeable)
instance IsOption RunNetworkTests where
defaultValue = RunNetworkTests True
- parseValue = fmap RunNetworkTests . safeReadBool
- optionName = return "run-network-tests"
- optionHelp = return "Run tests that need network access (default true)."
+ parseValue = fmap RunNetworkTests . safeReadBool
+ optionName = return "run-network-tests"
+ optionHelp = return "Run tests that need network access (default true)."
diff --git a/cabal-install/tests/UnitTests/TempTestDir.hs b/cabal-install/tests/UnitTests/TempTestDir.hs
index 77db49bd7aa7c17ce2c1610f9d6149fa61b2cae6..5a9d410e53a936f1e103218bca2b3bee3cdfddba 100644
--- a/cabal-install/tests/UnitTests/TempTestDir.hs
+++ b/cabal-install/tests/UnitTests/TempTestDir.hs
@@ -1,36 +1,34 @@
{-# LANGUAGE CPP #-}
-module UnitTests.TempTestDir (
- withTestDir, removeDirectoryRecursiveHack
+module UnitTests.TempTestDir
+ ( withTestDir
+ , removeDirectoryRecursiveHack
) where
-import Distribution.Verbosity
import Distribution.Compat.Internal.TempFile (createTempDirectory)
import Distribution.Simple.Utils (warn)
+import Distribution.Verbosity
-import Control.Monad (when)
-import Control.Exception (bracket, try, throwIO)
import Control.Concurrent (threadDelay)
+import Control.Exception (bracket, throwIO, try)
+import Control.Monad (when)
-import System.IO.Error
import System.Directory
+import System.IO.Error
#if !(MIN_VERSION_directory(1,2,7))
import System.FilePath ((</>))
#endif
import qualified System.Info (os)
-
-- | Much like 'withTemporaryDirectory' but with a number of hacks to make
-- sure on windows that we can clean up the directory at the end.
---
-withTestDir :: Verbosity -> String -> (FilePath -> IO a) -> IO a
+withTestDir :: Verbosity -> String -> (FilePath -> IO a) -> IO a
withTestDir verbosity template action = do
- systmpdir <- getTemporaryDirectory
- bracket
- (createTempDirectory systmpdir template)
- (removeDirectoryRecursiveHack verbosity)
- action
-
+ systmpdir <- getTemporaryDirectory
+ bracket
+ (createTempDirectory systmpdir template)
+ (removeDirectoryRecursiveHack verbosity)
+ action
-- | On Windows, file locks held by programs we run (in this case VCSs)
-- are not always released prior to completing process termination!
@@ -42,40 +40,42 @@ withTestDir verbosity template action = do
-- In addition, on Windows a file that is not writable also cannot be deleted,
-- so we must try setting the permissions to readable before deleting files.
-- Some VCS tools on Windows create files with read-only attributes.
---
removeDirectoryRecursiveHack :: Verbosity -> FilePath -> IO ()
removeDirectoryRecursiveHack verbosity dir | isWindows = go 1
where
isWindows = System.Info.os == "mingw32"
- limit = 3
+ limit = 3
go :: Int -> IO ()
go n = do
res <- try $ removePathForcibly dir
case res of
Left e
- -- wait a second and try again
- | isPermissionError e && n < limit -> do
+ -- wait a second and try again
+ | isPermissionError e && n < limit -> do
threadDelay 1000000
- go (n+1)
+ go (n + 1)
- -- but if we hit the limt warn and fail.
+ -- but if we hit the limt warn and fail.
| isPermissionError e -> do
- warn verbosity $ "Windows file locking hack: hit the retry limit "
- ++ show limit ++ " while trying to remove " ++ dir
+ warn verbosity $
+ "Windows file locking hack: hit the retry limit "
+ ++ show limit
+ ++ " while trying to remove "
+ ++ dir
throwIO e
- -- or it's a different error fail.
+ -- or it's a different error fail.
| otherwise -> throwIO e
-
Right () ->
when (n > 1) $
- warn verbosity $ "Windows file locking hack: had to try "
- ++ show n ++ " times to remove " ++ dir
-
+ warn verbosity $
+ "Windows file locking hack: had to try "
+ ++ show n
+ ++ " times to remove "
+ ++ dir
removeDirectoryRecursiveHack _ dir = removeDirectoryRecursive dir
-
#if !(MIN_VERSION_directory(1,2,7))
-- A simplified version that ought to work for our use case here, and does
-- not rely on directory internals.
@@ -101,4 +101,3 @@ removePathForcibly path = do
writable = True
}
#endif
-