diff --git a/Cabal/Cabal.cabal b/Cabal/Cabal.cabal index dde37864127..04a46b080f7 100644 --- a/Cabal/Cabal.cabal +++ b/Cabal/Cabal.cabal @@ -447,6 +447,8 @@ library Distribution.Types.MungedPackageId Distribution.Types.PackageId Distribution.Types.UnitId + Distribution.Types.CommonStanza + Distribution.Types.CommonStanzaImports Distribution.Types.Executable Distribution.Types.ExecutableScope Distribution.Types.Library @@ -474,6 +476,7 @@ library Distribution.Types.TestSuiteInterface Distribution.Types.TestType Distribution.Types.GenericPackageDescription + Distribution.Types.PackageSourceDescription Distribution.Types.Condition Distribution.Types.CondTree Distribution.Types.HookedBuildInfo @@ -520,6 +523,8 @@ library Distribution.FieldGrammar.Parsec Distribution.FieldGrammar.Pretty Distribution.PackageDescription.FieldGrammar + Distribution.PackageDescription.PackageSourceDescriptionParser + Distribution.PackageDescription.PackageSourceDescriptionPrettyPrint Distribution.PackageDescription.Parsec Distribution.PackageDescription.Quirks Distribution.Parsec @@ -543,9 +548,12 @@ library Distribution.Types.Lens Distribution.Types.Benchmark.Lens Distribution.Types.BuildInfo.Lens + Distribution.Types.CommonStanza.Lens + Distribution.Types.CommonStanzaImports.Lens Distribution.Types.Executable.Lens Distribution.Types.ForeignLib.Lens Distribution.Types.GenericPackageDescription.Lens + Distribution.Types.PackageSourceDescription.Lens Distribution.Types.InstalledPackageInfo.Lens Distribution.Types.Library.Lens Distribution.Types.PackageDescription.Lens diff --git a/Cabal/Distribution/PackageDescription/FieldGrammar.hs b/Cabal/Distribution/PackageDescription/FieldGrammar.hs index 2c6e8b4d121..45bec74f706 100644 --- a/Cabal/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal/Distribution/PackageDescription/FieldGrammar.hs @@ -3,6 +3,8 @@ module Distribution.PackageDescription.FieldGrammar ( -- * Package description packageDescriptionFieldGrammar, + -- * Common Stanza + commonStanzaFieldGrammar, -- * Library libraryFieldGrammar, -- * Foreign library @@ -53,6 +55,8 @@ import Distribution.Parsec import Distribution.Parsec.Newtypes import Distribution.Fields import Distribution.Pretty (prettyShow) +import Distribution.Types.CommonStanza +import Distribution.Types.CommonStanzaImports (CommonStanzaImports, emptyCommonStanzaImports) import Distribution.Types.ExecutableScope import Distribution.Types.ForeignLib import Distribution.Types.ForeignLibType @@ -117,6 +121,20 @@ packageDescriptionFieldGrammar = PackageDescription <*> monoidalFieldAla "license-files" (alaList' FSep FilePathNT) L.licenseFiles ^^^ hiddenField +------------------------------------------------------------------------------- +-- Common Stanza +------------------------------------------------------------------------------- + +commonStanzaFieldGrammar + :: (FieldGrammar g, Applicative (g CommonStanza), Applicative (g BuildInfo)) + => UnqualComponentName -> g CommonStanza CommonStanza +commonStanzaFieldGrammar n = CommonStanza n + <$> optionalFieldDef "import" L.commonStanzaRecursiveImports emptyCommonStanzaImports + <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar +{-# SPECIALIZE commonStanzaFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' CommonStanza #-} +{-# SPECIALIZE commonStanzaFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' CommonStanza #-} + + ------------------------------------------------------------------------------- -- Library ------------------------------------------------------------------------------- @@ -126,7 +144,8 @@ libraryFieldGrammar => LibraryName -> g Library Library libraryFieldGrammar n = Library n - <$> monoidalFieldAla "exposed-modules" (alaList' VCat MQuoted) L.exposedModules + <$> optionalFieldDef "import" L.libImports emptyCommonStanzaImports + <*> monoidalFieldAla "exposed-modules" (alaList' VCat MQuoted) L.exposedModules <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures ^^^ availableSince CabalSpecV2_0 [] @@ -153,7 +172,8 @@ foreignLibFieldGrammar :: (FieldGrammar g, Applicative (g ForeignLib), Applicative (g BuildInfo)) => UnqualComponentName -> g ForeignLib ForeignLib foreignLibFieldGrammar n = ForeignLib n - <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown + <$> optionalFieldDef "import" L.foreignLibImports emptyCommonStanzaImports + <*> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar <*> optionalField "lib-version-info" L.foreignLibVersionInfo @@ -171,7 +191,8 @@ executableFieldGrammar => 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 "import" L.exeImports emptyCommonStanzaImports + <*> optionalFieldDefAla "main-is" FilePathNT L.modulePath "" <*> optionalFieldDef "scope" L.exeScope ExecutablePublic ^^^ availableSince CabalSpecV2_0 ExecutablePublic <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar @@ -185,15 +206,23 @@ 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 + { _testStanzaImports :: CommonStanzaImports + , _testStanzaTestType :: Maybe TestType , _testStanzaMainIs :: Maybe FilePath , _testStanzaTestModule :: Maybe ModuleName , _testStanzaBuildInfo :: BuildInfo } +instance L.HasCommonStanzaImports TestSuiteStanza where + commonStanzaImports = testStanzaImports + instance L.HasBuildInfo TestSuiteStanza where buildInfo = testStanzaBuildInfo +testStanzaImports :: Lens' TestSuiteStanza CommonStanzaImports +testStanzaImports f s = fmap (\x -> s { _testStanzaImports = x }) (f (_testStanzaImports s)) +{-# INLINE testStanzaImports #-} + testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) {-# INLINE testStanzaTestType #-} @@ -214,7 +243,8 @@ testSuiteFieldGrammar :: (FieldGrammar g, Applicative (g TestSuiteStanza), Applicative (g BuildInfo)) => g TestSuiteStanza TestSuiteStanza testSuiteFieldGrammar = TestSuiteStanza - <$> optionalField "type" testStanzaTestType + <$> optionalFieldDef "import" testStanzaImports emptyCommonStanzaImports + <*> optionalField "type" testStanzaTestType <*> optionalFieldAla "main-is" FilePathNT testStanzaMainIs <*> optionalField "test-module" testStanzaTestModule <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar @@ -269,7 +299,8 @@ validateTestSuite pos stanza = case _testStanzaTestType stanza of unvalidateTestSuite :: TestSuite -> TestSuiteStanza unvalidateTestSuite t = TestSuiteStanza - { _testStanzaTestType = ty + { _testStanzaImports = view L.testImports t + , _testStanzaTestType = ty , _testStanzaMainIs = ma , _testStanzaTestModule = mo , _testStanzaBuildInfo = testBuildInfo t @@ -287,15 +318,23 @@ 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 + { _benchmarkStanzaImports :: CommonStanzaImports + , _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType , _benchmarkStanzaMainIs :: Maybe FilePath , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName , _benchmarkStanzaBuildInfo :: BuildInfo } +instance L.HasCommonStanzaImports BenchmarkStanza where + commonStanzaImports = benchmarkStanzaImports + instance L.HasBuildInfo BenchmarkStanza where buildInfo = benchmarkStanzaBuildInfo +benchmarkStanzaImports :: Lens' BenchmarkStanza CommonStanzaImports +benchmarkStanzaImports f s = fmap (\x -> s { _benchmarkStanzaImports = x }) (f (_benchmarkStanzaImports s)) +{-# INLINE benchmarkStanzaImports #-} + benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) {-# INLINE benchmarkStanzaBenchmarkType #-} @@ -316,7 +355,8 @@ benchmarkFieldGrammar :: (FieldGrammar g, Applicative (g BenchmarkStanza), Applicative (g BuildInfo)) => g BenchmarkStanza BenchmarkStanza benchmarkFieldGrammar = BenchmarkStanza - <$> optionalField "type" benchmarkStanzaBenchmarkType + <$> optionalFieldDef "import" benchmarkStanzaImports emptyCommonStanzaImports + <*> optionalField "type" benchmarkStanzaBenchmarkType <*> optionalFieldAla "main-is" FilePathNT benchmarkStanzaMainIs <*> optionalField "benchmark-module" benchmarkStanzaBenchmarkModule <*> blurFieldGrammar benchmarkStanzaBuildInfo buildInfoFieldGrammar @@ -357,7 +397,8 @@ validateBenchmark pos stanza = case _benchmarkStanzaBenchmarkType stanza of unvalidateBenchmark :: Benchmark -> BenchmarkStanza unvalidateBenchmark b = BenchmarkStanza - { _benchmarkStanzaBenchmarkType = ty + { _benchmarkStanzaImports = view L.benchmarkImports b + , _benchmarkStanzaBenchmarkType = ty , _benchmarkStanzaMainIs = ma , _benchmarkStanzaBenchmarkModule = mo , _benchmarkStanzaBuildInfo = benchmarkBuildInfo b diff --git a/Cabal/Distribution/PackageDescription/PackageSourceDescriptionParser.hs b/Cabal/Distribution/PackageDescription/PackageSourceDescriptionParser.hs new file mode 100644 index 00000000000..f93cbc858e2 --- /dev/null +++ b/Cabal/Distribution/PackageDescription/PackageSourceDescriptionParser.hs @@ -0,0 +1,794 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.PackageSourceDescriptionParser +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. + +module Distribution.PackageDescription.PackageSourceDescriptionParser ( + -- * Package descriptions + readPackageSourceDescription, + parsePackageSourceDescription, + parsePackageSourceDescriptionMaybe, + + -- ** Parsing + ParseResult, + runParseResult, + + -- * New-style spec-version + scanSpecVersion, + + -- ** Supplementary build information + readHookedBuildInfo, + parseHookedBuildInfo, + ) where + +import Distribution.Compat.Prelude +import Prelude () + +import Control.Applicative (Const (..)) +import Control.DeepSeq (deepseq) +import Control.Monad (guard) +import Control.Monad.State.Strict (StateT, execStateT) +import Control.Monad.Trans.Class (lift) +import Data.List (partition) +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.Fields.ParseResult +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration (freeVars) +import Distribution.PackageDescription.FieldGrammar +import Distribution.PackageDescription.Quirks (patchQuirks) +import Distribution.Parsec (parsec, simpleParsecBS) +import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) +import Distribution.Parsec.Newtypes (CommaFSep, List, SpecVersion (..), Token) +import Distribution.Parsec.Position (Position (..), zeroPos) +import Distribution.Parsec.Warning (PWarnType (..)) +import Distribution.Pretty (prettyShow) +import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import Distribution.Types.CondTree +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.ForeignLib +import Distribution.Types.ForeignLibType (knownForeignLibTypes) +import Distribution.Types.PackageSourceDescription (PackageSourceDescription, emptyPackageSourceDescription) +import Distribution.Types.PackageDescription (specVersion') +import Distribution.Types.UnqualComponentName (UnqualComponentName, mkUnqualComponentName) +import Distribution.Utils.Generic (breakMaybe, unfoldrM, validateUTF8) +import Distribution.Verbosity (Verbosity) +import Distribution.Version (LowerBound (..), Version, asVersionIntervals, mkVersion, orLaterVersion, version0, 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.Types.BuildInfo.Lens as L +import qualified Distribution.Types.PackageSourceDescription.Lens as L +import qualified Distribution.Types.PackageDescription.Lens as L +import qualified Text.Parsec as P + +-- --------------------------------------------------------------- +-- Parsing +-- --------------------------------------------------------------- + +-- | Parse the given package file. +readPackageSourceDescription :: Verbosity -> FilePath -> IO PackageSourceDescription +readPackageSourceDescription = readAndParseFile parsePackageSourceDescription + +------------------------------------------------------------------------------ +-- | Parses the given file into a 'PackageSourceDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +-- +parsePackageSourceDescription :: BS.ByteString -> ParseResult PackageSourceDescription +parsePackageSourceDescription bs = do + -- set scanned version + setCabalSpecVersion ver + -- if we get too new version, fail right away + case ver of + Just v | v > mkVersion [3,0] -> parseFailure zeroPos + "Unsupported cabal-version. See https://github.com/haskell/cabal/issues/4899." + _ -> pure () + + 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. + parsePackageSourceDescription' ver 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' + + invalidUtf8 = validateUTF8 bs' + + -- if there are invalid utf8 characters, we make the bytestring valid. + bs'' = case invalidUtf8 of + Nothing -> bs' + Just _ -> toUTF8BS (fromUTF8BS bs') + + +-- | 'Maybe' variant of 'parsePackageSourceDescription' +parsePackageSourceDescriptionMaybe :: BS.ByteString -> Maybe PackageSourceDescription +parsePackageSourceDescriptionMaybe = + either (const Nothing) Just . snd . runParseResult . parsePackageSourceDescription + +fieldlinesToBS :: [FieldLine ann] -> BS.ByteString +fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) + +-- Monad in which sections are parsed +type SectionParser = StateT SectionS ParseResult + +-- | State of section parser +data SectionS = SectionS + { _statePsd :: !PackageSourceDescription + , _stateCommonStanzas :: !(Set String) + } + +statePsd :: Lens' SectionS PackageSourceDescription +statePsd f (SectionS psd cs) = (\x -> SectionS x cs) <$> f psd +{-# INLINE statePsd #-} + +stateCommonStanzas :: Lens' SectionS (Set String) +stateCommonStanzas f (SectionS psd cs) = SectionS psd <$> f cs +{-# INLINE stateCommonStanzas #-} + +-- Note [Accumulating parser] +-- +-- This parser has two "states": +-- * first we parse fields of PackageDescription +-- * then we parse sections (libraries, executables, etc) +parsePackageSourceDescription' + :: Maybe Version + -> [LexWarning] + -> Maybe Int + -> [Field Position] + -> ParseResult PackageSourceDescription +parsePackageSourceDescription' cabalVerM 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 + cabalVer <- case cabalVerM of + Just v -> return v + Nothing -> case Map.lookup "cabal-version" fields >>= safeLast of + Nothing -> return version0 + Just (MkNamelessField pos fls) -> do + v <- specVersion' . Newtype.unpack' SpecVersion <$> runFieldParser pos parsec cabalSpecLatest fls + when (v >= mkVersion [2,1]) $ 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 + + let specVer = cabalSpecFromVersionDigits (versionNumbers cabalVer) + + -- reset cabal version + setCabalSpecVersion (Just cabalVer) + + -- Package description + pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar + + -- Check that scanned and parsed versions match. + unless (cabalVer == specVersion pd) $ parseFailure zeroPos $ + "Scanned and parsed cabal-versions don't match " ++ + prettyShow cabalVer ++ " /= " ++ prettyShow (specVersion pd) + + maybeWarnCabalVersion syntax pd + + -- Sections + let psd = emptyPackageSourceDescription & L.packageDescription .~ pd + psd1 <- view statePsd <$> execStateT (goSections specVer sectionFields) (SectionS psd Set.empty) + + checkForUndefinedFlags psd1 + psd1 `deepseq` return psd1 + where + safeLast :: [a] -> Maybe a + safeLast = listToMaybe . reverse + + newSyntaxVersion :: Version + newSyntaxVersion = mkVersion [1, 2] + + 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'." + + maybeWarnCabalVersion syntax pkg + | syntax == OldSyntax && specVersion pkg >= newSyntaxVersion + = parseWarning zeroPos PWTOldSyntax $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = prettyShow version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> prettyShow versionRange + ((LowerBound version _, _):_) -> prettyShow (orLaterVersion version) + + 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 + process (Section name args secFields) = + parseSection name args secFields + + snoc x xs = xs ++ [x] + + hasCommonStanzas = specHasCommonStanzas specVer + + -- we need signature, because this is polymorphic, but not-closed + parseCondTree' + :: L.HasBuildInfo a + => ParsecFieldGrammar' a -- ^ grammar + -> Set String -- ^ 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 + 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 + let unqualName = mkUnqualComponentName name' + commonStanza <- lift $ parseCondTree' (commonStanzaFieldGrammar unqualName) commonStanzas fields + + case Set.member name' commonStanzas of + False -> do + -- Add the full common stanza condition tree to the PackageSourceDescription. + statePsd . L.condCommonStanzas %= snoc (unqualName, commonStanza) + stateCommonStanzas .= Set.insert name' commonStanzas + True -> lift $ parseFailure pos $ + "Duplicate common stanza: " ++ name' + + | name == "library" && null args = do + prev <- use $ statePsd . 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'') commonStanzas fields + -- + -- TODO check that not set + statePsd . 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'') commonStanzas fields + -- TODO check duplicate name here? + statePsd . 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') 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? + statePsd . L.condForeignLibs %= snoc (name', flib) + + | name == "executable" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + exe <- lift $ parseCondTree' (executableFieldGrammar name') commonStanzas fields + -- TODO check duplicate name here? + statePsd . L.condExecutables %= snoc (name', exe) + + | name == "test-suite" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + testStanza <- lift $ parseCondTree' testSuiteFieldGrammar commonStanzas fields + testSuite <- lift $ traverse (validateTestSuite pos) testStanza + + let hasType ts = testInterface ts /= testInterface mempty + unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ concat + [ "Test suite " ++ 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 knownTestTypes) + ] + + -- TODO check duplicate name here? + statePsd . L.condTestSuites %= snoc (name', testSuite) + + | name == "benchmark" = do + commonStanzas <- use stateCommonStanzas + name' <- parseUnqualComponentName pos args + benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar commonStanzas fields + bench <- lift $ traverse (validateBenchmark pos) benchStanza + + let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty + unless (onAllBranches hasType bench) $ lift $ parseFailure pos $ concat + [ "Benchmark " ++ show (prettyShow name') + , " 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? + statePsd . 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 + statePsd . L.genPackageFlags %= snoc flag + + | name == "custom-setup" && null args = do + sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False) + statePsd . 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) + statePsd . 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 + +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 "" + +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 "" + +-- TODO: avoid conversion to 'String'. +parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName +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 +parseFields v fields grammar = do + 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 + +parseCondTree + :: forall a. + CabalSpecVersion + -> HasElif -- ^ accept @elif@ + -> ParsecFieldGrammar' a -- ^ grammar + -> Set String -- ^ common stanzas + -> (a -> [Dependency]) -- ^ condition extractor + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) +parseCondTree v hasElif grammar commonStanzas cond = go + where + go fields0 = do + fields <- + if v >= CabalSpecV3_0 + then checkCommonStanzaImports v commonStanzas fields0 + else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1) + + let (fs, ss) = partitionFields fields + x <- parseFieldGrammar v fs grammar + branches <- concat <$> traverse parseIfs ss + return $ 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') + parseIfs (MkSection (Name pos name) _ _ : sections) = do + parseWarning pos PWTInvalidSubsection $ "invalid subsection " ++ show name + parseIfs sections + + parseElseIfs + :: [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') + + 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 + + parseElseIfs sections = (,) Nothing <$> parseIfs sections + +{- Note [Accumulating parser] + +Note: Outdated a bit + +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 + +* 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: + @license-file@ and @license-files@ + +* 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. +-} + +parseCondTreeWithCommonStanzas + :: forall a. L.HasBuildInfo a + => CabalSpecVersion + -> ParsecFieldGrammar' a -- ^ grammar + -> Set String -- ^ common stanzas + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) +parseCondTreeWithCommonStanzas v grammar commonStanzas fields = do + fields' <- checkCommonStanzaImports v commonStanzas fields + parseCondTree v hasElif grammar commonStanzas (view L.targetBuildDepends) fields' + where + hasElif = specHasElif v + +checkCommonStanzaImports + :: CabalSpecVersion + -> Set String -- ^ common stanzas + -> [Field Position] + -> ParseResult [Field Position] +checkCommonStanzaImports _ _ [] = + pure [] +checkCommonStanzaImports v commonStanzas fs@(Field (Name pos name) fls : fields) + | name == "import" = do + + -- If the Cabal spec version declared in the file does not support + -- common stanzas than emit a warning. + when ((specHasCommonStanzas v) == NoCommonStanzas) $ + parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" + + -- Verify that all imported common pragmas have been defined in the file. + names <- getList' <$> runFieldParser pos parsec v fls + for_ names $ \commonName -> + case Set.member commonName commonStanzas of + False -> parseFailure pos $ "Undefined common stanza imported: " ++ commonName + True -> pure () + + -- Check that all remaining fields are not 'import' since common stanza + -- import directives must be first in the section. + for_ fields (warnImport v) + pure fs + + | otherwise = do + -- Check that all remaining fields are not 'import' since common stanza + -- import directives must be first in the section. + for_ fields (warnImport v) + pure fs + + where + getList' :: List CommaFSep Token String -> [String] + getList' = Newtype.unpack + +checkCommonStanzaImports _ _ fs = pure fs + + +-- | 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 + 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 +warnImport _ f = pure (Just f) + +------------------------------------------------------------------------------- +-- Branches +------------------------------------------------------------------------------- + +-- Check that a property holds on all branches of a condition tree +onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool +onAllBranches p = go mempty + where + -- If the current level of the tree satisfies the property, then we are + -- done. If not, then one of the conditional branches below the current node + -- must satisfy it. Each node may have multiple immediate children; we only + -- 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) + + -- 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 + +------------------------------------------------------------------------------- +-- Flag check +------------------------------------------------------------------------------- + +checkForUndefinedFlags :: PackageSourceDescription -> ParseResult () +checkForUndefinedFlags psd = do + let definedFlags, usedFlags :: Set.Set FlagName + definedFlags = toSetOf (L.genPackageFlags . traverse . getting flagName) psd + usedFlags = getConst $ L.allCondTrees f psd + + -- 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)) + +------------------------------------------------------------------------------- +-- Old syntax +------------------------------------------------------------------------------- + +-- TODO: move to own module + +-- | "Sectionize" an old-style Cabal file. A sectionized file has: +-- +-- * all global fields at the beginning, followed by +-- +-- * all flag declarations, followed by +-- +-- * an optional library section, and an arbitrary number of executable +-- sections (in any order). +-- +-- The current implementation just gathers all library-specific fields +-- in a library section and wraps all executable stanzas in an executable +-- section. +sectionizeFields :: [Field ann] -> (Syntax, [Field ann]) +sectionizeFields fs = case classifyFields fs of + 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 + + trim = BS.dropWhile isSpace' . BS.reverse . BS.dropWhile isSpace' . BS.reverse + isSpace' = (== 32) + + convert :: [(Name ann, [FieldLine ann])] -> [Field ann] + convert fields = + let + toField (name, ls) = Field name ls + -- "build-depends" is a local field now. To be backwards + -- 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 + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . getName . fst) hdr0 + + (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') + 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 + +-- | See 'sectionizeFields'. +data Syntax = OldSyntax | NewSyntax + deriving (Eq, Show) + +-- TODO: +libFieldNames :: [FieldName] +libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) + +------------------------------------------------------------------------------- +-- Suplementary build information +------------------------------------------------------------------------------- + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = readAndParseFile parseHookedBuildInfo + +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) + +parseHookedBuildInfo' + :: [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) + where + parseLib :: Fields Position -> ParseResult (Maybe BuildInfo) + parseLib fields + | 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) + + 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) + + toFields :: [Field Position] -> ParseResult (Fields Position) + toFields fields = do + 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])) + toExe (fss, fields) = do + 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 + isExecutableField _ = Nothing + +-- | Quickly scan new-style spec-version +-- +-- A new-style spec-version declaration begins the .cabal file and +-- follow the following case-insensitive grammar (expressed in +-- RFC5234 ABNF): +-- +-- @ +-- newstyle-spec-version-decl = "cabal-version" *WS ":" *WS newstyle-pec-version *WS +-- +-- spec-version = NUM "." NUM [ "." NUM ] +-- +-- NUM = DIGIT0 / DIGITP 1*DIGIT0 +-- DIGIT0 = %x30-39 +-- DIGITP = %x31-39 +-- WS = %20 +-- @ +-- +scanSpecVersion :: BS.ByteString -> Maybe Version +scanSpecVersion bs = do + fstline':_ <- pure (BS8.lines bs) + + -- parse + -- 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 + -- + -- 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'] + toLowerW8 :: Word8 -> Word8 + toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20 + | otherwise = w diff --git a/Cabal/Distribution/PackageDescription/PackageSourceDescriptionPrettyPrint.hs b/Cabal/Distribution/PackageDescription/PackageSourceDescriptionPrettyPrint.hs new file mode 100644 index 00000000000..8ec498fc643 --- /dev/null +++ b/Cabal/Distribution/PackageDescription/PackageSourceDescriptionPrettyPrint.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.PackageSourceDescriptionPrettyPrint +-- License : BSD3 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Pretty printing for cabal files +-- +----------------------------------------------------------------------------- + +module Distribution.PackageDescription.PackageSourceDescriptionPrettyPrint ( + -- * Generic package descriptions + writePackageSourceDescription, + showPackageSourceDescription, + ppPackageSourceDescription, + + -- ** Supplementary build information + writeHookedBuildInfo, + showHookedBuildInfo, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.CondTree +import Distribution.Types.Dependency +import Distribution.Types.ForeignLib (ForeignLib) +import Distribution.Types.LibraryName +import Distribution.Types.UnqualComponentName + +import Distribution.CabalSpecVersion +import Distribution.Fields.Pretty +import Distribution.PackageDescription + (PackageDescription, SourceRepo, SetupBuildInfo, Flag(..), FlagName, ConfVar(..), + Library, Executable, TestSuite, Benchmark, Condition(..), HookedBuildInfo, + specVersion, setupBuildInfo, sourceRepos, repoKind, defaultSetupDepends, unFlagName) +import Distribution.Pretty +import Distribution.Simple.Utils +import Distribution.Types.PackageSourceDescription + (PackageSourceDescription, packageDescription, genPackageFlags, condCommonStanzas, + condLibrary, condSubLibraries, condForeignLibs, condExecutables, condTestSuites, + condBenchmarks) +import Distribution.Types.CommonStanza (CommonStanza) +import Distribution.Types.Version (versionNumbers) + +import Distribution.FieldGrammar + (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.PackageDescription.FieldGrammar + (benchmarkFieldGrammar, buildInfoFieldGrammar, commonStanzaFieldGrammar, executableFieldGrammar, flagFieldGrammar, + foreignLibFieldGrammar, libraryFieldGrammar, packageDescriptionFieldGrammar, + setupBInfoFieldGrammar, sourceRepoFieldGrammar, testSuiteFieldGrammar) + +import qualified Distribution.PackageDescription.FieldGrammar as FG + +import Text.PrettyPrint (Doc, char, hsep, parens, text, (<+>)) + +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 + +-- | Writes a .cabal file from a generic package description +writePackageSourceDescription :: FilePath -> PackageSourceDescription -> IO () +writePackageSourceDescription fpath pkg = writeUTF8File fpath (showPackageSourceDescription pkg) + +-- | Writes a generic package description to a string +showPackageSourceDescription :: PackageSourceDescription -> String +showPackageSourceDescription gpd = showFields (const []) $ ppPackageSourceDescription v gpd + where + v = cabalSpecFromVersionDigits + $ versionNumbers + $ specVersion + $ packageDescription gpd + +-- | Convert a generic package description to 'PrettyField's. +ppPackageSourceDescription :: CabalSpecVersion -> PackageSourceDescription -> [PrettyField ()] +ppPackageSourceDescription v gpd = concat + [ ppPackageDescription v (packageDescription gpd) + , ppSetupBInfo v (setupBuildInfo (packageDescription gpd)) + , ppGenPackageFlags v (genPackageFlags gpd) + , ppCommonStanzas v (condCommonStanzas gpd) + , ppCondLibrary v (condLibrary gpd) + , ppCondSubLibraries v (condSubLibraries gpd) + , ppCondForeignLibs v (condForeignLibs gpd) + , ppCondExecutables v (condExecutables gpd) + , ppCondTestSuites v (condTestSuites gpd) + , ppCondBenchmarks v (condBenchmarks gpd) + ] + +ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] +ppPackageDescription v 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] $ + prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo + where + kind = repoKind repo + +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 + +ppGenPackageFlags :: CabalSpecVersion -> [Flag] -> [PrettyField ()] +ppGenPackageFlags = map . ppFlag + +ppFlag :: CabalSpecVersion -> Flag -> PrettyField () +ppFlag v flag@(MkFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ + prettyFieldGrammar v (flagFieldGrammar name) flag + +ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar [Dependency] s -> [PrettyField ()] +ppCondTree2 v grammar = go + where + -- TODO: recognise elif opportunities + go (CondNode it _ ifs) = + prettyFieldGrammar v grammar it ++ + concatMap ppIf ifs + + ppIf (CondBranch c thenTree Nothing) +-- | isEmpty thenDoc = mempty + | otherwise = [ppIfCondition c thenDoc] + where + thenDoc = go thenTree + + ppIf (CondBranch c thenTree (Just elseTree)) = + -- See #6193 + [ ppIfCondition c (go thenTree) + , PrettySection () "else" [] (go elseTree) + ] + +ppCommonStanzas :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] CommonStanza)] -> [PrettyField ()] +ppCommonStanzas v commonStanzas = + [ PrettySection () "common" [pretty n] + $ ppCondTree2 v (commonStanzaFieldGrammar n) condTree + | (n, condTree) <- commonStanzas + ] + +ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar [Dependency] Library) -> [PrettyField ()] +ppCondLibrary _ Nothing = mempty +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 + ] + +ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> [PrettyField ()] +ppCondForeignLibs v 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 + ] + +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 + ] + +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 + ] + +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]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <<>> parens (pretty os) +ppConfVar (Arch arch) = text "arch" <<>> parens (pretty arch) +ppConfVar (Flag name) = text "flag" <<>> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) + +ppFlagName :: FlagName -> Doc +ppFlagName = text . unFlagName + +ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () +ppIfCondition c = PrettySection () "if" [ppCondition c] + + +-- | @since 2.0.0.2 +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack + . showHookedBuildInfo + +-- | @since 2.0.0.2 +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const []) $ + maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi ++ + [ PrettySection () "executable:" [pretty name] + $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi + | (name, bi) <- ex_bis + ] diff --git a/Cabal/Distribution/PackageDescription/Parsec.hs b/Cabal/Distribution/PackageDescription/Parsec.hs index db97cd3a27f..d6f380d3b5c 100644 --- a/Cabal/Distribution/PackageDescription/Parsec.hs +++ b/Cabal/Distribution/PackageDescription/Parsec.hs @@ -61,6 +61,7 @@ import Distribution.Parsec.Position (Position (..), zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) import Distribution.Pretty (prettyShow) import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) +import Distribution.Types.CommonStanzaImports (emptyCommonStanzaImports) import Distribution.Types.CondTree import Distribution.Types.Dependency (Dependency) import Distribution.Types.ForeignLib @@ -578,10 +579,10 @@ instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibNa 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 emptyCommonStanzaImports Nothing Nothing Nothing bi instance FromBuildInfo BenchmarkStanza where - fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi + fromBuildInfo' _ bi = BenchmarkStanza emptyCommonStanzaImports Nothing Nothing Nothing bi parseCondTreeWithCommonStanzas :: forall a. L.HasBuildInfo a diff --git a/Cabal/Distribution/Simple/Build.hs b/Cabal/Distribution/Simple/Build.hs index e6916b8e9a6..fb89e834eab 100644 --- a/Cabal/Distribution/Simple/Build.hs +++ b/Cabal/Distribution/Simple/Build.hs @@ -470,6 +470,7 @@ testSuiteExeV10AsExe :: TestSuite -> Executable testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } = Executable { exeName = testName test, + exeImports = mempty, modulePath = mainFile, exeScope = ExecutablePublic, buildInfo = testBuildInfo test @@ -481,6 +482,7 @@ benchmarkExeV10asExe :: Benchmark -> Executable benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ mainFile } = Executable { exeName = benchmarkName bm, + exeImports = mempty, modulePath = mainFile, exeScope = ExecutablePublic, buildInfo = benchmarkBuildInfo bm @@ -507,6 +509,7 @@ testSuiteLibV09AsLibAndExe pkg_descr bi = testBuildInfo test lib = Library { libName = LMainLibName, + libImports = mempty, exposedModules = [ m ], reexportedModules = [], signatures = [], @@ -547,6 +550,7 @@ testSuiteLibV09AsLibAndExe pkg_descr testLibDep = thisPackageVersion $ package pkg exe = Executable { exeName = mkUnqualComponentName $ stubName test, + exeImports = mempty, modulePath = stubFilePath test, exeScope = ExecutablePublic, buildInfo = (testBuildInfo test) { diff --git a/Cabal/Distribution/Simple/Haddock.hs b/Cabal/Distribution/Simple/Haddock.hs index 7ad7d41c2e8..c2be57f987b 100644 --- a/Cabal/Distribution/Simple/Haddock.hs +++ b/Cabal/Distribution/Simple/Haddock.hs @@ -480,6 +480,7 @@ compToExe comp = CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } -> Just Executable { exeName = testName test, + exeImports = mempty, modulePath = f, exeScope = ExecutablePublic, buildInfo = testBuildInfo test @@ -487,6 +488,7 @@ compToExe comp = CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } -> Just Executable { exeName = benchmarkName bench, + exeImports = mempty, modulePath = f, exeScope = ExecutablePublic, buildInfo = benchmarkBuildInfo bench diff --git a/Cabal/Distribution/Types/Benchmark.hs b/Cabal/Distribution/Types/Benchmark.hs index 91b45616f0b..4df68f39234 100644 --- a/Cabal/Distribution/Types/Benchmark.hs +++ b/Cabal/Distribution/Types/Benchmark.hs @@ -13,6 +13,7 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Types.BuildInfo +import Distribution.Types.CommonStanzaImports import Distribution.Types.BenchmarkType import Distribution.Types.BenchmarkInterface import Distribution.Types.UnqualComponentName @@ -20,11 +21,13 @@ import Distribution.Types.UnqualComponentName import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.CommonStanzaImports.Lens as L -- | A \"benchmark\" stanza in a cabal file. -- data Benchmark = Benchmark { benchmarkName :: UnqualComponentName, + benchmarkImports :: CommonStanzaImports, benchmarkInterface :: BenchmarkInterface, benchmarkBuildInfo :: BuildInfo } @@ -34,12 +37,16 @@ instance Binary Benchmark instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf +instance L.HasCommonStanzaImports Benchmark where + commonStanzaImports f (Benchmark x1 x2 x3 x4) = fmap (\i1 -> Benchmark x1 i1 x3 x4) (f x2) + 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 x4) = fmap (\y1 -> Benchmark x1 x2 x3 y1) (f x4) instance Monoid Benchmark where mempty = Benchmark { benchmarkName = mempty, + benchmarkImports = mempty, benchmarkInterface = mempty, benchmarkBuildInfo = mempty } @@ -48,6 +55,7 @@ instance Monoid Benchmark where instance Semigroup Benchmark where a <> b = Benchmark { benchmarkName = combine' benchmarkName, + benchmarkImports = combine benchmarkImports, benchmarkInterface = combine benchmarkInterface, benchmarkBuildInfo = combine benchmarkBuildInfo } diff --git a/Cabal/Distribution/Types/Benchmark/Lens.hs b/Cabal/Distribution/Types/Benchmark/Lens.hs index db46345f5e6..59eb86b535c 100644 --- a/Cabal/Distribution/Types/Benchmark/Lens.hs +++ b/Cabal/Distribution/Types/Benchmark/Lens.hs @@ -10,6 +10,7 @@ import Prelude () import Distribution.Types.Benchmark (Benchmark) import Distribution.Types.BenchmarkInterface (BenchmarkInterface) import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) import Distribution.Types.UnqualComponentName (UnqualComponentName) import qualified Distribution.Types.Benchmark as T @@ -18,6 +19,10 @@ benchmarkName :: Lens' Benchmark UnqualComponentName benchmarkName f s = fmap (\x -> s { T.benchmarkName = x }) (f (T.benchmarkName s)) {-# INLINE benchmarkName #-} +benchmarkImports :: Lens' Benchmark CommonStanzaImports +benchmarkImports f s = fmap (\x -> s { T.benchmarkImports = x }) (f (T.benchmarkImports s)) +{-# INLINE benchmarkImports #-} + benchmarkInterface :: Lens' Benchmark BenchmarkInterface benchmarkInterface f s = fmap (\x -> s { T.benchmarkInterface = x }) (f (T.benchmarkInterface s)) {-# INLINE benchmarkInterface #-} diff --git a/Cabal/Distribution/Types/CommonStanza.hs b/Cabal/Distribution/Types/CommonStanza.hs new file mode 100644 index 00000000000..7df80b1dfe0 --- /dev/null +++ b/Cabal/Distribution/Types/CommonStanza.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.CommonStanza ( + CommonStanza(..), + emptyCommonStanza, +) where + +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo +import Distribution.Types.CommonStanzaImports +import Distribution.Types.UnqualComponentName + +import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.CommonStanzaImports.Lens as L + +data CommonStanza = CommonStanza + { commonStanzaName :: UnqualComponentName + , commonStanzaRecursiveImports:: CommonStanzaImports + , commonStanzaBuildInfo :: BuildInfo + } + deriving (Generic, Show, Eq, Read, Typeable, Data) + +instance L.HasCommonStanzaImports CommonStanza where + commonStanzaImports f l = (\x -> l { commonStanzaRecursiveImports = x }) <$> f (commonStanzaRecursiveImports l) + +instance L.HasBuildInfo CommonStanza where + buildInfo f l = (\x -> l { commonStanzaBuildInfo = x }) <$> f (commonStanzaBuildInfo l) + +instance Binary CommonStanza +instance Structured CommonStanza +instance NFData CommonStanza where rnf = genericRnf + +instance Monoid CommonStanza where + mempty = gmempty + mappend = (<>) + +instance Semigroup CommonStanza where + a <> b = CommonStanza{ + commonStanzaName = combine' commonStanzaName, + commonStanzaRecursiveImports = combine commonStanzaRecursiveImports, + commonStanzaBuildInfo = combine commonStanzaBuildInfo + } + 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 ++ "'" + +emptyCommonStanza :: CommonStanza +emptyCommonStanza = mempty diff --git a/Cabal/Distribution/Types/CommonStanza/Lens.hs b/Cabal/Distribution/Types/CommonStanza/Lens.hs new file mode 100644 index 00000000000..ba0ed4756e1 --- /dev/null +++ b/Cabal/Distribution/Types/CommonStanza/Lens.hs @@ -0,0 +1,28 @@ +module Distribution.Types.CommonStanza.Lens ( + CommonStanza, + module Distribution.Types.CommonStanza.Lens, + ) where + +import Distribution.Compat.Lens +import Distribution.Compat.Prelude +import Prelude () + +import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.CommonStanza (CommonStanza) +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) +import Distribution.Types.UnqualComponentName (UnqualComponentName) + +import qualified Distribution.Types.CommonStanza as T + +commonStanzaName :: Lens' CommonStanza UnqualComponentName +commonStanzaName f s = fmap (\x -> s { T.commonStanzaName = x }) (f (T.commonStanzaName s)) +{-# INLINE commonStanzaName #-} + +commonStanzaRecursiveImports :: Lens' CommonStanza CommonStanzaImports +commonStanzaRecursiveImports f s = fmap (\x -> s { T.commonStanzaRecursiveImports = x }) (f (T.commonStanzaRecursiveImports s)) +{-# INLINE commonStanzaRecursiveImports #-} + + +commonStanzaBuildInfo :: Lens' CommonStanza BuildInfo +commonStanzaBuildInfo f s = fmap (\x -> s { T.commonStanzaBuildInfo = x }) (f (T.commonStanzaBuildInfo s)) +{-# INLINE commonStanzaBuildInfo #-} diff --git a/Cabal/Distribution/Types/CommonStanzaImports.hs b/Cabal/Distribution/Types/CommonStanzaImports.hs new file mode 100644 index 00000000000..439461b5c55 --- /dev/null +++ b/Cabal/Distribution/Types/CommonStanzaImports.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.CommonStanzaImports ( + CommonStanzaImports(..), + + emptyCommonStanzaImports, +) where + +import Prelude () +import Distribution.Compat.Prelude + + +import Distribution.Parsec +import Distribution.Pretty +import Distribution.Types.UnqualComponentName (UnqualComponentName, mkUnqualComponentName) +import qualified Text.PrettyPrint as Disp +import Distribution.FieldGrammar.Described + + +-- | Represents the list of common stanzas specified in the `import` directive +-- of sections in a cabal file. +data CommonStanzaImports = CommonStanzaImports { + -- | The names of common stanzas to be imported. + getCommonStanzaImports :: [UnqualComponentName] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary CommonStanzaImports +instance Structured CommonStanzaImports +instance NFData CommonStanzaImports where rnf = genericRnf + +instance Monoid CommonStanzaImports where + mempty = CommonStanzaImports { + getCommonStanzaImports = [] + } + mappend = (<>) + +instance Semigroup CommonStanzaImports where + a <> b = CommonStanzaImports { + getCommonStanzaImports = getCommonStanzaImports a <> getCommonStanzaImports b + } + +emptyCommonStanzaImports :: CommonStanzaImports +emptyCommonStanzaImports = mempty + +instance Pretty CommonStanzaImports where + pretty (CommonStanzaImports []) = Disp.empty + pretty (CommonStanzaImports imports) = + Disp.fsep (Disp.punctuate Disp.comma (map pretty imports)) + +instance Parsec CommonStanzaImports where + parsec = CommonStanzaImports <$> parsecLeadingCommaList parsec + +instance Described CommonStanzaImports where + describe _ = RETodo diff --git a/Cabal/Distribution/Types/CommonStanzaImports/Lens.hs b/Cabal/Distribution/Types/CommonStanzaImports/Lens.hs new file mode 100644 index 00000000000..35b9fe03e77 --- /dev/null +++ b/Cabal/Distribution/Types/CommonStanzaImports/Lens.hs @@ -0,0 +1,18 @@ +module Distribution.Types.CommonStanzaImports.Lens ( + CommonStanzaImports, + HasCommonStanzaImports (..), + ) where + +import Prelude () +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) + +-- | Class lenses for 'CommonStanzaImports'. +class HasCommonStanzaImports a where + commonStanzaImports :: Lens' a CommonStanzaImports + +instance HasCommonStanzaImports CommonStanzaImports where + commonStanzaImports = id + {-# INLINE commonStanzaImports #-} diff --git a/Cabal/Distribution/Types/Executable.hs b/Cabal/Distribution/Types/Executable.hs index 16eff1042e1..febec5e248a 100644 --- a/Cabal/Distribution/Types/Executable.hs +++ b/Cabal/Distribution/Types/Executable.hs @@ -12,20 +12,26 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Types.BuildInfo +import Distribution.Types.CommonStanzaImports import Distribution.Types.UnqualComponentName import Distribution.Types.ExecutableScope import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.CommonStanzaImports.Lens as L data Executable = Executable { exeName :: UnqualComponentName, + exeImports :: CommonStanzaImports, modulePath :: FilePath, exeScope :: ExecutableScope, buildInfo :: BuildInfo } deriving (Generic, Show, Read, Eq, Typeable, Data) +instance L.HasCommonStanzaImports Executable where + commonStanzaImports f l = (\x -> l { exeImports = x }) <$> f (exeImports l) + instance L.HasBuildInfo Executable where buildInfo f l = (\x -> l { buildInfo = x }) <$> f (buildInfo l) @@ -40,6 +46,7 @@ instance Monoid Executable where instance Semigroup Executable where a <> b = Executable{ exeName = combine' exeName, + exeImports = combine exeImports, modulePath = combine modulePath, exeScope = combine exeScope, buildInfo = combine buildInfo diff --git a/Cabal/Distribution/Types/Executable/Lens.hs b/Cabal/Distribution/Types/Executable/Lens.hs index 36813072e69..9379a73431b 100644 --- a/Cabal/Distribution/Types/Executable/Lens.hs +++ b/Cabal/Distribution/Types/Executable/Lens.hs @@ -8,6 +8,7 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) import Distribution.Types.Executable (Executable) import Distribution.Types.ExecutableScope (ExecutableScope) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -18,6 +19,9 @@ exeName :: Lens' Executable UnqualComponentName exeName f s = fmap (\x -> s { T.exeName = x }) (f (T.exeName s)) {-# INLINE exeName #-} +exeImports :: Lens' Executable CommonStanzaImports +exeImports f s = fmap (\x -> s { T.exeImports = x }) (f (T.exeImports s)) + modulePath :: Lens' Executable String modulePath f s = fmap (\x -> s { T.modulePath = x }) (f (T.modulePath s)) {-# INLINE modulePath #-} diff --git a/Cabal/Distribution/Types/ForeignLib.hs b/Cabal/Distribution/Types/ForeignLib.hs index 3c96649e498..2d80c56e21e 100644 --- a/Cabal/Distribution/Types/ForeignLib.hs +++ b/Cabal/Distribution/Types/ForeignLib.hs @@ -25,6 +25,7 @@ import Distribution.Parsec import Distribution.Pretty import Distribution.System import Distribution.Types.BuildInfo +import Distribution.Types.CommonStanzaImports import Distribution.Types.ForeignLibOption import Distribution.Types.ForeignLibType import Distribution.Types.UnqualComponentName @@ -35,12 +36,15 @@ import qualified Text.PrettyPrint as Disp import qualified Text.Read as Read import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.CommonStanzaImports.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 + -- | Common stanza imports + , foreignLibImports :: CommonStanzaImports -- | What kind of foreign library is this (static or dynamic). , foreignLibType :: ForeignLibType -- | What options apply to this foreign library (e.g., are we @@ -136,6 +140,9 @@ libVersionNumberShow v = libVersionMajor :: LibVersionInfo -> Int libVersionMajor (LibVersionInfo c _ a) = c-a +instance L.HasCommonStanzaImports ForeignLib where + commonStanzaImports f l = (\x -> l { foreignLibImports = x }) <$> f (foreignLibImports l) + instance L.HasBuildInfo ForeignLib where buildInfo f l = (\x -> l { foreignLibBuildInfo = x }) <$> f (foreignLibBuildInfo l) @@ -146,6 +153,7 @@ instance NFData ForeignLib where rnf = genericRnf instance Semigroup ForeignLib where a <> b = ForeignLib { foreignLibName = combine' foreignLibName + , foreignLibImports = combine foreignLibImports , foreignLibType = combine foreignLibType , foreignLibOptions = combine foreignLibOptions , foreignLibBuildInfo = combine foreignLibBuildInfo @@ -165,6 +173,7 @@ instance Semigroup ForeignLib where instance Monoid ForeignLib where mempty = ForeignLib { foreignLibName = mempty + , foreignLibImports = mempty , foreignLibType = ForeignLibTypeUnknown , foreignLibOptions = [] , foreignLibBuildInfo = mempty diff --git a/Cabal/Distribution/Types/ForeignLib/Lens.hs b/Cabal/Distribution/Types/ForeignLib/Lens.hs index fe2df57733c..aa59ff601b2 100644 --- a/Cabal/Distribution/Types/ForeignLib/Lens.hs +++ b/Cabal/Distribution/Types/ForeignLib/Lens.hs @@ -8,6 +8,7 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) import Distribution.Types.ForeignLibOption (ForeignLibOption) import Distribution.Types.ForeignLibType (ForeignLibType) @@ -20,6 +21,10 @@ foreignLibName :: Lens' ForeignLib UnqualComponentName foreignLibName f s = fmap (\x -> s { T.foreignLibName = x }) (f (T.foreignLibName s)) {-# INLINE foreignLibName #-} +foreignLibImports :: Lens' ForeignLib CommonStanzaImports +foreignLibImports f s = fmap (\x -> s { T.foreignLibImports = x }) (f (T.foreignLibImports s)) +{-# INLINE foreignLibImports #-} + foreignLibType :: Lens' ForeignLib ForeignLibType foreignLibType f s = fmap (\x -> s { T.foreignLibType = x }) (f (T.foreignLibType s)) {-# INLINE foreignLibType #-} diff --git a/Cabal/Distribution/Types/Import.hs b/Cabal/Distribution/Types/Import.hs new file mode 100644 index 00000000000..901101cf250 --- /dev/null +++ b/Cabal/Distribution/Types/Import.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Types.CommonStanzaImports ( + CommonStanzaImports(..), + + emptyCommonStanzaImports, +) where + +import Prelude () +import Distribution.Compat.Prelude + +-- | Represents the list of common stanzas specified in the `import` directive +-- of sections in a cabal file. +data CommonStanzaImports = CommonStanzaImports { + -- | The names of common stanzas to be imported. + commonStanzaImports :: [String] + } + deriving (Generic, Show, Read, Eq, Typeable, Data) + +instance Binary BuildInfo +instance Structured BuildInfo +instance NFData BuildInfo where rnf = genericRnf + +instance Monoid BuildInfo where + mempty = BuildInfo { + commonStanzaImports = [], + } + mappend = (<>) + +instance Semigroup CommonStanzaImports where + a <> b = CommonStanzaImports { + commonStanzaImports = commonStanzaImports a <> commonStanzaImports b + } diff --git a/Cabal/Distribution/Types/Lens.hs b/Cabal/Distribution/Types/Lens.hs index 1581ff23cdd..0ca53452781 100644 --- a/Cabal/Distribution/Types/Lens.hs +++ b/Cabal/Distribution/Types/Lens.hs @@ -1,6 +1,8 @@ module Distribution.Types.Lens ( module Distribution.Types.Benchmark.Lens, module Distribution.Types.BuildInfo.Lens, + module Distribution.Types.CommonStanza.Lens, + module Distribution.Types.CommonStanzaImports.Lens, module Distribution.Types.Executable.Lens, module Distribution.Types.ForeignLib.Lens, module Distribution.Types.GenericPackageDescription.Lens, @@ -14,6 +16,8 @@ module Distribution.Types.Lens ( import Distribution.Types.Benchmark.Lens import Distribution.Types.BuildInfo.Lens +import Distribution.Types.CommonStanza.Lens +import Distribution.Types.CommonStanzaImports.Lens import Distribution.Types.Executable.Lens import Distribution.Types.ForeignLib.Lens import Distribution.Types.GenericPackageDescription.Lens diff --git a/Cabal/Distribution/Types/Library.hs b/Cabal/Distribution/Types/Library.hs index 27e5aada57e..d7b33dd0431 100644 --- a/Cabal/Distribution/Types/Library.hs +++ b/Cabal/Distribution/Types/Library.hs @@ -13,14 +13,17 @@ import Prelude () import Distribution.ModuleName import Distribution.Types.BuildInfo +import Distribution.Types.CommonStanzaImports import Distribution.Types.LibraryVisibility import Distribution.Types.ModuleReexport import Distribution.Types.LibraryName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.CommonStanzaImports.Lens as L data Library = Library { libName :: LibraryName + , libImports :: CommonStanzaImports , exposedModules :: [ModuleName] , reexportedModules :: [ModuleReexport] , signatures :: [ModuleName] -- ^ What sigs need implementations? @@ -30,6 +33,9 @@ data Library = Library } deriving (Generic, Show, Eq, Read, Typeable, Data) +instance L.HasCommonStanzaImports Library where + commonStanzaImports f l = (\x -> l { libImports = x }) <$> f (libImports l) + instance L.HasBuildInfo Library where buildInfo f l = (\x -> l { libBuildInfo = x }) <$> f (libBuildInfo l) @@ -40,6 +46,7 @@ instance NFData Library where rnf = genericRnf emptyLibrary :: Library emptyLibrary = Library { libName = LMainLibName + , libImports = mempty , exposedModules = mempty , reexportedModules = mempty , signatures = mempty @@ -63,6 +70,7 @@ instance Monoid Library where instance Semigroup Library where a <> b = Library { libName = combineLibraryName (libName a) (libName b) + , libImports = combine libImports , exposedModules = combine exposedModules , reexportedModules = combine reexportedModules , signatures = combine signatures diff --git a/Cabal/Distribution/Types/Library/Lens.hs b/Cabal/Distribution/Types/Library/Lens.hs index fefccbdd1a3..a6490d80333 100644 --- a/Cabal/Distribution/Types/Library/Lens.hs +++ b/Cabal/Distribution/Types/Library/Lens.hs @@ -9,6 +9,7 @@ import Prelude () import Distribution.ModuleName (ModuleName) import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) import Distribution.Types.Library (Library) import Distribution.Types.LibraryName (LibraryName) import Distribution.Types.LibraryVisibility (LibraryVisibility) @@ -20,6 +21,10 @@ libName :: Lens' Library LibraryName libName f s = fmap (\x -> s { T.libName = x }) (f (T.libName s)) {-# INLINE libName #-} +libImports :: Lens' Library CommonStanzaImports +libImports f s = fmap (\x -> s { T.libImports = x }) (f (T.libImports s)) +{-# INLINE libImports #-} + exposedModules :: Lens' Library [ModuleName] exposedModules f s = fmap (\x -> s { T.exposedModules = x }) (f (T.exposedModules s)) {-# INLINE exposedModules #-} diff --git a/Cabal/Distribution/Types/PackageSourceDescription.hs b/Cabal/Distribution/Types/PackageSourceDescription.hs new file mode 100644 index 00000000000..16fc4b517ae --- /dev/null +++ b/Cabal/Distribution/Types/PackageSourceDescription.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Distribution.Types.PackageSourceDescription ( + PackageSourceDescription(..), + emptyPackageSourceDescription, +) where + +import Prelude () +import Distribution.Compat.Prelude + +-- lens +import Distribution.Compat.Lens as L +import qualified Distribution.Types.BuildInfo.Lens as L + +import Distribution.Types.PackageDescription + +import Distribution.Types.Benchmark +import Distribution.Types.CommonStanza +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 + +-- --------------------------------------------------------------------------- +-- The 'PackageSourceDescription' type which represents the parsed package +-- source code before simplifications have been applied. This means that this +-- representation still contains comments and common stanzas. + +data PackageSourceDescription = + PackageSourceDescription + { packageDescription :: PackageDescription + , genPackageFlags :: [Flag] + , condCommonStanzas :: [( UnqualComponentName + , CondTree ConfVar [Dependency] CommonStanza )] + , 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) + +instance Package PackageSourceDescription where + packageId = packageId . packageDescription + +instance Binary PackageSourceDescription +instance Structured PackageSourceDescription +instance NFData PackageSourceDescription where rnf = genericRnf + +emptyPackageSourceDescription :: PackageSourceDescription +emptyPackageSourceDescription = PackageSourceDescription emptyPackageDescription [] [] Nothing [] [] [] [] [] + +-- ----------------------------------------------------------------------------- +-- Traversal Instances + +instance L.HasBuildInfos PackageSourceDescription where + traverseBuildInfos f (PackageSourceDescription p a1 x1 x2 x3 x4 x5 x6 x7) = + PackageSourceDescription + <$> L.traverseBuildInfos f p + <*> pure a1 + <*> (traverse . L._2 . traverse . L.buildInfo) f x1 + <*> (traverse . traverse . L.buildInfo) f x2 + <*> (traverse . L._2 . traverse . L.buildInfo) f x3 + <*> (traverse . L._2 . traverse . L.buildInfo) f x4 + <*> (traverse . L._2 . traverse . L.buildInfo) f x5 + <*> (traverse . L._2 . traverse . L.buildInfo) f x6 + <*> (traverse . L._2 . traverse . L.buildInfo) f x7 diff --git a/Cabal/Distribution/Types/PackageSourceDescription/Lens.hs b/Cabal/Distribution/Types/PackageSourceDescription/Lens.hs new file mode 100644 index 00000000000..7c3fb61e206 --- /dev/null +++ b/Cabal/Distribution/Types/PackageSourceDescription/Lens.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE Rank2Types #-} +module Distribution.Types.PackageSourceDescription.Lens ( + PackageSourceDescription, + Flag, + FlagName, + ConfVar (..), + module Distribution.Types.PackageSourceDescription.Lens, + ) where + +import Prelude() +import Distribution.Compat.Prelude +import Distribution.Compat.Lens + +import qualified Distribution.Types.PackageSourceDescription as T + +-- We import types from their packages, so we can remove unused imports +-- and have wider inter-module dependency graph +import Distribution.Types.CondTree (CondTree) +import Distribution.Types.CommonStanza (CommonStanza) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.Executable (Executable) +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.ForeignLib (ForeignLib) +import Distribution.Types.PackageSourceDescription (PackageSourceDescription(PackageSourceDescription) ) +import Distribution.Types.Flag (Flag(MkFlag), FlagName) +import Distribution.Types.ConfVar (ConfVar (..)) +import Distribution.Types.Library (Library) +import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.System (Arch, OS) +import Distribution.Compiler (CompilerFlavor) +import Distribution.Version (VersionRange) + +------------------------------------------------------------------------------- +-- PackageSourceDescription +------------------------------------------------------------------------------- + +packageDescription :: Lens' PackageSourceDescription PackageDescription +packageDescription f s = fmap (\x -> s { T.packageDescription = x }) (f (T.packageDescription s)) +{-# INLINE packageDescription #-} + +condCommonStanzas :: Lens' PackageSourceDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] CommonStanza))] +condCommonStanzas f s = fmap (\x -> s { T.condCommonStanzas = x }) (f (T.condCommonStanzas s)) +{-# INLINE condCommonStanzas #-} + +genPackageFlags :: Lens' PackageSourceDescription [Flag] +genPackageFlags f s = fmap (\x -> s { T.genPackageFlags = x }) (f (T.genPackageFlags s)) +{-# INLINE genPackageFlags #-} + +condLibrary :: Lens' PackageSourceDescription (Maybe (CondTree ConfVar [Dependency] Library)) +condLibrary f s = fmap (\x -> s { T.condLibrary = x }) (f (T.condLibrary s)) +{-# INLINE condLibrary #-} + +condSubLibraries :: Lens' PackageSourceDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Library))] +condSubLibraries f s = fmap (\x -> s { T.condSubLibraries = x }) (f (T.condSubLibraries s)) +{-# INLINE condSubLibraries #-} + +condForeignLibs :: Lens' PackageSourceDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] ForeignLib))] +condForeignLibs f s = fmap (\x -> s { T.condForeignLibs = x }) (f (T.condForeignLibs s)) +{-# INLINE condForeignLibs #-} + +condExecutables :: Lens' PackageSourceDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] Executable))] +condExecutables f s = fmap (\x -> s { T.condExecutables = x }) (f (T.condExecutables s)) +{-# INLINE condExecutables #-} + +condTestSuites :: Lens' PackageSourceDescription [(UnqualComponentName,(CondTree ConfVar [Dependency] TestSuite))] +condTestSuites f s = fmap (\x -> s { T.condTestSuites = x }) (f (T.condTestSuites s)) +{-# INLINE condTestSuites #-} + +condBenchmarks :: Lens' PackageSourceDescription [(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)) + -> PackageSourceDescription + -> f PackageSourceDescription +allCondTrees f (PackageSourceDescription p a1 x1 x2 x3 x4 x5 x6 x7) = + PackageSourceDescription + <$> pure p + <*> pure a1 + <*> (traverse . _2) f x1 + <*> traverse f x2 + <*> (traverse . _2) f x3 + <*> (traverse . _2) f x4 + <*> (traverse . _2) f x5 + <*> (traverse . _2) f x6 + <*> (traverse . _2) f x7 + + +------------------------------------------------------------------------------- +-- Flag +------------------------------------------------------------------------------- + +flagName :: Lens' Flag FlagName +flagName f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag y1 x2 x3 x4) (f x1) +{-# INLINE flagName #-} + +flagDescription :: Lens' Flag String +flagDescription f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag x1 y1 x3 x4) (f x2) +{-# INLINE flagDescription #-} + +flagDefault :: Lens' Flag Bool +flagDefault f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag x1 x2 y1 x4) (f x3) +{-# INLINE flagDefault #-} + +flagManual :: Lens' Flag Bool +flagManual f (MkFlag x1 x2 x3 x4) = fmap (\y1 -> MkFlag x1 x2 x3 y1) (f x4) +{-# INLINE flagManual #-} + +------------------------------------------------------------------------------- +-- ConfVar +------------------------------------------------------------------------------- + +_OS :: Traversal' ConfVar OS +_OS f (OS os) = OS <$> f os +_OS _ x = pure x + +_Arch :: Traversal' ConfVar Arch +_Arch f (Arch arch) = Arch <$> f arch +_Arch _ x = pure x + +_Flag :: Traversal' ConfVar FlagName +_Flag f (Flag flag) = Flag <$> f flag +_Flag _ x = pure x + +_Impl :: Traversal' ConfVar (CompilerFlavor, VersionRange) +_Impl f (Impl cf vr) = uncurry Impl <$> f (cf, vr) +_Impl _ x = pure x diff --git a/Cabal/Distribution/Types/TestSuite.hs b/Cabal/Distribution/Types/TestSuite.hs index 3eab5f81fd8..f8cc190c653 100644 --- a/Cabal/Distribution/Types/TestSuite.hs +++ b/Cabal/Distribution/Types/TestSuite.hs @@ -13,6 +13,7 @@ import Prelude () import Distribution.Compat.Prelude import Distribution.Types.BuildInfo +import Distribution.Types.CommonStanzaImports import Distribution.Types.TestType import Distribution.Types.TestSuiteInterface import Distribution.Types.UnqualComponentName @@ -20,16 +21,21 @@ import Distribution.Types.UnqualComponentName import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.CommonStanzaImports.Lens as L -- | A \"test-suite\" stanza in a cabal file. -- data TestSuite = TestSuite { testName :: UnqualComponentName, + testImports :: CommonStanzaImports, testInterface :: TestSuiteInterface, testBuildInfo :: BuildInfo } deriving (Generic, Show, Read, Eq, Typeable, Data) +instance L.HasCommonStanzaImports TestSuite where + commonStanzaImports f l = (\x -> l { testImports = x }) <$> f (testImports l) + instance L.HasBuildInfo TestSuite where buildInfo f l = (\x -> l { testBuildInfo = x }) <$> f (testBuildInfo l) @@ -41,6 +47,7 @@ instance NFData TestSuite where rnf = genericRnf instance Monoid TestSuite where mempty = TestSuite { testName = mempty, + testImports = mempty, testInterface = mempty, testBuildInfo = mempty } @@ -49,6 +56,7 @@ instance Monoid TestSuite where instance Semigroup TestSuite where a <> b = TestSuite { testName = combine' testName, + testImports = combine testImports, testInterface = combine testInterface, testBuildInfo = combine testBuildInfo } diff --git a/Cabal/Distribution/Types/TestSuite/Lens.hs b/Cabal/Distribution/Types/TestSuite/Lens.hs index 3f7135f37e7..65b1b790f5b 100644 --- a/Cabal/Distribution/Types/TestSuite/Lens.hs +++ b/Cabal/Distribution/Types/TestSuite/Lens.hs @@ -8,6 +8,7 @@ import Distribution.Compat.Prelude import Prelude () import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.CommonStanzaImports (CommonStanzaImports) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.TestSuiteInterface (TestSuiteInterface) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -18,6 +19,10 @@ testName :: Lens' TestSuite UnqualComponentName testName f s = fmap (\x -> s { T.testName = x }) (f (T.testName s)) {-# INLINE testName #-} +testImports :: Lens' TestSuite CommonStanzaImports +testImports f s = fmap (\x -> s { T.testImports = x }) (f (T.testImports s)) +{-# INLINE testImports #-} + testInterface :: Lens' TestSuite TestSuiteInterface testInterface f s = fmap (\x -> s { T.testInterface = x }) (f (T.testInterface s)) {-# INLINE testInterface #-} diff --git a/Cabal/tests/Instances/TreeDiff.hs b/Cabal/tests/Instances/TreeDiff.hs index 7cc54a5d2c3..acf645f96e9 100644 --- a/Cabal/tests/Instances/TreeDiff.hs +++ b/Cabal/tests/Instances/TreeDiff.hs @@ -22,6 +22,8 @@ import Distribution.ModuleName (ModuleName) import Distribution.Package (Dependency, PackageIdentifier, PackageName) import Distribution.PackageDescription import Distribution.Types.AbiHash (AbiHash) +import Distribution.Types.CommonStanza +import Distribution.Types.CommonStanzaImports import Distribution.Types.ComponentId (ComponentId) import Distribution.Types.CondTree import Distribution.Types.ExecutableScope @@ -55,6 +57,8 @@ instance ToExpr BenchmarkInterface instance ToExpr BenchmarkType instance ToExpr BuildInfo instance ToExpr BuildType +instance ToExpr CommonStanza +instance ToExpr CommonStanzaImports instance ToExpr CompilerFlavor instance ToExpr ComponentId where toExpr = defaultExprViaShow instance ToExpr DefUnitId diff --git a/cabal-install/main/Main.hs b/cabal-install/main/Main.hs index 96e9c6e1b64..10fb157c8f5 100644 --- a/cabal-install/main/Main.hs +++ b/cabal-install/main/Main.hs @@ -150,6 +150,10 @@ import Distribution.PackageDescription ( BuildType(..), Executable(..), buildable ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) +import Distribution.PackageDescription.PackageSourceDescriptionParser + ( readPackageSourceDescription) +import Distribution.PackageDescription.PackageSourceDescriptionPrettyPrint + ( writePackageSourceDescription) import Distribution.PackageDescription.PrettyPrint ( writeGenericPackageDescription ) import qualified Distribution.Simple as Simple @@ -1034,9 +1038,9 @@ formatAction verbosityFlag extraArgs _globalFlags = do [] -> do cwd <- getCurrentDirectory tryFindPackageDesc verbosity cwd (p:_) -> return p - pkgDesc <- readGenericPackageDescription verbosity path + pkgDesc <- readPackageSourceDescription verbosity path -- Uses 'writeFileAtomic' under the hood. - writeGenericPackageDescription path pkgDesc + writePackageSourceDescription path pkgDesc uninstallAction :: Flag Verbosity -> [String] -> Action uninstallAction verbosityFlag extraArgs _globalFlags = do