Skip to content

Prs 5028 5029 5033 #5046

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 8 commits into from
Jan 17, 2018
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
15 changes: 15 additions & 0 deletions Cabal/Cabal.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -38,13 +38,22 @@ extra-source-files:
tests/ParserTests/errors/common2.errors
tests/ParserTests/errors/common3.cabal
tests/ParserTests/errors/common3.errors
tests/ParserTests/errors/forward-compat.cabal
tests/ParserTests/errors/forward-compat.errors
tests/ParserTests/errors/forward-compat2.cabal
tests/ParserTests/errors/forward-compat2.errors
tests/ParserTests/errors/forward-compat3.cabal
tests/ParserTests/errors/forward-compat3.errors
tests/ParserTests/errors/leading-comma.cabal
tests/ParserTests/errors/leading-comma.errors
tests/ParserTests/errors/range-ge-wild.cabal
tests/ParserTests/errors/range-ge-wild.errors
tests/ParserTests/ipi/Includes2.cabal
tests/ParserTests/ipi/Includes2.expr
tests/ParserTests/ipi/Includes2.format
tests/ParserTests/ipi/internal-preprocessor-test.cabal
tests/ParserTests/ipi/internal-preprocessor-test.expr
tests/ParserTests/ipi/internal-preprocessor-test.format
tests/ParserTests/ipi/issue-2276-ghc-9885.cabal
tests/ParserTests/ipi/issue-2276-ghc-9885.expr
tests/ParserTests/ipi/issue-2276-ghc-9885.format
Expand Down Expand Up @@ -85,6 +94,9 @@ extra-source-files:
tests/ParserTests/regressions/shake.cabal
tests/ParserTests/regressions/shake.expr
tests/ParserTests/regressions/shake.format
tests/ParserTests/regressions/th-lift-instances.cabal
tests/ParserTests/regressions/th-lift-instances.expr
tests/ParserTests/regressions/th-lift-instances.format
tests/ParserTests/regressions/wl-pprint-indef.cabal
tests/ParserTests/regressions/wl-pprint-indef.expr
tests/ParserTests/regressions/wl-pprint-indef.format
Expand All @@ -99,6 +111,7 @@ extra-source-files:
tests/ParserTests/warnings/newsyntax.cabal
tests/ParserTests/warnings/oldsyntax.cabal
tests/ParserTests/warnings/subsection.cabal
tests/ParserTests/warnings/tab.cabal
tests/ParserTests/warnings/trailingfield.cabal
tests/ParserTests/warnings/unknownfield.cabal
tests/ParserTests/warnings/unknownsection.cabal
Expand Down Expand Up @@ -196,6 +209,7 @@ library
Distribution.Types.AbiDependency
Distribution.Types.ExposedModule
Distribution.Types.InstalledPackageInfo
Distribution.Types.InstalledPackageInfo.FieldGrammar
Distribution.License
Distribution.Make
Distribution.ModuleName
Expand Down Expand Up @@ -339,6 +353,7 @@ library
Distribution.Compat.CharParsing
Distribution.FieldGrammar
Distribution.FieldGrammar.Class
Distribution.FieldGrammar.FieldDescrs
Distribution.FieldGrammar.Parsec
Distribution.FieldGrammar.Pretty
Distribution.PackageDescription.FieldGrammar
Expand Down
20 changes: 0 additions & 20 deletions Cabal/Distribution/Compat/Lens.hs
Original file line number Diff line number Diff line change
Expand Up @@ -33,8 +33,6 @@ module Distribution.Compat.Lens (
aview,
-- * Common lenses
_1, _2,
non,
fromNon,
-- * Operators
(&),
(^.),
Expand Down Expand Up @@ -136,24 +134,6 @@ _1 f (a, c) = flip (,) c <$> f a
_2 :: Lens (c, a) (c, b) a b
_2 f (c, a) = (,) c <$> f a

-- | /Note:/ not an isomorphism here.
non :: Eq a => a -> Lens' (Maybe a) a
non def f s = wrap <$> f (unwrap s)
where
wrap x | x == def = Nothing
wrap x = Just x

unwrap = fromMaybe def


fromNon :: Eq a => a -> Lens' a (Maybe a)
fromNon def f s = unwrap <$> f (wrap s)
where
wrap x | x == def = Nothing
wrap x = Just x

unwrap = fromMaybe def

-------------------------------------------------------------------------------
-- Operators
-------------------------------------------------------------------------------
Expand Down
1 change: 0 additions & 1 deletion Cabal/Distribution/FieldGrammar.hs
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,6 @@ module Distribution.FieldGrammar (
uniqueField,
optionalField,
optionalFieldDef,
optionalFieldDefAla,
monoidalField,
deprecatedField',
-- * Concrete grammar implementations
Expand Down
25 changes: 11 additions & 14 deletions Cabal/Distribution/FieldGrammar/Class.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,6 @@ module Distribution.FieldGrammar.Class (
uniqueField,
optionalField,
optionalFieldDef,
optionalFieldDefAla,
monoidalField,
deprecatedField',
) where
Expand Down Expand Up @@ -55,6 +54,15 @@ class FieldGrammar g where
-> ALens' s (Maybe a) -- ^ lens into the field
-> g s (Maybe a)

-- | Optional field with default value.
optionalFieldDefAla
:: (Parsec b, Pretty b, Newtype b a, Eq a)
=> FieldName -- ^ field name
-> (a -> b) -- ^ 'Newtype' pack
-> ALens' s a -- ^ @'Lens'' s a@: lens into the field
-> a -- ^ default value
-> g s a

-- | Monoidal field.
--
-- Values are combined with 'mappend'.
Expand Down Expand Up @@ -112,24 +120,13 @@ optionalField fn = optionalFieldAla fn Identity

-- | Optional field with default value.
optionalFieldDef
:: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a, Show a)
:: (FieldGrammar g, Functor (g s), Parsec a, Pretty a, Eq a)
=> FieldName -- ^ field name
-> LensLike' (Pretext (Maybe a) (Maybe a)) s a -- ^ @'Lens'' s a@: lens into the field
-> ALens' 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)
Expand Down
78 changes: 78 additions & 0 deletions Cabal/Distribution/FieldGrammar/FieldDescrs.hs
Original file line number Diff line number Diff line change
@@ -0,0 +1,78 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE RankNTypes #-}
module Distribution.FieldGrammar.FieldDescrs (
FieldDescrs,
fieldDescrPretty,
fieldDescrParse,
) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Compat.Lens (aview, cloneLens)
import Distribution.Compat.Newtype
import Distribution.FieldGrammar
import Distribution.Pretty (pretty)
import Distribution.Utils.Generic (fromUTF8BS)

import qualified Data.Map as Map
import qualified Distribution.Parsec.Class as P
import qualified Distribution.Parsec.Field as P
import qualified Text.PrettyPrint as Disp

-- strict pair
data SP s = SP
{ pPretty :: !(s -> Disp.Doc)
, pParse :: !(forall m. P.CabalParsing m => s -> m s)
}

-- | A collection field parsers and pretty-printers.
newtype FieldDescrs s a = F { runF :: Map String (SP s) }
deriving (Functor)

instance Applicative (FieldDescrs s) where
pure _ = F mempty
f <*> x = F (mappend (runF f) (runF x))

singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a
singletonF fn f g = F $ Map.singleton (fromUTF8BS fn) (SP f g)

-- | Lookup a field value pretty-printer.
fieldDescrPretty :: FieldDescrs s a -> String -> Maybe (s -> Disp.Doc)
fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m

-- | Lookup a field value parser.
fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> String -> Maybe (s -> m s)
fieldDescrParse (F m) fn = pParse <$> Map.lookup fn m

-- | /Note:/ default values are printed.
instance FieldGrammar FieldDescrs where
blurFieldGrammar l (F m) = F (fmap blur m) where
blur (SP f g) = SP (f . aview l) (cloneLens l g)

booleanFieldDef fn l _def = singletonF fn f g where
f s = Disp.text (show (aview l s))
g s = cloneLens l (const P.parsec) s
-- Note: eta expansion is needed for RankNTypes type-checking to work.

uniqueFieldAla fn _pack l = singletonF fn f g where
f s = pretty (pack' _pack (aview l s))
g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s

optionalFieldAla fn _pack l = singletonF fn f g where
f s = maybe mempty (pretty . pack' _pack) (aview l s)
g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s

optionalFieldDefAla fn _pack l _def = singletonF fn f g where
f s = pretty (pack' _pack (aview l s))
g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s

monoidalFieldAla fn _pack l = singletonF fn f g where
f s = pretty (pack' _pack (aview l s))
g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s

prefixedFields _fnPfx _l = F mempty
knownField _ = pure ()
deprecatedSince _ _ x = x
availableSince _ _ = id
hiddenField _ = F mempty
14 changes: 14 additions & 0 deletions Cabal/Distribution/FieldGrammar/Parsec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -190,6 +190,20 @@ instance FieldGrammar ParsecFieldGrammar where
| null fls = pure Nothing
| otherwise = Just . unpack' _pack <$> runFieldParser pos parsec v fls

optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser
where
parser v fields = case Map.lookup fn fields of
Nothing -> pure def
Just [] -> pure def
Just [x] -> parseOne v x
Just xs -> do
warnMultipleSingularFields fn xs
last <$> traverse (parseOne v) xs

parseOne v (MkNamelessField pos fls)
| null fls = pure def
| otherwise = unpack' _pack <$> runFieldParser pos parsec v fls

monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser
where
parser v fields = case Map.lookup fn fields of
Expand Down
8 changes: 8 additions & 0 deletions Cabal/Distribution/FieldGrammar/Pretty.hs
Original file line number Diff line number Diff line change
Expand Up @@ -51,6 +51,14 @@ instance FieldGrammar PrettyFieldGrammar where
Nothing -> mempty
Just a -> ppField (fromUTF8BS fn) (pretty (pack' _pack a))

optionalFieldDefAla fn _pack l def = PrettyFG pp
where
pp s
| x == def = mempty
| otherwise = ppField (fromUTF8BS fn) (pretty (pack' _pack x))
where
x = aview l s

monoidalFieldAla fn _pack l = PrettyFG pp
where
pp s = ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s)))
Expand Down
Loading