1{-# LANGUAGE OverloadedStrings #-}
2module Distribution.Fields.ConfVar (parseConditionConfVar) where
3
4import Distribution.Compat.CharParsing              (char, integral)
5import Distribution.Compat.Prelude
6import Distribution.Parsec                    (Parsec (..), runParsecParser, Position (..))
7import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS)
8import Distribution.Fields.Field                    (SectionArg (..))
9import Distribution.Fields.ParseResult
10import Distribution.Types.Condition
11import Distribution.Types.ConfVar (ConfVar (..))
12import Distribution.Version
13       (anyVersion, earlierVersion, intersectVersionRanges, laterVersion, majorBoundVersion,
14       mkVersion, noVersion, orEarlierVersion, orLaterVersion, thisVersion, unionVersionRanges,
15       withinVersion)
16import Prelude ()
17
18import qualified Text.Parsec       as P
19import qualified Text.Parsec.Error as P
20
21-- | Parse @'Condition' 'ConfVar'@ from section arguments provided by parsec
22-- based outline parser.
23parseConditionConfVar :: [SectionArg Position] -> ParseResult (Condition ConfVar)
24parseConditionConfVar args =
25    -- The name of the input file is irrelevant, as we reformat the error message.
26    case P.runParser (parser <* P.eof) () "<condition>" args of
27        Right x  -> pure x
28        Left err -> do
29            -- Mangle the position to the actual one
30            let ppos = P.errorPos err
31            let epos = Position (P.sourceLine ppos) (P.sourceColumn ppos)
32            let msg = P.showErrorMessages
33                    "or" "unknown parse error" "expecting" "unexpected" "end of input"
34                    (P.errorMessages err)
35            parseFailure epos msg
36            pure $ Lit True
37
38type Parser = P.Parsec [SectionArg Position] ()
39
40sepByNonEmpty :: Parser a -> Parser sep -> Parser (NonEmpty a)
41sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p)
42
43parser :: Parser (Condition ConfVar)
44parser = condOr
45  where
46    condOr       = sepByNonEmpty condAnd (oper "||") >>= return . foldl1 COr
47    condAnd      = sepByNonEmpty cond    (oper "&&") >>= return . foldl1 CAnd
48    cond         = P.choice
49         [ boolLiteral, parens condOr,  notCond, osCond, archCond, flagCond, implCond ]
50
51    notCond      = CNot <$ oper "!" <*> cond
52
53    boolLiteral  = Lit <$> boolLiteral'
54    osCond       = Var . OS   <$ string "os"   <*> parens fromParsec
55    flagCond     = Var . Flag <$ string "flag" <*> parens fromParsec
56    archCond     = Var . Arch <$ string "arch" <*> parens fromParsec
57    implCond     = Var        <$ string "impl" <*> parens implCond'
58
59    implCond'    = Impl
60        <$> fromParsec
61        <*> P.option anyVersion versionRange
62
63    version = fromParsec
64    versionStar  = mkVersion <$> fromParsec' versionStar' <* oper "*"
65    versionStar' = some (integral <* char '.')
66
67    versionRange = expr
68      where
69        expr = foldl1 unionVersionRanges     <$> sepByNonEmpty term   (oper "||")
70        term = foldl1 intersectVersionRanges <$> sepByNonEmpty factor (oper "&&")
71
72        factor = P.choice
73            $ parens expr
74            : parseAnyVersion
75            : parseNoVersion
76            : parseWildcardRange
77            : map parseRangeOp rangeOps
78
79        parseAnyVersion    = anyVersion <$ string "-any"
80        parseNoVersion     = noVersion  <$ string "-none"
81
82        parseWildcardRange = P.try $ withinVersion <$ oper "==" <*> versionStar
83
84        parseRangeOp (s,f) = P.try (f <$ oper s <*> version)
85        rangeOps = [ ("<",  earlierVersion),
86                     ("<=", orEarlierVersion),
87                     (">",  laterVersion),
88                     (">=", orLaterVersion),
89                     ("^>=", majorBoundVersion),
90                     ("==", thisVersion) ]
91
92    -- Number token can have many dots in it: SecArgNum (Position 65 15) "7.6.1"
93    identBS = tokenPrim $ \t -> case t of
94        SecArgName _ s -> Just s
95        _              -> Nothing
96
97    boolLiteral' = tokenPrim $ \t -> case t of
98        SecArgName _ s
99            | s == "True"  -> Just True
100            | s == "true"  -> Just True
101            | s == "False" -> Just False
102            | s == "false" -> Just False
103        _                  -> Nothing
104
105    string s = tokenPrim $ \t -> case t of
106        SecArgName _ s' | s == s' -> Just ()
107        _                         -> Nothing
108
109    oper o = tokenPrim $ \t -> case t of
110        SecArgOther _ o' | o == o' -> Just ()
111        _                          -> Nothing
112
113    parens = P.between (oper "(") (oper ")")
114
115    tokenPrim = P.tokenPrim prettySectionArg updatePosition
116    -- TODO: check where the errors are reported
117    updatePosition x _ _ = x
118    prettySectionArg = show
119
120    fromParsec :: Parsec a => Parser a
121    fromParsec = fromParsec' parsec
122
123    fromParsec' p = do
124        bs <- identBS
125        let fls = fieldLineStreamFromBS bs
126        either (fail . show) pure (runParsecParser p "<fromParsec'>" fls)
127