Commit 069a641e authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

Merge pull request #4750 from phadej/elif

Elif
parents 1095f298 4ae4abbe
......@@ -34,6 +34,7 @@ extra-source-files:
-- BEGIN gen-extra-source-files
tests/ParserTests/regressions/Octree-0.5.cabal
tests/ParserTests/regressions/elif.cabal
tests/ParserTests/regressions/elif2.cabal
tests/ParserTests/regressions/encoding-0.8.cabal
tests/ParserTests/regressions/generics-sop.cabal
tests/ParserTests/regressions/issue-774.cabal
......@@ -274,6 +275,7 @@ library
-- Parsec parser relatedmodules
build-depends:
transformers,
mtl >= 2.1 && <2.3,
parsec >= 3.1.9 && <3.2
exposed-modules:
Distribution.Compat.Parsec
......
......@@ -20,6 +20,7 @@ module Distribution.Compat.Lens (
ALens',
-- * Getter
view,
use,
-- * Setter
set,
over,
......@@ -36,9 +37,11 @@ module Distribution.Compat.Lens (
fromNon,
-- * Operators
(&),
(^.), (.~), (%~),
(?~),
(^#), (#~), (#%~),
(^.),
(.~), (?~), (%~),
(.=), (?=), (%=),
(^#),
(#~), (#%~),
-- * Internal Comonads
Pretext (..),
-- * Cabal developer info
......@@ -50,6 +53,7 @@ import Distribution.Compat.Prelude
import Control.Applicative (Const (..))
import Data.Functor.Identity (Identity (..))
import Control.Monad.State.Class (MonadState (..), gets, modify)
import qualified Distribution.Compat.DList as DList
import qualified Data.Set as Set
......@@ -81,6 +85,11 @@ type ALens' s a = ALens s s a a
view :: Getting a s a -> s -> a
view l s = getConst (l Const s)
{-# INLINE view #-}
use :: MonadState s m => Getting a s a -> m a
use l = gets (view l)
{-# INLINE use #-}
-------------------------------------------------------------------------------
-- Setter
......@@ -156,7 +165,9 @@ fromNon def f s = unwrap <$> f (wrap s)
infixl 1 &
infixl 8 ^., ^#
infixr 4 .~, %~, ?~, #~, #%~
infixr 4 .~, %~, ?~
infixr 4 #~, #%~
infixr 4 .=, %=, ?=
(^.) :: s -> Getting a s a -> a
s ^. l = getConst (l Const s)
......@@ -174,6 +185,18 @@ l ?~ b = set l (Just b)
(%~) = over
{-# INLINE (%~) #-}
(.=) :: MonadState s m => ASetter s s a b -> b -> m ()
l .= b = modify (l .~ b)
{-# INLINE (.=) #-}
(?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
l ?= b = modify (l ?~ b)
{-# INLINE (?=) #-}
(%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
l %= f = modify (l %~ f)
{-# INLINE (%=) #-}
(^#) :: s -> ALens s t a b -> a
s ^# l = aview l s
......
......@@ -33,6 +33,8 @@ module Distribution.PackageDescription.Parsec (
import Distribution.Compat.Prelude
import Prelude ()
import Control.Monad.State.Strict (StateT, execStateT)
import Control.Monad.Trans.Class (lift)
import qualified Data.ByteString as BS
import Data.List (partition)
import qualified Distribution.Compat.Map.Strict as Map
......@@ -121,6 +123,9 @@ parseGenericPackageDescriptionMaybe =
fieldlinesToBS :: [FieldLine ann] -> BS.ByteString
fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs)
-- Monad in which sections are parsed
type SectionParser = StateT GenericPackageDescription ParseResult
-- Note [Accumulating parser]
--
-- This parser has two "states":
......@@ -141,84 +146,105 @@ parseGenericPackageDescription' lexWarnings fs = do
-- Sections
let gpd = emptyGpd & L.packageDescription .~ pd
goSections gpd sectionFields
where
-- Sections
goSections
:: GenericPackageDescription
-> [Field Position]
-> ParseResult GenericPackageDescription
goSections gpd [] = pure gpd
goSections gpd (Field (Name pos name) _ : fields) = do
parseWarning pos PWTTrailingFields $ "Ignoring trailing fields after sections: " ++ show name
goSections gpd fields
goSections gpd (Section name args secFields : fields) = do
gpd' <- parseSection gpd name args secFields
goSections gpd' fields
-- elif conditional is accepted if spec version is >= 2.1
let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif
execStateT (goSections hasElif sectionFields) gpd
where
emptyGpd :: GenericPackageDescription
emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] []
parseSection
:: GenericPackageDescription
-> Name Position
-> [SectionArg Position]
-> [Field Position]
-> ParseResult GenericPackageDescription
parseSection gpd (Name pos name) args fields
newSyntaxVersion :: Version
newSyntaxVersion = mkVersion [1, 2]
maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
maybeWarnCabalVersion syntax pkg
| syntax == NewSyntax && specVersion pkg < newSyntaxVersion
= parseWarning (Position 0 0) PWTNewSyntax $
"A package using section syntax must specify at least\n"
++ "'cabal-version: >= 1.2'."
maybeWarnCabalVersion syntax pkg
| syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
= parseWarning (Position 0 0) 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
[] {- impossible -} -> display versionRange
((LowerBound version _, _):_) -> display (orLaterVersion version)
maybeWarnCabalVersion _ _ = return ()
-- Sections
goSections :: HasElif -> [Field Position] -> SectionParser ()
goSections hasElif = 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]
parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser ()
parseSection (Name pos name) args fields
| name == "library" && null args = do
lib <- parseCondTree (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
lib <- lift $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields
-- TODO: check that library is defined once
pure $ gpd & L.condLibrary ?~ lib
L.condLibrary ?= lib
-- Sublibraries
| name == "library" = do
-- TODO: check cabal-version
name' <- parseUnqualComponentName pos args
lib <- parseCondTree (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
lib <- lift $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields
-- TODO check duplicate name here?
pure $ gpd & L.condSubLibraries %~ snoc (name', lib)
L.condSubLibraries %= snoc (name', lib)
| name == "foreign-library" = do
name' <- parseUnqualComponentName pos args
flib <- parseCondTree (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
flib <- lift $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields
-- TODO check duplicate name here?
pure $ gpd & L.condForeignLibs %~ snoc (name', flib)
L.condForeignLibs %= snoc (name', flib)
| name == "executable" = do
name' <- parseUnqualComponentName pos args
-- Note: we don't parse the "executable" field here, hence the tail hack. Duncan 2010
exe <- parseCondTree (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
exe <- lift $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields
-- TODO check duplicate name here?
pure $ gpd & L.condExecutables %~ snoc (name', exe)
L.condExecutables %= snoc (name', exe)
| name == "test-suite" = do
name' <- parseUnqualComponentName pos args
testStanza <- parseCondTree testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
testSuite <- traverse (validateTestSuite pos) testStanza
name' <- parseUnqualComponentName pos args
testStanza <- lift $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields
testSuite <- lift $ traverse (validateTestSuite pos) testStanza
-- TODO check duplicate name here?
pure $ gpd & L.condTestSuites %~ snoc (name', testSuite)
L.condTestSuites %= snoc (name', testSuite)
| name == "benchmark" = do
name' <- parseUnqualComponentName pos args
benchStanza <- parseCondTree benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
bench <- traverse (validateBenchmark pos) benchStanza
name' <- parseUnqualComponentName pos args
benchStanza <- lift $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields
bench <- lift $ traverse (validateBenchmark pos) benchStanza
-- TODO check duplicate name here?
pure $ gpd & L.condBenchmarks %~ snoc (name', bench)
L.condBenchmarks %= snoc (name', bench)
| name == "flag" = do
name' <- parseName pos args
name'' <- runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
flag <- parseFields fields (flagFieldGrammar name'')
name' <- parseName pos args
name'' <- lift $ runFieldParser' pos parsec name' `recoverWith` mkFlagName ""
flag <- lift $ parseFields fields (flagFieldGrammar name'')
-- Check default flag
pure $ gpd & L.genPackageFlags %~ snoc flag
L.genPackageFlags %= snoc flag
| name == "custom-setup" && null args = do
sbi <- parseFields fields (setupBInfoFieldGrammar False)
pure $ gpd & L.packageDescription . L.setupBuildInfo ?~ sbi
sbi <- lift $ parseFields fields (setupBInfoFieldGrammar False)
L.packageDescription . L.setupBuildInfo ?= sbi
| name == "source-repository" = do
kind <- case args of
kind <- lift $ case args of
[SecArgName spos secName] ->
runFieldParser' spos parsec (fromUTF8BS secName) `recoverWith` RepoHead
[] -> do
......@@ -228,55 +254,27 @@ parseGenericPackageDescription' lexWarnings fs = do
parseFailure pos $ "Invalid source-repository kind " ++ show args
pure RepoHead
sr <- parseFields fields (sourceRepoFieldGrammar kind)
pure $ gpd & L.packageDescription . L.sourceRepos %~ snoc sr
sr <- lift $ parseFields fields (sourceRepoFieldGrammar kind)
L.packageDescription . L.sourceRepos %= snoc sr
| otherwise = do
| otherwise = lift $
parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name
pure gpd
snoc x xs = xs ++ [x]
newSyntaxVersion :: Version
newSyntaxVersion = mkVersion [1, 2]
maybeWarnCabalVersion :: Syntax -> PackageDescription -> ParseResult ()
maybeWarnCabalVersion syntax pkg
| syntax == NewSyntax && specVersion pkg < newSyntaxVersion
= parseWarning (Position 0 0) PWTNewSyntax $
"A package using section syntax must specify at least\n"
++ "'cabal-version: >= 1.2'."
maybeWarnCabalVersion syntax pkg
| syntax == OldSyntax && specVersion pkg >= newSyntaxVersion
= parseWarning (Position 0 0) 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
[] {- impossible -} -> display versionRange
((LowerBound version _, _):_) -> display (orLaterVersion version)
maybeWarnCabalVersion _ _ = return ()
parseName :: Position -> [SectionArg Position] -> ParseResult String
parseName :: Position -> [SectionArg Position] -> SectionParser String
parseName pos args = case args of
[SecArgName _pos secName] ->
pure $ fromUTF8BS secName
[SecArgStr _pos secName] ->
pure $ fromUTF8BS secName
[] -> do
parseFailure pos $ "name required"
lift $ parseFailure pos $ "name required"
pure ""
_ -> do
-- TODO: pretty print args
parseFailure pos $ "Invalid name " ++ show args
lift $ parseFailure pos $ "Invalid name " ++ show args
pure ""
parseUnqualComponentName :: Position -> [SectionArg Position] -> ParseResult UnqualComponentName
parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName
parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args
-- | Parse a non-recursive list of fields.
......@@ -293,12 +291,18 @@ warnInvalidSubsection :: Section Position -> ParseResult ()
warnInvalidSubsection (MkSection (Name pos name) _ _) =
void (parseFailure pos $ "invalid subsection " ++ show name)
data HasElif = HasElif | NoElif
deriving (Eq, Show)
parseCondTree
:: forall a c. ParsecFieldGrammar' a -- ^ grammar
-> (a -> c) -- ^ condition extractor
:: forall a c.
HasElif -- ^ accept @elif@
-> ParsecFieldGrammar' a -- ^ grammar
-> (a -> c) -- ^ condition extractor
-> [Field Position]
-> ParseResult (CondTree ConfVar c a)
parseCondTree grammar cond = go
parseCondTree hasElif grammar cond = go
where
go fields = do
let (fs, ss) = partitionFields fields
......@@ -328,8 +332,8 @@ parseCondTree grammar cond = go
elseFields <- go fields
sections' <- parseIfs sections
return (Just elseFields, sections')
{-
parseElseIfs (MkSection (Name _ name) test fields : sections) | name == "elif" = do
parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do
-- TODO: check cabal-version
test' <- parseConditionConfVar test
fields' <- go fields
......@@ -337,7 +341,7 @@ parseCondTree grammar cond = go
-- we parse an empty 'Fields', to get empty value for a node
a <- parseFieldGrammar mempty grammar
return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections')
-}
parseElseIfs sections = (,) Nothing <$> parseIfs sections
{- Note [Accumulating parser]
......
......@@ -17,6 +17,7 @@
* Added '.Lens' modules, with optics for package description data
types. (#4701)
* Support for GHC's numeric -g debug levels (#4673).
* Added elif-conditionals to .cabal syntax (#4750)
* TODO
......
......@@ -2284,6 +2284,17 @@ or
Note that the ``if`` and the condition have to be all on the same line.
Since Cabal 2.2 conditional blocks support ``elif`` construct.
::
if condition1
property-descriptions-or-conditionals
elif condition2
property-descriptions-or-conditionals
else
property-descriptions-or-conditionals
Conditions
""""""""""
......
......@@ -80,6 +80,7 @@ regressionTests = testGroup "regressions"
, regressionTest "issue-774.cabal"
, regressionTest "generics-sop.cabal"
, regressionTest "elif.cabal"
, regressionTest "elif2.cabal"
, regressionTest "shake.cabal"
]
......
name: elif
version: 0
synopsis: The elif demo
build-type: Simple
cabal-version: >=2.1
source-repository head
Type: git
Location: https://github.com/hvr/-.git
library
default-language: Haskell2010
exposed-modules: ElseIf
if os(linux)
build-depends: unix
elif os(windows)
build-depends: Win32
else
buildable: False
name: elif
version: 0
synopsis: The elif demo
cabal-version: >=2.1
build-type: Simple
source-repository head
type: git
location: https://github.com/hvr/-.git
library
exposed-modules:
ElseIf
default-language: Haskell2010
if os(linux)
build-depends:
unix -any
else
if os(windows)
build-depends:
Win32 -any
else
buildable: False
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment