diff --git a/Cabal-described/src/Distribution/Described.hs b/Cabal-described/src/Distribution/Described.hs index aacb86f8754..e6ed4165baa 100644 --- a/Cabal-described/src/Distribution/Described.hs +++ b/Cabal-described/src/Distribution/Described.hs @@ -1,4 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Described ( @@ -56,6 +58,7 @@ import Test.Tasty.QuickCheck (testProperty) import Data.Semigroup (Semigroup (..)) import Distribution.Parsec (Parsec, eitherParsec) import Distribution.Pretty (Pretty, prettyShow) +import qualified Distribution.Types.Modify as Mod import qualified Distribution.Utils.CharSet as CS import qualified RERE as RE @@ -546,7 +549,7 @@ instance Described UnqualComponentName where -- Instances: Newtypes ------------------------------------------------------------------------------- -class Sep sep => DescribeSep sep where +class Sep Mod.HasNoAnn sep => DescribeSep sep where describeSep :: Proxy sep -> GrammarRegex a -> GrammarRegex a instance DescribeSep CommaVCat where describeSep _ = reCommaList diff --git a/Cabal-syntax/Cabal-syntax.cabal b/Cabal-syntax/Cabal-syntax.cabal index bb5a13ffc75..a8140bdd2e6 100644 --- a/Cabal-syntax/Cabal-syntax.cabal +++ b/Cabal-syntax/Cabal-syntax.cabal @@ -104,12 +104,14 @@ library Distribution.PackageDescription.Quirks Distribution.PackageDescription.Utils Distribution.Parsec + Distribution.Trivia Distribution.Parsec.Error Distribution.Parsec.FieldLineStream Distribution.Parsec.Position Distribution.Parsec.Warning Distribution.Parsec.Source Distribution.Pretty + Distribution.Pretty.ExactDoc Distribution.SPDX Distribution.SPDX.License Distribution.SPDX.LicenseExceptionId @@ -126,6 +128,7 @@ library Distribution.Types.BenchmarkInterface Distribution.Types.BenchmarkType Distribution.Types.BuildInfo + Distribution.Types.Modify Distribution.Types.BuildInfo.Lens Distribution.Types.BuildType Distribution.Types.Component diff --git a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs index 3f0d44b0a0a..39200b59c2f 100644 --- a/Cabal-syntax/src/Distribution/Compat/CharParsing.hs +++ b/Cabal-syntax/src/Distribution/Compat/CharParsing.hs @@ -24,6 +24,7 @@ module Distribution.Compat.CharParsing oneOf -- :: CharParsing m => [Char] -> m Char , noneOf -- :: CharParsing m => [Char] -> m Char , spaces -- :: CharParsing m => m () + , spaces' -- :: CharParsing m => m () , space -- :: CharParsing m => m Char , newline -- :: CharParsing m => m Char , tab -- :: CharParsing m => m Char @@ -90,6 +91,9 @@ spaces :: CharParsing m => m () spaces = skipMany space "white space" {-# INLINE spaces #-} +spaces' :: CharParsing m => m String +spaces' = many space "white space" + -- | Parses a white space character (any character which satisfies 'isSpace') -- Returns the parsed character. space :: CharParsing m => m Char diff --git a/Cabal-syntax/src/Distribution/Compat/Parsing.hs b/Cabal-syntax/src/Distribution/Compat/Parsing.hs index b08dd7b0303..b82f669a9b7 100644 --- a/Cabal-syntax/src/Distribution/Compat/Parsing.hs +++ b/Cabal-syntax/src/Distribution/Compat/Parsing.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} ----------------------------------------------------------------------------- @@ -27,9 +29,13 @@ module Distribution.Compat.Parsing , some -- from Control.Applicative, parsec many1 , many -- from Control.Applicative , sepBy + , sepByAnn , sepByNonEmpty + , sepByNonEmptyAnn , sepEndByNonEmpty + , sepEndByNonEmptyAnn , sepEndBy + , sepEndByAnn , endByNonEmpty , endBy , count @@ -44,6 +50,7 @@ module Distribution.Compat.Parsing ) where import Distribution.Compat.Prelude +import Distribution.Trivia import Prelude () import Control.Applicative (optional, (<**>)) @@ -101,18 +108,42 @@ sepBy :: Alternative m => m a -> m sep -> m [a] sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] {-# INLINE sepBy #-} +sepByAnn :: Alternative m => m (Ann SurroundingText a) -> m String -> m [Ann SurroundingText a] +sepByAnn p sep = toList <$> sepByNonEmptyAnn p sep <|> pure [] +{-# INLINE sepByAnn #-} + -- | @sepByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated -- by @sep@. Returns a non-empty list of values returned by @p@. sepByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepByNonEmpty p sep = (:|) <$> p <*> many (sep *> p) {-# INLINE sepByNonEmpty #-} +sepByNonEmptyAnn :: forall m a. Alternative m => m (Ann SurroundingText a) -> m String -> m (NonEmpty (Ann SurroundingText a)) +sepByNonEmptyAnn p sep = + (:|) + <$> p + <*> many + ( do + leading <- sep + x <- p + pure (mapAnn (preTrivia leading <>) x) + ) + -- | @sepEndByNonEmpty p sep@ parses /one/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a non-empty list of values -- returned by @p@. sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) +sepEndByNonEmptyAnn :: Alternative m => m (Ann SurroundingText a) -> m String -> m (NonEmpty (Ann SurroundingText a)) +sepEndByNonEmptyAnn p sep = do + x <- p + (trailing, xs) <- + ( (,) <$> sep <*> sepEndByAnn p sep + ) + <|> pure (mempty, []) + pure (mapAnn (<> postTrivia trailing) x :| xs) + -- | @sepEndBy p sep@ parses /zero/ or more occurrences of @p@, -- separated and optionally ended by @sep@, ie. haskell style -- statements. Returns a list of values returned by @p@. @@ -122,6 +153,10 @@ sepEndBy :: Alternative m => m a -> m sep -> m [a] sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] {-# INLINE sepEndBy #-} +-- | @sepEndByAnn@ is like @sepEndBy@, but it keeps the trivia. +sepEndByAnn :: Alternative m => m (Ann SurroundingText a) -> m String -> m [Ann SurroundingText a] +sepEndByAnn p sep = toList <$> sepEndByNonEmptyAnn p sep <|> pure [] + -- | @endByNonEmpty p sep@ parses /one/ or more occurrences of @p@, separated -- and ended by @sep@. Returns a non-empty list of values returned by @p@. endByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) diff --git a/Cabal-syntax/src/Distribution/ExactParsec.hs b/Cabal-syntax/src/Distribution/ExactParsec.hs new file mode 100644 index 00000000000..a6df1bc0f05 --- /dev/null +++ b/Cabal-syntax/src/Distribution/ExactParsec.hs @@ -0,0 +1,7 @@ +module Distribution.ExactParsec + ( ExactParsec (..) + ) +where + +import Distribution.Parsec +import Distribution.Trivia diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index 78739a37cfa..0e65ab33f75 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -5,8 +7,10 @@ -- | This module provides a way to specify a grammar of @.cabal@ -like files. module Distribution.FieldGrammar ( -- * Field grammar type - FieldGrammar (..) + FieldGrammar + , FieldGrammarWith (..) , uniqueField + , uniqueField' , optionalField , optionalFieldDef , monoidalField @@ -14,11 +18,13 @@ module Distribution.FieldGrammar -- * Concrete grammar implementations , ParsecFieldGrammar , ParsecFieldGrammar' + , ParsecFieldGrammarWith' , parseFieldGrammar , parseFieldGrammarCheckingStanzas , fieldGrammarKnownFieldList , PrettyFieldGrammar , PrettyFieldGrammar' + , PrettyFieldGrammarWith' , prettyFieldGrammar -- * Auxiliary @@ -47,8 +53,13 @@ import Distribution.FieldGrammar.Pretty import Distribution.Fields.Field import Distribution.Utils.Generic (spanMaybe) -type ParsecFieldGrammar' a = ParsecFieldGrammar a a -type PrettyFieldGrammar' a = PrettyFieldGrammar a a +import qualified Distribution.Types.Modify as Mod + +type ParsecFieldGrammarWith' (mod :: Mod.HasAnnotation) a = ParsecFieldGrammar mod a a +type PrettyFieldGrammarWith' (mod :: Mod.HasAnnotation) a = PrettyFieldGrammar mod a a + +type ParsecFieldGrammar' a = ParsecFieldGrammar Mod.HasNoAnn a a +type PrettyFieldGrammar' a = PrettyFieldGrammar Mod.HasNoAnn a a infixl 5 ^^^ diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index fa815a49a5e..ed9689c826b 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -1,12 +1,20 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableSuperClasses #-} module Distribution.FieldGrammar.Class - ( FieldGrammar (..) + ( FieldGrammar + , FieldGrammarWith (..) , uniqueField + , uniqueField' , optionalField , optionalFieldDef , monoidalField @@ -21,8 +29,16 @@ import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Compat.Newtype (Newtype) import Distribution.FieldGrammar.Newtypes import Distribution.Fields.Field +import Distribution.Parsec.Position (Position) +import Distribution.Trivia import Distribution.Utils.ShortText +import Data.Kind +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping) +import qualified Distribution.Types.Modify as Mod + +type FieldGrammar = FieldGrammarWith Mod.HasNoAnn + -- | 'FieldGrammar' is parametrised by -- -- * @s@ which is a structure we are parsing. We need this to provide prettyprinter @@ -39,11 +55,11 @@ class , c Token' , c FilePathNT ) => - FieldGrammar c g + FieldGrammarWith (m :: Mod.HasAnnotation) c g | g -> c where -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. - blurFieldGrammar :: ALens' a b -> g b d -> g a d + blurFieldGrammar :: ALens' a b -> g m b d -> g m a d -- | Field which should be defined, exactly once. uniqueFieldAla @@ -54,7 +70,21 @@ class -- ^ 'Newtype' pack -> ALens' s a -- ^ lens into the field - -> g s a + -> g m s a + + -- | Field which should be defined, exactly once. + uniqueFieldAla' + :: forall (b :: Type) (s :: Type) (a :: Type) + . ( Newtype a b + , c b + ) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s (AnnotateWith Positions m a) + -- ^ lens into the field + -> g m s (AnnotateWith Positions m a) -- | Boolean field with a default value. booleanFieldDef @@ -64,7 +94,17 @@ class -- ^ lens into the field -> Bool -- ^ default - -> g s Bool + -> g m s Bool + + -- | Boolean field with a default value. + booleanFieldDef' + :: FieldName + -- ^ field name + -> ALens' s (PreserveGrouping m (AnnotateWith Positions m Bool)) + -- ^ lens into the field + -> Bool + -- ^ default + -> g m s (PreserveGrouping m (AnnotateWith Positions m Bool)) -- | Optional field. optionalFieldAla @@ -75,7 +115,7 @@ class -- ^ 'pack' -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) + -> g m s (Maybe a) -- | Optional field with default value. optionalFieldDefAla @@ -88,7 +128,20 @@ class -- ^ @'Lens'' s a@: lens into the field -> a -- ^ default value - -> g s a + -> g m s a + + -- | Optional field with default value. + optionalFieldDefAla' + :: (c b, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s (AnnotateWith Positions m a) + -- ^ @'Lens'' s a@: lens into the field + -> a + -- ^ default value + -> g m s (AnnotateWith Positions m a) -- | Free text field is essentially 'optionalFieldDefAla` with @""@ -- as the default and "accept everything" parser. @@ -98,7 +151,7 @@ class :: FieldName -> ALens' s (Maybe String) -- ^ lens into the field - -> g s (Maybe String) + -> g m s (Maybe String) -- | Free text field is essentially 'optionalFieldDefAla` with @""@ -- as the default and "accept everything" parser. @@ -108,14 +161,14 @@ class :: FieldName -> ALens' s String -- ^ lens into the field - -> g s String + -> g m s String -- | @since 3.2.0.0 freeTextFieldDefST :: FieldName -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText + -> g m s ShortText -- | Monoidal field. -- @@ -130,7 +183,23 @@ class -- ^ 'pack' -> ALens' s a -- ^ lens into the field - -> g s a + -> g m s a + + -- | Monoidal field. + -- + -- Values are combined with 'mappend'. + -- + -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. + monoidalFieldAla' + :: forall s a b + . (c b, Monoid a, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'pack' + -> ALens' s (PreserveGrouping m (AttachPositions m a)) + -- ^ lens into the field + -> g m s (PreserveGrouping m (AttachPositions m a)) -- | Parser matching all fields with a name starting with a prefix. prefixedFields @@ -138,13 +207,13 @@ class -- ^ field name prefix -> ALens' s [(String, String)] -- ^ lens into the field - -> g s [(String, String)] + -> g m s [(String, String)] -- | Known field, which we don't parse, nor pretty print. - knownField :: FieldName -> g s () + knownField :: FieldName -> g m s () -- | Field which is parsed but not pretty printed. - hiddenField :: g s a -> g s a + hiddenField :: g m s a -> g m s a -- | Deprecated since deprecatedSince @@ -152,8 +221,8 @@ class -- ^ version -> String -- ^ deprecation message - -> g s a - -> g s a + -> g m s a + -> g m s a -- | Removed in. If we encounter removed field, parsing fails. removedIn @@ -161,8 +230,8 @@ class -- ^ version -> String -- ^ removal message - -> g s a - -> g s a + -> g m s a + -> g m s a -- | Annotate field with since spec-version. availableSince @@ -170,8 +239,8 @@ class -- ^ spec version -> a -- ^ default value - -> g s a - -> g s a + -> g m s a + -> g m s a -- | Annotate field with since spec-version. -- This is used to recognise, but warn about the field. @@ -183,59 +252,72 @@ class availableSinceWarn :: CabalSpecVersion -- ^ spec version - -> g s a - -> g s a + -> g m s a + -> g m s a availableSinceWarn _ = id -- | Field which can be defined at most once. uniqueField - :: (FieldGrammar c g, c (Identity a)) + :: (FieldGrammarWith m c g, c (Identity a)) => FieldName -- ^ field name -> ALens' s a -- ^ lens into the field - -> g s a + -> g m s a uniqueField fn l = uniqueFieldAla fn Identity l +-- | Field which can be defined at most once. +uniqueField' + :: forall m c g s (a :: Type) + . ( FieldGrammarWith m c g + , c (Identity a) + ) + => FieldName + -- ^ field name + -> ALens' s (AnnotateWith Positions m a) + -- ^ lens into the field + -> g m s (AnnotateWith Positions m a) +uniqueField' fn l = uniqueFieldAla' @m @c @g @(Identity a) @s @a fn Identity l + -- | Field which can be defined at most once. optionalField - :: (FieldGrammar c g, c (Identity a)) + :: (FieldGrammarWith m c g, c (Identity a)) => FieldName -- ^ field name -> ALens' s (Maybe a) -- ^ lens into the field - -> g s (Maybe a) + -> g m s (Maybe a) optionalField fn l = optionalFieldAla fn Identity l -- | Optional field with default value. optionalFieldDef - :: (FieldGrammar c g, Functor (g s), c (Identity a), Eq a) + :: (FieldGrammarWith m c g, Functor (g m s), c (Identity a), Eq a) => FieldName -- ^ field name -> ALens' s a -- ^ @'Lens'' s a@: lens into the field -> a -- ^ default value - -> g s a + -> g m s a optionalFieldDef fn l x = optionalFieldDefAla fn Identity l x -- | Field which can be define multiple times, and the results are @mappend@ed. monoidalField - :: (FieldGrammar c g, c (Identity a), Monoid a) + :: (FieldGrammarWith m c g, c (Identity a), Monoid a) => FieldName -- ^ field name -> ALens' s a -- ^ lens into the field - -> g s a + -> g m s a monoidalField fn l = monoidalFieldAla fn Identity l -- | Default implementation for 'freeTextFieldDefST'. defaultFreeTextFieldDefST - :: (Functor (g s), FieldGrammar c g) + :: (Functor (g m s), FieldGrammarWith m c g) => FieldName -> ALens' s ShortText -- ^ lens into the field - -> g s ShortText + -> g m s ShortText defaultFreeTextFieldDefST fn l = toShortText <$> freeTextFieldDef fn (cloneLens l . st) where diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs index e03ae749570..f0c1910e420 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} @@ -26,6 +28,8 @@ import qualified Distribution.Fields as P import qualified Distribution.Parsec as P import qualified Text.PrettyPrint as Disp +import qualified Distribution.Types.Modify as Mod + -- strict pair data SP s = SP { pPretty :: !(s -> Disp.Doc) @@ -33,34 +37,34 @@ data SP s = SP } -- | A collection of field parsers and pretty-printers. -newtype FieldDescrs s a = F {runF :: Map P.FieldName (SP s)} +newtype FieldDescrs (m :: Mod.HasAnnotation) s a = F {runF :: Map P.FieldName (SP s)} deriving (Functor) -instance Applicative (FieldDescrs s) where +instance Applicative (FieldDescrs m 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 :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs m s a singletonF fn f g = F $ Map.singleton fn (SP f g) -- | Lookup a field value pretty-printer. -fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc) +fieldDescrPretty :: FieldDescrs m s a -> P.FieldName -> 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 -> P.FieldName -> Maybe (s -> m s) +fieldDescrParse :: P.CabalParsing m => FieldDescrs mod s a -> P.FieldName -> Maybe (s -> m s) fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m fieldDescrsToList :: P.CabalParsing m - => FieldDescrs s a + => FieldDescrs mod s a -> [(P.FieldName, s -> Disp.Doc, s -> m s)] fieldDescrsToList = map mk . Map.toList . runF where mk (name, SP ppr parse) = (name, ppr, parse) -- | /Note:/ default values are printed. -instance FieldGrammar ParsecPretty FieldDescrs where +instance FieldGrammarWith Mod.HasNoAnn ParsecPretty FieldDescrs where blurFieldGrammar l (F m) = F (fmap blur m) where blur (SP f g) = SP (f . aview l) (cloneLens l g) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 8123285e2b9..7450f7511ac 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -1,17 +1,23 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". module Distribution.FieldGrammar.Newtypes ( -- * List alaList , alaList' + , alaListWith + , alaListWith' -- ** Modifiers , CommaVCat (..) @@ -19,10 +25,14 @@ module Distribution.FieldGrammar.Newtypes , VCat (..) , FSep (..) , NoCommaFSep (..) + + -- ** Separator class , Sep (..) -- ** Type , List + , ListAnn + , ListWith (..) -- ** Set , alaSet @@ -57,6 +67,9 @@ import Distribution.Compiler (CompilerFlavor) import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia +import Distribution.Types.Modify (Annotate, AttachPosition, PreserveGrouping) +import qualified Distribution.Types.Modify as Mod import Distribution.Utils.Path import Distribution.Version ( LowerBound (..) @@ -73,6 +86,7 @@ import Distribution.Version ) import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) +import Data.Kind (Type) import qualified Data.List.NonEmpty as NE import qualified Data.Set as Set import qualified Distribution.Compat.CharParsing as P @@ -93,13 +107,15 @@ data FSep = FSep -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep -class Sep sep where - prettySep :: Proxy sep -> [Doc] -> Doc +class Sep (mod :: Mod.HasAnnotation) sep where + -- TODO(leana8959): Relax Sep to return a list of annotated docs with position + -- Use the position propagated back from applyTriviaDoc + prettySep :: Proxy sep -> [AttachPosition mod (Annotate mod Doc)] -> PreserveGrouping mod (AttachPosition mod Doc) - parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) + parseSep :: CabalParsing m => Proxy sep -> m a -> m [AttachPosition mod (Annotate mod a)] + parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty (AttachPosition mod (Annotate mod a))) -instance Sep CommaVCat where +instance Sep Mod.HasNoAnn CommaVCat where prettySep _ = vcat . punctuate comma parseSep _ p = do v <- askCabalSpecVersion @@ -107,7 +123,22 @@ instance Sep CommaVCat where parseSepNE _ p = do v <- askCabalSpecVersion if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep CommaFSep where + +instance Sep Mod.HasAnn CommaVCat where + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV2_2 then parsecLeadingCommaListAnn p' else parsecCommaListAnn p' + + parseSepNE _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmptyAnn p' else parsecCommaNonEmptyAnn p' + +instance Sep Mod.HasNoAnn CommaFSep where prettySep _ = fsep . punctuate comma parseSep _ p = do v <- askCabalSpecVersion @@ -115,26 +146,88 @@ instance Sep CommaFSep where parseSepNE _ p = do v <- askCabalSpecVersion if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep VCat where + +instance Sep Mod.HasAnn CommaFSep where + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV2_2 then parsecLeadingCommaListAnn p' else parsecCommaListAnn p' + parseSepNE _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmptyAnn p' else parsecCommaNonEmptyAnn p' + +instance Sep Mod.HasNoAnn VCat where prettySep _ = vcat parseSep _ p = do v <- askCabalSpecVersion if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep FSep where + +instance Sep Mod.HasAnn VCat where + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' + parseSepNE _ p = + fmap extractPosition <$> + NE.some1 + ( do + x <- parsecWithPosition p + post <- P.spaces' + pure (Ann (postTrivia post) x) + ) + +instance Sep Mod.HasNoAnn FSep where prettySep _ = fsep parseSep _ p = do v <- askCabalSpecVersion if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep NoCommaFSep where + +instance Sep Mod.HasAnn FSep where + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' + parseSepNE _ p = + fmap extractPosition <$> + NE.some1 + ( do + x <- parsecWithPosition p + post <- P.spaces' + pure (Ann (postTrivia post) x) + ) + +instance Sep Mod.HasNoAnn NoCommaFSep where prettySep _ = fsep parseSep _ p = many (p <* P.spaces) parseSepNE _ p = NE.some1 (p <* P.spaces) +instance Sep Mod.HasAnn NoCommaFSep where + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = (fmap . fmap) extractPosition $ many $ do + x <- parsecWithPosition p + post <- P.spaces' + pure (Ann (postTrivia post) x) + parseSepNE _ p = (fmap . fmap) extractPosition $ NE.some1 $ do + x <- parsecWithPosition p + post <- P.spaces' + pure (Ann (postTrivia post) x) + -- | List separated with optional commas. Displayed with @sep@, arguments of -- type @a@ are parsed and pretty-printed as @b@. -newtype List sep b a = List {_getList :: [a]} +newtype ListWith mod sep b a = List {_getList :: [AttachPosition mod (Annotate mod a)]} + +type List = ListWith Mod.HasNoAnn +type ListAnn = ListWith Mod.HasAnn -- | 'alaList' and 'alaList'' are simply 'List', with additional phantom -- arguments to constrain the resulting type @@ -147,19 +240,44 @@ newtype List sep b a = List {_getList :: [a]} alaList :: sep -> [a] -> List sep (Identity a) a alaList _ = List +-- | Use Type Application to create a ListWith data +alaListWith + :: forall (mod :: Mod.HasAnnotation) (sep :: Type) (a :: Type) + . [AttachPosition mod (Annotate mod a)] + -> ListWith mod sep (Identity a) a +alaListWith = List + -- | More general version of 'alaList'. alaList' :: sep -> (a -> b) -> [a] -> List sep b a alaList' _ _ = List -instance Newtype [a] (List sep wrapper a) +alaListWith' + :: forall (mod :: Mod.HasAnnotation) (sep :: Type) (b :: Type) (a :: Type) + . [AttachPosition mod (Annotate mod a)] + -> ListWith mod sep b a +alaListWith' = List -instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec +instance Newtype [a] (ListWith Mod.HasNoAnn sep wrapper a) +instance Newtype [(Position, Ann SurroundingText a)] (ListWith Mod.HasAnn sep wrapper a) -instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack +instance (Newtype a b, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (List sep b a) where + parsec = pack . map (unpack :: b -> a) <$> parseSep @Mod.HasNoAnn (Proxy :: Proxy sep) parsec --- +instance (Newtype a b, Sep Mod.HasAnn sep, Parsec b) => Parsec (ListAnn sep b a) where + parsec = pack . (map . fmap . fmap) (unpack :: b -> a) <$> parseSep @Mod.HasAnn (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (List sep b a) where + pretty = prettySep @Mod.HasNoAnn (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack + +instance (Newtype a b, Sep Mod.HasAnn sep, Pretty b) => Pretty (ListAnn sep b a) where + -- TODO(leana8959): + -- Currently we lose the leading spaces because they are dropped by the field lexer / parser. + -- However, we still have the position information to reconstruct them. + -- + -- For the complete implementation we need to + -- - handle comments interleaved between the lines here, they are removed early on. + -- - indent each line and then mconcat them to restore exact horizontal spacing. whitespaces are removed at lexer stage. + pretty = mconcat . map snd . prettySep @Mod.HasAnn (Proxy :: Proxy sep) . (map . fmap . fmap) (pretty . (pack :: a -> b)) . unpack -- | Like 'List', but for 'Set'. -- @@ -190,11 +308,11 @@ alaSet' _ _ = Set' instance Newtype (Set a) (Set' sep wrapper a) -instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where - parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec +instance (Newtype a b, Ord a, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (Set' sep b a) where + parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep @Mod.HasNoAnn (Proxy :: Proxy sep) parsec -instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack +instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (Set' sep b a) where + pretty = prettySep @Mod.HasNoAnn (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack -- @@ -224,11 +342,11 @@ alaNonEmpty' _ _ = NonEmpty' instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) -instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where - parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec +instance (Newtype a b, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (NonEmpty' sep b a) where + parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE @Mod.HasNoAnn (Proxy :: Proxy sep) parsec -instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack +instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (NonEmpty' sep b a) where + pretty = prettySep @Mod.HasNoAnn (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack ------------------------------------------------------------------------------- -- Identifiers diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 581daf4c202..5ea269ba0ce 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- | This module provides a 'FieldGrammarParser', one way to parse -- @.cabal@ -like files. @@ -69,6 +75,7 @@ module Distribution.FieldGrammar.Parsec , freeTextIgnoreDotlineVers ) where +import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Utils.Generic (fromUTF8BS) @@ -90,6 +97,12 @@ import Distribution.Fields.ParseResult import Distribution.Parsec import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) +import Distribution.Trivia + +import Data.Kind + +import Distribution.Types.Modify (AttachPositions, AnnotateWith, PreserveGrouping) +import qualified Distribution.Types.Modify as Mod ------------------------------------------------------------------------------- -- Auxiliary types @@ -112,51 +125,51 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] -- ParsecFieldGrammar ------------------------------------------------------------------------------- -data ParsecFieldGrammar s a = ParsecFG +data ParsecFieldGrammar (m :: Mod.HasAnnotation) s a = ParsecFG { fieldGrammarKnownFields :: !(Set FieldName) , fieldGrammarKnownPrefixes :: !(Set FieldName) - , fieldGrammarParser :: forall src. (CabalSpecVersion -> Fields Position -> ParseResult src a) + , fieldGrammarParser :: forall src. (CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src a) } deriving (Functor) -parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a -parseFieldGrammar v fields grammar = do +parseFieldGrammar :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParsecFieldGrammar m s a -> ParseResult src a +parseFieldGrammar v sectionPos fields grammar = do for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) -> for_ nfields $ \(MkNamelessField pos _) -> parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name -- TODO: fields allowed in this section -- parse - fieldGrammarParser grammar v fields + fieldGrammarParser grammar v sectionPos fields -isUnknownField :: ParsecFieldGrammar s a -> FieldName -> [NamelessField Position] -> Bool +isUnknownField :: ParsecFieldGrammar m s a -> FieldName -> [NamelessField Position] -> Bool isUnknownField grammar k _ = not $ k `Set.member` fieldGrammarKnownFields grammar || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) -- | Parse a ParsecFieldGrammar and check for fields that should be stanzas. -parseFieldGrammarCheckingStanzas :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> Set BS.ByteString -> ParseResult src a -parseFieldGrammarCheckingStanzas v fields grammar sections = do +parseFieldGrammarCheckingStanzas :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParsecFieldGrammar m s a -> Set BS.ByteString -> ParseResult src a +parseFieldGrammarCheckingStanzas v sectionPos fields grammar sections = do for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) -> for_ nfields $ \(MkNamelessField pos _) -> if name `Set.member` sections then parseFailure pos $ "'" ++ fromUTF8BS name ++ "' is a stanza, not a field. Remove the trailing ':' to parse a stanza." else parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name - fieldGrammarParser grammar v fields + fieldGrammarParser grammar v sectionPos fields -fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] +fieldGrammarKnownFieldList :: ParsecFieldGrammar m s a -> [FieldName] fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields -instance Applicative (ParsecFieldGrammar s) where - pure x = ParsecFG mempty mempty (\_ _ -> pure x) +instance Applicative (ParsecFieldGrammar m 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') - (\v fields -> f'' v fields <*> x'' v fields) + (\v sPos fields -> f'' v sPos fields <*> x'' v sPos fields) {-# INLINE (<*>) #-} warnMultipleSingularFields :: FieldName -> [NamelessField Position] -> ParseResult src () @@ -167,12 +180,12 @@ warnMultipleSingularFields fn (x : xs) = do parseWarning pos PWTMultipleSingularField $ "The field " <> show fn <> " is specified more than once at positions " ++ intercalate ", " (map showPos (pos : poss)) -instance FieldGrammar Parsec ParsecFieldGrammar where +instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" Just [x] -> parseOne v x @@ -183,9 +196,11 @@ instance FieldGrammar Parsec ParsecFieldGrammar where parseOne v (MkNamelessField pos fls) = unpack' _pack <$> runFieldParser pos parsec v fls + uniqueFieldAla' = uniqueFieldAla + booleanFieldDef fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> pure def Just [] -> pure def Just [x] -> parseOne v x @@ -195,9 +210,11 @@ instance FieldGrammar Parsec ParsecFieldGrammar where parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + booleanFieldDef' = booleanFieldDef + optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> pure Nothing Just [] -> pure Nothing Just [x] -> parseOne v x @@ -211,7 +228,7 @@ instance FieldGrammar Parsec ParsecFieldGrammar where optionalFieldDefAla fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> pure def Just [] -> pure def Just [x] -> parseOne v x @@ -225,7 +242,7 @@ instance FieldGrammar Parsec ParsecFieldGrammar where freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> pure Nothing Just [] -> pure Nothing Just [x] -> parseOne v x @@ -240,7 +257,7 @@ instance FieldGrammar Parsec ParsecFieldGrammar where freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> pure "" Just [] -> pure "" Just [x] -> parseOne v x @@ -256,7 +273,7 @@ instance FieldGrammar Parsec ParsecFieldGrammar where -- freeTextFieldDefST = defaultFreeTextFieldDefST freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser v _ fields = case Map.lookup fn fields of Nothing -> pure mempty Just [] -> pure mempty Just [x] -> parseOne v x @@ -271,15 +288,26 @@ instance FieldGrammar Parsec ParsecFieldGrammar where | v >= freeTextIgnoreDotlineVers -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) + monoidalFieldAla + :: forall m b a s + . (Parsec b, Monoid a, Newtype a b) + => FieldName + -> (a -> b) + -> ALens' s a + -> ParsecFieldGrammar m s a monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser v fields = case Map.lookup fn fields of + parser :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src a + parser v _ fields = case Map.lookup fn fields of Nothing -> pure mempty Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src b parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) + monoidalFieldAla' = monoidalFieldAla + + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_v _sPos -> pure . parser) where parser :: Fields Position -> [(String, String)] parser values = reorder $ concatMap convert $ filter match $ Map.toList values @@ -294,8 +322,8 @@ instance FieldGrammar Parsec ParsecFieldGrammar where availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values - | v >= vs = parser v values + parser' v spos values + | v >= vs = parser v spos values | otherwise = do let unknownFields = Map.intersection values $ Map.fromSet (const ()) names for_ (Map.toList unknownFields) $ \(name, fields) -> @@ -307,8 +335,8 @@ instance FieldGrammar Parsec ParsecFieldGrammar where availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values - | v >= vs = parser v values + parser' v spos values + | v >= vs = parser v spos values | otherwise = do let unknownFields = Map.intersection values $ Map.fromSet (const ()) names for_ (Map.toList unknownFields) $ \(name, fields) -> @@ -316,12 +344,12 @@ instance FieldGrammar Parsec ParsecFieldGrammar where parseWarning pos PWTUnknownField $ "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." - parser v values + parser v spos values -- todo we know about this field deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values + parser' v spos values | v >= vs = do let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names for_ (Map.toList deprecatedFields) $ \(name, fields) -> @@ -329,12 +357,12 @@ instance FieldGrammar Parsec ParsecFieldGrammar where parseWarning pos PWTDeprecatedField $ "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg - parser v values - | otherwise = parser v values + parser v spos values + | otherwise = parser v spos values removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' where - parser' v values + parser' v spos values | v >= vs = do let msg' = if null msg then "" else ' ' : msg let unknownFields = Map.intersection values $ Map.fromSet (const ()) names @@ -348,17 +376,308 @@ instance FieldGrammar Parsec ParsecFieldGrammar where case namePos of -- no fields => proceed (with empty values, to be sure) - [] -> parser v mempty + [] -> parser v spos mempty -- if there's single field: fail fatally with it ((name, pos) : rest) -> do for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' parseFatalFailure pos $ makeMsg name - | otherwise = parser v values + | otherwise = parser v spos values + + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ _ -> pure ()) + + hiddenField = id + +instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where + -- Old methods + blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser + uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v _ fields = case Map.lookup fn fields of + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) = + unpack' _pack <$> runFieldParser pos parsec v fls + booleanFieldDef fn _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@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + optionalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v _ fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) + | 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@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) + | null fls = pure def + | otherwise = unpack' _pack <$> runFieldParser pos parsec v fls + freeTextField fn _ = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v _ fields = case Map.lookup fn fields of + Nothing -> pure Nothing + Just [] -> pure Nothing + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) + | null fls = pure Nothing + | v >= freeTextIgnoreDotlineVers = pure (Just (fieldlinesToFreeText3 pos fls)) + | otherwise = pure (Just (fieldlinesToFreeText fls)) + freeTextFieldDef fn _ = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v _ fields = case Map.lookup fn fields of + Nothing -> pure "" + Just [] -> pure "" + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) + | null fls = pure "" + | v >= freeTextIgnoreDotlineVers = pure (fieldlinesToFreeText3 pos fls) + | otherwise = pure (fieldlinesToFreeText fls) + freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser + where + parser v _ fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just [] -> pure mempty + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + parseOne v (MkNamelessField pos fls) = case fls of + [] -> pure mempty + [FieldLine _ bs] -> pure (ShortText.unsafeFromUTF8BS bs) + _ + | v >= freeTextIgnoreDotlineVers -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) + | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) + monoidalFieldAla + :: forall m b a s + . (Parsec b, Monoid a, Newtype a b) + => FieldName + -> (a -> b) + -> ALens' s a + -> ParsecFieldGrammar m s a + monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src a + parser v _ fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> foldMap (unpack' _pack) <$> traverse (parseOne v) xs + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src b + parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ _ fs -> pure (parser fs)) + 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) = + [ (pos, (fromUTF8BS fn, trim $ fromUTF8BS $ fieldlinesToBS fls)) + | MkNamelessField pos fls <- fields + ] + -- hack: recover the order of prefixed fields + reorder = map snd . sortBy (comparing fst) + availableSince vs def (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v spos values + | v >= vs = parser v spos values + | otherwise = do + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList unknownFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ + "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ ". This field will be ignored." + pure def - knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) + availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v spos values + | v >= vs = parser v spos values + | otherwise = do + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList unknownFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTUnknownField $ + "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." + parser v spos values + deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v spos values + | v >= vs = do + let deprecatedFields = Map.intersection values $ Map.fromSet (const ()) names + for_ (Map.toList deprecatedFields) $ \(name, fields) -> + for_ fields $ \(MkNamelessField pos _) -> + parseWarning pos PWTDeprecatedField $ + "The field " <> show name <> " is deprecated in the Cabal specification version " ++ showCabalSpecVersion vs ++ ". " ++ msg + parser v spos values + | otherwise = parser v spos values + removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v spos values + | v >= vs = do + let msg' = if null msg then "" else ' ' : msg + let unknownFields = Map.intersection values $ Map.fromSet (const ()) names + let namePos = + [ (name, pos) + | (name, fields) <- Map.toList unknownFields + , MkNamelessField pos _ <- fields + ] + let makeMsg name = "The field " <> show name <> " is removed in the Cabal specification version " ++ showCabalSpecVersion vs ++ "." ++ msg' + case namePos of + -- no fields => proceed (with empty values, to be sure) + [] -> parser v spos mempty + -- if there's single field: fail fatally with it + ((name, pos) : rest) -> do + for_ rest $ \(name', pos') -> parseFailure pos' $ makeMsg name' + parseFatalFailure pos $ makeMsg name + | otherwise = parser v spos values + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ _ -> pure ()) hiddenField = id + -- New methods + + booleanFieldDef' + :: forall s + . FieldName + -- \^ field name + -> ALens' s [Ann Positions Bool] + -- \^ lens into the field + -> Bool + -- \^ default + -> ParsecFieldGrammar Mod.HasAnn s [Ann Positions Bool] + booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src [Ann Positions Bool] + parser v spos fields = case Map.lookup fn fields of + Nothing -> pure def' + Just [] -> pure def' + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + where + def' = [Ann IsInserted def] + + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src [Ann Positions Bool] + parseOne v (MkNamelessField pos fls) = do + (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition parsec) v fls + pure . (:[]) $ Ann (HasTrivia $ Positions spos pos fieldLinePos) x + + -- TODO(leana8959): implement all methods + + -- This function allows us to manage the position coming from a parsed field + -- In the printer, it can... IDK? Annotate the pretty doc position? + -- + -- - merging is defered + -- - position is retained in each result + monoidalFieldAla' + :: forall b a s + . (Parsec b, Newtype a b) + => FieldName + -> (a -> b) + -> ALens' s [(Positions, a)] + -> ParsecFieldGrammar Mod.HasAnn s [(Positions, a)] + monoidalFieldAla' fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src [(Positions, a)] + parser v spos fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> map (\(p, a) -> (p,) $ unpack' _pack a) <$> traverse (parseOne v) xs + where + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) + parseOne v (MkNamelessField pos fls) = do + (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition parsec) v fls + pure (Positions spos pos fieldLinePos, x) + + optionalFieldDefAla' + :: forall b a s + . (Parsec b, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s (Ann Positions a) + -- ^ @'Lens'' s a@: lens into the field + -> a + -- ^ default value + -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions a) + optionalFieldDefAla' fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src (Ann Positions a) + parser v spos fields = case Map.lookup fn fields of + Nothing -> pure def' + Just [] -> pure def' + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + where + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Ann Positions a) + parseOne v (MkNamelessField pos fls) + | null fls = pure def' + | otherwise = do + (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition (parsec @b)) v fls + pure (Ann (HasTrivia $ Positions spos pos fieldLinePos) (unpack' _pack x)) + + def' :: Ann Positions a + def' = Ann IsInserted def + + + uniqueFieldAla' + :: forall (b :: Type) (s :: Type) (a :: Type) + . ( Newtype a b + , Parsec b + ) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s (Ann Positions a) + -- ^ lens into the field + -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions a) + uniqueFieldAla' fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: CabalSpecVersion -> Maybe Position -> Fields Position -> ParseResult src (Ann Positions a) + parser v spos fields = case Map.lookup fn fields of + Nothing -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [] -> parseFatalFailure zeroPos $ show fn ++ " field missing" + Just [x] -> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + NE.last <$> traverse (parseOne v) (y :| ys) + where + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Ann Positions a) + parseOne v (MkNamelessField pos fls) = do + (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition (parsec @b)) v fls + pure (Ann (HasTrivia $ Positions spos pos fieldLinePos) (unpack' _pack x)) + ------------------------------------------------------------------------------- -- Parsec ------------------------------------------------------------------------------- @@ -457,7 +776,10 @@ mealy f = go go _ [] = [] go s (x : xs) = let ~(s', y) = f s x in y : go s' xs -fieldLinesToStream :: [FieldLine ann] -> FieldLineStream -fieldLinesToStream [] = fieldLineStreamEnd -fieldLinesToStream [FieldLine _ bs] = FLSLast bs -fieldLinesToStream (FieldLine _ bs : fs) = FLSCons bs (fieldLinesToStream fs) +fieldLinesToStream :: [FieldLine Position] -> FieldLineStream +fieldLinesToStream = fieldLinesToStream' (Position 1 1) + +-- | Fallback to last position when there's no 'FieldLine' +fieldLinesToStream' :: Position -> [FieldLine Position] -> FieldLineStream +fieldLinesToStream' defaultPos [] = FLSLast mempty defaultPos +fieldLinesToStream' defaultPos (FieldLine pos bs : fs) = FLSCons bs pos (fieldLinesToStream' defaultPos fs) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index a35d8f361f4..75b77b3c550 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,5 +1,12 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.FieldGrammar.Pretty ( PrettyFieldGrammar @@ -11,53 +18,88 @@ import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Fields.Field (FieldName) -import Distribution.Fields.Pretty (PrettyField (..)) +import Distribution.Fields.Pretty (PrettyField, PrettyFieldWith (..)) +import Distribution.Parsec.Position import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) +import Distribution.Trivia +import Distribution.Types.Modify import Distribution.Utils.Generic (toUTF8BS) import Text.PrettyPrint (Doc) import qualified Text.PrettyPrint as PP import Prelude () +import Data.Kind + import Distribution.FieldGrammar.Class +import qualified Distribution.Types.Modify as Mod -newtype PrettyFieldGrammar s a = PrettyFG - { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] +-- TODO(leana8959): maybe we can compare this to [Field Position] and thus form a roundtrip test. +newtype PrettyFieldGrammar (m :: Mod.HasAnnotation) s a = PrettyFG + { fieldGrammarPretty + :: CabalSpecVersion + -> Maybe (ALens' s Position) + -- ^ A lens to retrieve the section position, if there are any + -> s + -> PrettyFieldGrammarOut m } deriving (Functor) -instance Applicative (PrettyFieldGrammar s) where +-- Toggle between legacy print and new exact print +-- +-- Sections are not modeled in Field grammar. +-- PrettyFieldGrammar should output a field and not think about sections. +-- +-- Outputting sections in field grammar would require us to fuse elements of the same section together. +type family PrettyFieldGrammarOut (m :: Mod.HasAnnotation) where + PrettyFieldGrammarOut Mod.HasNoAnn = [PrettyField] + PrettyFieldGrammarOut Mod.HasAnn = + [ ( Maybe Position + , (Position, FieldName) + , (Position, PP.Doc) + ) + ] + +instance Applicative (PrettyFieldGrammar Mod.HasNoAnn s) where + pure _ = PrettyFG (\_ _ -> mempty) + PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) + +instance Applicative (PrettyFieldGrammar Mod.HasAnn s) where pure _ = PrettyFG (\_ _ -> mempty) PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s) -- | We can use 'PrettyFieldGrammar' to pp print the @s@. -- -- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()] -prettyFieldGrammar = flip fieldGrammarPretty +prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> Maybe (ALens' s Position) -> s -> PrettyFieldGrammarOut m +prettyFieldGrammar csv fg sectionPos = fieldGrammarPretty fg csv sectionPos -instance FieldGrammar Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) +instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where + blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v _ -> pp v Nothing . aview f) - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> + uniqueFieldAla fn _pack l = PrettyFG $ \_v _ s -> ppField fn (pretty (pack' _pack (aview l s))) + uniqueFieldAla' = uniqueFieldAla + booleanFieldDef fn l def = PrettyFG pp where - pp _v s + pp _v _ s | b == def = mempty | otherwise = ppField fn (PP.text (show b)) where b = aview l s + booleanFieldDef' = booleanFieldDef + optionalFieldAla fn _pack l = PrettyFG pp where - pp v s = case aview l s of + pp v _ s = case aview l s of Nothing -> mempty Just a -> ppField fn (prettyVersioned v (pack' _pack a)) optionalFieldDefAla fn _pack l def = PrettyFG pp where - pp v s + pp v _ s | x == def = mempty | otherwise = ppField fn (prettyVersioned v (pack' _pack x)) where @@ -65,7 +107,7 @@ instance FieldGrammar Pretty PrettyFieldGrammar where freeTextField fn l = PrettyFG pp where - pp v s = maybe mempty (ppField fn . showFT) (aview l s) + pp v _ s = maybe mempty (ppField fn . showFT) (aview l s) where showFT | v >= CabalSpecV3_0 = showFreeTextV3 @@ -74,7 +116,7 @@ instance FieldGrammar Pretty PrettyFieldGrammar where -- it's ok to just show, as showFreeText of empty string is empty. freeTextFieldDef fn l = PrettyFG pp where - pp v s = ppField fn (showFT (aview l s)) + pp v _ s = ppField fn (showFT (aview l s)) where showFT | v >= CabalSpecV3_0 = showFreeTextV3 @@ -84,14 +126,16 @@ instance FieldGrammar Pretty PrettyFieldGrammar where monoidalFieldAla fn _pack l = PrettyFG pp where - pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) + pp v _ s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) + + monoidalFieldAla' = monoidalFieldAla - prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) + prefixedFields _fnPfx l = PrettyFG (\_ _ -> pp . aview l) where pp xs = -- always print the field, even its Doc is empty. -- i.e. don't use ppField - [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s + [ PrettyField (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s | (n, s) <- xs -- fnPfx `isPrefixOf` n ] @@ -106,7 +150,143 @@ instance FieldGrammar Pretty PrettyFieldGrammar where availableSince _ _ = id hiddenField _ = PrettyFG (\_ -> mempty) -ppField :: FieldName -> Doc -> [PrettyField ()] +instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where + -- Nothing because subgrammar is not directly within a section? + blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v _ -> pp v Nothing . aview f) + + -- TODO: push out section position from here + uniqueFieldAla fn _pack l = PrettyFG $ \_v pl s -> + ppFieldFakePos fn (pretty (pack' _pack (aview l s))) + + booleanFieldDef fn l def = PrettyFG pp + where + pp _v pl s + | b == def = mempty + | otherwise = ppFieldFakePos fn (PP.text (show b)) + where + b = aview l s + + optionalFieldAla fn _pack l = PrettyFG pp + where + pp v pl s = case aview l s of + Nothing -> mempty + Just a -> ppFieldFakePos fn (prettyVersioned v (pack' _pack a)) + + optionalFieldDefAla fn _pack l def = PrettyFG pp + where + pp v pl s + | x == def = mempty + | otherwise = ppFieldFakePos fn (prettyVersioned v (pack' _pack x)) + where + x = aview l s + + freeTextField fn l = PrettyFG pp + where + pp v pl s = maybe mempty (ppFieldFakePos fn . showFT) (aview l s) + where + showFT + | v >= CabalSpecV3_0 = showFreeTextV3 + | otherwise = showFreeText + + -- it's ok to just show, as showFreeText of empty string is empty. + freeTextFieldDef fn l = PrettyFG pp + where + pp v pl s = ppFieldFakePos fn (showFT (aview l s)) + where + showFT + | v >= CabalSpecV3_0 = showFreeTextV3 + | otherwise = showFreeText + + freeTextFieldDefST = defaultFreeTextFieldDefST + + monoidalFieldAla fn _pack l = PrettyFG pp + where + pp v pl s = ppFieldFakePos fn (prettyVersioned v (pack' _pack (aview l s))) + + prefixedFields _fnPfx l = PrettyFG (\_ _ -> pp . aview l) + where + pp xs = + -- always print the field, even its Doc is empty. + -- i.e. don't use ppField + [ (Just zeroPos,,) (zeroPos, toUTF8BS n) (zeroPos, PP.vcat $ map PP.text $ lines s) + | (n, s) <- xs + -- fnPfx `isPrefixOf` n + ] + + knownField _ = pure () + deprecatedSince _ _ x = x + + -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field + -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed + -- so invalid documents can be only manually constructed. + removedIn _ _ x = x + availableSince _ _ = id + hiddenField _ = PrettyFG (\_ -> mempty) + + -- New methods + + monoidalFieldAla' fn _pack l = PrettyFG $ \v pl s -> + let bs = fmap (prettyVersioned v . pack' _pack) <$> aview l s + in ppFieldPos fn bs + + booleanFieldDef' fn l def = PrettyFG $ \_v pl s -> + aview l s >>= \(Ann t b) -> case t of + HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] + IsInserted -> mempty + + optionalFieldDefAla' fn _pack l def = PrettyFG pp + where + -- We absorb fields that have no position for the prototype + pp v pl s = + let Ann t u :: Ann Positions Doc = prettyVersioned v . pack' _pack <$> x + in case t of + HasTrivia pos -> ppFieldPos fn [(pos, u)] + IsInserted -> mempty + where + x = aview l s + + uniqueFieldAla' + :: forall (b :: Type) (s :: Type) (a :: Type) + . ( Newtype a b + , Pretty b + ) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'Newtype' pack + -> ALens' s (Ann Positions a) + -- ^ lens into the field + -> PrettyFieldGrammar Mod.HasAnn s (Ann Positions a) + uniqueFieldAla' fn _pack l = PrettyFG pp + where + pp v pl s = + let Ann t u :: Ann Positions Doc = prettyVersioned v . pack' _pack <$> x + in case t of + -- We absorb fields that have no position for the prototype + HasTrivia pos -> ppFieldPos fn [(pos, u)] + IsInserted -> mempty + where x = aview l s + +ppField :: FieldName -> Doc -> [PrettyField] ppField name fielddoc | PP.isEmpty fielddoc = [] - | otherwise = [PrettyField () name fielddoc] + | otherwise = [PrettyField name fielddoc] + +ppFieldPos :: FieldName -> [(Positions, Doc)] -> PrettyFieldGrammarOut Mod.HasAnn +ppFieldPos name possFieldDocs = + [ (,,) + (sectionPos poss) + (fieldNamePos poss, name) + (fieldLinePos poss, fieldDoc) + | (poss, fieldDoc) <- possFieldDocs + ] + +-- TODO(leana8959): push out position +-- | Doesn't push out real position, tbd +ppFieldFakePos :: FieldName -> Doc -> PrettyFieldGrammarOut Mod.HasAnn +ppFieldFakePos name fieldDoc = + [ (,,) + (Just zeroPos) + (zeroPos, name) + (zeroPos, fieldDoc) + ] diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index d458ca41e80..b2571dbeb0c 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -1,4 +1,8 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase #-} @@ -10,8 +14,11 @@ module Distribution.Fields.Pretty ( -- * Fields CommentPosition (..) - , PrettyField (..) + , PrettyField + , PrettyFieldWith (..) + , filterFields , showFields + , exactShowFields , showFields' -- * Transformation from 'P.Field' @@ -24,10 +31,22 @@ module Distribution.Fields.Pretty import Distribution.Compat.Prelude import Distribution.Pretty (showToken) import Prelude () +import Control.Monad ((<=<)) -import Distribution.Fields.Field (FieldName) -import Distribution.Utils.Generic (fromUTF8BS) +import Distribution.Parsec.Position +import Distribution.Fields.Field (FieldName, Name) +import Distribution.Utils.Generic (fromUTF8BS, safeHead) +import qualified Data.List as List +import qualified Data.Text as T + +import Distribution.Trivia +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AttachPosition, AnnotateWith) +import Distribution.Pretty.ExactDoc (ExactDoc) +import qualified Distribution.Pretty.ExactDoc as EPP +import Text.PrettyPrint (Doc) +import qualified Text.PrettyPrint as PP import qualified Distribution.Fields.Parser as P import qualified Data.ByteString as BS @@ -39,11 +58,30 @@ import qualified Text.PrettyPrint as PP -- conjunction with @PrettyField@. data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment -data PrettyField ann - = PrettyField ann FieldName PP.Doc - | PrettySection ann FieldName [PP.Doc] [PrettyField ann] +type PrettyField = PrettyFieldWith Mod.HasNoAnn + +deriving instance Eq (PrettyFieldWith Mod.HasAnn) + +-- NOTE(leana8959): some pretty field considerations +-- - do section args need to be a _list_ of PP.Doc +-- - do we need pretty empty with exact doc +-- +-- TODO(leana8959): we need to reproduce the field line +-- - each Doc in field (FieldLine) should come with its positioning +data PrettyFieldWith (mod :: Mod.HasAnnotation) + = PrettyField (AttachPosition mod FieldName) (AttachPosition mod PP.Doc) + | PrettySection (AttachPosition mod FieldName) [PP.Doc] [PrettyFieldWith mod] | PrettyEmpty - deriving (Functor, Foldable, Traversable) + +prettyFieldPosition :: PrettyFieldWith Mod.HasAnn -> Maybe Position +prettyFieldPosition (PrettyField (pos, _) _) = Just pos +prettyFieldPosition _ = Nothing + +prettySectionPosition :: PrettyFieldWith Mod.HasAnn -> Maybe Position +prettySectionPosition (PrettySection (pos, _) _ _) = Just pos +prettySectionPosition _ = Nothing + +deriving instance Show (PrettyFieldWith Mod.HasAnn) -- | Prettyprint a list of fields. -- @@ -51,9 +89,36 @@ data PrettyField ann -- and properly prefixes (with @--@) to count as comments. -- This unsafety is left in place so one could generate empty lines -- between comment lines. -showFields :: (ann -> CommentPosition) -> [PrettyField ann] -> String +showFields :: (ann -> CommentPosition) -> [PrettyField] -> String showFields rann = showFields' rann (const id) 4 +-- | Only for the prototype. +-- We use zeroPos (Position 0 0) as a marker for data that shouldn't be printed. +-- This function filters them out. +filterFields :: [PrettyFieldWith Mod.HasAnn] -> [PrettyFieldWith Mod.HasAnn] +filterFields = mapMaybe $ \field -> case field of + PrettyField (fnamePos, _) _ -> do + guard (fnamePos /= zeroPos) + pure field + PrettySection sname@(snamePos, _) args fields -> do + let fields' = filterFields fields + guard (not (null fields')) + pure (PrettySection sname args fields') + +exactShowFields :: [PrettyFieldWith Mod.HasAnn] -> String +exactShowFields = + T.unpack + . EPP.renderText + . prettyFieldsToExactDoc + where + ctx0 = (Nothing, Nothing) + +prettyFieldsToExactDoc :: [PrettyFieldWith Mod.HasAnn] -> ExactDoc +prettyFieldsToExactDoc = mconcat . snd . exactRenderPrettyFields ctx0 + where + ctx0 = (Nothing, Nothing) + + -- | 'showFields' with user specified indentation. showFields' :: (ann -> CommentPosition) @@ -62,7 +127,7 @@ showFields' -- ^ Post-process non-annotation produced lines. -> Int -- ^ Indentation level. - -> [PrettyField ann] + -> [PrettyField] -- ^ Fields/sections to show. -> String showFields' rann post n = unlines . renderFields (Opts rann indent post) @@ -87,7 +152,7 @@ data Opts ann = Opts , _optPostprocess :: ann -> [String] -> [String] } -renderFields :: Opts ann -> [PrettyField ann] -> [String] +renderFields :: Opts ann -> [PrettyField] -> [String] renderFields opts fields = flattenBlocks blocks where len = maxNameLength 0 fields @@ -96,7 +161,7 @@ renderFields opts fields = flattenBlocks blocks map (renderField opts len) fields maxNameLength !acc [] = acc - maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest + maxNameLength !acc (PrettyField name _ : rest) = maxNameLength (max acc (BS.length name)) rest maxNameLength !acc (PrettySection{} : rest) = maxNameLength acc rest maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest @@ -128,20 +193,12 @@ flattenBlocks = go0 | surr' <> before == Margin = ("" :) | otherwise = id -renderField :: Opts ann -> Int -> PrettyField ann -> Block -renderField (Opts rann indent post) fw (PrettyField ann name doc) = +renderField :: Opts ann -> Int -> PrettyField -> Block +renderField (Opts rann indent post) fw (PrettyField name doc) = Block before after content where - content = case comments of - CommentBefore cs -> cs ++ post ann lines' - CommentAfter cs -> post ann lines' ++ cs - NoComment -> post ann lines' - comments = rann ann - before = case comments of - CommentBefore [] -> NoMargin - CommentAfter [] -> NoMargin - NoComment -> NoMargin - _ -> Margin + content = lines' + before = NoMargin (lines', after) = case lines narrow of [] -> ([name' ++ ":"], NoMargin) @@ -155,16 +212,11 @@ renderField (Opts rann indent post) fw (PrettyField ann name doc) = narrowStyle :: PP.Style narrowStyle = PP.style{PP.lineLength = PP.lineLength PP.style - fw} -renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = +renderField opts@(Opts rann indent post) _ (PrettySection name args fields) = Block Margin Margin $ - attachComments - (post ann [PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args]) + [PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args] ++ map indent (renderFields opts fields) where - attachComments content = case rann ann of - CommentBefore cs -> cs ++ content - CommentAfter cs -> content ++ cs - NoComment -> content renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty ------------------------------------------------------------------------------- @@ -178,13 +230,13 @@ genericFromParsecFields -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments -> [P.Field ann] - -> f [PrettyField ann] + -> f [PrettyField] genericFromParsecFields f g = goMany where goMany = traverse go - go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls - go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs + go (P.Field (P.Name _ name) fls) = PrettyField name <$> f name fls + go (P.Section (P.Name _ name) secargs fs) = PrettySection name <$> g name secargs <*> goMany fs -- | Used in 'fromParsecFields'. prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc @@ -202,7 +254,7 @@ prettySectionArgs _ = map $ \case P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs -- | Simple variant of 'genericFromParsecField' -fromParsecFields :: [P.Field ann] -> [PrettyField ann] +fromParsecFields :: [P.Field ann] -> [PrettyField] fromParsecFields = runIdentity . genericFromParsecFields @@ -211,3 +263,134 @@ fromParsecFields = where (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) (f .: g) x y = f (g x y) + + +type PrettyFieldPositionContext = + ( Maybe (PrettyFieldWith Mod.HasAnn) + , Maybe (Position, PP.Doc) + ) + +placeAt :: Position -> ExactDoc -> ExactDoc +placeAt (Position r c) = EPP.place r c + +-- | Post condition: Fields are sorted in ascending order +exactRenderPrettyFields + :: PrettyFieldPositionContext + -> [PrettyFieldWith Mod.HasAnn] + -> (PrettyFieldPositionContext, [ExactDoc]) +exactRenderPrettyFields ctx0 = fmap reverse . foldl go state0 . sortPrettyFields + where + state0 :: (PrettyFieldPositionContext, [ExactDoc]) + state0 = (ctx0, []) + + go (ctx, processed) field = + let (ctx', field') = exactRenderPrettyField ctx field + in (ctx', field' : processed) + +exactRenderPrettyField + :: PrettyFieldPositionContext + -> PrettyFieldWith Mod.HasAnn + -> (PrettyFieldPositionContext, ExactDoc) +exactRenderPrettyField ctx0@(lastField, lastFieldLine) field = case field of + -- Absorb empty + PrettyEmpty -> (ctx0, mempty) + PrettyField (pos, fieldName) fieldLines -> + let ctx' :: PrettyFieldPositionContext + fieldLines' :: ExactDoc + (ctx', fieldLines') = + exactRenderPrettyFieldLines (Just field, lastFieldLine) fieldLines + + fieldNamePosition :: Position + fieldNamePosition = pos + + fieldLinesFirstPos :: Position + fieldLinesFirstPos = fst fieldLines + + -- The fieldLines are all patched and we only need to concat them together + fieldLinesFinal :: ExactDoc + fieldLinesFinal = placeAt fieldLinesFirstPos $ fieldLines' + + lastPosition :: Maybe Position + lastPosition = fst <$> lastFieldLine <|> (prettyFieldPosition =<< lastField) + + isFirst = lastField == Nothing && lastFieldLine == Nothing + + docOut :: ExactDoc + docOut = placeAt fieldNamePosition $ + EPP.text (T.pack $ fromUTF8BS fieldName <> ":") <> fieldLinesFinal + in (ctx', docOut) + PrettySection (pos, fieldName) sectionArgs fields -> + let ctx' :: PrettyFieldPositionContext + fields' :: [ExactDoc] + (ctx', fields') = exactRenderPrettyFields (Just field, lastFieldLine) fields + + sectionNamePosition :: Maybe Position + sectionNamePosition = prettySectionPosition field + + lastPosition :: Maybe Position + lastPosition = fst <$> lastFieldLine <|> (prettyFieldPosition =<< lastField) + + fieldsFirstPosition :: Maybe Position + fieldsFirstPosition = prettyFieldPosition <=< safeHead $ fields + + guessedIndentation :: Int + guessedIndentation = fromMaybe 4 $ subtract 1 . positionCol <$> fieldsFirstPosition + + -- TODO(leana8959): section args are currently not exactly positioned + fieldsFinal :: ExactDoc + fieldsFinal = + maybe id placeAt fieldsFirstPosition $ + mconcat fields' + + isFirst = lastField == Nothing && lastFieldLine == Nothing + + docOut :: ExactDoc + docOut = + maybe id placeAt sectionNamePosition $ + EPP.text (T.pack $ fromUTF8BS fieldName) + <> mconcat (map docToExactDoc sectionArgs) + <> EPP.nest guessedIndentation fieldsFinal + in ( ctx' + , docOut + ) + +-- | Post condition: fieldlines are sorted in ascending order +-- exactRenderPrettyFieldLines +-- :: PrettyFieldPositionContext +-- -> (Position, Doc) +-- -> (PrettyFieldPositionContext, [ExactDoc]) +-- exactRenderPrettyFieldLines ctx0 = fmap reverse . foldl go state0 +-- where +-- state0 :: (PrettyFieldPositionContext, [ExactDoc]) +-- state0 = (ctx0, []) +-- +-- go (ctx, processed) fieldLine = +-- let (ctx', fieldLine') = exactRenderPrettyFieldLine ctx fieldLine +-- in (ctx', fieldLine' : processed) + +exactRenderPrettyFieldLines + :: PrettyFieldPositionContext + -> (Position, Doc) + -> (PrettyFieldPositionContext, ExactDoc) +exactRenderPrettyFieldLines (lastField, lastFieldLine) fieldLine@(_, doc) = + let lastPosition :: Maybe Position + lastPosition = liftA2 max (fst <$> lastFieldLine) (prettyFieldPosition =<< lastField) + + fieldLinePosition :: Position + fieldLinePosition = fst fieldLine + + ctx' :: PrettyFieldPositionContext + ctx' = (lastField, Just fieldLine) + + fieldLine' :: ExactDoc + fieldLine' = placeAt fieldLinePosition $ docToExactDoc doc + in (ctx', fieldLine') + +sortPrettyFields :: [PrettyFieldWith Mod.HasAnn] -> [PrettyFieldWith Mod.HasAnn] +sortPrettyFields = List.sortOn $ fromMaybe zeroPos . prettyFieldPosition + +-- sortPrettyFieldLines :: [(Position, Doc)] -> [(Position, Doc)] +-- sortPrettyFieldLines = List.sortOn (fromMaybe zeroPos . fst) + +docToExactDoc :: PP.Doc -> ExactDoc +docToExactDoc = EPP.multilineText . T.lines . T.pack . PP.renderStyle PP.style diff --git a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs index 350b9fee757..d1273b90032 100644 --- a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs +++ b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs @@ -100,7 +100,7 @@ parseInstalledPackageInfo parseInstalledPackageInfo s = case P.readFields s of Left err -> Left (show err :| []) Right fs -> case partitionFields fs of - (fs', _) -> case P.runParseResult $ withSource PInstalledPackageInfo $ parseFieldGrammar cabalSpecLatest fs' ipiFieldGrammar of + (fs', _) -> case P.runParseResult $ withSource PInstalledPackageInfo $ parseFieldGrammar cabalSpecLatest Nothing fs' ipiFieldGrammar of (ws, Right x) -> x `deepseq` Right (ws', x) where ws' = @@ -125,7 +125,7 @@ showInstalledPackageInfo ipi = -- | The variant of 'showInstalledPackageInfo' which outputs @pkgroot@ field too. showFullInstalledPackageInfo :: InstalledPackageInfo -> String -showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar +showFullInstalledPackageInfo = P.showFields (const NoComment) . prettyFieldGrammar cabalSpecLatest ipiFieldGrammar Nothing -- | -- diff --git a/Cabal-syntax/src/Distribution/Package.hs b/Cabal-syntax/src/Distribution/Package.hs index 9a6be33a95e..d26c65e968f 100644 --- a/Cabal-syntax/src/Distribution/Package.hs +++ b/Cabal-syntax/src/Distribution/Package.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- | diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs index cc6df0801e3..513e1ae501d 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs @@ -1,4 +1,8 @@ -- -Wno-deprecations for use of Map.foldWithKey +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} ----------------------------------------------------------------------------- @@ -58,6 +62,7 @@ import Distribution.Types.ComponentRequestedSpec import Distribution.Types.DependencyMap import Distribution.Types.DependencySatisfaction (DependencySatisfaction (..)) import Distribution.Types.MissingDependency (MissingDependency (..)) +import qualified Distribution.Types.Modify as Mod import Distribution.Types.PackageVersionConstraint import Distribution.Utils.Generic import Distribution.Utils.Path (sameDirectory) @@ -410,7 +415,7 @@ instance Semigroup PDTagged where SubComp n x <> SubComp n' x' | n == n' = SubComp n (x <> x') _ <> _ = cabalBug "Cannot combine incompatible tags" -instance L.HasBuildInfo PDTagged where +instance L.HasBuildInfoWith Mod.HasNoAnn PDTagged where buildInfo f x = case x of Lib lib -> Lib <$> L.buildInfo f lib SubComp name comp -> SubComp name <$> L.buildInfo f comp @@ -659,7 +664,7 @@ transformAllBuildDepends -> GenericPackageDescription -> GenericPackageDescription transformAllBuildDepends f = - over (L.traverseBuildInfos . L.targetBuildDepends . traverse) f + over (L.traverseBuildInfos @Mod.HasNoAnn . L.targetBuildDepends @Mod.HasNoAnn . traverse) f . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends . traverse) f -- | Walk a 'GenericPackageDescription' and apply @f@ to all nested @@ -669,5 +674,5 @@ transformAllBuildDependsN -> GenericPackageDescription -> GenericPackageDescription transformAllBuildDependsN f = - over (L.traverseBuildInfos . L.targetBuildDepends) f + over (L.traverseBuildInfos @Mod.HasNoAnn . L.targetBuildDepends @Mod.HasNoAnn) f . over (L.packageDescription . L.setupBuildInfo . traverse . L.setupDepends) f diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 24861389b8f..b8e571a5eba 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,9 +1,18 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- | 'GenericPackageDescription' Field descriptions module Distribution.PackageDescription.FieldGrammar @@ -22,7 +31,8 @@ module Distribution.PackageDescription.FieldGrammar , executableFieldGrammar -- * Test suite - , TestSuiteStanza (..) + , TestSuiteStanza + , TestSuiteStanzaWith (..) , testSuiteFieldGrammar , validateTestSuite , unvalidateTestSuite @@ -34,7 +44,8 @@ module Distribution.PackageDescription.FieldGrammar , testStanzaBuildInfo -- * Benchmark - , BenchmarkStanza (..) + , BenchmarkStanza + , BenchmarkStanzaWith (..) , benchmarkFieldGrammar , validateBenchmark , unvalidateBenchmark @@ -65,6 +76,9 @@ module Distribution.PackageDescription.FieldGrammar -- * Component build info , buildInfoFieldGrammar + , MiniBuildInfo (..) + , miniBuildInfoFieldGrammar + , BuildInfoConstraint ) where import Distribution.Compat.Lens @@ -85,6 +99,10 @@ import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) +import Distribution.Trivia +import Distribution.Types.Modify (Annotate, AttachPositions, AttachPosition, PreserveGrouping) +import qualified Distribution.Types.Modify as Mod + import qualified Data.ByteString.Char8 as BS8 import qualified Distribution.Compat.CharParsing as P import qualified Distribution.SPDX as SPDX @@ -95,9 +113,10 @@ import qualified Distribution.Types.Lens as L ------------------------------------------------------------------------------- packageDescriptionFieldGrammar - :: ( FieldGrammar c g - , Applicative (g PackageDescription) - , Applicative (g PackageIdentifier) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (PackageDescriptionWith mod)) + , Applicative (g mod (PackageIdentifierWith mod)) , c (Identity BuildType) , c (Identity PackageName) , c (Identity Version) @@ -107,10 +126,10 @@ packageDescriptionFieldGrammar , c CompatLicenseFile , c CompatDataDir ) - => g PackageDescription PackageDescription + => g mod (PackageDescriptionWith mod) (PackageDescriptionWith mod) packageDescriptionFieldGrammar = PackageDescription - <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 + <$> optionalFieldDefAla' "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 <*> blurFieldGrammar L.package packageIdentifierGrammar <*> optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE) <*> licenseFilesGrammar @@ -148,8 +167,8 @@ packageDescriptionFieldGrammar = where packageIdentifierGrammar = PackageIdentifier - <$> uniqueField "name" L.pkgName - <*> uniqueField "version" L.pkgVersion + <$> uniqueField' @mod @c @g @_ @PackageName "name" (L.pkgName @mod) + <*> uniqueField' @mod @c @g @_ @Version "version" L.pkgVersion licenseFilesGrammar = (++) @@ -165,14 +184,57 @@ packageDescriptionFieldGrammar = ------------------------------------------------------------------------------- libraryFieldGrammar - :: ( FieldGrammar c g - , Applicative (g Library) - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (LibraryWith mod)) + , Applicative (g mod (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + + +-- new bounds + , Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) +--- + + , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) , c (List CommaVCat (Identity Mixin) Mixin) , c (List CommaVCat (Identity ModuleReexport) ModuleReexport) , c (List FSep (MQuoted Extension) Extension) @@ -187,16 +249,16 @@ libraryFieldGrammar , c (MQuoted Language) ) => LibraryName - -> g Library Library + -> g mod (LibraryWith mod) (LibraryWith mod) libraryFieldGrammar n = Library n <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules <*> monoidalFieldAla "reexported-modules" (alaList CommaVCat) L.reexportedModules <*> monoidalFieldAla "signatures" (alaList' VCat MQuoted) L.signatures ^^^ availableSince CabalSpecV2_0 [] - <*> booleanFieldDef "exposed" L.libExposed True + <*> booleanFieldDef' "exposed" L.libExposed True <*> visibilityField - <*> blurFieldGrammar L.libBuildInfo buildInfoFieldGrammar + <*> blurFieldGrammar L.libBuildInfo (buildInfoFieldGrammar @mod) where visibilityField = case n of -- nameless/"main" libraries are public @@ -205,17 +267,62 @@ libraryFieldGrammar n = LSubLibName _ -> optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' Library #-} -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' Library #-} + +-- {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' LibraryAnn #-} +-- {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' LibraryAnn #-} ------------------------------------------------------------------------------- -- Foreign library ------------------------------------------------------------------------------- foreignLibFieldGrammar - :: ( FieldGrammar c g - , Applicative (g ForeignLib) - , Applicative (g BuildInfo) + :: forall (mod :: Mod.HasAnnotation) c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (ForeignLibWith mod)) + , Applicative (g mod (BuildInfoWith mod)) + + , L.HasBuildInfoWith mod (BuildInfoWith mod) + +-- new bounds + + , Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + +-- + , c (Identity ForeignLibType) , c (Identity LibVersionInfo) , c (Identity Version) @@ -237,26 +344,73 @@ foreignLibFieldGrammar , c (MQuoted Language) ) => UnqualComponentName - -> g ForeignLib ForeignLib + -> g mod (ForeignLibWith mod) (ForeignLibWith mod) foreignLibFieldGrammar n = ForeignLib n <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown <*> monoidalFieldAla "options" (alaList FSep) L.foreignLibOptions - <*> blurFieldGrammar L.foreignLibBuildInfo buildInfoFieldGrammar + <*> blurFieldGrammar (L.foreignLibBuildInfo @mod) (buildInfoFieldGrammar @mod) <*> optionalField "lib-version-info" L.foreignLibVersionInfo <*> optionalField "lib-version-linux" L.foreignLibVersionLinux <*> monoidalFieldAla "mod-def-file" (alaList' FSep RelativePathNT) L.foreignLibModDefFile -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} -{-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} +-- {-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' ForeignLib #-} +-- {-# SPECIALIZE foreignLibFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' ForeignLib #-} ------------------------------------------------------------------------------- -- Executable ------------------------------------------------------------------------------- executableFieldGrammar - :: ( FieldGrammar c g - , Applicative (g Executable) - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (ExecutableWith mod)) + , Applicative (g mod (BuildInfoWith mod)) + + , Monoid (ExecutableWith mod) + + , L.HasBuildInfoWith mod (ExecutableWith mod) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + +-- new bounds + + , Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + +-- + , c (Identity ExecutableScope) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -279,14 +433,14 @@ executableFieldGrammar , c (MQuoted Language) ) => UnqualComponentName - -> g Executable Executable + -> g mod (ExecutableWith mod) (ExecutableWith mod) executableFieldGrammar n = Executable n -- main-is is optional as conditional blocks don't have it - <$> optionalFieldDefAla "main-is" RelativePathNT L.modulePath (modulePath mempty) + <$> optionalFieldDefAla "main-is" RelativePathNT L.modulePath (unsafeMakeSymbolicPath "") <*> optionalFieldDef "scope" L.exeScope ExecutablePublic ^^^ availableSince CabalSpecV2_0 ExecutablePublic - <*> blurFieldGrammar L.buildInfo buildInfoFieldGrammar + <*> blurFieldGrammar (L.buildInfo @mod) (buildInfoFieldGrammar @mod) {-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> ParsecFieldGrammar' Executable #-} {-# SPECIALIZE executableFieldGrammar :: UnqualComponentName -> PrettyFieldGrammar' Executable #-} @@ -294,43 +448,86 @@ executableFieldGrammar n = -- TestSuite ------------------------------------------------------------------------------- +type TestSuiteStanza = TestSuiteStanzaWith Mod.HasNoAnn + -- | An intermediate type just used for parsing the test-suite stanza. -- After validation it is converted into the proper 'TestSuite' type. -data TestSuiteStanza = TestSuiteStanza +data TestSuiteStanzaWith (mod :: Mod.HasAnnotation) = TestSuiteStanza { _testStanzaTestType :: Maybe TestType , _testStanzaMainIs :: Maybe (RelativePath Source File) , _testStanzaTestModule :: Maybe ModuleName - , _testStanzaBuildInfo :: BuildInfo + , _testStanzaBuildInfo :: BuildInfoWith mod , _testStanzaCodeGenerators :: [String] } -instance L.HasBuildInfo TestSuiteStanza where - buildInfo = testStanzaBuildInfo - -testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) +testStanzaTestType :: Lens' (TestSuiteStanzaWith mod) (Maybe TestType) testStanzaTestType f s = fmap (\x -> s{_testStanzaTestType = x}) (f (_testStanzaTestType s)) {-# INLINE testStanzaTestType #-} -testStanzaMainIs :: Lens' TestSuiteStanza (Maybe (RelativePath Source File)) +testStanzaMainIs :: Lens' (TestSuiteStanzaWith mod) (Maybe (RelativePath Source File)) testStanzaMainIs f s = fmap (\x -> s{_testStanzaMainIs = x}) (f (_testStanzaMainIs s)) {-# INLINE testStanzaMainIs #-} -testStanzaTestModule :: Lens' TestSuiteStanza (Maybe ModuleName) +testStanzaTestModule :: Lens' (TestSuiteStanzaWith mod) (Maybe ModuleName) testStanzaTestModule f s = fmap (\x -> s{_testStanzaTestModule = x}) (f (_testStanzaTestModule s)) {-# INLINE testStanzaTestModule #-} -testStanzaBuildInfo :: Lens' TestSuiteStanza BuildInfo +testStanzaBuildInfo :: Lens' (TestSuiteStanzaWith mod) (BuildInfoWith mod) testStanzaBuildInfo f s = fmap (\x -> s{_testStanzaBuildInfo = x}) (f (_testStanzaBuildInfo s)) {-# INLINE testStanzaBuildInfo #-} -testStanzaCodeGenerators :: Lens' TestSuiteStanza [String] +testStanzaCodeGenerators :: Lens' (TestSuiteStanzaWith mod) [String] testStanzaCodeGenerators f s = fmap (\x -> s{_testStanzaCodeGenerators = x}) (f (_testStanzaCodeGenerators s)) {-# INLINE testStanzaCodeGenerators #-} testSuiteFieldGrammar - :: ( FieldGrammar c g - , Applicative (g TestSuiteStanza) - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (TestSuiteStanzaWith mod)) + , Applicative (g mod (BuildInfoWith mod)) + + , L.HasBuildInfoWith mod (BuildInfoWith mod) + +-- new bounds + + , Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + +-- + , c (Identity ModuleName) , c (Identity TestType) , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -351,16 +548,17 @@ testSuiteFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g TestSuiteStanza TestSuiteStanza + => g mod (TestSuiteStanzaWith mod) (TestSuiteStanzaWith mod) testSuiteFieldGrammar = TestSuiteStanza <$> optionalField "type" testStanzaTestType <*> optionalFieldAla "main-is" RelativePathNT testStanzaMainIs <*> optionalField "test-module" testStanzaTestModule - <*> blurFieldGrammar testStanzaBuildInfo buildInfoFieldGrammar + <*> blurFieldGrammar testStanzaBuildInfo (buildInfoFieldGrammar @mod) <*> monoidalFieldAla "code-generators" (alaList' CommaFSep Token) testStanzaCodeGenerators ^^^ availableSince CabalSpecV3_8 [] +-- validateTestSuite :: CabalSpecVersion -> Position -> TestSuiteStanzaWith Mod.HasAnn -> ParseResult src (TestSuiteWith Mod.HasAnn) validateTestSuite :: CabalSpecVersion -> Position -> TestSuiteStanza -> ParseResult src TestSuite validateTestSuite cabalSpecVersion pos stanza = case testSuiteType of Nothing -> pure basicTestSuite @@ -444,38 +642,82 @@ unvalidateTestSuite t = -- Benchmark ------------------------------------------------------------------------------- +type BenchmarkStanza = BenchmarkStanzaWith Mod.HasNoAnn + -- | An intermediate type just used for parsing the benchmark stanza. -- After validation it is converted into the proper 'Benchmark' type. -data BenchmarkStanza = BenchmarkStanza +data BenchmarkStanzaWith (mod :: Mod.HasAnnotation) = BenchmarkStanza { _benchmarkStanzaBenchmarkType :: Maybe BenchmarkType , _benchmarkStanzaMainIs :: Maybe (RelativePath Source File) , _benchmarkStanzaBenchmarkModule :: Maybe ModuleName - , _benchmarkStanzaBuildInfo :: BuildInfo + , _benchmarkStanzaBuildInfo :: BuildInfoWith mod } -instance L.HasBuildInfo BenchmarkStanza where - buildInfo = benchmarkStanzaBuildInfo - -benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) +benchmarkStanzaBenchmarkType :: Lens' (BenchmarkStanzaWith mod) (Maybe BenchmarkType) benchmarkStanzaBenchmarkType f s = fmap (\x -> s{_benchmarkStanzaBenchmarkType = x}) (f (_benchmarkStanzaBenchmarkType s)) {-# INLINE benchmarkStanzaBenchmarkType #-} -benchmarkStanzaMainIs :: Lens' BenchmarkStanza (Maybe (RelativePath Source File)) +benchmarkStanzaMainIs :: Lens' (BenchmarkStanzaWith mod) (Maybe (RelativePath Source File)) benchmarkStanzaMainIs f s = fmap (\x -> s{_benchmarkStanzaMainIs = x}) (f (_benchmarkStanzaMainIs s)) {-# INLINE benchmarkStanzaMainIs #-} -benchmarkStanzaBenchmarkModule :: Lens' BenchmarkStanza (Maybe ModuleName) +benchmarkStanzaBenchmarkModule :: Lens' (BenchmarkStanzaWith mod) (Maybe ModuleName) benchmarkStanzaBenchmarkModule f s = fmap (\x -> s{_benchmarkStanzaBenchmarkModule = x}) (f (_benchmarkStanzaBenchmarkModule s)) {-# INLINE benchmarkStanzaBenchmarkModule #-} -benchmarkStanzaBuildInfo :: Lens' BenchmarkStanza BuildInfo +benchmarkStanzaBuildInfo :: Lens' (BenchmarkStanzaWith mod) (BuildInfoWith mod) benchmarkStanzaBuildInfo f s = fmap (\x -> s{_benchmarkStanzaBuildInfo = x}) (f (_benchmarkStanzaBuildInfo s)) {-# INLINE benchmarkStanzaBuildInfo #-} benchmarkFieldGrammar - :: ( FieldGrammar c g - , Applicative (g BenchmarkStanza) - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BenchmarkStanzaWith mod)) + , Applicative (g mod (BuildInfoWith mod)) + + , L.HasBuildInfoWith mod (BuildInfoWith mod) + +-- new bounds + + , Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + + +-- + , c (Identity BenchmarkType) , c (Identity ModuleName) , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -495,7 +737,7 @@ benchmarkFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g BenchmarkStanza BenchmarkStanza + => g mod (BenchmarkStanzaWith mod) (BenchmarkStanzaWith mod) benchmarkFieldGrammar = BenchmarkStanza <$> optionalField "type" benchmarkStanzaBenchmarkType @@ -577,13 +819,19 @@ unvalidateBenchmark b = -- Build info ------------------------------------------------------------------------------- +{- + buildInfoFieldGrammar - :: ( FieldGrammar c g - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , -- TODO(leana8959): use legacy for now, not completely polymorphic + mod ~ Mod.HasNoAnn , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (List CommaVCat (Identity Dependency) Dependency) + , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) , c (List CommaVCat (Identity Mixin) Mixin) , c (List FSep (MQuoted Extension) Extension) , c (List FSep (MQuoted Language) Language) @@ -596,7 +844,7 @@ buildInfoFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g BuildInfo BuildInfo + => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar = BuildInfo <$> booleanFieldDef "buildable" L.buildable True @@ -638,7 +886,7 @@ buildInfoFieldGrammar = ^^^ availableSince CabalSpecV2_2 [] <*> monoidalFieldAla "js-sources" (alaList' VCat SymbolicPathNT) L.jsSources <*> hsSourceDirsGrammar - <*> monoidalFieldAla "other-modules" formatOtherModules L.otherModules + <*> monoidalFieldAla "other-modules" (formatOtherModules @Mod.HasNoAnn) L.otherModules <*> monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules ^^^ availableSince CabalSpecV2_2 [] <*> monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules @@ -680,33 +928,263 @@ buildInfoFieldGrammar = <*> profSharedOptionsFieldGrammar <*> pure mempty -- static-options ??? <*> prefixedFields "x-" L.customFieldsBI - <*> monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends + <*> monoidalFieldAla "build-depends" (formatDependencyList @mod) L.targetBuildDepends <*> monoidalFieldAla "mixins" formatMixinList L.mixins ^^^ availableSince CabalSpecV2_0 [] -{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfo #-} -{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfo #-} -hsSourceDirsGrammar - :: ( FieldGrammar c g - , Applicative (g BuildInfo) +-- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} +-- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} + +-} + + +type BuildInfoConstraint (mod :: Mod.HasAnnotation) c = + ( Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , c (List VCat (MQuoted ModuleName) ModuleName) + + , c (MQuoted Language) + + , c (List FSep (MQuoted Language) Language) + + , c (List FSep (MQuoted Extension) Extension) + + , c (List VCat Token String) + + , c (List FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (List FSep (SymbolicPathNT Pkg (Dir Lib)) (SymbolicPath Pkg (Dir Lib))) + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (List FSep (SymbolicPathNT Pkg (Dir Include)) (SymbolicPath Pkg (Dir Include))) + , c (List FSep (SymbolicPathNT Include File) (SymbolicPath Include File)) + , c (List FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (List FSep (RelativePathNT Include File) (RelativePath Include File)) + + , c (List NoCommaFSep Token' String) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + + , c (List CommaVCat (Identity Mixin) Mixin) + ) + +buildInfoFieldGrammar + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + + , L.HasBuildInfoWith mod (BuildInfoWith mod) + + , Newtype [AttachPosition mod (Annotate mod LegacyExeDependency)] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + + , Newtype [AttachPosition mod (Annotate mod ExeDependency)] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + + , Newtype [AttachPosition mod (Annotate mod String)] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + , Newtype [AttachPosition mod (Annotate mod PkgconfigDependency)] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + , Newtype [AttachPosition mod (Annotate mod (RelativePath Framework File))] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) + + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + , Newtype [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , c (List VCat (MQuoted ModuleName) ModuleName) + + , c (MQuoted Language) + + , c (List FSep (MQuoted Language) Language) + + , c (List FSep (MQuoted Extension) Extension) + + , c (List VCat Token String) + , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to)) + , forall from to. c (List FSep (RelativePathNT from to) (RelativePath from to)) + + , c (List NoCommaFSep Token' String) + + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + + , c (List CommaVCat (Identity Mixin) Mixin) + ) + => g mod (BuildInfoWith mod) (BuildInfoWith mod) +buildInfoFieldGrammar = do + buildable <- booleanFieldDef' "buildable" L.buildable True + buildTools <- monoidalFieldAla' "build-tools" (alaListWith @mod @CommaFSep @LegacyExeDependency) L.buildTools + buildToolDepends <- monoidalFieldAla' "build-tool-depends" (alaListWith @mod @CommaFSep @ExeDependency) L.buildToolDepends + cppOptions <- monoidalFieldAla' "cpp-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.cppOptions + asmOptions <- monoidalFieldAla' "asm-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.asmOptions + cmmOptions <- monoidalFieldAla' "cmm-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.cmmOptions + ccOptions <- monoidalFieldAla' "cc-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.ccOptions + cxxOptions <- monoidalFieldAla' "cxx-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.cxxOptions + jsppOptions <- monoidalFieldAla' "jspp-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.jsppOptions + ldOptions <- monoidalFieldAla' "ld-options" (alaListWith' @mod @NoCommaFSep @Token' @String) L.ldOptions + hsc2hsOptions <- monoidalFieldAla' "hsc2hsOptions" (alaListWith' @mod @NoCommaFSep @Token' @String) L.hsc2hsOptions + pkgconfigDepends <- monoidalFieldAla' "pkgconfig-depends" (alaListWith @mod @CommaFSep @PkgconfigDependency) L.pkgconfigDepends + frameworks <- monoidalFieldAla' "frameworks" (alaListWith' @mod @FSep @(RelativePathNT Framework File) @(RelativePath Framework File)) L.frameworks + extraFrameworkDirs <- monoidalFieldAla' "extra-framework-dirs" (alaListWith' @mod @FSep @(SymbolicPathNT Pkg (Dir Framework)) @(SymbolicPath Pkg (Dir Framework))) L.extraFrameworkDirs + asmSources <- monoidalFieldAla' "asm-sources" (alaListWith' @mod @VCat @(SymbolicPathNT Pkg File) @(SymbolicPath Pkg File)) L.asmSources + cmmSources <- monoidalFieldAla' "cmm-sources" (alaListWith' @mod @VCat @(SymbolicPathNT Pkg File) @(SymbolicPath Pkg File)) L.cmmSources + cSources <- monoidalFieldAla' "c-sources" (alaListWith' @mod @VCat @(SymbolicPathNT Pkg File) @(SymbolicPath Pkg File)) L.cSources + cxxSources <- monoidalFieldAla' "cxx-sources" (alaListWith' @mod @VCat @(SymbolicPathNT Pkg File) @(SymbolicPath Pkg File)) L.cxxSources + jsSources <- monoidalFieldAla' "js-sources" (alaListWith' @mod @VCat @(SymbolicPathNT Pkg File) @(SymbolicPath Pkg File)) L.jsSources + hsSourceDirs <- hsSourceDirsGrammar @mod + otherModules <- monoidalFieldAla' "other-modules" (formatOtherModules @mod) L.otherModules + + -- This section uses legacy monoidalFieldAla and doesn't handle trivia + virtualModules <- monoidalFieldAla "virtual-modules" (alaList' VCat MQuoted) L.virtualModules + autogenModules <- monoidalFieldAla "autogen-modules" (alaList' VCat MQuoted) L.autogenModules + defaultLanguage <- optionalFieldAla "default-language" MQuoted L.defaultLanguage + otherLanguages <- monoidalFieldAla "other-languages" (alaList' FSep MQuoted) L.otherLanguages + defaultExtensions <- monoidalFieldAla "default-extensions" (alaList' FSep MQuoted) L.defaultExtensions + otherExtensions <- monoidalFieldAla "other-extensions" formatOtherExtensions L.otherExtensions + oldExtensions <- monoidalFieldAla "extensions" (alaList' FSep MQuoted) L.oldExtensions + extraLibs <- monoidalFieldAla "extra-libraries" (alaList' VCat Token) L.extraLibs + extraLibsStatic <- monoidalFieldAla "extra-libraries-static" (alaList' VCat Token) L.extraLibsStatic + extraGHCiLibs <- monoidalFieldAla "extra-ghci-libraries" (alaList' VCat Token) L.extraGHCiLibs + extraBundledLibs <- monoidalFieldAla "extra-bundled-libraries" (alaList' VCat Token) L.extraBundledLibs + extraLibFlavours <- monoidalFieldAla "extra-library-flavours" (alaList' VCat Token) L.extraLibFlavours + extraDynLibFlavours <- monoidalFieldAla "extra-dynamic-library-flavours" (alaList' VCat Token) L.extraDynLibFlavours + extraLibDirs <- monoidalFieldAla "extra-lib-dirs" (alaList' FSep SymbolicPathNT) L.extraLibDirs + extraLibDirsStatic <- monoidalFieldAla "extra-lib-dirs-static" (alaList' FSep SymbolicPathNT) L.extraLibDirsStatic + includeDirs <- monoidalFieldAla "include-dirs" (alaList' FSep SymbolicPathNT) L.includeDirs + includes <- monoidalFieldAla "includes" (alaList' FSep SymbolicPathNT) L.includes + autogenIncludes <- monoidalFieldAla "autogen-includes" (alaList' FSep RelativePathNT) L.autogenIncludes + installIncludes <- monoidalFieldAla "install-includes" (alaList' FSep RelativePathNT) L.installIncludes + options <- optionsFieldGrammar + profOptions <- profOptionsFieldGrammar + sharedOptions <- sharedOptionsFieldGrammar + profSharedOptions <- profSharedOptionsFieldGrammar + let staticOptions = mempty + customFieldsBI <- prefixedFields "x-" L.customFieldsBI + + targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends + + mixins <- monoidalFieldAla "mixins" formatMixinList L.mixins + + pure (BuildInfo{..}) + +-- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasAnn BuildInfoAnn BuildInfoAnn #-} +-- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasNoAnn BuildInfo BuildInfo #-} +-- {-# SPECIALIZE buildInfoFieldGrammar' :: PrettyFieldGrammar Mod.HasAnn BuildInfoAnn BuildInfoAnn #-} +-- {-# SPECIALIZE buildInfoFieldGrammar' :: PrettyFieldGrammar Mod.HasNoAnn BuildInfo BuildInfo #-} + +data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo + { miniTargetBuildDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (DependencyWith m))]) + } + +deriving instance Show (MiniBuildInfo Mod.HasAnn) +deriving instance Show (MiniBuildInfo Mod.HasNoAnn) + +miniTargetBuildDependsLens + :: forall mod f + . Functor f + => (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (DependencyWith mod))]) -> f (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (DependencyWith mod))]))) + -> MiniBuildInfo mod + -> f (MiniBuildInfo mod) +miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) + +miniBuildInfoFieldGrammar + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (MiniBuildInfo mod)) + , Newtype + [AttachPosition mod (Annotate mod (DependencyWith mod))] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) - => g BuildInfo [SymbolicPath Pkg (Dir Source)] + => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) +miniBuildInfoFieldGrammar = + MiniBuildInfo + <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens + +hsSourceDirsGrammar + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , -- is a monoid with or without annotation + Monoid + (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + + , Newtype + [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))] + (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + ) + => g mod (BuildInfoWith mod) (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) hsSourceDirsGrammar = - (++) - <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs - <*> monoidalFieldAla "hs-source-dir" (alaList' FSep SymbolicPathNT) wrongLens + (<>) + <$> monoidalFieldAla' "hs-source-dirs" (alaListWith' @mod @FSep @(SymbolicPathNT Pkg (Dir Source)) @(SymbolicPath Pkg (Dir Source))) L.hsSourceDirs + <*> monoidalFieldAla' "hs-source-dir" (alaListWith' @mod @FSep @(SymbolicPathNT Pkg (Dir Source)) @(SymbolicPath Pkg (Dir Source))) wrongLens --- https://github.com/haskell/cabal/commit/49e3cdae3bdf21b017ccd42e66670ca402e22b44 ^^^ deprecatedSince CabalSpecV1_2 "Please use 'hs-source-dirs'" ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." where - -- TODO: make pretty printer aware of CabalSpecVersion - wrongLens :: Functor f => LensLike' f BuildInfo [SymbolicPath Pkg (Dir Source)] - wrongLens f bi = (\fps -> set L.hsSourceDirs fps bi) <$> f [] + wrongLens f bi = (\fps -> set (L.hsSourceDirs @mod) fps bi) <$> f mempty + +-- {-# SPECIALIZE hsSourceDirsGrammar :: ParsecFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} +-- {-# SPECIALIZE hsSourceDirsGrammar :: PrettyFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} optionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) optionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -718,34 +1196,52 @@ optionsFieldGrammar = <* knownField "hugs-options" <* knownField "nhc98-options" where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.options . lookupLens flavor + extract flavor = L.options @mod . lookupLens flavor + +-- {-# SPECIALIZE optionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} +-- {-# SPECIALIZE optionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} profOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) profOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profOptions . lookupLens flavor + extract flavor = L.profOptions @mod . lookupLens flavor + +-- {-# SPECIALIZE profOptionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} +-- {-# SPECIALIZE profOptionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} sharedOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) sharedOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) <*> monoidalFieldAla "ghcjs-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.sharedOptions . lookupLens flavor + extract flavor = L.sharedOptions @mod . lookupLens flavor profSharedOptionsFieldGrammar - :: (FieldGrammar c g, Applicative (g BuildInfo), c (List NoCommaFSep Token' String)) - => g BuildInfo (PerCompilerFlavor [String]) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) profSharedOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-prof-shared-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -753,8 +1249,7 @@ profSharedOptionsFieldGrammar = <*> monoidalFieldAla "ghcjs-prof-shared-options" (alaList' NoCommaFSep Token') (extract GHCJS) ^^^ availableSince CabalSpecV3_14 [] where - extract :: CompilerFlavor -> ALens' BuildInfo [String] - extract flavor = L.profSharedOptions . lookupLens flavor + extract flavor = L.profSharedOptions @mod . lookupLens flavor lookupLens :: (Functor f, Monoid v) => CompilerFlavor -> LensLike' f (PerCompilerFlavor v) v lookupLens k f p@(PerCompilerFlavor ghc ghcjs) @@ -767,25 +1262,26 @@ lookupLens k f p@(PerCompilerFlavor ghc ghcjs) ------------------------------------------------------------------------------- flagFieldGrammar - :: (FieldGrammar c g, Applicative (g PackageFlag)) + :: (FieldGrammarWith mod c g, Applicative (g mod PackageFlag)) => FlagName - -> g PackageFlag PackageFlag + -> g mod PackageFlag PackageFlag flagFieldGrammar name = MkPackageFlag name <$> freeTextFieldDef "description" L.flagDescription <*> booleanFieldDef "default" L.flagDefault True <*> booleanFieldDef "manual" L.flagManual False -{-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} -{-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} + +-- {-# SPECIALIZE flagFieldGrammar :: FlagName -> ParsecFieldGrammar' PackageFlag #-} +-- {-# SPECIALIZE flagFieldGrammar :: FlagName -> PrettyFieldGrammar' PackageFlag #-} ------------------------------------------------------------------------------- -- SourceRepo ------------------------------------------------------------------------------- sourceRepoFieldGrammar - :: (FieldGrammar c g, Applicative (g SourceRepo), c (Identity RepoType), c Token, c FilePathNT) + :: (FieldGrammarWith mod c g, Applicative (g mod SourceRepo), c (Identity RepoType), c Token, c FilePathNT) => RepoKind - -> g SourceRepo SourceRepo + -> g mod SourceRepo SourceRepo sourceRepoFieldGrammar kind = SourceRepo kind <$> optionalField "type" L.repoType @@ -794,29 +1290,31 @@ sourceRepoFieldGrammar kind = <*> optionalFieldAla "branch" Token L.repoBranch <*> optionalFieldAla "tag" Token L.repoTag <*> optionalFieldAla "subdir" FilePathNT L.repoSubdir -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} -{-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} + +-- {-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> ParsecFieldGrammar' SourceRepo #-} +-- {-# SPECIALIZE sourceRepoFieldGrammar :: RepoKind -> PrettyFieldGrammar' SourceRepo #-} ------------------------------------------------------------------------------- -- SetupBuildInfo ------------------------------------------------------------------------------- setupBInfoFieldGrammar - :: (FieldGrammar c g, Functor (g SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) + :: (FieldGrammarWith mod c g, Functor (g mod SetupBuildInfo), c (List CommaVCat (Identity Dependency) Dependency)) => Bool - -> g SetupBuildInfo SetupBuildInfo + -> g mod SetupBuildInfo SetupBuildInfo setupBInfoFieldGrammar def = flip SetupBuildInfo def <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} -{-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} + +-- {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} +-- {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} ------------------------------------------------------------------------------- -- Define how field values should be formatted for 'pretty'. ------------------------------------------------------------------------------- -formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency -formatDependencyList = alaList CommaVCat +formatDependencyList :: [AttachPosition mod (Annotate mod (DependencyWith mod))] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) +formatDependencyList = List formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat @@ -833,8 +1331,8 @@ formatHsSourceDirs = alaList' FSep SymbolicPathNT formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension formatOtherExtensions = alaList' FSep MQuoted -formatOtherModules :: [ModuleName] -> List VCat (MQuoted ModuleName) ModuleName -formatOtherModules = alaList' VCat MQuoted +formatOtherModules :: [AttachPosition mod (Annotate mod ModuleName)] -> ListWith mod VCat (MQuoted ModuleName) ModuleName +formatOtherModules = List ------------------------------------------------------------------------------- -- newtypes @@ -896,15 +1394,15 @@ _syntaxFieldNames = nub $ sort $ mconcat - [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar - , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName - , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" - , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" - , fieldGrammarKnownFieldList testSuiteFieldGrammar - , fieldGrammarKnownFieldList benchmarkFieldGrammar - , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") - , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") - , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True + [ fieldGrammarKnownFieldList (packageDescriptionFieldGrammar @Mod.HasNoAnn) + , fieldGrammarKnownFieldList $ (libraryFieldGrammar @Mod.HasNoAnn) LMainLibName + , fieldGrammarKnownFieldList $ (executableFieldGrammar @Mod.HasNoAnn) "exe" + , fieldGrammarKnownFieldList $ (foreignLibFieldGrammar @Mod.HasNoAnn) "flib" + , fieldGrammarKnownFieldList (testSuiteFieldGrammar @Mod.HasNoAnn) + , fieldGrammarKnownFieldList (benchmarkFieldGrammar @Mod.HasNoAnn) + , fieldGrammarKnownFieldList $ (flagFieldGrammar @Mod.HasNoAnn) (error "flagname") + , fieldGrammarKnownFieldList $ (sourceRepoFieldGrammar @Mod.HasNoAnn) (error "repokind") + , fieldGrammarKnownFieldList $ (setupBInfoFieldGrammar @Mod.HasNoAnn) True ] ] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index f23bf0a8107..1ae288e603f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,7 +1,14 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Distribution.PackageDescription.Parsec @@ -28,6 +35,10 @@ module Distribution.PackageDescription.Parsec -- ** Supplementary build information , parseHookedBuildInfo + + -- * Pre-processing utilities + , sectionizeFields + , takeFields ) where import Distribution.Compat.Prelude @@ -48,14 +59,18 @@ import Distribution.PackageDescription import Distribution.PackageDescription.Configuration (freeVars, transformAllBuildInfos) import Distribution.PackageDescription.FieldGrammar import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec (parsec, simpleParsecBS) +import Distribution.Parsec (Parsec, parsec, simpleParsecBS) import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) import Distribution.Parsec.Position (Position (..), incPos, zeroPos) import Distribution.Parsec.Warning (PWarnType (..)) import Distribution.Pretty (prettyShow) +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AnnotateWith) import Distribution.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) import Distribution.Version (Version, mkVersion, versionNumbers) +import Distribution.Trivia + import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map.Strict as Map @@ -76,7 +91,32 @@ import qualified Text.Parsec as P -- -- In Cabal 1.2 the syntax for package descriptions was changed to a format -- with sections and possibly indented property descriptions. -parseGenericPackageDescription :: BS.ByteString -> ParseResult src GenericPackageDescription +parseGenericPackageDescription + :: forall mod src + . ( FieldGrammarWith mod Parsec ParsecFieldGrammar + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod (LibraryWith mod) + , L.HasBuildInfoWith mod (ForeignLibWith mod) + , L.HasBuildInfoWith mod (ExecutableWith mod) + , L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) + , L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) + + , EmptyGPD mod + + , Monoid (BuildInfoWith mod) + , Monoid (LibraryWith mod) + , Monoid (ForeignLibWith mod) + , Monoid (ExecutableWith mod) + , Monoid (TestSuiteWith mod) + , Monoid (BenchmarkWith mod) + -- , Monoid (TestSuiteStanzaWith mod) + -- , Monoid (BenchmarkStanzaWith mod) + + , Parsec (DependencyWith mod) + + , BuildInfoConstraint mod Parsec + ) + => BS.ByteString -> ParseResult src (GenericPackageDescriptionWith mod) parseGenericPackageDescription bs = do -- set scanned version setCabalSpecVersion ver @@ -98,7 +138,7 @@ parseGenericPackageDescription bs = do when patched $ parseWarning zeroPos PWTQuirkyCabalFile "Legacy cabal file" -- UTF8 is validated in a prepass step, afterwards parsing is lenient. - parseGenericPackageDescription' csv lexWarnings invalidUtf8 fs + parseGenericPackageDescription' @mod csv lexWarnings invalidUtf8 fs -- TODO: better marshalling of errors Left perr -> parseFatalFailure pos (show perr) where @@ -116,7 +156,33 @@ parseGenericPackageDescription bs = do Just _ -> toUTF8BS (fromUTF8BS bs') -- | 'Maybe' variant of 'parseGenericPackageDescription' -parseGenericPackageDescriptionMaybe :: BS.ByteString -> Maybe GenericPackageDescription +parseGenericPackageDescriptionMaybe + :: forall mod src + . ( FieldGrammarWith mod Parsec ParsecFieldGrammar + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod (LibraryWith mod) + , L.HasBuildInfoWith mod (ForeignLibWith mod) + , L.HasBuildInfoWith mod (ExecutableWith mod) + , L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) + , L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) + + + , EmptyGPD mod + + , Monoid (BuildInfoWith mod) + , Monoid (LibraryWith mod) + , Monoid (ForeignLibWith mod) + , Monoid (ExecutableWith mod) + , Monoid (TestSuiteWith mod) + , Monoid (BenchmarkWith mod) + -- , Monoid (TestSuiteStanzaWith mod) + -- , Monoid (BenchmarkStanzaWith mod) + + , Parsec (DependencyWith mod) + + , BuildInfoConstraint mod Parsec + ) + => BS.ByteString -> Maybe (GenericPackageDescriptionWith mod) parseGenericPackageDescriptionMaybe = either (const Nothing) Just . snd . runParseResult . parseGenericPackageDescription @@ -124,19 +190,19 @@ fieldlinesToBS :: [FieldLine ann] -> BS.ByteString fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) -- Monad in which sections are parsed -type SectionParser src = StateT SectionS (ParseResult src) +type SectionParser (mod :: Mod.HasAnnotation) src = StateT (SectionS mod) (ParseResult src) -- | State of section parser -data SectionS = SectionS - { _stateGpd :: !GenericPackageDescription - , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) +data SectionS (mod :: Mod.HasAnnotation) = SectionS + { _stateGpd :: !(GenericPackageDescriptionWith mod) + , _stateCommonStanzas :: !(Map String (CondTreeBuildInfoWith mod)) } -stateGpd :: Lens' SectionS GenericPackageDescription +stateGpd :: Lens' (SectionS mod) (GenericPackageDescriptionWith mod) stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd {-# INLINE stateGpd #-} -stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) +stateCommonStanzas :: Lens' (SectionS mod) (Map String (CondTreeBuildInfoWith mod)) stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs {-# INLINE stateCommonStanzas #-} @@ -148,11 +214,40 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -- * then we parse sections (libraries, executables, etc) parseGenericPackageDescription' - :: Maybe CabalSpecVersion + :: forall mod src + . ( Semigroup (BuildInfoWith mod) + + , EmptyGPD mod + + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod (LibraryWith mod) + , L.HasBuildInfoWith mod (ForeignLibWith mod) + , L.HasBuildInfoWith mod (ExecutableWith mod) + , L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) + , L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) + + , Monoid (BuildInfoWith mod) + , Monoid (LibraryWith mod) + , Monoid (ForeignLibWith mod) + , Monoid (ExecutableWith mod) + , Monoid (TestSuiteWith mod) + , Monoid (BenchmarkWith mod) + -- , Monoid (TestSuiteStanzaWith mod) + -- , Monoid (BenchmarkStanzaWith mod) + + +-- Why this bound + , BuildInfoConstraint mod Parsec + + , Parsec (DependencyWith mod) + + , FieldGrammarWith mod Parsec ParsecFieldGrammar + ) + => Maybe CabalSpecVersion -> [LexWarning] -> Maybe Int -> [Field Position] - -> ParseResult src GenericPackageDescription + -> ParseResult src (GenericPackageDescriptionWith mod) parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do parseWarnings (toPWarnings lexWarnings) for_ utf8WarnPos $ \pos -> @@ -187,34 +282,42 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do setCabalSpecVersion (Just specVer') -- Package description - pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar + pd <- parseFieldGrammar specVer Nothing fields (packageDescriptionFieldGrammar @mod) - -- Check that scanned and parsed versions match. - unless (specVer == specVersion pd) $ - parseFailure zeroPos $ - "Scanned and parsed cabal-versions don't match " - ++ prettyShow (SpecVersion specVer) - ++ " /= " - ++ prettyShow (SpecVersion (specVersion pd)) + -- -- Check that scanned and parsed versions match. + -- unless (specVer == specVersion pd) $ + -- parseFailure zeroPos $ + -- "Scanned and parsed cabal-versions don't match " + -- ++ prettyShow (SpecVersion specVer) + -- ++ " /= " + -- ++ prettyShow (SpecVersion (specVersion pd)) - maybeWarnCabalVersion syntax pd + -- maybeWarnCabalVersion syntax pd -- Sections - let gpd = - emptyGenericPackageDescription + let gpd :: GenericPackageDescriptionWith mod + gpd = + (emptyGPD @mod) & L.packageDescription .~ pd - gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) + gpd1 <- view stateGpd <$> execStateT (goSections @mod specVer sectionFields) (SectionS gpd Map.empty) + + -- TODO(leana8959): we need a way to convert any validation endomorphism over GPD to endomorphism over GPD Annotated + -- This way, we don't redefine all the validation logic, or make them messy because now the trivia is there. + -- + -- Or, we could push out this validation at a later phase, only concerned with the plain GPD. + -- + -- let gpd2 = postProcessInternalDeps specVer gpd1 + -- checkForUndefinedFlags gpd2 + -- checkForUndefinedCustomSetup gpd2 - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - checkForUndefinedCustomSetup gpd2 -- See nothunks test, without this deepseq we get (at least): -- Thunk in ThunkInfo {thunkContext = ["PackageIdentifier","PackageDescription","GenericPackageDescription"]} -- -- TODO: re-benchmark, whether `deepseq` is important (both cabal-benchmarks and solver-benchmarks) -- TODO: remove the need for deepseq if `deepseq` in fact matters -- NOTE: IIRC it does affect (maximal) memory usage, which causes less GC pressure - gpd2 `deepseq` return gpd2 + -- gpd2 `deepseq` return gpd2 + pure gpd1 where safeLast :: [a] -> Maybe a safeLast = listToMaybe . reverse @@ -240,9 +343,38 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do cabalFormatVersionsDesc :: String cabalFormatVersionsDesc = "Current cabal-version values are listed at https://cabal.readthedocs.io/en/stable/file-format-changelog.html." -goSections :: CabalSpecVersion -> [Field Position] -> SectionParser src () +goSections + :: forall mod src + . ( BuildInfoConstraint mod Parsec + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod (LibraryWith mod) + , L.HasBuildInfoWith mod (ForeignLibWith mod) + , L.HasBuildInfoWith mod (ExecutableWith mod) + , Monoid (BuildInfoWith mod) + , Monoid (LibraryWith mod) + , Monoid (ForeignLibWith mod) + , Monoid (ExecutableWith mod) + , Monoid (TestSuiteWith mod) + , Monoid (BenchmarkWith mod) + , FieldGrammarWith mod Parsec ParsecFieldGrammar + , Parsec (DependencyWith mod) + ) + => CabalSpecVersion + -> [Field Position] + -> SectionParser mod src () goSections specVer = traverse_ process where + process + :: + -- forall mod src + -- . ( FieldGrammarWith mod Parsec ParsecFieldGrammar + -- , BuildInfoConstraint mod Parsec + -- ) + -- => + ( Semigroup (BuildInfoWith mod) + , Monoid (LibraryWith mod) + ) => + Field Position -> SectionParser mod src () process (Field (Name pos name) _) = lift $ parseWarning pos PWTTrailingFields $ @@ -256,25 +388,43 @@ goSections specVer = traverse_ process -- we need signature, because this is polymorphic, but not-closed parseCondTree' - :: L.HasBuildInfo a - => ParsecFieldGrammar' a + :: ( L.HasBuildInfoWith mod a + , Monoid (LibraryWith mod) + , Semigroup (BuildInfoWith mod) + ) + => ParsecFieldGrammarWith' mod a -- \^ grammar - -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo + -> (BuildInfoWith mod -> a) + -> Map String (CondTreeBuildInfoWith mod) -- \^ common stanzas + -> Maybe Position -> [Field Position] -> ParseResult src (CondTree ConfVar a) - parseCondTree' = parseCondTreeWithCommonStanzas specVer - - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser src () + parseCondTree' = parseCondTreeWithCommonStanzas @mod @src specVer + + parseSection + :: + -- forall mod src + -- . ( FieldGrammarWith mod Parsec ParsecFieldGrammar + -- , BuildInfoConstraint mod Parsec + -- , L.HasBuildInfoWith mod (BuildInfoWith mod) + -- ) + -- => + ( Semigroup (BuildInfoWith mod) + , Monoid (LibraryWith mod) + ) => + Name Position + -> [SectionArg Position] + -> [Field Position] + -> SectionParser mod src () parseSection (Name pos name) args fields | hasCommonStanzas == NoCommonStanzas , name == "common" = lift $ do parseWarning pos PWTUnknownSection "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." | name == "common" = do - commonStanzas <- use stateCommonStanzas + commonStanzas :: Map String (CondTreeBuildInfoWith mod) <- use stateCommonStanzas name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields + biTree :: CondTreeBuildInfoWith mod <- lift $ parseCondTree' (buildInfoFieldGrammar @mod) id commonStanzas (Just pos) fields case Map.lookup name' commonStanzas of Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas @@ -290,7 +440,7 @@ goSections specVer = traverse_ process commonStanzas <- use stateCommonStanzas let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields + lib <- lift $ parseCondTree' (libraryFieldGrammar @mod name'') (libraryFromBuildInfo name'') commonStanzas (Just pos) fields -- -- TODO check that not set stateGpd . L.condLibrary ?= lib @@ -301,7 +451,7 @@ goSections specVer = traverse_ process commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args let name'' = LSubLibName name' - lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields + lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas (Just pos) fields -- TODO check duplicate name here? stateGpd . L.condSubLibraries %= snoc (name', lib) @@ -309,9 +459,9 @@ goSections specVer = traverse_ process | name == "foreign-library" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields + flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas (Just pos) fields - let hasType ts = foreignLibType ts /= foreignLibType mempty + let hasType ts = foreignLibType ts /= foreignLibType (mempty :: ForeignLibWith mod) unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ @@ -328,62 +478,65 @@ goSections specVer = traverse_ process | name == "executable" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas fields + exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas (Just pos) fields -- TODO check duplicate name here? stateGpd . L.condExecutables %= snoc (name', exe) | name == "test-suite" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - testStanza <- lift $ parseCondTree' testSuiteFieldGrammar (fromBuildInfo' name') commonStanzas fields - testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza - - let hasType ts = testInterface ts /= testInterface mempty - unless (onAllBranches hasType testSuite) $ - lift $ - parseFailure pos $ - concat - [ "Test suite " ++ show (prettyShow name') - , concat $ case specVer of - v - | v >= CabalSpecV3_8 -> - [ " is missing required field \"main-is\" or the field " - , "is not present in all conditional branches." - ] - _ -> - [ " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available test types are: " - , intercalate ", " (map prettyShow knownTestTypes) - ] - ] + -- TODO(leana8959): push out validation at the desugar stage + -- testStanza <- lift $ parseCondTree' (testSuiteFieldGrammar @mod) (fromBuildInfo' name') commonStanzas fields + -- testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza + let testSuite = mempty + + -- let hasType ts = testInterface ts /= testInterface (mempty :: TestSuiteWith mod) + -- unless (onAllBranches hasType testSuite) $ + -- lift $ + -- parseFailure pos $ + -- concat + -- [ "Test suite " ++ show (prettyShow name') + -- , concat $ case specVer of + -- v + -- | v >= CabalSpecV3_8 -> + -- [ " is missing required field \"main-is\" or the field " + -- , "is not present in all conditional branches." + -- ] + -- _ -> + -- [ " is missing required field \"type\" or the field " + -- , "is not present in all conditional branches. The " + -- , "available test types are: " + -- , intercalate ", " (map prettyShow knownTestTypes) + -- ] + -- ] -- TODO check duplicate name here? stateGpd . L.condTestSuites %= snoc (name', testSuite) | name == "benchmark" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields - bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza - - let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty - unless (onAllBranches hasType bench) $ - lift $ - parseFailure pos $ - concat - [ "Benchmark " ++ show (prettyShow name') - , concat $ case specVer of - v - | v >= CabalSpecV3_8 -> - [ " is missing required field \"main-is\" or the field " - , "is not present in all conditional branches." - ] - _ -> - [ " is missing required field \"type\" or the field " - , "is not present in all conditional branches. The " - , "available benchmark types are: " - , intercalate ", " (map prettyShow knownBenchmarkTypes) - ] - ] + -- benchStanza <- lift $ parseCondTree' (benchmarkFieldGrammar @mod) (fromBuildInfo' name') commonStanzas fields + -- bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza + let bench = CondNode (mempty :: BenchmarkWith mod) [] + + -- let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty + -- unless (onAllBranches hasType bench) $ + -- lift $ + -- parseFailure pos $ + -- concat + -- [ "Benchmark " ++ show (prettyShow name') + -- , concat $ case specVer of + -- v + -- | v >= CabalSpecV3_8 -> + -- [ " is missing required field \"main-is\" or the field " + -- , "is not present in all conditional branches." + -- ] + -- _ -> + -- [ " is missing required field \"type\" or the field " + -- , "is not present in all conditional branches. The " + -- , "available benchmark types are: " + -- , intercalate ", " (map prettyShow knownBenchmarkTypes) + -- ] + -- ] -- TODO check duplicate name here? stateGpd . L.condBenchmarks %= snoc (name', bench) @@ -414,10 +567,10 @@ goSections specVer = traverse_ process parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name -parseName :: Position -> [SectionArg Position] -> SectionParser src String +parseName :: Position -> [SectionArg Position] -> SectionParser mod src String parseName pos args = fromUTF8BS <$> parseNameBS pos args -parseNameBS :: Position -> [SectionArg Position] -> SectionParser src BS.ByteString +parseNameBS :: Position -> [SectionArg Position] -> SectionParser mod src BS.ByteString -- TODO: use strict parser parseNameBS pos args = case args of [SecArgName _pos secName] -> @@ -447,7 +600,7 @@ parseCommonName pos args = case args of pure "" -- TODO: avoid conversion to 'String'. -parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser src UnqualComponentName +parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser mod src UnqualComponentName parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args -- | Parse a non-recursive list of fields. @@ -460,27 +613,31 @@ parseFields parseFields v fields grammar = do let (fs0, ss) = partitionFields fields traverse_ (traverse_ warnInvalidSubsection) ss - parseFieldGrammar v fs0 grammar + parseFieldGrammar v Nothing fs0 grammar warnInvalidSubsection :: Section Position -> ParseResult src () warnInvalidSubsection (MkSection (Name pos name) _ _) = void $ parseFailure pos $ "invalid subsection " ++ show name parseCondTree - :: forall src a - . L.HasBuildInfo a + :: forall mod src a + . ( L.HasBuildInfoWith mod a + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , Semigroup (BuildInfoWith mod) + ) => CabalSpecVersion -> HasElif -- ^ accept @elif@ - -> ParsecFieldGrammar' a + -> ParsecFieldGrammarWith' mod a -- ^ grammar - -> Map String CondTreeBuildInfo + -> Map String (CondTreeBuildInfoWith mod) -- ^ common stanzas - -> (BuildInfo -> a) + -> (BuildInfoWith mod -> a) -- ^ constructor from buildInfo + -> Maybe Position -> [Field Position] -> ParseResult src (CondTree ConfVar a) -parseCondTree v hasElif grammar commonStanzas fromBuildInfo = go +parseCondTree v hasElif grammar commonStanzas fromBuildInfo sectionPos = go where go fields0 = do (fields, endo) <- @@ -489,7 +646,8 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo = go else traverse (warnImport v) fields0 >>= \fields1 -> return (catMaybes fields1, id) let (fs, ss) = partitionFields fields - x <- parseFieldGrammar v fs grammar + -- TODO(leana8959): there are no position for conditional sections for now + x <- parseFieldGrammar v sectionPos fs grammar branches <- concat <$> traverse parseIfs ss return $ endo $ CondNode x branches @@ -522,7 +680,7 @@ parseCondTree v hasElif grammar commonStanzas fromBuildInfo = go fields' <- go fields (elseFields, sections') <- parseElseIfs sections -- we parse an empty 'Fields', to get empty value for a node - a <- parseFieldGrammar v mempty grammar + a <- parseFieldGrammar v Nothing mempty grammar return (Just $ CondNode a [CondBranch test' fields' elseFields], sections') parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do parseWarning pos PWTInvalidSubsection "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." @@ -591,7 +749,9 @@ with new AST, this all need to be rewritten. -- The approach is simple, and have good properties: -- -- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. -type CondTreeBuildInfo = CondTree ConfVar BuildInfo +type CondTreeBuildInfoWith (mod :: Mod.HasAnnotation) = CondTree ConfVar (BuildInfoWith mod) +type CondTreeBuildInfo = CondTreeBuildInfoWith Mod.HasNoAnn +type CondTreeBuildInfoAnn = CondTreeBuildInfoWith Mod.HasAnn -- | Create @a@ from 'BuildInfo'. -- This class is used to implement common stanza parsing. @@ -599,12 +759,12 @@ type CondTreeBuildInfo = CondTree ConfVar BuildInfo -- Law: @view buildInfo . fromBuildInfo = id@ -- -- This takes name, as 'FieldGrammar's take names too. -class L.HasBuildInfo a => FromBuildInfo a where - fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a +class L.HasBuildInfoWith mod a => FromBuildInfoWith mod a where + fromBuildInfo' :: UnqualComponentName -> BuildInfoWith mod -> a -libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library +libraryFromBuildInfo :: forall mod. Monoid (LibraryWith mod) => LibraryName -> BuildInfoWith mod -> LibraryWith mod libraryFromBuildInfo n bi = - emptyLibrary + (mempty :: LibraryWith mod) { libName = n , libVisibility = case n of LMainLibName -> LibraryVisibilityPublic @@ -612,42 +772,65 @@ libraryFromBuildInfo n bi = , libBuildInfo = bi } -instance FromBuildInfo BuildInfo where fromBuildInfo' _ = id -instance FromBuildInfo ForeignLib where fromBuildInfo' n bi = set L.foreignLibName n $ set L.buildInfo bi emptyForeignLib -instance FromBuildInfo Executable where fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi emptyExecutable +instance L.HasBuildInfoWith mod (BuildInfoWith mod) => FromBuildInfoWith mod (BuildInfoWith mod) where fromBuildInfo' _ = id +instance + ( L.HasBuildInfoWith mod (ForeignLibWith mod) + , Monoid (ForeignLibWith mod) + ) => FromBuildInfoWith mod (ForeignLibWith mod) where + fromBuildInfo' n bi = + set L.foreignLibName n $ set L.buildInfo bi (mempty :: ForeignLibWith mod) + +instance + ( L.HasBuildInfoWith mod (ExecutableWith mod) + , Monoid (ExecutableWith mod) + ) => FromBuildInfoWith mod (ExecutableWith mod) where + fromBuildInfo' n bi = set L.exeName n $ set L.buildInfo bi (mempty :: ExecutableWith mod) + +instance L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) where + buildInfo f t = (\x -> t{_testStanzaBuildInfo = x}) <$> f (_testStanzaBuildInfo t) -instance FromBuildInfo TestSuiteStanza where +instance L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) where + buildInfo f b = (\x -> b{_benchmarkStanzaBuildInfo = x}) <$> f (_benchmarkStanzaBuildInfo b) + +instance FromBuildInfoWith mod (TestSuiteStanzaWith mod) where fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi [] -instance FromBuildInfo BenchmarkStanza where +instance FromBuildInfoWith mod (BenchmarkStanzaWith mod) where fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi parseCondTreeWithCommonStanzas - :: forall src a - . L.HasBuildInfo a - => CabalSpecVersion - -> ParsecFieldGrammar' a + :: forall mod src a + . ( L.HasBuildInfoWith mod a + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , Semigroup (BuildInfoWith mod) + ) + => CabalSpecVersion + -> ParsecFieldGrammarWith' mod a -- ^ grammar - -> (BuildInfo -> a) + -> (BuildInfoWith mod -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo + -> Map String (CondTreeBuildInfoWith mod) -- ^ common stanzas + -> Maybe Position -> [Field Position] -> ParseResult src (CondTree ConfVar a) -parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do +parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas sectionPos fields = do (fields', endo) <- processImports v fromBuildInfo commonStanzas fields - x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo fields' + x <- parseCondTree v hasElif grammar commonStanzas fromBuildInfo sectionPos fields' return (endo x) where hasElif = specHasElif v processImports - :: forall src a - . L.HasBuildInfo a + :: forall (mod :: Mod.HasAnnotation) src a + . ( L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod a + , Semigroup (BuildInfoWith mod) + ) => CabalSpecVersion - -> (BuildInfo -> a) + -> (BuildInfoWith mod -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo + -> Map String (CondTreeBuildInfoWith mod) -- ^ common stanzas -> [Field Position] -> ParseResult src ([Field Position], CondTree ConfVar a -> CondTree ConfVar a) @@ -658,6 +841,10 @@ processImports v fromBuildInfo commonStanzas = go [] getList' :: List CommaFSep Token String -> [String] getList' = Newtype.unpack + go + :: [CondTree ConfVar (BuildInfoWith mod)] + -> [Field Position] + -> ParseResult src ([Field Position], CondTree ConfVar a -> CondTree ConfVar a) go acc (Field (Name pos name) _ : fields) | name == "import" , hasCommonStanzas == NoCommonStanzas = do @@ -691,9 +878,12 @@ warnImport v (Field (Name pos name) _) | name == "import" = do warnImport _ f = pure (Just f) mergeCommonStanza - :: L.HasBuildInfo a - => (BuildInfo -> a) - -> CondTree ConfVar BuildInfo + :: forall (mod :: Mod.HasAnnotation) a + . ( L.HasBuildInfoWith mod a + , Semigroup (BuildInfoWith mod) + ) + => (BuildInfoWith mod -> a) + -> CondTree ConfVar (BuildInfoWith mod) -> CondTree ConfVar a -> CondTree ConfVar a mergeCommonStanza fromBuildInfo (CondNode bi bis) (CondNode x cs) = @@ -920,7 +1110,7 @@ data Syntax = OldSyntax | NewSyntax -- TODO: libFieldNames :: [FieldName] -libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) +libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar @Mod.HasNoAnn LMainLibName) ------------------------------------------------------------------------------- -- Supplementary build information @@ -947,11 +1137,11 @@ parseHookedBuildInfo' lexWarnings fs = do parseLib :: Fields Position -> ParseResult src (Maybe BuildInfo) parseLib fields | Map.null fields = pure Nothing - | otherwise = Just <$> parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar + | otherwise = Just <$> parseFieldGrammar cabalSpecLatest Nothing fields buildInfoFieldGrammar parseExe :: (UnqualComponentName, Fields Position) -> ParseResult src (UnqualComponentName, BuildInfo) parseExe (n, fields) = do - bi <- parseFieldGrammar cabalSpecLatest fields buildInfoFieldGrammar + bi <- parseFieldGrammar cabalSpecLatest Nothing fields buildInfoFieldGrammar pure (n, bi) stanzas :: [Field Position] -> ParseResult src (Fields Position, [(UnqualComponentName, Fields Position)]) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index dbd872d2823..2fb945053cc 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -19,6 +23,7 @@ module Distribution.PackageDescription.PrettyPrint writeGenericPackageDescription , showGenericPackageDescription , ppGenericPackageDescription + , ppGenericPackageDescriptionAnn -- * Package descriptions , writePackageDescription @@ -34,8 +39,10 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Compat.Lens -import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.FieldGrammar (PrettyFieldGrammarWith', PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.Fields.Field import Distribution.Fields.Pretty +import Distribution.Parsec.Position import Distribution.PackageDescription import Distribution.PackageDescription.Configuration (transformAllBuildInfos) import Distribution.PackageDescription.FieldGrammar @@ -57,11 +64,18 @@ import qualified Distribution.PackageDescription.FieldGrammar as FG import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.SetupBuildInfo.Lens as L +import Control.Applicative + import Text.PrettyPrint (Doc, char, hsep, parens, text) +import Data.List (groupBy, sortBy) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Types.Modify as Mod +import qualified Text.PrettyPrint as PP +import Distribution.Types.Modify (AttachPosition) + -- | Writes a .cabal file from a generic package description writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) @@ -73,7 +87,7 @@ showGenericPackageDescription gpd = showFields (const NoComment) $ ppGenericPack v = specVersion $ packageDescription gpd -- | Convert a generic package description to 'PrettyField's. -ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField ()] +ppGenericPackageDescription :: CabalSpecVersion -> GenericPackageDescription -> [PrettyField] ppGenericPackageDescription v gpd0 = concat [ ppPackageDescription v (packageDescription gpd) @@ -89,44 +103,123 @@ ppGenericPackageDescription v gpd0 = where gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 -ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] +-- | Convert a generic package description to 'PrettyField's. +ppGenericPackageDescriptionAnn :: CabalSpecVersion -> GenericPackageDescriptionWith Mod.HasAnn -> [PrettyFieldWith Mod.HasAnn] +ppGenericPackageDescriptionAnn v gpd0 = + concat + [ ppPackageDescriptionAnn v (packageDescription gpd) + , ppSetupBInfoAnn v (setupBuildInfo (packageDescription gpd)) + , ppGenPackageFlagsAnn v (genPackageFlags gpd) + , ppCondLibraryAnn v (condLibrary gpd) + , ppCondSubLibrariesAnn v (condSubLibraries gpd) + , ppCondForeignLibsAnn v (condForeignLibs gpd) + , ppCondExecutablesAnn v (condExecutables gpd) + -- TODO(leana8959): think of a strategy to handle endomorphisms + -- , ppCondTestSuitesAnn v (condTestSuites gpd) + -- , ppCondBenchmarksAnn v (condBenchmarks gpd) + ] + where + -- TODO(leana8959): handle endomorphisms conversions / validations + -- gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 + gpd = gpd0 + +ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField] ppPackageDescription v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd + prettyFieldGrammar v packageDescriptionFieldGrammar Nothing pd ++ ppSourceRepos v (sourceRepos pd) -ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] +ppPackageDescriptionAnn :: CabalSpecVersion -> PackageDescriptionWith Mod.HasAnn -> [PrettyFieldWith Mod.HasAnn] +ppPackageDescriptionAnn v pd = + map + (\(_, fname, fdoc) -> PrettyField fname fdoc) + (prettyFieldGrammar v packageDescriptionFieldGrammar Nothing pd) + ++ ppSourceReposAnn v (sourceRepos pd) + +ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField] ppSourceRepos = map . ppSourceRepo -ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () +ppSourceReposAnn :: CabalSpecVersion -> [SourceRepo] -> [PrettyFieldWith Mod.HasAnn] +ppSourceReposAnn v = concatMap (ppSourceRepoAnn v) + +ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ppSourceRepo v repo = - PrettySection () "source-repository" [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo + PrettySection "source-repository" [pretty kind] $ + prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasNoAnn kind) Nothing repo where kind = repoKind repo -ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] +groupFields + :: [(Maybe Position, (Position, FieldName), (Position, Doc))] + -> [[(Maybe Position, (Position, FieldName), (Position, Doc))]] +groupFields = groupBy (\u v -> fst3 u == fst3 v) . sortBy (\u v -> fst3 u `compare` fst3 v) + where fst3 (a, _, _) = a + +intoFields + :: [(Maybe Position, (Position, FieldName), (Position, Doc))] + -> (Maybe Position, [PrettyFieldWith Mod.HasAnn]) +intoFields xs = (asum $ map sectionPoss xs, map intoField xs) + where + intoField (sectionPos, name, doc) = (PrettyField name doc) + sectionPoss (u, _, _) = u + +intoSection + :: FieldName + -> [Doc] + -> [(Maybe Position, (Position, FieldName), (Position, Doc))] + -> [PrettyFieldWith Mod.HasAnn] +intoSection sectionName sectionArgs xs = + let -- all group members have the same sectionPos, drop it. + (sectionPos, withoutSectionPos) = intoFields xs + in [ PrettySection (fromMaybe zeroPos sectionPos, sectionName) sectionArgs withoutSectionPos + ] + +ppSourceRepoAnn :: CabalSpecVersion -> SourceRepo -> [PrettyFieldWith Mod.HasAnn] +ppSourceRepoAnn v repo = + let fields = prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasAnn kind) Nothing repo + in concatMap (intoSection "source-repository" [pretty kind]) $ groupFields fields + where + kind = repoKind repo + +ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField] ppSetupBInfo _ Nothing = mempty ppSetupBInfo v (Just sbi) | defaultSetupDepends sbi = mempty | otherwise = pure $ - PrettySection () "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi + PrettySection "custom-setup" [] $ + prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasNoAnn False) Nothing sbi -ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] +ppSetupBInfoAnn :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyFieldWith Mod.HasAnn] +ppSetupBInfoAnn _ Nothing = mempty +ppSetupBInfoAnn v (Just sbi) + | defaultSetupDepends sbi = mempty + | otherwise = + let fields = prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasAnn False) Nothing sbi + in + concatMap (intoSection "custom-setup" []) $ groupFields fields + +ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField] ppGenPackageFlags = map . ppFlag -ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () +ppGenPackageFlagsAnn :: CabalSpecVersion -> [PackageFlag] -> [PrettyFieldWith Mod.HasAnn] +ppGenPackageFlagsAnn v = concatMap (ppFlagAnn v) + +ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ppFlag v flag@(MkPackageFlag name _ _ _) = - PrettySection () "flag" [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar name) flag + PrettySection "flag" [ppFlagName name] $ + prettyFieldGrammar v (flagFieldGrammar @Mod.HasNoAnn name) Nothing flag + +ppFlagAnn :: CabalSpecVersion -> PackageFlag -> [PrettyFieldWith Mod.HasAnn] +ppFlagAnn v flag@(MkPackageFlag name _ _ _) = + let fields = prettyFieldGrammar v (flagFieldGrammar @Mod.HasAnn name) Nothing flag + in concatMap (intoSection "flag" [ppFlagName name]) $ groupFields fields -ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar s -> [PrettyField ()] +ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar s -> [PrettyField] ppCondTree2 v grammar = go where -- TODO: recognise elif opportunities go (CondNode it ifs) = - prettyFieldGrammar v grammar it + prettyFieldGrammar v grammar Nothing it ++ concatMap ppIf ifs ppIf (CondBranch c thenTree Nothing) @@ -137,51 +230,115 @@ ppCondTree2 v grammar = go ppIf (CondBranch c thenTree (Just elseTree)) = -- See #6193 [ ppIfCondition c (go thenTree) - , PrettySection () "else" [] (go elseTree) + , PrettySection "else" [] (go elseTree) + ] + +ppCondTree2Ann :: CabalSpecVersion -> PrettyFieldGrammarWith' Mod.HasAnn s -> CondTree ConfVar s -> (Maybe Position, [PrettyFieldWith Mod.HasAnn]) +ppCondTree2Ann v grammar = go + where + go (CondNode it ifs) = + -- The fields are not contained within conditions + let (sectionPos, fields) = intoFields $ prettyFieldGrammar v grammar Nothing it + in (sectionPos, fields ++ concatMap ppIf ifs) + + ppIf (CondBranch c thenTree Nothing) + -- | isEmpty thenDoc = mempty + | otherwise = [ppIfConditionAnn c thenDoc] + where + thenDoc = snd $ go thenTree + ppIf (CondBranch c thenTree (Just elseTree)) = + -- See #6193 + [ ppIfConditionAnn c (snd $ go thenTree) + , PrettySection (zeroPos, "else") [] (snd $ go elseTree) ] -ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar Library) -> [PrettyField ()] +ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar Library) -> [PrettyField] ppCondLibrary _ Nothing = mempty ppCondLibrary v (Just condTree) = pure $ - PrettySection () "library" [] $ + PrettySection "library" [] $ ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree -ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Library)] -> [PrettyField ()] +ppCondLibraryAnn :: CabalSpecVersion -> Maybe (CondTree ConfVar (LibraryWith Mod.HasAnn)) -> [PrettyFieldWith Mod.HasAnn] +ppCondLibraryAnn _ Nothing = mempty +ppCondLibraryAnn v (Just condTree) = + let (sectionPos, fields) = ppCondTree2Ann v (libraryFieldGrammar LMainLibName) condTree + in + -- TODO(leana8959): assert that there are no more than one library ? + [ PrettySection (fromMaybe zeroPos sectionPos, "library") [] fields + ] + +ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Library)] -> [PrettyField] ppCondSubLibraries v libs = - [ PrettySection () "library" [pretty n] $ + [ PrettySection "library" [pretty n] $ ppCondTree2 v (libraryFieldGrammar $ LSubLibName n) condTree | (n, condTree) <- libs ] -ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar ForeignLib)] -> [PrettyField ()] +ppCondSubLibrariesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (LibraryWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +ppCondSubLibrariesAnn v libs = + [ PrettySection (fromMaybe zeroPos sectionPos, "library") [pretty n] fields + | (n, condTree) <- libs + , let (sectionPos, fields) = ppCondTree2Ann v (libraryFieldGrammar $ LSubLibName n) condTree + ] + +ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar ForeignLib)] -> [PrettyField] ppCondForeignLibs v flibs = - [ PrettySection () "foreign-library" [pretty n] $ + [ PrettySection "foreign-library" [pretty n] $ ppCondTree2 v (foreignLibFieldGrammar n) condTree | (n, condTree) <- flibs ] -ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Executable)] -> [PrettyField ()] +ppCondForeignLibsAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (ForeignLibWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +ppCondForeignLibsAnn v flibs = + [ PrettySection (fromMaybe zeroPos sectionPos, "foreign-library") [pretty n] fields + | (n, condTree) <- flibs + , let (sectionPos, fields) = ppCondTree2Ann v (foreignLibFieldGrammar n) condTree + ] + +ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Executable)] -> [PrettyField] ppCondExecutables v exes = - [ PrettySection () "executable" [pretty n] $ + [ PrettySection "executable" [pretty n] $ ppCondTree2 v (executableFieldGrammar n) condTree | (n, condTree) <- exes ] -ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar TestSuite)] -> [PrettyField ()] +ppCondExecutablesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (ExecutableWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +ppCondExecutablesAnn v exes = + [ PrettySection (fromMaybe zeroPos sectionPos, "executable") [pretty n] fields + | (n, condTree) <- exes + , let (sectionPos, fields) = ppCondTree2Ann v (executableFieldGrammar n) condTree + ] + +ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar TestSuite)] -> [PrettyField] ppCondTestSuites v suites = - [ PrettySection () "test-suite" [pretty n] $ + [ PrettySection "test-suite" [pretty n] $ ppCondTree2 v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) | (n, condTree) <- suites ] -ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Benchmark)] -> [PrettyField ()] +-- ppCondTestSuitesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (TestSuiteWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +-- ppCondTestSuitesAnn v suites = +-- [ PrettySection "test-suite" [pretty n] $ +-- ppCondTree2Ann v testSuiteFieldGrammar (fmap FG.unvalidateTestSuite condTree) +-- | (n, condTree) <- suites +-- ] + + +ppCondBenchmarks :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Benchmark)] -> [PrettyField] ppCondBenchmarks v suites = - [ PrettySection () "benchmark" [pretty n] $ + [ PrettySection "benchmark" [pretty n] $ ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) | (n, condTree) <- suites ] +-- ppCondBenchmarksAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (BenchmarkWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +-- ppCondBenchmarksAnn v suites = +-- [ PrettySection "benchmark" [pretty n] $ +-- ppCondTree2 v benchmarkFieldGrammar (fmap FG.unvalidateBenchmark condTree) +-- | (n, condTree) <- suites +-- ] + ppCondition :: Condition ConfVar -> Doc ppCondition (Var x) = ppConfVar x ppCondition (Lit b) = text (show b) @@ -211,8 +368,11 @@ ppConfVar (Impl c v) = text "impl" <<>> parens (pretty c <+> pretty v) ppFlagName :: FlagName -> Doc ppFlagName = text . unFlagName -ppIfCondition :: Condition ConfVar -> [PrettyField ()] -> PrettyField () -ppIfCondition c = PrettySection () "if" [ppCondition c] +ppIfCondition :: Condition ConfVar -> [PrettyField] -> PrettyField +ppIfCondition c = PrettySection "if" [ppCondition c] + +ppIfConditionAnn :: Condition ConfVar -> [PrettyFieldWith Mod.HasAnn] -> PrettyFieldWith Mod.HasAnn +ppIfConditionAnn c = PrettySection (zeroPos, "if") [ppCondition c] -- | @since 2.0.0.2 writePackageDescription :: FilePath -> PackageDescription -> IO () @@ -309,8 +469,8 @@ writeHookedBuildInfo fpath = showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const NoComment) $ - maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi - ++ [ PrettySection () "executable:" [pretty name] $ - prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi + maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar Nothing) mb_lib_bi + ++ [ PrettySection "executable:" [pretty name] $ + prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar Nothing bi | (name, bi) <- ex_bis ] diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 9b43b6e41a2..5258d6d2459 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -1,6 +1,8 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -37,25 +39,34 @@ module Distribution.Parsec -- * Position , Position (..) + , parsecWithPosition , incPos , retPos , showPos , zeroPos -- * Utilities + , extractPosition , parsecToken , parsecToken' , parsecFilePath , parsecQuoted , parsecMaybeQuoted , parsecCommaList + , parsecCommaListAnn , parsecCommaNonEmpty + , parsecCommaNonEmptyAnn , parsecLeadingCommaList + , parsecLeadingCommaListAnn , parsecLeadingCommaNonEmpty + , parsecLeadingCommaNonEmptyAnn , parsecOptCommaList + , parsecOptCommaListAnn , parsecLeadingOptCommaList + , parsecLeadingOptCommaListAnn , parsecStandard , parsecUnqualComponentName + , liftParsec ) where import Data.ByteString (ByteString) @@ -64,9 +75,10 @@ import Data.List (transpose) import Distribution.CabalSpecVersion import Distribution.Compat.Prelude import Distribution.Parsec.Error (PError (..), PErrorWithSource (..), showPError, showPErrorWithSource) +import Distribution.Trivia import Data.Monoid (Last (..)) -import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString) +import Distribution.Parsec.FieldLineStream (FieldLineStream, fieldLineStreamFromBS, fieldLineStreamFromString, fieldLineStreamPosition) import Distribution.Parsec.Position (Position (..), incPos, retPos, showPos, zeroPos) import Distribution.Parsec.Warning import Numeric (showIntAtBase) @@ -100,6 +112,8 @@ class (P.CharParsing m, MonadPlus m, Fail.MonadFail m) => CabalParsing m where askCabalSpecVersion :: m CabalSpecVersion + getPosition :: m Position + -- | 'parsec' /could/ consume trailing spaces, this function /will/ consume. lexemeParsec :: (CabalParsing m, Parsec a) => m a lexemeParsec = parsec <* P.spaces @@ -181,6 +195,13 @@ instance CabalParsing ParsecParser where (PWarning t (Position (Parsec.sourceLine spos) (Parsec.sourceColumn spos)) w :) askCabalSpecVersion = PP pure + getPosition = liftParsec $ do + (Position realRow colOffset) <- fieldLineStreamPosition <$> Parsec.getInput + col <- Parsec.sourceColumn <$> Parsec.getPosition + -- Fix up the source position + -- Override the line due to line jumps, and offset the column due to dropped leading spaced + pure $ Position realRow (col + colOffset - 1) + -- | Parse a 'String' with 'lexemeParsec'. simpleParsec :: Parsec a => String -> Maybe a simpleParsec = @@ -306,12 +327,46 @@ parsecStandard f = do -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). +-- | Parse parser @p@ and some trailing spaces. +-- The trivia is stored. +parsecSpacesAnn :: CabalParsing m => m (Ann SurroundingText a) -> m (Ann SurroundingText a) +parsecSpacesAnn p = do + x <- p + post <- P.spaces' + pure (mapAnn (<> postTrivia post) x) +{-# INLINEABLE parsecSpacesAnn #-} + +-- | Parse parser @p@ and store its /starting/ position. +parsecWithPosition :: CabalParsing m => m a -> m (Position, a) +parsecWithPosition = liftA2 (,) getPosition + +-- Ann SurroundingText (Position, a) +-- (Position, Ann SurroundingText a) + +extractPosition + :: Ann t (Position, a) + -> (Position, Ann t a) +extractPosition (Ann t (pos, x)) = (pos, Ann t x) + parsecCommaList :: CabalParsing m => m a -> m [a] parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") +parsecCommaListAnn :: forall m a. CabalParsing m => m (Ann SurroundingText a) -> m [Ann SurroundingText a] +parsecCommaListAnn p = P.sepByAnn (parsecSpacesAnn p) comma + where + comma :: m String + comma = (:) <$> (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 @parsecCommaNonEmpty@ but stores trivia. +parsecCommaNonEmptyAnn :: forall m a. CabalParsing m => m (Ann SurroundingText a) -> m (NonEmpty (Ann SurroundingText a)) +parsecCommaNonEmptyAnn p = P.sepByNonEmptyAnn (parsecSpacesAnn p) comma + where + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + -- | Like 'parsecCommaList' but accept leading or trailing comma. -- -- @ @@ -329,6 +384,21 @@ parsecLeadingCommaList p = do lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" +-- | Like 'parsecCommaList' but stores trivia. +parsecLeadingCommaListAnn :: forall m a. CabalParsing m => m (Ann SurroundingText a) -> m [Ann SurroundingText a] +parsecLeadingCommaListAnn p = + P.optional comma >>= \case + Nothing -> toList <$> P.sepEndByNonEmptyAnn lp comma <|> pure [] + Just c -> + let insertTriviaHead (x :| xs) = mapAnn (preTrivia c <>) x :| xs + in toList . insertTriviaHead <$> P.sepByNonEmptyAnn lp comma + where + lp :: m (Ann SurroundingText a) + lp = parsecSpacesAnn p + + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + -- | -- -- @since 3.4.0.0 @@ -342,11 +412,33 @@ parsecLeadingCommaNonEmpty p = do lp = p <* P.spaces comma = P.char ',' *> P.spaces P. "comma" +-- | Like @parsecLeadingCommaNonEmpty@ but stores trivia. +parsecLeadingCommaNonEmptyAnn :: forall m a. CabalParsing m => m (Ann SurroundingText a) -> m (NonEmpty (Ann SurroundingText a)) +parsecLeadingCommaNonEmptyAnn p = + P.optional comma >>= \case + Nothing -> P.sepEndByNonEmptyAnn lp comma + Just _ -> P.sepByNonEmptyAnn lp comma + where + lp :: m (Ann SurroundingText a) + lp = parsecSpacesAnn p + + comma :: m String + 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 +parsecOptCommaListAnn :: forall m a. CabalParsing m => m (Ann SurroundingText a) -> m [Ann SurroundingText a] +parsecOptCommaListAnn p = P.sepByAnn lp (comma <|> pure "") + where + lp :: m (Ann SurroundingText a) + lp = parsecSpacesAnn p + + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + -- | Like 'parsecOptCommaList' but -- -- * require all or none commas @@ -377,6 +469,27 @@ parsecLeadingOptCommaList p = do Nothing -> (x :) <$> many lp Just _ -> (x :) <$> P.sepEndBy lp comma +parsecLeadingOptCommaListAnn :: forall m a. CabalParsing m => m (Ann SurroundingText a) -> m [Ann SurroundingText a] +parsecLeadingOptCommaListAnn p = + P.optional comma >>= \case + Nothing -> sepEndBy1StartAnn <|> pure [] + Just c -> + let insertTriviaHead (x :| xs) = mapAnn (preTrivia c <>) x :| xs + in toList . insertTriviaHead <$> P.sepByNonEmptyAnn lp comma + where + lp :: m (Ann SurroundingText a) + lp = parsecSpacesAnn p + + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + + sepEndBy1StartAnn :: m [Ann SurroundingText a] + sepEndBy1StartAnn = do + x <- lp + P.optional comma >>= \case + Nothing -> (x :) <$> many lp + Just c -> (mapAnn (<> postTrivia c) x :) <$> P.sepEndByAnn lp comma + -- | Content isn't unquoted parsecQuoted :: CabalParsing m => m a -> m a parsecQuoted = P.between (P.char '"') (P.char '"') diff --git a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs index c42d33ad7b9..3c6345f2282 100644 --- a/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs +++ b/Cabal-syntax/src/Distribution/Parsec/FieldLineStream.hs @@ -7,12 +7,14 @@ module Distribution.Parsec.FieldLineStream ( FieldLineStream (..) , fieldLineStreamFromString + , fieldLineStreamPosition , fieldLineStreamFromBS , fieldLineStreamEnd ) where import Data.ByteString (ByteString) import Distribution.Compat.Prelude +import Distribution.Parsec.Position import Distribution.Utils.Generic (toUTF8BS) import Prelude () @@ -22,30 +24,34 @@ import qualified Text.Parsec as Parsec -- | This is essentially a lazy bytestring, but chunks are glued with newline @\'\\n\'@. data FieldLineStream - = FLSLast !ByteString - | FLSCons {-# UNPACK #-} !ByteString FieldLineStream + = FLSLast !ByteString !Position + | FLSCons {-# UNPACK #-} !ByteString !Position FieldLineStream deriving (Show) -fieldLineStreamEnd :: FieldLineStream +fieldLineStreamPosition :: FieldLineStream -> Position +fieldLineStreamPosition (FLSLast _ pos) = pos +fieldLineStreamPosition (FLSCons _ pos _) = pos + +fieldLineStreamEnd :: Position -> FieldLineStream fieldLineStreamEnd = FLSLast mempty -- | Convert 'String' to 'FieldLineStream'. -- -- /Note:/ inefficient! fieldLineStreamFromString :: String -> FieldLineStream -fieldLineStreamFromString = FLSLast . toUTF8BS +fieldLineStreamFromString = flip FLSLast (Position 1 1) . toUTF8BS fieldLineStreamFromBS :: ByteString -> FieldLineStream -fieldLineStreamFromBS = FLSLast +fieldLineStreamFromBS = flip FLSLast (Position 1 1) instance Monad m => Parsec.Stream FieldLineStream m Char where - uncons (FLSLast bs) = return $ case BS.uncons bs of + uncons (FLSLast bs pos) = return $ case BS.uncons bs of Nothing -> Nothing - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'') fieldLineStreamEnd) - uncons (FLSCons bs s) = return $ case BS.uncons bs of + Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSLast bs'' pos) (fieldLineStreamEnd pos)) + uncons (FLSCons bs pos s) = return $ case BS.uncons bs of -- as lines are glued with '\n', we return '\n' here! Nothing -> Just ('\n', s) - Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' s) s) + Just (c, bs') -> Just (unconsChar c bs' (\bs'' -> FLSCons bs'' pos s) s) unconsChar :: forall a. Word8 -> ByteString -> (ByteString -> a) -> a -> (Char, a) unconsChar c0 bs0 f next = go (utf8DecodeStart c0) bs0 diff --git a/Cabal-syntax/src/Distribution/Parsec/Position.hs b/Cabal-syntax/src/Distribution/Parsec/Position.hs index 892fc8b8fda..dad05cb0bdb 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Position.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Position.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Parsec.Position @@ -18,7 +19,7 @@ data Position = Position {-# UNPACK #-} !Int -- row {-# UNPACK #-} !Int -- column - deriving (Eq, Ord, Show, Generic) + deriving (Eq, Ord, Show, Generic, Data, Read) instance Binary Position instance NFData Position where rnf = genericRnf @@ -34,6 +35,7 @@ retPos (Position row _col) = Position (row + 1) 1 showPos :: Position -> String showPos (Position row col) = show row ++ ":" ++ show col +-- | Only used for error values zeroPos :: Position zeroPos = Position 0 0 diff --git a/Cabal-syntax/src/Distribution/Pretty/ExactDoc.hs b/Cabal-syntax/src/Distribution/Pretty/ExactDoc.hs new file mode 100644 index 00000000000..a1b34bd4384 --- /dev/null +++ b/Cabal-syntax/src/Distribution/Pretty/ExactDoc.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- This module is a twist on the existing pretty library, mainly making it +-- possible to place elements relatively. +module Distribution.Pretty.ExactDoc + ( -- * Type + ExactDoc (..) + -- TODO: hide the constructors in an internal module + + -- * Constructors + , text + , multilineText + , nil + + -- * Primitive combinators + , concatDoc + , stickyConcatDoc + , place + , nest + + -- * Helpers + , newline + , sep + + -- * Rendering + , renderText + ) +where + +import Distribution.Parsec.Position + +import Control.Applicative +import Control.Monad +import Control.Monad.Trans.State.Strict +import Data.List (intersperse) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import GHC.Generics + +data ExactDoc where + -- | Turn a Text into a document + Text :: !T.Text -> ExactDoc + -- | The empty document, 0 in width and height + Nil :: ExactDoc + -- | Force the layout engine to render a newline + Newline :: ExactDoc + -- | Join two documents together loosely. + Concat :: !ExactDoc -> !ExactDoc -> ExactDoc + -- | Stick to documents together. Placement and nesting distributes over this operator. + StickyConcat :: !ExactDoc -> !ExactDoc -> ExactDoc + -- | The document should be placed at (Row, Col) + Place :: !Int -> !Int -> !ExactDoc -> ExactDoc + -- | The document should be indented with n more spaces + Nest :: !Int -> !ExactDoc -> ExactDoc + deriving (Show, Eq, Generic) + +instance Semigroup ExactDoc where + (<>) = concatDoc + +instance Monoid ExactDoc where + mempty = Nil + mconcat = foldl concatDoc Nil + +type RenderState = Position + +-- | +-- Outputs the padding Text to currect the cursor position if needed, +-- changes the state otherwise. +updateCursorRow :: Int -> State RenderState Text +updateCursorRow row = do + Position currentRow currentCol <- get + let rowDiff = row - currentRow + padding = T.replicate rowDiff "\n" + + when (rowDiff /= 0) $ + -- Jumped, we move cursor forward (or also backward) to desired row and reset col. + -- It is important to move the cursor back in case of a backward jump, because it + -- guarantees the rest of the document to be agnostic to this jump. + put (Position row 1) + + pure padding + +updateCursorCol :: Int -> State RenderState Text +updateCursorCol col = do + Position currentRow currentCol <- get + let colDiff = col - currentCol + padding = T.replicate colDiff " " + + when (colDiff > 0) $ + put (Position currentRow col) + + pure padding + +renderText :: ExactDoc -> Text +renderText doc = evalState (renderTextStep doc) state0 + where + state0 = Position 1 1 -- the parser is 1,1 indexed + +renderTextStep :: ExactDoc -> State RenderState Text +renderTextStep d0 = case d0 of + Nil -> pure mempty + Place atRow atCol d -> + liftA3 + (\x y z -> x <> y <> z) + (updateCursorRow atRow) + (updateCursorCol atCol) + (renderTextStep d) + Nest indentSize d -> + get >>= \(Position row col) -> + liftA2 (<>) (updateCursorCol (col + indentSize)) (renderTextStep d) + Text t -> do + modify $ + \(Position row col) -> Position row (col + T.length t) + pure t + Concat d1 d2 -> liftA2 (<>) (renderTextStep d1) (renderTextStep d2) + StickyConcat d1 d2 -> liftA2 (<>) (renderTextStep d1) (renderTextStep d2) + Newline -> get >>= \(Position row col) -> updateCursorRow (row + 1) + +-- | Invariant: this assumes the input text doesn't have more than one line +text :: T.Text -> ExactDoc +text = Text + +-- TODO(leana8959): this was made for multiline fieldline content, but is no longer used. +-- multiline fieldlines are individual strings with exact positioning +multilineText :: [T.Text] -> ExactDoc +multilineText = foldr stickyConcatDoc Nil . intersperse Newline . map Text + +-- We use the exact offset primitive to define the newline primitive +newline :: ExactDoc +newline = Newline + +nil :: ExactDoc +nil = Nil + +concatDoc :: ExactDoc -> ExactDoc -> ExactDoc +concatDoc d1 d2 = case (d1, d2) of + (Nil, _) -> d2 + (_, Nil) -> d1 + _ -> d1 `Concat` d2 + +stickyConcatDoc :: ExactDoc -> ExactDoc -> ExactDoc +stickyConcatDoc d1 d2 = case (d1, d2) of + (Nil, _) -> d2 + (_, Nil) -> d1 + _ -> d1 `StickyConcat` d2 + +-- | Absolute offset "row, col" from the previous item +place :: Int -> Int -> ExactDoc -> ExactDoc +place s t d0 = case d0 of + Nil -> Nil + Place u v d -> place u v d -- Once placed, can't be moved + StickyConcat d1 d2 -> place s t d1 `StickyConcat` place s t d2 + _ -> Place s t d0 + +nest :: Int -> ExactDoc -> ExactDoc +nest k d0 = case d0 of + Nest m d -> nest (k + m) d + Nil -> Nil + Place u v d -> Place u v d -- Once placed, can't be moved + Concat d1 d2 -> nest k d1 <> nest k d2 + StickyConcat d1 d2 -> nest k d1 `StickyConcat` nest k d2 + _ -> Nest k d0 + +sep :: ExactDoc -> [ExactDoc] -> ExactDoc +sep by = mconcat . intersperse by diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs new file mode 100644 index 00000000000..9f196c129ce --- /dev/null +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} + +module Distribution.Trivia + ( SurroundingText (..) + , Positions (..) + , Trivia (..) + , preTrivia + , postTrivia + , Ann (..) + , mapAnn + , mapAnnA + , applyTriviaDoc + ) +where + +import Control.Applicative +import Data.Data +import Data.Monoid (Last (..)) +import Distribution.Parsec.Position +import qualified Text.PrettyPrint as Disp + +-- | Leading and trailing whitespaces +data SurroundingText = SurroundingText String String + deriving (Show, Eq, Ord, Read, Data) + +instance Semigroup SurroundingText where + SurroundingText s t <> SurroundingText a b = SurroundingText (s <> a) (t <> b) + +-- | A collection of different kinds of 'Position's, describing +-- the provenance of a data. +data Positions = Positions + { sectionPos :: Maybe Position + , fieldNamePos :: Position + , fieldLinePos :: Position + } + deriving (Show, Eq, Ord, Read, Data) + +data Trivia t + = HasTrivia t + | ExactRepresentation String + | IsInserted + | NoTrivia + deriving (Show, Eq, Ord, Read, Data, Functor) + +preTrivia :: String -> Trivia SurroundingText +preTrivia s = HasTrivia (SurroundingText s mempty) + +postTrivia :: String -> Trivia SurroundingText +postTrivia s = HasTrivia (SurroundingText mempty s) + +instance Semigroup t => Semigroup (Trivia t) where + HasTrivia x <> HasTrivia y = HasTrivia (x <> y) + ExactRepresentation u <> ExactRepresentation v = ExactRepresentation (u <> v) + u@(ExactRepresentation _) <> _ = u + _ <> v@(ExactRepresentation _) = v + NoTrivia <> v = v + u <> NoTrivia = u + IsInserted <> _ = IsInserted + _ <> IsInserted = IsInserted + +instance (Semigroup t, Semigroup u) => Semigroup (Ann t u) where + Ann u x <> Ann v y = Ann (u <> v) (x <> y) + +instance Semigroup t => Monoid (Trivia t) where + mempty = NoTrivia + +data Ann t a = Ann + { getAnn :: Trivia t + , unAnn :: a + } + deriving (Show, Eq, Ord, Functor, Read, Data) + +instance Semigroup t => Applicative (Ann t) where + pure = Ann mempty + Ann u x <*> Ann v y = Ann (u <> v) (x y) + +mapAnn + :: (Trivia s -> Trivia t) + -> Ann s a + -> Ann t a +mapAnn f (Ann t x) = Ann (f t) x + +mapAnnA + :: (Trivia s -> Trivia t) + -> (a -> b) + -> Ann s a + -> Ann t b +mapAnnA f g (Ann t x) = Ann (f t) (g x) + +applyTriviaDoc + :: Trivia SurroundingText + -> Disp.Doc + -> Disp.Doc +applyTriviaDoc t = case t of + HasTrivia (SurroundingText pre post) -> \d -> Disp.text pre <> d <> Disp.text post + ExactRepresentation repr -> const (Disp.text repr) + IsInserted -> const Disp.empty + NoTrivia -> id diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/Cabal-syntax/src/Distribution/Types/Benchmark.hs index 6da7ef9dcae..daf58c4af58 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -1,8 +1,15 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.Benchmark - ( Benchmark (..) + ( Benchmark + , BenchmarkWith (..) , emptyBenchmark , benchmarkType , benchmarkModules @@ -15,25 +22,35 @@ import Prelude () import Distribution.Types.BenchmarkInterface import Distribution.Types.BenchmarkType import Distribution.Types.BuildInfo +import qualified Distribution.Types.Modify as Mod import Distribution.Types.UnqualComponentName import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L +type Benchmark = BenchmarkWith Mod.HasNoAnn + -- | A \"benchmark\" stanza in a cabal file. -data Benchmark = Benchmark +data BenchmarkWith (mod :: Mod.HasAnnotation) = Benchmark { benchmarkName :: UnqualComponentName , benchmarkInterface :: BenchmarkInterface - , benchmarkBuildInfo :: BuildInfo + , benchmarkBuildInfo :: BuildInfoWith mod } - deriving (Generic, Show, Read, Eq, Ord, Data) +deriving instance Generic Benchmark +deriving instance Show Benchmark +deriving instance Read Benchmark +deriving instance Eq Benchmark +deriving instance Ord Benchmark +deriving instance Data Benchmark + +deriving instance Show (BenchmarkWith Mod.HasAnn) instance Binary Benchmark instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf -instance L.HasBuildInfo Benchmark where +instance forall (mod :: Mod.HasAnnotation). L.HasBuildInfoWith mod (BenchmarkWith mod) where buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) instance Monoid Benchmark where @@ -45,6 +62,15 @@ instance Monoid Benchmark where } mappend = (<>) +instance Monoid (BenchmarkWith Mod.HasAnn) where + mempty = + Benchmark + { benchmarkName = mempty + , benchmarkInterface = mempty + , benchmarkBuildInfo = mempty + } + mappend = (<>) + instance Semigroup Benchmark where a <> b = Benchmark @@ -55,6 +81,16 @@ instance Semigroup Benchmark where where combine field = field a `mappend` field b +instance Semigroup (BenchmarkWith Mod.HasAnn) where + a <> b = + Benchmark + { benchmarkName = combineNames a b benchmarkName "benchmark" + , benchmarkInterface = combine benchmarkInterface + , benchmarkBuildInfo = combine benchmarkBuildInfo + } + where + combine field = field a `mappend` field b + emptyBenchmark :: Benchmark emptyBenchmark = mempty diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs b/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs index 40b17330fec..6d3aee5ed48 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark/Lens.hs @@ -7,21 +7,21 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.Benchmark (Benchmark, BenchmarkWith) import Distribution.Types.BenchmarkInterface (BenchmarkInterface) -import Distribution.Types.BuildInfo (BuildInfo) +import Distribution.Types.BuildInfo (BuildInfo, BuildInfoWith) import Distribution.Types.UnqualComponentName (UnqualComponentName) import qualified Distribution.Types.Benchmark as T -benchmarkName :: Lens' Benchmark UnqualComponentName +benchmarkName :: Lens' (BenchmarkWith mod) UnqualComponentName benchmarkName f s = fmap (\x -> s{T.benchmarkName = x}) (f (T.benchmarkName s)) {-# INLINE benchmarkName #-} -benchmarkInterface :: Lens' Benchmark BenchmarkInterface +benchmarkInterface :: Lens' (BenchmarkWith mod) BenchmarkInterface benchmarkInterface f s = fmap (\x -> s{T.benchmarkInterface = x}) (f (T.benchmarkInterface s)) {-# INLINE benchmarkInterface #-} -benchmarkBuildInfo :: Lens' Benchmark BuildInfo +benchmarkBuildInfo :: Lens' (BenchmarkWith mod) (BuildInfoWith mod) benchmarkBuildInfo f s = fmap (\x -> s{T.benchmarkBuildInfo = x}) (f (T.benchmarkBuildInfo s)) {-# INLINE benchmarkBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index e68fcbc5c22..195dfa21eca 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -1,9 +1,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Types.BuildInfo - ( BuildInfo (..) + ( BuildInfo + , BuildInfoAnn + , BuildInfoWith (..) + , unannotateBuildInfo + , unannotateDependencyAnn , emptyBuildInfo , allLanguages , allExtensions @@ -16,9 +25,13 @@ module Distribution.Types.BuildInfo , hcStaticOptions ) where +import qualified Data.Semigroup as Semigroup (Last(..)) +import Data.Monoid (All (..)) + import Distribution.Compat.Prelude import Prelude () +import Distribution.Trivia import Distribution.Types.Dependency import Distribution.Types.ExeDependency import Distribution.Types.LegacyExeDependency @@ -30,11 +43,23 @@ import Distribution.Compiler import Distribution.ModuleName import Language.Haskell.Extension +import Data.Kind + +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping, AttachPosition) +import qualified Distribution.Types.Modify as Mod + +type BuildInfo = BuildInfoWith Mod.HasNoAnn +type BuildInfoAnn = BuildInfoWith Mod.HasAnn + +-- type family TargetBuildDepends (mod :: Mod.HasAnnotation) where +-- TargetBuildDepends Mod.HasAnn = [(Positions, [DependencyWith Mod.HasAnn])] +-- TargetBuildDepends Mod.HasNoAnn = [DependencyWith Mod.HasNoAnn] + -- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo - { buildable :: Bool +data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo + { buildable :: PreserveGrouping m (AnnotateWith Positions m Bool) -- ^ component is buildable here - , buildTools :: [LegacyExeDependency] + , buildTools :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m LegacyExeDependency)]) -- ^ Tools needed to build this bit. -- -- This is a legacy field that 'buildToolDepends' largely supersedes. @@ -42,7 +67,7 @@ data BuildInfo = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , buildToolDepends :: [ExeDependency] + , buildToolDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m ExeDependency)]) -- ^ Haskell tools needed to build this bit -- -- This field is better than 'buildTools' because it allows one to @@ -51,40 +76,40 @@ data BuildInfo = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , cppOptions :: [String] + , cppOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for pre-processing Haskell code - , asmOptions :: [String] + , asmOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for assembler - , cmmOptions :: [String] + , cmmOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for C-- compiler - , ccOptions :: [String] + , ccOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for C compiler - , cxxOptions :: [String] + , cxxOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for C++ compiler - , jsppOptions :: [String] + , jsppOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for pre-processing JavaScript code @since 3.16.0.0 - , ldOptions :: [String] + , ldOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for linker - , hsc2hsOptions :: [String] + , hsc2hsOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for hsc2hs - , pkgconfigDepends :: [PkgconfigDependency] + , pkgconfigDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m PkgconfigDependency)]) -- ^ pkg-config packages that are used - , frameworks :: [RelativePath Framework File] + , frameworks :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (RelativePath Framework File))]) -- ^ support frameworks for Mac OS X - , extraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)] + , extraFrameworkDirs :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg (Dir Framework)))]) -- ^ extra locations to find frameworks. - , asmSources :: [SymbolicPath Pkg File] + , asmSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) -- ^ Assembly files. - , cmmSources :: [SymbolicPath Pkg File] + , cmmSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) -- ^ C-- files. - , cSources :: [SymbolicPath Pkg File] - , cxxSources :: [SymbolicPath Pkg File] - , jsSources :: [SymbolicPath Pkg File] - , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] + , cSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) + , cxxSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) + , jsSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) + , hsSourceDirs :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg (Dir Source)))]) -- ^ where to look for the Haskell module hierarchy , -- NB: these are symbolic paths are not relative paths, -- because autogenerated modules might end up in an absolute path - otherModules :: [ModuleName] + otherModules :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m ModuleName)]) -- ^ non-exposed or non-main modules , virtualModules :: [ModuleName] -- ^ exposed modules that do not have a source file (e.g. @GHC.Prim@ from @ghc-prim@ package) @@ -142,16 +167,56 @@ data BuildInfo = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: [Dependency] + , targetBuildDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (DependencyWith m))]) -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } - deriving (Generic, Show, Read, Eq, Ord, Data) + deriving (Generic) + +deriving instance Show BuildInfo +deriving instance Read BuildInfo +deriving instance Eq BuildInfo +deriving instance Ord BuildInfo +deriving instance Data BuildInfo + +deriving instance Show (BuildInfoWith Mod.HasAnn) instance Binary BuildInfo instance Structured BuildInfo instance NFData BuildInfo where rnf = genericRnf +unannotateBuildInfo :: BuildInfoAnn -> BuildInfo +unannotateBuildInfo bi = + let unannotateMonoidalField = map (unAnn . snd) . join . map snd + in + bi + { buildable = foldl (&&) False $ map unAnn $ buildable bi + , buildTools = unannotateMonoidalField $ buildTools bi + , buildToolDepends = unannotateMonoidalField $ buildToolDepends bi + , cppOptions = unannotateMonoidalField $ cppOptions bi + , asmOptions = unannotateMonoidalField $ asmOptions bi + , cmmOptions = unannotateMonoidalField $ cmmOptions bi + , ccOptions = unannotateMonoidalField $ ccOptions bi + , cxxOptions = unannotateMonoidalField $ cxxOptions bi + , jsppOptions = unannotateMonoidalField $ jsppOptions bi + , ldOptions = unannotateMonoidalField $ ldOptions bi + , hsc2hsOptions = unannotateMonoidalField $ hsc2hsOptions bi + , pkgconfigDepends = unannotateMonoidalField $ pkgconfigDepends bi + , frameworks = unannotateMonoidalField $ frameworks bi + , extraFrameworkDirs = unannotateMonoidalField $ extraFrameworkDirs bi + , asmSources = unannotateMonoidalField $ asmSources bi + , cmmSources = unannotateMonoidalField $ cmmSources bi + , cSources = unannotateMonoidalField $ cSources bi + , cxxSources = unannotateMonoidalField $ cxxSources bi + , jsSources = unannotateMonoidalField $ jsSources bi + , hsSourceDirs = unannotateMonoidalField $ hsSourceDirs bi + , otherModules = unannotateMonoidalField $ otherModules bi + , -- TODO(leana8959): add more fields here + + -- [(Positions, (Position, Ann t dep))] + targetBuildDepends = map (unannotateDependencyAnn . unAnn . snd) $ join $ map snd $ targetBuildDepends bi + } + instance Monoid BuildInfo where mempty = BuildInfo @@ -206,6 +271,9 @@ instance Monoid BuildInfo where } mappend = (<>) +instance Monoid (BuildInfoWith Mod.HasAnn) where + mempty = emptyBuildInfo' + instance Semigroup BuildInfo where a <> b = BuildInfo @@ -259,6 +327,65 @@ instance Semigroup BuildInfo where , mixins = combine mixins } where + combine :: Monoid a => (BuildInfo -> a) -> a + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + +instance Semigroup (BuildInfoWith Mod.HasAnn) where + a <> b = + BuildInfo + { buildable = combine buildable + , buildTools = combine buildTools + , buildToolDepends = combine buildToolDepends + , cppOptions = combine cppOptions + , asmOptions = combine asmOptions + , cmmOptions = combine cmmOptions + , ccOptions = combine ccOptions + , cxxOptions = combine cxxOptions + , jsppOptions = combine jsppOptions + , ldOptions = combine ldOptions + , hsc2hsOptions = combine hsc2hsOptions + , pkgconfigDepends = combine pkgconfigDepends + , frameworks = combineNub frameworks + , extraFrameworkDirs = combineNub extraFrameworkDirs + , asmSources = combineNub asmSources + , cmmSources = combineNub cmmSources + , cSources = combineNub cSources + , cxxSources = combineNub cxxSources + , jsSources = combineNub jsSources + , hsSourceDirs = combineNub hsSourceDirs + , otherModules = combineNub otherModules + , virtualModules = combineNub virtualModules + , autogenModules = combineNub autogenModules + , defaultLanguage = combineMby defaultLanguage + , otherLanguages = combineNub otherLanguages + , defaultExtensions = combineNub defaultExtensions + , otherExtensions = combineNub otherExtensions + , oldExtensions = combineNub oldExtensions + , extraLibs = combine extraLibs + , extraLibsStatic = combine extraLibsStatic + , extraGHCiLibs = combine extraGHCiLibs + , extraBundledLibs = combine extraBundledLibs + , extraLibFlavours = combine extraLibFlavours + , extraDynLibFlavours = combine extraDynLibFlavours + , extraLibDirs = combineNub extraLibDirs + , extraLibDirsStatic = combineNub extraLibDirsStatic + , includeDirs = combineNub includeDirs + , includes = combineNub includes + , autogenIncludes = combineNub autogenIncludes + , installIncludes = combineNub installIncludes + , options = combine options + , profOptions = combine profOptions + , sharedOptions = combine sharedOptions + , profSharedOptions = combine profSharedOptions + , staticOptions = combine staticOptions + , customFieldsBI = combine customFieldsBI + , targetBuildDepends = combineNub targetBuildDepends + , mixins = combine mixins + } + where + combine :: Monoid a => (BuildInfoWith Mod.HasAnn -> a) -> a combine field = field a `mappend` field b combineNub field = nub (combine field) combineMby field = field b `mplus` field a @@ -266,6 +393,59 @@ instance Semigroup BuildInfo where emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty +emptyBuildInfo' :: BuildInfoWith Mod.HasAnn +emptyBuildInfo' = + BuildInfo + { buildable = [] + , buildTools = [] + , buildToolDepends = [] + , cppOptions = [] + , asmOptions = [] + , cmmOptions = [] + , ccOptions = [] + , cxxOptions = [] + , jsppOptions = [] + , ldOptions = [] + , hsc2hsOptions = [] + , pkgconfigDepends = [] + , frameworks = [] + , extraFrameworkDirs = [] + , asmSources = [] + , cmmSources = [] + , cSources = [] + , cxxSources = [] + , jsSources = [] + , hsSourceDirs = [] + , otherModules = [] + , virtualModules = [] + , autogenModules = [] + , defaultLanguage = Nothing + , otherLanguages = [] + , defaultExtensions = [] + , otherExtensions = [] + , oldExtensions = [] + , extraLibs = [] + , extraLibsStatic = [] + , extraGHCiLibs = [] + , extraBundledLibs = [] + , extraLibFlavours = [] + , extraDynLibFlavours = [] + , extraLibDirs = [] + , extraLibDirsStatic = [] + , includeDirs = [] + , includes = [] + , autogenIncludes = [] + , installIncludes = [] + , options = mempty + , profOptions = mempty + , sharedOptions = mempty + , profSharedOptions = mempty + , staticOptions = mempty + , customFieldsBI = [] + , targetBuildDepends = [] + , mixins = [] + } + -- | The 'Language's used by this component allLanguages :: BuildInfo -> [Language] allLanguages bi = diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index e554f43ebdf..489c4cfa003 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -1,9 +1,24 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Distribution.Types.BuildInfo.Lens ( BuildInfo - , HasBuildInfo (..) - , HasBuildInfos (..) + , HasBuildInfo + , HasBuildInfoAnn + , HasBuildInfoWith (..) + , HasBuildInfos + , HasBuildInfosAnn + , HasBuildInfosWith (..) ) where import Distribution.Compat.Lens @@ -12,8 +27,8 @@ import Prelude () import Distribution.Compiler (PerCompilerFlavor) import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Dependency (Dependency) +import Distribution.Types.BuildInfo (BuildInfo, BuildInfoWith) +import Distribution.Types.Dependency (DependencyWith) import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.LegacyExeDependency (LegacyExeDependency) import Distribution.Types.Mixin (Mixin) @@ -21,205 +36,313 @@ import Distribution.Types.PkgconfigDependency (PkgconfigDependency) import Distribution.Utils.Path import Language.Haskell.Extension (Extension, Language) +import Distribution.Trivia import qualified Distribution.Types.BuildInfo as T +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping, AttachPosition) +import qualified Distribution.Types.Modify as Mod --- | Classy lenses for 'BuildInfo'. -class HasBuildInfo a where - buildInfo :: Lens' a BuildInfo +type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn +type HasBuildInfoAnn = HasBuildInfoWith Mod.HasAnn - buildable :: Lens' a Bool - buildable = buildInfo . buildable +class HasBuildInfoWith mod a | a -> mod where + buildInfo :: Lens' a (BuildInfoWith mod) + + buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AnnotateWith Positions mod Bool)) + buildable = buildInfo @mod . buildable @mod + + buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod LegacyExeDependency)])) + buildTools = buildInfo @mod . buildTools @mod + + buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod ExeDependency)])) + buildToolDepends = buildInfo @mod . buildToolDepends @mod + + cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + cppOptions = buildInfo @mod . cppOptions @mod + + asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + asmOptions = buildInfo @mod . asmOptions @mod + + cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + cmmOptions = buildInfo @mod . cmmOptions @mod + + ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + ccOptions = buildInfo @mod . ccOptions @mod + + cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + cxxOptions = buildInfo @mod . cxxOptions @mod + + jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + jsppOptions = buildInfo @mod . jsppOptions @mod + + ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + ldOptions = buildInfo @mod . ldOptions @mod + + hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod String)])) + hsc2hsOptions = buildInfo @mod . hsc2hsOptions @mod + + pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod PkgconfigDependency)])) + pkgconfigDepends = buildInfo @mod . pkgconfigDepends @mod + + frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (RelativePath Framework File))])) + frameworks = buildInfo @mod . frameworks @mod + + extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Framework)))])) + extraFrameworkDirs = buildInfo @mod . extraFrameworkDirs @mod + + asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))])) + asmSources = buildInfo @mod . asmSources @mod + + cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))])) + cmmSources = buildInfo @mod . cmmSources @mod + + cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))])) + cSources = buildInfo @mod . cSources @mod + + cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))])) + cxxSources = buildInfo @mod . cxxSources @mod + + jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg File))])) + jsSources = buildInfo @mod . jsSources @mod + + hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (SymbolicPath Pkg (Dir Source)))])) + hsSourceDirs = buildInfo @mod . hsSourceDirs @mod + + otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod ModuleName)])) + otherModules = buildInfo @mod . otherModules @mod + + virtualModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ModuleName] + virtualModules = buildInfo @mod . virtualModules @mod + + autogenModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ModuleName] + autogenModules = buildInfo @mod . autogenModules @mod + + defaultLanguage :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (Maybe Language) + defaultLanguage = buildInfo @mod . defaultLanguage @mod + + otherLanguages :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Language] + otherLanguages = buildInfo @mod . otherLanguages @mod + + defaultExtensions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Extension] + defaultExtensions = buildInfo @mod . defaultExtensions @mod + + otherExtensions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Extension] + otherExtensions = buildInfo @mod . otherExtensions @mod + + oldExtensions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Extension] + oldExtensions = buildInfo @mod . oldExtensions @mod + + extraLibs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + extraLibs = buildInfo @mod . extraLibs @mod + + extraLibsStatic :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + extraLibsStatic = buildInfo @mod . extraLibsStatic @mod + + extraGHCiLibs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + extraGHCiLibs = buildInfo @mod . extraGHCiLibs @mod + + extraBundledLibs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + extraBundledLibs = buildInfo @mod . extraBundledLibs @mod + + extraLibFlavours :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + extraLibFlavours = buildInfo @mod . extraLibFlavours @mod + + extraDynLibFlavours :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + extraDynLibFlavours = buildInfo @mod . extraDynLibFlavours @mod + + extraLibDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Lib)] + extraLibDirs = buildInfo @mod . extraLibDirs @mod + + extraLibDirsStatic :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Lib)] + extraLibDirsStatic = buildInfo @mod . extraLibDirsStatic @mod + + includeDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Include)] + includeDirs = buildInfo @mod . includeDirs @mod + + includes :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Include File] + includes = buildInfo @mod . includes @mod + + autogenIncludes :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [RelativePath Include File] + autogenIncludes = buildInfo @mod . autogenIncludes @mod + + installIncludes :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [RelativePath Include File] + installIncludes = buildInfo @mod . installIncludes @mod + + options :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PerCompilerFlavor [String]) + options = buildInfo @mod . options @mod + + profOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PerCompilerFlavor [String]) + profOptions = buildInfo @mod . profOptions @mod + + sharedOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PerCompilerFlavor [String]) + sharedOptions = buildInfo @mod . sharedOptions @mod + + profSharedOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PerCompilerFlavor [String]) + profSharedOptions = buildInfo @mod . profSharedOptions @mod + + staticOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PerCompilerFlavor [String]) + staticOptions = buildInfo @mod . staticOptions @mod + + customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] + customFieldsBI = buildInfo @mod . customFieldsBI @mod + + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [AttachPosition mod (Annotate mod (DependencyWith mod))])) + targetBuildDepends = buildInfo @mod . targetBuildDepends @mod + + mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] + mixins = buildInfo @mod . mixins @mod + +instance HasBuildInfoWith Mod.HasNoAnn (BuildInfoWith Mod.HasNoAnn) where + buildInfo = id + {-# INLINE buildInfo #-} + + buildable f s = fmap (\x -> s{T.buildable = x}) (f (T.buildable s)) {-# INLINE buildable #-} - buildTools :: Lens' a [LegacyExeDependency] - buildTools = buildInfo . buildTools + buildTools f s = fmap (\x -> s{T.buildTools = x}) (f (T.buildTools s)) {-# INLINE buildTools #-} - buildToolDepends :: Lens' a [ExeDependency] - buildToolDepends = buildInfo . buildToolDepends + buildToolDepends f s = fmap (\x -> s{T.buildToolDepends = x}) (f (T.buildToolDepends s)) {-# INLINE buildToolDepends #-} - cppOptions :: Lens' a [String] - cppOptions = buildInfo . cppOptions + cppOptions f s = fmap (\x -> s{T.cppOptions = x}) (f (T.cppOptions s)) {-# INLINE cppOptions #-} - asmOptions :: Lens' a [String] - asmOptions = buildInfo . asmOptions + asmOptions f s = fmap (\x -> s{T.asmOptions = x}) (f (T.asmOptions s)) {-# INLINE asmOptions #-} - cmmOptions :: Lens' a [String] - cmmOptions = buildInfo . cmmOptions + cmmOptions f s = fmap (\x -> s{T.cmmOptions = x}) (f (T.cmmOptions s)) {-# INLINE cmmOptions #-} - ccOptions :: Lens' a [String] - ccOptions = buildInfo . ccOptions + ccOptions f s = fmap (\x -> s{T.ccOptions = x}) (f (T.ccOptions s)) {-# INLINE ccOptions #-} - cxxOptions :: Lens' a [String] - cxxOptions = buildInfo . cxxOptions + cxxOptions f s = fmap (\x -> s{T.cxxOptions = x}) (f (T.cxxOptions s)) {-# INLINE cxxOptions #-} - jsppOptions :: Lens' a [String] - jsppOptions = buildInfo . jsppOptions + jsppOptions f s = fmap (\x -> s{T.jsppOptions = x}) (f (T.jsppOptions s)) {-# INLINE jsppOptions #-} - ldOptions :: Lens' a [String] - ldOptions = buildInfo . ldOptions + ldOptions f s = fmap (\x -> s{T.ldOptions = x}) (f (T.ldOptions s)) {-# INLINE ldOptions #-} - hsc2hsOptions :: Lens' a [String] - hsc2hsOptions = buildInfo . hsc2hsOptions + hsc2hsOptions f s = fmap (\x -> s{T.hsc2hsOptions = x}) (f (T.hsc2hsOptions s)) {-# INLINE hsc2hsOptions #-} - pkgconfigDepends :: Lens' a [PkgconfigDependency] - pkgconfigDepends = buildInfo . pkgconfigDepends + pkgconfigDepends f s = fmap (\x -> s{T.pkgconfigDepends = x}) (f (T.pkgconfigDepends s)) {-# INLINE pkgconfigDepends #-} - frameworks :: Lens' a [RelativePath Framework File] - frameworks = buildInfo . frameworks + frameworks f s = fmap (\x -> s{T.frameworks = x}) (f (T.frameworks s)) {-# INLINE frameworks #-} - extraFrameworkDirs :: Lens' a [SymbolicPath Pkg (Dir Framework)] - extraFrameworkDirs = buildInfo . extraFrameworkDirs + extraFrameworkDirs f s = fmap (\x -> s{T.extraFrameworkDirs = x}) (f (T.extraFrameworkDirs s)) {-# INLINE extraFrameworkDirs #-} - asmSources :: Lens' a [SymbolicPath Pkg File] - asmSources = buildInfo . asmSources + asmSources f s = fmap (\x -> s{T.asmSources = x}) (f (T.asmSources s)) {-# INLINE asmSources #-} - cmmSources :: Lens' a [SymbolicPath Pkg File] - cmmSources = buildInfo . cmmSources + cmmSources f s = fmap (\x -> s{T.cmmSources = x}) (f (T.cmmSources s)) {-# INLINE cmmSources #-} - cSources :: Lens' a [SymbolicPath Pkg File] - cSources = buildInfo . cSources + cSources f s = fmap (\x -> s{T.cSources = x}) (f (T.cSources s)) {-# INLINE cSources #-} - cxxSources :: Lens' a [SymbolicPath Pkg File] - cxxSources = buildInfo . cxxSources + cxxSources f s = fmap (\x -> s{T.cxxSources = x}) (f (T.cxxSources s)) {-# INLINE cxxSources #-} - jsSources :: Lens' a [SymbolicPath Pkg File] - jsSources = buildInfo . jsSources + jsSources f s = fmap (\x -> s{T.jsSources = x}) (f (T.jsSources s)) {-# INLINE jsSources #-} - hsSourceDirs :: Lens' a [SymbolicPath Pkg (Dir Source)] - hsSourceDirs = buildInfo . hsSourceDirs + hsSourceDirs f s = fmap (\x -> s{T.hsSourceDirs = x}) (f (T.hsSourceDirs s)) {-# INLINE hsSourceDirs #-} - otherModules :: Lens' a [ModuleName] - otherModules = buildInfo . otherModules + otherModules f s = fmap (\x -> s{T.otherModules = x}) (f (T.otherModules s)) {-# INLINE otherModules #-} - virtualModules :: Lens' a [ModuleName] - virtualModules = buildInfo . virtualModules + virtualModules f s = fmap (\x -> s{T.virtualModules = x}) (f (T.virtualModules s)) {-# INLINE virtualModules #-} - autogenModules :: Lens' a [ModuleName] - autogenModules = buildInfo . autogenModules + autogenModules f s = fmap (\x -> s{T.autogenModules = x}) (f (T.autogenModules s)) {-# INLINE autogenModules #-} - defaultLanguage :: Lens' a (Maybe Language) - defaultLanguage = buildInfo . defaultLanguage + defaultLanguage f s = fmap (\x -> s{T.defaultLanguage = x}) (f (T.defaultLanguage s)) {-# INLINE defaultLanguage #-} - otherLanguages :: Lens' a [Language] - otherLanguages = buildInfo . otherLanguages + otherLanguages f s = fmap (\x -> s{T.otherLanguages = x}) (f (T.otherLanguages s)) {-# INLINE otherLanguages #-} - defaultExtensions :: Lens' a [Extension] - defaultExtensions = buildInfo . defaultExtensions + defaultExtensions f s = fmap (\x -> s{T.defaultExtensions = x}) (f (T.defaultExtensions s)) {-# INLINE defaultExtensions #-} - otherExtensions :: Lens' a [Extension] - otherExtensions = buildInfo . otherExtensions + otherExtensions f s = fmap (\x -> s{T.otherExtensions = x}) (f (T.otherExtensions s)) {-# INLINE otherExtensions #-} - oldExtensions :: Lens' a [Extension] - oldExtensions = buildInfo . oldExtensions + oldExtensions f s = fmap (\x -> s{T.oldExtensions = x}) (f (T.oldExtensions s)) {-# INLINE oldExtensions #-} - extraLibs :: Lens' a [String] - extraLibs = buildInfo . extraLibs + extraLibs f s = fmap (\x -> s{T.extraLibs = x}) (f (T.extraLibs s)) {-# INLINE extraLibs #-} - extraLibsStatic :: Lens' a [String] - extraLibsStatic = buildInfo . extraLibsStatic + extraLibsStatic f s = fmap (\x -> s{T.extraLibsStatic = x}) (f (T.extraLibsStatic s)) {-# INLINE extraLibsStatic #-} - extraGHCiLibs :: Lens' a [String] - extraGHCiLibs = buildInfo . extraGHCiLibs + extraGHCiLibs f s = fmap (\x -> s{T.extraGHCiLibs = x}) (f (T.extraGHCiLibs s)) {-# INLINE extraGHCiLibs #-} - extraBundledLibs :: Lens' a [String] - extraBundledLibs = buildInfo . extraBundledLibs + extraBundledLibs f s = fmap (\x -> s{T.extraBundledLibs = x}) (f (T.extraBundledLibs s)) {-# INLINE extraBundledLibs #-} - extraLibFlavours :: Lens' a [String] - extraLibFlavours = buildInfo . extraLibFlavours + extraLibFlavours f s = fmap (\x -> s{T.extraLibFlavours = x}) (f (T.extraLibFlavours s)) {-# INLINE extraLibFlavours #-} - extraDynLibFlavours :: Lens' a [String] - extraDynLibFlavours = buildInfo . extraDynLibFlavours + extraDynLibFlavours f s = fmap (\x -> s{T.extraDynLibFlavours = x}) (f (T.extraDynLibFlavours s)) {-# INLINE extraDynLibFlavours #-} - extraLibDirs :: Lens' a [SymbolicPath Pkg (Dir Lib)] - extraLibDirs = buildInfo . extraLibDirs + extraLibDirs f s = fmap (\x -> s{T.extraLibDirs = x}) (f (T.extraLibDirs s)) {-# INLINE extraLibDirs #-} - extraLibDirsStatic :: Lens' a [SymbolicPath Pkg (Dir Lib)] - extraLibDirsStatic = buildInfo . extraLibDirsStatic + extraLibDirsStatic f s = fmap (\x -> s{T.extraLibDirsStatic = x}) (f (T.extraLibDirsStatic s)) {-# INLINE extraLibDirsStatic #-} - includeDirs :: Lens' a [SymbolicPath Pkg (Dir Include)] - includeDirs = buildInfo . includeDirs + includeDirs f s = fmap (\x -> s{T.includeDirs = x}) (f (T.includeDirs s)) {-# INLINE includeDirs #-} - includes :: Lens' a [SymbolicPath Include File] - includes = buildInfo . includes + includes f s = fmap (\x -> s{T.includes = x}) (f (T.includes s)) {-# INLINE includes #-} - autogenIncludes :: Lens' a [RelativePath Include File] - autogenIncludes = buildInfo . autogenIncludes + autogenIncludes f s = fmap (\x -> s{T.autogenIncludes = x}) (f (T.autogenIncludes s)) {-# INLINE autogenIncludes #-} - installIncludes :: Lens' a [RelativePath Include File] - installIncludes = buildInfo . installIncludes + installIncludes f s = fmap (\x -> s{T.installIncludes = x}) (f (T.installIncludes s)) {-# INLINE installIncludes #-} - options :: Lens' a (PerCompilerFlavor [String]) - options = buildInfo . options + options f s = fmap (\x -> s{T.options = x}) (f (T.options s)) {-# INLINE options #-} - profOptions :: Lens' a (PerCompilerFlavor [String]) - profOptions = buildInfo . profOptions + profOptions f s = fmap (\x -> s{T.profOptions = x}) (f (T.profOptions s)) {-# INLINE profOptions #-} - sharedOptions :: Lens' a (PerCompilerFlavor [String]) - sharedOptions = buildInfo . sharedOptions + sharedOptions f s = fmap (\x -> s{T.sharedOptions = x}) (f (T.sharedOptions s)) {-# INLINE sharedOptions #-} - profSharedOptions :: Lens' a (PerCompilerFlavor [String]) - profSharedOptions = buildInfo . profSharedOptions + profSharedOptions f s = fmap (\x -> s{T.profSharedOptions = x}) (f (T.profSharedOptions s)) {-# INLINE profSharedOptions #-} - staticOptions :: Lens' a (PerCompilerFlavor [String]) - staticOptions = buildInfo . staticOptions + staticOptions f s = fmap (\x -> s{T.staticOptions = x}) (f (T.staticOptions s)) {-# INLINE staticOptions #-} - customFieldsBI :: Lens' a [(String, String)] - customFieldsBI = buildInfo . customFieldsBI + customFieldsBI f s = fmap (\x -> s{T.customFieldsBI = x}) (f (T.customFieldsBI s)) {-# INLINE customFieldsBI #-} - targetBuildDepends :: Lens' a [Dependency] - targetBuildDepends = buildInfo . targetBuildDepends + targetBuildDepends f s = fmap (\x -> s{T.targetBuildDepends = x}) (f (T.targetBuildDepends s)) {-# INLINE targetBuildDepends #-} - mixins :: Lens' a [Mixin] - mixins = buildInfo . mixins + mixins f s = fmap (\x -> s{T.mixins = x}) (f (T.mixins s)) {-# INLINE mixins #-} -instance HasBuildInfo BuildInfo where +type HasBuildInfos = HasBuildInfoWith Mod.HasNoAnn +type HasBuildInfosAnn = HasBuildInfoWith Mod.HasAnn + +instance HasBuildInfoWith Mod.HasAnn (BuildInfoWith Mod.HasAnn) where buildInfo = id {-# INLINE buildInfo #-} @@ -367,5 +490,5 @@ instance HasBuildInfo BuildInfo where mixins f s = fmap (\x -> s{T.mixins = x}) (f (T.mixins s)) {-# INLINE mixins #-} -class HasBuildInfos a where - traverseBuildInfos :: Traversal' a BuildInfo +class HasBuildInfosWith mod a where + traverseBuildInfos :: Traversal' a (BuildInfoWith mod) diff --git a/Cabal-syntax/src/Distribution/Types/Component.hs b/Cabal-syntax/src/Distribution/Types/Component.hs index fee1201fba9..0c612f68748 100644 --- a/Cabal-syntax/src/Distribution/Types/Component.hs +++ b/Cabal-syntax/src/Distribution/Types/Component.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.Component ( Component (..) @@ -22,6 +24,7 @@ import Distribution.Types.BuildInfo import Distribution.Types.ComponentName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.Modify as Mod data Component = CLib Library @@ -42,7 +45,7 @@ instance Semigroup Component where CBench b <> CBench b' = CBench (b <> b') _ <> _ = error "Cannot merge Component" -instance L.HasBuildInfo Component where +instance L.HasBuildInfoWith Mod.HasNoAnn Component where buildInfo f (CLib l) = CLib <$> L.buildInfo f l buildInfo f (CFLib l) = CFLib <$> L.buildInfo f l buildInfo f (CExe e) = CExe <$> L.buildInfo f e diff --git a/Cabal-syntax/src/Distribution/Types/CondTree.hs b/Cabal-syntax/src/Distribution/Types/CondTree.hs index 49dad5912b2..22e654fcce3 100644 --- a/Cabal-syntax/src/Distribution/Types/CondTree.hs +++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs @@ -1,7 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Distribution.Types.CondTree ( CondTree (..) @@ -27,6 +33,9 @@ import Prelude () import Distribution.Types.Condition +import Control.Exception +import Data.Kind + import qualified Distribution.Compat.Lens as L -- | A 'CondTree' is used to represent the conditional structure of @@ -57,7 +66,20 @@ data CondTree v a = CondNode { condTreeData :: a , condTreeComponents :: [CondBranch v a] } - deriving (Show, Eq, Data, Generic, Functor, Foldable, Traversable) + +deriving instance (Show v, Show a) => Show (CondTree v a) +deriving instance (Eq v, Eq a) => Eq (CondTree v a) +deriving instance (Data v, Data a) => Data (CondTree v a) +deriving instance Generic (CondTree v a) + +instance Functor (CondTree v) where + fmap f (CondNode x bs) = CondNode (f x) ((fmap . fmap) f bs) + +instance Foldable (CondTree v) where + foldMap f (CondNode x bs) = f x <> (foldMap . foldMap) f bs + +instance Traversable (CondTree v) where + traverse f (CondNode x bs) = CondNode <$> f x <*> (traverse . traverse) f bs instance (Binary v, Binary a) => Binary (CondTree v a) instance (Structured v, Structured a) => Structured (CondTree v a) @@ -78,7 +100,14 @@ data CondBranch v a = CondBranch , condBranchIfTrue :: CondTree v a , condBranchIfFalse :: Maybe (CondTree v a) } - deriving (Show, Eq, Data, Generic, Functor, Traversable, Foldable) + deriving (Generic) + +deriving instance (Show v, Show a) => Show (CondBranch v a) +deriving instance (Eq v, Eq a) => Eq (CondBranch v a) +deriving instance (Data v, Data a) => Data (CondBranch v a) +deriving instance Functor (CondBranch v) +deriving instance Foldable (CondBranch v) +deriving instance Traversable (CondBranch v) instance (Binary v, Binary a) => Binary (CondBranch v a) instance (Structured v, Structured a) => Structured (CondBranch v a) diff --git a/Cabal-syntax/src/Distribution/Types/Dependency.hs b/Cabal-syntax/src/Distribution/Types/Dependency.hs index d0d5627002b..09b41b11559 100644 --- a/Cabal-syntax/src/Distribution/Types/Dependency.hs +++ b/Cabal-syntax/src/Distribution/Types/Dependency.hs @@ -1,8 +1,18 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeSynonymInstances #-} module Distribution.Types.Dependency - ( Dependency (..) + ( Dependency + , DependencyAnn + , DependencyWith (..) + , unannotateDependencyAnn , mkDependency , depPkgName , depVerRange @@ -12,16 +22,18 @@ module Distribution.Types.Dependency ) where import Distribution.Compat.Prelude +import Distribution.Utils.ShortText import Prelude () -import Distribution.Types.VersionRange (isAnyVersionLight) -import Distribution.Version (VersionRange, anyVersion, simplifyVersionRange) +import Distribution.Types.VersionRange (isAnyVersionLight, unAnnVersionRange) +import Distribution.Version (VersionRange, VersionRangeAnn, VersionRangeWith (..), anyVersionAnn, simplifyVersionRange) import Distribution.CabalSpecVersion -import Distribution.Compat.CharParsing (char, spaces) +import Distribution.Compat.CharParsing (char, spaces, spaces') import Distribution.Compat.Parsing (between, option) import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia import Distribution.Types.LibraryName import Distribution.Types.PackageName import Distribution.Types.UnqualComponentName @@ -29,19 +41,45 @@ import Distribution.Types.UnqualComponentName import qualified Distribution.Compat.NonEmptySet as NES import qualified Text.PrettyPrint as PP +import qualified Distribution.Types.Modify as Mod + -- | Describes a dependency on a source package (API) -- -- /Invariant:/ package name does not appear as 'LSubLibName' in -- set of library names. -data Dependency +type Dependency = DependencyWith Mod.HasNoAnn + +type DependencyAnn = DependencyWith Mod.HasAnn + +data DependencyWith (m :: Mod.HasAnnotation) = -- | The set of libraries required from the package. -- Only the selected libraries will be built. -- It does not affect the cabal-install solver yet. Dependency - PackageName - VersionRange + (PackageNameWith m) + (VersionRangeWith m) (NonEmptySet LibraryName) - deriving (Generic, Read, Show, Eq, Ord, Data) + deriving (Generic) + +deriving instance Read Dependency +deriving instance Show Dependency +deriving instance Eq Dependency +deriving instance Ord Dependency +deriving instance Data Dependency + +-- TODO: less instances? +deriving instance Read (DependencyWith Mod.HasAnn) +deriving instance Show (DependencyWith Mod.HasAnn) +deriving instance Eq (DependencyWith Mod.HasAnn) +deriving instance Ord (DependencyWith Mod.HasAnn) +deriving instance Data (DependencyWith Mod.HasAnn) + +unannotateDependencyAnn :: DependencyAnn -> Dependency +unannotateDependencyAnn (Dependency pname vrange libs) = + Dependency + (unannotatePackageName pname) + (unAnnVersionRange vrange) + libs depPkgName :: Dependency -> PackageName depPkgName (Dependency pn _ _) = pn @@ -62,12 +100,22 @@ mkDependency :: PackageName -> VersionRange -> NonEmptySet LibraryName -> Depend mkDependency pn vr lb = Dependency pn vr (NES.map conv lb) where pn' = packageNameToUnqualComponentName pn - conv l@LMainLibName = l conv l@(LSubLibName ln) | ln == pn' = LMainLibName | otherwise = l +mkDependencyAnn :: PackageNameAnn -> VersionRangeAnn -> NonEmptySet LibraryName -> DependencyWith Mod.HasAnn +mkDependencyAnn pn vr lb = Dependency pn vr (NES.map conv lb) + where + pn' = packageNameToUnqualComponentNameWith pn + + -- TODO(leana8959): lossy? + conv l@LMainLibName = l + conv l@(LSubLibName ln) + | ln == unAnn pn' = LMainLibName + | otherwise = l + instance Binary Dependency instance Structured Dependency instance NFData Dependency where rnf = genericRnf @@ -93,6 +141,10 @@ instance Pretty Dependency where | isAnyVersionLight ver = PP.empty | otherwise = pretty ver +-- TODO(leana8959): implement packagename part +instance Pretty DependencyAnn where + pretty (Dependency name ver sublibs) = prettyLibraryNames name (NES.toNonEmpty sublibs) <> pretty ver + -- | -- -- >>> simpleParsec "mylib:sub" :: Maybe Dependency @@ -125,17 +177,22 @@ instance Pretty Dependency where -- >>> map (`simpleParsec'` "mylib:sub") [CabalSpecV2_4, CabalSpecV3_0] :: [Maybe Dependency] -- [Nothing,Just (Dependency (PackageName "mylib") (OrLaterVersion (mkVersion [0])) (fromNonEmpty (LSubLibName (UnqualComponentName "sub") :| [])))] instance Parsec Dependency where - parsec = do - name <- parsec - - libs <- option mainLibSet $ do - _ <- char ':' - versionGuardMultilibs - NES.singleton <$> parseLib <|> parseMultipleLibs + parsec = unannotateDependencyAnn <$> parsec - spaces -- https://github.com/haskell/cabal/issues/5846 - ver <- parsec <|> pure anyVersion - return $ mkDependency name ver libs +instance Parsec (DependencyAnn) where + parsec = do + (pname :: PackageNameAnn, libraries) <- do + name <- unPackageNameST <$> parsec + libs <- option mainLibSet $ do + _ <- char ':' + versionGuardMultilibs + NES.singleton <$> parseLib <|> parseMultipleLibs + + post <- spaces' -- https://github.com/haskell/cabal/issues/5846 + pure (PackageName $ Ann (postTrivia post) name, libs) + + ver <- parsec <|> pure anyVersionAnn + return $ mkDependencyAnn pname ver libraries where parseLib = LSubLibName <$> parsec parseMultipleLibs = diff --git a/Cabal-syntax/src/Distribution/Types/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs index 2017a9ba8d2..cc6149821b4 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -1,9 +1,14 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.Executable - ( Executable (..) + ( Executable + , ExecutableWith (..) , emptyExecutable , exeModules , exeModulesAutogen @@ -18,17 +23,28 @@ import Distribution.Types.ExecutableScope import Distribution.Types.UnqualComponentName import Distribution.Utils.Path +import qualified Distribution.Types.Modify as Mod + import qualified Distribution.Types.BuildInfo.Lens as L -data Executable = Executable +type Executable = ExecutableWith Mod.HasNoAnn + +data ExecutableWith (mod :: Mod.HasAnnotation) = Executable { exeName :: UnqualComponentName , modulePath :: RelativePath Source File , exeScope :: ExecutableScope - , buildInfo :: BuildInfo + , buildInfo :: BuildInfoWith mod } - deriving (Generic, Show, Read, Eq, Ord, Data) +deriving instance Generic Executable +deriving instance Show Executable +deriving instance Read Executable +deriving instance Eq Executable +deriving instance Ord Executable +deriving instance Data Executable -instance L.HasBuildInfo Executable where +deriving instance Show (ExecutableWith Mod.HasAnn) + +instance L.HasBuildInfoWith mod (ExecutableWith mod) where buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l) instance Binary Executable @@ -56,9 +72,32 @@ instance Semigroup Executable where where combine field = field a `mappend` field b +instance Monoid (ExecutableWith Mod.HasAnn) where + mempty = emptyExecutable' + +instance Semigroup (ExecutableWith Mod.HasAnn) where + a <> b = + Executable + { exeName = combineNames a b exeName "executable" + , modulePath = unsafeMakeSymbolicPath $ combineNames a b (getSymbolicPath . modulePath) "modulePath" + , exeScope = combine exeScope + , buildInfo = combine buildInfo + } + where + combine field = field a `mappend` field b + emptyExecutable :: Executable emptyExecutable = mempty +emptyExecutable' :: ExecutableWith Mod.HasAnn +emptyExecutable' = + Executable + { exeName = mempty + , modulePath = unsafeMakeSymbolicPath "" + , exeScope = mempty + , buildInfo = mempty + } + -- | Get all the module names from an exe exeModules :: Executable -> [ModuleName] exeModules exe = otherModules (buildInfo exe) diff --git a/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs b/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs index 3683522ac8d..e0536c43fa5 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable/Lens.hs @@ -9,26 +9,26 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Executable (Executable) +import Distribution.Types.BuildInfo (BuildInfo, BuildInfoWith) +import Distribution.Types.Executable (Executable, ExecutableWith) import Distribution.Types.ExecutableScope (ExecutableScope) import Distribution.Types.UnqualComponentName (UnqualComponentName) import Distribution.Utils.Path import qualified Distribution.Types.Executable as T -exeName :: Lens' Executable UnqualComponentName +exeName :: Lens' (ExecutableWith mod) UnqualComponentName exeName f s = fmap (\x -> s{T.exeName = x}) (f (T.exeName s)) {-# INLINE exeName #-} -modulePath :: Lens' Executable (RelativePath Source File) +modulePath :: Lens' (ExecutableWith mod) (RelativePath Source File) modulePath f s = fmap (\x -> s{T.modulePath = x}) (f (T.modulePath s)) {-# INLINE modulePath #-} -exeScope :: Lens' Executable ExecutableScope +exeScope :: Lens' (ExecutableWith mod) ExecutableScope exeScope f s = fmap (\x -> s{T.exeScope = x}) (f (T.exeScope s)) {-# INLINE exeScope #-} -exeBuildInfo :: Lens' Executable BuildInfo +exeBuildInfo :: Lens' (ExecutableWith mod) (BuildInfoWith mod) exeBuildInfo f s = fmap (\x -> s{T.buildInfo = x}) (f (T.buildInfo s)) {-# INLINE exeBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs index c8a1472ca56..be471e61992 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -1,9 +1,14 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.ForeignLib - ( ForeignLib (..) + ( ForeignLib + , ForeignLibWith (..) , emptyForeignLib , foreignLibModules , foreignLibIsShared @@ -30,6 +35,8 @@ import Distribution.Types.UnqualComponentName import Distribution.Utils.Path import Distribution.Version +import qualified Distribution.Types.Modify as Mod + import Data.Monoid import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp @@ -37,9 +44,11 @@ import qualified Text.Read as Read import qualified Distribution.Types.BuildInfo.Lens as L +type ForeignLib = ForeignLibWith Mod.HasNoAnn + -- | A foreign library stanza is like a library stanza, except that -- the built code is intended for consumption by a non-Haskell client. -data ForeignLib = ForeignLib +data ForeignLibWith (m :: Mod.HasAnnotation) = ForeignLib { foreignLibName :: UnqualComponentName -- ^ Name of the foreign library , foreignLibType :: ForeignLibType @@ -47,7 +56,7 @@ data ForeignLib = ForeignLib , foreignLibOptions :: [ForeignLibOption] -- ^ What options apply to this foreign library (e.g., are we -- merging in all foreign dependencies.) - , foreignLibBuildInfo :: BuildInfo + , foreignLibBuildInfo :: BuildInfoWith m -- ^ Build information for this foreign library. , foreignLibVersionInfo :: Maybe LibVersionInfo -- ^ Libtool-style version-info data to compute library version. @@ -61,7 +70,14 @@ data ForeignLib = ForeignLib -- This is a list rather than a maybe field so that we can flatten -- the condition trees (for instance, when creating an sdist) } - deriving (Generic, Show, Read, Eq, Ord, Data) +deriving instance Generic ForeignLib +deriving instance Show ForeignLib +deriving instance Read ForeignLib +deriving instance Eq ForeignLib +deriving instance Ord ForeignLib +deriving instance Data ForeignLib + +deriving instance Show (ForeignLibWith Mod.HasAnn) data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic) @@ -133,7 +149,7 @@ libVersionNumberShow v = libVersionMajor :: LibVersionInfo -> Int libVersionMajor (LibVersionInfo c _ a) = c - a -instance L.HasBuildInfo ForeignLib where +instance L.HasBuildInfoWith mod (ForeignLibWith mod) where buildInfo f l = (\x -> l{foreignLibBuildInfo = x}) <$> f (foreignLibBuildInfo l) instance Binary ForeignLib @@ -156,6 +172,22 @@ instance Semigroup ForeignLib where -- chooseLast: the second field overrides the first, unless it is Nothing chooseLast field = getLast (Last (field a) <> Last (field b)) +instance Semigroup (ForeignLibWith Mod.HasAnn) where + a <> b = + ForeignLib + { foreignLibName = combineNames a b foreignLibName "foreign library" + , foreignLibType = combine foreignLibType + , foreignLibOptions = combine foreignLibOptions + , foreignLibBuildInfo = combine foreignLibBuildInfo + , foreignLibVersionInfo = chooseLast foreignLibVersionInfo + , foreignLibVersionLinux = chooseLast foreignLibVersionLinux + , foreignLibModDefFile = combine foreignLibModDefFile + } + where + combine field = field a `mappend` field b + -- chooseLast: the second field overrides the first, unless it is Nothing + chooseLast field = getLast (Last (field a) <> Last (field b)) + instance Monoid ForeignLib where mempty = ForeignLib @@ -169,10 +201,25 @@ instance Monoid ForeignLib where } mappend = (<>) +instance Monoid (ForeignLibWith Mod.HasAnn) where + mempty = emptyForeignLib' + -- | An empty foreign library. emptyForeignLib :: ForeignLib emptyForeignLib = mempty +emptyForeignLib' :: ForeignLibWith Mod.HasAnn +emptyForeignLib' = + ForeignLib + { foreignLibName = mempty + , foreignLibType = ForeignLibTypeUnknown + , foreignLibOptions = [] + , foreignLibBuildInfo = mempty + , foreignLibVersionInfo = Nothing + , foreignLibVersionLinux = Nothing + , foreignLibModDefFile = [] + } + -- | Modules defined by a foreign library. foreignLibModules :: ForeignLib -> [ModuleName] foreignLibModules = otherModules . foreignLibBuildInfo diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs index b7f4fee3197..3f732ec0cc6 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib/Lens.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Types.ForeignLib.Lens ( ForeignLib @@ -9,8 +10,8 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.ForeignLib (ForeignLib, LibVersionInfo) +import Distribution.Types.BuildInfo (BuildInfo, BuildInfoWith) +import Distribution.Types.ForeignLib (ForeignLib, ForeignLibWith, LibVersionInfo) import Distribution.Types.ForeignLibOption (ForeignLibOption) import Distribution.Types.ForeignLibType (ForeignLibType) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -19,30 +20,30 @@ import Distribution.Version (Version) import qualified Distribution.Types.ForeignLib as T -foreignLibName :: Lens' ForeignLib UnqualComponentName +foreignLibName :: Lens' (ForeignLibWith mod) UnqualComponentName foreignLibName f s = fmap (\x -> s{T.foreignLibName = x}) (f (T.foreignLibName s)) {-# INLINE foreignLibName #-} -foreignLibType :: Lens' ForeignLib ForeignLibType +foreignLibType :: Lens' (ForeignLibWith mod) ForeignLibType foreignLibType f s = fmap (\x -> s{T.foreignLibType = x}) (f (T.foreignLibType s)) {-# INLINE foreignLibType #-} -foreignLibOptions :: Lens' ForeignLib [ForeignLibOption] +foreignLibOptions :: Lens' (ForeignLibWith mod) [ForeignLibOption] foreignLibOptions f s = fmap (\x -> s{T.foreignLibOptions = x}) (f (T.foreignLibOptions s)) {-# INLINE foreignLibOptions #-} -foreignLibBuildInfo :: Lens' ForeignLib BuildInfo +foreignLibBuildInfo :: forall mod. Lens' (ForeignLibWith mod) (BuildInfoWith mod) foreignLibBuildInfo f s = fmap (\x -> s{T.foreignLibBuildInfo = x}) (f (T.foreignLibBuildInfo s)) {-# INLINE foreignLibBuildInfo #-} -foreignLibVersionInfo :: Lens' ForeignLib (Maybe LibVersionInfo) +foreignLibVersionInfo :: Lens' (ForeignLibWith mod) (Maybe LibVersionInfo) foreignLibVersionInfo f s = fmap (\x -> s{T.foreignLibVersionInfo = x}) (f (T.foreignLibVersionInfo s)) {-# INLINE foreignLibVersionInfo #-} -foreignLibVersionLinux :: Lens' ForeignLib (Maybe Version) +foreignLibVersionLinux :: Lens' (ForeignLibWith mod) (Maybe Version) foreignLibVersionLinux f s = fmap (\x -> s{T.foreignLibVersionLinux = x}) (f (T.foreignLibVersionLinux s)) {-# INLINE foreignLibVersionLinux #-} -foreignLibModDefFile :: Lens' ForeignLib [RelativePath Source File] +foreignLibModDefFile :: Lens' (ForeignLibWith mod) [RelativePath Source File] foreignLibModDefFile f s = fmap (\x -> s{T.foreignLibModDefFile = x}) (f (T.foreignLibModDefFile s)) {-# INLINE foreignLibModDefFile #-} diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 67c39879614..5e44d9fa235 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -1,11 +1,25 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Types.GenericPackageDescription - ( GenericPackageDescription (..) + ( GenericPackageDescription + , GenericPackageDescriptionAnn + , GenericPackageDescriptionWith (..) , emptyGenericPackageDescription + , EmptyGPD (..) ) where import Distribution.Compat.Prelude @@ -29,11 +43,17 @@ import Distribution.Types.TestSuite import Distribution.Types.UnqualComponentName import Distribution.Version +import Data.Kind +import qualified Distribution.Types.Modify as Mod + -- --------------------------------------------------------------------------- -- The 'GenericPackageDescription' type -data GenericPackageDescription = GenericPackageDescription - { packageDescription :: PackageDescription +type GenericPackageDescription = GenericPackageDescriptionWith Mod.HasNoAnn +type GenericPackageDescriptionAnn = GenericPackageDescriptionWith Mod.HasAnn + +data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDescription + { packageDescription :: PackageDescriptionWith m , gpdScannedVersion :: Maybe Version -- ^ This is a version as specified in source. -- We populate this field in index reading for dummy GPDs, @@ -44,49 +64,54 @@ data GenericPackageDescription = GenericPackageDescription -- Perfectly, PackageIndex should have sum type, so we don't need to -- have dummy GPDs. , genPackageFlags :: [PackageFlag] - , condLibrary :: Maybe (CondTree ConfVar Library) + , condLibrary :: Maybe (CondTree ConfVar (LibraryWith m)) , condSubLibraries - :: [ ( UnqualComponentName - , CondTree ConfVar Library - ) - ] + :: [(UnqualComponentName, CondTree ConfVar (LibraryWith m))] , condForeignLibs - :: [ ( UnqualComponentName - , CondTree ConfVar ForeignLib - ) - ] + :: [(UnqualComponentName, CondTree ConfVar (ForeignLibWith m))] , condExecutables - :: [ ( UnqualComponentName - , CondTree ConfVar Executable - ) - ] + :: [(UnqualComponentName, CondTree ConfVar (ExecutableWith m))] , condTestSuites - :: [ ( UnqualComponentName - , CondTree ConfVar TestSuite - ) - ] + :: [(UnqualComponentName, CondTree ConfVar (TestSuiteWith m))] , condBenchmarks - :: [ ( UnqualComponentName - , CondTree ConfVar Benchmark - ) - ] + :: [(UnqualComponentName, CondTree ConfVar (BenchmarkWith m))] } - deriving (Show, Eq, Data, Generic) -instance Package GenericPackageDescription where +deriving instance Eq (GenericPackageDescriptionWith Mod.HasNoAnn) +deriving instance Show (GenericPackageDescriptionWith Mod.HasNoAnn) +deriving instance Data (GenericPackageDescriptionWith Mod.HasNoAnn) +deriving instance Generic (GenericPackageDescriptionWith Mod.HasNoAnn) + +deriving instance Show (GenericPackageDescriptionWith Mod.HasAnn) + +instance Package (GenericPackageDescriptionWith Mod.HasNoAnn) where packageId = packageId . packageDescription -instance Binary GenericPackageDescription +deriving instance Binary (GenericPackageDescriptionWith Mod.HasNoAnn) + instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf +class EmptyGPD (mod :: Mod.HasAnnotation) where + emptyGPD :: GenericPackageDescriptionWith mod + +-- | BAD: this is for prototyping =D +instance EmptyGPD Mod.HasNoAnn where + emptyGPD = emptyGenericPackageDescription + +instance EmptyGPD Mod.HasAnn where + emptyGPD = emptyGenericPackageDescriptionAnn + emptyGenericPackageDescription :: GenericPackageDescription emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] +emptyGenericPackageDescriptionAnn :: GenericPackageDescriptionWith Mod.HasAnn +emptyGenericPackageDescriptionAnn = GenericPackageDescription emptyPackageDescriptionAnn Nothing [] Nothing [] [] [] [] [] + -- ----------------------------------------------------------------------------- -- Traversal Instances -instance L.HasBuildInfos GenericPackageDescription where +instance L.HasBuildInfosWith Mod.HasNoAnn GenericPackageDescription where traverseBuildInfos f (GenericPackageDescription p v a1 x1 x2 x3 x4 x5 x6) = GenericPackageDescription <$> L.traverseBuildInfos f p diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index f194ddda9c9..10012eefc79 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -19,16 +19,16 @@ import qualified Distribution.Types.GenericPackageDescription as T import Distribution.Compiler (CompilerFlavor) import Distribution.System (Arch, OS) -import Distribution.Types.Benchmark (Benchmark) +import Distribution.Types.Benchmark (Benchmark, BenchmarkWith) import Distribution.Types.CondTree (CondTree) import Distribution.Types.ConfVar (ConfVar (..)) -import Distribution.Types.Executable (Executable) +import Distribution.Types.Executable (Executable, ExecutableWith) import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag)) -import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription (GenericPackageDescription)) -import Distribution.Types.Library (Library) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.TestSuite (TestSuite) +import Distribution.Types.ForeignLib (ForeignLib, ForeignLibWith) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription, GenericPackageDescriptionWith (..)) +import Distribution.Types.Library (Library, LibraryWith) +import Distribution.Types.PackageDescription (PackageDescription, PackageDescriptionWith) +import Distribution.Types.TestSuite (TestSuite, TestSuiteWith) import Distribution.Types.UnqualComponentName (UnqualComponentName) import Distribution.Version (Version, VersionRange) @@ -36,7 +36,7 @@ import Distribution.Version (Version, VersionRange) -- GenericPackageDescription ------------------------------------------------------------------------------- -packageDescription :: Lens' GenericPackageDescription PackageDescription +packageDescription :: Lens' (GenericPackageDescriptionWith mod) (PackageDescriptionWith mod) packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s)) {-# INLINE packageDescription #-} @@ -44,31 +44,31 @@ gpdScannedVersion :: Lens' GenericPackageDescription (Maybe Version) gpdScannedVersion f s = fmap (\x -> s{T.gpdScannedVersion = x}) (f (T.gpdScannedVersion s)) {-# INLINE gpdScannedVersion #-} -genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] +genPackageFlags :: Lens' (GenericPackageDescriptionWith mod) [PackageFlag] genPackageFlags f s = fmap (\x -> s{T.genPackageFlags = x}) (f (T.genPackageFlags s)) {-# INLINE genPackageFlags #-} -condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar Library)) +condLibrary :: Lens' (GenericPackageDescriptionWith mod) (Maybe (CondTree ConfVar (LibraryWith mod))) condLibrary f s = fmap (\x -> s{T.condLibrary = x}) (f (T.condLibrary s)) {-# INLINE condLibrary #-} -condSubLibraries :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar Library))] +condSubLibraries :: Lens' (GenericPackageDescriptionWith mod) [(UnqualComponentName, (CondTree ConfVar (LibraryWith mod)))] condSubLibraries f s = fmap (\x -> s{T.condSubLibraries = x}) (f (T.condSubLibraries s)) {-# INLINE condSubLibraries #-} -condForeignLibs :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar ForeignLib))] +condForeignLibs :: Lens' (GenericPackageDescriptionWith mod) [(UnqualComponentName, (CondTree ConfVar (ForeignLibWith mod)))] condForeignLibs f s = fmap (\x -> s{T.condForeignLibs = x}) (f (T.condForeignLibs s)) {-# INLINE condForeignLibs #-} -condExecutables :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar Executable))] +condExecutables :: Lens' (GenericPackageDescriptionWith mod) [(UnqualComponentName, (CondTree ConfVar (ExecutableWith mod)))] condExecutables f s = fmap (\x -> s{T.condExecutables = x}) (f (T.condExecutables s)) {-# INLINE condExecutables #-} -condTestSuites :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar TestSuite))] +condTestSuites :: Lens' (GenericPackageDescriptionWith mod) [(UnqualComponentName, (CondTree ConfVar (TestSuiteWith mod)))] condTestSuites f s = fmap (\x -> s{T.condTestSuites = x}) (f (T.condTestSuites s)) {-# INLINE condTestSuites #-} -condBenchmarks :: Lens' GenericPackageDescription [(UnqualComponentName, (CondTree ConfVar Benchmark))] +condBenchmarks :: Lens' (GenericPackageDescriptionWith mod) [(UnqualComponentName, (CondTree ConfVar (BenchmarkWith mod)))] condBenchmarks f s = fmap (\x -> s{T.condBenchmarks = x}) (f (T.condBenchmarks s)) {-# INLINE condBenchmarks #-} diff --git a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs index 6d2849c5142..a7a8c177835 100644 --- a/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -35,6 +37,7 @@ import qualified Distribution.SPDX as SPDX import qualified Text.PrettyPrint as Disp import Distribution.Types.InstalledPackageInfo +import qualified Distribution.Types.Modify as Mod import qualified Distribution.Types.InstalledPackageInfo.Lens as L import qualified Distribution.Types.PackageId.Lens as L @@ -55,8 +58,8 @@ f <@> x = f <*> x ipiFieldGrammar :: ( FieldGrammar c g - , Applicative (g InstalledPackageInfo) - , Applicative (g Basic) + , Applicative (g Mod.HasNoAnn InstalledPackageInfo) + , Applicative (g Mod.HasNoAnn Basic) , c (Identity AbiHash) , c (Identity LibraryVisibility) , c (Identity PackageName) @@ -74,7 +77,7 @@ ipiFieldGrammar , c InstWith , c SpecLicenseLenient ) - => g InstalledPackageInfo InstalledPackageInfo + => g Mod.HasNoAnn InstalledPackageInfo InstalledPackageInfo ipiFieldGrammar = mkInstalledPackageInfo -- Deprecated fields @@ -137,9 +140,9 @@ ipiFieldGrammar = _basicLibVisibility where MungedPackageName pn ln = _basicName -{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} -{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar InstalledPackageInfo InstalledPackageInfo #-} +{-# SPECIALIZE ipiFieldGrammar :: FieldDescrs Mod.HasNoAnn InstalledPackageInfo InstalledPackageInfo #-} +{-# SPECIALIZE ipiFieldGrammar :: ParsecFieldGrammar Mod.HasNoAnn InstalledPackageInfo InstalledPackageInfo #-} +{-# SPECIALIZE ipiFieldGrammar :: PrettyFieldGrammar Mod.HasNoAnn InstalledPackageInfo InstalledPackageInfo #-} -- (forall b. [b]) ~ () unitedList :: Lens' a [b] @@ -301,14 +304,14 @@ basicLibVisibility f b = basicFieldGrammar :: ( FieldGrammar c g - , Applicative (g Basic) + , Applicative (g Mod.HasNoAnn Basic) , c (Identity LibraryVisibility) , c (Identity PackageName) , c (Identity UnqualComponentName) , c (MQuoted MungedPackageName) , c (MQuoted Version) ) - => g Basic Basic + => g Mod.HasNoAnn Basic Basic basicFieldGrammar = mkBasic <$> optionalFieldDefAla "name" MQuoted basicName (mungedPackageName emptyInstalledPackageInfo) diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs index fd4b89b6a6a..002395be4a1 100644 --- a/Cabal-syntax/src/Distribution/Types/Library.hs +++ b/Cabal-syntax/src/Distribution/Types/Library.hs @@ -1,8 +1,17 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} module Distribution.Types.Library - ( Library (..) + ( Library + , LibraryAnn + , LibraryWith (..) , emptyLibrary , explicitLibModules , libModulesAutogen @@ -19,21 +28,37 @@ import Distribution.Types.ModuleReexport import qualified Distribution.Types.BuildInfo.Lens as L -data Library = Library +import Distribution.Trivia +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AnnotateWith, PreserveGrouping) + +type Library = LibraryWith Mod.HasNoAnn +type LibraryAnn = LibraryWith Mod.HasAnn + +data LibraryWith (m :: Mod.HasAnnotation) = Library { libName :: LibraryName , exposedModules :: [ModuleName] , reexportedModules :: [ModuleReexport] , signatures :: [ModuleName] -- ^ What sigs need implementations? - , libExposed :: Bool + , libExposed :: PreserveGrouping m (AnnotateWith Positions m Bool) + -- [(Positions, Bool)] -- ^ Is the lib to be exposed by default? (i.e. whether its modules available in GHCi for example) , libVisibility :: LibraryVisibility -- ^ Whether this multilib can be used as a dependency for other packages. - , libBuildInfo :: BuildInfo + , libBuildInfo :: BuildInfoWith m } - deriving (Generic, Show, Eq, Ord, Read, Data) + deriving (Generic) + +deriving instance Show Library +deriving instance Eq Library +deriving instance Ord Library +deriving instance Read Library +deriving instance Data Library + +deriving instance Show (LibraryWith Mod.HasAnn) -instance L.HasBuildInfo Library where +instance L.HasBuildInfoWith mod (LibraryWith mod) where buildInfo f l = (\x -> l{libBuildInfo = x}) <$> f (libBuildInfo l) instance Binary Library @@ -52,6 +77,18 @@ emptyLibrary = , libBuildInfo = mempty } +emptyLibraryAnn :: LibraryWith Mod.HasAnn +emptyLibraryAnn = + Library + { libName = LMainLibName + , exposedModules = mempty + , reexportedModules = mempty + , signatures = mempty + , libExposed = [] + , libVisibility = mempty + , libBuildInfo = mempty + } + -- | This instance is not good. -- -- We need it for 'PackageDescription.Configuration.addBuildableCondition'. @@ -63,6 +100,24 @@ instance Monoid Library where mempty = emptyLibrary mappend = (<>) +instance Monoid (LibraryWith Mod.HasAnn) where + mempty = emptyLibraryAnn + mappend = (<>) + +instance Semigroup (LibraryWith Mod.HasAnn) where + a <> b = + Library + { libName = combineLibraryName (libName a) (libName b) + , exposedModules = combine exposedModules + , reexportedModules = combine reexportedModules + , signatures = combine signatures + , libExposed = libExposed a <> libExposed b -- so False propagates + , libVisibility = combine libVisibility + , libBuildInfo = combine libBuildInfo + } + where + combine field = field a `mappend` field b + instance Semigroup Library where a <> b = Library diff --git a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs index 9787f3700dd..dd74427c90e 100644 --- a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs @@ -7,39 +7,42 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () +import Distribution.Types.Modify (AnnotateWith, PreserveGrouping) +import Distribution.Trivia + import Distribution.ModuleName (ModuleName) -import Distribution.Types.BuildInfo (BuildInfo) -import Distribution.Types.Library (Library) +import Distribution.Types.BuildInfo (BuildInfoWith) +import Distribution.Types.Library (Library, LibraryWith) import Distribution.Types.LibraryName (LibraryName) import Distribution.Types.LibraryVisibility (LibraryVisibility) import Distribution.Types.ModuleReexport (ModuleReexport) import qualified Distribution.Types.Library as T -libName :: Lens' Library LibraryName +libName :: Lens' (LibraryWith mod) LibraryName libName f s = fmap (\x -> s{T.libName = x}) (f (T.libName s)) {-# INLINE libName #-} -exposedModules :: Lens' Library [ModuleName] +exposedModules :: Lens' (LibraryWith mod) [ModuleName] exposedModules f s = fmap (\x -> s{T.exposedModules = x}) (f (T.exposedModules s)) {-# INLINE exposedModules #-} -reexportedModules :: Lens' Library [ModuleReexport] +reexportedModules :: Lens' (LibraryWith mod) [ModuleReexport] reexportedModules f s = fmap (\x -> s{T.reexportedModules = x}) (f (T.reexportedModules s)) {-# INLINE reexportedModules #-} -signatures :: Lens' Library [ModuleName] +signatures :: Lens' (LibraryWith mod) [ModuleName] signatures f s = fmap (\x -> s{T.signatures = x}) (f (T.signatures s)) {-# INLINE signatures #-} -libExposed :: Lens' Library Bool +libExposed :: Lens' (LibraryWith mod) (PreserveGrouping mod (AnnotateWith Positions mod Bool)) libExposed f s = fmap (\x -> s{T.libExposed = x}) (f (T.libExposed s)) {-# INLINE libExposed #-} -libVisibility :: Lens' Library LibraryVisibility +libVisibility :: Lens' (LibraryWith mod) LibraryVisibility libVisibility f s = fmap (\x -> s{T.libVisibility = x}) (f (T.libVisibility s)) {-# INLINE libVisibility #-} -libBuildInfo :: Lens' Library BuildInfo +libBuildInfo :: Lens' (LibraryWith mod) (BuildInfoWith mod) libBuildInfo f s = fmap (\x -> s{T.libBuildInfo = x}) (f (T.libBuildInfo s)) {-# INLINE libBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs new file mode 100644 index 00000000000..40e41385b83 --- /dev/null +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Types that can be used as modifiers +module Distribution.Types.Modify where + +import Distribution.Parsec.Position +import Distribution.Trivia + +import Data.Data +import Data.Kind + +-- | Toggle whether a GPD component has annotation or not. +data HasAnnotation + = HasAnn + | HasNoAnn + deriving (Show, Read, Eq, Ord, Data) + +-- Type family combinators that can compose and attach concrete syntax informations conditionally. + +type Annotate (m :: HasAnnotation) (a :: Type) = AnnotateWith SurroundingText m a + +type family AnnotateWith (trivia :: Type) (m :: HasAnnotation) (a :: Type) where + AnnotateWith t HasNoAnn a = a + AnnotateWith t HasAnn a = Ann t a + +type AttachPositions (m :: HasAnnotation) (a :: Type) = AttachWith Positions m a +type AttachPosition (m :: HasAnnotation) (a :: Type) = AttachWith Position m a + +type family AttachWith (t :: Type) (m :: HasAnnotation) (a :: Type) where + AttachWith t HasAnn a = (t, a) + AttachWith _ HasNoAnn a = a + +type family PreserveGrouping (m :: HasAnnotation) (a :: Type) where + PreserveGrouping HasAnn a = [a] + PreserveGrouping HasNoAnn a = a diff --git a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs index 8e879620478..333aeb6f162 100644 --- a/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs +++ b/Cabal-syntax/src/Distribution/Types/MungedPackageId.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.MungedPackageId @@ -66,7 +67,7 @@ instance Pretty MungedPackageId where -- Nothing instance Parsec MungedPackageId where parsec = do - PackageIdentifier pn v <- parsec + PackageIdentifier pn v <- parsec @PackageIdentifier return $ MungedPackageId (decodeCompatPackageName pn) v instance NFData MungedPackageId where diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs index 8ef892a9ad3..3a6fcfd25e3 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -1,7 +1,11 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -28,11 +32,13 @@ -- feature was introduced. It could probably do with being rationalised at some -- point to make it simpler. module Distribution.Types.PackageDescription - ( PackageDescription (..) + ( PackageDescription + , PackageDescriptionWith (..) , license , license' , buildType , emptyPackageDescription + , emptyPackageDescriptionAnn , hasPublicLib , hasLibs , allLibraries @@ -78,6 +84,7 @@ import Distribution.Types.ComponentName import Distribution.Types.ComponentRequestedSpec import Distribution.Types.Dependency import Distribution.Types.HookedBuildInfo +import qualified Distribution.Types.Modify as Mod import Distribution.Types.PackageId import Distribution.Types.PackageName import Distribution.Types.SetupBuildInfo @@ -92,8 +99,14 @@ import Distribution.Utils.Path import Distribution.Utils.ShortText import Distribution.Version +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AnnotateWith) +import Distribution.Trivia + import qualified Distribution.SPDX as SPDX +type PackageDescription = PackageDescriptionWith Mod.HasNoAnn + -- ----------------------------------------------------------------------------- -- The PackageDescription type @@ -102,12 +115,12 @@ import qualified Distribution.SPDX as SPDX -- which is needed for all packages, such as the package name and version, and -- information which is needed for the simple build system only, such as -- the compiler options and library name. -data PackageDescription = PackageDescription +data PackageDescriptionWith (mod :: Mod.HasAnnotation) = PackageDescription { -- the following are required by all packages: - specVersion :: CabalSpecVersion + specVersion :: AnnotateWith Positions mod CabalSpecVersion -- ^ The version of the Cabal spec that this package description uses. - , package :: PackageIdentifier + , package :: PackageIdentifierWith mod , licenseRaw :: Either SPDX.License License , licenseFiles :: [RelativePath Pkg File] , copyright :: !ShortText @@ -151,7 +164,15 @@ data PackageDescription = PackageDescription , extraDocFiles :: [RelativePath Pkg File] , extraFiles :: [RelativePath Pkg File] } - deriving (Generic, Show, Read, Eq, Ord, Data) + +deriving instance Generic PackageDescription +deriving instance Show PackageDescription +deriving instance Read PackageDescription +deriving instance Eq PackageDescription +deriving instance Ord PackageDescription +deriving instance Data PackageDescription + +deriving instance Show (PackageDescriptionWith Mod.HasAnn) instance Binary PackageDescription instance Structured PackageDescription @@ -239,6 +260,45 @@ emptyPackageDescription = , extraFiles = [] } +emptyPackageDescriptionAnn :: PackageDescriptionWith Mod.HasAnn +emptyPackageDescriptionAnn = + PackageDescription + { package = + PackageIdentifier + (Ann IsInserted $ mkPackageName "") + (Ann IsInserted $ nullVersion) + , licenseRaw = Right UnspecifiedLicense -- TODO: + , licenseFiles = [] + , specVersion = Ann IsInserted CabalSpecV1_0 + , buildTypeRaw = Nothing + , copyright = mempty + , maintainer = mempty + , author = mempty + , stability = mempty + , testedWith = [] + , homepage = mempty + , pkgUrl = mempty + , bugReports = mempty + , sourceRepos = [] + , synopsis = mempty + , description = mempty + , category = mempty + , customFieldsPD = [] + , setupBuildInfo = Nothing + , library = Nothing + , subLibraries = [] + , foreignLibs = [] + , executables = [] + , testSuites = [] + , benchmarks = [] + , dataFiles = [] + , dataDir = sameDirectory + , extraSrcFiles = [] + , extraTmpFiles = [] + , extraDocFiles = [] + , extraFiles = [] + } + -- --------------------------------------------------------------------------- -- The Library type @@ -456,7 +516,7 @@ getComponent pkg cname = fromMaybe missingComponent (lookupComponent pkg cname) -- ----------------------------------------------------------------------------- -- Traversal Instances -instance L.HasBuildInfos PackageDescription where +instance L.HasBuildInfosWith Mod.HasNoAnn PackageDescription where traverseBuildInfos f ( PackageDescription diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs index a9a669c5e73..f4e72c34241 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs @@ -25,8 +25,8 @@ import Distribution.Types.ForeignLib (ForeignLib, foreignLibModules) import Distribution.Types.ForeignLib.Lens (foreignLibBuildInfo, foreignLibName) import Distribution.Types.Library (Library, explicitLibModules) import Distribution.Types.Library.Lens (libBuildInfo, libName) -import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageDescription (PackageDescription, PackageDescriptionWith) +import Distribution.Types.PackageId (PackageIdentifier, PackageIdentifierWith) import Distribution.Types.SetupBuildInfo (SetupBuildInfo) import Distribution.Types.SourceRepo (SourceRepo) import Distribution.Types.TestSuite (TestSuite, testModules) @@ -38,138 +38,142 @@ import Distribution.Version (VersionRange) import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.PackageDescription as T -package :: Lens' PackageDescription PackageIdentifier +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AnnotateWith) +import Distribution.Trivia + +package :: Lens' (PackageDescriptionWith mod) (PackageIdentifierWith mod) package f s = fmap (\x -> s{T.package = x}) (f (T.package s)) {-# INLINE package #-} -licenseRaw :: Lens' PackageDescription (Either SPDX.License License) +licenseRaw :: Lens' (PackageDescriptionWith mod) (Either SPDX.License License) licenseRaw f s = fmap (\x -> s{T.licenseRaw = x}) (f (T.licenseRaw s)) {-# INLINE licenseRaw #-} -licenseFiles :: Lens' PackageDescription [RelativePath Pkg File] +licenseFiles :: Lens' (PackageDescriptionWith mod) [RelativePath Pkg File] licenseFiles f s = fmap (\x -> s{T.licenseFiles = x}) (f (T.licenseFiles s)) {-# INLINE licenseFiles #-} -copyright :: Lens' PackageDescription ShortText +copyright :: Lens' (PackageDescriptionWith mod) ShortText copyright f s = fmap (\x -> s{T.copyright = x}) (f (T.copyright s)) {-# INLINE copyright #-} -maintainer :: Lens' PackageDescription ShortText +maintainer :: Lens' (PackageDescriptionWith mod) ShortText maintainer f s = fmap (\x -> s{T.maintainer = x}) (f (T.maintainer s)) {-# INLINE maintainer #-} -author :: Lens' PackageDescription ShortText +author :: Lens' (PackageDescriptionWith mod) ShortText author f s = fmap (\x -> s{T.author = x}) (f (T.author s)) {-# INLINE author #-} -stability :: Lens' PackageDescription ShortText +stability :: Lens' (PackageDescriptionWith mod) ShortText stability f s = fmap (\x -> s{T.stability = x}) (f (T.stability s)) {-# INLINE stability #-} -testedWith :: Lens' PackageDescription [(CompilerFlavor, VersionRange)] +testedWith :: Lens' (PackageDescriptionWith mod) [(CompilerFlavor, VersionRange)] testedWith f s = fmap (\x -> s{T.testedWith = x}) (f (T.testedWith s)) {-# INLINE testedWith #-} -homepage :: Lens' PackageDescription ShortText +homepage :: Lens' (PackageDescriptionWith mod) ShortText homepage f s = fmap (\x -> s{T.homepage = x}) (f (T.homepage s)) {-# INLINE homepage #-} -pkgUrl :: Lens' PackageDescription ShortText +pkgUrl :: Lens' (PackageDescriptionWith mod) ShortText pkgUrl f s = fmap (\x -> s{T.pkgUrl = x}) (f (T.pkgUrl s)) {-# INLINE pkgUrl #-} -bugReports :: Lens' PackageDescription ShortText +bugReports :: Lens' (PackageDescriptionWith mod) ShortText bugReports f s = fmap (\x -> s{T.bugReports = x}) (f (T.bugReports s)) {-# INLINE bugReports #-} -sourceRepos :: Lens' PackageDescription [SourceRepo] +sourceRepos :: Lens' (PackageDescriptionWith mod) [SourceRepo] sourceRepos f s = fmap (\x -> s{T.sourceRepos = x}) (f (T.sourceRepos s)) {-# INLINE sourceRepos #-} -synopsis :: Lens' PackageDescription ShortText +synopsis :: Lens' (PackageDescriptionWith mod) ShortText synopsis f s = fmap (\x -> s{T.synopsis = x}) (f (T.synopsis s)) {-# INLINE synopsis #-} -description :: Lens' PackageDescription ShortText +description :: Lens' (PackageDescriptionWith mod) ShortText description f s = fmap (\x -> s{T.description = x}) (f (T.description s)) {-# INLINE description #-} -category :: Lens' PackageDescription ShortText +category :: Lens' (PackageDescriptionWith mod) ShortText category f s = fmap (\x -> s{T.category = x}) (f (T.category s)) {-# INLINE category #-} -customFieldsPD :: Lens' PackageDescription [(String, String)] +customFieldsPD :: Lens' (PackageDescriptionWith mod) [(String, String)] customFieldsPD f s = fmap (\x -> s{T.customFieldsPD = x}) (f (T.customFieldsPD s)) {-# INLINE customFieldsPD #-} -specVersion :: Lens' PackageDescription CabalSpecVersion +specVersion :: Lens' (PackageDescriptionWith mod) (AnnotateWith Positions mod CabalSpecVersion) specVersion f s = fmap (\x -> s{T.specVersion = x}) (f (T.specVersion s)) {-# INLINE specVersion #-} -buildTypeRaw :: Lens' PackageDescription (Maybe BuildType) +buildTypeRaw :: Lens' (PackageDescriptionWith mod) (Maybe BuildType) buildTypeRaw f s = fmap (\x -> s{T.buildTypeRaw = x}) (f (T.buildTypeRaw s)) {-# INLINE buildTypeRaw #-} -setupBuildInfo :: Lens' PackageDescription (Maybe SetupBuildInfo) +setupBuildInfo :: Lens' (PackageDescriptionWith mod) (Maybe SetupBuildInfo) setupBuildInfo f s = fmap (\x -> s{T.setupBuildInfo = x}) (f (T.setupBuildInfo s)) {-# INLINE setupBuildInfo #-} -library :: Lens' PackageDescription (Maybe Library) +library :: Lens' (PackageDescriptionWith mod) (Maybe Library) library f s = fmap (\x -> s{T.library = x}) (f (T.library s)) {-# INLINE library #-} -subLibraries :: Lens' PackageDescription [Library] +subLibraries :: Lens' (PackageDescriptionWith mod) [Library] subLibraries f s = fmap (\x -> s{T.subLibraries = x}) (f (T.subLibraries s)) {-# INLINE subLibraries #-} -executables :: Lens' PackageDescription [Executable] +executables :: Lens' (PackageDescriptionWith mod) [Executable] executables f s = fmap (\x -> s{T.executables = x}) (f (T.executables s)) {-# INLINE executables #-} -foreignLibs :: Lens' PackageDescription [ForeignLib] +foreignLibs :: Lens' (PackageDescriptionWith mod) [ForeignLib] foreignLibs f s = fmap (\x -> s{T.foreignLibs = x}) (f (T.foreignLibs s)) {-# INLINE foreignLibs #-} -testSuites :: Lens' PackageDescription [TestSuite] +testSuites :: Lens' (PackageDescriptionWith mod) [TestSuite] testSuites f s = fmap (\x -> s{T.testSuites = x}) (f (T.testSuites s)) {-# INLINE testSuites #-} -benchmarks :: Lens' PackageDescription [Benchmark] +benchmarks :: Lens' (PackageDescriptionWith mod) [Benchmark] benchmarks f s = fmap (\x -> s{T.benchmarks = x}) (f (T.benchmarks s)) {-# INLINE benchmarks #-} -dataFiles :: Lens' PackageDescription [RelativePath DataDir File] +dataFiles :: Lens' (PackageDescriptionWith mod) [RelativePath DataDir File] dataFiles f s = fmap (\x -> s{T.dataFiles = x}) (f (T.dataFiles s)) {-# INLINE dataFiles #-} -dataDir :: Lens' PackageDescription (SymbolicPath Pkg (Dir DataDir)) +dataDir :: Lens' (PackageDescriptionWith mod) (SymbolicPath Pkg (Dir DataDir)) dataDir f s = fmap (\x -> s{T.dataDir = x}) (f (T.dataDir s)) {-# INLINE dataDir #-} -extraSrcFiles :: Lens' PackageDescription [RelativePath Pkg File] +extraSrcFiles :: Lens' (PackageDescriptionWith mod) [RelativePath Pkg File] extraSrcFiles f s = fmap (\x -> s{T.extraSrcFiles = x}) (f (T.extraSrcFiles s)) {-# INLINE extraSrcFiles #-} -extraTmpFiles :: Lens' PackageDescription [RelativePath Pkg File] +extraTmpFiles :: Lens' (PackageDescriptionWith mod) [RelativePath Pkg File] extraTmpFiles f s = fmap (\x -> s{T.extraTmpFiles = x}) (f (T.extraTmpFiles s)) {-# INLINE extraTmpFiles #-} -extraDocFiles :: Lens' PackageDescription [RelativePath Pkg File] +extraDocFiles :: Lens' (PackageDescriptionWith mod) [RelativePath Pkg File] extraDocFiles f s = fmap (\x -> s{T.extraDocFiles = x}) (f (T.extraDocFiles s)) {-# INLINE extraDocFiles #-} -extraFiles :: Lens' PackageDescription [RelativePath Pkg File] +extraFiles :: Lens' (PackageDescriptionWith mod) [RelativePath Pkg File] extraFiles f s = fmap (\x -> s{T.extraFiles = x}) (f (T.extraFiles s)) {-# INLINE extraFiles #-} -- | @since 3.0.0.0 -allLibraries :: Traversal' PackageDescription Library +allLibraries :: Traversal' (PackageDescriptionWith mod) Library allLibraries f pd = mk <$> traverse f (T.library pd) <*> traverse f (T.subLibraries pd) where mk l ls = pd{T.library = l, T.subLibraries = ls} -- | @since 2.4 -componentModules :: Monoid r => ComponentName -> Getting r PackageDescription [ModuleName] +componentModules :: Monoid r => ComponentName -> Getting r (PackageDescriptionWith mod) [ModuleName] componentModules cname = case cname of CLibName name -> componentModules' name allLibraries libName explicitLibModules @@ -185,10 +189,10 @@ componentModules cname = case cname of componentModules' :: (Eq name, Monoid r) => name - -> Traversal' PackageDescription a + -> Traversal' (PackageDescriptionWith mod) a -> Lens' a name -> (a -> [ModuleName]) - -> Getting r PackageDescription [ModuleName] + -> Getting r (PackageDescriptionWith mod) [ModuleName] componentModules' name pdL nameL modules = pdL . filtered ((== name) . view nameL) @@ -198,7 +202,7 @@ componentModules cname = case cname of filtered p f s = if p s then f s else pure s -- | @since 2.4 -componentBuildInfo :: ComponentName -> Traversal' PackageDescription BuildInfo +componentBuildInfo :: ComponentName -> Traversal' (PackageDescriptionWith mod) BuildInfo componentBuildInfo cname = case cname of CLibName name -> componentBuildInfo' name allLibraries libName libBuildInfo @@ -214,10 +218,10 @@ componentBuildInfo cname = case cname of componentBuildInfo' :: Eq name => name - -> Traversal' PackageDescription a + -> Traversal' (PackageDescriptionWith mod) a -> Lens' a name -> Traversal' a BuildInfo - -> Traversal' PackageDescription BuildInfo + -> Traversal' (PackageDescriptionWith mod) BuildInfo componentBuildInfo' name pdL nameL biL = pdL . filtered ((== name) . view nameL) diff --git a/Cabal-syntax/src/Distribution/Types/PackageId.hs b/Cabal-syntax/src/Distribution/Types/PackageId.hs index 0bdf475abf6..0fb1e152b53 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageId.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageId.hs @@ -1,8 +1,13 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.PackageId - ( PackageIdentifier (..) + ( PackageIdentifier + , PackageIdentifierWith (..) , PackageId ) where @@ -18,17 +23,31 @@ import qualified Data.List.NonEmpty as NE import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as Disp +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AnnotateWith) +import Distribution.Trivia + -- | Type alias so we can use the shorter name PackageId. type PackageId = PackageIdentifier +type PackageIdentifier = PackageIdentifierWith Mod.HasNoAnn + -- | The name and version of a package. -data PackageIdentifier = PackageIdentifier - { pkgName :: PackageName +data PackageIdentifierWith (mod :: Mod.HasAnnotation) = PackageIdentifier + { pkgName :: AnnotateWith Positions mod PackageName -- ^ The name of this package, eg. foo - , pkgVersion :: Version + , pkgVersion :: AnnotateWith Positions mod Version -- ^ the version of this package, eg 1.2 } - deriving (Generic, Read, Show, Eq, Ord, Data) + +deriving instance Generic PackageIdentifier +deriving instance Read PackageIdentifier +deriving instance Show PackageIdentifier +deriving instance Eq PackageIdentifier +deriving instance Ord PackageIdentifier +deriving instance Data PackageIdentifier + +deriving instance Show (PackageIdentifierWith Mod.HasAnn) instance Binary PackageIdentifier instance Structured PackageIdentifier diff --git a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs index 08305234fbd..c22a6d0450e 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs @@ -7,16 +7,19 @@ import Distribution.Compat.Lens import Distribution.Compat.Prelude import Prelude () -import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageId (PackageIdentifier, PackageIdentifierWith) import Distribution.Types.PackageName (PackageName) import Distribution.Version (Version) +import Distribution.Trivia +import Distribution.Types.Modify (AnnotateWith) + import qualified Distribution.Types.PackageId as T -pkgName :: Lens' PackageIdentifier PackageName +pkgName :: Lens' (PackageIdentifierWith mod) (AnnotateWith Positions mod PackageName) pkgName f s = fmap (\x -> s{T.pkgName = x}) (f (T.pkgName s)) {-# INLINE pkgName #-} -pkgVersion :: Lens' PackageIdentifier Version +pkgVersion :: Lens' (PackageIdentifierWith mod) (AnnotateWith Positions mod Version) pkgVersion f s = fmap (\x -> s{T.pkgVersion = x}) (f (T.pkgVersion s)) {-# INLINE pkgVersion #-} diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index 8a22662d672..f130b32902e 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -1,8 +1,17 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Distribution.Types.PackageName ( PackageName + , PackageNameAnn + , PackageNameWith (..) + , unannotatePackageName , unPackageName , mkPackageName , unPackageNameST @@ -15,8 +24,13 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia import qualified Text.PrettyPrint as Disp +import Data.Kind +import Distribution.Types.Modify (Annotate) +import qualified Distribution.Types.Modify as Mod + -- | A package name. -- -- Use 'mkPackageName' and 'unPackageName' to convert from/to a @@ -25,8 +39,27 @@ import qualified Text.PrettyPrint as Disp -- This type is opaque since @Cabal-2.0@ -- -- @since 2.0.0.2 -newtype PackageName = PackageName ShortText - deriving (Generic, Read, Show, Eq, Ord, Data) +type PackageName = PackageNameWith Mod.HasNoAnn + +type PackageNameAnn = PackageNameWith Mod.HasAnn + +newtype PackageNameWith (m :: Mod.HasAnnotation) = PackageName (Annotate m ShortText) + deriving (Generic) + +deriving instance Show PackageName +deriving instance Read PackageName +deriving instance Eq PackageName +deriving instance Ord PackageName +deriving instance Data PackageName + +deriving instance Show PackageNameAnn +deriving instance Read PackageNameAnn +deriving instance Eq PackageNameAnn +deriving instance Ord PackageNameAnn +deriving instance Data PackageNameAnn + +unannotatePackageName :: PackageNameWith Mod.HasAnn -> PackageName +unannotatePackageName (PackageName pname) = PackageName (unAnn pname) -- | Convert 'PackageName' to 'String' unPackageName :: PackageName -> String @@ -68,8 +101,14 @@ instance Structured PackageName instance Pretty PackageName where pretty = Disp.text . unPackageName +instance Pretty PackageNameAnn where + pretty (PackageName (Ann t x)) = applyTriviaDoc t $ Disp.text $ fromShortText x + instance Parsec PackageName where parsec = mkPackageName <$> parsecUnqualComponentName +instance Parsec (PackageNameWith Mod.HasAnn) where + parsec = PackageName . Ann mempty . toShortText <$> parsecUnqualComponentName + instance NFData PackageName where rnf (PackageName pkg) = rnf pkg diff --git a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs index 013226ca2d5..7e81bbdac8d 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageVersionConstraint.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Types.PackageVersionConstraint @@ -53,7 +54,7 @@ instance Pretty PackageVersionConstraint where -- Just (PackageVersionConstraint (PackageName "foo") (ThisVersion (mkVersion [2,0]))) instance Parsec PackageVersionConstraint where parsec = do - PackageIdentifier name ver <- parsec + PackageIdentifier name ver <- parsec @PackageIdentifier if ver == nullVersion then do P.spaces diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs index 129e17dabfb..bea9322b2bd 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -1,8 +1,15 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.TestSuite - ( TestSuite (..) + ( TestSuite + , TestSuiteWith (..) , emptyTestSuite , testType , testModules @@ -20,17 +27,27 @@ import Distribution.Types.UnqualComponentName import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.Modify as Mod + +type TestSuite = TestSuiteWith Mod.HasNoAnn -- | A \"test-suite\" stanza in a cabal file. -data TestSuite = TestSuite +data TestSuiteWith (mod :: Mod.HasAnnotation) = TestSuite { testName :: UnqualComponentName , testInterface :: TestSuiteInterface - , testBuildInfo :: BuildInfo + , testBuildInfo :: BuildInfoWith mod , testCodeGenerators :: [String] } - deriving (Generic, Show, Read, Eq, Ord, Data) +deriving instance Generic TestSuite +deriving instance Show TestSuite +deriving instance Read TestSuite +deriving instance Eq TestSuite +deriving instance Ord TestSuite +deriving instance Data TestSuite + +deriving instance Show (TestSuiteWith Mod.HasAnn) -instance L.HasBuildInfo TestSuite where +instance forall (mod :: Mod.HasAnnotation). L.HasBuildInfoWith mod (TestSuiteWith mod) where buildInfo f l = (\x -> l{testBuildInfo = x}) <$> f (testBuildInfo l) instance Binary TestSuite @@ -59,9 +76,32 @@ instance Semigroup TestSuite where where combine field = field a `mappend` field b +instance Semigroup (TestSuiteWith Mod.HasAnn) where + a <> b = + TestSuite + { testName = combineNames a b testName "test" + , testInterface = combine testInterface + , testBuildInfo = combine testBuildInfo + , testCodeGenerators = combine testCodeGenerators + } + where + combine field = field a `mappend` field b + +instance Monoid (TestSuiteWith Mod.HasAnn) where + mempty = emptyTestSuite' + emptyTestSuite :: TestSuite emptyTestSuite = mempty +emptyTestSuite' :: TestSuiteWith Mod.HasAnn +emptyTestSuite' = + TestSuite + { testName = mempty + , testInterface = mempty + , testBuildInfo = mempty + , testCodeGenerators = mempty + } + testType :: TestSuite -> TestType testType test = case testInterface test of TestSuiteExeV10 ver _ -> TestTypeExe ver diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs index f671759b42f..8ae9e7e6f61 100644 --- a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs +++ b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -8,6 +9,7 @@ module Distribution.Types.UnqualComponentName , unUnqualComponentNameST , mkUnqualComponentName , packageNameToUnqualComponentName + , packageNameToUnqualComponentNameWith , unqualComponentNameToPackageName , combineNames ) where @@ -17,6 +19,8 @@ import Distribution.Utils.ShortText import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia +import qualified Distribution.Types.Modify as Mod import Distribution.Types.PackageName -- | An unqualified component name, for any kind of component. @@ -93,6 +97,9 @@ instance NFData UnqualComponentName where packageNameToUnqualComponentName :: PackageName -> UnqualComponentName packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST +packageNameToUnqualComponentNameWith :: PackageNameWith Mod.HasAnn -> Ann SurroundingText UnqualComponentName +packageNameToUnqualComponentNameWith (PackageName u) = fmap UnqualComponentName u + -- | Converts an unqualified component name to a package name -- -- `packageNameToUnqualComponentName` is the inverse of diff --git a/Cabal-syntax/src/Distribution/Types/Version.hs b/Cabal-syntax/src/Distribution/Types/Version.hs index c821062ee3d..00c8882fe5e 100644 --- a/Cabal-syntax/src/Distribution/Types/Version.hs +++ b/Cabal-syntax/src/Distribution/Types/Version.hs @@ -1,10 +1,15 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} module Distribution.Types.Version ( -- * Package versions Version + , VersionAnn , mkVersion + , mkVersionAnn , mkVersion' , versionNumbers , nullVersion @@ -22,6 +27,7 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia import qualified Data.Version as Base import qualified Distribution.Compat.CharParsing as P @@ -39,6 +45,8 @@ import qualified Text.Read as Read -- 'Binary' instance using a different (and more compact) encoding. -- -- @since 2.0.0.2 +type VersionAnn = Ann SurroundingText Version + data Version = PV0 {-# UNPACK #-} !Word64 | PV1 !Int [Int] @@ -98,6 +106,12 @@ instance Pretty Version where (map Disp.int $ versionNumbers ver) ) +instance Pretty VersionAnn where + pretty (Ann t ver) = applyTrivia $ fmap pretty (t, ver) + where + applyTrivia :: (Trivia SurroundingText, Disp.Doc) -> Disp.Doc + applyTrivia = uncurry applyTriviaDoc + instance Parsec Version where parsec = mkVersion <$> toList <$> P.sepByNonEmpty versionDigitParser (P.char '.') <* tags where @@ -191,6 +205,9 @@ mkVersion (v1 : vs@[v2, v3, v4]) mkWord64VerRep4 y1 y2 y3 y4 = mkWord64VerRep (y1 + 1) (y2 + 1) (y3 + 1) (y4 + 1) mkVersion (v1 : vs) = PV1 v1 vs +mkVersionAnn :: Trivia SurroundingText -> [Int] -> VersionAnn +mkVersionAnn t vs = Ann t (mkVersion vs) + -- | Version 0. A lower bound of 'Version'. -- -- @since 2.2 diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange.hs b/Cabal-syntax/src/Distribution/Types/VersionRange.hs index 6f451d0d5e1..eb49bbc099e 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange.hs @@ -4,6 +4,9 @@ module Distribution.Types.VersionRange ( -- * Version Range VersionRange + , VersionRangeAnn + , VersionRangeWith (..) + , unAnnVersionRange -- ** Predicates -- $predicate-examples @@ -23,6 +26,7 @@ module Distribution.Types.VersionRange -- ** Constructing , anyVersion + , anyVersionAnn , noVersion , thisVersion , notThisVersion diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs index a62b82fc04b..a381d250946 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs @@ -1,10 +1,16 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | The only purpose of this module is to prevent the export of @@ -12,8 +18,12 @@ -- "Distribution.Types.VersionRange". To avoid creating orphan -- instances, a lot of related code had to be moved here too. module Distribution.Types.VersionRange.Internal - ( VersionRange (..) + ( VersionRange + , VersionRangeAnn + , VersionRangeWith (..) + , unAnnVersionRange , anyVersion + , anyVersionAnn , noVersion , thisVersion , notThisVersion @@ -31,9 +41,11 @@ module Distribution.Types.VersionRange.Internal , cataVersionRange , anaVersionRange , hyloVersionRange + , hyloVersionRangeAnn , versionRangeParser , majorUpperBound , wildcardUpperBound + , wildcardUpperBoundAnn ) where import Distribution.Compat.Prelude @@ -43,27 +55,118 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia import Distribution.Utils.Generic (unsnoc) import qualified Distribution.Compat.CharParsing as P import qualified Distribution.Compat.DList as DList import qualified Text.PrettyPrint as Disp -data VersionRange - = ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | OrLaterVersion Version -- >= version - | EarlierVersion Version -- < version - | OrEarlierVersion Version -- <= version - | MajorBoundVersion Version -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - deriving (Data, Eq, Ord, Generic, Read, Show) +import qualified Distribution.Types.Modify as Mod + +import Control.Applicative +import Data.Kind + +type VersionRange = VersionRangeWith Mod.HasNoAnn +type VersionRangeAnn = VersionRangeWith Mod.HasAnn + +-- | Dependending on whether the data is a leaf, we annotate differently +type family Modify (m :: Mod.HasAnnotation) (a :: Type) where + Modify Mod.HasNoAnn a = a + Modify Mod.HasAnn Version = (Trivia SurroundingText, VersionAnn) + Modify Mod.HasAnn (VersionRangeWith Mod.HasAnn) = (Trivia SurroundingText, VersionRangeWith Mod.HasAnn) + +data VersionRangeWith (m :: Mod.HasAnnotation) + = ThisVersion (Modify m Version) -- = version + | LaterVersion (Modify m Version) -- > version (NB. not >=) + | OrLaterVersion (Modify m Version) -- >= version + | EarlierVersion (Modify m Version) -- < version + | OrEarlierVersion (Modify m Version) -- <= version + | MajorBoundVersion (Modify m Version) -- @^>= ver@ (same as >= ver && < MAJ(ver)+1) + | UnionVersionRanges (Modify m (VersionRangeWith m)) (Modify m (VersionRangeWith m)) + | IntersectVersionRanges (Modify m (VersionRangeWith m)) (Modify m (VersionRangeWith m)) + deriving (Generic) + +deriving instance Eq VersionRange +deriving instance Ord VersionRange +deriving instance Data VersionRange +deriving instance Read VersionRange +deriving instance Show VersionRange + +deriving instance Eq VersionRangeAnn +deriving instance Ord VersionRangeAnn +deriving instance Data VersionRangeAnn +deriving instance Read VersionRangeAnn +deriving instance Show VersionRangeAnn instance Binary VersionRange instance Structured VersionRange instance NFData VersionRange where rnf = genericRnf +unAnnVersionRange :: VersionRangeAnn -> VersionRange +unAnnVersionRange (ThisVersion v) = ThisVersion (unAnn $ snd v) +unAnnVersionRange (LaterVersion v) = LaterVersion (unAnn $ snd v) +unAnnVersionRange (OrLaterVersion v) = OrLaterVersion (unAnn $ snd v) +unAnnVersionRange (EarlierVersion v) = EarlierVersion (unAnn $ snd v) +unAnnVersionRange (OrEarlierVersion v) = OrEarlierVersion (unAnn $ snd v) +unAnnVersionRange (MajorBoundVersion v) = MajorBoundVersion (unAnn $ snd v) +unAnnVersionRange (UnionVersionRanges a b) = UnionVersionRanges (unAnnVersionRange $ snd a) (unAnnVersionRange $ snd b) +unAnnVersionRange (IntersectVersionRanges a b) = IntersectVersionRanges (unAnnVersionRange $ snd a) (unAnnVersionRange $ snd b) + +-- | Map annotation to a already annotated VersionRange data +mapVersionRangeAnn + :: ( (Trivia SurroundingText, VersionAnn) -> (Trivia SurroundingText, VersionAnn) + ) + -> ( (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) + ) + -> ( (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) + ) + -> VersionRangeAnn + -> VersionRangeAnn +mapVersionRangeAnn mapLeaf mapBranchL mapBranchR vr = case vr of + ThisVersion v -> ThisVersion (mapLeaf v) + LaterVersion v -> LaterVersion (mapLeaf v) + OrLaterVersion v -> OrLaterVersion (mapLeaf v) + EarlierVersion v -> EarlierVersion (mapLeaf v) + OrEarlierVersion v -> OrEarlierVersion (mapLeaf v) + MajorBoundVersion v -> MajorBoundVersion (mapLeaf v) + UnionVersionRanges a b -> UnionVersionRanges (mapBranchL a) (mapBranchR b) + IntersectVersionRanges a b -> IntersectVersionRanges (mapBranchL a) (mapBranchR b) + +decorateTriviaVersionRangeAnn + :: (Trivia SurroundingText, Trivia SurroundingText) + -> VersionRangeAnn + -> ((Trivia SurroundingText, VersionRangeAnn), VersionRangeAnn) +decorateTriviaVersionRangeAnn (leading, trailing) vr = (enclose vr, insert vr) + where + enclose = (leading <> trailing,) + insert = + mapVersionRangeAnn + ( \(ann, v) -> (leading <> ann <> trailing, v) + ) + ( \(ann, vrl) -> (leading <> ann, vrl) + ) + ( \(ann, vrr) -> (ann, insertTrailing vrr) + ) + + insertTrailing = + mapVersionRangeAnn + ( \(ann, v) -> (ann <> trailing, v) + ) + id + ( \(ann, vrr) -> (ann, insertTrailing vrr) + ) + +-- | LiftA3 with a different ordering +surroundWith + :: Applicative f + => (a -> b -> c -> d) + -> f a + -> f c + -> f b + -> f d +surroundWith f = liftA3 (\u v w -> f u w v) + -- | The version range @-any@. That is, a version range containing all -- versions. -- @@ -71,6 +174,9 @@ instance NFData VersionRange where rnf = genericRnf anyVersion :: VersionRange anyVersion = OrLaterVersion (mkVersion [0]) +anyVersionAnn :: VersionRangeAnn +anyVersionAnn = OrLaterVersion (ExactRepresentation "-any", Ann mempty $ mkVersion [0]) + -- | The empty version range @-none@, that is a version range containing no versions. -- -- This can be constructed using any unsatisfiable version range expression, @@ -80,12 +186,18 @@ anyVersion = OrLaterVersion (mkVersion [0]) noVersion :: VersionRange noVersion = EarlierVersion (mkVersion [0]) +noVersionAnn :: VersionRangeAnn +noVersionAnn = EarlierVersion (ExactRepresentation "-none", Ann mempty $ mkVersion [0]) + -- | The version range @== v@. -- -- > withinRange v' (thisVersion v) = v' == v thisVersion :: Version -> VersionRange thisVersion = ThisVersion +thisVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +thisVersionAnn = ThisVersion + -- | The version range @/= v@. -- -- > withinRange v' (notThisVersion v) = v' /= v @@ -98,24 +210,36 @@ notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) laterVersion :: Version -> VersionRange laterVersion = LaterVersion +laterVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +laterVersionAnn = LaterVersion + -- | The version range @>= v@. -- -- > withinRange v' (orLaterVersion v) = v' >= v orLaterVersion :: Version -> VersionRange orLaterVersion = OrLaterVersion +orLaterVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +orLaterVersionAnn = OrLaterVersion + -- | The version range @< v@. -- -- > withinRange v' (earlierVersion v) = v' < v earlierVersion :: Version -> VersionRange earlierVersion = EarlierVersion +earlierVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +earlierVersionAnn = EarlierVersion + -- | The version range @<= v@. -- -- > withinRange v' (orEarlierVersion v) = v' <= v orEarlierVersion :: Version -> VersionRange orEarlierVersion = OrEarlierVersion +orEarlierVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +orEarlierVersionAnn = OrEarlierVersion + -- | The version range @vr1 || vr2@. -- -- > withinRange v' (unionVersionRanges vr1 vr2) @@ -123,6 +247,9 @@ orEarlierVersion = OrEarlierVersion unionVersionRanges :: VersionRange -> VersionRange -> VersionRange unionVersionRanges = UnionVersionRanges +unionVersionRangesAnn :: (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) -> VersionRangeAnn +unionVersionRangesAnn = UnionVersionRanges + -- | The version range @vr1 && vr2@. -- -- > withinRange v' (intersectVersionRanges vr1 vr2) @@ -130,6 +257,9 @@ unionVersionRanges = UnionVersionRanges intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges +intersectVersionRangesAnn :: (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) -> VersionRangeAnn +intersectVersionRangesAnn = IntersectVersionRanges + -- | The version range @== v.*@. -- -- For example, for version @1.2@, the version range @== 1.2.*@ is the same as @@ -144,6 +274,13 @@ withinVersion v = (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) +-- TODO(leana8959): how to detect that this is inserted +withinVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +withinVersionAnn v = + intersectVersionRangesAnn + (mempty, orLaterVersionAnn v) + (mempty, earlierVersionAnn (wildcardUpperBoundAnn v)) + -- | The version range @^>= v@. -- -- For example, for version @1.2.3.4@, the version range @^>= 1.2.3.4@ @@ -155,6 +292,9 @@ withinVersion v = majorBoundVersion :: Version -> VersionRange majorBoundVersion = MajorBoundVersion +majorBoundVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn +majorBoundVersionAnn = MajorBoundVersion + -- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. -- -- @since 2.2 @@ -250,6 +390,13 @@ hyloVersionRange -> VersionRange hyloVersionRange f g = h where h = f . fmap h . g +hyloVersionRangeAnn + :: (VersionRangeF VersionRangeAnn -> VersionRangeAnn) + -> (VersionRangeAnn -> VersionRangeF VersionRangeAnn) + -> VersionRangeAnn + -> VersionRangeAnn +hyloVersionRangeAnn f g = h where h = f . fmap h . g + ------------------------------------------------------------------------------- -- Parsec & Pretty ------------------------------------------------------------------------------- @@ -309,6 +456,33 @@ prettyVersionRange16 (IntersectVersionRanges (OrLaterVersion v) (EarlierVersion <<>> Disp.text ".*" prettyVersionRange16 vr = prettyVersionRange vr +instance Pretty VersionRangeAnn where + pretty = prettyVersionRangeAnn + +-- TODO(leana8959): how do we know if the element is inserted and we need to fallback +prettyVersionRangeAnn :: VersionRangeAnn -> Disp.Doc +prettyVersionRangeAnn vr = case vr of + ThisVersion vAnn -> applyLeafTrivia (Disp.text "==") vAnn + LaterVersion vAnn -> applyLeafTrivia (Disp.text ">") vAnn + OrLaterVersion vAnn -> applyLeafTrivia (Disp.text ">=") vAnn + EarlierVersion vAnn -> applyLeafTrivia (Disp.text "<") vAnn + OrEarlierVersion vAnn -> applyLeafTrivia (Disp.text "<=") vAnn + MajorBoundVersion vAnn -> applyLeafTrivia (Disp.text "^>=") vAnn + UnionVersionRanges r1 r2 -> + applyBranchTrivia (fmap prettyVersionRangeAnn r1) + <> "||" + <> applyBranchTrivia (fmap prettyVersionRangeAnn r2) + IntersectVersionRanges r1 r2 -> + applyBranchTrivia (fmap prettyVersionRangeAnn r1) + <> "&&" + <> applyBranchTrivia (fmap prettyVersionRangeAnn r2) + where + applyLeafTrivia :: Disp.Doc -> (Trivia SurroundingText, VersionAnn) -> Disp.Doc + applyLeafTrivia symb (t, v) = applyTriviaDoc t (symb <> pretty v) + + applyBranchTrivia :: (Trivia SurroundingText, Disp.Doc) -> Disp.Doc + applyBranchTrivia = uncurry applyTriviaDoc + -- | -- -- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange @@ -349,6 +523,9 @@ prettyVersionRange16 vr = prettyVersionRange vr instance Parsec VersionRange where parsec = askCabalSpecVersion >>= versionRangeParser versionDigitParser +instance Parsec VersionRangeAnn where + parsec = askCabalSpecVersion >>= versionRangeAnnParser versionDigitParser + -- | 'VersionRange' parser parametrised by version digit parser. -- -- - 'versionDigitParser' is used for all 'VersionRange'. @@ -357,71 +534,100 @@ instance Parsec VersionRange where -- -- @since 3.0 versionRangeParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRange -versionRangeParser digitParser csv = expr +versionRangeParser digitParser csv = unAnnVersionRange <$> versionRangeAnnParser digitParser csv + +-- TODO(leana8959): implement this +versionRangeAnnParser :: forall m. CabalParsing m => m Int -> CabalSpecVersion -> m VersionRangeAnn +versionRangeAnnParser digitParser csv = expr where + expr :: m VersionRangeAnn expr = do - P.spaces - t <- term - P.spaces + (tEnclosed, tInserted) <- + surroundWith + (curry decorateTriviaVersionRangeAnn) + (preTrivia <$> P.spaces') + term + (postTrivia <$> P.spaces') + ( do _ <- P.string "||" checkOp - P.spaces - e <- expr - return (unionVersionRanges t e) - <|> return t + (eEnclosed, _eInserted) <- + surroundWith + (curry decorateTriviaVersionRangeAnn) + (preTrivia <$> P.spaces') + expr + (pure mempty) + + return (unionVersionRangesAnn tEnclosed eEnclosed) + <|> return tInserted ) + + term :: m VersionRangeAnn term = do - f <- factor - P.spaces + (fEnclosed, fInserted) <- + surroundWith + (curry decorateTriviaVersionRangeAnn) + (pure mempty) + factor + (postTrivia <$> P.spaces') + ( do _ <- P.string "&&" checkOp - P.spaces - t <- term - return (intersectVersionRanges f t) - <|> return f + (tEnclosed, _tInserted) <- + surroundWith + (curry decorateTriviaVersionRangeAnn) + (preTrivia <$> P.spaces') + term + (pure mempty) + + return (intersectVersionRangesAnn fEnclosed tEnclosed) + <|> return fInserted ) + + factor :: m VersionRangeAnn factor = parens expr <|> prim + prim :: m VersionRangeAnn prim = do op <- P.munch1 isOpChar P. "operator" case op of - "-" -> anyVersion <$ P.string "any" <|> P.string "none" *> noVersion' + "-" -> anyVersionAnn <$ P.string "any" <|> P.string "none" *> noVersion' "==" -> do - P.spaces + pre <- preTrivia <$> P.spaces' ( do (wild, v) <- verOrWild checkWild wild - pure $ (if wild then withinVersion else thisVersion) v - <|> (verSet' thisVersion =<< verSet) + pure $ (if wild then withinVersionAnn else thisVersionAnn) (mempty, Ann pre v) + <|> (verSet' (thisVersionAnn . (mempty,)) =<< verSet) ) "^>=" -> do - P.spaces + pre <- preTrivia <$> P.spaces' ( do (wild, v) <- verOrWild when wild $ - P.unexpected "wild-card version after ^>= operator" - majorBoundVersion' v - <|> (verSet' majorBoundVersion =<< verSet) + P.unexpected $ + "wild-card version after ^>= operator" + majorBoundVersion' (mempty, Ann pre v) + <|> (verSet' (majorBoundVersionAnn . (mempty,)) =<< verSet) ) _ -> do - P.spaces + pre <- preTrivia <$> P.spaces' (wild, v) <- verOrWild when wild $ P.unexpected $ "wild-card version after non-== operator: " ++ show op case op of - ">=" -> pure $ orLaterVersion v - "<" -> pure $ earlierVersion v - "<=" -> pure $ orEarlierVersion v - ">" -> pure $ laterVersion v + ">=" -> pure $ orLaterVersionAnn (mempty, Ann pre v) + "<" -> pure $ earlierVersionAnn (mempty, Ann pre v) + "<=" -> pure $ orEarlierVersionAnn (mempty, Ann pre v) + ">" -> pure $ laterVersionAnn (mempty, Ann pre v) _ -> fail $ "Unknown version operator " ++ show op -- Cannot be warning -- On 2020-03-16 there was around 27400 files on Hackage failing to parse due this -- For example https://hackage.haskell.org/package/haxr-3000.0.0/haxr.cabal - -- checkOp = when (csv < CabalSpecV1_8) $ parsecWarning PWTVersionOperator $ @@ -433,7 +639,6 @@ versionRangeParser digitParser csv = expr -- Cannot be warning -- On 2020-03-16 there was 46 files on Hackage failing to parse due this -- For example https://hackage.haskell.org/package/derive-0.1.2/derive.cabal - -- checkWild False = pure () checkWild True = when (csv < CabalSpecV1_6) $ @@ -457,9 +662,10 @@ versionRangeParser digitParser csv = expr isOpChar _ = False -- -none version range is available since 1.22 + noVersion' :: m VersionRangeAnn noVersion' = if csv >= CabalSpecV1_22 - then pure noVersion + then pure noVersionAnn else fail $ unwords @@ -470,29 +676,38 @@ versionRangeParser digitParser csv = expr ] -- \^>= is available since 2.0 + majorBoundVersion' :: (Trivia SurroundingText, VersionAnn) -> m VersionRangeAnn majorBoundVersion' v = if csv >= CabalSpecV2_0 - then pure $ majorBoundVersion v + then pure $ majorBoundVersionAnn v else fail $ unwords [ "major bounded version syntax (caret, ^>=) used." , "To use this syntax the package need to specify at least 'cabal-version: 2.0'." , "Alternatively, if broader compatibility is important then use:" - , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersion v + -- , prettyShow $ eliminateMajorBoundSyntax $ majorBoundVersionAnn v ] where - eliminateMajorBoundSyntax = hyloVersionRange embed projectVersionRange - embed (MajorBoundVersionF u) = - intersectVersionRanges - (orLaterVersion u) - (earlierVersion (majorUpperBound u)) - embed vr = embedVersionRange vr + + -- TODO(leana8959): rewrite the hyloVersionRange and VersionRangeF and then deal with this + -- + -- eliminateMajorBoundSyntax :: VersionRangeAnn -> VersionRangeAnn + -- eliminateMajorBoundSyntax = undefined + -- -- hyloVersionRangeAnn embed projectVersionRange + -- + -- embed (MajorBoundVersionF u) = + -- intersectVersionRanges + -- (orLaterVersion u) + -- (earlierVersion (majorUpperBound u)) + -- embed vr = embedVersionRange vr -- version set notation (e.g. "== { 0.0.1.0, 0.0.2.0, 0.1.0.0 }") + -- exactprint doesn't support braces + verSet' :: (t -> VersionRangeAnn) -> NonEmpty t -> m VersionRangeAnn verSet' op vs = if csv >= CabalSpecV3_0 - then pure $ foldr1 unionVersionRanges (fmap op vs) + then pure $ foldr1 (\x y -> unionVersionRangesAnn (mempty, x) (mempty, y)) (fmap op vs) else fail $ unwords @@ -500,16 +715,18 @@ versionRangeParser digitParser csv = expr , "To use this syntax the package needs to specify at least 'cabal-version: 3.0'." , "Alternatively, if broader compatibility is important then use" , "a series of single version constraints joined with the || operator:" - , prettyShow (foldr1 unionVersionRanges (fmap op vs)) + -- TODO(leana8959): fix the pretty instance + -- , prettyShow (foldr1 (\x y -> unionVersionRangesAnn (Ann NoTrivia x) y) (fmap op vs)) ] - verSet :: CabalParsing m => m (NonEmpty Version) + -- TODO(leana8959): register this trivia + verSet :: CabalParsing m => m (NonEmpty VersionAnn) verSet = do _ <- P.char '{' P.spaces vs <- P.sepByNonEmpty (verPlain <* P.spaces) (P.char ',' *> P.spaces) _ <- P.char '}' - pure vs + pure (Ann mempty <$> vs) -- a plain version without tags or wildcards verPlain :: CabalParsing m => m Version @@ -534,13 +751,31 @@ versionRangeParser digitParser csv = expr let wild = (True, mkVersion (DList.toList acc)) <$ P.char '*' digit <|> wild - parens p = P.between - ((P.char '(' P. "opening paren") >> P.spaces) - (P.char ')' >> P.spaces) - $ do - a <- p - P.spaces - return a + parens :: m VersionRangeAnn -> m VersionRangeAnn + parens p = do + let open :: m String + open = + liftA2 + (:) + (P.char '(' P. "opening paren") + P.spaces' + + close :: m String + close = + liftA3 + (\u v w -> u ++ [v] ++ w) + P.spaces' + (P.char ')') + P.spaces' + + (_enclosed, inserted) <- + surroundWith + (\pre post x -> decorateTriviaVersionRangeAnn (pre, post) x) + (preTrivia <$> open) + p + (postTrivia <$> close) + + pure inserted tags :: CabalParsing m => m () tags = do @@ -577,3 +812,6 @@ wildcardUpperBound = alterVersion $ \lowerBound -> case unsnoc lowerBound of Nothing -> [] Just (xs, x) -> xs ++ [x + 1] + +wildcardUpperBoundAnn :: (Trivia SurroundingText, VersionAnn) -> (Trivia SurroundingText, VersionAnn) +wildcardUpperBoundAnn = (fmap . fmap) wildcardUpperBound diff --git a/Cabal-syntax/src/Distribution/Version.hs b/Cabal-syntax/src/Distribution/Version.hs index 2abf88100a8..6942b4f6cb6 100644 --- a/Cabal-syntax/src/Distribution/Version.hs +++ b/Cabal-syntax/src/Distribution/Version.hs @@ -24,9 +24,12 @@ module Distribution.Version -- * Version ranges , VersionRange + , VersionRangeAnn + , VersionRangeWith (..) -- ** Constructing , anyVersion + , anyVersionAnn , noVersion , thisVersion , notThisVersion diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal index 50ee8893b3f..3808667e5bd 100644 --- a/Cabal-tests/Cabal-tests.cabal +++ b/Cabal-tests/Cabal-tests.cabal @@ -93,6 +93,7 @@ test-suite parser-tests , tasty-golden >=2.3.1.1 && <2.4 , tasty-hunit , tree-diff >=0.1 && <0.4 + , pretty-simple ghc-options: -Wall default-language: Haskell2010 diff --git a/Cabal-tests/tests/HackageTests.hs b/Cabal-tests/tests/HackageTests.hs index b5cfab5d4ec..226965b9285 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -1,5 +1,8 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-pattern-binds #-} -- pattern match to assert field count @@ -21,7 +24,7 @@ import Distribution.PackageDescription.Check (PackageCheck (..), checkPack import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import Distribution.PackageDescription.Quirks (patchQuirks) import Distribution.PackageDescription - ( GenericPackageDescription(GenericPackageDescription) + ( GenericPackageDescriptionWith(GenericPackageDescription) , packageDescription , gpdScannedVersion , genPackageFlags @@ -32,6 +35,7 @@ import Distribution.PackageDescription , condTestSuites , condBenchmarks ) +import qualified Distribution.Types.Modify as Mod import Distribution.Simple.Utils (fromUTF8BS, toUTF8BS) import Distribution.Fields.ParseResult import Distribution.Parsec.Source @@ -180,10 +184,35 @@ parseParsecTest keepGoing fpath bs = do traverse_ (putStrLn . Parsec.showPErrorWithSource . fmap renderCabalFileSource) errors exitFailure +-- Whether we can parse everything with annotation +parseParsecTest' :: Bool -> FilePath -> B.ByteString -> IO ParsecResult +parseParsecTest' keepGoing fpath bs = do + let (warnings, result) = Parsec.runParseResult $ + withSource (PCabalFile (fpath, bs)) $ Parsec.parseGenericPackageDescription @Mod.HasAnn bs + + let w | null warnings = 0 + | otherwise = 1 + + case result of + Right gpd -> do + forEachGPD' fpath bs gpd + return (ParsecResult 1 w 0) + + Left (_, errors) | keepGoing -> do + traverse_ (putStrLn . Parsec.showPErrorWithSource . fmap renderCabalFileSource) errors + return (ParsecResult 1 w 1) + | otherwise -> do + traverse_ (putStrLn . Parsec.showPErrorWithSource . fmap renderCabalFileSource) errors + exitFailure + -- | A hook to make queries on Hackage forEachGPD :: FilePath -> B8.ByteString -> L.GenericPackageDescription -> IO () forEachGPD _ _ _ = return () +-- | A hook to make queries on Hackage +forEachGPD' :: FilePath -> B8.ByteString -> (GenericPackageDescriptionWith Mod.HasAnn) -> IO () +forEachGPD' _ _ _ = return () + ------------------------------------------------------------------------------- -- ParsecResult ------------------------------------------------------------------------------- @@ -361,6 +390,7 @@ main = join (O.execParser opts) [ command "read-fields" readFieldsP "Parse outer format (to '[Field]', TODO: apply Quirks)" , command "parsec" parsecP "Parse GPD with parsec" + , command "parsec-ann" parsecP' "Parse GPD with parsec (with annotation)" , command "roundtrip" roundtripP "parse . pretty . parse = parse" , command "check" checkP "Check GPD" ] <|> pure defaultA @@ -373,6 +403,7 @@ main = join (O.execParser opts) readFieldsA pfx idx = parseIndex (mkPredicate pfx idx) readFieldTest parsecP = parsecA <$> prefixP <*> keepGoingP <*> indexP + parsecP' = parsecA' <$> prefixP <*> keepGoingP <*> indexP keepGoingP = O.flag' True (O.long "keep-going") <|> O.flag' False (O.long "no-keep-going") <|> @@ -390,6 +421,18 @@ main = join (O.execParser opts) putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed" putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e6 / fromIntegral n :: Double) " milliseconds per file" + parsecA' pfx keepGoing idx = do + begin <- Clock.getTime Clock.Monotonic + ParsecResult n w f <- parseIndex (mkPredicate pfx idx) (parseParsecTest' keepGoing) + end <- Clock.getTime Clock.Monotonic + let diff = Clock.toNanoSecs $ Clock.diffTimeSpec end begin + + putStrLn $ show n ++ " files processed" + putStrLn $ show w ++ " files contained warnings" + putStrLn $ show f ++ " files failed to parse" + putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e9 :: Double) " seconds elapsed" + putStrLn $ showFFloat (Just 6) (fromInteger diff / 1e6 / fromIntegral n :: Double) " milliseconds per file" + roundtripP = roundtripA <$> prefixP <*> testFieldsP <*> indexP roundtripA pfx testFieldsTransform idx = do Sum n <- parseIndex (mkPredicate pfx idx) (roundtripTest testFieldsTransform) diff --git a/Cabal-tests/tests/NoThunks.hs b/Cabal-tests/tests/NoThunks.hs index 323597eea82..f9c34040719 100644 --- a/Cabal-tests/tests/NoThunks.hs +++ b/Cabal-tests/tests/NoThunks.hs @@ -6,6 +6,7 @@ main = putStrLn "Old GHC, no nothunks" #else {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 42ab00ae9f2..ae911fe29e3 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -1,4 +1,10 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Main ( main ) where @@ -13,7 +19,8 @@ import Test.Tasty.HUnit import Control.Monad (void) import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) import Data.Maybe (isNothing) -import Distribution.Fields (pwarning) +import Distribution.CabalSpecVersion +import Distribution.Fields (pwarning, readFields) import Distribution.PackageDescription ( GenericPackageDescription , packageDescription @@ -26,25 +33,50 @@ import Distribution.PackageDescription , condTestSuites , condBenchmarks ) -import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.PackageDescription.PrettyPrint (ppGenericPackageDescriptionAnn) +import Distribution.PackageDescription.FieldGrammar(buildInfoFieldGrammar, miniBuildInfoFieldGrammar, MiniBuildInfo (..)) +import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, sectionizeFields, takeFields) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) -import Distribution.Parsec (PWarnType (..), PWarning (..), showPErrorWithSource, showPWarningWithSource) -import Distribution.Pretty (prettyShow) +import Distribution.Parsec (Parsec (..), explicitEitherParsec', PWarnType (..), PWarning (..), showPErrorWithSource, showPWarningWithSource) +import Distribution.Pretty (Pretty (..), prettyShow) +import Distribution.Fields.Parser (readFields') import Distribution.Fields.ParseResult +import Distribution.Fields.Pretty (PrettyFieldWith (..), exactShowFields, filterFields) +import Distribution.FieldGrammar.Parsec (ParsecFieldGrammar, parseFieldGrammar) +import Distribution.FieldGrammar.Pretty (prettyFieldGrammar) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) +import qualified Distribution.Types.Modify as Mod import System.Directory (setCurrentDirectory) import System.Environment (getArgs, withArgs) import System.FilePath (replaceExtension, ()) import Distribution.Parsec.Source +import Distribution.Types.Dependency (DependencyAnn) +import Distribution.Types.PackageName (PackageName) +import Distribution.FieldGrammar.Newtypes + ( CommaVCat + , CommaFSep + , VCat + , FSep + , NoCommaFSep + , ListAnn + ) + +import Data.Functor ((<&>)) +import Data.Functor.Identity (Identity) +import Control.Monad (unless) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import qualified Data.List.NonEmpty as NE +-- NOTE(leana8959): remove this after demo is done +import Text.Pretty.Simple + import qualified Distribution.InstalledPackageInfo as IPI #ifdef MIN_VERSION_tree_diff import Data.TreeDiff (ansiWlEditExpr, ediff, toExpr) +import Data.TreeDiff.Class (ToExpr) import Data.TreeDiff.Golden (ediffGolden) import Data.TreeDiff.Instances.Cabal () #endif @@ -55,6 +87,10 @@ tests = testGroup "parsec tests" , warningTests , errorTests , ipiTests + , parsecPrettyTests + -- , miniBuildInfoAnnTest + -- , miniBuildInfoTest + , smallCabalFileTest ] ------------------------------------------------------------------------------- @@ -92,7 +128,7 @@ warningTest :: PWarnType -> FilePath -> TestTree warningTest wt fp = testCase (show wt) $ do contents <- BS.readFile $ "tests" "ParserTests" "warnings" fp - let res = withSource (PCabalFile (fp, contents)) $ parseGenericPackageDescription contents + let res = withSource (PCabalFile (fp, contents)) $ (parseGenericPackageDescription @Mod.HasNoAnn) contents let (warns, x) = runParseResult res assertBool ("should parse successfully: " ++ show x) $ isRight x @@ -161,6 +197,158 @@ errorTest fp = cabalGoldenTest fp correct $ do input = "tests" "ParserTests" "errors" fp correct = replaceExtension input "errors" +------------------------------------------------------------------------------- +-- Parsec/Pretty roundtrip test +------------------------------------------------------------------------------- +parsecPrettyTests :: TestTree +parsecPrettyTests = testGroup "parsec pretty roundtrip" $ + [ CabalSpecV1_0 .. ] <&> \specVer -> testGroup (show specVer) $ + optionals (specVer >= CabalSpecV2_0) + [ parsecPrettyTest @DependencyAnn specVer "Dependency ^>=" "text ^>= 1" + , parsecPrettyTest @DependencyAnn specVer "Dependency || and &&" "text (^>= 1 || > 2) && == 3" + , parsecPrettyTest @DependencyAnn specVer "Dependency ||" "text ^>= 1 || > 2" + ] + ++ + [ parsecPrettyTest @DependencyAnn specVer "Dependency ==" "text == 1" + , parsecPrettyTest @DependencyAnn specVer "Dependency >" "text > 1" + , parsecPrettyTest @DependencyAnn specVer "Dependency >=" "text >= 1" + , parsecPrettyTest @DependencyAnn specVer "Dependency <" "text< 1" + , parsecPrettyTest @DependencyAnn specVer "Dependency <=" "text <= 1" + , parsecPrettyTest @DependencyAnn specVer "Dependency || and &&" "text (>= 1 || > 2) && == 3" + , parsecPrettyTest @DependencyAnn specVer "Dependency ||" "text >= 1 || > 2" + ] + ++ + -- Test list combinators using PackageName because it has a simple Parsec instance. + parsecPrettyTest @PackageName specVer "PackageName simple" "foo" -- make sure PackageName itself parses. + : + optionals (specVer >= CabalSpecV2_2) + [ parsecPrettyTest @(ListAnn CommaVCat (Identity PackageName) PackageName) specVer "CommaVCat leading" ", foo , bar" + , parsecPrettyTest @(ListAnn CommaFSep (Identity PackageName) PackageName) specVer "CommaFSep leading" ", foo , bar" + , parsecPrettyTest @(ListAnn CommaVCat (Identity PackageName) PackageName) specVer "CommaVCat trailing" "foo \n , bar \n, " + , parsecPrettyTest @(ListAnn CommaFSep (Identity PackageName) PackageName) specVer "CommaFSep trailing" "foo \n , bar , " + ] + ++ + optionals (specVer >= CabalSpecV3_0) + [ parsecPrettyTest @(ListAnn VCat (Identity PackageName) PackageName) specVer "VCat leading" ", foo , bar" + , parsecPrettyTest @(ListAnn FSep (Identity PackageName) PackageName) specVer "FSep leading" ", foo , bar" + ] + ++ + [ parsecPrettyTest @(ListAnn CommaVCat (Identity PackageName) PackageName) specVer "CommaVCat simple" "foo , bar , baz" + , parsecPrettyTest @(ListAnn CommaVCat (Identity PackageName) PackageName) specVer "CommaVCat newline" "foo ,\n bar , baz" + , parsecPrettyTest @(ListAnn CommaVCat (Identity PackageName) PackageName) specVer "CommaVCat newline" "foo ,\n bar \n, baz" + + , parsecPrettyTest @(ListAnn CommaFSep (Identity PackageName) PackageName) specVer "CommaFSep simple" "foo , bar , baz" + , parsecPrettyTest @(ListAnn CommaFSep (Identity PackageName) PackageName) specVer "CommaFSep newline" "foo ,\n bar , baz" + , parsecPrettyTest @(ListAnn CommaFSep (Identity PackageName) PackageName) specVer "CommaFSep newline" "foo ,\n bar \n, baz" + + , parsecPrettyTest @(ListAnn VCat (Identity PackageName) PackageName) specVer "VCat simple" "foo \n bar" + , parsecPrettyTest @(ListAnn VCat (Identity PackageName) PackageName) specVer "VCat trailing" "foo \n bar \n" + , parsecPrettyTest @(ListAnn VCat (Identity PackageName) PackageName) specVer "VCat trailing" "foo \n bar \n\n" + , parsecPrettyTest @(ListAnn VCat (Identity PackageName) PackageName) specVer "VCat optional comma" "foo , \n bar \n\n" + + , parsecPrettyTest @(ListAnn FSep (Identity PackageName) PackageName) specVer "FSep simple" "foo \n bar" + , parsecPrettyTest @(ListAnn FSep (Identity PackageName) PackageName) specVer "FSep trailing" "foo \n bar \n" + , parsecPrettyTest @(ListAnn FSep (Identity PackageName) PackageName) specVer "FSep trailing" "foo \n bar \n\n" + , parsecPrettyTest @(ListAnn FSep (Identity PackageName) PackageName) specVer "FSep optional comma" "foo , \n bar \n\n" + + , parsecPrettyTest @(ListAnn NoCommaFSep (Identity PackageName) PackageName) specVer "NoCommaFSep simple" "foo \n bar" + , parsecPrettyTest @(ListAnn NoCommaFSep (Identity PackageName) PackageName) specVer "NoCommaFSep trailing" "foo \n bar \n" + , parsecPrettyTest @(ListAnn NoCommaFSep (Identity PackageName) PackageName) specVer "NoCommaFSep trailing" "foo \n bar \n\n" + , parsecPrettyTest @(ListAnn NoCommaFSep (Identity PackageName) PackageName) specVer "NoCommaFSep optional comma" "foo \n bar \n\n" + ] + + where + optionals cond ifTrue = if cond then ifTrue else [] + +-- miniBuildInfoAnnTest :: TestTree +-- miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do +-- fields <- readFields <$> BS.readFile input >>= \case +-- Left err -> fail $ "readFields: err" +-- Right ok -> pure ok +-- +-- -- We ignore sections now, which necessite goSections to dispatch field gramamr parsers +-- let (frontFields, _sections) = takeFields fields +-- pr :: ParseResult src (MiniBuildInfo Mod.HasAnn) +-- pr = parseFieldGrammar CabalSpecV3_0 Nothing frontFields miniBuildInfoFieldGrammar +-- +-- (_warns, pr') = runParseResult pr +-- +-- pr'' <- case pr' of +-- Left (_, errs) -> fail "ERROR in running field grammar" +-- Right ok -> pure $ ok +-- +-- let prettyFields :: [PrettyFieldWith Mod.HasAnn] = prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar pr'' +-- putStrLn +-- $ exactShowFields prettyFields +-- where +-- input = "tests" "ParserTests" "miniBuildInfoDemo.cabal" + +smallCabalFileTest :: TestTree +smallCabalFileTest = testCase "smallCabalFile" $ do + contents <- BS.readFile input + let res = withSource (PCabalFile (fp, contents)) $ (parseGenericPackageDescription @Mod.HasAnn) contents + let (_, x) = runParseResult res + gpd <- case x of + Right ok -> pure ok + Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPErrorWithSource . fmap renderCabalFileSource) (NE.toList errs) + + let prettyFields = ppGenericPackageDescriptionAnn CabalSpecV3_0 gpd + prettyFields' = filterFields prettyFields + + pPrint $ prettyFields' + -- putStrLn $ exactShowFields prettyFields' + where + input = "tests" "ParserTests" fp + fp = "smallCabalFile.cabal" + +-- miniBuildInfoTest :: TestTree +-- miniBuildInfoTest = testCase "miniBuildInfo NoAnn" $ do +-- fields <- readFields <$> BS.readFile input >>= \case +-- Left err -> fail $ "readFields: err" +-- Right ok -> pure ok +-- +-- -- We ignore sections now, which necessite goSections to dispatch field gramamr parsers +-- let (frontFields, _sections) = takeFields fields +-- pr :: ParseResult src (MiniBuildInfo Mod.HasNoAnn) +-- pr = parseFieldGrammar CabalSpecV3_0 Nothing frontFields miniBuildInfoFieldGrammar +-- +-- (_warns, pr') = runParseResult pr +-- +-- pr'' <- case pr' of +-- Left (_, errs) -> fail "ERROR in running field grammar" +-- Right ok -> pure $ ok +-- +-- pPrint pr'' +-- where +-- input = "tests" "ParserTests" "miniBuildInfoDemo.cabal" + +parsecPrettyTest :: forall a. (Parsec a, Pretty a) => CabalSpecVersion -> String -> String -> TestTree +parsecPrettyTest specVer testName input = testCase testName $ do + parsed <- case explicitEitherParsec' specVer parsec input of + Left err -> fail $ unlines $ "ERROR" : show err : [] + Right ok -> pure $ ok + + -- TODO(leana8959): should we handle different layout configurations? + let reprinted = show (pretty @a parsed) + +{- FOURMOLU_DISABLE -} + unless (input == reprinted) $ +#ifdef MIN_VERSION_tree_diff + assertFailure $ unlines + [ "re-parsed doesn't match" + , show $ ansiWlEditExpr $ ediff input reprinted + ] +#else + assertFailure $ unlines + [ "re-printed doesn't match" + , "expected" + , show input + , "actual" + , show reprinted + ] +#endif +{- FOURMOLU_ENABLE -} + ------------------------------------------------------------------------------- -- Regressions ------------------------------------------------------------------------------- @@ -214,7 +402,7 @@ regressionTests = testGroup "regressions" regressionTest :: FilePath -> TestTree regressionTest fp = let formatTests = [ formatGoldenTest fp, formatRoundTripTest fp ] in #ifdef MIN_VERSION_tree_diff - testGroup fp $ formatTests ++ [ treeDiffGoldenTest fp ] + testGroup fp $ formatTests ++ [ mkTreeDiffGoldenTest "regressions" fp ] #else testGroup fp formatTests #endif @@ -239,16 +427,16 @@ formatGoldenTest fp = cabalGoldenTest "format" correct $ do correct = replaceExtension input "format" #ifdef MIN_VERSION_tree_diff -treeDiffGoldenTest :: FilePath -> TestTree -treeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do +mkTreeDiffGoldenTest :: FilePath -> FilePath -> TestTree +mkTreeDiffGoldenTest goldenFileDir fp = ediffGolden goldenTest "expr" exprFile $ do contents <- BS.readFile input - let res = withSource (PCabalFile (fp, contents)) $ parseGenericPackageDescription contents + let res = withSource (PCabalFile (fp, contents)) $ (parseGenericPackageDescription @Mod.HasNoAnn) contents let (_, x) = runParseResult res case x of Right gpd -> pure (toExpr gpd) Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPErrorWithSource . fmap renderCabalFileSource) (NE.toList errs) where - input = "tests" "ParserTests" "regressions" fp + input = "tests" "ParserTests" goldenFileDir fp exprFile = replaceExtension input "expr" #endif diff --git a/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal b/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal new file mode 100644 index 00000000000..155894e1455 --- /dev/null +++ b/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal @@ -0,0 +1,7 @@ + + + +build-depends: + foo > 2, + bar > 3, + baz> 4, diff --git a/Cabal-tests/tests/ParserTests/smallCabalFile.cabal b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal new file mode 100644 index 00000000000..3432f8935f5 --- /dev/null +++ b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal @@ -0,0 +1,14 @@ +cabal-version: 3.0 + +name: small-cabal-file +version: 0.0.0 + +library foo + main-is: Main.hs + + buildable: True + + build-depends: + text + , + base > 4 diff --git a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs index 6ff7df26ec6..5335d5fa061 100644 --- a/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs +++ b/Cabal-tests/tests/custom-setup/CabalDoctestSetup.hs @@ -98,8 +98,8 @@ import Data.String import Distribution.Package (InstalledPackageId, Package (..)) import Distribution.PackageDescription - (BuildInfo (..), Executable (..), GenericPackageDescription, - Library (..), PackageDescription, TestSuite (..)) + (BuildInfo, Executable (..), GenericPackageDescription, + Library, LibraryWith (..), PackageDescription, TestSuite (..), BuildInfoWith (..)) import Distribution.Simple (UserHooks (..), autoconfUserHooks, defaultMainWithHooks, simpleUserHooks) @@ -142,9 +142,9 @@ import Distribution.Types.UnqualComponentName -- For amendGPD import Distribution.PackageDescription - (CondTree (..)) + (CondTreeWith (..)) import Distribution.Types.GenericPackageDescription - (GenericPackageDescription (condTestSuites)) + (GenericPackageDescriptionWith (condTestSuites)) import Distribution.Version (mkVersion) diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs index 83b0073cf7d..3c9a259fbef 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/Cabal.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} + + {-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs index ec96ec9f6b1..d25296b8138 100644 --- a/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs +++ b/Cabal-tree-diff/src/Data/TreeDiff/Instances/CabalVersion.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -freduction-depth=0 #-} {-# OPTIONS_GHC -Wno-orphans #-} module Data.TreeDiff.Instances.CabalVersion where diff --git a/Cabal/src/Distribution/Backpack/Configure.hs b/Cabal/src/Distribution/Backpack/Configure.hs index 55d1ae03254..34813a832d4 100644 --- a/Cabal/src/Distribution/Backpack/Configure.hs +++ b/Cabal/src/Distribution/Backpack/Configure.hs @@ -35,7 +35,7 @@ import Distribution.InstalledPackageInfo import qualified Distribution.InstalledPackageInfo as Installed import Distribution.ModuleName import Distribution.Package -import Distribution.PackageDescription (FlagAssignment, PackageDescription (..), libName) +import Distribution.PackageDescription (FlagAssignment, PackageDescription, PackageDescriptionWith (..), libName) import Distribution.Simple.Compiler import Distribution.Simple.Flag import Distribution.Simple.LocalBuildInfo diff --git a/Cabal/src/Distribution/PackageDescription/Check/Target.hs b/Cabal/src/Distribution/PackageDescription/Check/Target.hs index ada37c48b22..8d8b2c3017a 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Target.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Target.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + -- | -- Module : Distribution.PackageDescription.Check.Target -- Copyright : Lennart Kolmodin 2008, Francesco Ariis 2023 diff --git a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs index 7f333a9c4c8..b701ecc8771 100644 --- a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs +++ b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs @@ -38,7 +38,7 @@ import Distribution.ModuleName (ModuleName) import Distribution.Parsec.Warning (PWarning, showPWarning) import Distribution.Pretty (prettyShow) import Distribution.Types.BenchmarkType (BenchmarkType, knownBenchmarkTypes) -import Distribution.Types.Dependency (Dependency (..)) +import Distribution.Types.Dependency (Dependency) import Distribution.Types.ExeDependency (ExeDependency) import Distribution.Types.Flag (FlagName, unFlagName) import Distribution.Types.LibraryName (LibraryName (..), showLibraryName) diff --git a/Cabal/src/Distribution/Simple/Bench.hs b/Cabal/src/Distribution/Simple/Bench.hs index 991a11f74b3..4ee0e8e31b8 100644 --- a/Cabal/src/Distribution/Simple/Bench.hs +++ b/Cabal/src/Distribution/Simple/Bench.hs @@ -38,7 +38,7 @@ import Distribution.Simple.Setup.Common import Distribution.Simple.UserHooks import Distribution.Simple.Utils import Distribution.System (Platform (Platform)) -import Distribution.Types.Benchmark (Benchmark (benchmarkBuildInfo)) +import Distribution.Types.Benchmark (Benchmark, BenchmarkWith (benchmarkBuildInfo)) import Distribution.Types.UnqualComponentName import Distribution.Utils.Path import Distribution.Verbosity diff --git a/Cabal/src/Distribution/Simple/Configure.hs b/Cabal/src/Distribution/Simple/Configure.hs index 5d8ab963c7c..f145fd6debc 100644 --- a/Cabal/src/Distribution/Simple/Configure.hs +++ b/Cabal/src/Distribution/Simple/Configure.hs @@ -1089,7 +1089,7 @@ addExtraIncludeLibDirsFromConfigFlags :: PackageDescription -> ConfigFlags -> PackageDescription addExtraIncludeLibDirsFromConfigFlags pkg_descr cfg = let extraBi = - mempty + (mempty :: BuildInfo) { extraLibDirs = configExtraLibDirs cfg , extraLibDirsStatic = configExtraLibDirsStatic cfg , extraFrameworkDirs = configExtraFrameworkDirs cfg @@ -2487,7 +2487,7 @@ ccLdOptionsBuildInfo cflags ldflags ldflags_static = (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' (extraLibsStatic') = filter ("-l" `isPrefixOf`) ldflags_static (extraLibDirsStatic') = filter ("-L" `isPrefixOf`) ldflags_static - in mempty + in (mempty :: BuildInfo) { includeDirs = map (makeSymbolicPath . drop 2) includeDirs' , extraLibs = map (drop 2) extraLibs' , extraLibDirs = map (makeSymbolicPath . drop 2) extraLibDirs' diff --git a/Cabal/src/Distribution/Simple/Hpc.hs b/Cabal/src/Distribution/Simple/Hpc.hs index 4198d7a66ba..5c024141d1b 100644 --- a/Cabal/src/Distribution/Simple/Hpc.hs +++ b/Cabal/src/Distribution/Simple/Hpc.hs @@ -32,7 +32,8 @@ import Prelude () import Distribution.ModuleName (ModuleName, main) import Distribution.PackageDescription - ( TestSuite (..) + ( TestSuite + , TestSuiteWith (..) , testModules ) import qualified Distribution.PackageDescription as PD diff --git a/Cabal/src/Distribution/Simple/PackageDescription.hs b/Cabal/src/Distribution/Simple/PackageDescription.hs index 3ca2756d0cd..9c018fd0628 100644 --- a/Cabal/src/Distribution/Simple/PackageDescription.hs +++ b/Cabal/src/Distribution/Simple/PackageDescription.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -48,13 +49,15 @@ import Distribution.Verbosity (Verbosity, VerbosityLevel (..), verbosityLevel) import System.Directory (doesFileExist) import Text.Printf (printf) +import qualified Distribution.Types.Modify as Mod + readGenericPackageDescription :: Verbosity -> Maybe (SymbolicPath CWD (Dir Pkg)) -> SymbolicPath Pkg File -> IO GenericPackageDescription readGenericPackageDescription = - readAndParseFile parseGenericPackageDescription + readAndParseFile (parseGenericPackageDescription @Mod.HasNoAnn) readHookedBuildInfo :: Verbosity diff --git a/buildinfo-reference-generator/buildinfo-reference-generator.cabal b/buildinfo-reference-generator/buildinfo-reference-generator.cabal index a09fc4dc62c..5be60e25e1f 100644 --- a/buildinfo-reference-generator/buildinfo-reference-generator.cabal +++ b/buildinfo-reference-generator/buildinfo-reference-generator.cabal @@ -9,6 +9,7 @@ executable buildinfo-reference-generator main-is: Main.hs build-depends: , base >=4.11 && <4.22 + , Cabal-syntax , Cabal , Cabal-described , containers diff --git a/buildinfo-reference-generator/src/Main.hs b/buildinfo-reference-generator/src/Main.hs index 9ef0cc988b5..070041f99ed 100644 --- a/buildinfo-reference-generator/src/Main.hs +++ b/buildinfo-reference-generator/src/Main.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} module Main (main) where @@ -31,6 +33,7 @@ import Distribution.Utils.GrammarRegex import Distribution.ModuleName (ModuleName) import Distribution.Types.Version (Version) import Distribution.Types.VersionRange (VersionRange) +import qualified Distribution.Types.Modify as Mod ------------------------------------------------------------------------------- -- Main @@ -44,9 +47,9 @@ main = do -- TODO: getArgs run <- Z.parseAndCompileTemplateIO tmpl contents <- run $ Z - { zBuildInfoFields = fromReference buildInfoFieldGrammar + { zBuildInfoFields = fromReference (buildInfoFieldGrammar @Mod.HasNoAnn) , zPackageDescriptionFields = fromReference packageDescriptionFieldGrammar - , zTestSuiteFields = fromReference $ testSuiteFieldGrammar // buildInfoFieldGrammar + , zTestSuiteFields = fromReference $ testSuiteFieldGrammar // (buildInfoFieldGrammar @Mod.HasNoAnn) , zProductions = [ zproduction "hs-string" reHsString "String as in Haskell; it's recommended to avoid using Haskell-specific escapes." diff --git a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs index 0162f6e7f02..1cdbe126798 100644 --- a/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs +++ b/cabal-install-solver/src/Distribution/Solver/Types/SourcePackage.hs @@ -10,7 +10,7 @@ import Prelude () import Distribution.Package ( PackageId, Package(..) ) import Distribution.PackageDescription - ( GenericPackageDescription(..) ) + ( GenericPackageDescription ) import Data.ByteString.Lazy (ByteString) diff --git a/cabal-install/parser-tests/Tests/ParserTests.hs b/cabal-install/parser-tests/Tests/ParserTests.hs index 34b65edcb5e..08be588c410 100644 --- a/cabal-install/parser-tests/Tests/ParserTests.hs +++ b/cabal-install/parser-tests/Tests/ParserTests.hs @@ -49,14 +49,14 @@ import Distribution.Solver.Types.Settings , StrongFlags (..) ) import Distribution.System (OS (..), buildOS) -import Distribution.Types.CondTree (CondTree (..)) +import Distribution.Types.CondTree (CondTreeWith (..)) import Distribution.Types.Flag (mkFlagAssignment) import Distribution.Types.PackageId (PackageIdentifier (..)) import Distribution.Types.PackageName import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) import Distribution.Types.SourceRepo (KnownRepoType (..), RepoType (..)) import Distribution.Types.Version (mkVersion) -import Distribution.Types.VersionRange.Internal (VersionRange (..)) +import Distribution.Types.VersionRange.Internal (VersionRange, VersionRangeWith (..)) import Distribution.Utils.NubList import Distribution.Verbosity import Network.URI (parseURI) diff --git a/cabal-install/src/Distribution/Client/CmdConfigure.hs b/cabal-install/src/Distribution/Client/CmdConfigure.hs index 0de7acaa3eb..da6649fed28 100644 --- a/cabal-install/src/Distribution/Client/CmdConfigure.hs +++ b/cabal-install/src/Distribution/Client/CmdConfigure.hs @@ -55,7 +55,7 @@ import Distribution.Client.HttpUtils import Distribution.Client.ProjectConfig.Types import Distribution.Client.RebuildMonad (runRebuild) import Distribution.Types.CondTree - ( CondTree (..) + ( CondTreeWith (..) ) import Distribution.Utils.NubList ( fromNubList diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index b9f361271cf..d0b57e48419 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -129,23 +130,27 @@ import Distribution.Solver.Types.SourcePackage ( SourcePackage (..) ) import Distribution.Types.BuildInfo - ( BuildInfo (..) + ( BuildInfo + , BuildInfoWith (..) , emptyBuildInfo ) import Distribution.Types.ComponentName ( componentNameString ) import Distribution.Types.CondTree - ( CondTree (..) + ( CondTreeWith (..) ) import Distribution.Types.Dependency - ( Dependency (..) + ( Dependency + , DependencyWith (..) , mainLibSet ) import Distribution.Types.Library - ( Library (..) + ( Library + , LibraryWith (..) , emptyLibrary ) +import qualified Distribution.Types.Modify as Mod import Distribution.Types.ParStrat import Distribution.Types.Version ( Version @@ -730,7 +735,7 @@ addDepsToProjectTarget deps pkgId ctx = -- occurrences of the field `targetBuildDepends`. It ensures that -- fields depending on the latter are also consistently updated. srcpkgDescription - & (L.traverseBuildInfos . L.targetBuildDepends) + & (L.traverseBuildInfos @Mod.HasNoAnn . L.targetBuildDepends @Mod.HasNoAnn) %~ (deps ++) } addDeps spec = spec diff --git a/cabal-install/src/Distribution/Client/IndexUtils.hs b/cabal-install/src/Distribution/Client/IndexUtils.hs index 8872ad6467f..2c5d1dacdd4 100644 --- a/cabal-install/src/Distribution/Client/IndexUtils.hs +++ b/cabal-install/src/Distribution/Client/IndexUtils.hs @@ -78,7 +78,8 @@ import Distribution.Package , packageVersion ) import Distribution.PackageDescription - ( GenericPackageDescription (..) + ( GenericPackageDescription + , GenericPackageDescriptionWith (..) , PackageDescription (..) , emptyPackageDescription ) diff --git a/cabal-install/src/Distribution/Client/Install.hs b/cabal-install/src/Distribution/Client/Install.hs index f7eeae2803b..e59e2e429fb 100644 --- a/cabal-install/src/Distribution/Client/Install.hs +++ b/cabal-install/src/Distribution/Client/Install.hs @@ -162,7 +162,7 @@ import Distribution.Package , packageVersion ) import Distribution.PackageDescription - ( GenericPackageDescription (..) + ( GenericPackageDescriptionWith (..) , PackageDescription ) import qualified Distribution.PackageDescription as PackageDescription diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index 90e0c347995..80ce3ffb4e4 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -136,8 +136,10 @@ import Distribution.Simple.Utils , noticeDoc ) import Distribution.Types.CondTree - ( CondBranch (..) - , CondTree (..) + ( CondBranch + , CondBranchWith (..) + , CondTree + , CondTreeWith (..) , ignoreConditions , mapTreeConds , mapTreeData diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs index 90740fc7a93..d35d0f035ce 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Parsec.hs @@ -43,7 +43,7 @@ import Distribution.Simple.Setup import Distribution.Simple.Utils (debug, noticeDoc) import Distribution.Solver.Types.ProjectConfigPath import Distribution.System (buildOS) -import Distribution.Types.CondTree (CondBranch (..), CondTree (..)) +import Distribution.Types.CondTree (CondBranch, CondBranchWith (..), CondTreeWith (..)) import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.PackageName (PackageName) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS, validateUTF8) diff --git a/cabal-install/src/Distribution/Client/Run.hs b/cabal-install/src/Distribution/Client/Run.hs index baa6264abe4..3121207d376 100644 --- a/cabal-install/src/Distribution/Client/Run.hs +++ b/cabal-install/src/Distribution/Client/Run.hs @@ -22,7 +22,8 @@ import Distribution.Client.Utils (tryCanonicalizePath) import Distribution.PackageDescription ( Benchmark (..) - , BuildInfo (buildable) + , BuildInfo + , BuildInfoWith (buildable) , Executable (..) , PackageDescription (..) , TestSuite (..) diff --git a/cabal-install/src/Distribution/Client/ScriptUtils.hs b/cabal-install/src/Distribution/Client/ScriptUtils.hs index c4f2925651e..3a50f588a4c 100644 --- a/cabal-install/src/Distribution/Client/ScriptUtils.hs +++ b/cabal-install/src/Distribution/Client/ScriptUtils.hs @@ -143,19 +143,21 @@ import Distribution.System ( Platform (..) ) import Distribution.Types.BuildInfo - ( BuildInfo (..) + ( BuildInfo + , BuildInfoWith (..) ) import Distribution.Types.ComponentId ( mkComponentId ) import Distribution.Types.CondTree - ( CondTree (..) + ( CondTreeWith (..) ) import Distribution.Types.Executable ( Executable (..) ) import Distribution.Types.GenericPackageDescription as GPD - ( GenericPackageDescription (..) + ( GenericPackageDescription + , GenericPackageDescriptionWith (..) , emptyGenericPackageDescription ) import Distribution.Types.PackageDescription diff --git a/cabal-install/src/Distribution/Client/SetupWrapper.hs b/cabal-install/src/Distribution/Client/SetupWrapper.hs index acb8f031c3a..a086f187363 100644 --- a/cabal-install/src/Distribution/Client/SetupWrapper.hs +++ b/cabal-install/src/Distribution/Client/SetupWrapper.hs @@ -49,7 +49,7 @@ import Distribution.Package ) import Distribution.PackageDescription ( BuildType (..) - , GenericPackageDescription (packageDescription) + , GenericPackageDescriptionWith (packageDescription) , PackageDescription (..) , buildType , specVersion diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 56ea25d958e..6022d2c462a 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -70,7 +70,8 @@ import Distribution.ModuleName import Distribution.PackageDescription ( Benchmark (..) , BenchmarkInterface (..) - , BuildInfo (..) + , BuildInfo + , BuildInfoWith (..) , Executable (..) , PackageDescription , TestSuite (..) diff --git a/cabal-install/src/Distribution/Client/Utils/Parsec.hs b/cabal-install/src/Distribution/Client/Utils/Parsec.hs index d7fcbf4778d..087bb5f9bad 100644 --- a/cabal-install/src/Distribution/Client/Utils/Parsec.hs +++ b/cabal-install/src/Distribution/Client/Utils/Parsec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -31,6 +33,8 @@ import Distribution.Simple.Flag import Distribution.Utils.NubList (NubList (..)) import qualified Distribution.Utils.NubList as NubList +import qualified Distribution.Types.Modify as Mod + -- | Like 'List' for usage with a 'FieldGrammar', but for 'Flag'. -- This enables to parse type aliases such as 'FilePath' that do not have 'Parsec' instances -- by using newtype variants such as 'FilePathNT'. @@ -73,10 +77,10 @@ alaNubList' _ _ = NubList' instance Newtype (NubList a) (NubList' sep wrapper a) -instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (NubList' sep b a) where +instance (Newtype a b, Ord a, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (NubList' sep b a) where parsec = pack . NubList.toNubList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec -instance (Newtype a b, Sep sep, Pretty b) => Pretty (NubList' sep b a) where +instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (NubList' sep b a) where pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NubList.fromNubList . unpack remoteRepoGrammar :: RepoName -> ParsecFieldGrammar RemoteRepo RemoteRepo diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs index 95619d63225..2d7f6381a1f 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL.hs @@ -461,7 +461,7 @@ exAvSrcPkg ex = , C.gpdScannedVersion = Nothing , C.genPackageFlags = flags , C.condLibrary = - let mkLib v bi = mempty{C.libVisibility = v, C.libBuildInfo = bi} + let mkLib v bi = (mempty :: C.Library){C.libVisibility = v, C.libBuildInfo = bi} -- Avoid using the Monoid instance for [a] when getting -- the library dependencies, to allow for the possibility -- that the package doesn't have a library: @@ -469,7 +469,7 @@ exAvSrcPkg ex = in mkTopLevelCondTree defaultLib mkLib <$> libDeps , C.condSubLibraries = let mkTree = mkTopLevelCondTree defaultSubLib mkLib - mkLib v bi = mempty{C.libVisibility = v, C.libBuildInfo = bi} + mkLib v bi = (mempty :: C.Library){C.libVisibility = v, C.libBuildInfo = bi} in map (second mkTree) subLibraries , C.condForeignLibs = let mkTree = mkTopLevelCondTree (mkLib defaultTopLevelBuildInfo) (const mkLib) @@ -512,7 +512,7 @@ exAvSrcPkg ex = defaultLib :: C.Library defaultLib = - mempty + (mempty :: C.Library) { C.libBuildInfo = defaultTopLevelBuildInfo , C.exposedModules = [Module.fromString "Module"] , C.libVisibility = C.LibraryVisibilityPublic @@ -520,7 +520,7 @@ exAvSrcPkg ex = defaultSubLib :: C.Library defaultSubLib = - mempty + (mempty :: C.Library) { C.libBuildInfo = defaultTopLevelBuildInfo , C.exposedModules = [Module.fromString "Module"] } diff --git a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs index eecab420f8c..5a2142e3ef0 100644 --- a/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs +++ b/cabal-install/tests/UnitTests/Distribution/Solver/Modular/QuickCheck.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/cabal-testsuite/src/Test/Cabal/Plan.hs b/cabal-testsuite/src/Test/Cabal/Plan.hs index ddeba7f24a6..8dd44053e27 100644 --- a/cabal-testsuite/src/Test/Cabal/Plan.hs +++ b/cabal-testsuite/src/Test/Cabal/Plan.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wno-orphans #-}