{-# LANGUAGE OverloadedStrings #-}
module Distribution.Fields.ConfVar (parseConditionConfVar) where

import Distribution.Compat.CharParsing     (char, integral)
import Distribution.Compat.Prelude
import Distribution.Fields.Field           (SectionArg (..))
import Distribution.Fields.ParseResult
import Distribution.Parsec                 (Parsec (..), Position (..), runParsecParser)
import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
import Distribution.Types.Condition
import Distribution.Types.ConfVar          (ConfVar (..))
import Distribution.Version
       (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion,
       mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges,
       withinVersion)
import Prelude ()

import qualified Text.Parsec       as P
import qualified Text.Parsec.Error as P

-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
-- based outline parser.
parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
parseConditionConfVar [SectionArg Position]
args =
    -- The name of the input file is irrelevant, as we reformat the error message.
    case forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> SourceName -> s -> Either ParseError a
P.runParser (ParsecT [SectionArg Position] () Identity (Condition ConfVar)
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
P.eof) () SourceName
"<condition>" [SectionArg Position]
args of
        Right Condition ConfVar
x  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Condition ConfVar
x
        Left ParseError
err -> do
            -- Mangle the position to the actual one
            let ppos :: SourcePos
ppos = ParseError -> SourcePos
P.errorPos ParseError
err
            let epos :: Position
epos = Int -> Int -> Position
Position (SourcePos -> Int
P.sourceLine SourcePos
ppos) (SourcePos -> Int
P.sourceColumn SourcePos
ppos)
            let msg :: SourceName
msg = SourceName
-> SourceName
-> SourceName
-> SourceName
-> SourceName
-> [Message]
-> SourceName
P.showErrorMessages
                    SourceName
"or" SourceName
"unknown parse error" SourceName
"expecting" SourceName
"unexpected" SourceName
"end of input"
                    (ParseError -> [Message]
P.errorMessages ParseError
err)
            Position -> SourceName -> ParseResult ()
parseFailure Position
epos SourceName
msg
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall c. Bool -> Condition c
Lit Bool
True

type Parser = P.Parsec [SectionArg Position] ()

sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a)
sepByNonEmpty :: forall a sep. Parser a -> Parser sep -> Parser (NonEmpty a)
sepByNonEmpty Parser a
p Parser sep
sep = forall a. a -> [a] -> NonEmpty a
(:|) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser a
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser sep
sep forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser a
p)

parser :: Parser (Condition ConfVar)
parser :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
parser = ParsecT [SectionArg Position] () Identity (Condition ConfVar)
condOr
  where
    condOr :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
condOr       = forall a sep. Parser a -> Parser sep -> Parser (NonEmpty a)
sepByNonEmpty ParsecT [SectionArg Position] () Identity (Condition ConfVar)
condAnd (forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"||") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> a) -> NonEmpty a -> a
foldl1 forall c. Condition c -> Condition c -> Condition c
COr
    condAnd :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
condAnd      = forall a sep. Parser a -> Parser sep -> Parser (NonEmpty a)
sepByNonEmpty ParsecT [SectionArg Position] () Identity (Condition ConfVar)
cond    (forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"&&") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> a) -> NonEmpty a -> a
foldl1 forall c. Condition c -> Condition c -> Condition c
CAnd
    cond :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
cond         = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice
         [ forall {u} {c}.
ParsecT [SectionArg Position] u Identity (Condition c)
boolLiteral, forall {u} {a}.
ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens ParsecT [SectionArg Position] () Identity (Condition ConfVar)
condOr,  ParsecT [SectionArg Position] () Identity (Condition ConfVar)
notCond, ParsecT [SectionArg Position] () Identity (Condition ConfVar)
osCond, ParsecT [SectionArg Position] () Identity (Condition ConfVar)
archCond, ParsecT [SectionArg Position] () Identity (Condition ConfVar)
flagCond, ParsecT [SectionArg Position] () Identity (Condition ConfVar)
implCond ]

    notCond :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
notCond      = forall c. Condition c -> Condition c
CNot forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"!" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT [SectionArg Position] () Identity (Condition ConfVar)
cond

    boolLiteral :: ParsecT [SectionArg Position] u Identity (Condition c)
boolLiteral  = forall c. Bool -> Condition c
Lit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {u}. ParsecT [SectionArg Position] u Identity Bool
boolLiteral'
    osCond :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
osCond       = forall c. c -> Condition c
Var forall b c a. (b -> c) -> (a -> b) -> a -> c
. OS -> ConfVar
OS   forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
"os"   forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u} {a}.
ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens forall a. Parsec a => Parser a
fromParsec
    flagCond :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
flagCond     = forall c. c -> Condition c
Var forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagName -> ConfVar
PackageFlag forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
"flag" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u} {a}.
ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens forall a. Parsec a => Parser a
fromParsec
    archCond :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
archCond     = forall c. c -> Condition c
Var forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arch -> ConfVar
Arch forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
"arch" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u} {a}.
ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens forall a. Parsec a => Parser a
fromParsec
    implCond :: ParsecT [SectionArg Position] () Identity (Condition ConfVar)
implCond     = forall c. c -> Condition c
Var        forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
"impl" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u} {a}.
ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens ParsecT [SectionArg Position] () Identity ConfVar
implCond'

    implCond' :: ParsecT [SectionArg Position] () Identity ConfVar
implCond'    = CompilerFlavor -> VersionRange -> ConfVar
Impl
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parsec a => Parser a
fromParsec
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
P.option VersionRange
anyVersion ParsecT [SectionArg Position] () Identity VersionRange
versionRange

    version :: Parser Version
version = forall a. Parsec a => Parser a
fromParsec
    versionStar :: ParsecT [SectionArg Position] u Identity Version
versionStar  = [Int] -> Version
mkVersion forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b} {u}.
ParsecParser b -> ParsecT [SectionArg Position] u Identity b
fromParsec' ParsecParser [Int]
versionStar' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"*"
    versionStar' :: ParsecParser [Int]
versionStar' = forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
integral forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). CharParsing m => Char -> m Char
char Char
'.')

    versionRange :: ParsecT [SectionArg Position] () Identity VersionRange
versionRange = ParsecT [SectionArg Position] () Identity VersionRange
expr
      where
        expr :: ParsecT [SectionArg Position] () Identity VersionRange
expr = forall a. (a -> a -> a) -> NonEmpty a -> a
foldl1 VersionRange -> VersionRange -> VersionRange
unionVersionRanges     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a sep. Parser a -> Parser sep -> Parser (NonEmpty a)
sepByNonEmpty ParsecT [SectionArg Position] () Identity VersionRange
term   (forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"||")
        term :: ParsecT [SectionArg Position] () Identity VersionRange
term = forall a. (a -> a -> a) -> NonEmpty a -> a
foldl1 VersionRange -> VersionRange -> VersionRange
intersectVersionRanges forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a sep. Parser a -> Parser sep -> Parser (NonEmpty a)
sepByNonEmpty ParsecT [SectionArg Position] () Identity VersionRange
factor (forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"&&")

        factor :: ParsecT [SectionArg Position] () Identity VersionRange
factor = forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
P.choice
            forall a b. (a -> b) -> a -> b
$ forall {u} {a}.
ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens ParsecT [SectionArg Position] () Identity VersionRange
expr
            forall a. a -> [a] -> [a]
: forall {u}. ParsecT [SectionArg Position] u Identity VersionRange
parseAnyVersion
            forall a. a -> [a] -> [a]
: forall {u}. ParsecT [SectionArg Position] u Identity VersionRange
parseNoVersion
            forall a. a -> [a] -> [a]
: forall {u}. ParsecT [SectionArg Position] u Identity VersionRange
parseWildcardRange
            forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a}.
(ByteString, Version -> a)
-> ParsecT [SectionArg Position] () Identity a
parseRangeOp [(ByteString, Version -> VersionRange)]
rangeOps

        parseAnyVersion :: ParsecT [SectionArg Position] u Identity VersionRange
parseAnyVersion    = VersionRange
anyVersion forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
"-any"
        parseNoVersion :: ParsecT [SectionArg Position] u Identity VersionRange
parseNoVersion     = VersionRange
noVersion  forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
"-none"

        parseWildcardRange :: ParsecT [SectionArg Position] u Identity VersionRange
parseWildcardRange = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try forall a b. (a -> b) -> a -> b
$ Version -> VersionRange
withinVersion forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"==" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {u}. ParsecT [SectionArg Position] u Identity Version
versionStar

        parseRangeOp :: (ByteString, Version -> a)
-> ParsecT [SectionArg Position] () Identity a
parseRangeOp (ByteString
s,Version -> a
f) = forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (Version -> a
f forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
s forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Version
version)
        rangeOps :: [(ByteString, Version -> VersionRange)]
rangeOps = [ (ByteString
"<",  Version -> VersionRange
earlierVersion),
                     (ByteString
"<=", Version -> VersionRange
orEarlierVersion),
                     (ByteString
">",  Version -> VersionRange
laterVersion),
                     (ByteString
">=", Version -> VersionRange
orLaterVersion),
                     (ByteString
"^>=", Version -> VersionRange
majorBoundVersion),
                     (ByteString
"==", Version -> VersionRange
thisVersion) ]

    -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"
    identBS :: ParsecT [SectionArg Position] u Identity ByteString
identBS = forall {a} {u}.
(SectionArg Position -> Maybe a)
-> ParsecT [SectionArg Position] u Identity a
tokenPrim forall a b. (a -> b) -> a -> b
$ \SectionArg Position
t -> case SectionArg Position
t of
        SecArgName Position
_ ByteString
s -> forall a. a -> Maybe a
Just ByteString
s
        SectionArg Position
_              -> forall a. Maybe a
Nothing

    boolLiteral' :: ParsecT [SectionArg Position] u Identity Bool
boolLiteral' = forall {a} {u}.
(SectionArg Position -> Maybe a)
-> ParsecT [SectionArg Position] u Identity a
tokenPrim forall a b. (a -> b) -> a -> b
$ \SectionArg Position
t -> case SectionArg Position
t of
        SecArgName Position
_ ByteString
s
            | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
"True"  -> forall a. a -> Maybe a
Just Bool
True
            | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
"true"  -> forall a. a -> Maybe a
Just Bool
True
            | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
"False" -> forall a. a -> Maybe a
Just Bool
False
            | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
"false" -> forall a. a -> Maybe a
Just Bool
False
        SectionArg Position
_                  -> forall a. Maybe a
Nothing

    string :: ByteString -> ParsecT [SectionArg Position] u Identity ()
string ByteString
s = forall {a} {u}.
(SectionArg Position -> Maybe a)
-> ParsecT [SectionArg Position] u Identity a
tokenPrim forall a b. (a -> b) -> a -> b
$ \SectionArg Position
t -> case SectionArg Position
t of
        SecArgName Position
_ ByteString
s' | ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
s' -> forall a. a -> Maybe a
Just ()
        SectionArg Position
_                         -> forall a. Maybe a
Nothing

    oper :: ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
o = forall {a} {u}.
(SectionArg Position -> Maybe a)
-> ParsecT [SectionArg Position] u Identity a
tokenPrim forall a b. (a -> b) -> a -> b
$ \SectionArg Position
t -> case SectionArg Position
t of
        SecArgOther Position
_ ByteString
o' | ByteString
o forall a. Eq a => a -> a -> Bool
== ByteString
o' -> forall a. a -> Maybe a
Just ()
        SectionArg Position
_                          -> forall a. Maybe a
Nothing

    parens :: ParsecT [SectionArg Position] u Identity a
-> ParsecT [SectionArg Position] u Identity a
parens = forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
P.between (forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
"(") (forall {u}.
ByteString -> ParsecT [SectionArg Position] u Identity ()
oper ByteString
")")

    tokenPrim :: (SectionArg Position -> Maybe a)
-> ParsecT [SectionArg Position] u Identity a
tokenPrim = forall s (m :: * -> *) t a u.
Stream s m t =>
(t -> SourceName)
-> (SourcePos -> t -> s -> SourcePos)
-> (t -> Maybe a)
-> ParsecT s u m a
P.tokenPrim SectionArg Position -> SourceName
prettySectionArg forall {p} {p} {p}. p -> p -> p -> p
updatePosition
    -- TODO: check where the errors are reported
    updatePosition :: p -> p -> p -> p
updatePosition p
x p
_ p
_ = p
x
    prettySectionArg :: SectionArg Position -> SourceName
prettySectionArg = forall a. Show a => a -> SourceName
show

    fromParsec :: Parsec a => Parser a
    fromParsec :: forall a. Parsec a => Parser a
fromParsec = forall {b} {u}.
ParsecParser b -> ParsecT [SectionArg Position] u Identity b
fromParsec' forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec

    fromParsec' :: ParsecParser b -> ParsecT [SectionArg Position] u Identity b
fromParsec' ParsecParser b
p = do
        ByteString
bs <- forall {u}. ParsecT [SectionArg Position] u Identity ByteString
identBS
        let fls :: FieldLineStream
fls = ByteString -> FieldLineStream
fieldLineStreamFromBS ByteString
bs
        forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => SourceName -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> SourceName
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a.
ParsecParser a
-> SourceName -> FieldLineStream -> Either ParseError a
runParsecParser ParsecParser b
p SourceName
"<fromParsec'>" FieldLineStream
fls)