1{-# LANGUAGE OverloadedStrings #-} 2module Distribution.Fields.ConfVar (parseConditionConfVar) where 3 4import Distribution.Compat.CharParsing (char, integral) 5import Distribution.Compat.Prelude 6import Distribution.Fields.Field (SectionArg (..)) 7import Distribution.Fields.ParseResult 8import Distribution.Parsec (Parsec (..), Position (..), runParsecParser) 9import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) 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 . PackageFlag <$ 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