{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

-- | Parsing project configuration.
module Distribution.Client.ProjectConfig.Parsec
  ( -- * Package configuration
    parseProject
  , ProjectConfig (..)

    -- ** Parsing
  , ParseResult
  , runParseResult
  ) where

import Distribution.CabalSpecVersion
import Distribution.Client.HttpUtils
import Distribution.Client.ProjectConfig.FieldGrammar (packageConfigFieldGrammar, projectConfigFieldGrammar)
import Distribution.Client.ProjectConfig.Import (ProjectConfigSkeleton, cyclicalImportMsg, fetchImport, untrimmedUriImportMsg)
import qualified Distribution.Client.ProjectConfig.Lens as L
import Distribution.Client.ProjectConfig.Types
import Distribution.Client.Types.Repo hiding (repoName)
import Distribution.Client.Types.RepoName (RepoName (..))
import Distribution.Client.Types.SourceRepo (sourceRepositoryPackageGrammar)
import Distribution.Client.Utils.Parsec
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Distribution.FieldGrammar
import Distribution.FieldGrammar.Parsec (NamelessField (..), namelessFieldAnn)
import Distribution.Fields (Field (..), FieldLine (..), FieldName, Name (..), SectionArg (..), readFields')
import Distribution.Fields.ConfVar (parseConditionConfVar)
import Distribution.Fields.Field (fieldLinesToString, sectionArgAnn)
import Distribution.Fields.LexerMonad (toPWarnings)
import Distribution.Fields.ParseResult
import Distribution.Parsec (ParsecParser, eitherParsec, parsec, parsecFilePath, runParsecParser)
import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
import Distribution.Parsec.Position (Position (..), incPos, zeroPos)
import Distribution.Parsec.Warning (PWarnType (..))
import Distribution.Simple.Program.Db (ProgramDb, defaultProgramDb, knownPrograms, lookupKnownProgram)
import Distribution.Simple.Program.Types (programName)
import Distribution.Simple.Setup
import Distribution.Simple.Utils (debug, noticeDoc)
import Distribution.Solver.Types.ProjectConfigPath
import Distribution.System (buildOS)
import Distribution.Types.CondTree (CondBranch (..), CondTree (..))
import Distribution.Types.ConfVar (ConfVar (..))
import Distribution.Types.PackageName (PackageName)
import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8)
import Distribution.Utils.NubList (toNubList)
import Distribution.Verbosity

import Control.Monad.State.Strict (StateT, execStateT, lift)
import qualified Data.ByteString as BS
import Data.Functor ((<&>))
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Distribution.Client.Errors.Parser (ProjectFileSource (..))
import qualified Distribution.Compat.CharParsing as P
import Network.URI (URI, uriFragment, uriPath, uriScheme)
import System.Directory (makeAbsolute)
import System.FilePath (splitFileName)
import qualified Text.Parsec
import Text.PrettyPrint (render)
import qualified Text.PrettyPrint as Disp

singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton :: ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton ProjectConfig
x = ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> [CondBranch
      ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
-> ProjectConfigSkeleton
forall v a. a -> [CondBranch v a] -> CondTree v a
CondNode ([(Maybe URI, ProjectConfigPath)]
forall a. Monoid a => a
mempty, ProjectConfig
x) [CondBranch
   ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
forall a. Monoid a => a
mempty

readPreprocessFields :: BS.ByteString -> ParseResult src [Field Position]
readPreprocessFields :: forall src. ByteString -> ParseResult src [Field Position]
readPreprocessFields ByteString
bs = do
  case ByteString -> Either ParseError ([Field Position], [LexWarning])
readFields' ByteString
bs' of
    Right ([Field Position]
fs, [LexWarning]
lexWarnings) -> do
      [PWarning] -> ParseResult src ()
forall src. [PWarning] -> ParseResult src ()
parseWarnings ([LexWarning] -> [PWarning]
toPWarnings [LexWarning]
lexWarnings)
      Maybe Int -> (Int -> ParseResult src ()) -> ParseResult src ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe Int
invalidUtf8 ((Int -> ParseResult src ()) -> ParseResult src ())
-> (Int -> ParseResult src ()) -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ \Int
pos ->
        Position -> PWarnType -> FilePath -> ParseResult src ()
forall src. Position -> PWarnType -> FilePath -> ParseResult src ()
parseWarning Position
zeroPos PWarnType
PWTUTF (FilePath -> ParseResult src ()) -> FilePath -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ FilePath
"UTF8 encoding problem at byte offset " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
pos
      [Field Position] -> ParseResult src [Field Position]
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return [Field Position]
fs
    Left ParseError
perr -> Position -> FilePath -> ParseResult src [Field Position]
forall src a. Position -> FilePath -> ParseResult src a
parseFatalFailure Position
pos (ParseError -> FilePath
forall a. Show a => a -> FilePath
show ParseError
perr)
      where
        ppos :: SourcePos
ppos = ParseError -> SourcePos
Text.Parsec.errorPos ParseError
perr
        pos :: Position
pos = Int -> Int -> Position
Position (SourcePos -> Int
Text.Parsec.sourceLine SourcePos
ppos) (SourcePos -> Int
Text.Parsec.sourceColumn SourcePos
ppos)
  where
    invalidUtf8 :: Maybe Int
invalidUtf8 = ByteString -> Maybe Int
validateUTF8 ByteString
bs
    bs' :: ByteString
bs' = case Maybe Int
invalidUtf8 of
      Maybe Int
Nothing -> ByteString
bs
      Just Int
_ -> FilePath -> ByteString
toUTF8BS (ByteString -> FilePath
fromUTF8BS ByteString
bs)

-- | Parses a project from its root config file, typically cabal.project.
parseProject
  :: FilePath
  -- ^ The root of the project configuration, typically cabal.project
  -> FilePath
  -> HttpTransport
  -> Verbosity
  -> ProjectConfigToParse
  -- ^ The contents of the file to parse
  -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
parseProject :: FilePath
-> FilePath
-> HttpTransport
-> Verbosity
-> ProjectConfigToParse
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
parseProject FilePath
rootPath FilePath
cacheDir HttpTransport
httpTransport Verbosity
verbosity ProjectConfigToParse
configToParse = do
  let (FilePath
dir, FilePath
projectFileName) = FilePath -> (FilePath, FilePath)
splitFileName FilePath
rootPath
  projectDir <- FilePath -> IO FilePath
makeAbsolute FilePath
dir
  projectPath <- canonicalizeConfigPath projectDir (ProjectConfigPath $ projectFileName :| [])
  parseProjectSkeleton cacheDir httpTransport verbosity projectDir projectPath configToParse

parseProjectSkeleton
  :: FilePath
  -> HttpTransport
  -> Verbosity
  -> FilePath
  -- ^ The directory of the project configuration, typically the directory of cabal.project
  -> ProjectConfigPath
  -- ^ The path of the file being parsed, either the root or an import
  -> ProjectConfigToParse
  -- ^ The contents of the file to parse
  -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
parseProjectSkeleton :: FilePath
-> HttpTransport
-> Verbosity
-> FilePath
-> ProjectConfigPath
-> ProjectConfigToParse
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
parseProjectSkeleton FilePath
cacheDir HttpTransport
httpTransport Verbosity
verbosity FilePath
projectDir ProjectConfigPath
source (ProjectConfigToParse ByteString
bs) = do
  normSource <- FilePath -> ProjectConfigPath -> IO ProjectConfigPath
canonicalizeConfigPath FilePath
projectDir ProjectConfigPath
source
  res <- (sanityWalkPCS False =<<) <$> liftParseResult (go []) (readPreprocessFields bs)
  pure $ withSource (ProjectFileSource (normSource, bs)) res
  where
    go :: [Field Position] -> [Field Position] -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
    go :: [Field Position]
-> [Field Position]
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
go [Field Position]
acc (Field Position
x : [Field Position]
xs) = case Field Position
x of
      (Field (Name Position
pos ByteString
name) [FieldLine Position]
importLines) | ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"import" -> do
        (FilePath
 -> IO (ParseResult ProjectFileSource ProjectConfigSkeleton))
-> ParseResult ProjectFileSource FilePath
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
forall a src b.
(a -> IO (ParseResult src b))
-> ParseResult src a -> IO (ParseResult src b)
liftParseResult
          ( \FilePath
importLoc -> do
              let importLocPath :: ProjectConfigPath
importLocPath = FilePath
importLoc FilePath -> ProjectConfigPath -> ProjectConfigPath
`consProjectConfigPath` ProjectConfigPath
source

              -- Once we canonicalize the import path, we can check for cyclical imports
              normSource <- FilePath -> ProjectConfigPath -> IO ProjectConfigPath
canonicalizeConfigPath FilePath
projectDir ProjectConfigPath
source
              normLocPath <- canonicalizeConfigPath projectDir importLocPath
              debug verbosity $ "\nimport path, normalized\n=======================\n" ++ render (docProjectConfigPath normLocPath)

              if isCyclicConfigPath normLocPath
                then pure $ parseFatalFailure pos (render $ cyclicalImportMsg normLocPath)
                else do
                  when
                    (isUntrimmedUriConfigPath importLocPath)
                    (noticeDoc verbosity $ untrimmedUriImportMsg (Disp.text "Warning:") importLocPath)
                  let parser = FilePath
-> HttpTransport
-> Verbosity
-> FilePath
-> ProjectConfigPath
-> ProjectConfigToParse
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
parseProjectSkeleton FilePath
cacheDir HttpTransport
httpTransport Verbosity
verbosity FilePath
projectDir ProjectConfigPath
importLocPath
                  (mbUri, importParseResult) <- fetchImport parser cacheDir httpTransport verbosity projectDir normLocPath
                  rest <- go [] xs
                  let fs = (\ProjectConfig
z -> ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> [CondBranch v ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
-> CondTree v ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall v a. a -> [CondBranch v a] -> CondTree v a
CondNode ([(Maybe URI
mbUri, ProjectConfigPath
normLocPath)], ProjectConfig
z) [CondBranch v ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
forall a. Monoid a => a
mempty) (ProjectConfig
 -> CondTree v ([(Maybe URI, ProjectConfigPath)], ProjectConfig))
-> ParseResult ProjectFileSource ProjectConfig
-> ParseResult
     ProjectFileSource
     (CondTree v ([(Maybe URI, ProjectConfigPath)], ProjectConfig))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectConfigPath
-> [Field Position] -> ParseResult ProjectFileSource ProjectConfig
fieldsToConfig ProjectConfigPath
normSource ([Field Position] -> [Field Position]
forall a. [a] -> [a]
reverse [Field Position]
acc)
                  pure . fmap mconcat . sequence $ [fs, importParseResult, rest]
          )
          (Position
-> [FieldLine Position] -> ParseResult ProjectFileSource FilePath
parseImport Position
pos [FieldLine Position]
importLines)
      (Section (Name Position
pos ByteString
"if") [SectionArg Position]
args [Field Position]
xs') -> do
        subpcs <- [Field Position]
-> [Field Position]
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
go [] [Field Position]
xs'
        let fs = (ProjectConfig -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource ProjectConfig
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a b.
(a -> b)
-> ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProjectConfig -> ProjectConfigSkeleton
singletonProjectConfigSkeleton (ParseResult ProjectFileSource ProjectConfig
 -> ParseResult ProjectFileSource ProjectConfigSkeleton)
-> ParseResult ProjectFileSource ProjectConfig
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a b. (a -> b) -> a -> b
$ ProjectConfigPath
-> [Field Position] -> ParseResult ProjectFileSource ProjectConfig
fieldsToConfig ProjectConfigPath
source ([Field Position] -> [Field Position]
forall a. [a] -> [a]
reverse [Field Position]
acc)
        (elseClauses, rest) <- parseElseClauses xs
        let condNode =
              (\Condition ConfVar
c ProjectConfigSkeleton
pcs Maybe ProjectConfigSkeleton
e -> ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> [CondBranch
      ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
-> ProjectConfigSkeleton
forall v a. a -> [CondBranch v a] -> CondTree v a
CondNode ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall a. Monoid a => a
mempty [Condition ConfVar
-> ProjectConfigSkeleton
-> Maybe ProjectConfigSkeleton
-> CondBranch
     ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall v a.
Condition v
-> CondTree v a -> Maybe (CondTree v a) -> CondBranch v a
CondBranch Condition ConfVar
c ProjectConfigSkeleton
pcs Maybe ProjectConfigSkeleton
e])
                (Condition ConfVar
 -> ProjectConfigSkeleton
 -> Maybe ProjectConfigSkeleton
 -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource (Condition ConfVar)
-> ParseResult
     ProjectFileSource
     (ProjectConfigSkeleton
      -> Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> [SectionArg Position]
-> ParseResult ProjectFileSource (Condition ConfVar)
forall src.
Position
-> [SectionArg Position] -> ParseResult src (Condition ConfVar)
parseConditionConfVar (Position -> [SectionArg Position] -> Position
startOfSection (Int -> Position -> Position
incPos Int
2 Position
pos) [SectionArg Position]
args) [SectionArg Position]
args
                ParseResult
  ProjectFileSource
  (ProjectConfigSkeleton
   -> Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource ProjectConfigSkeleton
-> ParseResult
     ProjectFileSource
     (Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
forall a b.
ParseResult ProjectFileSource (a -> b)
-> ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseResult ProjectFileSource ProjectConfigSkeleton
subpcs
                ParseResult
  ProjectFileSource
  (Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton)
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a b.
ParseResult ProjectFileSource (a -> b)
-> ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton)
elseClauses
        pure . fmap mconcat . sequence $ [fs, condNode, rest]
      Field Position
_ -> [Field Position]
-> [Field Position]
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
go (Field Position
x Field Position -> [Field Position] -> [Field Position]
forall a. a -> [a] -> [a]
: [Field Position]
acc) [Field Position]
xs
    go [Field Position]
acc [] = do
      normSource <- FilePath -> ProjectConfigPath -> IO ProjectConfigPath
canonicalizeConfigPath FilePath
projectDir ProjectConfigPath
source
      pure . fmap singletonProjectConfigSkeleton . fieldsToConfig normSource $ reverse acc

    parseElseClauses :: [Field Position] -> IO (ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton), ParseResult ProjectFileSource ProjectConfigSkeleton)
    parseElseClauses :: [Field Position]
-> IO
     (ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton),
      ParseResult ProjectFileSource ProjectConfigSkeleton)
parseElseClauses [Field Position]
x = case [Field Position]
x of
      (Section (Name Position
_pos ByteString
"else") [SectionArg Position]
_args [Field Position]
xs' : [Field Position]
xs) -> do
        subpcs <- [Field Position]
-> [Field Position]
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
go [] [Field Position]
xs'
        rest <- go [] xs
        pure (Just <$> subpcs, rest)
      (Section (Name Position
pos ByteString
"elif") [SectionArg Position]
args [Field Position]
xs' : [Field Position]
xs) -> do
        subpcs <- [Field Position]
-> [Field Position]
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
go [] [Field Position]
xs'
        (elseClauses, rest) <- parseElseClauses xs
        let condNode =
              (\Condition ConfVar
c ProjectConfigSkeleton
pcs Maybe ProjectConfigSkeleton
e -> ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> [CondBranch
      ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
-> ProjectConfigSkeleton
forall v a. a -> [CondBranch v a] -> CondTree v a
CondNode ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall a. Monoid a => a
mempty [Condition ConfVar
-> ProjectConfigSkeleton
-> Maybe ProjectConfigSkeleton
-> CondBranch
     ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
forall v a.
Condition v
-> CondTree v a -> Maybe (CondTree v a) -> CondBranch v a
CondBranch Condition ConfVar
c ProjectConfigSkeleton
pcs Maybe ProjectConfigSkeleton
e])
                (Condition ConfVar
 -> ProjectConfigSkeleton
 -> Maybe ProjectConfigSkeleton
 -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource (Condition ConfVar)
-> ParseResult
     ProjectFileSource
     (ProjectConfigSkeleton
      -> Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Position
-> [SectionArg Position]
-> ParseResult ProjectFileSource (Condition ConfVar)
forall src.
Position
-> [SectionArg Position] -> ParseResult src (Condition ConfVar)
parseConditionConfVar (Position -> [SectionArg Position] -> Position
startOfSection (Int -> Position -> Position
incPos Int
4 Position
pos) [SectionArg Position]
args) [SectionArg Position]
args
                ParseResult
  ProjectFileSource
  (ProjectConfigSkeleton
   -> Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource ProjectConfigSkeleton
-> ParseResult
     ProjectFileSource
     (Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
forall a b.
ParseResult ProjectFileSource (a -> b)
-> ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseResult ProjectFileSource ProjectConfigSkeleton
subpcs
                ParseResult
  ProjectFileSource
  (Maybe ProjectConfigSkeleton -> ProjectConfigSkeleton)
-> ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton)
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a b.
ParseResult ProjectFileSource (a -> b)
-> ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton)
elseClauses
        pure (Just <$> condNode, rest)
      [Field Position]
_ -> (Maybe ProjectConfigSkeleton
-> ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton)
forall a. a -> ParseResult ProjectFileSource a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ProjectConfigSkeleton
forall a. Maybe a
Nothing,) (ParseResult ProjectFileSource ProjectConfigSkeleton
 -> (ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton),
     ParseResult ProjectFileSource ProjectConfigSkeleton))
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
-> IO
     (ParseResult ProjectFileSource (Maybe ProjectConfigSkeleton),
      ParseResult ProjectFileSource ProjectConfigSkeleton)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Field Position]
-> [Field Position]
-> IO (ParseResult ProjectFileSource ProjectConfigSkeleton)
go [] [Field Position]
x

    parseImport :: Position -> [FieldLine Position] -> ParseResult ProjectFileSource FilePath
    parseImport :: Position
-> [FieldLine Position] -> ParseResult ProjectFileSource FilePath
parseImport Position
pos [FieldLine Position]
lines' = Position
-> ParsecParser FilePath
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult ProjectFileSource FilePath
forall a src.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
runFieldParser Position
pos (ParsecParser Char -> ParsecParser FilePath
forall a. ParsecParser a -> ParsecParser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
P.many ParsecParser Char
forall (m :: * -> *). CharParsing m => m Char
P.anyChar) CabalSpecVersion
cabalSpec [FieldLine Position]
lines'

    -- We want a normalized path for @fieldsToConfig@. This eventually surfaces
    -- in solver rejection messages and build messages "this build was affected
    -- by the following (project) config files" so we want all paths shown there
    -- to be relative to the directory of the project, not relative to the file
    -- they were imported from.
    fieldsToConfig :: ProjectConfigPath -> [Field Position] -> ParseResult ProjectFileSource ProjectConfig
    fieldsToConfig :: ProjectConfigPath
-> [Field Position] -> ParseResult ProjectFileSource ProjectConfig
fieldsToConfig ProjectConfigPath
sourceConfigPath [Field Position]
xs = do
      let (Fields Position
fs, [[Section Position]]
sectionGroups) = [Field Position] -> (Fields Position, [[Section Position]])
forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
xs
          sections :: [Section Position]
sections = [[Section Position]] -> [Section Position]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Section Position]]
sectionGroups
      config <- CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar ProjectConfig ProjectConfig
-> Set ByteString
-> ParseResult ProjectFileSource ProjectConfig
forall s a src.
CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar s a
-> Set ByteString
-> ParseResult src a
parseFieldGrammarCheckingStanzas CabalSpecVersion
cabalSpec Fields Position
fs (ProjectConfigPath
-> [FilePath] -> ParsecFieldGrammar ProjectConfig ProjectConfig
projectConfigFieldGrammar ProjectConfigPath
sourceConfigPath (ProgramDb -> [FilePath]
knownProgramNames ProgramDb
programDb)) Set ByteString
stanzas
      config' <- view stateConfig <$> execStateT (goSections programDb sections) (SectionS config)
      return config'
    modifiesCompiler :: ProjectConfig -> Bool
    modifiesCompiler :: ProjectConfig -> Bool
modifiesCompiler ProjectConfig
pc = (ProjectConfigShared -> Last CompilerFlavor) -> Bool
forall {a}. Eq a => (ProjectConfigShared -> Last a) -> Bool
isSet ProjectConfigShared -> Last CompilerFlavor
projectConfigHcFlavor Bool -> Bool -> Bool
|| (ProjectConfigShared -> Last FilePath) -> Bool
forall {a}. Eq a => (ProjectConfigShared -> Last a) -> Bool
isSet ProjectConfigShared -> Last FilePath
projectConfigHcPath Bool -> Bool -> Bool
|| (ProjectConfigShared -> Last FilePath) -> Bool
forall {a}. Eq a => (ProjectConfigShared -> Last a) -> Bool
isSet ProjectConfigShared -> Last FilePath
projectConfigHcPkg
      where
        isSet :: (ProjectConfigShared -> Last a) -> Bool
isSet ProjectConfigShared -> Last a
f = ProjectConfigShared -> Last a
f (ProjectConfig -> ProjectConfigShared
projectConfigShared ProjectConfig
pc) Last a -> Last a -> Bool
forall a. Eq a => a -> a -> Bool
/= Last a
forall a. Last a
NoFlag

    sanityWalkPCS :: Bool -> ProjectConfigSkeleton -> ParseResult ProjectFileSource ProjectConfigSkeleton
    sanityWalkPCS :: Bool
-> ProjectConfigSkeleton
-> ParseResult ProjectFileSource ProjectConfigSkeleton
sanityWalkPCS Bool
underConditional t :: ProjectConfigSkeleton
t@(CondNode ([(Maybe URI, ProjectConfigPath)]
_c, ProjectConfig
d) [CondBranch
   ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
comps)
      | Bool
underConditional Bool -> Bool -> Bool
&& ProjectConfig -> Bool
modifiesCompiler ProjectConfig
d = Position
-> FilePath -> ParseResult ProjectFileSource ProjectConfigSkeleton
forall src a. Position -> FilePath -> ParseResult src a
parseFatalFailure Position
zeroPos FilePath
"Cannot set compiler in a conditional clause of a cabal project file"
      | Bool
otherwise = (CondBranch
   ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
 -> ParseResult ProjectFileSource ())
-> [CondBranch
      ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
-> ParseResult ProjectFileSource ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CondBranch
  ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> ParseResult ProjectFileSource ()
sanityWalkBranch [CondBranch
   ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)]
comps ParseResult ProjectFileSource ()
-> ParseResult ProjectFileSource ProjectConfigSkeleton
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a b.
ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
-> ParseResult ProjectFileSource b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ProjectConfigSkeleton
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a. a -> ParseResult ProjectFileSource a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectConfigSkeleton
t

    sanityWalkBranch :: CondBranch ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig) -> ParseResult ProjectFileSource ()
    sanityWalkBranch :: CondBranch
  ConfVar ([(Maybe URI, ProjectConfigPath)], ProjectConfig)
-> ParseResult ProjectFileSource ()
sanityWalkBranch (CondBranch Condition ConfVar
_c ProjectConfigSkeleton
t Maybe ProjectConfigSkeleton
f) = (ProjectConfigSkeleton
 -> ParseResult ProjectFileSource ProjectConfigSkeleton)
-> Maybe ProjectConfigSkeleton -> ParseResult ProjectFileSource ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Bool
-> ProjectConfigSkeleton
-> ParseResult ProjectFileSource ProjectConfigSkeleton
sanityWalkPCS Bool
True) Maybe ProjectConfigSkeleton
f ParseResult ProjectFileSource ()
-> ParseResult ProjectFileSource ProjectConfigSkeleton
-> ParseResult ProjectFileSource ProjectConfigSkeleton
forall a b.
ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
-> ParseResult ProjectFileSource b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool
-> ProjectConfigSkeleton
-> ParseResult ProjectFileSource ProjectConfigSkeleton
sanityWalkPCS Bool
True ProjectConfigSkeleton
t ParseResult ProjectFileSource ProjectConfigSkeleton
-> ParseResult ProjectFileSource ()
-> ParseResult ProjectFileSource ()
forall a b.
ParseResult ProjectFileSource a
-> ParseResult ProjectFileSource b
-> ParseResult ProjectFileSource b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ParseResult ProjectFileSource ()
forall a. a -> ParseResult ProjectFileSource a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

    programDb :: ProgramDb
programDb = ProgramDb
defaultProgramDb

startOfSection :: Position -> [SectionArg Position] -> Position
-- The case where we have no args is the start of the section
startOfSection :: Position -> [SectionArg Position] -> Position
startOfSection Position
defaultPos [] = Position
defaultPos
-- Otherwise the start of the section is the position of the first argument.
startOfSection Position
_ (SectionArg Position
cond : [SectionArg Position]
_) = SectionArg Position -> Position
forall ann. SectionArg ann -> ann
sectionArgAnn SectionArg Position
cond

knownProgramNames :: ProgramDb -> [String]
knownProgramNames :: ProgramDb -> [FilePath]
knownProgramNames ProgramDb
programDb = Program -> FilePath
programName (Program -> FilePath)
-> ((Program, Maybe ConfiguredProgram) -> Program)
-> (Program, Maybe ConfiguredProgram)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Program, Maybe ConfiguredProgram) -> Program
forall a b. (a, b) -> a
fst ((Program, Maybe ConfiguredProgram) -> FilePath)
-> [(Program, Maybe ConfiguredProgram)] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProgramDb -> [(Program, Maybe ConfiguredProgram)]
knownPrograms ProgramDb
programDb

-- | Monad in which sections are parsed
type SectionParser src = StateT SectionS (ParseResult src)

-- | State of 'SectionParser'
newtype SectionS = SectionS
  { SectionS -> ProjectConfig
_stateConfig :: ProjectConfig
  }

stateConfig :: Lens' SectionS ProjectConfig
stateConfig :: Lens' SectionS ProjectConfig
stateConfig ProjectConfig -> f ProjectConfig
f (SectionS ProjectConfig
cfg) = ProjectConfig -> SectionS
SectionS (ProjectConfig -> SectionS) -> f ProjectConfig -> f SectionS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectConfig -> f ProjectConfig
f ProjectConfig
cfg
{-# INLINEABLE stateConfig #-}

goSections :: ProgramDb -> [Section Position] -> SectionParser src ()
goSections :: forall src. ProgramDb -> [Section Position] -> SectionParser src ()
goSections ProgramDb
programDb = (Section Position -> StateT SectionS (ParseResult src) ())
-> [Section Position] -> StateT SectionS (ParseResult src) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ProgramDb
-> Section Position -> StateT SectionS (ParseResult src) ()
forall src. ProgramDb -> Section Position -> SectionParser src ()
parseSection ProgramDb
programDb)

parseSection :: ProgramDb -> Section Position -> SectionParser src ()
parseSection :: forall src. ProgramDb -> Section Position -> SectionParser src ()
parseSection ProgramDb
programDb (MkSection (Name Position
pos ByteString
name) [SectionArg Position]
args [Field Position]
secFields)
  | ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"source-repository-package" = do
      StateT SectionS (ParseResult src) ()
verifyNullSubsections
      StateT SectionS (ParseResult src) ()
verifyNullSectionArgs
      srp <- ParseResult src SourceRepoList
-> StateT SectionS (ParseResult src) SourceRepoList
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src SourceRepoList
 -> StateT SectionS (ParseResult src) SourceRepoList)
-> ParseResult src SourceRepoList
-> StateT SectionS (ParseResult src) SourceRepoList
forall a b. (a -> b) -> a -> b
$ CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar SourceRepoList SourceRepoList
-> ParseResult src SourceRepoList
forall s a src.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a
parseFieldGrammar CabalSpecVersion
cabalSpec Fields Position
fields ParsecFieldGrammar SourceRepoList SourceRepoList
forall (c :: * -> Constraint) (g :: * -> * -> *).
(FieldGrammar c g, c (Identity RepoType),
 c (List NoCommaFSep FilePathNT FilePath),
 c (NonEmpty' NoCommaFSep Token FilePath)) =>
g SourceRepoList SourceRepoList
sourceRepositoryPackageGrammar
      stateConfig . L.projectPackagesRepo %= (<> [srp])
  | ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"program-options" = do
      StateT SectionS (ParseResult src) ()
verifyNullSubsections
      StateT SectionS (ParseResult src) ()
verifyNullSectionArgs
      opts' <- ParseResult src (MapMappend FilePath [FilePath])
-> StateT
     SectionS (ParseResult src) (MapMappend FilePath [FilePath])
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src (MapMappend FilePath [FilePath])
 -> StateT
      SectionS (ParseResult src) (MapMappend FilePath [FilePath]))
-> ParseResult src (MapMappend FilePath [FilePath])
-> StateT
     SectionS (ParseResult src) (MapMappend FilePath [FilePath])
forall a b. (a -> b) -> a -> b
$ ProgramDb
-> Fields Position
-> ParseResult src (MapMappend FilePath [FilePath])
forall src.
ProgramDb
-> Fields Position
-> ParseResult src (MapMappend FilePath [FilePath])
parseProgramArgs ProgramDb
programDb Fields Position
fields
      stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramArgs %= (opts' <>)
  | ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"program-locations" = do
      StateT SectionS (ParseResult src) ()
verifyNullSubsections
      StateT SectionS (ParseResult src) ()
verifyNullSectionArgs
      paths' <- ParseResult src (MapLast FilePath FilePath)
-> StateT SectionS (ParseResult src) (MapLast FilePath FilePath)
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src (MapLast FilePath FilePath)
 -> StateT SectionS (ParseResult src) (MapLast FilePath FilePath))
-> ParseResult src (MapLast FilePath FilePath)
-> StateT SectionS (ParseResult src) (MapLast FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ ProgramDb
-> Fields Position -> ParseResult src (MapLast FilePath FilePath)
forall src.
ProgramDb
-> Fields Position -> ParseResult src (MapLast FilePath FilePath)
parseProgramPaths ProgramDb
programDb Fields Position
fields
      stateConfig . L.projectConfigLocalPackages . L.packageConfigProgramPaths %= (paths' <>)
  | ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"repository" = do
      StateT SectionS (ParseResult src) ()
verifyNullSubsections
      mRepoName <- ParseResult src (Maybe RepoName)
-> StateT SectionS (ParseResult src) (Maybe RepoName)
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src (Maybe RepoName)
 -> StateT SectionS (ParseResult src) (Maybe RepoName))
-> ParseResult src (Maybe RepoName)
-> StateT SectionS (ParseResult src) (Maybe RepoName)
forall a b. (a -> b) -> a -> b
$ Position
-> [SectionArg Position] -> ParseResult src (Maybe RepoName)
forall src.
Position
-> [SectionArg Position] -> ParseResult src (Maybe RepoName)
parseRepoName Position
pos [SectionArg Position]
args
      case mRepoName of
        Just RepoName
repoName -> do
          remoteRepo <- ParseResult src RemoteRepo
-> StateT SectionS (ParseResult src) RemoteRepo
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src RemoteRepo
 -> StateT SectionS (ParseResult src) RemoteRepo)
-> ParseResult src RemoteRepo
-> StateT SectionS (ParseResult src) RemoteRepo
forall a b. (a -> b) -> a -> b
$ CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar RemoteRepo RemoteRepo
-> ParseResult src RemoteRepo
forall s a src.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a
parseFieldGrammar CabalSpecVersion
cabalSpec Fields Position
fields (RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo
remoteRepoGrammar RepoName
repoName)
          remoteOrLocalRepo <- lift $ postProcessRemoteRepo pos remoteRepo
          case remoteOrLocalRepo of
            Left LocalRepo
local -> LensLike Identity SectionS SectionS ProjectConfig ProjectConfig
Lens' SectionS ProjectConfig
stateConfig LensLike Identity SectionS SectionS ProjectConfig ProjectConfig
-> ((NubList LocalRepo -> Identity (NubList LocalRepo))
    -> ProjectConfig -> Identity ProjectConfig)
-> (NubList LocalRepo -> Identity (NubList LocalRepo))
-> SectionS
-> Identity SectionS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike
  Identity
  ProjectConfig
  ProjectConfig
  ProjectConfigShared
  ProjectConfigShared
Lens' ProjectConfig ProjectConfigShared
L.projectConfigShared LensLike
  Identity
  ProjectConfig
  ProjectConfig
  ProjectConfigShared
  ProjectConfigShared
-> ((NubList LocalRepo -> Identity (NubList LocalRepo))
    -> ProjectConfigShared -> Identity ProjectConfigShared)
-> (NubList LocalRepo -> Identity (NubList LocalRepo))
-> ProjectConfig
-> Identity ProjectConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NubList LocalRepo -> Identity (NubList LocalRepo))
-> ProjectConfigShared -> Identity ProjectConfigShared
Lens' ProjectConfigShared (NubList LocalRepo)
L.projectConfigLocalNoIndexRepos ((NubList LocalRepo -> Identity (NubList LocalRepo))
 -> SectionS -> Identity SectionS)
-> (NubList LocalRepo -> NubList LocalRepo)
-> StateT SectionS (ParseResult src) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (NubList LocalRepo -> NubList LocalRepo -> NubList LocalRepo
forall a. Semigroup a => a -> a -> a
<> [LocalRepo] -> NubList LocalRepo
forall a. Ord a => [a] -> NubList a
toNubList [LocalRepo
local])
            Right RemoteRepo
remote -> LensLike Identity SectionS SectionS ProjectConfig ProjectConfig
Lens' SectionS ProjectConfig
stateConfig LensLike Identity SectionS SectionS ProjectConfig ProjectConfig
-> ((NubList RemoteRepo -> Identity (NubList RemoteRepo))
    -> ProjectConfig -> Identity ProjectConfig)
-> (NubList RemoteRepo -> Identity (NubList RemoteRepo))
-> SectionS
-> Identity SectionS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike
  Identity
  ProjectConfig
  ProjectConfig
  ProjectConfigShared
  ProjectConfigShared
Lens' ProjectConfig ProjectConfigShared
L.projectConfigShared LensLike
  Identity
  ProjectConfig
  ProjectConfig
  ProjectConfigShared
  ProjectConfigShared
-> ((NubList RemoteRepo -> Identity (NubList RemoteRepo))
    -> ProjectConfigShared -> Identity ProjectConfigShared)
-> (NubList RemoteRepo -> Identity (NubList RemoteRepo))
-> ProjectConfig
-> Identity ProjectConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NubList RemoteRepo -> Identity (NubList RemoteRepo))
-> ProjectConfigShared -> Identity ProjectConfigShared
Lens' ProjectConfigShared (NubList RemoteRepo)
L.projectConfigRemoteRepos ((NubList RemoteRepo -> Identity (NubList RemoteRepo))
 -> SectionS -> Identity SectionS)
-> (NubList RemoteRepo -> NubList RemoteRepo)
-> StateT SectionS (ParseResult src) ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (NubList RemoteRepo -> NubList RemoteRepo -> NubList RemoteRepo
forall a. Semigroup a => a -> a -> a
<> [RemoteRepo] -> NubList RemoteRepo
forall a. Ord a => [a] -> NubList a
toNubList [RemoteRepo
remote])
        Maybe RepoName
Nothing -> ParseResult src () -> StateT SectionS (ParseResult src) ()
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src () -> StateT SectionS (ParseResult src) ())
-> ParseResult src () -> StateT SectionS (ParseResult src) ()
forall a b. (a -> b) -> a -> b
$ Position -> FilePath -> ParseResult src ()
forall src. Position -> FilePath -> ParseResult src ()
parseFailure Position
pos FilePath
"a 'repository' section requires the repository name as an argument"
  | ByteString
name ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"package" = do
      StateT SectionS (ParseResult src) ()
verifyNullSubsections
      package <- ParseResult src (Maybe PackageConfigTarget)
-> StateT SectionS (ParseResult src) (Maybe PackageConfigTarget)
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src (Maybe PackageConfigTarget)
 -> StateT SectionS (ParseResult src) (Maybe PackageConfigTarget))
-> ParseResult src (Maybe PackageConfigTarget)
-> StateT SectionS (ParseResult src) (Maybe PackageConfigTarget)
forall a b. (a -> b) -> a -> b
$ Position
-> [SectionArg Position]
-> ParseResult src (Maybe PackageConfigTarget)
forall src.
Position
-> [SectionArg Position]
-> ParseResult src (Maybe PackageConfigTarget)
parsePackageName Position
pos [SectionArg Position]
args
      case package of
        Just PackageConfigTarget
AllPackages -> do
          packageCfg' <- StateT SectionS (ParseResult src) PackageConfig
parsePackageConfig
          stateConfig . L.projectConfigAllPackages %= (packageCfg' <>)
        Just (SpecificPackage PackageName
packageName) -> do
          packageCfg <- StateT SectionS (ParseResult src) PackageConfig
parsePackageConfig
          stateConfig . L.projectConfigSpecificPackage %= (<> MapMappend (Map.singleton packageName packageCfg))
        Maybe PackageConfigTarget
Nothing -> do
          ParseResult src () -> StateT SectionS (ParseResult src) ()
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src () -> StateT SectionS (ParseResult src) ())
-> ParseResult src () -> StateT SectionS (ParseResult src) ()
forall a b. (a -> b) -> a -> b
$ Position -> PWarnType -> FilePath -> ParseResult src ()
forall src. Position -> PWarnType -> FilePath -> ParseResult src ()
parseWarning Position
pos PWarnType
PWTUnknownSection FilePath
"target package name or * required"
          () -> StateT SectionS (ParseResult src) ()
forall a. a -> StateT SectionS (ParseResult src) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = do
      Position -> ByteString -> StateT SectionS (ParseResult src) ()
forall {t :: (* -> *) -> * -> *} {a} {src}.
(MonadTrans t, Show a) =>
Position -> a -> t (ParseResult src) ()
warnInvalidSubsection Position
pos ByteString
name
  where
    (Fields Position
fields, [[Section Position]]
sections) = [Field Position] -> (Fields Position, [[Section Position]])
forall ann. [Field ann] -> (Fields ann, [[Section ann]])
partitionFields [Field Position]
secFields
    warnInvalidSubsection :: Position -> a -> t (ParseResult src) ()
warnInvalidSubsection Position
pos' a
name' = ParseResult src () -> t (ParseResult src) ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src () -> t (ParseResult src) ())
-> ParseResult src () -> t (ParseResult src) ()
forall a b. (a -> b) -> a -> b
$ Position -> PWarnType -> FilePath -> ParseResult src ()
forall src. Position -> PWarnType -> FilePath -> ParseResult src ()
parseWarning Position
pos' PWarnType
PWTInvalidSubsection (FilePath -> ParseResult src ()) -> FilePath -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid subsection " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ a -> FilePath
forall a. Show a => a -> FilePath
show a
name'
    programNames :: [FilePath]
programNames = ProgramDb -> [FilePath]
knownProgramNames ProgramDb
programDb
    verifyNullSubsections :: StateT SectionS (ParseResult src) ()
verifyNullSubsections = Bool
-> StateT SectionS (ParseResult src) ()
-> StateT SectionS (ParseResult src) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[Section Position]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Section Position]]
sections) (Position -> ByteString -> StateT SectionS (ParseResult src) ()
forall {t :: (* -> *) -> * -> *} {a} {src}.
(MonadTrans t, Show a) =>
Position -> a -> t (ParseResult src) ()
warnInvalidSubsection Position
pos ByteString
name)
    verifyNullSectionArgs :: StateT SectionS (ParseResult src) ()
verifyNullSectionArgs = Bool
-> StateT SectionS (ParseResult src) ()
-> StateT SectionS (ParseResult src) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SectionArg Position] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SectionArg Position]
args) (ParseResult src () -> StateT SectionS (ParseResult src) ()
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src () -> StateT SectionS (ParseResult src) ())
-> ParseResult src () -> StateT SectionS (ParseResult src) ()
forall a b. (a -> b) -> a -> b
$ Position -> FilePath -> ParseResult src ()
forall src. Position -> FilePath -> ParseResult src ()
parseFailure Position
pos (FilePath -> ParseResult src ()) -> FilePath -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$ FilePath
"The section '" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
name FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"' takes no arguments")
    parsePackageConfig :: StateT SectionS (ParseResult src) PackageConfig
parsePackageConfig = do
      packageCfg <- ParseResult src PackageConfig
-> StateT SectionS (ParseResult src) PackageConfig
forall (m :: * -> *) a. Monad m => m a -> StateT SectionS m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParseResult src PackageConfig
 -> StateT SectionS (ParseResult src) PackageConfig)
-> ParseResult src PackageConfig
-> StateT SectionS (ParseResult src) PackageConfig
forall a b. (a -> b) -> a -> b
$ CabalSpecVersion
-> Fields Position
-> ParsecFieldGrammar PackageConfig PackageConfig
-> ParseResult src PackageConfig
forall s a src.
CabalSpecVersion
-> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a
parseFieldGrammar CabalSpecVersion
cabalSpec Fields Position
fields ([FilePath] -> ParsecFieldGrammar PackageConfig PackageConfig
packageConfigFieldGrammar [FilePath]
programNames)
      args' <- lift $ parseProgramArgs programDb fields
      paths <- lift $ parseProgramPaths programDb fields
      return packageCfg{packageConfigProgramPaths = paths, packageConfigProgramArgs = args'}

stanzas :: Set BS.ByteString
stanzas :: Set ByteString
stanzas = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList [ByteString
"source-repository-package", ByteString
"program-options", ByteString
"program-locations", ByteString
"repository", ByteString
"package"]

-- | Currently a duplicate of 'Distribution.Client.Config.postProcessRepo' but migrated to Parsec ParseResult.
postProcessRemoteRepo :: Position -> RemoteRepo -> ParseResult src (Either LocalRepo RemoteRepo)
postProcessRemoteRepo :: forall src.
Position
-> RemoteRepo -> ParseResult src (Either LocalRepo RemoteRepo)
postProcessRemoteRepo Position
pos RemoteRepo
repo = case URI -> FilePath
uriScheme (RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo) of
  -- TODO: check that there are no authority, query or fragment
  -- Note: the trailing colon is important
  FilePath
"file+noindex:" -> do
    let uri :: URI
uri = OS -> URI -> URI
normaliseFileNoIndexURI OS
buildOS (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> URI
remoteRepoURI RemoteRepo
repo
    Either LocalRepo RemoteRepo
-> ParseResult src (Either LocalRepo RemoteRepo)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either LocalRepo RemoteRepo
 -> ParseResult src (Either LocalRepo RemoteRepo))
-> Either LocalRepo RemoteRepo
-> ParseResult src (Either LocalRepo RemoteRepo)
forall a b. (a -> b) -> a -> b
$ LocalRepo -> Either LocalRepo RemoteRepo
forall a b. a -> Either a b
Left (LocalRepo -> Either LocalRepo RemoteRepo)
-> LocalRepo -> Either LocalRepo RemoteRepo
forall a b. (a -> b) -> a -> b
$ RepoName -> FilePath -> Bool -> LocalRepo
LocalRepo (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo) (URI -> FilePath
uriPath URI
uri) (URI -> FilePath
uriFragment URI
uri FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"#shared-cache")
  FilePath
_ -> do
    Bool -> ParseResult src () -> ParseResult src ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RemoteRepo -> Int
remoteRepoKeyThreshold RemoteRepo
repo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> [FilePath] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (RemoteRepo -> [FilePath]
remoteRepoRootKeys RemoteRepo
repo)) (ParseResult src () -> ParseResult src ())
-> ParseResult src () -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> ParseResult src ()
forall {src}. FilePath -> ParseResult src ()
warning (FilePath -> ParseResult src ()) -> FilePath -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"'key-threshold' for repository "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
forall a. Show a => a -> FilePath
show (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" higher than number of keys"

    Bool -> ParseResult src () -> ParseResult src ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([FilePath] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RemoteRepo -> [FilePath]
remoteRepoRootKeys RemoteRepo
repo)) Bool -> Bool -> Bool
&& RemoteRepo -> Maybe Bool
remoteRepoSecure RemoteRepo
repo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True) (ParseResult src () -> ParseResult src ())
-> ParseResult src () -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> ParseResult src ()
forall {src}. FilePath -> ParseResult src ()
warning (FilePath -> ParseResult src ()) -> FilePath -> ParseResult src ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"'root-keys' for repository "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RepoName -> FilePath
forall a. Show a => a -> FilePath
show (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
repo)
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" non-empty, but 'secure' not set to True."

    Either LocalRepo RemoteRepo
-> ParseResult src (Either LocalRepo RemoteRepo)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either LocalRepo RemoteRepo
 -> ParseResult src (Either LocalRepo RemoteRepo))
-> Either LocalRepo RemoteRepo
-> ParseResult src (Either LocalRepo RemoteRepo)
forall a b. (a -> b) -> a -> b
$ RemoteRepo -> Either LocalRepo RemoteRepo
forall a b. b -> Either a b
Right RemoteRepo
repo
    where
      warning :: FilePath -> ParseResult src ()
warning FilePath
msg = Position -> PWarnType -> FilePath -> ParseResult src ()
forall src. Position -> PWarnType -> FilePath -> ParseResult src ()
parseWarning Position
pos PWarnType
PWTOther FilePath
msg

parseRepoName :: Position -> [SectionArg Position] -> ParseResult src (Maybe RepoName)
parseRepoName :: forall src.
Position
-> [SectionArg Position] -> ParseResult src (Maybe RepoName)
parseRepoName Position
pos [SectionArg Position]
args = case [SectionArg Position]
args of
  [SecArgName Position
_ ByteString
secName] -> ByteString -> ParseResult src (Maybe RepoName)
forall src. ByteString -> ParseResult src (Maybe RepoName)
parseName ByteString
secName
  [SecArgStr Position
_ ByteString
secName] -> ByteString -> ParseResult src (Maybe RepoName)
forall src. ByteString -> ParseResult src (Maybe RepoName)
parseName ByteString
secName
  [SecArgOther Position
_ ByteString
secName] -> ByteString -> ParseResult src (Maybe RepoName)
forall src. ByteString -> ParseResult src (Maybe RepoName)
parseName ByteString
secName
  [SectionArg Position]
_ -> Maybe RepoName -> ParseResult src (Maybe RepoName)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RepoName
forall a. Maybe a
Nothing
  where
    parseName :: BS.ByteString -> ParseResult src (Maybe RepoName)
    parseName :: forall src. ByteString -> ParseResult src (Maybe RepoName)
parseName ByteString
str =
      let repoNameStr :: FilePath
repoNameStr = ByteString -> FilePath
fromUTF8BS ByteString
str
       in case FilePath -> Either FilePath RepoName
forall a. Parsec a => FilePath -> Either FilePath a
eitherParsec FilePath
repoNameStr of
            Left FilePath
_ -> do
              Position -> FilePath -> ParseResult src ()
forall src. Position -> FilePath -> ParseResult src ()
parseFailure Position
pos (FilePath
"Invalid repository name" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
repoNameStr)
              Maybe RepoName -> ParseResult src (Maybe RepoName)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RepoName
forall a. Maybe a
Nothing
            Right RepoName
name -> Maybe RepoName -> ParseResult src (Maybe RepoName)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RepoName -> ParseResult src (Maybe RepoName))
-> Maybe RepoName -> ParseResult src (Maybe RepoName)
forall a b. (a -> b) -> a -> b
$ RepoName -> Maybe RepoName
forall a. a -> Maybe a
Just RepoName
name

data PackageConfigTarget = AllPackages | SpecificPackage !PackageName

parsePackageName :: Position -> [SectionArg Position] -> ParseResult src (Maybe PackageConfigTarget)
parsePackageName :: forall src.
Position
-> [SectionArg Position]
-> ParseResult src (Maybe PackageConfigTarget)
parsePackageName Position
pos [SectionArg Position]
args = case [SectionArg Position]
args of
  [SecArgName Position
_ ByteString
secName] -> ByteString -> ParseResult src (Maybe PackageConfigTarget)
forall {src}.
ByteString -> ParseResult src (Maybe PackageConfigTarget)
parseName ByteString
secName
  [SecArgStr Position
_ ByteString
secName] -> ByteString -> ParseResult src (Maybe PackageConfigTarget)
forall {src}.
ByteString -> ParseResult src (Maybe PackageConfigTarget)
parseName ByteString
secName
  [SecArgOther Position
_ ByteString
secName] -> ByteString -> ParseResult src (Maybe PackageConfigTarget)
forall {src}.
ByteString -> ParseResult src (Maybe PackageConfigTarget)
parseName ByteString
secName
  [SectionArg Position]
_ -> Maybe PackageConfigTarget
-> ParseResult src (Maybe PackageConfigTarget)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageConfigTarget
forall a. Maybe a
Nothing
  where
    parseName :: ByteString -> ParseResult src (Maybe PackageConfigTarget)
parseName ByteString
secName = case ParsecParser PackageConfigTarget
-> FilePath
-> FieldLineStream
-> Either ParseError PackageConfigTarget
forall a.
ParsecParser a
-> FilePath -> FieldLineStream -> Either ParseError a
runParsecParser ParsecParser PackageConfigTarget
parser FilePath
"<parsePackageName>" (ByteString -> FieldLineStream
fieldLineStreamFromBS ByteString
secName) of
      Left ParseError
_ -> do
        Position -> FilePath -> ParseResult src ()
forall src. Position -> FilePath -> ParseResult src ()
parseFailure Position
pos (FilePath
"Invalid package name" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
fromUTF8BS ByteString
secName)
        Maybe PackageConfigTarget
-> ParseResult src (Maybe PackageConfigTarget)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe PackageConfigTarget
forall a. Maybe a
Nothing
      Right PackageConfigTarget
cfgTarget -> Maybe PackageConfigTarget
-> ParseResult src (Maybe PackageConfigTarget)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe PackageConfigTarget
 -> ParseResult src (Maybe PackageConfigTarget))
-> Maybe PackageConfigTarget
-> ParseResult src (Maybe PackageConfigTarget)
forall a b. (a -> b) -> a -> b
$ PackageConfigTarget -> Maybe PackageConfigTarget
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageConfigTarget
cfgTarget
    parser :: ParsecParser PackageConfigTarget
    parser :: ParsecParser PackageConfigTarget
parser =
      [ParsecParser PackageConfigTarget]
-> ParsecParser PackageConfigTarget
forall (m :: * -> *) a. Alternative m => [m a] -> m a
P.choice [ParsecParser PackageConfigTarget
-> ParsecParser PackageConfigTarget
forall a. ParsecParser a -> ParsecParser a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (Char -> ParsecParser Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
'*' ParsecParser Char
-> ParsecParser PackageConfigTarget
-> ParsecParser PackageConfigTarget
forall a b. ParsecParser a -> ParsecParser b -> ParsecParser b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> PackageConfigTarget -> ParsecParser PackageConfigTarget
forall a. a -> ParsecParser a
forall (m :: * -> *) a. Monad m => a -> m a
return PackageConfigTarget
AllPackages), PackageName -> PackageConfigTarget
SpecificPackage (PackageName -> PackageConfigTarget)
-> ParsecParser PackageName -> ParsecParser PackageConfigTarget
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecParser PackageName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m PackageName
parsec]

-- | Parse fields of a program-options stanza.
parseProgramArgs :: ProgramDb -> Fields Position -> ParseResult src (MapMappend String [String])
parseProgramArgs :: forall src.
ProgramDb
-> Fields Position
-> ParseResult src (MapMappend FilePath [FilePath])
parseProgramArgs ProgramDb
programDb Fields Position
fields = (MapMappend FilePath [FilePath]
 -> (ByteString, [NamelessField Position])
 -> ParseResult src (MapMappend FilePath [FilePath]))
-> MapMappend FilePath [FilePath]
-> [(ByteString, [NamelessField Position])]
-> ParseResult src (MapMappend FilePath [FilePath])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MapMappend FilePath [FilePath]
-> (ByteString, [NamelessField Position])
-> ParseResult src (MapMappend FilePath [FilePath])
forall {src}.
MapMappend FilePath [FilePath]
-> (ByteString, [NamelessField Position])
-> ParseResult src (MapMappend FilePath [FilePath])
parseField MapMappend FilePath [FilePath]
forall a. Monoid a => a
mempty (((ByteString, [NamelessField Position]) -> Bool)
-> [(ByteString, [NamelessField Position])]
-> [(ByteString, [NamelessField Position])]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString, [NamelessField Position]) -> Bool
forall {b}. (ByteString, b) -> Bool
hasOptionsSuffix ([(ByteString, [NamelessField Position])]
 -> [(ByteString, [NamelessField Position])])
-> [(ByteString, [NamelessField Position])]
-> [(ByteString, [NamelessField Position])]
forall a b. (a -> b) -> a -> b
$ Fields Position -> [(ByteString, [NamelessField Position])]
forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
fields)
  where
    parseField :: MapMappend FilePath [FilePath]
-> (ByteString, [NamelessField Position])
-> ParseResult src (MapMappend FilePath [FilePath])
parseField MapMappend FilePath [FilePath]
programArgs (ByteString
fieldName, [NamelessField Position]
fieldLines) = do
      case FilePath -> ProgramDb -> ByteString -> Maybe FilePath
readProgramName FilePath
"-options" ProgramDb
programDb ByteString
fieldName of
        Maybe FilePath
Nothing -> ByteString -> [NamelessField Position] -> ParseResult src ()
forall src.
ByteString -> [NamelessField Position] -> ParseResult src ()
warnUnknownFields ByteString
fieldName [NamelessField Position]
fieldLines ParseResult src ()
-> ParseResult src (MapMappend FilePath [FilePath])
-> ParseResult src (MapMappend FilePath [FilePath])
forall a b.
ParseResult src a -> ParseResult src b -> ParseResult src b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MapMappend FilePath [FilePath]
-> ParseResult src (MapMappend FilePath [FilePath])
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return MapMappend FilePath [FilePath]
programArgs
        Just FilePath
program -> do
          args <- [NamelessField Position] -> ParseResult src [FilePath]
forall src. [NamelessField Position] -> ParseResult src [FilePath]
parseProgramArgsField ([NamelessField Position] -> ParseResult src [FilePath])
-> [NamelessField Position] -> ParseResult src [FilePath]
forall a b. (a -> b) -> a -> b
$ [NamelessField Position] -> [NamelessField Position]
forall a. [a] -> [a]
reverse [NamelessField Position]
fieldLines
          return $ programArgs <> MapMappend (Map.singleton program args)
    hasOptionsSuffix :: (ByteString, b) -> Bool
hasOptionsSuffix (ByteString
fieldName, b
_) = ByteString -> ByteString -> Bool
BS.isSuffixOf ByteString
"-options" ByteString
fieldName

-- | Parse fields of a program-locations stanza.
parseProgramPaths :: ProgramDb -> Fields Position -> ParseResult src (MapLast String FilePath)
parseProgramPaths :: forall src.
ProgramDb
-> Fields Position -> ParseResult src (MapLast FilePath FilePath)
parseProgramPaths ProgramDb
programDb Fields Position
fields = (MapLast FilePath FilePath
 -> (ByteString, [NamelessField Position])
 -> ParseResult src (MapLast FilePath FilePath))
-> MapLast FilePath FilePath
-> [(ByteString, [NamelessField Position])]
-> ParseResult src (MapLast FilePath FilePath)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM MapLast FilePath FilePath
-> (ByteString, [NamelessField Position])
-> ParseResult src (MapLast FilePath FilePath)
forall {src}.
MapLast FilePath FilePath
-> (ByteString, [NamelessField Position])
-> ParseResult src (MapLast FilePath FilePath)
parseField MapLast FilePath FilePath
forall a. Monoid a => a
mempty (((ByteString, [NamelessField Position]) -> Bool)
-> [(ByteString, [NamelessField Position])]
-> [(ByteString, [NamelessField Position])]
forall a. (a -> Bool) -> [a] -> [a]
filter (ByteString, [NamelessField Position]) -> Bool
forall {b}. (ByteString, b) -> Bool
hasLocationSuffix ([(ByteString, [NamelessField Position])]
 -> [(ByteString, [NamelessField Position])])
-> [(ByteString, [NamelessField Position])]
-> [(ByteString, [NamelessField Position])]
forall a b. (a -> b) -> a -> b
$ Fields Position -> [(ByteString, [NamelessField Position])]
forall k a. Map k a -> [(k, a)]
Map.toList Fields Position
fields)
  where
    parseField :: MapLast FilePath FilePath
-> (ByteString, [NamelessField Position])
-> ParseResult src (MapLast FilePath FilePath)
parseField MapLast FilePath FilePath
paths (ByteString
fieldName, [NamelessField Position]
fieldLines) = do
      case FilePath -> ProgramDb -> ByteString -> Maybe FilePath
readProgramName FilePath
"-location" ProgramDb
programDb ByteString
fieldName of
        Maybe FilePath
Nothing -> ByteString -> [NamelessField Position] -> ParseResult src ()
forall src.
ByteString -> [NamelessField Position] -> ParseResult src ()
warnUnknownFields ByteString
fieldName [NamelessField Position]
fieldLines ParseResult src ()
-> ParseResult src (MapLast FilePath FilePath)
-> ParseResult src (MapLast FilePath FilePath)
forall a b.
ParseResult src a -> ParseResult src b -> ParseResult src b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MapLast FilePath FilePath
-> ParseResult src (MapLast FilePath FilePath)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return MapLast FilePath FilePath
paths
        Just FilePath
program -> do
          case [NamelessField Position]
fieldLines of
            (MkNamelessField Position
pos [FieldLine Position]
lines') : [NamelessField Position]
_ -> do
              fp <- Position
-> ParsecParser FilePath
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src FilePath
forall a src.
Position
-> ParsecParser a
-> CabalSpecVersion
-> [FieldLine Position]
-> ParseResult src a
runFieldParser Position
pos ParsecParser FilePath
forall (m :: * -> *). CabalParsing m => m FilePath
parsecFilePath CabalSpecVersion
cabalSpec [FieldLine Position]
lines'
              return $ paths <> MapLast (Map.singleton program fp)
            [] -> MapLast FilePath FilePath
-> ParseResult src (MapLast FilePath FilePath)
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return MapLast FilePath FilePath
forall a. Monoid a => a
mempty
    hasLocationSuffix :: (ByteString, b) -> Bool
hasLocationSuffix (ByteString
fieldName, b
_) = ByteString -> ByteString -> Bool
BS.isSuffixOf ByteString
"-location" ByteString
fieldName

-- | Parse all arguments to a single program in program-options stanza.
-- By processing '[NamelessField Position]', we support multiple occurrences of the field, concatenating the arguments.
parseProgramArgsField :: [NamelessField Position] -> ParseResult src [String]
parseProgramArgsField :: forall src. [NamelessField Position] -> ParseResult src [FilePath]
parseProgramArgsField [NamelessField Position]
fieldLines =
  [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[FilePath]] -> [FilePath])
-> ParseResult src [[FilePath]] -> ParseResult src [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamelessField Position -> ParseResult src [FilePath])
-> [NamelessField Position] -> ParseResult src [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\(MkNamelessField Position
_ [FieldLine Position]
lines') -> [FieldLine Position] -> ParseResult src [FilePath]
forall src. [FieldLine Position] -> ParseResult src [FilePath]
parseProgramArgsFieldLines [FieldLine Position]
lines') [NamelessField Position]
fieldLines

-- | Parse all fieldLines of a single field occurrence in a program-options stanza.
parseProgramArgsFieldLines :: [FieldLine Position] -> ParseResult src [String]
parseProgramArgsFieldLines :: forall src. [FieldLine Position] -> ParseResult src [FilePath]
parseProgramArgsFieldLines [FieldLine Position]
lines' = [FilePath] -> ParseResult src [FilePath]
forall a. a -> ParseResult src a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> ParseResult src [FilePath])
-> [FilePath] -> ParseResult src [FilePath]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
splitArgs FilePath
strLines
  where
    strLines :: FilePath
strLines = [FieldLine Position] -> FilePath
forall ann. [FieldLine ann] -> FilePath
fieldLinesToString [FieldLine Position]
lines'

type FieldSuffix = String

-- | Extract the program name of a <progname> field, allow it to have a suffix such as '-options' and check whether the 'ProgramDB' contains it.
readProgramName :: FieldSuffix -> ProgramDb -> FieldName -> Maybe String
readProgramName :: FilePath -> ProgramDb -> ByteString -> Maybe FilePath
readProgramName FilePath
suffix ProgramDb
programDb ByteString
fieldName =
  (FilePath -> ByteString -> Maybe FilePath
parseProgramName FilePath
suffix ByteString
fieldName Maybe FilePath -> (FilePath -> Maybe Program) -> Maybe Program
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (FilePath -> ProgramDb -> Maybe Program
`lookupKnownProgram` ProgramDb
programDb)) Maybe Program -> (Program -> FilePath) -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Program -> FilePath
programName

parseProgramName :: FieldSuffix -> FieldName -> Maybe String
parseProgramName :: FilePath -> ByteString -> Maybe FilePath
parseProgramName FilePath
suffix ByteString
fieldName = case ParsecParser FilePath
-> FilePath -> FieldLineStream -> Either ParseError FilePath
forall a.
ParsecParser a
-> FilePath -> FieldLineStream -> Either ParseError a
runParsecParser ParsecParser FilePath
parser FilePath
"<parseProgramName>" FieldLineStream
fieldNameStream of
  Left ParseError
_ -> Maybe FilePath
forall a. Maybe a
Nothing
  Right FilePath
str -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
str
  where
    parser :: ParsecParser FilePath
parser = ParsecParser Char -> ParsecParser FilePath -> ParsecParser FilePath
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m [a]
P.manyTill ParsecParser Char
forall (m :: * -> *). CharParsing m => m Char
P.anyChar (ParsecParser FilePath -> ParsecParser FilePath
forall a. ParsecParser a -> ParsecParser a
forall (m :: * -> *) a. Parsing m => m a -> m a
P.try (FilePath -> ParsecParser FilePath
forall (m :: * -> *). CharParsing m => FilePath -> m FilePath
P.string FilePath
suffix) ParsecParser FilePath -> ParsecParser () -> ParsecParser FilePath
forall a b. ParsecParser a -> ParsecParser b -> ParsecParser a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecParser ()
forall (m :: * -> *). Parsing m => m ()
P.eof)
    fieldNameStream :: FieldLineStream
fieldNameStream = ByteString -> FieldLineStream
fieldLineStreamFromBS ByteString
fieldName

-- | Issue a 'PWTUnknownField' warning at all occurrences of a field.
warnUnknownFields :: FieldName -> [NamelessField Position] -> ParseResult src ()
warnUnknownFields :: forall src.
ByteString -> [NamelessField Position] -> ParseResult src ()
warnUnknownFields ByteString
fieldName [NamelessField Position]
fieldLines = [NamelessField Position]
-> (NamelessField Position -> ParseResult src ())
-> ParseResult src ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [NamelessField Position]
fieldLines (\NamelessField Position
field -> Position -> PWarnType -> FilePath -> ParseResult src ()
forall src. Position -> PWarnType -> FilePath -> ParseResult src ()
parseWarning (NamelessField Position -> Position
forall {ann}. NamelessField ann -> ann
pos NamelessField Position
field) PWarnType
PWTUnknownField FilePath
message)
  where
    message :: FilePath
message = FilePath
"Unknown field: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ByteString -> FilePath
forall a. Show a => a -> FilePath
show ByteString
fieldName
    pos :: NamelessField ann -> ann
pos = NamelessField ann -> ann
forall {ann}. NamelessField ann -> ann
namelessFieldAnn

cabalSpec :: CabalSpecVersion
cabalSpec :: CabalSpecVersion
cabalSpec = CabalSpecVersion
cabalSpecLatest