Commit 7e3ce23b authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

Merge pull request #3602 from phadej/parsec-parser

Parsec parser
parents c9584259 7226fa45
......@@ -46,6 +46,9 @@ matrix:
- env: GHCVER=8.0.1 SCRIPT=solver-debug-flags
sudo: required
os: linux
- env: GHCVER=8.0.1 SCRIPT=script PARSEC=YES
os: linux
sudo: required
- env: GHCVER=8.0.1 SCRIPT=bootstrap
sudo: required
os: linux
......@@ -89,6 +92,7 @@ before_install:
- export PATH=$HOME/.local/bin:$PATH
- export PATH=/opt/cabal/1.24/bin:$PATH
- export PATH=/opt/happy/1.19.5/bin:$PATH
- export PATH=/opt/alex/3.1.7/bin:$PATH
- ./travis-install.sh
# Set up deployment to the haskell/cabal-website repo.
......
......@@ -303,6 +303,20 @@ extra-source-files:
tests/PackageTests/UniqueIPID/P2/M.hs
tests/PackageTests/UniqueIPID/P2/my.cabal
tests/PackageTests/multInst/my.cabal
tests/ParserTests/warnings/bom.cabal
tests/ParserTests/warnings/bool.cabal
tests/ParserTests/warnings/deprecatedfield.cabal
tests/ParserTests/warnings/extratestmodule.cabal
tests/ParserTests/warnings/gluedop.cabal
tests/ParserTests/warnings/nbsp.cabal
tests/ParserTests/warnings/newsyntax.cabal
tests/ParserTests/warnings/oldsyntax.cabal
tests/ParserTests/warnings/subsection.cabal
tests/ParserTests/warnings/trailingfield.cabal
tests/ParserTests/warnings/unknownfield.cabal
tests/ParserTests/warnings/unknownsection.cabal
tests/ParserTests/warnings/utf8.cabal
tests/ParserTests/warnings/versiontag.cabal
tests/Setup.hs
tests/hackage/check.sh
tests/hackage/download.sh
......@@ -322,6 +336,16 @@ flag old-directory
description: Use directory < 1.2 and old-time
default: False
flag parsec
description: Use parsec parser
default: False
manual: True
flag parsec-struct-diff
description: Use StructDiff in parsec tests. Affects only parsec tests.
default: False
manual: True
library
build-depends:
array >= 0.1 && < 0.6,
......@@ -482,6 +506,30 @@ library
Language.Haskell.Extension
Distribution.Compat.Binary
if flag(parsec)
cpp-options: -DCABAL_PARSEC
build-depends:
transformers,
parsec >= 3.1.9 && <3.2
build-tools:
alex >=3.1.4 && <3.3
exposed-modules:
Distribution.Compat.Parsec
Distribution.PackageDescription.Parsec
Distribution.PackageDescription.Parsec.FieldDescr
Distribution.Parsec.Class
Distribution.Parsec.ConfVar
Distribution.Parsec.Lexer
Distribution.Parsec.LexerMonad
Distribution.Parsec.Parser
Distribution.Parsec.Types.Common
Distribution.Parsec.Types.Field
Distribution.Parsec.Types.FieldDescr
Distribution.Parsec.Types.ParseResult
Distribution.Compat.DList
-- Move DList to other-module if/when D.C.Lens is done
other-modules:
Distribution.Backpack.PreExistingComponent
Distribution.Backpack.ReadyComponent
......@@ -494,8 +542,8 @@ library
Distribution.Compat.CopyFile
Distribution.Compat.GetShortPathName
Distribution.Compat.MonadFail
Distribution.Compat.DList
Distribution.Compat.Prelude
Distribution.Compat.SnocList
Distribution.GetOpt
Distribution.Lex
Distribution.Utils.String
......@@ -612,3 +660,53 @@ test-suite package-tests
ghc-options: -Wall -rtsopts
default-extensions: CPP
default-language: Haskell2010
test-suite parser-tests
if !flag(parsec)
buildable: False
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: ParserTests.hs
build-depends:
base,
bytestring,
filepath,
tasty,
tasty-hunit,
tasty-quickcheck,
Cabal
ghc-options: -Wall
default-language: Haskell2010
test-suite parser-hackage-tests
if !flag(parsec)
buildable: False
type: exitcode-stdio-1.0
main-is: ParserHackageTests.hs
hs-source-dirs: tests
build-depends:
base,
containers,
tar >=0.5 && <0.6,
bytestring,
directory,
filepath,
Cabal
if flag(parsec-struct-diff)
build-depends:
generics-sop ==0.2.*,
these >=0.7.1 && <0.8,
singleton-bool >=0.1.1.0 && <0.2,
keys
other-modules:
DiffInstances
StructDiff
cpp-options: -DHAS_STRUCT_DIFF
ghc-options: -Wall -rtsopts
default-extensions: CPP
default-language: Haskell2010
......@@ -13,6 +13,7 @@ module Distribution.Compat.DList (
DList,
runDList,
singleton,
snoc,
) where
import Prelude ()
......@@ -28,6 +29,9 @@ runDList (DList run) = run []
singleton :: a -> DList a
singleton a = DList (a:)
snoc :: DList a -> a -> DList a
snoc xs x = xs <> singleton x
instance Monoid (DList a) where
mempty = DList id
mappend = (<>)
......
{-# LANGUAGE FlexibleContexts #-}
module Distribution.Compat.Parsec (
P.Parsec,
P.ParsecT,
P.Stream,
(P.<?>),
P.runParser,
-- * Combinators
P.between,
P.option,
P.optional,
P.optionMaybe,
P.try,
P.sepBy,
P.sepBy1,
P.choice,
-- * Char
integral,
P.char,
P.anyChar,
P.satisfy,
P.space,
P.spaces,
P.string,
munch,
munch1,
P.oneOf,
) where
import Distribution.Compat.Prelude
import Prelude ()
import qualified Text.Parsec as P
import qualified Text.Parsec.Pos as P
integral :: (P.Stream s m Char, Integral a) => P.ParsecT s u m a
integral = toNumber <$> some d P.<?> "integral"
where
toNumber = foldl' (\a b -> a * 10 + b) 0
d = P.tokenPrim
(\c -> show [c])
(\pos c _cs -> P.updatePosChar pos c)
f
f '0' = Just 0
f '1' = Just 1
f '2' = Just 2
f '3' = Just 3
f '4' = Just 4
f '5' = Just 5
f '6' = Just 6
f '7' = Just 7
f '8' = Just 8
f '9' = Just 9
f _ = Nothing
-- | Greedily munch characters while predicate holds.
-- Require at least one character.
munch1
:: P.Stream s m Char
=> (Char -> Bool)
-> P.ParsecT s u m String
munch1 = some . P.satisfy
-- | Greedely munch characters while predicate holds.
-- Always succeeds.
munch
:: P.Stream s m Char
=> (Char -> Bool)
-> P.ParsecT s u m String
munch = many . P.satisfy
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.SnocList
-- License : BSD3
--
-- Maintainer : cabal-dev@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- A very reversed list. Has efficient `snoc`
module Distribution.Compat.SnocList (
SnocList,
runSnocList,
snoc,
) where
import Prelude ()
import Distribution.Compat.Prelude
newtype SnocList a = SnocList [a]
snoc :: SnocList a -> a -> SnocList a
snoc (SnocList xs) x = SnocList (x : xs)
runSnocList :: SnocList a -> [a]
runSnocList (SnocList xs) = reverse xs
instance Semigroup (SnocList a) where
SnocList xs <> SnocList ys = SnocList (ys <> xs)
instance Monoid (SnocList a) where
mempty = SnocList []
mappend = (<>)
......@@ -13,7 +13,7 @@
-- Data type for Haskell module names.
module Distribution.ModuleName (
ModuleName,
ModuleName (..), -- TODO: move Parsec instance here, don't export constructor
fromString,
fromComponents,
components,
......
This diff is collapsed.
This diff is collapsed.
{-# LANGUAGE FlexibleContexts #-}
module Distribution.Parsec.Class (
Parsec(..),
-- * Warnings
parsecWarning,
-- * Utilities
parsecTestedWith,
parsecPkgconfigDependency,
parsecBuildTool,
parsecToken,
parsecToken',
parsecFilePath,
parsecQuoted,
parsecMaybeQuoted,
parsecCommaList,
parsecOptCommaList,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Data.Functor.Identity (Identity)
import qualified Distribution.Compat.Parsec as P
import Distribution.Parsec.Types.Common
(PWarnType (..), PWarning (..), Position (..))
import qualified Text.Parsec as Parsec
import qualified Text.Parsec.Language as Parsec
import qualified Text.Parsec.Token as Parsec
-- Instances
import Distribution.Compiler
(CompilerFlavor (..), classifyCompilerFlavor)
import Distribution.License (License (..))
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package
(Dependency (..), PackageName, mkPackageName)
import Distribution.System
(Arch (..), ClassificationStrictness (..), OS (..),
classifyArch, classifyOS)
import Distribution.Text (display)
import Distribution.Types.BenchmarkType
(BenchmarkType (..))
import Distribution.Types.BuildType (BuildType (..))
import Distribution.Types.GenericPackageDescription (FlagName (..))
import Distribution.Types.ModuleReexport
(ModuleReexport (..))
import Distribution.Types.SourceRepo
(RepoKind, RepoType, classifyRepoKind, classifyRepoType)
import Distribution.Types.TestType (TestType (..))
import Distribution.Version
(Version, VersionRange (..), anyVersion, earlierVersion,
intersectVersionRanges, laterVersion, majorBoundVersion,
mkVersion, noVersion, orEarlierVersion, orLaterVersion,
thisVersion, unionVersionRanges, withinVersion)
import Language.Haskell.Extension
(Extension, Language, classifyExtension, classifyLanguage)
-------------------------------------------------------------------------------
-- Class
-------------------------------------------------------------------------------
-- |
--
-- TODO: implementation details: should be careful about consuming trailing whitespace?
-- Should we always consume it?
class Parsec a where
parsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a
-- | 'parsec' /could/ consume trailing spaces, this function /must/ consume.
lexemeParsec :: P.Stream s Identity Char => P.Parsec s [PWarning] a
lexemeParsec = parsec <* P.spaces
parsecWarning :: PWarnType -> String -> P.Parsec s [PWarning] ()
parsecWarning t w =
Parsec.modifyState (PWarning t (Position 0 0) w :)
-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------
-- TODO: use lexemeParsec
instance Parsec PackageName where
-- todo
parsec = mkPackageName . intercalate "-" <$> P.sepBy1 component (P.char '-')
where
component :: P.Stream s Identity Char => P.Parsec s [PWarning] String
component = do
cs <- P.munch1 isAlphaNum
if all isDigit cs then fail "all digits PackageName" else return cs
instance Parsec ModuleName where
parsec = ModuleName.fromComponents <$> P.sepBy1 component (P.char '.')
where
component = do
c <- P.satisfy isUpper
cs <- P.munch validModuleChar
return (c:cs)
validModuleChar :: Char -> Bool
validModuleChar c = isAlphaNum c || c == '_' || c == '\''
instance Parsec FlagName where
parsec = FlagName . map toLower . intercalate "-" <$> P.sepBy1 component (P.char '-')
where
-- http://hackage.haskell.org/package/cabal-debian-4.24.8/cabal-debian.cabal
-- has flag with all digit component: pretty-112
component :: P.Stream s Identity Char => P.Parsec s [PWarning] String
component = P.munch1 (\c -> isAlphaNum c || c `elem` "_")
instance Parsec Dependency where
parsec = do
name <- lexemeParsec
ver <- parsec <|> pure anyVersion
return (Dependency name ver)
instance Parsec Version where
parsec = mkVersion <$>
P.sepBy1 P.integral (P.char '.')
<* tags
where
tags = do
ts <- P.optionMaybe $ some $ P.char '-' *> some (P.satisfy isAlphaNum)
case ts of
Nothing -> pure ()
-- TODO: make this warning severe
Just _ -> parsecWarning PWTVersionTag "version with tags"
-- TODO: this is not good parsec code
-- use lexer, also see D.P.ConfVar
instance Parsec VersionRange where
parsec = expr
where
expr = do P.spaces
t <- term
P.spaces
(do _ <- P.string "||"
P.spaces
e <- expr
return (unionVersionRanges t e)
<|>
return t)
term = do f <- factor
P.spaces
(do _ <- P.string "&&"
P.spaces
t <- term
return (intersectVersionRanges f t)
<|>
return f)
factor = P.choice
$ parens expr
: parseAnyVersion
: parseNoVersion
: parseWildcardRange
: map parseRangeOp rangeOps
parseAnyVersion = P.string "-any" >> return anyVersion
parseNoVersion = P.string "-none" >> return noVersion
parseWildcardRange = P.try $ do
_ <- P.string "=="
P.spaces
branch <- some (P.integral <* P.char '.')
_ <- P.char '*'
return (withinVersion (mkVersion branch))
parens p = P.between
(P.char '(' >> P.spaces)
(P.char ')' >> P.spaces)
(do a <- p
P.spaces
return (VersionRangeParens a))
-- TODO: make those non back-tracking
parseRangeOp (s,f) = P.try (P.string s *> P.spaces *> fmap f parsec)
rangeOps = [ ("<", earlierVersion),
("<=", orEarlierVersion),
(">", laterVersion),
(">=", orLaterVersion),
("^>=", majorBoundVersion),
("==", thisVersion) ]
instance Parsec Language where
parsec = classifyLanguage <$> P.munch1 isAlphaNum
instance Parsec Extension where
parsec = classifyExtension <$> P.munch1 isAlphaNum
instance Parsec RepoType where
parsec = classifyRepoType <$> P.munch1 isIdent
instance Parsec RepoKind where
parsec = classifyRepoKind <$> P.munch1 isIdent
instance Parsec License where
parsec = do
name <- P.munch1 isAlphaNum
version <- P.optionMaybe (P.char '-' *> parsec)
return $! case (name, version :: Maybe Version) of
("GPL", _ ) -> GPL version
("LGPL", _ ) -> LGPL version
("AGPL", _ ) -> AGPL version
("BSD2", Nothing) -> BSD2
("BSD3", Nothing) -> BSD3
("BSD4", Nothing) -> BSD4
("ISC", Nothing) -> ISC
("MIT", Nothing) -> MIT
("MPL", Just version') -> MPL version'
("Apache", _ ) -> Apache version
("PublicDomain", Nothing) -> PublicDomain
("AllRightsReserved", Nothing) -> AllRightsReserved
("OtherLicense", Nothing) -> OtherLicense
_ -> UnknownLicense $ name ++
maybe "" (('-':) . display) version
instance Parsec BuildType where
parsec = do
name <- P.munch1 isAlphaNum
return $ case name of
"Simple" -> Simple
"Configure" -> Configure
"Custom" -> Custom
"Make" -> Make
_ -> UnknownBuildType name
instance Parsec TestType where
parsec = stdParse $ \ver name -> case name of
"exitcode-stdio" -> TestTypeExe ver
"detailed" -> TestTypeLib ver
_ -> TestTypeUnknown name ver
instance Parsec BenchmarkType where
parsec = stdParse $ \ver name -> case name of
"exitcode-stdio" -> BenchmarkTypeExe ver
_ -> BenchmarkTypeUnknown name ver
instance Parsec OS where
parsec = classifyOS Compat <$> parsecIdent
instance Parsec Arch where
parsec = classifyArch Strict <$> parsecIdent
instance Parsec CompilerFlavor where
parsec = classifyCompilerFlavor <$> component
where
component :: P.Stream s Identity Char => P.Parsec s [PWarning] String
component = do
cs <- P.munch1 isAlphaNum
if all isDigit cs then fail "all digits compiler name" else return cs
instance Parsec ModuleReexport where
parsec = do
mpkgname <- P.optionMaybe (P.try $ parsec <* P.char ':')
origname <- parsec
newname <- P.option origname $ P.try $ do
P.spaces
_ <- P.string "as"
P.spaces
parsec
return (ModuleReexport mpkgname origname newname)
-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------
isIdent :: Char -> Bool
isIdent c = isAlphaNum c || c == '_' || c == '-'
parsecTestedWith :: P.Stream s Identity Char => P.Parsec s [PWarning] (CompilerFlavor, VersionRange)
parsecTestedWith = do
name <- lexemeParsec
ver <- parsec <|> pure anyVersion
return (name, ver)
parsecPkgconfigDependency :: P.Stream s Identity Char => P.Parsec s [PWarning] Dependency
parsecPkgconfigDependency = do
name <- P.munch1 (\c -> isAlphaNum c || c `elem` "+-._")
P.spaces
verRange <- parsec <|> pure anyVersion
pure $ Dependency (mkPackageName name) verRange
parsecBuildTool :: P.Stream s Identity Char => P.Parsec s [PWarning] Dependency
parsecBuildTool = do
name <- parsecMaybeQuoted nameP
P.spaces
verRange <- parsec <|> pure anyVersion
pure $ Dependency (mkPackageName name) verRange
where
nameP = intercalate "-" <$> P.sepBy1 component (P.char '-')
component = do
cs <- P.munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
if all isDigit cs then fail "invalid component" else return cs
parsecToken :: P.Stream s Identity Char => P.Parsec s [PWarning] String
parsecToken = parsecHaskellString <|> (P.munch1 (\x -> not (isSpace x) && x /= ',') P.<?> "identifier" )
parsecToken' :: P.Stream s Identity Char => P.Parsec s [PWarning] String
parsecToken' = parsecHaskellString <|> (P.munch1 (not . isSpace) P.<?> "token")
parsecFilePath :: P.Stream s Identity Char => P.Parsec s [PWarning] String
parsecFilePath = parsecToken
-- | Parse a benchmark/test-suite types.
stdParse
:: P.Stream s Identity Char
=> (Version -> String -> a)
-> P.Parsec s [PWarning] a
stdParse f = do
-- TODO: this backtracks
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
:: P.Stream s Identity Char
=> P.Parsec s [PWarning] a
-> P.Parsec s [PWarning] [a]
parsecCommaList p = P.sepBy (p <* P.spa