Commit 1017f710 authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Replace the module renaming/thinning system

We had an old implementation of 'ModuleRenaming', with the
assumption that it would be used directly in build-depends; since
we have dropped this assumption, we can refactor 'ModuleRenaming'
and we do so.  The main idea is to make the data type more directly
reflect the syntax you can specify in a Cabal file; so the default
renaming and an explicit thinning renaming are now different
constructors.  It's no longer possible to use the "with" syntax, but
it's not necessary either, since we have a special backpack-includes
field to specify renamings, so we don't need them to be Monoidal.

There is also a new syntax for 'hiding', which just lets you hide
some modules when including a package. Handy!

Previously, we recorded 'ModuleRenaming' in @build-depends@, but
separated it out when we stored in 'BuildInfo'.  We now go even
further, by changing it from a 'Map' (the only thing @build-depends@
could support) to a list (so that a package name can be specified
multiple times.)  This is good because now a user can instantiate
something several times, which is useful in Backpack.

Also add the new field @backpack-includes@ which can be used to exert
fine-grained control over what modules a package brings into scope,
include it multiple times, etc.

In the .cabal checks, replace 'depsUsingThinningRenamingSyntax' with a
more direct check to see if @backpack-includes@ was used.

Dropped the legacy 'lookupRenaming' export from ModuleRenaming and
PackageDescription; we will shortly not use it anymore. As an
intermediate hack we have a local definition in Configure, but this
will go away shortly.
parent 8d31f43b
......@@ -401,6 +401,7 @@ library
Distribution.Types.Library
Distribution.Types.ModuleReexport
Distribution.Types.ModuleRenaming
Distribution.Types.IncludeRenaming
Distribution.Types.SetupBuildInfo
Distribution.Types.TestSuite
Distribution.Types.TestSuiteInterface
......
......@@ -23,10 +23,9 @@ module Distribution.PackageDescription (
knownBuildTypes,
allLibraries,
-- ** Renaming
-- ** Renaming (syntactic)
ModuleRenaming(..),
defaultRenaming,
lookupRenaming,
-- ** Libraries
Library(..),
......
......@@ -1007,13 +1007,10 @@ checkCabalVersion pkg =
++ "at least 'cabal-version: >= 1.21'."
-- check use of thinning and renaming
, checkVersion [1,21] (not (null depsUsingThinningRenamingSyntax)) $
, checkVersion [1,25] usesBackpackIncludes $
PackageDistInexcusable $
"The package uses "
++ "thinning and renaming in the 'build-depends' field: "
++ commaSep (map display depsUsingThinningRenamingSyntax)
++ ". To use this new syntax, the package needs to specify at least"
++ "'cabal-version: >= 1.21'."
"To use the 'backpack-includes' field the package needs to specify "
++ "at least 'cabal-version: >= 1.25'."
-- check use of 'extra-framework-dirs' field
, checkVersion [1,23] (any (not . null) (buildInfoField extraFrameworkDirs)) $
......@@ -1242,13 +1239,7 @@ checkCabalVersion pkg =
depsUsingMajorBoundSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
, usesMajorBoundSyntax vr ]
-- TODO: If the user writes build-depends: foo with (), this is
-- indistinguishable from build-depends: foo, so there won't be an
-- error even though there should be
depsUsingThinningRenamingSyntax =
[ name
| bi <- allBuildInfo pkg
, (name, _) <- Map.toList (targetBuildRenaming bi) ]
usesBackpackIncludes = any (not . null . backpackIncludes) (allBuildInfo pkg)
testedWithUsingWildcardSyntax =
[ Dependency (mkPackageName (display compiler)) vr
......
......@@ -48,6 +48,7 @@ module Distribution.PackageDescription.Parse (
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.IncludeRenaming
import Distribution.ParseUtils hiding (parseFields)
import Distribution.PackageDescription
import Distribution.PackageDescription.Utils
......@@ -67,7 +68,7 @@ import Control.Monad (mapM)
import Text.PrettyPrint
(vcat, ($$), (<+>), text, render,
comma, fsep, nest, ($+$), punctuate)
comma, fsep, nest, ($+$), punctuate, Doc)
-- -----------------------------------------------------------------------------
......@@ -371,6 +372,16 @@ validateBenchmark line stanza =
-- ---------------------------------------------------------------------------
-- The BuildInfo type
showBackpackInclude :: (PackageName, IncludeRenaming) -> Doc
showBackpackInclude (pkg_name, incl) = do
disp pkg_name <+> disp incl
parseBackpackInclude :: ReadP r (PackageName, IncludeRenaming)
parseBackpackInclude = do
pkg_name <- parse
skipSpaces
incl <- parse
return (pkg_name, incl)
binfoFieldDescrs :: [FieldDescr BuildInfo]
binfoFieldDescrs =
......@@ -382,6 +393,9 @@ binfoFieldDescrs =
, commaListFieldWithSep vcat "build-depends"
disp parse
targetBuildDepends (\xs binfo -> binfo{targetBuildDepends=xs})
, commaListFieldWithSep vcat "backpack-includes"
showBackpackInclude parseBackpackInclude
backpackIncludes (\xs binfo -> binfo{backpackIncludes=xs})
, spaceListField "cpp-options"
showToken parseTokenQ'
cppOptions (\val binfo -> binfo{cppOptions=val})
......
......@@ -67,7 +67,6 @@ import Distribution.Verbosity
import Distribution.Compat.Graph (IsNode(..))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.List ( intersect )
import System.FilePath ( (</>), (<.>) )
......@@ -454,8 +453,7 @@ testSuiteLibV09AsLibAndExe pkg_descr
buildInfo = (testBuildInfo test) {
hsSourceDirs = [ testDir ],
targetBuildDepends = testLibDep
: (targetBuildDepends $ testBuildInfo test),
targetBuildRenaming = Map.empty
: (targetBuildDepends $ testBuildInfo test)
}
}
-- | The stub executable needs a new 'ComponentLocalBuildInfo'
......
......@@ -62,6 +62,7 @@ import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compiler
import Distribution.Types.IncludeRenaming
import Distribution.Utils.NubList
import Distribution.Simple.Compiler hiding (Flag)
import Distribution.Simple.PreProcess
......@@ -1000,9 +1001,8 @@ configureFinalizedPackage verbosity cfg enabled
checkCompilerProblems :: Compiler -> PackageDescription -> ComponentRequestedSpec -> IO ()
checkCompilerProblems comp pkg_descr enabled = do
unless (renamingPackageFlagsSupported comp ||
and [ True
| bi <- enabledBuildInfos pkg_descr enabled
, _ <- Map.elems (targetBuildRenaming bi)]) $
all (all (isDefaultIncludeRenaming . snd) . backpackIncludes)
(enabledBuildInfos pkg_descr enabled)) $
die $ "Your compiler does not support thinning and renaming on "
++ "package flags. To use this feature you probably must use "
++ "GHC 7.9 or later."
......@@ -1933,9 +1933,14 @@ mkComponentsLocalBuildInfo cfg use_external_internal comp installedPackages
| pkgid <- selectSubset bi internalPkgDeps ]
else [ (Installed.installedUnitId pkg, packageId pkg)
| pkg <- externalPkgDeps ]
includes = map (\(i,p) -> (i,lookupRenaming p cprns)) cpds
-- TODO: this is an intermediate stage in introducing backpack
-- so this is a bit of a hack. It will be completely replaced.
includes = map (\(i,p) -> (i,lookupRenaming p)) cpds
lookupRenaming p = case Map.lookup (packageName p) cprns of
Nothing -> defaultRenaming
Just rns -> includeProvidesRn rns
cprns = if newPackageDepsBehaviour pkg_descr
then targetBuildRenaming bi
then Map.fromList (backpackIncludes bi)
else Map.empty
dedup = Map.toList . Map.fromList
......
......@@ -17,15 +17,13 @@ module Distribution.Types.BuildInfo (
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.ModuleRenaming
import Distribution.Types.IncludeRenaming
import Distribution.Package
import Distribution.ModuleName
import Distribution.Compiler
import Language.Haskell.Extension
import qualified Data.Map as Map
-- Consider refactoring into executable and library versions.
data BuildInfo = BuildInfo {
buildable :: Bool, -- ^ component is buildable here
......@@ -61,7 +59,7 @@ data BuildInfo = BuildInfo {
-- with x-, stored in a
-- simple assoc-list.
targetBuildDepends :: [Dependency], -- ^ Dependencies specific to a library or executable target
targetBuildRenaming :: Map PackageName ModuleRenaming
backpackIncludes :: [(PackageName, IncludeRenaming)]
}
deriving (Generic, Show, Read, Eq, Typeable, Data)
......@@ -98,7 +96,7 @@ instance Monoid BuildInfo where
sharedOptions = [],
customFieldsBI = [],
targetBuildDepends = [],
targetBuildRenaming = Map.empty
backpackIncludes = []
}
mappend = (<>)
......@@ -133,13 +131,12 @@ instance Semigroup BuildInfo where
sharedOptions = combine sharedOptions,
customFieldsBI = combine customFieldsBI,
targetBuildDepends = combineNub targetBuildDepends,
targetBuildRenaming = combineMap targetBuildRenaming
backpackIncludes = combine backpackIncludes
}
where
combine field = field a `mappend` field b
combineNub field = nub (combine field)
combineMby field = field b `mplus` field a
combineMap field = Map.unionWith mappend (field a) (field b)
emptyBuildInfo :: BuildInfo
emptyBuildInfo = mempty
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Types.IncludeRenaming (
IncludeRenaming(..),
defaultIncludeRenaming,
isDefaultIncludeRenaming,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.ModuleRenaming
import Distribution.Text
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<+>), text)
import Distribution.Compat.ReadP
-- ---------------------------------------------------------------------------
-- 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)
instance Binary IncludeRenaming
-- | The 'defaultIncludeRenaming' applied when you only @build-depends@
-- on a package.
defaultIncludeRenaming :: IncludeRenaming
defaultIncludeRenaming = IncludeRenaming defaultRenaming defaultRenaming
-- | Is an 'IncludeRenaming' the default one?
isDefaultIncludeRenaming :: IncludeRenaming -> Bool
isDefaultIncludeRenaming (IncludeRenaming p r) = isDefaultRenaming p && isDefaultRenaming r
instance Text IncludeRenaming where
disp (IncludeRenaming prov_rn req_rn) =
disp prov_rn
<+> (if isDefaultRenaming req_rn
then Disp.empty
else text "requires" <+> disp req_rn)
parse = do
prov_rn <- parse
req_rn <- (string "requires" >> skipSpaces >> parse) <++ return defaultRenaming
-- 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)
......@@ -4,70 +4,78 @@
module Distribution.Types.ModuleRenaming (
ModuleRenaming(..),
defaultRenaming,
lookupRenaming,
isDefaultRenaming,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Prelude hiding (empty)
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP ((<++))
import Distribution.Package
import Distribution.ModuleName
import Distribution.Text
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<+>), text)
import qualified Data.Map as Map
-- ---------------------------------------------------------------------------
-- Module renaming
import Text.PrettyPrint
-- | Renaming applied to the modules provided by a package.
-- The boolean indicates whether or not to also include all of the
-- original names of modules. Thus, @ModuleRenaming False []@ is
-- "don't expose any modules, and @ModuleRenaming True [("Data.Bool", "Bool")]@
-- is, "expose all modules, but also expose @Data.Bool@ as @Bool@".
-- 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 = ModuleRenaming Bool [(ModuleName, ModuleName)]
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)
-- | The default renaming, if something is specified in @build-depends@
-- only.
defaultRenaming :: ModuleRenaming
defaultRenaming = ModuleRenaming True []
defaultRenaming = DefaultRenaming
lookupRenaming :: Package pkg => pkg -> Map PackageName ModuleRenaming -> ModuleRenaming
lookupRenaming = Map.findWithDefault defaultRenaming . packageName
-- | Tests if its the default renaming; we can use a more compact syntax
-- in 'Distribution.Types.IncludeRenaming.IncludeRenaming' in this case.
isDefaultRenaming :: ModuleRenaming -> Bool
isDefaultRenaming DefaultRenaming = True
isDefaultRenaming _ = False
instance Binary ModuleRenaming where
instance Monoid ModuleRenaming where
mempty = ModuleRenaming False []
mappend = (<>)
instance Semigroup ModuleRenaming where
ModuleRenaming b rns <> ModuleRenaming b' rns'
= ModuleRenaming (b || b') (rns ++ rns') -- TODO: dedupe?
-- NB: parentheses are mandatory, because later we may extend this syntax
-- to allow "hiding (A, B)" or other modifier words.
instance Text ModuleRenaming where
disp (ModuleRenaming True []) = Disp.empty
disp (ModuleRenaming b vs) = (if b then text "with" else Disp.empty) <+> dispRns
where dispRns = Disp.parens
(Disp.hsep
(Disp.punctuate Disp.comma (map dispEntry vs)))
dispEntry (orig, new)
disp DefaultRenaming = empty
disp (HidingRenaming hides)
= text "hiding" <+> parens (hsep (punctuate comma (map disp hides)))
disp (ModuleRenaming rns)
= parens . hsep $ punctuate comma (map dispEntry rns)
where dispEntry (orig, new)
| orig == new = disp orig
| otherwise = disp orig <+> text "as" <+> disp new
parse = do Parse.string "with" >> Parse.skipSpaces
fmap (ModuleRenaming True) parseRns
<++ fmap (ModuleRenaming False) parseRns
<++ return (ModuleRenaming True [])
parse = do fmap ModuleRenaming parseRns
<++ parseHidingRenaming
<++ return DefaultRenaming
where parseRns = do
rns <- Parse.between (Parse.char '(') (Parse.char ')') parseList
Parse.skipSpaces
return rns
parseHidingRenaming = do
_ <- Parse.string "hiding"
Parse.skipSpaces
hides <- Parse.between (Parse.char '(') (Parse.char ')')
(Parse.sepBy parse (Parse.char ',' >> Parse.skipSpaces))
return (HidingRenaming hides)
parseList =
Parse.sepBy parseEntry (Parse.char ',' >> Parse.skipSpaces)
parseEntry :: Parse.ReadP r (ModuleName, ModuleName)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment