{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Parsec ( Parsec(..), ParsecParser (..), runParsecParser, runParsecParser', simpleParsec, simpleParsecBS, simpleParsec', simpleParsecW', lexemeParsec, eitherParsec, explicitEitherParsec, explicitEitherParsec', -- * CabalParsing and diagnostics CabalParsing (..), -- ** Warnings PWarnType (..), PWarning (..), showPWarning, -- ** Errors PError (..), showPError, -- * Position Position (..), incPos, retPos, showPos, zeroPos, -- * Utilities parsecToken, parsecToken', parsecFilePath, parsecQuoted, parsecMaybeQuoted, parsecCommaList, parsecCommaNonEmpty, parsecLeadingCommaList, parsecLeadingCommaNonEmpty, parsecOptCommaList, parsecLeadingOptCommaList, parsecStandard, parsecUnqualComponentName, ) where import Data.ByteString (ByteString) import Data.Char (digitToInt, intToDigit) import Data.List (transpose) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude import Distribution.Parsec.Error (PError (..), showPError) import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) import Distribution.Parsec.Warning (PWarnType (..), PWarning (..), showPWarning) import Numeric (showIntAtBase) import Prelude () import qualified Distribution.Compat.CharParsing as P import qualified Distribution.Compat.DList as DList import qualified Distribution.Compat.MonadFail as Fail import qualified Text.Parsec as Parsec ------------------------------------------------------------------------------- -- Class ------------------------------------------------------------------------------- -- | Class for parsing with @parsec@. Mainly used for @.cabal@ file fields. -- -- For parsing @.cabal@ like file structure, see "Distribution.Fields". -- class Parsec a where parsec :: CabalParsing m => m a -- | Parsing class which -- -- * can report Cabal parser warnings. -- -- * knows @cabal-version@ we work with -- class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where parsecWarning :: PWarnType -> String -> m () parsecHaskellString :: m String parsecHaskellString = stringLiteral askCabalSpecVersion :: m CabalSpecVersion -- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. lexemeParsec :: (CabalParsing m, Parsec a) => m a lexemeParsec = parsec <* P.spaces newtype ParsecParser a = PP { unPP :: CabalSpecVersion -> Parsec.Parsec FieldLineStream [PWarning] a } liftParsec :: Parsec.Parsec FieldLineStream [PWarning] a -> ParsecParser a liftParsec p = PP $ \_ -> p instance Functor ParsecParser where fmap f p = PP $ \v -> fmap f (unPP p v) {-# INLINE fmap #-} x <$ p = PP $ \v -> x <$ unPP p v {-# INLINE (<$) #-} instance Applicative ParsecParser where pure = liftParsec . pure {-# INLINE pure #-} f <*> x = PP $ \v -> unPP f v <*> unPP x v {-# INLINE (<*>) #-} f *> x = PP $ \v -> unPP f v *> unPP x v {-# INLINE (*>) #-} f <* x = PP $ \v -> unPP f v <* unPP x v {-# INLINE (<*) #-} instance Alternative ParsecParser where empty = liftParsec empty a <|> b = PP $ \v -> unPP a v <|> unPP b v {-# INLINE (<|>) #-} many p = PP $ \v -> many (unPP p v) {-# INLINE many #-} some p = PP $ \v -> some (unPP p v) {-# INLINE some #-} instance Monad ParsecParser where return = pure m >>= k = PP $ \v -> unPP m v >>= \x -> unPP (k x) v {-# INLINE (>>=) #-} (>>) = (*>) {-# INLINE (>>) #-} #if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail #endif instance MonadPlus ParsecParser where mzero = empty mplus = (<|>) instance Fail.MonadFail ParsecParser where fail = P.unexpected instance P.Parsing ParsecParser where try p = PP $ \v -> P.try (unPP p v) p d = PP $ \v -> unPP p v P. d skipMany p = PP $ \v -> P.skipMany (unPP p v) skipSome p = PP $ \v -> P.skipSome (unPP p v) unexpected = liftParsec . P.unexpected eof = liftParsec P.eof notFollowedBy p = PP $ \v -> P.notFollowedBy (unPP p v) instance P.CharParsing ParsecParser where satisfy = liftParsec . P.satisfy char = liftParsec . P.char notChar = liftParsec . P.notChar anyChar = liftParsec P.anyChar string = liftParsec . P.string instance CabalParsing ParsecParser where parsecWarning t w = liftParsec $ do spos <- Parsec.getPosition Parsec.modifyState (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) askCabalSpecVersion = PP pure -- | Parse a 'String' with 'lexemeParsec'. simpleParsec :: Parsec a => String -> Maybe a simpleParsec = either (const Nothing) Just . runParsecParser lexemeParsec "" . fieldLineStreamFromString -- | Like 'simpleParsec' but for 'ByteString' simpleParsecBS :: Parsec a => ByteString -> Maybe a simpleParsecBS = either (const Nothing) Just . runParsecParser lexemeParsec "" . fieldLineStreamFromBS -- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. -- -- @since 3.4.0.0 simpleParsec' :: Parsec a => CabalSpecVersion -> String -> Maybe a simpleParsec' spec = either (const Nothing) Just . runParsecParser' spec lexemeParsec "" . fieldLineStreamFromString -- | Parse a 'String' with 'lexemeParsec' using specific 'CabalSpecVersion'. -- Fail if there are any warnings. -- -- @since 3.4.0.0 simpleParsecW' :: Parsec a => CabalSpecVersion -> String -> Maybe a simpleParsecW' spec = either (const Nothing) (\(x, ws) -> if null ws then Just x else Nothing) . runParsecParser' spec ((,) <$> lexemeParsec <*> liftParsec Parsec.getState) "" . fieldLineStreamFromString -- | Parse a 'String' with 'lexemeParsec'. eitherParsec :: Parsec a => String -> Either String a eitherParsec = explicitEitherParsec parsec -- | Parse a 'String' with given 'ParsecParser'. Trailing whitespace is accepted. explicitEitherParsec :: ParsecParser a -> String -> Either String a explicitEitherParsec parser = either (Left . show) Right . runParsecParser (parser <* P.spaces) "" . fieldLineStreamFromString -- | Parse a 'String' with given 'ParsecParser' and 'CabalSpecVersion'. Trailing whitespace is accepted. -- See 'explicitEitherParsec'. -- -- @since 3.4.0.0 -- explicitEitherParsec' :: CabalSpecVersion -> ParsecParser a -> String -> Either String a explicitEitherParsec' spec parser = either (Left . show) Right . runParsecParser' spec (parser <* P.spaces) "" . fieldLineStreamFromString -- | Run 'ParsecParser' with 'cabalSpecLatest'. runParsecParser :: ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a runParsecParser = runParsecParser' cabalSpecLatest -- | Like 'runParsecParser' but lets specify 'CabalSpecVersion' used. -- -- @since 3.0.0.0 -- runParsecParser' :: CabalSpecVersion -> ParsecParser a -> FilePath -> FieldLineStream -> Either Parsec.ParseError a runParsecParser' v p n = Parsec.runParser (unPP p v <* P.eof) [] n instance Parsec a => Parsec (Identity a) where parsec = Identity <$> parsec instance Parsec Bool where parsec = P.munch1 isAlpha >>= postprocess where postprocess str | str == "True" = pure True | str == "False" = pure False | lstr == "true" = parsecWarning PWTBoolCase caseWarning *> pure True | lstr == "false" = parsecWarning PWTBoolCase caseWarning *> pure False | otherwise = fail $ "Not a boolean: " ++ str where lstr = map toLower str caseWarning = "Boolean values are case sensitive, use 'True' or 'False'." -- | @[^ ,]@ parsecToken :: CabalParsing m => m String parsecToken = parsecHaskellString <|> ((P.munch1 (\x -> not (isSpace x) && x /= ',') P. "identifier" ) >>= checkNotDoubleDash) -- | @[^ ]@ parsecToken' :: CabalParsing m => m String parsecToken' = parsecHaskellString <|> ((P.munch1 (not . isSpace) P. "token") >>= checkNotDoubleDash) checkNotDoubleDash :: CabalParsing m => String -> m String checkNotDoubleDash s = do when (s == "--") $ parsecWarning PWTDoubleDash $ unwords [ "Double-dash token found." , "Note: there are no end-of-line comments in .cabal files, only whole line comments." , "Use \"--\" (quoted double dash) to silence this warning, if you actually want -- token" ] return s parsecFilePath :: CabalParsing m => m FilePath parsecFilePath = parsecToken -- | Parse a benchmark/test-suite types. parsecStandard :: (CabalParsing m, Parsec ver) => (ver -> String -> a) -> m a parsecStandard f = do cs <- some $ P.try (component <* P.char '-') ver <- parsec let name = map toLower (intercalate "-" cs) return $! f ver name where component = do cs <- P.munch1 isAlphaNum if all isDigit cs then fail "all digit component" else return cs -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). parsecCommaList :: CabalParsing m => m a -> m [a] parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") parsecCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) parsecCommaNonEmpty p = P.sepByNonEmpty (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") -- | Like 'parsecCommaList' but accept leading or trailing comma. -- -- @ -- p (comma p)* -- p `sepBy` comma -- (comma p)* -- leading comma -- (p comma)* -- trailing comma -- @ parsecLeadingCommaList :: CabalParsing m => m a -> m [a] parsecLeadingCommaList p = do c <- P.optional comma case c of Nothing -> toList <$> P.sepEndByNonEmpty lp comma <|> pure [] Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" -- | -- -- @since 3.4.0.0 parsecLeadingCommaNonEmpty :: CabalParsing m => m a -> m (NonEmpty a) parsecLeadingCommaNonEmpty p = do c <- P.optional comma case c of Nothing -> P.sepEndByNonEmpty lp comma Just _ -> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" parsecOptCommaList :: CabalParsing m => m a -> m [a] parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) where comma = P.char ',' *> P.spaces -- | Like 'parsecOptCommaList' but -- -- * require all or none commas -- * accept leading or trailing comma. -- -- @ -- p (comma p)* -- p `sepBy` comma -- (comma p)* -- leading comma -- (p comma)* -- trailing comma -- p* -- no commas: many p -- @ -- -- @since 3.0.0.0 -- parsecLeadingOptCommaList :: CabalParsing m => m a -> m [a] parsecLeadingOptCommaList p = do c <- P.optional comma case c of Nothing -> sepEndBy1Start <|> pure [] Just _ -> toList <$> P.sepByNonEmpty lp comma where lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" sepEndBy1Start = do x <- lp c <- P.optional comma case c of Nothing -> (x :) <$> many lp Just _ -> (x :) <$> P.sepEndBy lp comma -- | Content isn't unquoted parsecQuoted :: CabalParsing m => m a -> m a parsecQuoted = P.between (P.char '"') (P.char '"') -- | @parsecMaybeQuoted p = 'parsecQuoted' p <|> p@. parsecMaybeQuoted :: CabalParsing m => m a -> m a parsecMaybeQuoted p = parsecQuoted p <|> p parsecUnqualComponentName :: forall m. CabalParsing m => m String parsecUnqualComponentName = state0 DList.empty where -- -- using @kleene@ package we can easily see that -- we need only two states to recognize -- unqual-component-name -- -- Compare with declarative -- 'Distribution.FieldGrammar.Described.reUnqualComponent'. -- -- @ -- import Kleene -- import Kleene.Internal.Pretty -- import Algebra.Lattice -- import Data.Char -- -- import qualified Data.RangeSet.Map as RSet -- -- main = do -- -- this is an approximation, to get an idea. -- let component :: RE Char -- component = star alphaNum <> alpha <> star alphaNum -- -- alphaNum = alpha \/ num -- alpha = unions $ map char ['a'..'z'] -- num = unions $ map char ['0'..'9'] -- -- re :: RE Char -- re = component <> star (char '-' <> component) -- -- putPretty re -- putPretty $ fromTM re -- @ state0 :: DList.DList Char -> m String state0 acc = do c <- ch -- <|> fail ("Invalid component, after " ++ DList.toList acc) case () of _ | isDigit c -> state0 (DList.snoc acc c) | isAlphaNum c -> state1 (DList.snoc acc c) | c == '-' -> fail ("Empty component, after " ++ DList.toList acc) | otherwise -> fail ("Internal error, after " ++ DList.toList acc) state1 :: DList.DList Char -> m String state1 acc = state1' acc `alt` return (DList.toList acc) state1' :: DList.DList Char -> m String state1' acc = do c <- ch case () of _ | isAlphaNum c -> state1 (DList.snoc acc c) | c == '-' -> state0 (DList.snoc acc c) | otherwise -> fail ("Internal error, after " ++ DList.toList acc) ch :: m Char !ch = P.satisfy (\c -> isAlphaNum c || c == '-') alt :: m String -> m String -> m String !alt = (<|>) stringLiteral :: forall m. P.CharParsing m => m String stringLiteral = lit where lit :: m String lit = foldr (maybe id (:)) "" <$> P.between (P.char '"') (P.char '"' P. "end of string") (many stringChar) P. "string" stringChar :: m (Maybe Char) stringChar = Just <$> stringLetter <|> stringEscape P. "string character" stringLetter :: m Char stringLetter = P.satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) stringEscape :: m (Maybe Char) stringEscape = P.char '\\' *> esc where esc :: m (Maybe Char) esc = Nothing <$ escapeGap <|> Nothing <$ escapeEmpty <|> Just <$> escapeCode escapeEmpty, escapeGap :: m Char escapeEmpty = P.char '&' escapeGap = P.skipSpaces1 *> (P.char '\\' P. "end of string gap") escapeCode :: forall m. P.CharParsing m => m Char escapeCode = (charEsc <|> charNum <|> charAscii <|> charControl) P. "escape code" where charControl, charNum :: m Char charControl = (\c -> toEnum (fromEnum c - fromEnum '@')) <$> (P.char '^' *> (P.upper <|> P.char '@')) charNum = toEnum <$> num where num :: m Int num = bounded 10 maxchar <|> (P.char 'o' *> bounded 8 maxchar) <|> (P.char 'x' *> bounded 16 maxchar) maxchar = fromEnum (maxBound :: Char) bounded :: Int -> Int -> m Int bounded base bnd = foldl' (\x d -> base * x + digitToInt d) 0 <$> bounded' (take base thedigits) (map digitToInt $ showIntAtBase base intToDigit bnd "") where thedigits :: [m Char] thedigits = map P.char ['0'..'9'] ++ map P.oneOf (transpose [['A'..'F'],['a'..'f']]) toomuch :: m a toomuch = P.unexpected "out-of-range numeric escape sequence" bounded', bounded'' :: [m Char] -> [Int] -> m [Char] bounded' dps@(zero:_) bds = P.skipSome zero *> ([] <$ P.notFollowedBy (P.choice dps) <|> bounded'' dps bds) <|> bounded'' dps bds bounded' [] _ = error "bounded called with base 0" bounded'' dps [] = [] <$ P.notFollowedBy (P.choice dps) <|> toomuch bounded'' dps (bd : bds) = let anyd :: m Char anyd = P.choice dps nomore :: m () nomore = P.notFollowedBy anyd <|> toomuch (low, ex, high) = case splitAt bd dps of (low', ex' : high') -> (low', ex', high') (_, _) -> error "escapeCode: Logic error" in ((:) <$> P.choice low <*> atMost (length bds) anyd) <* nomore <|> ((:) <$> ex <*> ([] <$ nomore <|> bounded'' dps bds)) <|> if not (null bds) then (:) <$> P.choice high <*> atMost (length bds - 1) anyd <* nomore else empty atMost n p | n <= 0 = pure [] | otherwise = ((:) <$> p <*> atMost (n - 1) p) <|> pure [] charEsc :: m Char charEsc = P.choice $ parseEsc <$> escMap parseEsc (c,code) = code <$ P.char c escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" charAscii :: m Char charAscii = P.choice $ parseAscii <$> asciiMap parseAscii (asc,code) = P.try $ code <$ P.string asc asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) ascii2codes, ascii3codes :: [String] ascii2codes = [ "BS","HT","LF","VT","FF","CR","SO" , "SI","EM","FS","GS","RS","US","SP"] ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK" ,"BEL","DLE","DC1","DC2","DC3","DC4","NAK" ,"SYN","ETB","CAN","SUB","ESC","DEL"] ascii2, ascii3 :: String ascii2 = "\BS\HT\LF\VT\FF\CR\SO\SI\EM\FS\GS\RS\US\SP" ascii3 = "\NUL\SOH\STX\ETX\EOT\ENQ\ACK\BEL\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\SUB\ESC\DEL"