forked from haskell/cabal
-
Notifications
You must be signed in to change notification settings - Fork 0
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Parse custom-setup. Fixes haskell#4697 [ci skip] - Rename PPP to FieldGrammar. Flatten D.PackageDescription namespace - Add booleanFieldDef, flagFieldGrammar - Correct FreeText parsec - WIP: FieldGrammar BuildInfo and Library [ci skip] - More newtypes [ci skip] - Unknown and deprecated fields - NoCommaFSep - extra-libraries [ci skip] - Parse 'else' [ci skip] - WIP - More BuildInfo opts [ci skip] - ReadP parses 'location:\n' as location = Just "" [ci skip] - Known fields [ci skip] - monoidalField [ci skip] - ^^^ operator - RFC: Add elif [ci skip] - Make FieldGrammar into a type class [ci skip] - Parse sublibraries with FieldGrammar [ci skip] - Use prettyFieldGrammar for library sections [ci skip] - executableFieldGrammar [ci skip] - ForeignLib grammar - PackageDescription grammar [ci skip] - Remove unused imports - shake regression - Update extra-source-files [ci skip] - TestSuite & Benchmark grammars [ci skip] - Change readp license-files setter [ci skip] - Add hiddenField - Add GPD parse . pretty roundtrip tests. Fixes haskell#4719 - Roundtrip hackage tests [ci skip] - Roundtrip fixes [ci skip] - More pretty-printing fixes - More pp fixes [ci skip]
- Loading branch information
Showing
41 changed files
with
2,869 additions
and
1,371 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,141 @@ | ||
| {-# LANGUAGE DeriveFunctor #-} | ||
| {-# LANGUAGE FlexibleContexts #-} | ||
| {-# LANGUAGE FlexibleInstances #-} | ||
| {-# LANGUAGE OverloadedStrings #-} | ||
| {-# LANGUAGE ScopedTypeVariables #-} | ||
| -- | This module provides one way to specify 'FieldGrammar', | ||
| -- to parse lists of 'Field' and pretty print the structures. | ||
| -- | ||
| -- 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 non important. (The only exception is @hs-source-dirs@ and | ||
| -- @hs-source-dir@, but it can be fixed with preprocessing). | ||
| -- | ||
| -- Also conditional sections are considered after non-conditional data. | ||
| -- The example of this silent-commutation quirck 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 ( | ||
| -- * Field grammar type | ||
| FieldGrammar (..), | ||
| uniqueField, | ||
| optionalField, | ||
| optionalFieldDef, | ||
| optionalFieldDefAla, | ||
| monoidalField, | ||
| deprecatedField', | ||
| -- * Concrete grammar implementations | ||
| ParsecFieldGrammar, | ||
| ParsecFieldGrammar', | ||
| parseFieldGrammar, | ||
| fieldGrammarKnownFieldList, | ||
| PrettyFieldGrammar, | ||
| PrettyFieldGrammar', | ||
| prettyFieldGrammar, | ||
| -- * Auxlilary | ||
| (^^^), | ||
| Section(..), | ||
| partitionFields, | ||
| takeFields, | ||
| ) 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 | ||
|
|
||
| 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 | ||
|
|
||
| -- | Partitionin 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 | ||
|
|
||
| spanMaybe :: (a -> Maybe b) -> [a] -> ([b],[a]) | ||
| spanMaybe _ xs@[] = ([], xs) | ||
| spanMaybe p xs@(x:xs') = case p x of | ||
| Just y -> let (ys, zs) = spanMaybe p xs' in (y : ys, zs) | ||
| Nothing -> ([], xs) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,149 @@ | ||
| 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 [] |
Oops, something went wrong.