Distribution/Fields/ConfVar.hs

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

    import Distribution.Compat.CharParsing              (char, integral)
    import Distribution.Compat.Prelude
    import Distribution.Parsec                    (Parsec (..), runParsecParser, Position (..))
    import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
    import Distribution.Fields.Field                    (SectionArg (..))
    import Distribution.Fields.ParseResult
    import Distribution.Types.Condition
    import Distribution.Types.GenericPackageDescription (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 args =
        -- The name of the input file is irrelevant, as we reformat the error message.
        case P.runParser (parser <* P.eof) () "<condition>" args of
            Right x  -> pure x
            Left err -> do
                -- Mangle the position to the actual one
                let ppos = P.errorPos err
                let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
                let msg = P.showErrorMessages
                        "or" "unknown parse error" "expecting" "unexpected" "end of input"
                        (P.errorMessages err)
                parseFailure epos msg
                pure $ Lit True

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

    parser :: Parser (Condition ConfVar)
    parser = condOr
      where
        condOr       = P.sepBy1 condAnd (oper "||") >>= return . foldl1 COr
        condAnd      = P.sepBy1 cond    (oper "&&") >>= return . foldl1 CAnd
        cond         = P.choice
             [ boolLiteral, parens condOr,  notCond, osCond, archCond, flagCond, implCond ]

        notCond      = CNot <$ oper "!" <*> cond

        boolLiteral  = Lit <$> boolLiteral'
        osCond       = Var . OS   <$ string "os"   <*> parens fromParsec
        flagCond     = Var . Flag <$ string "flag" <*> parens fromParsec
        archCond     = Var . Arch <$ string "arch" <*> parens fromParsec
        implCond     = Var        <$ string "impl" <*> parens implCond'

        implCond'    = Impl
            <$> fromParsec
            <*> P.option anyVersion versionRange

        version = fromParsec
        versionStar  = mkVersion <$> fromParsec' versionStar' <* oper "*"
        versionStar' = some (integral <* char '.')

        versionRange = expr
          where
            expr = foldl1 unionVersionRanges     <$> P.sepBy1 term   (oper "||")
            term = foldl1 intersectVersionRanges <$> P.sepBy1 factor (oper "&&")

            factor = P.choice
                $ parens expr
                : parseAnyVersion
                : parseNoVersion
                : parseWildcardRange
                : map parseRangeOp rangeOps

            parseAnyVersion    = anyVersion <$ string "-any"
            parseNoVersion     = noVersion  <$ string "-none"

            parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar

            parseRangeOp (s,f) = P.try (f <$ oper s <*> version)
            rangeOps = [ ("<",  earlierVersion),
                         ("<=", orEarlierVersion),
                         (">",  laterVersion),
                         (">=", orLaterVersion),
                         ("^>=", majorBoundVersion),
                         ("==", thisVersion) ]

        -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"
        identBS = tokenPrim $ \t -> case t of
            SecArgName _ s -> Just s
            _              -> Nothing

        boolLiteral' = tokenPrim $ \t -> case t of
            SecArgName _ s
                | s == "True"  -> Just True
                | s == "true"  -> Just True
                | s == "False" -> Just False
                | s == "false" -> Just False
            _                  -> Nothing

        string s = tokenPrim $ \t -> case t of
            SecArgName _ s' | s == s' -> Just ()
            _                         -> Nothing

        oper o = tokenPrim $ \t -> case t of
            SecArgOther _ o' | o == o' -> Just ()
            _                          -> Nothing

        parens = P.between (oper "(") (oper ")")

        tokenPrim = P.tokenPrim prettySectionArg updatePosition
        -- TODO: check where the errors are reported
        updatePosition x _ _ = x
        prettySectionArg = show

        fromParsec :: Parsec a => Parser a
        fromParsec = fromParsec' parsec

        fromParsec' p = do
            bs <- identBS
            let fls = fieldLineStreamFromBS bs
            either (fail . show) pure (runParsecParser p "<fromParsec'>" fls)