Commit 1e1ed457 authored by Oleg Grenrus's avatar Oleg Grenrus Committed by GitHub
Browse files

Merge pull request #4702 from phadej/fields-parser

Fields parser
parents 61c02a15 66e22322
......@@ -33,9 +33,12 @@ extra-source-files:
-- Do NOT edit this section manually; instead, run the script.
-- BEGIN gen-extra-source-files
tests/ParserTests/regressions/Octree-0.5.cabal
tests/ParserTests/regressions/elif.cabal
tests/ParserTests/regressions/encoding-0.8.cabal
tests/ParserTests/regressions/generics-sop.cabal
tests/ParserTests/regressions/issue-774.cabal
tests/ParserTests/regressions/nothing-unicode.cabal
tests/ParserTests/regressions/shake.cabal
tests/ParserTests/warnings/bom.cabal
tests/ParserTests/warnings/bool.cabal
tests/ParserTests/warnings/deprecatedfield.cabal
......@@ -274,18 +277,22 @@ library
parsec >= 3.1.9 && <3.2
exposed-modules:
Distribution.Compat.Parsec
Distribution.FieldGrammar
Distribution.FieldGrammar.Class
Distribution.FieldGrammar.Parsec
Distribution.FieldGrammar.Pretty
Distribution.PackageDescription.FieldGrammar
Distribution.PackageDescription.Parsec
Distribution.PackageDescription.Parsec.FieldDescr
Distribution.PackageDescription.Parsec.Quirks
Distribution.PackageDescription.Quirks
Distribution.Parsec.Class
Distribution.Parsec.Common
Distribution.Parsec.ConfVar
Distribution.Parsec.Field
Distribution.Parsec.Lexer
Distribution.Parsec.LexerMonad
Distribution.Parsec.Newtypes
Distribution.Parsec.ParseResult
Distribution.Parsec.Parser
Distribution.Parsec.Types.Common
Distribution.Parsec.Types.Field
Distribution.Parsec.Types.FieldDescr
Distribution.Parsec.Types.ParseResult
-- Lens functionality
exposed-modules:
......@@ -400,6 +407,7 @@ test-suite parser-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
main-is: ParserTests.hs
build-depends: containers
build-depends:
base,
bytestring,
......@@ -450,7 +458,7 @@ test-suite parser-hackage-tests
if flag(parsec-struct-diff)
build-depends:
generics-sop >= 0.2.5 && <0.3,
generics-sop >= 0.3.1.0 && <0.4,
these >=0.7.1 && <0.8,
singleton-bool >=0.1.1.0 && <0.2,
keys
......
......@@ -12,6 +12,7 @@ module Distribution.Compat.Map.Strict
#ifdef HAVE_containers_050
#else
, insertWith
, fromSet
#endif
) where
......@@ -20,7 +21,11 @@ import Data.Map.Strict as X
#else
import Data.Map as X hiding (insertWith, insertWith')
import qualified Data.Map
import qualified Data.Set
insertWith :: Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
insertWith = Data.Map.insertWith'
fromSet :: (k -> a) -> Data.Set.Set k -> Map k a
fromSet f = Data.Map.fromDistinctAscList . Prelude.map (\k -> (k, f k)) . Data.Set.toList
#endif
......@@ -25,6 +25,7 @@ module Distribution.Compat.Parsec (
P.satisfy,
P.space,
P.spaces,
skipSpaces1,
P.string,
munch,
munch1,
......@@ -72,3 +73,6 @@ munch
=> (Char -> Bool)
-> P.ParsecT s u m String
munch = many . P.satisfy
skipSpaces1 :: P.Stream s m Char => P.ParsecT s u m ()
skipSpaces1 = P.skipMany1 P.space
......@@ -67,17 +67,23 @@ module Distribution.Compat.ReadP
-- * Running a parser
ReadS, -- :: *; = String -> [(a,String)]
readP_to_S, -- :: ReadP a -> ReadS a
readS_to_P -- :: ReadS a -> ReadP a
readS_to_P, -- :: ReadS a -> ReadP a
-- ** Parsec
parsecToReadP,
)
where
import Prelude ()
import Distribution.Compat.Prelude hiding (many, get)
import Control.Applicative (liftA2)
import qualified Distribution.Compat.MonadFail as Fail
import Control.Monad( replicateM, (>=>) )
import qualified Text.Parsec as P
infixr 5 +++, <++
-- ---------------------------------------------------------------------------
......@@ -414,3 +420,16 @@ readS_to_P :: ReadS a -> ReadP r a
-- parser, and therefore a possible inefficiency.
readS_to_P r =
R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
-- ---------------------------------------------------------------------------
-- Converting from Parsec to ReadP
--
-- | Convert @Parsec@ parser to 'ReadP'.
parsecToReadP
:: P.Parsec [Char] u a
-> u -- ^ initial user state
-> ReadP r a
parsecToReadP p u = R $ \k -> Look $ \s ->
case P.runParser (liftA2 (,) p P.getInput) u "<parsecToReadP>" s of
Right (x, s') -> final (run (k x) s')
Left _ -> Fail
......@@ -51,8 +51,11 @@ import Language.Haskell.Extension
import Distribution.Version (Version, mkVersion', nullVersion)
import qualified System.Info (compilerName, compilerVersion)
import Distribution.Parsec.Class (Parsec (..))
import Distribution.Pretty (Pretty (..))
import Distribution.Text (Text(..), display)
import qualified Distribution.Compat.ReadP as Parse
import qualified Distribution.Compat.Parsec as P
import qualified Text.PrettyPrint as Disp
data CompilerFlavor =
......@@ -66,12 +69,20 @@ instance Binary CompilerFlavor
knownCompilerFlavors :: [CompilerFlavor]
knownCompilerFlavors = [GHC, GHCJS, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
instance Text CompilerFlavor where
disp (OtherCompiler name) = Disp.text name
disp (HaskellSuite name) = Disp.text name
disp NHC = Disp.text "nhc98"
disp other = Disp.text (lowercase (show other))
instance Pretty CompilerFlavor where
pretty (OtherCompiler name) = Disp.text name
pretty (HaskellSuite name) = Disp.text name
pretty NHC = Disp.text "nhc98"
pretty other = Disp.text (lowercase (show other))
instance Parsec CompilerFlavor where
parsec = classifyCompilerFlavor <$> component
where
component = do
cs <- P.munch1 isAlphaNum
if all isDigit cs then fail "all digits compiler name" else return cs
instance Text CompilerFlavor where
parse = do
comp <- Parse.munch1 isAlphaNum
when (all isDigit comp) Parse.pfail
......@@ -81,7 +92,7 @@ classifyCompilerFlavor :: String -> CompilerFlavor
classifyCompilerFlavor s =
fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap
where
compilerMap = [ (display compiler, compiler)
compilerMap = [ (lowercase (display compiler), compiler)
| compiler <- knownCompilerFlavors ]
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This module provides a way to specify a grammar of @.cabal@ -like files.
module Distribution.FieldGrammar (
-- * Field grammar type
FieldGrammar (..),
uniqueField,
optionalField,
optionalFieldDef,
optionalFieldDefAla,
monoidalField,
deprecatedField',
-- * Concrete grammar implementations
ParsecFieldGrammar,
ParsecFieldGrammar',
parseFieldGrammar,
fieldGrammarKnownFieldList,
PrettyFieldGrammar,
PrettyFieldGrammar',
prettyFieldGrammar,
-- * Auxlilary
(^^^),
Section(..),
Fields,
partitionFields,
takeFields,
runFieldParser,
runFieldParser',
) where
import Distribution.Compat.Prelude
import Prelude ()
import qualified Distribution.Compat.Map.Strict as Map
import Distribution.FieldGrammar.Class
import Distribution.FieldGrammar.Parsec
import Distribution.FieldGrammar.Pretty
import Distribution.Parsec.Field
import Distribution.Utils.Generic (spanMaybe)
type ParsecFieldGrammar' a = ParsecFieldGrammar a a
type PrettyFieldGrammar' a = PrettyFieldGrammar a a
infixl 5 ^^^
-- | Reverse function application which binds tighter than '<$>' and '<*>'.
-- Useful for refining grammar specification.
--
-- @
-- \<*\> 'monoidalFieldAla' "extensions" (alaList' FSep MQuoted) oldExtensions
-- ^^^ 'deprecatedSince' [1,12] "Please use 'default-extensions' or 'other-extensions' fields."
-- @
(^^^) :: a -> (a -> b) -> b
x ^^^ f = f x
-- | Partitioning state
data PS ann = PS (Fields ann) [Section ann] [[Section ann]]
-- | Partition field list into field map and groups of sections.
partitionFields :: [Field ann] -> (Fields ann, [[Section ann]])
partitionFields = finalize . foldl' f (PS mempty mempty mempty)
where
finalize :: PS ann -> (Fields ann, [[Section ann]])
finalize (PS fs s ss)
| null s = (fs, reverse ss)
| otherwise = (fs, reverse (reverse s : ss))
f :: PS ann -> Field ann -> PS ann
f (PS fs s ss) (Field (Name ann name) fss) =
PS (Map.insertWith (flip (++)) name [MkNamelessField ann fss] fs) [] ss'
where
ss' | null s = ss
| otherwise = reverse s : ss
f (PS fs s ss) (Section name sargs sfields) =
PS fs (MkSection name sargs sfields : s) ss
-- | Take all fields from the front.
takeFields :: [Field ann] -> (Fields ann, [Field ann])
takeFields = finalize . spanMaybe match
where
finalize (fs, rest) = (Map.fromListWith (flip (++)) fs, rest)
match (Field (Name ann name) fs) = Just (name, [MkNamelessField ann fs])
match _ = Nothing
module Distribution.FieldGrammar.Class (
FieldGrammar (..),
uniqueField,
optionalField,
optionalFieldDef,
optionalFieldDefAla,
monoidalField,
deprecatedField',
) where
import Distribution.Compat.Lens
import Distribution.Compat.Prelude
import Prelude ()
import Data.Functor.Identity (Identity (..))
import Distribution.Compat.Newtype (Newtype)
import Distribution.Parsec.Class (Parsec)
import Distribution.Parsec.Field
import Distribution.Pretty (Pretty)
-- | 'FieldGrammar' is parametrised by
--
-- * @s@ which is a structure we are parsing. We need this to provide prettyprinter
-- functionality
--
-- * @a@ type of the field.
--
-- /Note:/ We'd like to have @forall s. Applicative (f s)@ context.
--
class FieldGrammar g where
-- | Unfocus, zoom out, /blur/ 'FieldGrammar'.
blurFieldGrammar :: ALens' a b -> g b c -> g a c
-- | Field which should be defined, exactly once.
uniqueFieldAla
:: (Parsec b, Pretty b, Newtype b a)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'Newtype' pack
-> ALens' s a -- ^ lens into the field
-> g s a
-- | Boolean field with a default value.
booleanFieldDef
:: FieldName -- ^ field name
-> ALens' s Bool -- ^ lens into the field
-> Bool -- ^ default
-> g s Bool
-- | Optional field.
optionalFieldAla
:: (Parsec b, Pretty b, Newtype b a)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'pack'
-> ALens' s (Maybe a) -- ^ lens into the field
-> g s (Maybe a)
-- | Monoidal field.
--
-- Values are combined with 'mappend'.
--
-- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid.
--
monoidalFieldAla
:: (Parsec b, Pretty b, Monoid a, Newtype b a)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'pack'
-> ALens' s a -- ^ lens into the field
-> g s a
-- | Parser matching all fields with a name starting with a prefix.
prefixedFields
:: FieldName -- ^ field name prefix
-> ALens' s [(String, String)] -- ^ lens into the field
-> g s [(String, String)]
-- | Known field, which we don't parse, neither pretty print.
knownField :: FieldName -> g s ()
-- | Field which is parsed but not pretty printed.
hiddenField :: g s a -> g s a
-- | Deprecated since
deprecatedSince
:: [Int] -- ^ version
-> String -- ^ deprecation message
-> g s a
-> g s a
-- | Annotate field with since spec-version.
availableSince
:: [Int] -- ^ spec version
-> g s a
-> g s a
-- | Field which can be defined at most once.
uniqueField
:: (FieldGrammar g, Parsec a, Pretty a)
=> FieldName -- ^ field name
-> ALens' s a -- ^ lens into the field
-> g s a
uniqueField fn = uniqueFieldAla fn Identity
-- | Field which can be defined at most once.
optionalField
:: (FieldGrammar g, Parsec a, Pretty a)
=> FieldName -- ^ field name
-> ALens' s (Maybe a) -- ^ lens into the field
-> g s (Maybe a)
optionalField fn = optionalFieldAla fn Identity
-- | Optional field with default value.
optionalFieldDef
:: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a, Show a)
=> FieldName -- ^ field name
-> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field
-> a -- ^ default value
-> g s a
optionalFieldDef fn = optionalFieldDefAla fn Identity
-- | Optional field with default value.
optionalFieldDefAla
:: (FieldGrammar g, Functor (g s), Parsec b, Pretty b, Newtype b a, Eq a, Show a)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'Newtype' pack
-> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field
-> a -- ^ default value
-> g s a
optionalFieldDefAla fn pack l def =
fromMaybe def <$> optionalFieldAla fn pack (l . fromNon def)
-- | Field which can be define multiple times, and the results are @mappend@ed.
monoidalField
:: (FieldGrammar g, Parsec a, Pretty a, Monoid a)
=> FieldName -- ^ field name
-> ALens' s a -- ^ lens into the field
-> g s a
monoidalField fn = monoidalFieldAla fn Identity
-- | Deprecated field. If found, warning is issued.
--
-- /Note:/ also it's not pretty printed!
--
deprecatedField'
:: FieldGrammar g
=> String -- ^ deprecation message
-> g s a
-> g s a
deprecatedField' = deprecatedSince []
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module provides a 'FieldGrammarParser', one way to parse
-- @.cabal@ -like files.
--
-- Fields can be specified multiple times in the .cabal files. The order of
-- such entries is important, but the mutual ordering of different fields is
-- not.Also conditional sections are considered after non-conditional data.
-- The example of this silent-commutation quirk is the fact that
--
-- @
-- buildable: True
-- if os(linux)
-- buildable: False
-- @
--
-- and
--
-- @
-- if os(linux)
-- buildable: False
-- buildable: True
-- @
--
-- behave the same! This is the limitation of 'GeneralPackageDescription'
-- structure.
--
-- So we transform the list of fields @['Field' ann]@ into
-- a map of grouped ordinary fields and a list of lists of sections:
-- @'Fields' ann = 'Map' 'FieldName' ['NamelessField' ann]@ and @[['Section' ann]]@.
--
-- We need list of list of sections, because we need to distinguish situations
-- where there are fields in between. For example
--
-- @
-- if flag(bytestring-lt-0_10_4)
-- build-depends: bytestring < 0.10.4
--
-- default-language: Haskell2020
--
-- else
-- build-depends: bytestring >= 0.10.4
--
-- @
--
-- is obviously invalid specification.
--
-- We can parse 'Fields' like we parse @aeson@ objects, yet we use
-- slighly higher-level API, so we can process unspecified fields,
-- to report unknown fields and save custom @x-fields@.
--
module Distribution.FieldGrammar.Parsec (
ParsecFieldGrammar,
parseFieldGrammar,
fieldGrammarKnownFieldList,
-- * Auxiliary
Fields,
NamelessField (..),
Section (..),
runFieldParser,
runFieldParser',
) where
import qualified Data.ByteString as BS
import Data.List (dropWhileEnd)
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Distribution.Compat.Map.Strict as Map
import Distribution.Compat.Prelude
import Distribution.Compat.Newtype
import Distribution.Simple.Utils (fromUTF8BS)
import Prelude ()
import qualified Text.Parsec as P
import qualified Text.Parsec.Error as P
import Distribution.FieldGrammar.Class
import Distribution.Parsec.Class
import Distribution.Parsec.Common
import Distribution.Parsec.Field
import Distribution.Parsec.ParseResult
-------------------------------------------------------------------------------
-- Auxiliary types
-------------------------------------------------------------------------------
type Fields ann = Map FieldName [NamelessField ann]
-- | Single field, without name, but with its annotation.
data NamelessField ann = MkNamelessField !ann [FieldLine ann]
deriving (Eq, Show, Functor)
-- | The 'Section' constructor of 'Field'.
data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann]
deriving (Eq, Show, Functor)
-------------------------------------------------------------------------------
-- ParsecFieldGrammar
-------------------------------------------------------------------------------
data ParsecFieldGrammar s a = ParsecFG
{ fieldGrammarKnownFields :: !(Set FieldName)
, fieldGrammarKnownPrefixes :: !(Set FieldName)
, fieldGrammarParser :: !(Fields Position -> ParseResult a)
}
deriving (Functor)
parseFieldGrammar :: Fields Position -> ParsecFieldGrammar s a -> ParseResult a
parseFieldGrammar fields grammar = do
for_ (Map.toList (Map.filterWithKey isUnknownField fields)) $ \(name, nfields) ->
for_ nfields $ \(MkNamelessField pos _) ->
parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name
-- TODO: fields allowed in this section
-- parse
fieldGrammarParser grammar fields
where
isUnknownField k _ = not $
k `Set.member` fieldGrammarKnownFields grammar
|| any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar)
fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName]
fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields
instance Applicative (ParsecFieldGrammar s) where
pure x = ParsecFG mempty mempty (\_ -> pure x)
{-# INLINE pure #-}
ParsecFG f f' f'' <*> ParsecFG x x' x'' = ParsecFG
(mappend f x)
(mappend f' x')
(\fields -> f'' fields <*> x'' fields)
{-# INLINE (<*>) #-}
instance FieldGrammar ParsecFieldGrammar where
blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser
uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
where
parser fields = case Map.lookup fn fields of
Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing:"
Just [] -> parseFatalFailure zeroPos $ show fn ++ " field foo"
Just [x] -> parseOne x
-- TODO: parse all
-- TODO: warn about duplicate fields?
Just xs-> parseOne (last xs)
parseOne (MkNamelessField pos fls) =
unpack' _pack <$> runFieldParser pos parsec fls
booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser
where
parser :: Fields Position -> ParseResult Bool
parser fields = case Map.lookup fn fields of
Nothing -> pure def
Just [] -> pure def
Just [x] -> parseOne x
-- TODO: parse all
-- TODO: warn about duplicate optional fields?
Just xs -> parseOne (last xs)
parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls
optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
where
parser fields = case Map.lookup fn fields of
Nothing -> pure Nothing
Just [] -> pure Nothing
Just [x] -> parseOne x
-- TODO: parse all!
Just xs -> parseOne (last xs) -- TODO: warn about duplicate optional fields?
parseOne (MkNamelessField pos fls)
| null fls = pure Nothing
| otherwise = Just . (unpack' _pack) <$> runFieldParser pos parsec fls
monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
where
parser fields = case Map.lookup fn fields of
Nothing -> pure mempty
Just xs -> foldMap (unpack' _pack) <$> traverse parseOne xs
parseOne (MkNamelessField pos fls) = runFieldParser pos parsec fls
prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (pure . parser)
where
parser :: Fields Position -> [(String, String)]
parser values = reorder $ concatMap convert $ filter match $ Map.toList values
match (fn, _) = fnPfx `BS.isPrefixOf` fn
convert (fn, fields) =