module Distribution.PackageDescription.Parsec (
readGenericPackageDescription,
parseGenericPackageDescription,
parseGenericPackageDescriptionMaybe,
ParseResult,
runParseResult,
scanSpecVersion,
readHookedBuildInfo,
parseHookedBuildInfo,
) where
import Distribution.Compat.Prelude
import Prelude ()
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.PackageDescription
import Distribution.PackageDescription.FieldGrammar
import Distribution.PackageDescription.Quirks (patchQuirks)
import Distribution.Parsec.Class (parsec, simpleParsec)
import Distribution.Parsec.Common
import Distribution.Parsec.ConfVar (parseConditionConfVar)
import Distribution.Parsec.Field (FieldName, getName)
import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
import Distribution.Parsec.LexerMonad (LexWarning, toPWarnings)
import Distribution.Parsec.Newtypes (CommaFSep, List, SpecVersion (..), Token)
import Distribution.Parsec.Parser
import Distribution.Parsec.ParseResult
import Distribution.Pretty (prettyShow)
import Distribution.Simple.Utils (fromUTF8BS)
import Distribution.Text (display)
import Distribution.Types.CondTree
import Distribution.Types.Dependency (Dependency)
import Distribution.Types.ForeignLib
import Distribution.Types.ForeignLibType (knownForeignLibTypes)
import Distribution.Types.GenericPackageDescription (emptyGenericPackageDescription)
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 Distribution.Compat.Newtype as Newtype
import qualified Distribution.Types.BuildInfo.Lens as L
import qualified Distribution.Types.GenericPackageDescription.Lens as L
import qualified Distribution.Types.PackageDescription.Lens as L
import qualified Text.Parsec as P
readGenericPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
readGenericPackageDescription = readAndParseFile parseGenericPackageDescription
parseGenericPackageDescription :: BS.ByteString -> ParseResult GenericPackageDescription
parseGenericPackageDescription bs = do
setCabalSpecVersion ver
case ver of
Just v | v > mkVersion [2,4] -> 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"
parseGenericPackageDescription' ver lexWarnings (validateUTF8 bs') fs
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'
parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription
parseGenericPackageDescriptionMaybe =
either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
type SectionParser = StateT SectionS ParseResult
data SectionS = SectionS
{ _stateGpd :: !GenericPackageDescription
, _stateCommonStanzas :: !(Map String CondTreeBuildInfo)
}
stateGpd :: Lens' SectionS GenericPackageDescription
stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd
stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo)
stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs
parseGenericPackageDescription'
:: Maybe Version
-> [LexWarning]
-> Maybe Int
-> [Field Position]
-> ParseResult GenericPackageDescription
parseGenericPackageDescription' 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'
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
| cabalVer >= mkVersion [2,3] = CabalSpecV2_4
| cabalVer >= mkVersion [2,1] = CabalSpecV2_2
| cabalVer >= mkVersion [1,25] = CabalSpecV2_0
| cabalVer >= mkVersion [1,23] = CabalSpecV1_24
| cabalVer >= mkVersion [1,21] = CabalSpecV1_22
| otherwise = CabalSpecOld
setCabalSpecVersion (Just cabalVer)
pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar
unless (cabalVer == specVersion pd) $ parseFailure zeroPos $
"Scanned and parsed cabal-versions don't match " ++
prettyShow cabalVer ++ " /= " ++ prettyShow (specVersion pd)
maybeWarnCabalVersion syntax pd
let gpd = emptyGenericPackageDescription & L.packageDescription .~ pd
view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty)
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) = display version
displaySpecVersion (Right versionRange) =
case asVersionIntervals versionRange of
[] -> display versionRange
((LowerBound version _, _):_) -> display (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
parseCondTree'
:: FromBuildInfo a
=> ParsecFieldGrammar' a
-> Map String CondTreeBuildInfo
-> [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
biTree <- lift $ parseCondTree' buildInfoFieldGrammar commonStanzas fields
case Map.lookup name' commonStanzas of
Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas
Just _ -> lift $ parseFailure pos $
"Duplicate common stanza: " ++ name'
| name == "library" && null args = do
commonStanzas <- use stateCommonStanzas
lib <- lift $ parseCondTree' (libraryFieldGrammar Nothing) commonStanzas fields
stateGpd . L.condLibrary ?= lib
| name == "library" = do
commonStanzas <- use stateCommonStanzas
name' <- parseUnqualComponentName pos args
lib <- lift $ parseCondTree' (libraryFieldGrammar $ Just name') commonStanzas fields
stateGpd . L.condSubLibraries %= snoc (name', lib)
| 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 (display name')
, " is missing required field \"type\" or the field "
, "is not present in all conditional branches. The "
, "available test types are: "
, intercalate ", " (map display knownForeignLibTypes)
]
stateGpd . L.condForeignLibs %= snoc (name', flib)
| name == "executable" = do
commonStanzas <- use stateCommonStanzas
name' <- parseUnqualComponentName pos args
exe <- lift $ parseCondTree' (executableFieldGrammar name') commonStanzas fields
stateGpd . 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 (display name')
, " is missing required field \"type\" or the field "
, "is not present in all conditional branches. The "
, "available test types are: "
, intercalate ", " (map display knownTestTypes)
]
stateGpd . 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 (display name')
, " is missing required field \"type\" or the field "
, "is not present in all conditional branches. The "
, "available benchmark types are: "
, intercalate ", " (map display knownBenchmarkTypes)
]
stateGpd . L.condBenchmarks %= snoc (name', bench)
| name == "flag" = do
name' <- parseNameBS pos args
name'' <- lift $ runFieldParser' pos parsec specVer (fieldLineStreamFromBS name') `recoverWith` mkFlagName ""
flag <- lift $ parseFields specVer fields (flagFieldGrammar name'')
stateGpd . L.genPackageFlags %= snoc flag
| name == "custom-setup" && null args = do
sbi <- lift $ parseFields specVer fields (setupBInfoFieldGrammar False)
stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi
| name == "source-repository" = do
kind <- lift $ case args of
[SecArgName spos secName] ->
runFieldParser' spos parsec specVer (fieldLineStreamFromBS secName) `recoverWith` RepoHead
[] -> do
parseFailure pos "'source-repository' requires exactly one argument"
pure RepoHead
_ -> do
parseFailure pos $ "Invalid source-repository kind " ++ show args
pure RepoHead
sr <- lift $ parseFields specVer fields (sourceRepoFieldGrammar kind)
stateGpd . L.packageDescription . L.sourceRepos %= snoc sr
| otherwise = lift $
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
parseName :: Position -> [SectionArg Position] -> SectionParser String
parseName pos args = fromUTF8BS <$> parseNameBS pos args
parseNameBS :: Position -> [SectionArg Position] -> SectionParser BS.ByteString
parseNameBS pos args = case args of
[SecArgName _pos secName] ->
pure secName
[SecArgStr _pos secName] ->
pure secName
[] -> do
lift $ parseFailure pos "name required"
pure ""
_ -> do
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
parseFailure pos $ "Invalid name " ++ show args
pure ""
parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
parseFields
:: CabalSpecVersion
-> [Field Position]
-> 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 c.
CabalSpecVersion
-> HasElif
-> ParsecFieldGrammar' a
-> (a -> c)
-> [Field Position]
-> ParseResult (CondTree ConfVar c a)
parseCondTree v hasElif grammar cond = go
where
go fields = do
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 c 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 c a), [CondBranch ConfVar c 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
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
type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo
class L.HasBuildInfo a => FromBuildInfo a where
fromBuildInfo :: BuildInfo -> a
instance FromBuildInfo BuildInfo where fromBuildInfo = id
instance FromBuildInfo Library where fromBuildInfo bi = set L.buildInfo bi emptyLibrary
instance FromBuildInfo ForeignLib where fromBuildInfo bi = set L.buildInfo bi emptyForeignLib
instance FromBuildInfo Executable where fromBuildInfo bi = set L.buildInfo bi emptyExecutable
instance FromBuildInfo TestSuiteStanza where
fromBuildInfo = TestSuiteStanza Nothing Nothing Nothing
instance FromBuildInfo BenchmarkStanza where
fromBuildInfo = BenchmarkStanza Nothing Nothing Nothing
parseCondTreeWithCommonStanzas
:: forall a. FromBuildInfo a
=> CabalSpecVersion
-> ParsecFieldGrammar' a
-> Map String CondTreeBuildInfo
-> [Field Position]
-> ParseResult (CondTree ConfVar [Dependency] a)
parseCondTreeWithCommonStanzas v grammar commonStanzas = goImports []
where
hasElif = specHasElif v
hasCommonStanzas = specHasCommonStanzas v
getList' :: List CommaFSep Token String -> [String]
getList' = Newtype.unpack
goImports acc (Field (Name pos name) _ : fields) | name == "import", hasCommonStanzas == NoCommonStanzas = do
parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas"
goImports acc fields
goImports acc (Field (Name pos name) fls : fields) | name == "import" = do
names <- getList' <$> runFieldParser pos parsec v fls
names' <- for names $ \commonName ->
case Map.lookup commonName commonStanzas of
Nothing -> do
parseFailure pos $ "Undefined common stanza imported: " ++ commonName
pure Nothing
Just commonTree ->
pure (Just commonTree)
goImports (acc ++ catMaybes names') fields
goImports acc fields = go acc fields
go :: [CondTreeBuildInfo] -> [Field Position] -> ParseResult (CondTree ConfVar [Dependency] a)
go bis fields = do
x <- parseCondTree v hasElif grammar (view L.targetBuildDepends) fields
pure $ foldr mergeCommonStanza x bis
mergeCommonStanza
:: forall a. FromBuildInfo a
=> CondTree ConfVar [Dependency] BuildInfo
-> CondTree ConfVar [Dependency] a
-> CondTree ConfVar [Dependency] a
mergeCommonStanza (CondNode bi _ bis) (CondNode x _ cs) =
CondNode x' (x' ^. L.targetBuildDepends) cs'
where
x' = x & L.buildInfo %~ (bi <>)
cs' = map (fmap fromBuildInfo) bis ++ cs
onAllBranches :: forall v c a. Monoid a => (a -> Bool) -> CondTree v c a -> Bool
onAllBranches p = go mempty
where
go :: a -> CondTree v c a -> Bool
go acc ct = let acc' = acc `mappend` condTreeData ct
in p acc' || any (goBranch acc') (condTreeComponents ct)
goBranch :: a -> CondBranch v c a -> Bool
goBranch _ (CondBranch _ _ Nothing) = False
goBranch acc (CondBranch _ t (Just e)) = go acc t && go acc e
sectionizeFields :: [Field ann] -> (Syntax, [Field ann])
sectionizeFields fs = case classifyFields fs of
Just fields -> (OldSyntax, convert fields)
Nothing -> (NewSyntax, fs)
where
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
(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
data Syntax = OldSyntax | NewSyntax
deriving (Eq, Show)
libFieldNames :: [FieldName]
libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar Nothing)
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
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
scanSpecVersion :: BS.ByteString -> Maybe Version
scanSpecVersion bs = do
fstline':_ <- pure (BS8.lines bs)
let fstline = BS.map toLowerW8 $ BS.filter (/= 0x20) fstline'
["cabal-version",vers] <- pure (BS8.split ':' fstline)
ver <- simpleParsec (BS8.unpack vers)
guard $ case versionNumbers ver of
[_,_] -> True
[_,_,_] -> True
_ -> False
pure ver
where
toLowerW8 :: Word8 -> Word8
toLowerW8 w | 0x40 < w && w < 0x5b = w+0x20
| otherwise = w