From 36ef1b8c3935d2c59560cb8b81cf269e5a0e5efc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 13 Mar 2026 13:57:53 +0100 Subject: [PATCH 001/111] implement GPD Barbie fix build error don't allow other types as modifiers stop using undecidable instances rewrite condtree as barbie rewrite condbranch as barbie fix build add ExactParsec class simple example for dependency make PackageName a barbie fix build pass down modifier to package name barbie update Dependency's ExactParsec instance complete PackageName exactparse proof of concept use exactparsec to define parsec parameterize VersionRange parameterize Version pass down modifier to version barbie remove ExactParsec class Rename Barbie -> With, WithTrivia -> Ann implement VersionRangeAnn Parsec instance define Parsec without ann remodel trivia representation remodel version range fix trailing / leading string implement pretty VersionRangeAnn use VersionRangeAnn in DependencyAnn implement pretty DependencyAnn parameterize BuildInfo parameterize Library parameterize GenericPackageDescription refactor modify rename type variable for consistency Modifiers now have kind type make buildinfo lens polymorphic update codebase to match HasBuildInfo change introduce constraint alias fix compilation run formatter implement Ann variant of HasBuildInfoWith class make buildInfoFieldGrammar generic make optionsFieldGrammar generic make profOptionsfieldGrammar generic make sharedOptionsFieldGrammar generic make profSharedOptionsFieldGrammar generic make hsSourceDirsGrammar generic export GenericPackageDescriptionAnn alias run formatter clean up make library's lens polymorphic make libraryFieldGrammar polymorphic add dependency parsec/pretty instance tests complete dependency roundtrip refactor cabal versioned tests test entirety of cabal dependency specification parameterize newtype combinators fix compile errors make testcases names more descriptive implement trivia-aware commavcat run fourmolu fix warnings implement trivia-aware commafcat implement trivia-aware vcatann run fourmolu implement trivia-aware fsepann implement trivia-aware NoCommaFSepAnn only guard ^>= bound test behind cabal version 2 implement parsec instance of trivia-aware polymorphic list combinator implement pretty instance of trivia-aware list combinator add all tests for combinators fix VCatAnn and FSepAnn leading trivia parsing fix VCatAnn and FSepAnn optional comma fix CommaVCatAnn and CommaFSepAnn trailing correct parsec pretty test names factor out parsecSpaceAnn pattern include position in trivia model refactor cabal-syntax to use DataKinds This makes the modifier closed fix project wide compilation errors create PrettPos as subclass of Pretty add todos Revert "create PrettPos as subclass of Pretty" Retrieve stored position from the Pretty instances and pass them to FieldGrammar. What was tried: - [x] MultiParamTypeClasses Breaking all downstream instances due to instance head change. - [x] TypeFamilies: Impossible to use injectivity because one modifier has more than one `a`. Otherwise requires all sites to define the associated type modifier. - [x] PrettyPos as subclass of Pretty. Use PrettyPos in FieldGrammar. Enforces all field grammar to have position. Not all of them have position. - [ ] Combine MultiParamTypeClasses and PrettyPos subclass: Flexibility: not all field grammar need to have the same output type. No breakage: downstream instance heads aren't changed. We create a new class. --- Cabal-described/src/Distribution/Described.hs | 5 +- Cabal-syntax/Cabal-syntax.cabal | 2 + .../src/Distribution/Compat/CharParsing.hs | 4 + .../src/Distribution/Compat/Parsing.hs | 35 ++ Cabal-syntax/src/Distribution/ExactParsec.hs | 7 + .../src/Distribution/FieldGrammar/Newtypes.hs | 138 ++++++- .../src/Distribution/FieldGrammar/Pretty.hs | 1 + .../PackageDescription/Configuration.hs | 11 +- .../PackageDescription/FieldGrammar.hs | 113 ++++-- .../Distribution/PackageDescription/Parsec.hs | 10 +- Cabal-syntax/src/Distribution/Parsec.hs | 87 +++++ .../src/Distribution/Parsec/Position.hs | 3 +- Cabal-syntax/src/Distribution/Trivia.hs | 83 ++++ .../src/Distribution/Types/Benchmark.hs | 5 +- .../src/Distribution/Types/BuildInfo.hs | 35 +- .../src/Distribution/Types/BuildInfo/Lens.hs | 332 ++++++++++------ .../src/Distribution/Types/Component.hs | 5 +- .../src/Distribution/Types/CondTree.hs | 59 ++- .../src/Distribution/Types/Dependency.hs | 95 ++++- .../src/Distribution/Types/Executable.hs | 5 +- .../src/Distribution/Types/ForeignLib.hs | 5 +- .../Types/GenericPackageDescription.hs | 63 ++-- .../Types/GenericPackageDescription/Lens.hs | 2 +- .../src/Distribution/Types/Library.hs | 28 +- .../src/Distribution/Types/Library/Lens.hs | 18 +- Cabal-syntax/src/Distribution/Types/Modify.hs | 13 + .../Distribution/Types/PackageDescription.hs | 4 +- .../src/Distribution/Types/PackageName.hs | 46 ++- .../src/Distribution/Types/TestSuite.hs | 5 +- .../Distribution/Types/UnqualComponentName.hs | 7 + .../src/Distribution/Types/Version.hs | 17 + .../src/Distribution/Types/VersionRange.hs | 4 + .../Types/VersionRange/Internal.hs | 357 +++++++++++++++--- Cabal-syntax/src/Distribution/Version.hs | 3 + Cabal-tests/tests/HackageTests.hs | 2 +- Cabal-tests/tests/NoThunks.hs | 1 + Cabal-tests/tests/ParserTests.hs | 130 ++++++- .../tests/custom-setup/CabalDoctestSetup.hs | 8 +- .../src/Data/TreeDiff/Instances/Cabal.hs | 4 + .../Data/TreeDiff/Instances/CabalVersion.hs | 2 + .../PackageDescription/Check/Target.hs | 2 + .../PackageDescription/Check/Warning.hs | 2 +- Cabal/src/Distribution/Simple/Configure.hs | 4 +- .../buildinfo-reference-generator.cabal | 1 + buildinfo-reference-generator/src/Main.hs | 7 +- .../Solver/Types/SourcePackage.hs | 2 +- .../parser-tests/Tests/ParserTests.hs | 4 +- .../src/Distribution/Client/CmdConfigure.hs | 2 +- .../src/Distribution/Client/CmdRepl.hs | 15 +- .../src/Distribution/Client/IndexUtils.hs | 3 +- .../src/Distribution/Client/Install.hs | 2 +- .../Client/ProjectConfig/Legacy.hs | 6 +- .../Client/ProjectConfig/Parsec.hs | 2 +- cabal-install/src/Distribution/Client/Run.hs | 3 +- .../src/Distribution/Client/ScriptUtils.hs | 8 +- .../src/Distribution/Client/SetupWrapper.hs | 2 +- .../src/Distribution/Client/TargetSelector.hs | 3 +- .../src/Distribution/Client/Utils/Parsec.hs | 8 +- .../Distribution/Solver/Modular/DSL.hs | 8 +- .../Distribution/Solver/Modular/QuickCheck.hs | 1 + cabal-testsuite/src/Test/Cabal/Plan.hs | 1 + 61 files changed, 1486 insertions(+), 354 deletions(-) create mode 100644 Cabal-syntax/src/Distribution/ExactParsec.hs create mode 100644 Cabal-syntax/src/Distribution/Trivia.hs create mode 100644 Cabal-syntax/src/Distribution/Types/Modify.hs 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..244d27f52a1 100644 --- a/Cabal-syntax/Cabal-syntax.cabal +++ b/Cabal-syntax/Cabal-syntax.cabal @@ -104,6 +104,7 @@ library Distribution.PackageDescription.Quirks Distribution.PackageDescription.Utils Distribution.Parsec + Distribution.Trivia Distribution.Parsec.Error Distribution.Parsec.FieldLineStream Distribution.Parsec.Position @@ -126,6 +127,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..4b924866d16 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 a) -> m String -> m [Ann 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 a) -> m String -> m (NonEmpty (Ann 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 a) -> m String -> m (NonEmpty (Ann 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 a) -> m String -> m [Ann 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/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 8123285e2b9..6a0c4ec4046 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -1,11 +1,14 @@ {-# 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 @@ -19,10 +22,19 @@ module Distribution.FieldGrammar.Newtypes , VCat (..) , FSep (..) , NoCommaFSep (..) + , CommaVCatAnn (..) + , CommaFSepAnn (..) + , VCatAnn (..) + , FSepAnn (..) + , NoCommaFSepAnn (..) + + -- ** Separator class , Sep (..) -- ** Type , List + , ListAnn + , ListWith -- ** Set , alaSet @@ -57,6 +69,8 @@ import Distribution.Compiler (CompilerFlavor) import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia +import qualified Distribution.Types.Modify as Mod import Distribution.Utils.Path import Distribution.Version ( LowerBound (..) @@ -73,6 +87,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 @@ -81,25 +96,41 @@ import qualified Distribution.SPDX as SPDX -- | Vertical list with commas. Displayed with 'vcat' data CommaVCat = CommaVCat +data CommaVCatAnn = CommaVCatAnn + -- | Paragraph fill list with commas. Displayed with 'fsep' data CommaFSep = CommaFSep +data CommaFSepAnn = CommaFSepAnn + -- | Vertical list with optional commas. Displayed with 'vcat'. data VCat = VCat +data VCatAnn = VCatAnn + -- | Paragraph fill list with optional commas. Displayed with 'fsep'. data FSep = FSep +data FSepAnn = FSepAnn + -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep -class Sep sep where - prettySep :: Proxy sep -> [Doc] -> Doc +data NoCommaFSepAnn = NoCommaFSepAnn + +type family Modify (mod :: Mod.HasAnnotation) (a :: Type) where + Modify Mod.HasNoAnn a = a + Modify Mod.HasAnn a = Ann a - parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a) +-- TODO(leana8959): Relax Sep to return a list of annotated docs with position +-- Use the position propagated back from applyTriviaDoc +class Sep (mod :: Mod.HasAnnotation) sep | sep -> mod where + prettySep :: Proxy sep -> [Modify mod Doc] -> Doc -instance Sep CommaVCat where + parseSep :: CabalParsing m => Proxy sep -> m a -> m [Modify mod a] + parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty (Modify mod a)) + +instance Sep Mod.HasNoAnn CommaVCat where prettySep _ = vcat . punctuate comma parseSep _ p = do v <- askCabalSpecVersion @@ -107,7 +138,19 @@ 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 CommaVCatAnn where + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> p + if v >= CabalSpecV2_2 then parsecLeadingCommaListAnn p' else parsecCommaListAnn p' + parseSepNE _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> p + 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 +158,82 @@ 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 CommaFSepAnn where + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> p + if v >= CabalSpecV2_2 then parsecLeadingCommaListAnn p' else parsecCommaListAnn p' + parseSepNE _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> p + 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 VCatAnn where + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> p + if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' + parseSepNE _ p = + NE.some1 + ( do + x <- 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 FSepAnn where + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = do + v <- askCabalSpecVersion + let p' = Ann mempty <$> p + if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' + parseSepNE _ p = + NE.some1 + ( do + x <- 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 NoCommaFSepAnn where + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + parseSep _ p = many $ do + x <- p + post <- P.spaces' + pure (Ann (postTrivia post) x) + parseSepNE _ p = NE.some1 $ do + x <- 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 :: [Modify 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 @@ -152,14 +251,19 @@ alaList' :: sep -> (a -> b) -> [a] -> List sep b a alaList' _ _ = List instance Newtype [a] (List sep wrapper a) +instance Newtype [Ann a] (ListAnn sep wrapper a) -instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where +instance (Newtype a b, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (List sep b a) where parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec -instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where +instance (Newtype a b, Sep Mod.HasAnn sep, Parsec b) => Parsec (ListAnn sep b a) where + parsec = pack . (map . fmap) (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + +instance (Newtype a b, Sep Mod.HasNoAnn 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.HasAnn sep, Pretty b) => Pretty (ListAnn sep b a) where + pretty = prettySep (Proxy :: Proxy sep) . (map . fmap) (pretty . (pack :: a -> b)) . unpack -- | Like 'List', but for 'Set'. -- @@ -190,10 +294,10 @@ 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 +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 (Proxy :: Proxy sep) parsec -instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where +instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (Set' sep b a) where pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack -- @@ -224,10 +328,10 @@ alaNonEmpty' _ _ = NonEmpty' instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) -instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where +instance (Newtype a b, Sep Mod.HasNoAnn 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 sep, Pretty b) => Pretty (NonEmpty' sep b a) where +instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (NonEmpty' sep b a) where pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index a35d8f361f4..0bfd4575695 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -20,6 +20,7 @@ import Prelude () import Distribution.FieldGrammar.Class +-- TODO(leana8959): maybe we can compare this to [Field Position] and thus form a roundtrip test. newtype PrettyFieldGrammar s a = PrettyFG { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] } diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs index cc6df0801e3..61aae3903f1 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 MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# 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..e189d3e8cb4 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,9 +1,12 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | 'GenericPackageDescription' Field descriptions module Distribution.PackageDescription.FieldGrammar @@ -85,6 +88,8 @@ import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) +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 @@ -165,14 +170,16 @@ packageDescriptionFieldGrammar = ------------------------------------------------------------------------------- libraryFieldGrammar - :: ( FieldGrammar c g - , Applicative (g Library) - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammar c g + , Applicative (g (LibraryWith mod)) + , Applicative (g (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith 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,7 +194,7 @@ libraryFieldGrammar , c (MQuoted Language) ) => LibraryName - -> g Library Library + -> g (LibraryWith mod) (LibraryWith mod) libraryFieldGrammar n = Library n <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules @@ -205,8 +212,8 @@ 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 @@ -304,7 +311,7 @@ data TestSuiteStanza = TestSuiteStanza , _testStanzaCodeGenerators :: [String] } -instance L.HasBuildInfo TestSuiteStanza where +instance L.HasBuildInfoWith Mod.HasNoAnn TestSuiteStanza where buildInfo = testStanzaBuildInfo testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) @@ -453,7 +460,7 @@ data BenchmarkStanza = BenchmarkStanza , _benchmarkStanzaBuildInfo :: BuildInfo } -instance L.HasBuildInfo BenchmarkStanza where +instance L.HasBuildInfoWith Mod.HasNoAnn BenchmarkStanza where buildInfo = benchmarkStanzaBuildInfo benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) @@ -578,12 +585,14 @@ unvalidateBenchmark b = ------------------------------------------------------------------------------- buildInfoFieldGrammar - :: ( FieldGrammar c g - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) , 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 +605,7 @@ buildInfoFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g BuildInfo BuildInfo + => g (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar = BuildInfo <$> booleanFieldDef "buildable" L.buildable True @@ -680,18 +689,20 @@ 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 #-} +{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} +{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} hsSourceDirsGrammar - :: ( FieldGrammar c g - , Applicative (g BuildInfo) + :: forall mod c g + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to)) ) - => g BuildInfo [SymbolicPath Pkg (Dir Source)] + => g (BuildInfoWith mod) [SymbolicPath Pkg (Dir Source)] hsSourceDirsGrammar = (++) <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs @@ -700,13 +711,19 @@ hsSourceDirsGrammar = ^^^ 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 [] + -- -- TODO: make pretty printer aware of CabalSpecVersion + wrongLens f bi = (\fps -> set (L.hsSourceDirs @mod) fps bi) <$> f [] +{-# 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 + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g (BuildInfoWith mod) (PerCompilerFlavor [String]) optionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -718,34 +735,50 @@ 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 + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g (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 + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g (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 + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , c (List NoCommaFSep Token' String) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + ) + => g (BuildInfoWith mod) (PerCompilerFlavor [String]) profSharedOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-prof-shared-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -753,8 +786,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) @@ -815,7 +847,8 @@ setupBInfoFieldGrammar def = -- Define how field values should be formatted for 'pretty'. ------------------------------------------------------------------------------- -formatDependencyList :: [Dependency] -> List CommaVCat (Identity Dependency) Dependency +-- TODO(leana8959): implement this +formatDependencyList :: [DependencyWith mod] -> List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) formatDependencyList = alaList CommaVCat formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin @@ -897,7 +930,7 @@ _syntaxFieldNames = sort $ mconcat [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar - , fieldGrammarKnownFieldList $ libraryFieldGrammar LMainLibName + , fieldGrammarKnownFieldList $ (libraryFieldGrammar @Mod.HasNoAnn) LMainLibName , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" , fieldGrammarKnownFieldList testSuiteFieldGrammar diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index f23bf0a8107..762246be8c3 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Distribution.PackageDescription.Parsec @@ -28,6 +31,10 @@ module Distribution.PackageDescription.Parsec -- ** Supplementary build information , parseHookedBuildInfo + + -- * Pre-processing utilities + , sectionizeFields + , takeFields ) where import Distribution.Compat.Prelude @@ -53,6 +60,7 @@ 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.Utils.Generic (breakMaybe, fromUTF8BS, toUTF8BS, unfoldrM, validateUTF8) import Distribution.Version (Version, mkVersion, versionNumbers) @@ -920,7 +928,7 @@ data Syntax = OldSyntax | NewSyntax -- TODO: libFieldNames :: [FieldName] -libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar LMainLibName) +libFieldNames = fieldGrammarKnownFieldList (libraryFieldGrammar @Mod.HasNoAnn LMainLibName) ------------------------------------------------------------------------------- -- Supplementary build information diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 9b43b6e41a2..03ca3614087 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 #-} @@ -49,11 +51,17 @@ module Distribution.Parsec , parsecQuoted , parsecMaybeQuoted , parsecCommaList + , parsecCommaListAnn , parsecCommaNonEmpty + , parsecCommaNonEmptyAnn , parsecLeadingCommaList + , parsecLeadingCommaListAnn , parsecLeadingCommaNonEmpty + , parsecLeadingCommaNonEmptyAnn , parsecOptCommaList + , parsecOptCommaListAnn , parsecLeadingOptCommaList + , parsecLeadingOptCommaListAnn , parsecStandard , parsecUnqualComponentName ) where @@ -64,6 +72,7 @@ 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) @@ -306,12 +315,35 @@ 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 a) -> m (Ann a) +parsecSpacesAnn p = do + x <- p + post <- P.spaces' + pure (mapAnn (<> postTrivia post) x) +{-# INLINABLE parsecSpacesAnn #-} + 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 a) -> m [Ann 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 a) -> m (NonEmpty (Ann 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 +361,20 @@ 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 a) -> m [Ann 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 a) + lp = parsecSpacesAnn p + + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + -- | -- -- @since 3.4.0.0 @@ -342,11 +388,32 @@ 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 a) -> m (NonEmpty (Ann a)) +parsecLeadingCommaNonEmptyAnn p = P.optional comma >>= \case + Nothing -> P.sepEndByNonEmptyAnn lp comma + Just _ -> P.sepByNonEmptyAnn lp comma + where + lp :: m (Ann 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 a) -> m [Ann a] +parsecOptCommaListAnn p = P.sepByAnn lp (comma <|> pure "") + where + lp :: m (Ann a) + lp = parsecSpacesAnn p + + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + -- | Like 'parsecOptCommaList' but -- -- * require all or none commas @@ -377,6 +444,26 @@ parsecLeadingOptCommaList p = do Nothing -> (x :) <$> many lp Just _ -> (x :) <$> P.sepEndBy lp comma +parsecLeadingOptCommaListAnn :: forall m a. CabalParsing m => m (Ann a) -> m [Ann 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 a) + lp = parsecSpacesAnn p + + comma :: m String + comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" + + sepEndBy1StartAnn :: m [Ann 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/Position.hs b/Cabal-syntax/src/Distribution/Parsec/Position.hs index 892fc8b8fda..9524fffeb02 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Position.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Position.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} module Distribution.Parsec.Position ( 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 diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs new file mode 100644 index 00000000000..c763a09ac2e --- /dev/null +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveFunctor #-} + +module Distribution.Trivia + ( Trivia (..) + , preTrivia + , postTrivia + , posTrivia + , Ann (..) + , mapAnn + , mapAnnA + , applyTriviaDoc + ) +where + +import Data.Data +import Control.Applicative +import Distribution.Parsec.Position +import qualified Text.PrettyPrint as Disp + +-- TODO(leana8959): implement position trivia somewhere +data Trivia + = HasTrivia (Maybe Position) String String + | ExactRepresentation String + | IsInserted + | NoTrivia + deriving (Show, Eq, Ord, Read, Data) + +preTrivia :: String -> Trivia +preTrivia s = HasTrivia Nothing s mempty + +postTrivia :: String -> Trivia +postTrivia s = HasTrivia Nothing mempty s + +posTrivia :: Position -> Trivia +posTrivia pos = HasTrivia (Just pos) mempty mempty + +instance Semigroup Trivia where + HasTrivia mpos s t <> HasTrivia mpos' a b = HasTrivia (mpos <|> mpos') (s <> a) (t <> b) + + ExactRepresentation u <> ExactRepresentation v = ExactRepresentation (u <> v) + u@(ExactRepresentation _) <> _ = u + _ <> v@(ExactRepresentation _) = v + + NoTrivia <> v = v + u <> NoTrivia = u + + IsInserted <> _ = IsInserted + _ <> IsInserted = IsInserted + +instance Monoid Trivia where + mempty = NoTrivia + +data Ann a = Ann + { getAnn :: Trivia + , unAnn :: a + } + deriving (Show, Eq, Ord, Functor, Read, Data) + +mapAnn + :: (Trivia -> Trivia) + -> Ann a + -> Ann a +mapAnn f (Ann t x) = Ann (f t) x + +mapAnnA + :: (Trivia -> Trivia) + -> (a -> a) + -> Ann a + -> Ann a +mapAnnA f g (Ann t x) = Ann (f t) (g x) + +applyTriviaDoc + :: Trivia + -> Disp.Doc + -> Disp.Doc +applyTriviaDoc t = case t of + -- TODO(leana8959): do not ignore the position here + HasTrivia _ 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..ccb659f5f0d 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.Benchmark ( Benchmark (..) @@ -15,6 +17,7 @@ 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 @@ -33,7 +36,7 @@ instance Binary Benchmark instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf -instance L.HasBuildInfo Benchmark where +instance L.HasBuildInfoWith Mod.HasNoAnn Benchmark where buildInfo f (Benchmark x1 x2 x3) = fmap (\y1 -> Benchmark x1 x2 y1) (f x3) instance Monoid Benchmark where diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index e68fcbc5c22..cb0389be5f1 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -1,9 +1,16 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} module Distribution.Types.BuildInfo - ( BuildInfo (..) + ( BuildInfo + , BuildInfoAnn + , BuildInfoWith (..) + , unannotateDependencyAnn , emptyBuildInfo , allLanguages , allExtensions @@ -30,8 +37,15 @@ import Distribution.Compiler import Distribution.ModuleName import Language.Haskell.Extension +import Data.Kind + +import qualified Distribution.Types.Modify as Mod + +type BuildInfo = BuildInfoWith Mod.HasNoAnn +type BuildInfoAnn = BuildInfoWith Mod.HasAnn + -- Consider refactoring into executable and library versions. -data BuildInfo = BuildInfo +data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo { buildable :: Bool -- ^ component is buildable here , buildTools :: [LegacyExeDependency] @@ -142,16 +156,28 @@ data BuildInfo = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: [Dependency] + , targetBuildDepends :: [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 instance Binary BuildInfo instance Structured BuildInfo instance NFData BuildInfo where rnf = genericRnf +unannotateBuildInfo :: BuildInfoAnn -> BuildInfo +unannotateBuildInfo bi = + bi + { targetBuildDepends = map unannotateDependencyAnn (targetBuildDepends bi) + } + instance Monoid BuildInfo where mempty = BuildInfo @@ -259,6 +285,7 @@ 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 diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index e554f43ebdf..7d2f8c25c91 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -1,9 +1,23 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# 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 +26,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) @@ -22,204 +36,310 @@ import Distribution.Utils.Path import Language.Haskell.Extension (Extension, Language) import qualified Distribution.Types.BuildInfo as T +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 Bool + buildable = buildInfo @mod . buildable @mod + + buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [LegacyExeDependency] + buildTools = buildInfo @mod . buildTools @mod + + buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ExeDependency] + buildToolDepends = buildInfo @mod . buildToolDepends @mod + + cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + cppOptions = buildInfo @mod . cppOptions @mod + + asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + asmOptions = buildInfo @mod . asmOptions @mod + + cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + cmmOptions = buildInfo @mod . cmmOptions @mod + + ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + ccOptions = buildInfo @mod . ccOptions @mod + + cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + cxxOptions = buildInfo @mod . cxxOptions @mod + + jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + jsppOptions = buildInfo @mod . jsppOptions @mod + + ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + ldOptions = buildInfo @mod . ldOptions @mod + + hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + hsc2hsOptions = buildInfo @mod . hsc2hsOptions @mod + + pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [PkgconfigDependency] + pkgconfigDepends = buildInfo @mod . pkgconfigDepends @mod + + frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [RelativePath Framework File] + frameworks = buildInfo @mod . frameworks @mod + + extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Framework)] + extraFrameworkDirs = buildInfo @mod . extraFrameworkDirs @mod + + asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + asmSources = buildInfo @mod . asmSources @mod + + cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + cmmSources = buildInfo @mod . cmmSources @mod + + cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + cSources = buildInfo @mod . cSources @mod + + cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + cxxSources = buildInfo @mod . cxxSources @mod + + jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + jsSources = buildInfo @mod . jsSources @mod + + hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Source)] + hsSourceDirs = buildInfo @mod . hsSourceDirs @mod + + otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [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 [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 +487,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..d20db2ebfe4 100644 --- a/Cabal-syntax/src/Distribution/Types/CondTree.hs +++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs @@ -1,11 +1,19 @@ {-# 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 (..) - , CondBranch (..) + ( CondTree + , CondTreeWith (..) + , CondBranch + , CondBranchWith (..) , condIfThen , condIfThenElse , foldCondTree @@ -25,10 +33,19 @@ module Distribution.Types.CondTree import Distribution.Compat.Prelude import Prelude () +import Distribution.Trivia import Distribution.Types.Condition +import Control.Exception +import Data.Kind + import qualified Distribution.Compat.Lens as L +type family Modify (f :: Type -> Type) (a :: Type) where + Modify Identity a = a + Modify Ann a = ([String], a) + Modify _ a = TypeError + -- | A 'CondTree' is used to represent the conditional structure of -- a Cabal file, reflecting a syntax element subject to constraints, -- and then any number of sub-elements which may be enabled subject @@ -53,11 +70,26 @@ import qualified Distribution.Compat.Lens as L -- derived off of 'targetBuildInfo' (perhaps a good refactoring -- would be to convert this into an opaque type, with a smart -- constructor that pre-computes the dependencies.) -data CondTree v a = CondNode - { condTreeData :: a +type CondTree = CondTreeWith Identity + +data CondTreeWith f v a = CondNode + { condTreeData :: Modify f 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) @@ -73,12 +105,21 @@ instance (Semigroup a, Monoid a) => Monoid (CondTree v a) where -- | A 'CondBranch' represents a conditional branch, e.g., @if -- flag(foo)@ on some syntax @a@. It also has an optional false -- branch. -data CondBranch v a = CondBranch +type CondBranch = CondBranchWith Identity + +data CondBranchWith (f :: Type -> Type) v a = CondBranch { condBranchCondition :: Condition v - , condBranchIfTrue :: CondTree v a - , condBranchIfFalse :: Maybe (CondTree v a) + , condBranchIfTrue :: CondTreeWith f v a + , condBranchIfFalse :: Maybe (CondTreeWith f 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..f89ccc70937 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.Executable ( Executable (..) @@ -18,6 +19,8 @@ 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 @@ -28,7 +31,7 @@ data Executable = Executable } deriving (Generic, Show, Read, Eq, Ord, Data) -instance L.HasBuildInfo Executable where +instance L.HasBuildInfoWith Mod.HasNoAnn Executable where buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l) instance Binary Executable diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs index c8a1472ca56..fe6efb6827a 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.ForeignLib ( ForeignLib (..) @@ -30,6 +31,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 @@ -133,7 +136,7 @@ libVersionNumberShow v = libVersionMajor :: LibVersionInfo -> Int libVersionMajor (LibVersionInfo c _ a) = c - a -instance L.HasBuildInfo ForeignLib where +instance L.HasBuildInfoWith Mod.HasNoAnn ForeignLib where buildInfo f l = (\x -> l{foreignLibBuildInfo = x}) <$> f (foreignLibBuildInfo l) instance Binary ForeignLib diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 67c39879614..330ee9e112a 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -1,10 +1,23 @@ +{-# 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 ) where @@ -29,10 +42,16 @@ 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 +type GenericPackageDescription = GenericPackageDescriptionWith Mod.HasNoAnn +type GenericPackageDescriptionAnn = GenericPackageDescriptionWith Mod.HasAnn + +data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDescription { packageDescription :: PackageDescription , gpdScannedVersion :: Maybe Version -- ^ This is a version as specified in source. @@ -44,39 +63,29 @@ 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 Library)] , condForeignLibs - :: [ ( UnqualComponentName - , CondTree ConfVar ForeignLib - ) - ] + :: [(UnqualComponentName, CondTree ConfVar ForeignLib)] , condExecutables - :: [ ( UnqualComponentName - , CondTree ConfVar Executable - ) - ] + :: [(UnqualComponentName, CondTree ConfVar Executable)] , condTestSuites - :: [ ( UnqualComponentName - , CondTree ConfVar TestSuite - ) - ] + :: [(UnqualComponentName, CondTree ConfVar TestSuite)] , condBenchmarks - :: [ ( UnqualComponentName - , CondTree ConfVar Benchmark - ) - ] + :: [(UnqualComponentName, CondTree ConfVar Benchmark)] } - 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) + +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 @@ -86,7 +95,7 @@ emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescripti -- ----------------------------------------------------------------------------- -- 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..7d0b0be09cf 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -25,7 +25,7 @@ import Distribution.Types.ConfVar (ConfVar (..)) import Distribution.Types.Executable (Executable) import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag)) import Distribution.Types.ForeignLib (ForeignLib) -import Distribution.Types.GenericPackageDescription (GenericPackageDescription (GenericPackageDescription)) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription, GenericPackageDescriptionWith (..)) import Distribution.Types.Library (Library) import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.TestSuite (TestSuite) diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs index fd4b89b6a6a..c26561a2e64 100644 --- a/Cabal-syntax/src/Distribution/Types/Library.hs +++ b/Cabal-syntax/src/Distribution/Types/Library.hs @@ -1,8 +1,15 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} module Distribution.Types.Library - ( Library (..) + ( Library + , LibraryAnn + , LibraryWith (..) , emptyLibrary , explicitLibModules , libModulesAutogen @@ -19,7 +26,12 @@ import Distribution.Types.ModuleReexport import qualified Distribution.Types.BuildInfo.Lens as L -data Library = Library +import qualified Distribution.Types.Modify as Mod + +type Library = LibraryWith Mod.HasNoAnn +type LibraryAnn = LibraryWith Mod.HasAnn + +data LibraryWith (m :: Mod.HasAnnotation) = Library { libName :: LibraryName , exposedModules :: [ModuleName] , reexportedModules :: [ModuleReexport] @@ -29,11 +41,17 @@ data Library = Library -- ^ 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 -instance L.HasBuildInfo Library where +instance L.HasBuildInfoWith Mod.HasNoAnn Library where buildInfo f l = (\x -> l{libBuildInfo = x}) <$> f (libBuildInfo l) instance Binary Library diff --git a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs index 9787f3700dd..effd5b72a35 100644 --- a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs @@ -8,38 +8,38 @@ import Distribution.Compat.Prelude import Prelude () 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) 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..0ce1c2dec7e --- /dev/null +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | +-- Types that can be used as modifiers +module Distribution.Types.Modify where + +import Data.Data + +-- | Toggle whether a GPD component has annotation or not. +data HasAnnotation + = HasAnn + | HasNoAnn + deriving (Show, Read, Eq, Ord, Data) diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs index 8ef892a9ad3..fcf5032aa44 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- @@ -78,6 +79,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 @@ -456,7 +458,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/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index 8a22662d672..9c6ad91c1e3 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,12 @@ import Prelude () import Distribution.Parsec import Distribution.Pretty +import Distribution.Trivia import qualified Text.PrettyPrint as Disp +import Data.Kind +import qualified Distribution.Types.Modify as Mod + -- | A package name. -- -- Use 'mkPackageName' and 'unPackageName' to convert from/to a @@ -25,8 +38,31 @@ 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 + +type family ModifyPackageName (m :: Mod.HasAnnotation) (a :: Type) where + ModifyPackageName Mod.HasNoAnn a = a + ModifyPackageName Mod.HasAnn a = Ann a + +newtype PackageNameWith (m :: Mod.HasAnnotation) = PackageName (ModifyPackageName 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 +104,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/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs index 129e17dabfb..5440e3f09e0 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiParamTypeClasses #-} module Distribution.Types.TestSuite ( TestSuite (..) @@ -20,6 +22,7 @@ import Distribution.Types.UnqualComponentName import Distribution.ModuleName import qualified Distribution.Types.BuildInfo.Lens as L +import qualified Distribution.Types.Modify as Mod -- | A \"test-suite\" stanza in a cabal file. data TestSuite = TestSuite @@ -30,7 +33,7 @@ data TestSuite = TestSuite } deriving (Generic, Show, Read, Eq, Ord, Data) -instance L.HasBuildInfo TestSuite where +instance L.HasBuildInfoWith Mod.HasNoAnn TestSuite where buildInfo f l = (\x -> l{testBuildInfo = x}) <$> f (testBuildInfo l) instance Binary TestSuite diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs index f671759b42f..453c3c4d3df 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 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..8d949b84373 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 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, 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 -> [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..74cbe6df36a 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,117 @@ 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 + +type family Modify (m :: Mod.HasAnnotation) (a :: Type) where + Modify Mod.HasNoAnn a = a + Modify Mod.HasAnn Version = (Trivia, VersionAnn) + Modify Mod.HasAnn VersionRangeAnn = (Trivia, VersionRangeAnn) + +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, VersionAnn) -> (Trivia, VersionAnn) + ) + -> ( (Trivia, VersionRangeAnn) -> (Trivia, VersionRangeAnn) + ) + -> ( (Trivia, VersionRangeAnn) -> (Trivia, 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, Trivia) + -> VersionRangeAnn + -> ((Trivia, 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 +173,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 +185,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, VersionAnn) -> VersionRangeAnn +thisVersionAnn = ThisVersion + -- | The version range @/= v@. -- -- > withinRange v' (notThisVersion v) = v' /= v @@ -98,24 +209,36 @@ notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) laterVersion :: Version -> VersionRange laterVersion = LaterVersion +laterVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +laterVersionAnn = LaterVersion + -- | The version range @>= v@. -- -- > withinRange v' (orLaterVersion v) = v' >= v orLaterVersion :: Version -> VersionRange orLaterVersion = OrLaterVersion +orLaterVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +orLaterVersionAnn = OrLaterVersion + -- | The version range @< v@. -- -- > withinRange v' (earlierVersion v) = v' < v earlierVersion :: Version -> VersionRange earlierVersion = EarlierVersion +earlierVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +earlierVersionAnn = EarlierVersion + -- | The version range @<= v@. -- -- > withinRange v' (orEarlierVersion v) = v' <= v orEarlierVersion :: Version -> VersionRange orEarlierVersion = OrEarlierVersion +orEarlierVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +orEarlierVersionAnn = OrEarlierVersion + -- | The version range @vr1 || vr2@. -- -- > withinRange v' (unionVersionRanges vr1 vr2) @@ -123,6 +246,9 @@ orEarlierVersion = OrEarlierVersion unionVersionRanges :: VersionRange -> VersionRange -> VersionRange unionVersionRanges = UnionVersionRanges +unionVersionRangesAnn :: (Trivia, VersionRangeAnn) -> (Trivia, VersionRangeAnn) -> VersionRangeAnn +unionVersionRangesAnn = UnionVersionRanges + -- | The version range @vr1 && vr2@. -- -- > withinRange v' (intersectVersionRanges vr1 vr2) @@ -130,6 +256,9 @@ unionVersionRanges = UnionVersionRanges intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges +intersectVersionRangesAnn :: (Trivia, VersionRangeAnn) -> (Trivia, 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 +273,13 @@ withinVersion v = (orLaterVersion v) (earlierVersion (wildcardUpperBound v)) +-- TODO(leana8959): how to detect that this is inserted +withinVersionAnn :: (Trivia, 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 +291,9 @@ withinVersion v = majorBoundVersion :: Version -> VersionRange majorBoundVersion = MajorBoundVersion +majorBoundVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +majorBoundVersionAnn = MajorBoundVersion + -- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. -- -- @since 2.2 @@ -250,6 +389,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 +455,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, VersionAnn) -> Disp.Doc + applyLeafTrivia symb (t, v) = applyTriviaDoc t (symb <> pretty v) + + applyBranchTrivia :: (Trivia, Disp.Doc) -> Disp.Doc + applyBranchTrivia = uncurry applyTriviaDoc + -- | -- -- >>> simpleParsec "^>= 3.4" :: Maybe VersionRange @@ -349,6 +522,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 +533,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 +638,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 +661,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 +675,38 @@ versionRangeParser digitParser csv = expr ] -- \^>= is available since 2.0 + majorBoundVersion' :: (Trivia, 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 +714,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 +750,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 +811,6 @@ wildcardUpperBound = alterVersion $ \lowerBound -> case unsnoc lowerBound of Nothing -> [] Just (xs, x) -> xs ++ [x + 1] + +wildcardUpperBoundAnn :: (Trivia, VersionAnn) -> (Trivia, 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/tests/HackageTests.hs b/Cabal-tests/tests/HackageTests.hs index b5cfab5d4ec..f68bc962aea 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -21,7 +21,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 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..ca9aa3920bf 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -1,4 +1,8 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + module Main ( main ) where @@ -13,6 +17,7 @@ import Test.Tasty.HUnit import Control.Monad (void) import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) import Data.Maybe (isNothing) +import Distribution.CabalSpecVersion import Distribution.Fields (pwarning) import Distribution.PackageDescription ( GenericPackageDescription @@ -26,17 +31,36 @@ import Distribution.PackageDescription , condTestSuites , condBenchmarks ) -import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) +import Distribution.PackageDescription.FieldGrammar(buildInfoFieldGrammar) +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.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 + ( CommaVCatAnn + , CommaFSepAnn + , VCatAnn + , FSepAnn + , NoCommaFSepAnn + , 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 @@ -45,6 +69,7 @@ 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 +80,7 @@ tests = testGroup "parsec tests" , warningTests , errorTests , ipiTests + , parsecPrettyTests ] ------------------------------------------------------------------------------- @@ -161,6 +187,96 @@ 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 CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn leading" ", foo , bar" + , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn leading" ", foo , bar" + , parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn trailing" "foo \n , bar \n, " + , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn trailing" "foo \n , bar , " + ] + ++ + optionals (specVer >= CabalSpecV3_0) + [ parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn leading" ", foo , bar" + , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn leading" ", foo , bar" + ] + ++ + [ parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn simple" "foo , bar , baz" + , parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn newline" "foo ,\n bar , baz" + , parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn newline" "foo ,\n bar \n, baz" + + , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn simple" "foo , bar , baz" + , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn newline" "foo ,\n bar , baz" + , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn newline" "foo ,\n bar \n, baz" + + , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn simple" "foo \n bar" + , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn trailing" "foo \n bar \n" + , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn trailing" "foo \n bar \n\n" + , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn optional comma" "foo , \n bar \n\n" + + , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn simple" "foo \n bar" + , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn trailing" "foo \n bar \n" + , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn trailing" "foo \n bar \n\n" + , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn optional comma" "foo , \n bar \n\n" + + , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn simple" "foo \n bar" + , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn trailing" "foo \n bar \n" + , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn trailing" "foo \n bar \n\n" + , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn optional comma" "foo \n bar \n\n" + ] + + where + optionals cond ifTrue = if cond then ifTrue else [] + +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 +330,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,8 +355,8 @@ 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 (_, x) = runParseResult res @@ -248,7 +364,7 @@ treeDiffGoldenTest fp = ediffGolden goldenTest "expr" exprFile $ do 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/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/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/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/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 #-} From fe6313c308f59a7a45d12a9229d1ecfc865935ec Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 3 Apr 2026 15:41:35 +0200 Subject: [PATCH 002/111] make trivia type parameterized In some situations we want to pass around not only the whitespaces trivia, but also Position. This makes it possible to reuse the Trivia type for Position. --- .../src/Distribution/Compat/Parsing.hs | 8 +-- .../src/Distribution/FieldGrammar/Newtypes.hs | 4 +- Cabal-syntax/src/Distribution/Parsec.hs | 55 +++++++++-------- Cabal-syntax/src/Distribution/Trivia.hs | 61 +++++++++---------- .../src/Distribution/Types/CondTree.hs | 8 +-- .../src/Distribution/Types/PackageName.hs | 2 +- .../Distribution/Types/UnqualComponentName.hs | 2 +- .../src/Distribution/Types/Version.hs | 6 +- .../Types/VersionRange/Internal.hs | 40 ++++++------ 9 files changed, 91 insertions(+), 95 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Compat/Parsing.hs b/Cabal-syntax/src/Distribution/Compat/Parsing.hs index 4b924866d16..b82f669a9b7 100644 --- a/Cabal-syntax/src/Distribution/Compat/Parsing.hs +++ b/Cabal-syntax/src/Distribution/Compat/Parsing.hs @@ -108,7 +108,7 @@ sepBy :: Alternative m => m a -> m sep -> m [a] sepBy p sep = toList <$> sepByNonEmpty p sep <|> pure [] {-# INLINE sepBy #-} -sepByAnn :: Alternative m => m (Ann a) -> m String -> m [Ann a] +sepByAnn :: Alternative m => m (Ann SurroundingText a) -> m String -> m [Ann SurroundingText a] sepByAnn p sep = toList <$> sepByNonEmptyAnn p sep <|> pure [] {-# INLINE sepByAnn #-} @@ -118,7 +118,7 @@ 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 a) -> m String -> m (NonEmpty (Ann a)) +sepByNonEmptyAnn :: forall m a. Alternative m => m (Ann SurroundingText a) -> m String -> m (NonEmpty (Ann SurroundingText a)) sepByNonEmptyAnn p sep = (:|) <$> p @@ -135,7 +135,7 @@ sepByNonEmptyAnn p sep = sepEndByNonEmpty :: Alternative m => m a -> m sep -> m (NonEmpty a) sepEndByNonEmpty p sep = (:|) <$> p <*> ((sep *> sepEndBy p sep) <|> pure []) -sepEndByNonEmptyAnn :: Alternative m => m (Ann a) -> m String -> m (NonEmpty (Ann a)) +sepEndByNonEmptyAnn :: Alternative m => m (Ann SurroundingText a) -> m String -> m (NonEmpty (Ann SurroundingText a)) sepEndByNonEmptyAnn p sep = do x <- p (trailing, xs) <- @@ -154,7 +154,7 @@ sepEndBy p sep = toList <$> sepEndByNonEmpty p sep <|> pure [] {-# INLINE sepEndBy #-} -- | @sepEndByAnn@ is like @sepEndBy@, but it keeps the trivia. -sepEndByAnn :: Alternative m => m (Ann a) -> m String -> m [Ann a] +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 diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 6a0c4ec4046..8c324ffc67c 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -120,7 +120,7 @@ data NoCommaFSepAnn = NoCommaFSepAnn type family Modify (mod :: Mod.HasAnnotation) (a :: Type) where Modify Mod.HasNoAnn a = a - Modify Mod.HasAnn a = Ann a + Modify Mod.HasAnn a = Ann SurroundingText a -- TODO(leana8959): Relax Sep to return a list of annotated docs with position -- Use the position propagated back from applyTriviaDoc @@ -251,7 +251,7 @@ alaList' :: sep -> (a -> b) -> [a] -> List sep b a alaList' _ _ = List instance Newtype [a] (List sep wrapper a) -instance Newtype [Ann a] (ListAnn sep wrapper a) +instance Newtype [Ann SurroundingText a] (ListAnn sep wrapper a) instance (Newtype a b, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (List sep b a) where parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 03ca3614087..33351d09155 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -318,17 +318,17 @@ parsecStandard f = do -- | -- Parse parser @p@ and some trailing spaces. -- The trivia is stored. -parsecSpacesAnn :: (CabalParsing m) => m (Ann a) -> m (Ann a) +parsecSpacesAnn :: CabalParsing m => m (Ann SurroundingText a) -> m (Ann SurroundingText a) parsecSpacesAnn p = do x <- p post <- P.spaces' pure (mapAnn (<> postTrivia post) x) -{-# INLINABLE parsecSpacesAnn #-} +{-# INLINEABLE parsecSpacesAnn #-} 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 a) -> m [Ann a] +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 @@ -338,7 +338,7 @@ 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 a) -> m (NonEmpty (Ann a)) +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 @@ -362,14 +362,15 @@ parsecLeadingCommaList p = do comma = P.char ',' *> P.spaces P. "comma" -- | Like 'parsecCommaList' but stores trivia. -parsecLeadingCommaListAnn :: forall m a. CabalParsing m => m (Ann a) -> m [Ann 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 +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 a) + lp :: m (Ann SurroundingText a) lp = parsecSpacesAnn p comma :: m String @@ -389,12 +390,13 @@ parsecLeadingCommaNonEmpty p = do comma = P.char ',' *> P.spaces P. "comma" -- | Like @parsecLeadingCommaNonEmpty@ but stores trivia. -parsecLeadingCommaNonEmptyAnn :: forall m a. CabalParsing m => m (Ann a) -> m (NonEmpty (Ann a)) -parsecLeadingCommaNonEmptyAnn p = P.optional comma >>= \case - Nothing -> P.sepEndByNonEmptyAnn lp comma - Just _ -> P.sepByNonEmptyAnn lp comma +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 a) + lp :: m (Ann SurroundingText a) lp = parsecSpacesAnn p comma :: m String @@ -405,10 +407,10 @@ parsecOptCommaList p = P.sepBy (p <* P.spaces) (P.optional comma) where comma = P.char ',' *> P.spaces -parsecOptCommaListAnn :: forall m a. CabalParsing m => m (Ann a) -> m [Ann a] +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 a) + lp :: m (Ann SurroundingText a) lp = parsecSpacesAnn p comma :: m String @@ -444,20 +446,21 @@ parsecLeadingOptCommaList p = do Nothing -> (x :) <$> many lp Just _ -> (x :) <$> P.sepEndBy lp comma -parsecLeadingOptCommaListAnn :: forall m a. CabalParsing m => m (Ann a) -> m [Ann 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 +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 a) + lp :: m (Ann SurroundingText a) lp = parsecSpacesAnn p comma :: m String comma = (:) <$> (P.char ',') <*> P.spaces' P. "comma" - sepEndBy1StartAnn :: m [Ann a] + sepEndBy1StartAnn :: m [Ann SurroundingText a] sepEndBy1StartAnn = do x <- lp P.optional comma >>= \case diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index c763a09ac2e..f3960525138 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -1,12 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} module Distribution.Trivia ( Trivia (..) + , SurroundingText (..) , preTrivia , postTrivia - , posTrivia , Ann (..) , mapAnn , mapAnnA @@ -14,70 +14,69 @@ module Distribution.Trivia ) where -import Data.Data import Control.Applicative +import Data.Data import Distribution.Parsec.Position import qualified Text.PrettyPrint as Disp --- TODO(leana8959): implement position trivia somewhere -data Trivia - = HasTrivia (Maybe Position) String String +-- | 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) + +data Trivia t + = HasTrivia t | ExactRepresentation String | IsInserted | NoTrivia deriving (Show, Eq, Ord, Read, Data) -preTrivia :: String -> Trivia -preTrivia s = HasTrivia Nothing s mempty - -postTrivia :: String -> Trivia -postTrivia s = HasTrivia Nothing mempty s - -posTrivia :: Position -> Trivia -posTrivia pos = HasTrivia (Just pos) mempty mempty +preTrivia :: String -> Trivia SurroundingText +preTrivia s = HasTrivia (SurroundingText s mempty) -instance Semigroup Trivia where - HasTrivia mpos s t <> HasTrivia mpos' a b = HasTrivia (mpos <|> mpos') (s <> a) (t <> b) +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 Monoid Trivia where +instance Semigroup t => Monoid (Trivia t) where mempty = NoTrivia -data Ann a = Ann - { getAnn :: Trivia +data Ann t a = Ann + { getAnn :: Trivia t , unAnn :: a } deriving (Show, Eq, Ord, Functor, Read, Data) mapAnn - :: (Trivia -> Trivia) - -> Ann a - -> Ann a + :: (Trivia s -> Trivia t) + -> Ann s a + -> Ann t a mapAnn f (Ann t x) = Ann (f t) x mapAnnA - :: (Trivia -> Trivia) - -> (a -> a) - -> Ann a - -> Ann a + :: (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 + :: Trivia SurroundingText -> Disp.Doc -> Disp.Doc applyTriviaDoc t = case t of - -- TODO(leana8959): do not ignore the position here - HasTrivia _ pre post -> \d -> Disp.text pre <> d <> Disp.text post + 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/CondTree.hs b/Cabal-syntax/src/Distribution/Types/CondTree.hs index d20db2ebfe4..7832b483391 100644 --- a/Cabal-syntax/src/Distribution/Types/CondTree.hs +++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs @@ -33,7 +33,6 @@ module Distribution.Types.CondTree import Distribution.Compat.Prelude import Prelude () -import Distribution.Trivia import Distribution.Types.Condition import Control.Exception @@ -41,11 +40,6 @@ import Data.Kind import qualified Distribution.Compat.Lens as L -type family Modify (f :: Type -> Type) (a :: Type) where - Modify Identity a = a - Modify Ann a = ([String], a) - Modify _ a = TypeError - -- | A 'CondTree' is used to represent the conditional structure of -- a Cabal file, reflecting a syntax element subject to constraints, -- and then any number of sub-elements which may be enabled subject @@ -73,7 +67,7 @@ type family Modify (f :: Type -> Type) (a :: Type) where type CondTree = CondTreeWith Identity data CondTreeWith f v a = CondNode - { condTreeData :: Modify f a + { condTreeData :: a , condTreeComponents :: [CondBranch v a] } diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index 9c6ad91c1e3..c1c2b9ef970 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -44,7 +44,7 @@ type PackageNameAnn = PackageNameWith Mod.HasAnn type family ModifyPackageName (m :: Mod.HasAnnotation) (a :: Type) where ModifyPackageName Mod.HasNoAnn a = a - ModifyPackageName Mod.HasAnn a = Ann a + ModifyPackageName Mod.HasAnn a = Ann SurroundingText a newtype PackageNameWith (m :: Mod.HasAnnotation) = PackageName (ModifyPackageName m ShortText) deriving (Generic) diff --git a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs index 453c3c4d3df..8ae9e7e6f61 100644 --- a/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs +++ b/Cabal-syntax/src/Distribution/Types/UnqualComponentName.hs @@ -97,7 +97,7 @@ instance NFData UnqualComponentName where packageNameToUnqualComponentName :: PackageName -> UnqualComponentName packageNameToUnqualComponentName = UnqualComponentName . unPackageNameST -packageNameToUnqualComponentNameWith :: PackageNameWith Mod.HasAnn -> Ann UnqualComponentName +packageNameToUnqualComponentNameWith :: PackageNameWith Mod.HasAnn -> Ann SurroundingText UnqualComponentName packageNameToUnqualComponentNameWith (PackageName u) = fmap UnqualComponentName u -- | Converts an unqualified component name to a package name diff --git a/Cabal-syntax/src/Distribution/Types/Version.hs b/Cabal-syntax/src/Distribution/Types/Version.hs index 8d949b84373..00c8882fe5e 100644 --- a/Cabal-syntax/src/Distribution/Types/Version.hs +++ b/Cabal-syntax/src/Distribution/Types/Version.hs @@ -45,7 +45,7 @@ import qualified Text.Read as Read -- 'Binary' instance using a different (and more compact) encoding. -- -- @since 2.0.0.2 -type VersionAnn = Ann Version +type VersionAnn = Ann SurroundingText Version data Version = PV0 {-# UNPACK #-} !Word64 @@ -109,7 +109,7 @@ instance Pretty Version where instance Pretty VersionAnn where pretty (Ann t ver) = applyTrivia $ fmap pretty (t, ver) where - applyTrivia :: (Trivia, Disp.Doc) -> Disp.Doc + applyTrivia :: (Trivia SurroundingText, Disp.Doc) -> Disp.Doc applyTrivia = uncurry applyTriviaDoc instance Parsec Version where @@ -205,7 +205,7 @@ 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 -> [Int] -> VersionAnn +mkVersionAnn :: Trivia SurroundingText -> [Int] -> VersionAnn mkVersionAnn t vs = Ann t (mkVersion vs) -- | Version 0. A lower bound of 'Version'. diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs index 74cbe6df36a..e9506ed57f0 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs @@ -72,8 +72,8 @@ type VersionRangeAnn = VersionRangeWith Mod.HasAnn type family Modify (m :: Mod.HasAnnotation) (a :: Type) where Modify Mod.HasNoAnn a = a - Modify Mod.HasAnn Version = (Trivia, VersionAnn) - Modify Mod.HasAnn VersionRangeAnn = (Trivia, VersionRangeAnn) + Modify Mod.HasAnn Version = (Trivia SurroundingText, VersionAnn) + Modify Mod.HasAnn VersionRangeAnn = (Trivia SurroundingText, VersionRangeAnn) data VersionRangeWith (m :: Mod.HasAnnotation) = ThisVersion (Modify m Version) -- = version @@ -114,11 +114,11 @@ unAnnVersionRange (IntersectVersionRanges a b) = IntersectVersionRanges (unAnnVe -- | Map annotation to a already annotated VersionRange data mapVersionRangeAnn - :: ( (Trivia, VersionAnn) -> (Trivia, VersionAnn) + :: ( (Trivia SurroundingText, VersionAnn) -> (Trivia SurroundingText, VersionAnn) ) - -> ( (Trivia, VersionRangeAnn) -> (Trivia, VersionRangeAnn) + -> ( (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) ) - -> ( (Trivia, VersionRangeAnn) -> (Trivia, VersionRangeAnn) + -> ( (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) ) -> VersionRangeAnn -> VersionRangeAnn @@ -133,9 +133,9 @@ mapVersionRangeAnn mapLeaf mapBranchL mapBranchR vr = case vr of IntersectVersionRanges a b -> IntersectVersionRanges (mapBranchL a) (mapBranchR b) decorateTriviaVersionRangeAnn - :: (Trivia, Trivia) + :: (Trivia SurroundingText, Trivia SurroundingText) -> VersionRangeAnn - -> ((Trivia, VersionRangeAnn), VersionRangeAnn) + -> ((Trivia SurroundingText, VersionRangeAnn), VersionRangeAnn) decorateTriviaVersionRangeAnn (leading, trailing) vr = (enclose vr, insert vr) where enclose = (leading <> trailing,) @@ -194,7 +194,7 @@ noVersionAnn = EarlierVersion (ExactRepresentation "-none", Ann mempty $ mkVersi thisVersion :: Version -> VersionRange thisVersion = ThisVersion -thisVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +thisVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn thisVersionAnn = ThisVersion -- | The version range @/= v@. @@ -209,7 +209,7 @@ notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) laterVersion :: Version -> VersionRange laterVersion = LaterVersion -laterVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +laterVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn laterVersionAnn = LaterVersion -- | The version range @>= v@. @@ -218,7 +218,7 @@ laterVersionAnn = LaterVersion orLaterVersion :: Version -> VersionRange orLaterVersion = OrLaterVersion -orLaterVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +orLaterVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn orLaterVersionAnn = OrLaterVersion -- | The version range @< v@. @@ -227,7 +227,7 @@ orLaterVersionAnn = OrLaterVersion earlierVersion :: Version -> VersionRange earlierVersion = EarlierVersion -earlierVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +earlierVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn earlierVersionAnn = EarlierVersion -- | The version range @<= v@. @@ -236,7 +236,7 @@ earlierVersionAnn = EarlierVersion orEarlierVersion :: Version -> VersionRange orEarlierVersion = OrEarlierVersion -orEarlierVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +orEarlierVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn orEarlierVersionAnn = OrEarlierVersion -- | The version range @vr1 || vr2@. @@ -246,7 +246,7 @@ orEarlierVersionAnn = OrEarlierVersion unionVersionRanges :: VersionRange -> VersionRange -> VersionRange unionVersionRanges = UnionVersionRanges -unionVersionRangesAnn :: (Trivia, VersionRangeAnn) -> (Trivia, VersionRangeAnn) -> VersionRangeAnn +unionVersionRangesAnn :: (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) -> VersionRangeAnn unionVersionRangesAnn = UnionVersionRanges -- | The version range @vr1 && vr2@. @@ -256,7 +256,7 @@ unionVersionRangesAnn = UnionVersionRanges intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange intersectVersionRanges = IntersectVersionRanges -intersectVersionRangesAnn :: (Trivia, VersionRangeAnn) -> (Trivia, VersionRangeAnn) -> VersionRangeAnn +intersectVersionRangesAnn :: (Trivia SurroundingText, VersionRangeAnn) -> (Trivia SurroundingText, VersionRangeAnn) -> VersionRangeAnn intersectVersionRangesAnn = IntersectVersionRanges -- | The version range @== v.*@. @@ -274,7 +274,7 @@ withinVersion v = (earlierVersion (wildcardUpperBound v)) -- TODO(leana8959): how to detect that this is inserted -withinVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +withinVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn withinVersionAnn v = intersectVersionRangesAnn (mempty, orLaterVersionAnn v) @@ -291,7 +291,7 @@ withinVersionAnn v = majorBoundVersion :: Version -> VersionRange majorBoundVersion = MajorBoundVersion -majorBoundVersionAnn :: (Trivia, VersionAnn) -> VersionRangeAnn +majorBoundVersionAnn :: (Trivia SurroundingText, VersionAnn) -> VersionRangeAnn majorBoundVersionAnn = MajorBoundVersion -- | F-Algebra of 'VersionRange'. See 'cataVersionRange'. @@ -476,10 +476,10 @@ prettyVersionRangeAnn vr = case vr of <> "&&" <> applyBranchTrivia (fmap prettyVersionRangeAnn r2) where - applyLeafTrivia :: Disp.Doc -> (Trivia, VersionAnn) -> Disp.Doc + applyLeafTrivia :: Disp.Doc -> (Trivia SurroundingText, VersionAnn) -> Disp.Doc applyLeafTrivia symb (t, v) = applyTriviaDoc t (symb <> pretty v) - applyBranchTrivia :: (Trivia, Disp.Doc) -> Disp.Doc + applyBranchTrivia :: (Trivia SurroundingText, Disp.Doc) -> Disp.Doc applyBranchTrivia = uncurry applyTriviaDoc -- | @@ -675,7 +675,7 @@ versionRangeAnnParser digitParser csv = expr ] -- \^>= is available since 2.0 - majorBoundVersion' :: (Trivia, VersionAnn) -> m VersionRangeAnn + majorBoundVersion' :: (Trivia SurroundingText, VersionAnn) -> m VersionRangeAnn majorBoundVersion' v = if csv >= CabalSpecV2_0 then pure $ majorBoundVersionAnn v @@ -812,5 +812,5 @@ wildcardUpperBound = alterVersion $ Nothing -> [] Just (xs, x) -> xs ++ [x + 1] -wildcardUpperBoundAnn :: (Trivia, VersionAnn) -> (Trivia, VersionAnn) +wildcardUpperBoundAnn :: (Trivia SurroundingText, VersionAnn) -> (Trivia SurroundingText, VersionAnn) wildcardUpperBoundAnn = (fmap . fmap) wildcardUpperBound From cdc2edfbd081ae8f0331b69c347867520f50088c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 3 Apr 2026 17:15:45 +0200 Subject: [PATCH 003/111] implement model for position tracking --- Cabal-syntax/src/Distribution/Trivia.hs | 29 +++++++++++++++++++++++-- 1 file changed, 27 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index f3960525138..61de3587556 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -3,8 +3,10 @@ {-# LANGUAGE TupleSections #-} module Distribution.Trivia - ( Trivia (..) - , SurroundingText (..) + ( SurroundingText (..) + , Positions (..) + , Trivia (..) + , preTrivia , postTrivia , Ann (..) @@ -15,6 +17,7 @@ module Distribution.Trivia where import Control.Applicative +import Data.Monoid (Last (..)) import Data.Data import Distribution.Parsec.Position import qualified Text.PrettyPrint as Disp @@ -26,6 +29,28 @@ data SurroundingText = SurroundingText String String 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 + { fieldNamePos :: Maybe Position + , fieldLinePos :: Maybe Position + , fieldSectionPos :: Maybe Position + } + deriving (Show, Eq, Ord, Read, Data) + +instance Semigroup Positions where + i <> j = + Positions + { fieldNamePos = field fieldNamePos + , fieldLinePos = field fieldLinePos + , fieldSectionPos = field fieldSectionPos + } + where + field a = getLast (Last (a i) <> Last (a j)) + +instance Monoid Positions where + mempty = Positions Nothing Nothing Nothing + data Trivia t = HasTrivia t | ExactRepresentation String From f0eb41bd6e66dd9ac566d7a9cf1e8719c064aa24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 3 Apr 2026 17:38:24 +0200 Subject: [PATCH 004/111] WIP: figure out how to thread position in field grammar --- .../src/Distribution/FieldGrammar/Class.hs | 18 +++++++++ .../src/Distribution/FieldGrammar/Parsec.hs | 38 +++++++++++++++++++ .../PackageDescription/FieldGrammar.hs | 14 +++++++ Cabal-syntax/src/Distribution/Parsec.hs | 1 + 4 files changed, 71 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index fa815a49a5e..37168a7fa59 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -19,6 +19,8 @@ import Prelude () import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Compat.Newtype (Newtype) +import Distribution.Trivia +import Distribution.Parsec.Position (Position) import Distribution.FieldGrammar.Newtypes import Distribution.Fields.Field import Distribution.Utils.ShortText @@ -132,6 +134,22 @@ class -- ^ lens into the field -> g s a + -- | Monoidal field. + -- + -- Values are combined with 'mappend'. + -- + -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. + monoidalFieldAlaAnn + :: (c b, Monoid u, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'pack' + -> ALens' s a + -- ^ lens into the field + -> (Positions -> a -> u) + -> g s u + -- | Parser matching all fields with a name starting with a prefix. prefixedFields :: FieldName diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 581daf4c202..1a12e264384 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -69,12 +71,14 @@ module Distribution.FieldGrammar.Parsec , freeTextIgnoreDotlineVers ) where +import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Utils.Generic (fromUTF8BS) import Distribution.Utils.String (trim) import Prelude () +import Data.Monoid (Last (..)) import qualified Data.ByteString as BS import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -88,6 +92,7 @@ import Distribution.FieldGrammar.Class import Distribution.Fields.Field import Distribution.Fields.ParseResult import Distribution.Parsec +import Distribution.Trivia import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) @@ -271,14 +276,47 @@ instance FieldGrammar Parsec ParsecFieldGrammar where | v >= freeTextIgnoreDotlineVers -> pure (ShortText.toShortText $ fieldlinesToFreeText3 pos fls) | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) + monoidalFieldAla + :: forall b a s + . (Parsec b, Monoid a, Newtype a b) + => FieldName + -> (a -> b) + -> ALens' s a + -> ParsecFieldGrammar s a monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where + parser :: CabalSpecVersion -> 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 + -- TODO(leana8959): maybe define monoidalFieldAla base on monoidalFieldAlaAnn + -- + -- This function allows us to manage the position coming from a parsed field + -- In the printer, it can... IDK? Annotate the pretty doc position? + monoidalFieldAlaAnn + :: forall b a s u + . (Parsec b, Monoid u, Newtype a b) + => FieldName + -> (a -> b) + -> ALens' s a + -> (Positions -> a -> u) + -> ParsecFieldGrammar s u + monoidalFieldAlaAnn fn _pack _extract attachPos = ParsecFG (Set.singleton fn) Set.empty parser + where + parser :: CabalSpecVersion -> Fields Position -> ParseResult src u + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> foldMap (\(p, b) -> attachPos p $ unpack' _pack b) <$> traverse (parseOne v) xs + + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) + parseOne v (MkNamelessField pos fls) = do + (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls + pure (Positions (Just pos) (undefined linePos) Nothing, x) + prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) where parser :: Fields Position -> [(String, String)] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index e189d3e8cb4..ab40410963e 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -695,6 +695,20 @@ buildInfoFieldGrammar = {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} + +onlyBuildDepends + :: forall mod c g + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod [DependencyWith mod] + , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + ) + => g [DependencyWith mod] [DependencyWith mod] +onlyBuildDepends = monoidalFieldAla "build-depends" (formatDependencyList @mod) L.targetBuildDepends +{-# SPECIALIZE onlyBuildDepends :: ParsecFieldGrammar' [DependencyAnn] #-} +{-# SPECIALIZE onlyBuildDepends :: PrettyFieldGrammar' [DependencyAnn] #-} + hsSourceDirsGrammar :: forall mod c g . ( FieldGrammar c g diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 33351d09155..41675594f4c 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -64,6 +64,7 @@ module Distribution.Parsec , parsecLeadingOptCommaListAnn , parsecStandard , parsecUnqualComponentName + , liftParsec ) where import Data.ByteString (ByteString) From c4dfb6a9925dd6e7bfea521c75e86bc405ff6b1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 09:30:48 +0200 Subject: [PATCH 005/111] implement example of build depends with positions --- .../src/Distribution/FieldGrammar/Class.hs | 7 +++---- .../src/Distribution/FieldGrammar/Parsec.hs | 21 ++++++++++--------- .../PackageDescription/FieldGrammar.hs | 16 +++++++++++++- 3 files changed, 29 insertions(+), 15 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 37168a7fa59..7195670b82b 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -140,15 +140,14 @@ class -- -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. monoidalFieldAlaAnn - :: (c b, Monoid u, Newtype a b) + :: (c b, Newtype a b) => FieldName -- ^ field name -> (a -> b) -- ^ 'pack' - -> ALens' s a + -> ALens' s [(Positions, a)] -- ^ lens into the field - -> (Positions -> a -> u) - -> g s u + -> g s [(Positions, a)] -- | Parser matching all fields with a name starting with a prefix. prefixedFields diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 1a12e264384..3c046b57031 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -78,7 +78,6 @@ import Distribution.Utils.Generic (fromUTF8BS) import Distribution.Utils.String (trim) import Prelude () -import Data.Monoid (Last (..)) import qualified Data.ByteString as BS import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map @@ -297,25 +296,27 @@ instance FieldGrammar Parsec ParsecFieldGrammar where -- -- 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 monoidalFieldAlaAnn - :: forall b a s u - . (Parsec b, Monoid u, Newtype a b) + :: forall b a s + . (Parsec b, Newtype a b) => FieldName -> (a -> b) - -> ALens' s a - -> (Positions -> a -> u) - -> ParsecFieldGrammar s u - monoidalFieldAlaAnn fn _pack _extract attachPos = ParsecFG (Set.singleton fn) Set.empty parser + -> ALens' s [(Positions, a)] + -> ParsecFieldGrammar s [(Positions, a)] + monoidalFieldAlaAnn fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src u + parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] parser v fields = case Map.lookup fn fields of Nothing -> pure mempty - Just xs -> foldMap (\(p, b) -> attachPos p $ unpack' _pack b) <$> traverse (parseOne v) xs + Just xs -> map (\(p, a) -> (p,) $ unpack' _pack a) <$> traverse (parseOne v) xs parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) parseOne v (MkNamelessField pos fls) = do (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls - pure (Positions (Just pos) (undefined linePos) Nothing, x) + pure (Positions (Just pos) (error "convert linePos" linePos) Nothing, x) prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) where diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index ab40410963e..3bbfecb8cb8 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -87,6 +88,7 @@ import Distribution.Parsec import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) +import Distribution.Trivia (Positions (..)) import qualified Distribution.Types.Modify as Mod @@ -709,6 +711,19 @@ onlyBuildDepends = monoidalFieldAla "build-depends" (formatDependencyList @mod) {-# SPECIALIZE onlyBuildDepends :: ParsecFieldGrammar' [DependencyAnn] #-} {-# SPECIALIZE onlyBuildDepends :: PrettyFieldGrammar' [DependencyAnn] #-} +onlyBuildDependsPos + :: forall mod c g + . ( FieldGrammar c g + , Applicative (g (BuildInfoWith mod)) + , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + ) + => g [(Positions, [DependencyWith mod])] [(Positions, [DependencyWith mod])] +onlyBuildDependsPos = + monoidalFieldAlaAnn + "build-depends" + (formatDependencyList @mod) + id + hsSourceDirsGrammar :: forall mod c g . ( FieldGrammar c g @@ -725,7 +740,6 @@ hsSourceDirsGrammar = ^^^ 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 f bi = (\fps -> set (L.hsSourceDirs @mod) fps bi) <$> f [] {-# SPECIALIZE hsSourceDirsGrammar :: ParsecFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} {-# SPECIALIZE hsSourceDirsGrammar :: PrettyFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} From be072cf3035a288391fe74cdf8e55916f73a4d06 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 10:50:13 +0200 Subject: [PATCH 006/111] implement pretty version of field grammar --- .../src/Distribution/FieldGrammar/Pretty.hs | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 0bfd4575695..66ccfb93a17 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} module Distribution.FieldGrammar.Pretty @@ -10,6 +12,7 @@ import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude +import Distribution.Trivia import Distribution.Fields.Field (FieldName) import Distribution.Fields.Pretty (PrettyField (..)) import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) @@ -87,6 +90,26 @@ instance FieldGrammar Pretty PrettyFieldGrammar where where pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) + -- TODO(leana8959): push out the Position + monoidalFieldAlaAnn + :: forall b a s + . (Pretty b, Newtype a b) + => FieldName + -> (a -> b) + -> ALens' s [(Positions, a)] + -> PrettyFieldGrammar s [(Positions, a)] + monoidalFieldAlaAnn fn _pack l = PrettyFG pp + where + pp v s = + -- TODO(leana8959): implement more than one field printing + -- + -- Here the list represents the "groups" of fields that are defined separately but merged by + -- monoidal field. + -- + -- They should be displayed separately anyway. + let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) + in ppField fn mempty + prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) where pp xs = From 08c47f5861409a7b5b66997d11643866b86f4fac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 14:40:29 +0200 Subject: [PATCH 007/111] make targetBuildDepends field hold position if needed --- .../PackageDescription/FieldGrammar.hs | 49 ++++++++----------- .../src/Distribution/Types/BuildInfo.hs | 10 +++- .../src/Distribution/Types/BuildInfo/Lens.hs | 3 +- 3 files changed, 30 insertions(+), 32 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 3bbfecb8cb8..fc558b34205 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -177,6 +178,7 @@ libraryFieldGrammar , Applicative (g (LibraryWith mod)) , Applicative (g (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) + , TargetBuildDepends mod [DependencyWith mod] ~ [DependencyWith mod] , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -214,8 +216,8 @@ libraryFieldGrammar n = LSubLibName _ -> optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' LibraryAnn #-} -{-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' LibraryAnn #-} +-- {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' LibraryAnn #-} +-- {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' LibraryAnn #-} ------------------------------------------------------------------------------- -- Foreign library @@ -591,6 +593,13 @@ buildInfoFieldGrammar . ( FieldGrammar c g , Applicative (g (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) + -- NOTE(leana8959): This constraint is here for the time being to parse legacy BuildInfo without Annotation. + -- To make this fully polymorphic (and lift this constraint), we need to choose between monoidalFieldAla and monoidalFieldAlaAnn using the type. + -- This might force us to add one more new type param to the FieldGrammar type class and render things more complicated, + -- so we leave it for later and ponder on it. + -- + -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. + , TargetBuildDepends mod [DependencyWith mod] ~ [DependencyWith mod] , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) @@ -694,22 +703,8 @@ buildInfoFieldGrammar = <*> monoidalFieldAla "build-depends" (formatDependencyList @mod) L.targetBuildDepends <*> monoidalFieldAla "mixins" formatMixinList L.mixins ^^^ availableSince CabalSpecV2_0 [] -{-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -{-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} - - -onlyBuildDepends - :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) - , L.HasBuildInfoWith mod (BuildInfoWith mod) - , L.HasBuildInfoWith mod [DependencyWith mod] - , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - ) - => g [DependencyWith mod] [DependencyWith mod] -onlyBuildDepends = monoidalFieldAla "build-depends" (formatDependencyList @mod) L.targetBuildDepends -{-# SPECIALIZE onlyBuildDepends :: ParsecFieldGrammar' [DependencyAnn] #-} -{-# SPECIALIZE onlyBuildDepends :: PrettyFieldGrammar' [DependencyAnn] #-} +-- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} +-- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} onlyBuildDependsPos :: forall mod c g @@ -718,11 +713,7 @@ onlyBuildDependsPos , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => g [(Positions, [DependencyWith mod])] [(Positions, [DependencyWith mod])] -onlyBuildDependsPos = - monoidalFieldAlaAnn - "build-depends" - (formatDependencyList @mod) - id +onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList @mod) id hsSourceDirsGrammar :: forall mod c g @@ -741,8 +732,8 @@ hsSourceDirsGrammar = ^^^ removedIn CabalSpecV3_0 "Please use 'hs-source-dirs' field." where wrongLens f bi = (\fps -> set (L.hsSourceDirs @mod) fps bi) <$> f [] -{-# SPECIALIZE hsSourceDirsGrammar :: ParsecFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} -{-# SPECIALIZE hsSourceDirsGrammar :: PrettyFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} +-- {-# SPECIALIZE hsSourceDirsGrammar :: ParsecFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} +-- {-# SPECIALIZE hsSourceDirsGrammar :: PrettyFieldGrammar BuildInfoAnn [SymbolicPath Pkg (Dir Source)] #-} optionsFieldGrammar :: forall mod c g @@ -764,8 +755,8 @@ optionsFieldGrammar = <* knownField "nhc98-options" where extract flavor = L.options @mod . lookupLens flavor -{-# SPECIALIZE optionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} -{-# SPECIALIZE optionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} +-- {-# SPECIALIZE optionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} +-- {-# SPECIALIZE optionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} profOptionsFieldGrammar :: forall mod c g @@ -781,8 +772,8 @@ profOptionsFieldGrammar = <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) where extract flavor = L.profOptions @mod . lookupLens flavor -{-# SPECIALIZE profOptionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} -{-# SPECIALIZE profOptionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} +-- {-# SPECIALIZE profOptionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} +-- {-# SPECIALIZE profOptionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} sharedOptionsFieldGrammar :: forall mod c g diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index cb0389be5f1..f11af704972 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -10,6 +10,7 @@ module Distribution.Types.BuildInfo ( BuildInfo , BuildInfoAnn , BuildInfoWith (..) + , TargetBuildDepends , unannotateDependencyAnn , emptyBuildInfo , allLanguages @@ -26,6 +27,7 @@ module Distribution.Types.BuildInfo import Distribution.Compat.Prelude import Prelude () +import Distribution.Trivia import Distribution.Types.Dependency import Distribution.Types.ExeDependency import Distribution.Types.LegacyExeDependency @@ -44,6 +46,10 @@ import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn type BuildInfoAnn = BuildInfoWith Mod.HasAnn +type family TargetBuildDepends (mod :: Mod.HasAnnotation) (a :: Type) where + TargetBuildDepends Mod.HasAnn a = (Positions, a) + TargetBuildDepends Mod.HasNoAnn a = a + -- Consider refactoring into executable and library versions. data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo { buildable :: Bool @@ -156,7 +162,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: [DependencyWith m] + , targetBuildDepends :: TargetBuildDepends m [DependencyWith m] -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } @@ -175,7 +181,7 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi - { targetBuildDepends = map unannotateDependencyAnn (targetBuildDepends bi) + { targetBuildDepends = map unannotateDependencyAnn $ snd (targetBuildDepends bi) } instance Monoid BuildInfo where diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 7d2f8c25c91..ff243cd3517 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitForAll #-} @@ -182,7 +183,7 @@ class HasBuildInfoWith mod a | a -> mod where customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] customFieldsBI = buildInfo @mod . customFieldsBI @mod - targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [DependencyWith mod] + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (T.TargetBuildDepends mod [DependencyWith mod]) targetBuildDepends = buildInfo @mod . targetBuildDepends @mod mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] From cb2fa93b189226e41e15195d616b355bb6c3f1be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 15:15:34 +0200 Subject: [PATCH 008/111] field BuildInfo type family --- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index f11af704972..b7f3373aa3d 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -47,7 +48,7 @@ type BuildInfo = BuildInfoWith Mod.HasNoAnn type BuildInfoAnn = BuildInfoWith Mod.HasAnn type family TargetBuildDepends (mod :: Mod.HasAnnotation) (a :: Type) where - TargetBuildDepends Mod.HasAnn a = (Positions, a) + TargetBuildDepends Mod.HasAnn a = [(Positions, a)] TargetBuildDepends Mod.HasNoAnn a = a -- Consider refactoring into executable and library versions. @@ -181,7 +182,11 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi - { targetBuildDepends = map unannotateDependencyAnn $ snd (targetBuildDepends bi) + { targetBuildDepends = + mconcat + $ (fmap . fmap) unannotateDependencyAnn + $ map snd + $ targetBuildDepends bi } instance Monoid BuildInfo where From 6504cf73463bc9c20b0ab286001bfec6e4bffb30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 17:13:44 +0200 Subject: [PATCH 009/111] simplify TargetBuildDepends type class --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 4 ++-- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 8 ++++---- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index fc558b34205..ef13cdf500b 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -178,7 +178,7 @@ libraryFieldGrammar , Applicative (g (LibraryWith mod)) , Applicative (g (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , TargetBuildDepends mod [DependencyWith mod] ~ [DependencyWith mod] + , TargetBuildDepends mod ~ [DependencyWith mod] , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -599,7 +599,7 @@ buildInfoFieldGrammar -- so we leave it for later and ponder on it. -- -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. - , TargetBuildDepends mod [DependencyWith mod] ~ [DependencyWith mod] + , TargetBuildDepends mod ~ [DependencyWith mod] , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index b7f3373aa3d..4b3c98a5889 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -47,9 +47,9 @@ import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn type BuildInfoAnn = BuildInfoWith Mod.HasAnn -type family TargetBuildDepends (mod :: Mod.HasAnnotation) (a :: Type) where - TargetBuildDepends Mod.HasAnn a = [(Positions, a)] - TargetBuildDepends Mod.HasNoAnn a = a +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 BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo @@ -163,7 +163,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: TargetBuildDepends m [DependencyWith m] + , targetBuildDepends :: TargetBuildDepends m -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index ff243cd3517..1974b821ae3 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -183,7 +183,7 @@ class HasBuildInfoWith mod a | a -> mod where customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] customFieldsBI = buildInfo @mod . customFieldsBI @mod - targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (T.TargetBuildDepends mod [DependencyWith mod]) + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (T.TargetBuildDepends mod) targetBuildDepends = buildInfo @mod . targetBuildDepends @mod mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] From d11f317901125977db5e454df1eac7e9e7d06e1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 17:16:39 +0200 Subject: [PATCH 010/111] mini example of field grammar with position retention --- .../PackageDescription/FieldGrammar.hs | 35 ++++++++++++++++--- 1 file changed, 30 insertions(+), 5 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index ef13cdf500b..e14d7fbf129 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -706,14 +706,39 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} +data MiniBuildInfo = MiniBuildInfo + { miniTargetBuildDepends :: TargetBuildDepends Mod.HasAnn + } + +miniTargetBuildDependsLens + :: forall f + . Functor f + => ([(Positions, [DependencyWith Mod.HasAnn])] -> f [(Positions, [DependencyWith Mod.HasAnn])]) + -> MiniBuildInfo + -> f MiniBuildInfo +miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) + onlyBuildDependsPos - :: forall mod c g + :: forall c g . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) - , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , Applicative (g (BuildInfoWith Mod.HasAnn)) + , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) + ) + => g (TargetBuildDepends Mod.HasAnn) (TargetBuildDepends Mod.HasAnn) +onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) id + +miniBuildInfoFieldGrammar + :: forall c g + . ( FieldGrammar c g + , Applicative (g MiniBuildInfo) + , Applicative (g (BuildInfoWith Mod.HasAnn)) + , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) ) - => g [(Positions, [DependencyWith mod])] [(Positions, [DependencyWith mod])] -onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList @mod) id + => g MiniBuildInfo MiniBuildInfo +miniBuildInfoFieldGrammar = + -- blurFieldGrammar (miniTargetBuildDepends) onlyBuildDependsPos + MiniBuildInfo <$> + monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) (miniTargetBuildDependsLens) hsSourceDirsGrammar :: forall mod c g From e6779b887f5ac1dafced527a192acb986c39149a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 19:50:27 +0200 Subject: [PATCH 011/111] checkpoint --- .../PackageDescription/FieldGrammar.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index e14d7fbf129..bab362ac5c6 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DataKinds #-} @@ -706,16 +707,16 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} -data MiniBuildInfo = MiniBuildInfo - { miniTargetBuildDepends :: TargetBuildDepends Mod.HasAnn +data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo + { miniTargetBuildDepends :: TargetBuildDepends m } -miniTargetBuildDependsLens +miniTargetBuildDependsLens :: forall f . Functor f - => ([(Positions, [DependencyWith Mod.HasAnn])] -> f [(Positions, [DependencyWith Mod.HasAnn])]) - -> MiniBuildInfo - -> f MiniBuildInfo + => (TargetBuildDepends Mod.HasAnn -> f (TargetBuildDepends Mod.HasAnn)) + -> (MiniBuildInfo Mod.HasAnn) + -> f (MiniBuildInfo Mod.HasAnn) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) onlyBuildDependsPos @@ -730,11 +731,10 @@ onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList miniBuildInfoFieldGrammar :: forall c g . ( FieldGrammar c g - , Applicative (g MiniBuildInfo) - , Applicative (g (BuildInfoWith Mod.HasAnn)) + , Applicative (g (MiniBuildInfo Mod.HasAnn)) , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) ) - => g MiniBuildInfo MiniBuildInfo + => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) miniBuildInfoFieldGrammar = -- blurFieldGrammar (miniTargetBuildDepends) onlyBuildDependsPos MiniBuildInfo <$> From 107d01a87935a0bb424008f138008d69ee2aa7da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 19:51:45 +0200 Subject: [PATCH 012/111] checkpoint --- .../PackageDescription/FieldGrammar.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index bab362ac5c6..9adcdee84a4 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -712,11 +712,11 @@ data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo } miniTargetBuildDependsLens - :: forall f + :: forall mod f . Functor f - => (TargetBuildDepends Mod.HasAnn -> f (TargetBuildDepends Mod.HasAnn)) - -> (MiniBuildInfo Mod.HasAnn) - -> f (MiniBuildInfo Mod.HasAnn) + => (TargetBuildDepends mod -> f (TargetBuildDepends mod)) + -> (MiniBuildInfo mod) + -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) onlyBuildDependsPos @@ -728,17 +728,16 @@ onlyBuildDependsPos => g (TargetBuildDepends Mod.HasAnn) (TargetBuildDepends Mod.HasAnn) onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) id -miniBuildInfoFieldGrammar +miniBuildInfoFieldGrammarAnn :: forall c g . ( FieldGrammar c g , Applicative (g (MiniBuildInfo Mod.HasAnn)) , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) ) => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) -miniBuildInfoFieldGrammar = - -- blurFieldGrammar (miniTargetBuildDepends) onlyBuildDependsPos +miniBuildInfoFieldGrammarAnn = MiniBuildInfo <$> - monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) (miniTargetBuildDependsLens) + monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens hsSourceDirsGrammar :: forall mod c g From eab59b9a2dabf3f7552307315dd1cd244791bd34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 7 Apr 2026 21:01:51 +0200 Subject: [PATCH 013/111] conversion example --- .../PackageDescription/FieldGrammar.hs | 23 +++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 9adcdee84a4..f3a5df5840f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -739,6 +739,29 @@ miniBuildInfoFieldGrammarAnn = MiniBuildInfo <$> monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens +convertTargetBuildDepends + :: TargetBuildDepends Mod.HasAnn + -> TargetBuildDepends Mod.HasNoAnn +convertTargetBuildDepends = join . map (map unannotateDependencyAnn . snd) + +unannotateMiniBuildInfo + :: MiniBuildInfo Mod.HasAnn + -> MiniBuildInfo Mod.HasNoAnn +unannotateMiniBuildInfo (MiniBuildInfo x) = MiniBuildInfo (convertTargetBuildDepends x) + +miniBuildInfoFieldGrammarAnn' + :: forall c g + . ( FieldGrammar c g + , Applicative (g (MiniBuildInfo Mod.HasAnn)) + , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) + ) + => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasNoAnn) +miniBuildInfoFieldGrammarAnn' = fmap unannotateMiniBuildInfo miniBuildInfoFieldGrammarAnn + +-- NOTE(leana8959): +-- For the parser, this parses with HasNoAnn (post processes the parse result) +-- For the printer, this prints with HasNoAnn (shifts the focus) + hsSourceDirsGrammar :: forall mod c g . ( FieldGrammar c g From 795b04df6a59be11942734af654df78aa4fd0840 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 8 Apr 2026 12:13:45 +0200 Subject: [PATCH 014/111] allow contramapping field grammar and leave some notes --- Cabal-syntax/src/Distribution/FieldGrammar/Class.hs | 6 ++++++ Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs | 2 ++ Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs | 2 ++ .../src/Distribution/PackageDescription/FieldGrammar.hs | 4 ---- 4 files changed, 10 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 7195670b82b..c66c070bd24 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -47,6 +47,12 @@ class -- | Unfocus, zoom out, /blur/ 'FieldGrammar'. blurFieldGrammar :: ALens' a b -> g b d -> g a d + -- NOTE(leana8959): this is not what I wanted + -- This allows turning a printer with annotation to one without annotation, + -- but would mean that we insert dummy annotations and it's up to the Pretty instances to figure that out. + -- Very not ideal. + contramapFieldGrammar :: (a -> b) -> g b d -> g a d + -- | Field which should be defined, exactly once. uniqueFieldAla :: (c b, Newtype a b) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 3c046b57031..128102b0737 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -174,6 +174,8 @@ warnMultipleSingularFields fn (x : xs) = do instance FieldGrammar Parsec ParsecFieldGrammar where blurFieldGrammar _ (ParsecFG s s' parser) = ParsecFG s s' parser + contramapFieldGrammar _ (ParsecFG fs prefs p) = ParsecFG fs prefs p + uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 66ccfb93a17..7a1899c322d 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -42,6 +42,8 @@ prettyFieldGrammar = flip fieldGrammarPretty instance FieldGrammar Pretty PrettyFieldGrammar where blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) + contramapFieldGrammar f (PrettyFG pp) = PrettyFG $ \v -> pp v . f + uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> ppField fn (pretty (pack' _pack (aview l s))) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index f3a5df5840f..c9f46111229 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -758,10 +758,6 @@ miniBuildInfoFieldGrammarAnn' => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasNoAnn) miniBuildInfoFieldGrammarAnn' = fmap unannotateMiniBuildInfo miniBuildInfoFieldGrammarAnn --- NOTE(leana8959): --- For the parser, this parses with HasNoAnn (post processes the parse result) --- For the printer, this prints with HasNoAnn (shifts the focus) - hsSourceDirsGrammar :: forall mod c g . ( FieldGrammar c g From 2e9c9d3ff11d366fbe670d86d72c9da067e3ea6a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 10:18:33 +0200 Subject: [PATCH 015/111] attepmt to make position registering also controllable in field grammar --- .../src/Distribution/FieldGrammar/Class.hs | 22 +++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index c66c070bd24..314f34d858c 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -1,4 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,6 +29,13 @@ import Distribution.FieldGrammar.Newtypes import Distribution.Fields.Field import Distribution.Utils.ShortText +import Data.Kind +import qualified Distribution.Types.Modify as Mod + +type family Annotate (m :: Mod.HasAnnotation) (a :: Type) where + Annotate Mod.HasAnn a = a + Annotate Mod.HasNoAnn a = a + -- | 'FieldGrammar' is parametrised by -- -- * @s@ which is a structure we are parsing. We need this to provide prettyprinter @@ -155,6 +166,17 @@ class -- ^ lens into the field -> g s [(Positions, a)] + monoidalFieldAlaAnnProxy + :: forall (m :: Mod.HasAnnotation) b s a + . (c b, Newtype a b) + => FieldName + -- ^ field name + -> (a -> b) + -- ^ 'pack' + -> ALens' s (Annotate m a) + -- ^ lens into the field + -> g s (Annotate m a) + -- | Parser matching all fields with a name starting with a prefix. prefixedFields :: FieldName From 9d89ae262efc776c65ab2af6fe8e1923c5c49801 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 10:23:02 +0200 Subject: [PATCH 016/111] attempt to parameterize field gramamr output --- Cabal-syntax/src/Distribution/FieldGrammar/Class.hs | 4 ++-- .../Distribution/PackageDescription/FieldGrammar.hs | 11 +++++++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 314f34d858c..3f2e719a9c5 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -33,7 +33,7 @@ import Data.Kind import qualified Distribution.Types.Modify as Mod type family Annotate (m :: Mod.HasAnnotation) (a :: Type) where - Annotate Mod.HasAnn a = a + Annotate Mod.HasAnn a = [(Positions, a)] Annotate Mod.HasNoAnn a = a -- | 'FieldGrammar' is parametrised by @@ -166,7 +166,7 @@ class -- ^ lens into the field -> g s [(Positions, a)] - monoidalFieldAlaAnnProxy + monoidalFieldAlaAnnTypeApp :: forall (m :: Mod.HasAnnotation) b s a . (c b, Newtype a b) => FieldName diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index c9f46111229..03435682689 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -739,6 +739,17 @@ miniBuildInfoFieldGrammarAnn = MiniBuildInfo <$> monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens +miniBuildInfoFieldGrammarTypeApp + :: forall c g + . ( FieldGrammar c g + , Applicative (g (MiniBuildInfo Mod.HasAnn)) + , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) + ) + => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) +miniBuildInfoFieldGrammarTypeApp = + MiniBuildInfo <$> + monoidalFieldAlaAnnTypeApp @_ @_ @Mod.HasAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens + convertTargetBuildDepends :: TargetBuildDepends Mod.HasAnn -> TargetBuildDepends Mod.HasNoAnn From 052c9b490c2536e2120aff5e2cdc5d4211383c83 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 10:27:47 +0200 Subject: [PATCH 017/111] implement field grammar fully generically --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 1 + .../src/Distribution/FieldGrammar/Class.hs | 1 + .../PackageDescription/FieldGrammar.hs | 16 ++++++++++++++++ 3 files changed, 18 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index 78739a37cfa..163a2d8641e 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -6,6 +6,7 @@ module Distribution.FieldGrammar ( -- * Field grammar type FieldGrammar (..) + , Annotate , uniqueField , optionalField , optionalFieldDef diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 3f2e719a9c5..d239006689a 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -10,6 +10,7 @@ module Distribution.FieldGrammar.Class ( FieldGrammar (..) + , Annotate , uniqueField , optionalField , optionalFieldDef diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 03435682689..c29fbe31bf1 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -750,6 +750,22 @@ miniBuildInfoFieldGrammarTypeApp = MiniBuildInfo <$> monoidalFieldAlaAnnTypeApp @_ @_ @Mod.HasAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens +miniBuildInfoFieldGrammarTypeApp' + :: forall mod c g + . ( FieldGrammar c g + + -- NOTE(leana8959): this exists due to two different type class used to describe "with position" + -- Could be simplified + , TargetBuildDepends mod ~ Annotate mod [DependencyWith mod] + + , Applicative (g (MiniBuildInfo mod)) + , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + ) + => g (MiniBuildInfo mod) (MiniBuildInfo mod) +miniBuildInfoFieldGrammarTypeApp' = + MiniBuildInfo <$> + monoidalFieldAlaAnnTypeApp @_ @_ @mod "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens + convertTargetBuildDepends :: TargetBuildDepends Mod.HasAnn -> TargetBuildDepends Mod.HasNoAnn From 791c661072161d2da7b7480950362848abf47c76 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 11:09:48 +0200 Subject: [PATCH 018/111] Split out Annotate type family --- .../src/Distribution/FieldGrammar/Newtypes.hs | 13 +++++-------- Cabal-syntax/src/Distribution/Types/Modify.hs | 10 ++++++++++ Cabal-syntax/src/Distribution/Types/PackageName.hs | 8 ++------ .../src/Distribution/Types/VersionRange/Internal.hs | 3 ++- 4 files changed, 19 insertions(+), 15 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 8c324ffc67c..dfd4551b3fb 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -70,6 +70,7 @@ import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty import Distribution.Trivia +import Distribution.Types.Modify (Annotate) import qualified Distribution.Types.Modify as Mod import Distribution.Utils.Path import Distribution.Version @@ -118,17 +119,13 @@ data NoCommaFSep = NoCommaFSep data NoCommaFSepAnn = NoCommaFSepAnn -type family Modify (mod :: Mod.HasAnnotation) (a :: Type) where - Modify Mod.HasNoAnn a = a - Modify Mod.HasAnn a = Ann SurroundingText a - -- TODO(leana8959): Relax Sep to return a list of annotated docs with position -- Use the position propagated back from applyTriviaDoc class Sep (mod :: Mod.HasAnnotation) sep | sep -> mod where - prettySep :: Proxy sep -> [Modify mod Doc] -> Doc + prettySep :: Proxy sep -> [Annotate mod Doc] -> Doc - parseSep :: CabalParsing m => Proxy sep -> m a -> m [Modify mod a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty (Modify mod a)) + parseSep :: CabalParsing m => Proxy sep -> m a -> m [Annotate mod a] + parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty (Annotate mod a)) instance Sep Mod.HasNoAnn CommaVCat where prettySep _ = vcat . punctuate comma @@ -230,7 +227,7 @@ instance Sep Mod.HasAnn NoCommaFSepAnn where -- | List separated with optional commas. Displayed with @sep@, arguments of -- type @a@ are parsed and pretty-printed as @b@. -newtype ListWith mod sep b a = List {_getList :: [Modify mod a]} +newtype ListWith mod sep b a = List {_getList :: [Annotate mod a]} type List = ListWith Mod.HasNoAnn type ListAnn = ListWith Mod.HasAnn diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 0ce1c2dec7e..0c2eb36e557 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -1,13 +1,23 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} -- | -- Types that can be used as modifiers module Distribution.Types.Modify where +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 Annotate (m :: HasAnnotation) (a :: Type) where + Annotate HasNoAnn a = a + Annotate HasAnn a = Ann SurroundingText a diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index c1c2b9ef970..e580bb07b93 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -28,6 +28,7 @@ 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. @@ -39,14 +40,9 @@ import qualified Distribution.Types.Modify as Mod -- -- @since 2.0.0.2 type PackageName = PackageNameWith Mod.HasNoAnn - type PackageNameAnn = PackageNameWith Mod.HasAnn -type family ModifyPackageName (m :: Mod.HasAnnotation) (a :: Type) where - ModifyPackageName Mod.HasNoAnn a = a - ModifyPackageName Mod.HasAnn a = Ann SurroundingText a - -newtype PackageNameWith (m :: Mod.HasAnnotation) = PackageName (ModifyPackageName m ShortText) +newtype PackageNameWith (m :: Mod.HasAnnotation) = PackageName (Annotate m ShortText) deriving (Generic) deriving instance Show PackageName diff --git a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs index e9506ed57f0..a381d250946 100644 --- a/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs +++ b/Cabal-syntax/src/Distribution/Types/VersionRange/Internal.hs @@ -70,10 +70,11 @@ 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 VersionRangeAnn = (Trivia SurroundingText, VersionRangeAnn) + Modify Mod.HasAnn (VersionRangeWith Mod.HasAnn) = (Trivia SurroundingText, VersionRangeWith Mod.HasAnn) data VersionRangeWith (m :: Mod.HasAnnotation) = ThisVersion (Modify m Version) -- = version From dd018b11954042fb6fb14bd7a40b95a78cd0187e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 11:14:23 +0200 Subject: [PATCH 019/111] move AttachPos type family --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 1 - Cabal-syntax/src/Distribution/FieldGrammar/Class.hs | 10 +++------- .../Distribution/PackageDescription/FieldGrammar.hs | 3 ++- Cabal-syntax/src/Distribution/Types/Modify.hs | 4 ++++ 4 files changed, 9 insertions(+), 9 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index 163a2d8641e..78739a37cfa 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -6,7 +6,6 @@ module Distribution.FieldGrammar ( -- * Field grammar type FieldGrammar (..) - , Annotate , uniqueField , optionalField , optionalFieldDef diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index d239006689a..9afd04552c0 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -10,7 +10,6 @@ module Distribution.FieldGrammar.Class ( FieldGrammar (..) - , Annotate , uniqueField , optionalField , optionalFieldDef @@ -31,12 +30,9 @@ import Distribution.Fields.Field import Distribution.Utils.ShortText import Data.Kind +import Distribution.Types.Modify (AttachPos) import qualified Distribution.Types.Modify as Mod -type family Annotate (m :: Mod.HasAnnotation) (a :: Type) where - Annotate Mod.HasAnn a = [(Positions, a)] - Annotate Mod.HasNoAnn a = a - -- | 'FieldGrammar' is parametrised by -- -- * @s@ which is a structure we are parsing. We need this to provide prettyprinter @@ -174,9 +170,9 @@ class -- ^ field name -> (a -> b) -- ^ 'pack' - -> ALens' s (Annotate m a) + -> ALens' s (AttachPos m a) -- ^ lens into the field - -> g s (Annotate m a) + -> g s (AttachPos m a) -- | Parser matching all fields with a name starting with a prefix. prefixedFields diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index c29fbe31bf1..8e5abc55e3d 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -92,6 +92,7 @@ import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) import Distribution.Trivia (Positions (..)) +import Distribution.Types.Modify (AttachPos) import qualified Distribution.Types.Modify as Mod import qualified Data.ByteString.Char8 as BS8 @@ -756,7 +757,7 @@ miniBuildInfoFieldGrammarTypeApp' -- NOTE(leana8959): this exists due to two different type class used to describe "with position" -- Could be simplified - , TargetBuildDepends mod ~ Annotate mod [DependencyWith mod] + , TargetBuildDepends mod ~ AttachPos mod [DependencyWith mod] , Applicative (g (MiniBuildInfo mod)) , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 0c2eb36e557..0ee0c7c6763 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -21,3 +21,7 @@ data HasAnnotation type family Annotate (m :: HasAnnotation) (a :: Type) where Annotate HasNoAnn a = a Annotate HasAnn a = Ann SurroundingText a + +type family AttachPos (m :: HasAnnotation) (a :: Type) where + AttachPos HasAnn a = [(Positions, a)] + AttachPos HasNoAnn a = a From 0f3bcd7f77270b3e122dfca12861fbf1633b27ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 11:27:54 +0200 Subject: [PATCH 020/111] remove TargetBuildDepends type family --- .../PackageDescription/FieldGrammar.hs | 16 ++++++++-------- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 10 +++++----- .../src/Distribution/Types/BuildInfo/Lens.hs | 3 ++- 3 files changed, 15 insertions(+), 14 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 8e5abc55e3d..d35b2b61db8 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -180,7 +180,7 @@ libraryFieldGrammar , Applicative (g (LibraryWith mod)) , Applicative (g (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , TargetBuildDepends mod ~ [DependencyWith mod] + , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -601,7 +601,7 @@ buildInfoFieldGrammar -- so we leave it for later and ponder on it. -- -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. - , TargetBuildDepends mod ~ [DependencyWith mod] + , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) @@ -709,13 +709,13 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo - { miniTargetBuildDepends :: TargetBuildDepends m + { miniTargetBuildDepends :: AttachPos m [DependencyWith m] } miniTargetBuildDependsLens :: forall mod f . Functor f - => (TargetBuildDepends mod -> f (TargetBuildDepends mod)) + => (AttachPos mod [DependencyWith mod] -> f (AttachPos mod [DependencyWith mod])) -> (MiniBuildInfo mod) -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) @@ -726,7 +726,7 @@ onlyBuildDependsPos , Applicative (g (BuildInfoWith Mod.HasAnn)) , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) ) - => g (TargetBuildDepends Mod.HasAnn) (TargetBuildDepends Mod.HasAnn) + => g (AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn]) (AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn]) onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) id miniBuildInfoFieldGrammarAnn @@ -757,7 +757,7 @@ miniBuildInfoFieldGrammarTypeApp' -- NOTE(leana8959): this exists due to two different type class used to describe "with position" -- Could be simplified - , TargetBuildDepends mod ~ AttachPos mod [DependencyWith mod] + , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] , Applicative (g (MiniBuildInfo mod)) , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) @@ -768,8 +768,8 @@ miniBuildInfoFieldGrammarTypeApp' = monoidalFieldAlaAnnTypeApp @_ @_ @mod "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens convertTargetBuildDepends - :: TargetBuildDepends Mod.HasAnn - -> TargetBuildDepends Mod.HasNoAnn + :: AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn] + -> AttachPos Mod.HasNoAnn [DependencyWith Mod.HasNoAnn] convertTargetBuildDepends = join . map (map unannotateDependencyAnn . snd) unannotateMiniBuildInfo diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 4b3c98a5889..2b4f75b940e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -11,7 +11,6 @@ module Distribution.Types.BuildInfo ( BuildInfo , BuildInfoAnn , BuildInfoWith (..) - , TargetBuildDepends , unannotateDependencyAnn , emptyBuildInfo , allLanguages @@ -42,14 +41,15 @@ import Language.Haskell.Extension import Data.Kind +import Distribution.Types.Modify (AttachPos) 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] +-- 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 BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo @@ -163,7 +163,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: TargetBuildDepends m + , targetBuildDepends :: AttachPos m ([DependencyWith m]) -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 1974b821ae3..5b8dffa45a9 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -37,6 +37,7 @@ import Distribution.Utils.Path import Language.Haskell.Extension (Extension, Language) import qualified Distribution.Types.BuildInfo as T +import Distribution.Types.Modify (AttachPos) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn @@ -183,7 +184,7 @@ class HasBuildInfoWith mod a | a -> mod where customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] customFieldsBI = buildInfo @mod . customFieldsBI @mod - targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (T.TargetBuildDepends mod) + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod [DependencyWith mod]) targetBuildDepends = buildInfo @mod . targetBuildDepends @mod mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] From d3a60082914ae98b0d1c39e45c685afe85db8381 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 11:48:00 +0200 Subject: [PATCH 021/111] rewrite with proxy --- Cabal-syntax/src/Distribution/FieldGrammar/Class.hs | 5 +++-- .../src/Distribution/PackageDescription/FieldGrammar.hs | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 9afd04552c0..f74f72c38ff 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -163,10 +163,11 @@ class -- ^ lens into the field -> g s [(Positions, a)] - monoidalFieldAlaAnnTypeApp + monoidalFieldAlaAnnProxy :: forall (m :: Mod.HasAnnotation) b s a . (c b, Newtype a b) - => FieldName + => Proxy m + -> FieldName -- ^ field name -> (a -> b) -- ^ 'pack' diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index d35b2b61db8..4fdaf2ab88e 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -749,7 +749,7 @@ miniBuildInfoFieldGrammarTypeApp => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) miniBuildInfoFieldGrammarTypeApp = MiniBuildInfo <$> - monoidalFieldAlaAnnTypeApp @_ @_ @Mod.HasAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens + monoidalFieldAlaAnnProxy (Proxy :: Proxy Mod.HasAnn) "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens miniBuildInfoFieldGrammarTypeApp' :: forall mod c g @@ -765,7 +765,7 @@ miniBuildInfoFieldGrammarTypeApp' => g (MiniBuildInfo mod) (MiniBuildInfo mod) miniBuildInfoFieldGrammarTypeApp' = MiniBuildInfo <$> - monoidalFieldAlaAnnTypeApp @_ @_ @mod "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens + monoidalFieldAlaAnnProxy (Proxy :: Proxy mod) "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens convertTargetBuildDepends :: AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn] From 9b22d857ecd0e9dc020b43a35f57490388d3a236 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 12:25:04 +0200 Subject: [PATCH 022/111] introduce one more type argument in Field Grammar --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 10 +- .../src/Distribution/FieldGrammar/Class.hs | 78 ++++---- .../Distribution/FieldGrammar/FieldDescrs.hs | 18 +- .../src/Distribution/FieldGrammar/Parsec.hs | 80 ++++---- .../src/Distribution/FieldGrammar/Pretty.hs | 17 +- .../PackageDescription/FieldGrammar.hs | 185 ++++++++---------- .../PackageDescription/PrettyPrint.hs | 10 +- .../InstalledPackageInfo/FieldGrammar.hs | 19 +- 8 files changed, 205 insertions(+), 212 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index 78739a37cfa..3ae9a435f2f 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -1,11 +1,13 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module provides a way to specify a grammar of @.cabal@ -like files. module Distribution.FieldGrammar ( -- * Field grammar type - FieldGrammar (..) + FieldGrammar + , FieldGrammarWith (..) , uniqueField , optionalField , optionalFieldDef @@ -47,8 +49,10 @@ 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 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 f74f72c38ff..091f00b8feb 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} @@ -9,7 +10,8 @@ {-# LANGUAGE UndecidableSuperClasses #-} module Distribution.FieldGrammar.Class - ( FieldGrammar (..) + ( FieldGrammar + , FieldGrammarWith (..) , uniqueField , optionalField , optionalFieldDef @@ -33,6 +35,8 @@ import Data.Kind import Distribution.Types.Modify (AttachPos) 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 @@ -49,17 +53,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 - - -- NOTE(leana8959): this is not what I wanted - -- This allows turning a printer with annotation to one without annotation, - -- but would mean that we insert dummy annotations and it's up to the Pretty instances to figure that out. - -- Very not ideal. - contramapFieldGrammar :: (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 @@ -70,7 +68,7 @@ class -- ^ 'Newtype' pack -> ALens' s a -- ^ lens into the field - -> g s a + -> g m s a -- | Boolean field with a default value. booleanFieldDef @@ -80,7 +78,7 @@ class -- ^ lens into the field -> Bool -- ^ default - -> g s Bool + -> g m s Bool -- | Optional field. optionalFieldAla @@ -91,7 +89,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 @@ -104,7 +102,7 @@ class -- ^ @'Lens'' s a@: lens into the field -> a -- ^ default value - -> g s a + -> g m s a -- | Free text field is essentially 'optionalFieldDefAla` with @""@ -- as the default and "accept everything" parser. @@ -114,7 +112,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. @@ -124,14 +122,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. -- @@ -146,7 +144,7 @@ class -- ^ 'pack' -> ALens' s a -- ^ lens into the field - -> g s a + -> g m s a -- | Monoidal field. -- @@ -161,7 +159,7 @@ class -- ^ 'pack' -> ALens' s [(Positions, a)] -- ^ lens into the field - -> g s [(Positions, a)] + -> g m s [(Positions, a)] monoidalFieldAlaAnnProxy :: forall (m :: Mod.HasAnnotation) b s a @@ -173,7 +171,7 @@ class -- ^ 'pack' -> ALens' s (AttachPos m a) -- ^ lens into the field - -> g s (AttachPos m a) + -> g m s (AttachPos m a) -- | Parser matching all fields with a name starting with a prefix. prefixedFields @@ -181,13 +179,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 @@ -195,8 +193,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 @@ -204,8 +202,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 @@ -213,8 +211,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. @@ -226,59 +224,59 @@ 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. 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..bf010b483bd 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} @@ -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/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 128102b0737..5e0948b3f27 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -95,6 +97,8 @@ import Distribution.Trivia import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) +import qualified Distribution.Types.Modify as Mod + ------------------------------------------------------------------------------- -- Auxiliary types ------------------------------------------------------------------------------- @@ -116,14 +120,14 @@ 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) } deriving (Functor) -parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar s a -> ParseResult src a +parseFieldGrammar :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar m s a -> ParseResult src a parseFieldGrammar v fields grammar = do for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) -> for_ nfields $ \(MkNamelessField pos _) -> @@ -133,14 +137,14 @@ parseFieldGrammar v fields grammar = do -- parse fieldGrammarParser grammar v 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 :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar m s a -> Set BS.ByteString -> ParseResult src a parseFieldGrammarCheckingStanzas v fields grammar sections = do for_ (Map.toList (Map.filterWithKey (isUnknownField grammar) fields)) $ \(name, nfields) -> for_ nfields $ \(MkNamelessField pos _) -> @@ -149,10 +153,10 @@ parseFieldGrammarCheckingStanzas v fields grammar sections = do else parseWarning pos PWTUnknownField $ "Unknown field: " ++ show name fieldGrammarParser grammar v fields -fieldGrammarKnownFieldList :: ParsecFieldGrammar s a -> [FieldName] +fieldGrammarKnownFieldList :: ParsecFieldGrammar m s a -> [FieldName] fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields -instance Applicative (ParsecFieldGrammar s) where +instance Applicative (ParsecFieldGrammar m s) where pure x = ParsecFG mempty mempty (\_ _ -> pure x) {-# INLINE pure #-} @@ -171,11 +175,9 @@ 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 - contramapFieldGrammar _ (ParsecFG fs prefs p) = ParsecFG fs prefs p - uniqueFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser v fields = case Map.lookup fn fields of @@ -278,12 +280,12 @@ instance FieldGrammar Parsec ParsecFieldGrammar where | otherwise -> pure (ShortText.toShortText $ fieldlinesToFreeText fls) monoidalFieldAla - :: forall b a s + :: forall m b a s . (Parsec b, Monoid a, Newtype a b) => FieldName -> (a -> b) -> ALens' s a - -> ParsecFieldGrammar s a + -> ParsecFieldGrammar m s a monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser :: CabalSpecVersion -> Fields Position -> ParseResult src a @@ -294,31 +296,6 @@ instance FieldGrammar Parsec ParsecFieldGrammar where parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src b parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls - -- TODO(leana8959): maybe define monoidalFieldAla base on monoidalFieldAlaAnn - -- - -- 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 - monoidalFieldAlaAnn - :: forall b a s - . (Parsec b, Newtype a b) - => FieldName - -> (a -> b) - -> ALens' s [(Positions, a)] - -> ParsecFieldGrammar s [(Positions, a)] - monoidalFieldAlaAnn fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] - parser v fields = case Map.lookup fn fields of - Nothing -> pure mempty - Just xs -> map (\(p, a) -> (p,) $ unpack' _pack a) <$> traverse (parseOne v) xs - - parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) - parseOne v (MkNamelessField pos fls) = do - (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls - pure (Positions (Just pos) (error "convert linePos" linePos) Nothing, x) prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) where @@ -400,6 +377,37 @@ instance FieldGrammar Parsec ParsecFieldGrammar where hiddenField = id +instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where + -- TODO(leana8959): implement monoidalFieldAla + -- TODO(leana8959): implement all methods + + + -- -- TODO(leana8959): maybe define monoidalFieldAla base on monoidalFieldAlaAnn + -- -- + -- -- 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 m b a s + -- . (Parsec b, Newtype a b) + -- => FieldName + -- -> (a -> b) + -- -> ALens' s [(Positions, a)] + -- -> ParsecFieldGrammar m s [(Positions, a)] + -- monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser + -- where + -- parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] + -- parser v fields = case Map.lookup fn fields of + -- Nothing -> pure mempty + -- Just xs -> map (\(p, a) -> (p,) $ unpack' _pack a) <$> traverse (parseOne v) xs + -- + -- parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) + -- parseOne v (MkNamelessField pos fls) = do + -- (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls + -- pure (Positions (Just pos) (error "convert linePos" linePos) Nothing, x) + ------------------------------------------------------------------------------- -- Parsec ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 7a1899c322d..14ed6fbb6d9 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -22,28 +24,27 @@ import qualified Text.PrettyPrint as PP import Prelude () import Distribution.FieldGrammar.Class +import qualified Distribution.Types.Modify as Mod -- TODO(leana8959): maybe we can compare this to [Field Position] and thus form a roundtrip test. -newtype PrettyFieldGrammar s a = PrettyFG +newtype PrettyFieldGrammar (m :: Mod.HasAnnotation) s a = PrettyFG { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()] } deriving (Functor) -instance Applicative (PrettyFieldGrammar s) where +instance Applicative (PrettyFieldGrammar m 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 :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> [PrettyField ()] prettyFieldGrammar = flip fieldGrammarPretty -instance FieldGrammar Pretty PrettyFieldGrammar where +instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) - contramapFieldGrammar f (PrettyFG pp) = PrettyFG $ \v -> pp v . f - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> ppField fn (pretty (pack' _pack (aview l s))) @@ -94,12 +95,12 @@ instance FieldGrammar Pretty PrettyFieldGrammar where -- TODO(leana8959): push out the Position monoidalFieldAlaAnn - :: forall b a s + :: forall m b a s . (Pretty b, Newtype a b) => FieldName -> (a -> b) -> ALens' s [(Positions, a)] - -> PrettyFieldGrammar s [(Positions, a)] + -> PrettyFieldGrammar m s [(Positions, a)] monoidalFieldAlaAnn fn _pack l = PrettyFG pp where pp v s = diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 4fdaf2ab88e..8a5fc07a417 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -106,8 +106,8 @@ import qualified Distribution.Types.Lens as L packageDescriptionFieldGrammar :: ( FieldGrammar c g - , Applicative (g PackageDescription) - , Applicative (g PackageIdentifier) + , Applicative (g Mod.HasNoAnn PackageDescription) + , Applicative (g Mod.HasNoAnn PackageIdentifier) , c (Identity BuildType) , c (Identity PackageName) , c (Identity Version) @@ -117,7 +117,7 @@ packageDescriptionFieldGrammar , c CompatLicenseFile , c CompatDataDir ) - => g PackageDescription PackageDescription + => g Mod.HasNoAnn PackageDescription PackageDescription packageDescriptionFieldGrammar = PackageDescription <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 @@ -176,9 +176,9 @@ packageDescriptionFieldGrammar = libraryFieldGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (LibraryWith mod)) - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (LibraryWith mod)) + , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] , c (Identity LibraryVisibility) @@ -200,7 +200,7 @@ libraryFieldGrammar , c (MQuoted Language) ) => LibraryName - -> g (LibraryWith mod) (LibraryWith mod) + -> g mod (LibraryWith mod) (LibraryWith mod) libraryFieldGrammar n = Library n <$> monoidalFieldAla "exposed-modules" formatExposedModules L.exposedModules @@ -227,8 +227,8 @@ libraryFieldGrammar n = foreignLibFieldGrammar :: ( FieldGrammar c g - , Applicative (g ForeignLib) - , Applicative (g BuildInfo) + , Applicative (g Mod.HasNoAnn ForeignLib) + , Applicative (g Mod.HasNoAnn BuildInfo) , c (Identity ForeignLibType) , c (Identity LibVersionInfo) , c (Identity Version) @@ -250,7 +250,7 @@ foreignLibFieldGrammar , c (MQuoted Language) ) => UnqualComponentName - -> g ForeignLib ForeignLib + -> g Mod.HasNoAnn ForeignLib ForeignLib foreignLibFieldGrammar n = ForeignLib n <$> optionalFieldDef "type" L.foreignLibType ForeignLibTypeUnknown @@ -268,8 +268,8 @@ foreignLibFieldGrammar n = executableFieldGrammar :: ( FieldGrammar c g - , Applicative (g Executable) - , Applicative (g BuildInfo) + , Applicative (g Mod.HasNoAnn Executable) + , Applicative (g Mod.HasNoAnn BuildInfo) , c (Identity ExecutableScope) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -292,7 +292,7 @@ executableFieldGrammar , c (MQuoted Language) ) => UnqualComponentName - -> g Executable Executable + -> g Mod.HasNoAnn Executable Executable executableFieldGrammar n = Executable n -- main-is is optional as conditional blocks don't have it @@ -342,8 +342,8 @@ testStanzaCodeGenerators f s = fmap (\x -> s{_testStanzaCodeGenerators = x}) (f testSuiteFieldGrammar :: ( FieldGrammar c g - , Applicative (g TestSuiteStanza) - , Applicative (g BuildInfo) + , Applicative (g Mod.HasNoAnn TestSuiteStanza) + , Applicative (g Mod.HasNoAnn BuildInfo) , c (Identity ModuleName) , c (Identity TestType) , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -364,7 +364,7 @@ testSuiteFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g TestSuiteStanza TestSuiteStanza + => g Mod.HasNoAnn TestSuiteStanza TestSuiteStanza testSuiteFieldGrammar = TestSuiteStanza <$> optionalField "type" testStanzaTestType @@ -487,8 +487,8 @@ benchmarkStanzaBuildInfo f s = fmap (\x -> s{_benchmarkStanzaBuildInfo = x}) (f benchmarkFieldGrammar :: ( FieldGrammar c g - , Applicative (g BenchmarkStanza) - , Applicative (g BuildInfo) + , Applicative (g Mod.HasNoAnn BenchmarkStanza) + , Applicative (g Mod.HasNoAnn BuildInfo) , c (Identity BenchmarkType) , c (Identity ModuleName) , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -508,7 +508,7 @@ benchmarkFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g BenchmarkStanza BenchmarkStanza + => g Mod.HasNoAnn BenchmarkStanza BenchmarkStanza benchmarkFieldGrammar = BenchmarkStanza <$> optionalField "type" benchmarkStanzaBenchmarkType @@ -592,8 +592,8 @@ unvalidateBenchmark b = buildInfoFieldGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) -- NOTE(leana8959): This constraint is here for the time being to parse legacy BuildInfo without Annotation. -- To make this fully polymorphic (and lift this constraint), we need to choose between monoidalFieldAla and monoidalFieldAlaAnn using the type. @@ -618,7 +618,7 @@ buildInfoFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g (BuildInfoWith mod) (BuildInfoWith mod) + => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar = BuildInfo <$> booleanFieldDef "buildable" L.buildable True @@ -720,52 +720,32 @@ miniTargetBuildDependsLens -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) -onlyBuildDependsPos - :: forall c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith Mod.HasAnn)) - , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) - ) - => g (AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn]) (AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn]) -onlyBuildDependsPos = monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) id - -miniBuildInfoFieldGrammarAnn - :: forall c g - . ( FieldGrammar c g - , Applicative (g (MiniBuildInfo Mod.HasAnn)) - , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) - ) - => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) -miniBuildInfoFieldGrammarAnn = - MiniBuildInfo <$> - monoidalFieldAlaAnn "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens - -miniBuildInfoFieldGrammarTypeApp - :: forall c g - . ( FieldGrammar c g - , Applicative (g (MiniBuildInfo Mod.HasAnn)) - , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) - ) - => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) -miniBuildInfoFieldGrammarTypeApp = - MiniBuildInfo <$> - monoidalFieldAlaAnnProxy (Proxy :: Proxy Mod.HasAnn) "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens - -miniBuildInfoFieldGrammarTypeApp' - :: forall mod c g - . ( FieldGrammar c g - - -- NOTE(leana8959): this exists due to two different type class used to describe "with position" - -- Could be simplified - , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] - - , Applicative (g (MiniBuildInfo mod)) - , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - ) - => g (MiniBuildInfo mod) (MiniBuildInfo mod) -miniBuildInfoFieldGrammarTypeApp' = - MiniBuildInfo <$> - monoidalFieldAlaAnnProxy (Proxy :: Proxy mod) "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens +-- miniBuildInfoFieldGrammarTypeApp +-- :: forall c g +-- . ( FieldGrammar Mod.HasAnn c g +-- , Applicative (g Mod.HasAnn (MiniBuildInfo Mod.HasAnn)) +-- , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) +-- ) +-- => g Mod.HasAnn (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) +-- miniBuildInfoFieldGrammarTypeApp = +-- MiniBuildInfo <$> +-- monoidalFieldAlaAnnProxy (Proxy :: Proxy Mod.HasAnn) "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens + +-- miniBuildInfoFieldGrammarTypeApp' +-- :: forall mod c g +-- . ( FieldGrammar c g +-- +-- -- NOTE(leana8959): this exists due to two different type class used to describe "with position" +-- -- Could be simplified +-- , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] +-- +-- , Applicative (g mod (MiniBuildInfo mod)) +-- , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) +-- ) +-- => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) +-- miniBuildInfoFieldGrammarTypeApp' = +-- MiniBuildInfo <$> +-- monoidalFieldAlaAnnProxy (Proxy :: Proxy mod) "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens convertTargetBuildDepends :: AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn] @@ -777,23 +757,14 @@ unannotateMiniBuildInfo -> MiniBuildInfo Mod.HasNoAnn unannotateMiniBuildInfo (MiniBuildInfo x) = MiniBuildInfo (convertTargetBuildDepends x) -miniBuildInfoFieldGrammarAnn' - :: forall c g - . ( FieldGrammar c g - , Applicative (g (MiniBuildInfo Mod.HasAnn)) - , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) - ) - => g (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasNoAnn) -miniBuildInfoFieldGrammarAnn' = fmap unannotateMiniBuildInfo miniBuildInfoFieldGrammarAnn - hsSourceDirsGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to)) ) - => g (BuildInfoWith mod) [SymbolicPath Pkg (Dir Source)] + => g mod (BuildInfoWith mod) [SymbolicPath Pkg (Dir Source)] hsSourceDirsGrammar = (++) <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs @@ -808,12 +779,12 @@ hsSourceDirsGrammar = optionsFieldGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) , c (List NoCommaFSep Token' String) , L.HasBuildInfoWith mod (BuildInfoWith mod) ) - => g (BuildInfoWith mod) (PerCompilerFlavor [String]) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) optionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -831,12 +802,12 @@ optionsFieldGrammar = profOptionsFieldGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) , c (List NoCommaFSep Token' String) , L.HasBuildInfoWith mod (BuildInfoWith mod) ) - => g (BuildInfoWith mod) (PerCompilerFlavor [String]) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) profOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-prof-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -848,12 +819,12 @@ profOptionsFieldGrammar = sharedOptionsFieldGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) , c (List NoCommaFSep Token' String) , L.HasBuildInfoWith mod (BuildInfoWith mod) ) - => g (BuildInfoWith mod) (PerCompilerFlavor [String]) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) sharedOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-shared-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -863,12 +834,12 @@ sharedOptionsFieldGrammar = profSharedOptionsFieldGrammar :: forall mod c g - . ( FieldGrammar c g - , Applicative (g (BuildInfoWith mod)) + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) , c (List NoCommaFSep Token' String) , L.HasBuildInfoWith mod (BuildInfoWith mod) ) - => g (BuildInfoWith mod) (PerCompilerFlavor [String]) + => g mod (BuildInfoWith mod) (PerCompilerFlavor [String]) profSharedOptionsFieldGrammar = PerCompilerFlavor <$> monoidalFieldAla "ghc-prof-shared-options" (alaList' NoCommaFSep Token') (extract GHC) @@ -889,25 +860,25 @@ 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 @@ -916,22 +887,22 @@ 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'. @@ -1025,9 +996,9 @@ _syntaxFieldNames = , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" , fieldGrammarKnownFieldList testSuiteFieldGrammar , fieldGrammarKnownFieldList benchmarkFieldGrammar - , fieldGrammarKnownFieldList $ flagFieldGrammar (error "flagname") - , fieldGrammarKnownFieldList $ sourceRepoFieldGrammar (error "repokind") - , fieldGrammarKnownFieldList $ setupBInfoFieldGrammar True + , 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/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index dbd872d2823..44aa9ef9f09 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- @@ -62,6 +64,8 @@ import Text.PrettyPrint (Doc, char, hsep, parens, text) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Types.Modify as Mod + -- | Writes a .cabal file from a generic package description writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) @@ -100,7 +104,7 @@ ppSourceRepos = map . ppSourceRepo ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () ppSourceRepo v repo = PrettySection () "source-repository" [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar kind) repo + prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasNoAnn kind) repo where kind = repoKind repo @@ -111,7 +115,7 @@ ppSetupBInfo v (Just sbi) | otherwise = pure $ PrettySection () "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar False) sbi + prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasNoAnn False) sbi ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] ppGenPackageFlags = map . ppFlag @@ -119,7 +123,7 @@ ppGenPackageFlags = map . ppFlag ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection () "flag" [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar name) flag + prettyFieldGrammar v (flagFieldGrammar @Mod.HasNoAnn name) flag ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar s -> [PrettyField ()] ppCondTree2 v grammar = go 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) From e224ce955e9e8485165e36c7e328b73277ce5175 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 14:36:01 +0200 Subject: [PATCH 023/111] add a field to attepmt polymorphic monoidalFieldAla output --- .../src/Distribution/FieldGrammar/Class.hs | 17 +++++++++ .../src/Distribution/FieldGrammar/Parsec.hs | 2 +- .../src/Distribution/FieldGrammar/Pretty.hs | 38 +++++++++---------- 3 files changed, 37 insertions(+), 20 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 091f00b8feb..a119065723e 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} @@ -146,6 +147,22 @@ class -- ^ lens into the field -> 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 (AttachPos m a) + -- ^ lens into the field + -> g m s (AttachPos m a) + -- | Monoidal field. -- -- Values are combined with 'mappend'. diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 5e0948b3f27..5b4f6c59378 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -377,7 +377,7 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where hiddenField = id -instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where +-- instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -- TODO(leana8959): implement monoidalFieldAla -- TODO(leana8959): implement all methods diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 14ed6fbb6d9..fb1edcb8bd2 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -93,25 +93,25 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where where pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) - -- TODO(leana8959): push out the Position - monoidalFieldAlaAnn - :: forall m b a s - . (Pretty b, Newtype a b) - => FieldName - -> (a -> b) - -> ALens' s [(Positions, a)] - -> PrettyFieldGrammar m s [(Positions, a)] - monoidalFieldAlaAnn fn _pack l = PrettyFG pp - where - pp v s = - -- TODO(leana8959): implement more than one field printing - -- - -- Here the list represents the "groups" of fields that are defined separately but merged by - -- monoidal field. - -- - -- They should be displayed separately anyway. - let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) - in ppField fn mempty + -- -- TODO(leana8959): push out the Position + -- monoidalFieldAlaAnn + -- :: forall m b a s + -- . (Pretty b, Newtype a b) + -- => FieldName + -- -> (a -> b) + -- -> ALens' s [(Positions, a)] + -- -> PrettyFieldGrammar m s [(Positions, a)] + -- monoidalFieldAlaAnn fn _pack l = PrettyFG pp + -- where + -- pp v s = + -- -- TODO(leana8959): implement more than one field printing + -- -- + -- -- Here the list represents the "groups" of fields that are defined separately but merged by + -- -- monoidal field. + -- -- + -- -- They should be displayed separately anyway. + -- let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) + -- in ppField fn mempty prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) where From 004e9f81752b7181db2de809416266f3c40c320c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 14:57:39 +0200 Subject: [PATCH 024/111] reimplement minibuildinfo with generic monoidalFieldAla' --- .../PackageDescription/FieldGrammar.hs | 52 ++++++++----------- 1 file changed, 23 insertions(+), 29 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 8a5fc07a417..36d894c981e 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -709,43 +709,37 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo - { miniTargetBuildDepends :: AttachPos m [DependencyWith m] + { miniTargetBuildDependsPoly :: AttachPos m [DependencyWith m] + , miniTargetBuildDepends :: [DependencyWith m] } -miniTargetBuildDependsLens +miniTargetBuildDependsPolyLens :: forall mod f . Functor f => (AttachPos mod [DependencyWith mod] -> f (AttachPos mod [DependencyWith mod])) -> (MiniBuildInfo mod) -> f (MiniBuildInfo mod) +miniTargetBuildDependsPolyLens f s = fmap (\x -> s{miniTargetBuildDependsPoly = x}) (f (miniTargetBuildDependsPoly s)) + +miniTargetBuildDependsLens + :: forall mod f + . Functor f + => ([DependencyWith mod] -> f [DependencyWith mod]) + -> (MiniBuildInfo mod) + -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) --- miniBuildInfoFieldGrammarTypeApp --- :: forall c g --- . ( FieldGrammar Mod.HasAnn c g --- , Applicative (g Mod.HasAnn (MiniBuildInfo Mod.HasAnn)) --- , c (List CommaVCat (Identity (DependencyWith Mod.HasAnn)) (DependencyWith Mod.HasAnn)) --- ) --- => g Mod.HasAnn (MiniBuildInfo Mod.HasAnn) (MiniBuildInfo Mod.HasAnn) --- miniBuildInfoFieldGrammarTypeApp = --- MiniBuildInfo <$> --- monoidalFieldAlaAnnProxy (Proxy :: Proxy Mod.HasAnn) "build-depends" (formatDependencyList @Mod.HasAnn) miniTargetBuildDependsLens - --- miniBuildInfoFieldGrammarTypeApp' --- :: forall mod c g --- . ( FieldGrammar c g --- --- -- NOTE(leana8959): this exists due to two different type class used to describe "with position" --- -- Could be simplified --- , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] --- --- , Applicative (g mod (MiniBuildInfo mod)) --- , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) --- ) --- => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) --- miniBuildInfoFieldGrammarTypeApp' = --- MiniBuildInfo <$> --- monoidalFieldAlaAnnProxy (Proxy :: Proxy mod) "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens +miniBuildInfoFieldGrammarTypeApp' + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (MiniBuildInfo mod)) + , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + ) + => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) +miniBuildInfoFieldGrammarTypeApp' = + MiniBuildInfo + <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsPolyLens + <*> monoidalFieldAla "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens convertTargetBuildDepends :: AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn] @@ -755,7 +749,7 @@ convertTargetBuildDepends = join . map (map unannotateDependencyAnn . snd) unannotateMiniBuildInfo :: MiniBuildInfo Mod.HasAnn -> MiniBuildInfo Mod.HasNoAnn -unannotateMiniBuildInfo (MiniBuildInfo x) = MiniBuildInfo (convertTargetBuildDepends x) +unannotateMiniBuildInfo (MiniBuildInfo x y) = MiniBuildInfo (convertTargetBuildDepends x) (map unannotateDependencyAnn y) hsSourceDirsGrammar :: forall mod c g From 22fd1fdb1b0f10b500960d4425353f19f7bbe745 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 15:00:55 +0200 Subject: [PATCH 025/111] implement monoidalFieldAla' --- .../src/Distribution/FieldGrammar/Parsec.hs | 49 +++++++++---------- 1 file changed, 23 insertions(+), 26 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 5b4f6c59378..0fbb3e5cefc 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -377,36 +377,33 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where hiddenField = id --- instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where +instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -- TODO(leana8959): implement monoidalFieldAla -- TODO(leana8959): implement all methods - - -- -- TODO(leana8959): maybe define monoidalFieldAla base on monoidalFieldAlaAnn - -- -- - -- -- 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 m b a s - -- . (Parsec b, Newtype a b) - -- => FieldName - -- -> (a -> b) - -- -> ALens' s [(Positions, a)] - -- -> ParsecFieldGrammar m s [(Positions, a)] - -- monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser - -- where - -- parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] - -- parser v fields = case Map.lookup fn fields of - -- Nothing -> pure mempty - -- Just xs -> map (\(p, a) -> (p,) $ unpack' _pack a) <$> traverse (parseOne v) xs + -- This function allows us to manage the position coming from a parsed field + -- In the printer, it can... IDK? Annotate the pretty doc position? -- - -- parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) - -- parseOne v (MkNamelessField pos fls) = do - -- (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls - -- pure (Positions (Just pos) (error "convert linePos" linePos) Nothing, x) + -- - 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 -> Fields Position -> ParseResult src [(Positions, a)] + parser v fields = case Map.lookup fn fields of + Nothing -> pure mempty + Just xs -> map (\(p, a) -> (p,) $ unpack' _pack a) <$> traverse (parseOne v) xs + + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) + parseOne v (MkNamelessField pos fls) = do + (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls + pure (Positions (Just pos) (error "convert linePos" linePos) Nothing, x) ------------------------------------------------------------------------------- -- Parsec From 6ed8bff5b454c8a8f686fa0626408fc7da76ce78 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 15:09:23 +0200 Subject: [PATCH 026/111] export miniBuildInfoFieldGrammar for a demo --- .../PackageDescription/FieldGrammar.hs | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 36d894c981e..bee10a10fa5 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -71,6 +71,9 @@ module Distribution.PackageDescription.FieldGrammar -- * Component build info , buildInfoFieldGrammar + + , MiniBuildInfo (..) + , miniBuildInfoFieldGrammar ) where import Distribution.Compat.Lens @@ -90,7 +93,6 @@ import Distribution.Parsec import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) -import Distribution.Trivia (Positions (..)) import Distribution.Types.Modify (AttachPos) import qualified Distribution.Types.Modify as Mod @@ -729,28 +731,18 @@ miniTargetBuildDependsLens -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) -miniBuildInfoFieldGrammarTypeApp' +miniBuildInfoFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g , Applicative (g mod (MiniBuildInfo mod)) , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) -miniBuildInfoFieldGrammarTypeApp' = +miniBuildInfoFieldGrammar = MiniBuildInfo <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsPolyLens <*> monoidalFieldAla "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens -convertTargetBuildDepends - :: AttachPos Mod.HasAnn [DependencyWith Mod.HasAnn] - -> AttachPos Mod.HasNoAnn [DependencyWith Mod.HasNoAnn] -convertTargetBuildDepends = join . map (map unannotateDependencyAnn . snd) - -unannotateMiniBuildInfo - :: MiniBuildInfo Mod.HasAnn - -> MiniBuildInfo Mod.HasNoAnn -unannotateMiniBuildInfo (MiniBuildInfo x y) = MiniBuildInfo (convertTargetBuildDepends x) (map unannotateDependencyAnn y) - hsSourceDirsGrammar :: forall mod c g . ( FieldGrammarWith mod c g From 06ef2986c8c7594203f5cc625beb4130232f98ce Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 15:44:48 +0200 Subject: [PATCH 027/111] implement demo for miniBuildInfoDemo --- .../src/Distribution/FieldGrammar/Parsec.hs | 2 +- .../PackageDescription/FieldGrammar.hs | 20 ++++++------ Cabal-tests/Cabal-tests.cabal | 1 + Cabal-tests/tests/ParserTests.hs | 31 +++++++++++++++++-- .../tests/ParserTests/miniBuildInfoDemo.cabal | 7 +++++ 5 files changed, 49 insertions(+), 12 deletions(-) create mode 100644 Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 0fbb3e5cefc..a9b76a5a744 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -403,7 +403,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) parseOne v (MkNamelessField pos fls) = do (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls - pure (Positions (Just pos) (error "convert linePos" linePos) Nothing, x) + pure (Positions (Just pos) (Nothing {- TODO(leana8959): "convert linePos" linePos -}) Nothing, x) ------------------------------------------------------------------------------- -- Parsec diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index bee10a10fa5..dbb8eb4ce11 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TupleSections #-} @@ -712,9 +713,11 @@ buildInfoFieldGrammar = data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo { miniTargetBuildDependsPoly :: AttachPos m [DependencyWith m] - , miniTargetBuildDepends :: [DependencyWith m] + -- , miniTargetBuildDepends :: [DependencyWith m] } +deriving instance Show (MiniBuildInfo Mod.HasAnn) + miniTargetBuildDependsPolyLens :: forall mod f . Functor f @@ -723,13 +726,13 @@ miniTargetBuildDependsPolyLens -> f (MiniBuildInfo mod) miniTargetBuildDependsPolyLens f s = fmap (\x -> s{miniTargetBuildDependsPoly = x}) (f (miniTargetBuildDependsPoly s)) -miniTargetBuildDependsLens - :: forall mod f - . Functor f - => ([DependencyWith mod] -> f [DependencyWith mod]) - -> (MiniBuildInfo mod) - -> f (MiniBuildInfo mod) -miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) +-- miniTargetBuildDependsLens +-- :: forall mod f +-- . Functor f +-- => ([DependencyWith mod] -> f [DependencyWith mod]) +-- -> (MiniBuildInfo mod) +-- -> f (MiniBuildInfo mod) +-- miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) miniBuildInfoFieldGrammar :: forall mod c g @@ -741,7 +744,6 @@ miniBuildInfoFieldGrammar miniBuildInfoFieldGrammar = MiniBuildInfo <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsPolyLens - <*> monoidalFieldAla "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens hsSourceDirsGrammar :: forall mod c g 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/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index ca9aa3920bf..865aabcdb49 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -18,7 +20,7 @@ import Control.Monad (void) import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff) import Data.Maybe (isNothing) import Distribution.CabalSpecVersion -import Distribution.Fields (pwarning) +import Distribution.Fields (pwarning, readFields) import Distribution.PackageDescription ( GenericPackageDescription , packageDescription @@ -31,7 +33,7 @@ import Distribution.PackageDescription , condTestSuites , condBenchmarks ) -import Distribution.PackageDescription.FieldGrammar(buildInfoFieldGrammar) +import Distribution.PackageDescription.FieldGrammar(buildInfoFieldGrammar, miniBuildInfoFieldGrammar, MiniBuildInfo (..)) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, sectionizeFields, takeFields) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import Distribution.Parsec (Parsec (..), explicitEitherParsec', PWarnType (..), PWarning (..), showPErrorWithSource, showPWarningWithSource) @@ -65,6 +67,9 @@ 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 @@ -81,6 +86,7 @@ tests = testGroup "parsec tests" , errorTests , ipiTests , parsecPrettyTests + , miniBulidInfoDemoTest ] ------------------------------------------------------------------------------- @@ -250,6 +256,27 @@ parsecPrettyTests = testGroup "parsec pretty roundtrip" $ where optionals cond ifTrue = if cond then ifTrue else [] +miniBulidInfoDemoTest :: TestTree +miniBulidInfoDemoTest = testCase "miniBuildInfo" $ 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 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 diff --git a/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal b/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal new file mode 100644 index 00000000000..c40cffcd592 --- /dev/null +++ b/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal @@ -0,0 +1,7 @@ + + + +build-depends: + foo > 2, + bar > 3, + baz > 4, From 7779ce7b1340350cb8c5b2d6cb39a899399cb71c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 15:47:45 +0200 Subject: [PATCH 028/111] add note --- Cabal-syntax/src/Distribution/Trivia.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index 61de3587556..dd6cdb3412f 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -34,6 +34,8 @@ instance Semigroup SurroundingText where data Positions = Positions { fieldNamePos :: Maybe Position , fieldLinePos :: Maybe Position + -- TODO(leana8959): will need to be patched at goSection + -- field grammar don't see sections , fieldSectionPos :: Maybe Position } deriving (Show, Eq, Ord, Read, Data) From 8c0d1af7136d13da3a8def85980f3bd2e1bca0a5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 15:54:14 +0200 Subject: [PATCH 029/111] demonstrate that NoAnn works --- .../src/Distribution/FieldGrammar/Parsec.hs | 1 + .../PackageDescription/FieldGrammar.hs | 1 + Cabal-tests/tests/ParserTests.hs | 28 +++++++++++++++++-- 3 files changed, 27 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index a9b76a5a744..b93bfe0b511 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -296,6 +296,7 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src b parseOne v (MkNamelessField pos fls) = runFieldParser pos parsec v fls + monoidalFieldAla' = monoidalFieldAla prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) where diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index dbb8eb4ce11..ab321c9459a 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -717,6 +717,7 @@ data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo } deriving instance Show (MiniBuildInfo Mod.HasAnn) +deriving instance Show (MiniBuildInfo Mod.HasNoAnn) miniTargetBuildDependsPolyLens :: forall mod f diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 865aabcdb49..2481dd12079 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -86,7 +86,8 @@ tests = testGroup "parsec tests" , errorTests , ipiTests , parsecPrettyTests - , miniBulidInfoDemoTest + , miniBuildInfoAnnTest + , miniBuildInfoTest ] ------------------------------------------------------------------------------- @@ -256,8 +257,8 @@ parsecPrettyTests = testGroup "parsec pretty roundtrip" $ where optionals cond ifTrue = if cond then ifTrue else [] -miniBulidInfoDemoTest :: TestTree -miniBulidInfoDemoTest = testCase "miniBuildInfo" $ do +miniBuildInfoAnnTest :: TestTree +miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do fields <- readFields <$> BS.readFile input >>= \case Left err -> fail $ "readFields: err" Right ok -> pure ok @@ -277,6 +278,27 @@ miniBulidInfoDemoTest = testCase "miniBuildInfo" $ do where input = "tests" "ParserTests" "miniBuildInfoDemo.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 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 From ade8d0a68b9cfd99ab2d26503c4ff24ff468caee Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 17:55:50 +0200 Subject: [PATCH 030/111] implement buildable field in BuildInfo --- .../src/Distribution/FieldGrammar/Class.hs | 10 ++++++ .../src/Distribution/FieldGrammar/Parsec.hs | 32 +++++++++++++++++++ .../PackageDescription/FieldGrammar.hs | 25 ++++++++++----- 3 files changed, 59 insertions(+), 8 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index a119065723e..9fb778a958e 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -81,6 +81,16 @@ class -- ^ default -> g m s Bool + -- | Boolean field with a default value. + booleanFieldDef' + :: FieldName + -- ^ field name + -> ALens' s (AttachPos m Bool) + -- ^ lens into the field + -> Bool + -- ^ default + -> g m s (AttachPos m Bool) + -- | Optional field. optionalFieldAla :: (c b, Newtype a b) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index b93bfe0b511..dad3e2554c7 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -97,6 +97,7 @@ import Distribution.Trivia import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) +import Distribution.Types.Modify (AttachPos) import qualified Distribution.Types.Modify as Mod ------------------------------------------------------------------------------- @@ -379,6 +380,37 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where hiddenField = id instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where + + -- TODO(leana8959): remove multiplicity here because it doesn't have merging + + booleanFieldDef' + :: forall s + . FieldName + -- ^ field name + -> ALens' s [(Positions, Bool)] + -- ^ lens into the field + -> Bool + -- ^ default + -> ParsecFieldGrammar Mod.HasAnn s [(Positions, Bool)] + booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser + where + -- TODO(leana8959): implement position + + parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, Bool)] + parser v fields = case Map.lookup fn fields of + Nothing -> (pure . pure) (noPos, def) + Just [] -> (pure . pure) (noPos, def) + Just [x] -> pure <$> parseOne v x + Just xs@(_ : y : ys) -> do + warnMultipleSingularFields fn xs + pure . NE.last <$> traverse (parseOne v) (y :| ys) + + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, Bool) + parseOne v (MkNamelessField pos fls) = do + (noPos,) <$> runFieldParser pos parsec v fls + + noPos = Positions Nothing Nothing Nothing + -- TODO(leana8959): implement monoidalFieldAla -- TODO(leana8959): implement all methods diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index ab321c9459a..bd2c4437643 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -711,6 +711,23 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} +-- Some fields of BuildInfo so I construct the record incrementally and find type errors +type SubBuildInfo mod = + ( {-buildable-} AttachPos mod Bool + , {-targetBuildDepends-} AttachPos mod [DependencyWith mod] + ) +buildInfoFieldGrammar' + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (AttachPos mod Bool, AttachPos mod [DependencyWith mod])) + , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + ) + => g mod (SubBuildInfo mod) (SubBuildInfo mod) +buildInfoFieldGrammar' = + (,) + <$> booleanFieldDef' "buildable" _1 True + <*> monoidalFieldAla' "build-depends" (formatDependencyList @mod) _2 + data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo { miniTargetBuildDependsPoly :: AttachPos m [DependencyWith m] -- , miniTargetBuildDepends :: [DependencyWith m] @@ -727,14 +744,6 @@ miniTargetBuildDependsPolyLens -> f (MiniBuildInfo mod) miniTargetBuildDependsPolyLens f s = fmap (\x -> s{miniTargetBuildDependsPoly = x}) (f (miniTargetBuildDependsPoly s)) --- miniTargetBuildDependsLens --- :: forall mod f --- . Functor f --- => ([DependencyWith mod] -> f [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 From aa0718e029dcb4033935603b577f387606dadc49 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 18:11:02 +0200 Subject: [PATCH 031/111] implement buildable --- .../PackageDescription/FieldGrammar.hs | 24 ++++++++++--------- .../src/Distribution/Types/BuildInfo.hs | 8 +++++-- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 20 insertions(+), 14 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index bd2c4437643..15461967856 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,4 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} @@ -184,6 +186,7 @@ libraryFieldGrammar , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] + , AttachPos mod Bool ~ Bool , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -598,6 +601,7 @@ buildInfoFieldGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) + -- NOTE(leana8959): This constraint is here for the time being to parse legacy BuildInfo without Annotation. -- To make this fully polymorphic (and lift this constraint), we need to choose between monoidalFieldAla and monoidalFieldAlaAnn using the type. -- This might force us to add one more new type param to the FieldGrammar type class and render things more complicated, @@ -605,6 +609,8 @@ buildInfoFieldGrammar -- -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] + , AttachPos mod Bool ~ Bool + , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (List CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) @@ -711,22 +717,18 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} --- Some fields of BuildInfo so I construct the record incrementally and find type errors -type SubBuildInfo mod = - ( {-buildable-} AttachPos mod Bool - , {-targetBuildDepends-} AttachPos mod [DependencyWith mod] - ) buildInfoFieldGrammar' :: forall mod c g . ( FieldGrammarWith mod c g - , Applicative (g mod (AttachPos mod Bool, AttachPos mod [DependencyWith mod])) + , Applicative (g mod (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) - => g mod (SubBuildInfo mod) (SubBuildInfo mod) -buildInfoFieldGrammar' = - (,) - <$> booleanFieldDef' "buildable" _1 True - <*> monoidalFieldAla' "build-depends" (formatDependencyList @mod) _2 + => g mod (BuildInfoWith mod) (BuildInfoWith mod) +buildInfoFieldGrammar' = do + buildable <- booleanFieldDef' "buildable" (L.buildable @mod) True + buildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) (L.targetBuildDepends @mod) + pure (BuildInfo {..}) data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo { miniTargetBuildDependsPoly :: AttachPos m [DependencyWith m] diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 2b4f75b940e..f9d73097c73 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -53,7 +53,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn -- Consider refactoring into executable and library versions. data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo - { buildable :: Bool + { buildable :: AttachPos m Bool -- ^ component is buildable here , buildTools :: [LegacyExeDependency] -- ^ Tools needed to build this bit. @@ -182,7 +182,11 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi - { targetBuildDepends = + { buildable = case map snd $ buildable bi of + -- TODO(leana8959): remove multiplicity here + [u] -> u + _ -> undefined + , targetBuildDepends = mconcat $ (fmap . fmap) unannotateDependencyAnn $ map snd diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 5b8dffa45a9..25007b48e9e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -46,7 +46,7 @@ type HasBuildInfoAnn = HasBuildInfoWith Mod.HasAnn class HasBuildInfoWith mod a | a -> mod where buildInfo :: Lens' a (BuildInfoWith mod) - buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a Bool + buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod Bool) buildable = buildInfo @mod . buildable @mod buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [LegacyExeDependency] From 406eaf93d0769ac3eb7c84187c00a02aa92a46f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 18:19:22 +0200 Subject: [PATCH 032/111] split AttachPos into AttachPos and PreserveGrouping --- .../src/Distribution/FieldGrammar/Class.hs | 6 +++--- .../src/Distribution/FieldGrammar/Parsec.hs | 14 +++++++------- .../PackageDescription/FieldGrammar.hs | 15 ++++++++------- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 9 +++------ .../src/Distribution/Types/BuildInfo/Lens.hs | 4 ++-- Cabal-syntax/src/Distribution/Types/Modify.hs | 6 +++++- 6 files changed, 28 insertions(+), 26 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 9fb778a958e..2571a93d53a 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -33,7 +33,7 @@ import Distribution.Fields.Field import Distribution.Utils.ShortText import Data.Kind -import Distribution.Types.Modify (AttachPos) +import Distribution.Types.Modify (AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type FieldGrammar = FieldGrammarWith Mod.HasNoAnn @@ -169,9 +169,9 @@ class -- ^ field name -> (a -> b) -- ^ 'pack' - -> ALens' s (AttachPos m a) + -> ALens' s (PreserveGrouping m (AttachPos m a)) -- ^ lens into the field - -> g m s (AttachPos m a) + -> g m s (PreserveGrouping m (AttachPos m a)) -- | Monoidal field. -- diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index dad3e2554c7..e76bac1df23 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -387,23 +387,23 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where :: forall s . FieldName -- ^ field name - -> ALens' s [(Positions, Bool)] + -> ALens' s (Positions, Bool) -- ^ lens into the field -> Bool -- ^ default - -> ParsecFieldGrammar Mod.HasAnn s [(Positions, Bool)] + -> ParsecFieldGrammar Mod.HasAnn s (Positions, Bool) booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where -- TODO(leana8959): implement position - parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, Bool)] + parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Positions, Bool) parser v fields = case Map.lookup fn fields of - Nothing -> (pure . pure) (noPos, def) - Just [] -> (pure . pure) (noPos, def) - Just [x] -> pure <$> parseOne v x + Nothing -> pure (noPos, def) + Just [] -> pure (noPos, def) + Just [x] -> parseOne v x Just xs@(_ : y : ys) -> do warnMultipleSingularFields fn xs - pure . NE.last <$> traverse (parseOne v) (y :| ys) + NE.last <$> traverse (parseOne v) (y :| ys) parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, Bool) parseOne v (MkNamelessField pos fls) = do diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 15461967856..0fb21a90744 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -97,7 +97,7 @@ import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) -import Distribution.Types.Modify (AttachPos) +import Distribution.Types.Modify (AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod import qualified Data.ByteString.Char8 as BS8 @@ -186,6 +186,7 @@ libraryFieldGrammar , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] + , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] , AttachPos mod Bool ~ Bool , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -609,6 +610,7 @@ buildInfoFieldGrammar -- -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] + , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] , AttachPos mod Bool ~ Bool , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -731,20 +733,19 @@ buildInfoFieldGrammar' = do pure (BuildInfo {..}) data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo - { miniTargetBuildDependsPoly :: AttachPos m [DependencyWith m] - -- , miniTargetBuildDepends :: [DependencyWith m] + { miniTargetBuildDepends :: PreserveGrouping m (AttachPos m [DependencyWith m]) } deriving instance Show (MiniBuildInfo Mod.HasAnn) deriving instance Show (MiniBuildInfo Mod.HasNoAnn) -miniTargetBuildDependsPolyLens +miniTargetBuildDependsLens :: forall mod f . Functor f - => (AttachPos mod [DependencyWith mod] -> f (AttachPos mod [DependencyWith mod])) + => (PreserveGrouping mod (AttachPos mod [DependencyWith mod]) -> f (PreserveGrouping mod (AttachPos mod [DependencyWith mod]))) -> (MiniBuildInfo mod) -> f (MiniBuildInfo mod) -miniTargetBuildDependsPolyLens f s = fmap (\x -> s{miniTargetBuildDependsPoly = x}) (f (miniTargetBuildDependsPoly s)) +miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) miniBuildInfoFieldGrammar :: forall mod c g @@ -755,7 +756,7 @@ miniBuildInfoFieldGrammar => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) miniBuildInfoFieldGrammar = MiniBuildInfo - <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsPolyLens + <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens hsSourceDirsGrammar :: forall mod c g diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index f9d73097c73..2ad3d7ead15 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -41,7 +41,7 @@ import Language.Haskell.Extension import Data.Kind -import Distribution.Types.Modify (AttachPos) +import Distribution.Types.Modify (AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn @@ -163,7 +163,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: AttachPos m ([DependencyWith m]) + , targetBuildDepends :: PreserveGrouping m (AttachPos m [DependencyWith m]) -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } @@ -182,10 +182,7 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi - { buildable = case map snd $ buildable bi of - -- TODO(leana8959): remove multiplicity here - [u] -> u - _ -> undefined + { buildable = snd $ buildable bi , targetBuildDepends = mconcat $ (fmap . fmap) unannotateDependencyAnn diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 25007b48e9e..7c07ea8d5df 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -37,7 +37,7 @@ import Distribution.Utils.Path import Language.Haskell.Extension (Extension, Language) import qualified Distribution.Types.BuildInfo as T -import Distribution.Types.Modify (AttachPos) +import Distribution.Types.Modify (AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn @@ -184,7 +184,7 @@ class HasBuildInfoWith mod a | a -> mod where customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] customFieldsBI = buildInfo @mod . customFieldsBI @mod - targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod [DependencyWith mod]) + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [DependencyWith mod])) targetBuildDepends = buildInfo @mod . targetBuildDepends @mod mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 0ee0c7c6763..1cc02f8f511 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -23,5 +23,9 @@ type family Annotate (m :: HasAnnotation) (a :: Type) where Annotate HasAnn a = Ann SurroundingText a type family AttachPos (m :: HasAnnotation) (a :: Type) where - AttachPos HasAnn a = [(Positions, a)] + AttachPos HasAnn a = (Positions, a) AttachPos HasNoAnn a = a + +type family PreserveGrouping (m :: HasAnnotation) (a :: Type) where + PreserveGrouping HasAnn a = [a] + PreserveGrouping HasNoAnn a = a From 5b8ba685d0814b2091f755dc1f29a9cd020e1de6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 18:37:35 +0200 Subject: [PATCH 033/111] implement buildTools --- .../PackageDescription/FieldGrammar.hs | 15 ++++++++++++++- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 6 +++++- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 20 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 0fb21a90744..2e10fba7668 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -185,9 +185,13 @@ libraryFieldGrammar , Applicative (g mod (LibraryWith mod)) , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) + , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] + , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] + , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] , AttachPos mod Bool ~ Bool + , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -611,6 +615,8 @@ buildInfoFieldGrammar -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] + , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] + , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] , AttachPos mod Bool ~ Bool , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -724,12 +730,16 @@ buildInfoFieldGrammar' . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) + -- TODO(leana8959): implement dispatch to list with annotation when needed , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith Mod.HasNoAnn CommaVCat (Identity LegacyExeDependency) LegacyExeDependency) ) => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar' = do buildable <- booleanFieldDef' "buildable" (L.buildable @mod) True - buildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) (L.targetBuildDepends @mod) + -- NOTE(leana8959): adding a binding for the lens formatters help type inference + buildTools <- monoidalFieldAla' "build-tools" formatBuildTools (L.buildTools @mod) + targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) (L.targetBuildDepends @mod) pure (BuildInfo {..}) data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo @@ -913,6 +923,9 @@ setupBInfoFieldGrammar def = formatDependencyList :: [DependencyWith mod] -> List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) formatDependencyList = alaList CommaVCat +formatBuildTools :: [LegacyExeDependency] -> List CommaVCat (Identity LegacyExeDependency) LegacyExeDependency +formatBuildTools = alaList CommaVCat + formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 2ad3d7ead15..e7369d1c541 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -55,7 +55,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo { buildable :: AttachPos m Bool -- ^ component is buildable here - , buildTools :: [LegacyExeDependency] + , buildTools :: PreserveGrouping m (AttachPos m [LegacyExeDependency]) -- ^ Tools needed to build this bit. -- -- This is a legacy field that 'buildToolDepends' largely supersedes. @@ -183,6 +183,10 @@ unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi { buildable = snd $ buildable bi + , buildTools = + mconcat + $ map snd + $ buildTools bi , targetBuildDepends = mconcat $ (fmap . fmap) unannotateDependencyAnn diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 7c07ea8d5df..5e906f0377f 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -49,7 +49,7 @@ class HasBuildInfoWith mod a | a -> mod where buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod Bool) buildable = buildInfo @mod . buildable @mod - buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [LegacyExeDependency] + buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [LegacyExeDependency])) buildTools = buildInfo @mod . buildTools @mod buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ExeDependency] From e8b00562cde5a7304cfcf255c1c1de2b30173504 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 18:40:33 +0200 Subject: [PATCH 034/111] remove some redundant type application --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 2e10fba7668..fe2b24de0cf 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -736,10 +736,10 @@ buildInfoFieldGrammar' ) => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar' = do - buildable <- booleanFieldDef' "buildable" (L.buildable @mod) True + buildable <- booleanFieldDef' "buildable" L.buildable True -- NOTE(leana8959): adding a binding for the lens formatters help type inference - buildTools <- monoidalFieldAla' "build-tools" formatBuildTools (L.buildTools @mod) - targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) (L.targetBuildDepends @mod) + buildTools <- monoidalFieldAla' "build-tools" formatBuildTools L.buildTools + targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends pure (BuildInfo {..}) data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo From d789c8e1f292aa73cf697ca8950b71bac43c1a34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 9 Apr 2026 18:48:05 +0200 Subject: [PATCH 035/111] implement BuildtoolDepends --- .../PackageDescription/FieldGrammar.hs | 15 ++++++++++++--- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 6 +++++- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index fe2b24de0cf..4ef36aa75c5 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -190,6 +190,8 @@ libraryFieldGrammar , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] + , AttachPos mod [ExeDependency] ~ [ExeDependency] + , PreserveGrouping mod [ExeDependency] ~ [ExeDependency] , AttachPos mod Bool ~ Bool , c (Identity LibraryVisibility) @@ -617,6 +619,8 @@ buildInfoFieldGrammar , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] + , AttachPos mod [ExeDependency] ~ [ExeDependency] + , PreserveGrouping mod [ExeDependency] ~ [ExeDependency] , AttachPos mod Bool ~ Bool , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -732,13 +736,15 @@ buildInfoFieldGrammar' , L.HasBuildInfoWith mod (BuildInfoWith mod) -- TODO(leana8959): implement dispatch to list with annotation when needed , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - , c (ListWith Mod.HasNoAnn CommaVCat (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith Mod.HasNoAnn CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith Mod.HasNoAnn CommaFSep (Identity ExeDependency) ExeDependency) ) => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar' = do buildable <- booleanFieldDef' "buildable" L.buildable True -- NOTE(leana8959): adding a binding for the lens formatters help type inference buildTools <- monoidalFieldAla' "build-tools" formatBuildTools L.buildTools + buildToolDepends <- monoidalFieldAla' "build-tool-depends" formatBuildToolDepends L.buildToolDepends targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends pure (BuildInfo {..}) @@ -923,8 +929,11 @@ setupBInfoFieldGrammar def = formatDependencyList :: [DependencyWith mod] -> List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) formatDependencyList = alaList CommaVCat -formatBuildTools :: [LegacyExeDependency] -> List CommaVCat (Identity LegacyExeDependency) LegacyExeDependency -formatBuildTools = alaList CommaVCat +formatBuildTools :: [LegacyExeDependency] -> List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency +formatBuildTools = alaList CommaFSep + +formatBuildToolDepends :: [ExeDependency] -> List CommaFSep (Identity ExeDependency) ExeDependency +formatBuildToolDepends = alaList CommaFSep formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index e7369d1c541..ae090dfc862 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -63,7 +63,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = 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 (AttachPos m [ExeDependency]) -- ^ Haskell tools needed to build this bit -- -- This field is better than 'buildTools' because it allows one to @@ -187,6 +187,10 @@ unannotateBuildInfo bi = mconcat $ map snd $ buildTools bi + , buildToolDepends = + mconcat + $ map snd + $ buildToolDepends bi , targetBuildDepends = mconcat $ (fmap . fmap) unannotateDependencyAnn diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 5e906f0377f..f20f847f8c8 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -52,7 +52,7 @@ class HasBuildInfoWith mod a | a -> mod where buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [LegacyExeDependency])) buildTools = buildInfo @mod . buildTools @mod - buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ExeDependency] + buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [ExeDependency])) buildToolDepends = buildInfo @mod . buildToolDepends @mod cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From 30a3194667a2040ad9cfd9c04171987f7055f1f2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 10:25:06 +0200 Subject: [PATCH 036/111] use mod to choose ListWith instance --- .../src/Distribution/FieldGrammar/Newtypes.hs | 50 +++++--------- .../PackageDescription/FieldGrammar.hs | 59 ++++++++++------- .../src/Distribution/Types/BuildInfo.hs | 8 +-- .../src/Distribution/Types/BuildInfo/Lens.hs | 4 +- Cabal-tests/tests/ParserTests.hs | 66 +++++++++---------- 5 files changed, 92 insertions(+), 95 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index dfd4551b3fb..3066a7c7ac4 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -22,11 +23,6 @@ module Distribution.FieldGrammar.Newtypes , VCat (..) , FSep (..) , NoCommaFSep (..) - , CommaVCatAnn (..) - , CommaFSepAnn (..) - , VCatAnn (..) - , FSepAnn (..) - , NoCommaFSepAnn (..) -- ** Separator class , Sep (..) @@ -34,7 +30,7 @@ module Distribution.FieldGrammar.Newtypes -- ** Type , List , ListAnn - , ListWith + , ListWith (..) -- ** Set , alaSet @@ -97,31 +93,21 @@ import qualified Distribution.SPDX as SPDX -- | Vertical list with commas. Displayed with 'vcat' data CommaVCat = CommaVCat -data CommaVCatAnn = CommaVCatAnn - -- | Paragraph fill list with commas. Displayed with 'fsep' data CommaFSep = CommaFSep -data CommaFSepAnn = CommaFSepAnn - -- | Vertical list with optional commas. Displayed with 'vcat'. data VCat = VCat -data VCatAnn = VCatAnn - -- | Paragraph fill list with optional commas. Displayed with 'fsep'. data FSep = FSep -data FSepAnn = FSepAnn - -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep -data NoCommaFSepAnn = NoCommaFSepAnn - -- TODO(leana8959): Relax Sep to return a list of annotated docs with position -- Use the position propagated back from applyTriviaDoc -class Sep (mod :: Mod.HasAnnotation) sep | sep -> mod where +class Sep (mod :: Mod.HasAnnotation) sep where prettySep :: Proxy sep -> [Annotate mod Doc] -> Doc parseSep :: CabalParsing m => Proxy sep -> m a -> m [Annotate mod a] @@ -136,7 +122,7 @@ instance Sep Mod.HasNoAnn CommaVCat where v <- askCabalSpecVersion if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep Mod.HasAnn CommaVCatAnn where +instance Sep Mod.HasAnn CommaVCat where prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion @@ -156,7 +142,7 @@ instance Sep Mod.HasNoAnn CommaFSep where v <- askCabalSpecVersion if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p -instance Sep Mod.HasAnn CommaFSepAnn where +instance Sep Mod.HasAnn CommaFSep where prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion @@ -174,7 +160,7 @@ instance Sep Mod.HasNoAnn VCat where if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep Mod.HasAnn VCatAnn where +instance Sep Mod.HasAnn VCat where prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion @@ -195,7 +181,7 @@ instance Sep Mod.HasNoAnn FSep where if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep Mod.HasAnn FSepAnn where +instance Sep Mod.HasAnn FSep where prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion @@ -214,7 +200,7 @@ instance Sep Mod.HasNoAnn NoCommaFSep where parseSep _ p = many (p <* P.spaces) parseSepNE _ p = NE.some1 (p <* P.spaces) -instance Sep Mod.HasAnn NoCommaFSepAnn where +instance Sep Mod.HasAnn NoCommaFSep where prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = many $ do x <- p @@ -247,20 +233,20 @@ alaList _ = List alaList' :: sep -> (a -> b) -> [a] -> List sep b a alaList' _ _ = List -instance Newtype [a] (List sep wrapper a) -instance Newtype [Ann SurroundingText a] (ListAnn sep wrapper a) +instance Newtype [a] (ListWith Mod.HasNoAnn sep wrapper a) +instance Newtype [Ann SurroundingText a] (ListWith Mod.HasAnn sep wrapper a) instance (Newtype a b, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (List sep b a) where - parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + 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) (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec + parsec = pack . (map . 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 (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack + 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 - pretty = prettySep (Proxy :: Proxy sep) . (map . fmap) (pretty . (pack :: a -> b)) . unpack + pretty = prettySep @Mod.HasAnn (Proxy :: Proxy sep) . (map . fmap) (pretty . (pack :: a -> b)) . unpack -- | Like 'List', but for 'Set'. -- @@ -292,10 +278,10 @@ alaSet' _ _ = Set' instance Newtype (Set a) (Set' sep wrapper a) 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 (Proxy :: Proxy sep) parsec + parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep @Mod.HasNoAnn (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (Set' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack + pretty = prettySep @Mod.HasNoAnn (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack -- @@ -326,10 +312,10 @@ alaNonEmpty' _ _ = NonEmpty' instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a) instance (Newtype a b, Sep Mod.HasNoAnn sep, Parsec b) => Parsec (NonEmpty' sep b a) where - parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec + parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE @Mod.HasNoAnn (Proxy :: Proxy sep) parsec instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (NonEmpty' sep b a) where - pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack + pretty = prettySep @Mod.HasNoAnn (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack ------------------------------------------------------------------------------- -- Identifiers diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 4ef36aa75c5..e36f27b94fd 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -97,7 +97,8 @@ import Distribution.Pretty (Pretty (..), prettyShow, showToken) import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) -import Distribution.Types.Modify (AttachPos, PreserveGrouping) +import Distribution.Trivia +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) import qualified Distribution.Types.Modify as Mod import qualified Data.ByteString.Char8 as BS8 @@ -187,6 +188,7 @@ libraryFieldGrammar , L.HasBuildInfoWith mod (BuildInfoWith mod) , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] + , Annotate mod (DependencyWith mod) ~ DependencyWith mod , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] @@ -616,6 +618,7 @@ buildInfoFieldGrammar -- -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] + , Annotate mod (DependencyWith mod) ~ DependencyWith mod , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] @@ -729,27 +732,27 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} -buildInfoFieldGrammar' - :: forall mod c g - . ( FieldGrammarWith mod c g - , Applicative (g mod (BuildInfoWith mod)) - , L.HasBuildInfoWith mod (BuildInfoWith mod) - -- TODO(leana8959): implement dispatch to list with annotation when needed - , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - , c (ListWith Mod.HasNoAnn CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (ListWith Mod.HasNoAnn CommaFSep (Identity ExeDependency) ExeDependency) - ) - => g mod (BuildInfoWith mod) (BuildInfoWith mod) -buildInfoFieldGrammar' = do - buildable <- booleanFieldDef' "buildable" L.buildable True - -- NOTE(leana8959): adding a binding for the lens formatters help type inference - buildTools <- monoidalFieldAla' "build-tools" formatBuildTools L.buildTools - buildToolDepends <- monoidalFieldAla' "build-tool-depends" formatBuildToolDepends L.buildToolDepends - targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends - pure (BuildInfo {..}) +-- buildInfoFieldGrammar' +-- :: forall mod c g +-- . ( FieldGrammarWith mod c g +-- , Applicative (g mod (BuildInfoWith mod)) +-- , L.HasBuildInfoWith mod (BuildInfoWith mod) +-- -- TODO(leana8959): implement dispatch to list with annotation when needed +-- , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) +-- , c (ListWith Mod.HasNoAnn CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) +-- , c (ListWith Mod.HasNoAnn CommaFSep (Identity ExeDependency) ExeDependency) +-- ) +-- => g mod (BuildInfoWith mod) (BuildInfoWith mod) +-- buildInfoFieldGrammar' = do +-- buildable <- booleanFieldDef' "buildable" L.buildable True +-- -- NOTE(leana8959): adding a binding for the lens formatters help type inference +-- buildTools <- monoidalFieldAla' "build-tools" formatBuildTools L.buildTools +-- buildToolDepends <- monoidalFieldAla' "build-tool-depends" formatBuildToolDepends L.buildToolDepends +-- targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends +-- pure (BuildInfo {..}) data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo - { miniTargetBuildDepends :: PreserveGrouping m (AttachPos m [DependencyWith m]) + { miniTargetBuildDepends :: PreserveGrouping m (AttachPos m [Annotate m (DependencyWith m)]) } deriving instance Show (MiniBuildInfo Mod.HasAnn) @@ -758,8 +761,8 @@ deriving instance Show (MiniBuildInfo Mod.HasNoAnn) miniTargetBuildDependsLens :: forall mod f . Functor f - => (PreserveGrouping mod (AttachPos mod [DependencyWith mod]) -> f (PreserveGrouping mod (AttachPos mod [DependencyWith mod]))) - -> (MiniBuildInfo mod) + => (PreserveGrouping mod (AttachPos mod [Annotate mod (DependencyWith mod)]) -> f (PreserveGrouping mod (AttachPos mod [Annotate mod (DependencyWith mod)]))) + -> MiniBuildInfo mod -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) @@ -767,12 +770,17 @@ miniBuildInfoFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g , Applicative (g mod (MiniBuildInfo mod)) - , c (List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + + , Newtype + [Annotate mod (DependencyWith mod)] + (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) miniBuildInfoFieldGrammar = MiniBuildInfo - <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens + <$> monoidalFieldAla' "build-depends" (formatDependencyList' @mod) miniTargetBuildDependsLens hsSourceDirsGrammar :: forall mod c g @@ -929,6 +937,9 @@ setupBInfoFieldGrammar def = formatDependencyList :: [DependencyWith mod] -> List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) formatDependencyList = alaList CommaVCat +formatDependencyList' :: [Annotate mod (DependencyWith mod)] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) +formatDependencyList' = List + formatBuildTools :: [LegacyExeDependency] -> List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency formatBuildTools = alaList CommaFSep diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index ae090dfc862..4902d257c80 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -41,7 +41,7 @@ import Language.Haskell.Extension import Data.Kind -import Distribution.Types.Modify (AttachPos, PreserveGrouping) +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn @@ -163,7 +163,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: PreserveGrouping m (AttachPos m [DependencyWith m]) + , targetBuildDepends :: PreserveGrouping m (AttachPos m [Annotate m (DependencyWith m)]) -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } @@ -192,8 +192,8 @@ unannotateBuildInfo bi = $ map snd $ buildToolDepends bi , targetBuildDepends = - mconcat - $ (fmap . fmap) unannotateDependencyAnn + map (unannotateDependencyAnn . unAnn) + $ join $ map snd $ targetBuildDepends bi } diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index f20f847f8c8..1525b6dbd29 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -37,7 +37,7 @@ import Distribution.Utils.Path import Language.Haskell.Extension (Extension, Language) import qualified Distribution.Types.BuildInfo as T -import Distribution.Types.Modify (AttachPos, PreserveGrouping) +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn @@ -184,7 +184,7 @@ class HasBuildInfoWith mod a | a -> mod where customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] customFieldsBI = buildInfo @mod . customFieldsBI @mod - targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [DependencyWith mod])) + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (DependencyWith mod)])) targetBuildDepends = buildInfo @mod . targetBuildDepends @mod mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 2481dd12079..1a5ff4c7d3b 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -52,11 +52,11 @@ import Distribution.Parsec.Source import Distribution.Types.Dependency (DependencyAnn) import Distribution.Types.PackageName (PackageName) import Distribution.FieldGrammar.Newtypes - ( CommaVCatAnn - , CommaFSepAnn - , VCatAnn - , FSepAnn - , NoCommaFSepAnn + ( CommaVCat + , CommaFSep + , VCat + , FSep + , NoCommaFSep , ListAnn ) @@ -219,39 +219,39 @@ parsecPrettyTests = testGroup "parsec pretty roundtrip" $ parsecPrettyTest @PackageName specVer "PackageName simple" "foo" -- make sure PackageName itself parses. : optionals (specVer >= CabalSpecV2_2) - [ parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn leading" ", foo , bar" - , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn leading" ", foo , bar" - , parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn trailing" "foo \n , bar \n, " - , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn trailing" "foo \n , bar , " + [ 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 VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn leading" ", foo , bar" - , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn leading" ", foo , bar" + [ parsecPrettyTest @(ListAnn VCat (Identity PackageName) PackageName) specVer "VCat leading" ", foo , bar" + , parsecPrettyTest @(ListAnn FSep (Identity PackageName) PackageName) specVer "FSep leading" ", foo , bar" ] ++ - [ parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn simple" "foo , bar , baz" - , parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn newline" "foo ,\n bar , baz" - , parsecPrettyTest @(ListAnn CommaVCatAnn (Identity PackageName) PackageName) specVer "CommaVCatAnn newline" "foo ,\n bar \n, baz" - - , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn simple" "foo , bar , baz" - , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn newline" "foo ,\n bar , baz" - , parsecPrettyTest @(ListAnn CommaFSepAnn (Identity PackageName) PackageName) specVer "CommaFSepAnn newline" "foo ,\n bar \n, baz" - - , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn simple" "foo \n bar" - , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn trailing" "foo \n bar \n" - , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn trailing" "foo \n bar \n\n" - , parsecPrettyTest @(ListAnn VCatAnn (Identity PackageName) PackageName) specVer "VCatAnn optional comma" "foo , \n bar \n\n" - - , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn simple" "foo \n bar" - , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn trailing" "foo \n bar \n" - , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn trailing" "foo \n bar \n\n" - , parsecPrettyTest @(ListAnn FSepAnn (Identity PackageName) PackageName) specVer "FSepAnn optional comma" "foo , \n bar \n\n" - - , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn simple" "foo \n bar" - , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn trailing" "foo \n bar \n" - , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn trailing" "foo \n bar \n\n" - , parsecPrettyTest @(ListAnn NoCommaFSepAnn (Identity PackageName) PackageName) specVer "NoCommaFSepAnn optional comma" "foo \n bar \n\n" + [ 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 From b0da442426b7cbdf685665082405cee29dc8b18f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 10:51:57 +0200 Subject: [PATCH 037/111] fix buildinfo example --- .../PackageDescription/FieldGrammar.hs | 83 +++++++------------ .../src/Distribution/Types/BuildInfo.hs | 10 ++- .../src/Distribution/Types/BuildInfo/Lens.hs | 4 +- 3 files changed, 40 insertions(+), 57 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index e36f27b94fd..05f53e57b0c 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -187,14 +187,8 @@ libraryFieldGrammar , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] - , Annotate mod (DependencyWith mod) ~ DependencyWith mod - , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] - , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] - , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] - , AttachPos mod [ExeDependency] ~ [ExeDependency] - , PreserveGrouping mod [ExeDependency] ~ [ExeDependency] - , AttachPos mod Bool ~ Bool + -- TODO(leana8959): use legacy for now, not completely polymorphic + , mod ~ Mod.HasNoAnn , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) @@ -611,20 +605,8 @@ buildInfoFieldGrammar , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - -- NOTE(leana8959): This constraint is here for the time being to parse legacy BuildInfo without Annotation. - -- To make this fully polymorphic (and lift this constraint), we need to choose between monoidalFieldAla and monoidalFieldAlaAnn using the type. - -- This might force us to add one more new type param to the FieldGrammar type class and render things more complicated, - -- so we leave it for later and ponder on it. - -- - -- Also, do we need the legacy parser? I think we can reimplement the old behaviour by "fmap unannotate" into the Field Grammar. - , AttachPos mod [DependencyWith mod] ~ [DependencyWith mod] - , Annotate mod (DependencyWith mod) ~ DependencyWith mod - , PreserveGrouping mod [DependencyWith mod] ~ [DependencyWith mod] - , AttachPos mod [LegacyExeDependency] ~ [LegacyExeDependency] - , PreserveGrouping mod [LegacyExeDependency] ~ [LegacyExeDependency] - , AttachPos mod [ExeDependency] ~ [ExeDependency] - , PreserveGrouping mod [ExeDependency] ~ [ExeDependency] - , AttachPos mod Bool ~ Bool + -- TODO(leana8959): use legacy for now, not completely polymorphic + , mod ~ Mod.HasNoAnn , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -732,24 +714,27 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} --- buildInfoFieldGrammar' --- :: forall mod c g --- . ( FieldGrammarWith mod c g --- , Applicative (g mod (BuildInfoWith mod)) --- , L.HasBuildInfoWith mod (BuildInfoWith mod) --- -- TODO(leana8959): implement dispatch to list with annotation when needed --- , c (ListWith Mod.HasNoAnn CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) --- , c (ListWith Mod.HasNoAnn CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) --- , c (ListWith Mod.HasNoAnn CommaFSep (Identity ExeDependency) ExeDependency) --- ) --- => g mod (BuildInfoWith mod) (BuildInfoWith mod) --- buildInfoFieldGrammar' = do --- buildable <- booleanFieldDef' "buildable" L.buildable True --- -- NOTE(leana8959): adding a binding for the lens formatters help type inference --- buildTools <- monoidalFieldAla' "build-tools" formatBuildTools L.buildTools --- buildToolDepends <- monoidalFieldAla' "build-tool-depends" formatBuildToolDepends L.buildToolDepends --- targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends --- pure (BuildInfo {..}) +buildInfoFieldGrammar' + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod (BuildInfoWith mod)) + , L.HasBuildInfoWith mod (BuildInfoWith mod) + + , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + ) + => g mod (BuildInfoWith mod) (BuildInfoWith mod) +buildInfoFieldGrammar' = do + buildable <- booleanFieldDef' "buildable" L.buildable True + -- NOTE(leana8959): adding a binding for the lens formatters help type inference + buildTools <- monoidalFieldAla' "build-tools" (formatBuildTools @mod) L.buildTools + buildToolDepends <- monoidalFieldAla' "build-tool-depends" (formatBuildToolDepends @mod) L.buildToolDepends + targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends + pure (BuildInfo {..}) data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo { miniTargetBuildDepends :: PreserveGrouping m (AttachPos m [Annotate m (DependencyWith m)]) @@ -780,7 +765,7 @@ miniBuildInfoFieldGrammar => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) miniBuildInfoFieldGrammar = MiniBuildInfo - <$> monoidalFieldAla' "build-depends" (formatDependencyList' @mod) miniTargetBuildDependsLens + <$> monoidalFieldAla' "build-depends" (formatDependencyList @mod) miniTargetBuildDependsLens hsSourceDirsGrammar :: forall mod c g @@ -933,18 +918,14 @@ setupBInfoFieldGrammar def = -- Define how field values should be formatted for 'pretty'. ------------------------------------------------------------------------------- --- TODO(leana8959): implement this -formatDependencyList :: [DependencyWith mod] -> List CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) -formatDependencyList = alaList CommaVCat - -formatDependencyList' :: [Annotate mod (DependencyWith mod)] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) -formatDependencyList' = List +formatDependencyList :: [Annotate mod (DependencyWith mod)] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) +formatDependencyList = List -formatBuildTools :: [LegacyExeDependency] -> List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency -formatBuildTools = alaList CommaFSep +formatBuildTools :: [Annotate mod LegacyExeDependency] -> ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency +formatBuildTools = List -formatBuildToolDepends :: [ExeDependency] -> List CommaFSep (Identity ExeDependency) ExeDependency -formatBuildToolDepends = alaList CommaFSep +formatBuildToolDepends :: [Annotate mod ExeDependency] -> ListWith mod CommaFSep (Identity ExeDependency) ExeDependency +formatBuildToolDepends = List formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 4902d257c80..c412e0d8c57 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -55,7 +55,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo { buildable :: AttachPos m Bool -- ^ component is buildable here - , buildTools :: PreserveGrouping m (AttachPos m [LegacyExeDependency]) + , buildTools :: PreserveGrouping m (AttachPos m [Annotate m LegacyExeDependency]) -- ^ Tools needed to build this bit. -- -- This is a legacy field that 'buildToolDepends' largely supersedes. @@ -63,7 +63,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , buildToolDepends :: PreserveGrouping m (AttachPos m [ExeDependency]) + , buildToolDepends :: PreserveGrouping m (AttachPos m [Annotate m ExeDependency]) -- ^ Haskell tools needed to build this bit -- -- This field is better than 'buildTools' because it allows one to @@ -184,11 +184,13 @@ unannotateBuildInfo bi = bi { buildable = snd $ buildable bi , buildTools = - mconcat + map unAnn + $ join $ map snd $ buildTools bi , buildToolDepends = - mconcat + map unAnn + $ join $ map snd $ buildToolDepends bi , targetBuildDepends = diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 1525b6dbd29..27a5edcc59c 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -49,10 +49,10 @@ class HasBuildInfoWith mod a | a -> mod where buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod Bool) buildable = buildInfo @mod . buildable @mod - buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [LegacyExeDependency])) + buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod LegacyExeDependency])) buildTools = buildInfo @mod . buildTools @mod - buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [ExeDependency])) + buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod ExeDependency])) buildToolDepends = buildInfo @mod . buildToolDepends @mod cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From 01924fa68311dec27f5544c6d314cf694526b0ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:05:00 +0200 Subject: [PATCH 038/111] add cppOptions field --- .../PackageDescription/FieldGrammar.hs | 16 ++++++++++++++-- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 10 +++++++++- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 24 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 05f53e57b0c..238e3a92f02 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -720,12 +720,17 @@ buildInfoFieldGrammar' , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + + -- TODO(leana8959): constraints go here + + , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar' = do @@ -733,6 +738,10 @@ buildInfoFieldGrammar' = do -- NOTE(leana8959): adding a binding for the lens formatters help type inference buildTools <- monoidalFieldAla' "build-tools" (formatBuildTools @mod) L.buildTools buildToolDepends <- monoidalFieldAla' "build-tool-depends" (formatBuildToolDepends @mod) L.buildToolDepends + cppOptions <- monoidalFieldAla' "cpp-options" (formatCppOptions @mod) L.cppOptions + + -- TODO(leana8959): add more + targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends pure (BuildInfo {..}) @@ -927,6 +936,9 @@ formatBuildTools = List formatBuildToolDepends :: [Annotate mod ExeDependency] -> ListWith mod CommaFSep (Identity ExeDependency) ExeDependency formatBuildToolDepends = List +formatCppOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String +formatCppOptions = List + formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index c412e0d8c57..3906adc8001 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -72,7 +72,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = 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 (AttachPos m [Annotate m String]) -- ^ options for pre-processing Haskell code , asmOptions :: [String] -- ^ options for assembler @@ -193,6 +193,14 @@ unannotateBuildInfo bi = $ join $ map snd $ buildToolDepends bi + , cppOptions = + map unAnn + $ join + $ map snd + $ cppOptions bi + + -- TODO(leana8959): add more fields here + , targetBuildDepends = map (unannotateDependencyAnn . unAnn) $ join diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 27a5edcc59c..f4eec6bf8f3 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -55,7 +55,7 @@ class HasBuildInfoWith mod a | a -> mod where buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod ExeDependency])) buildToolDepends = buildInfo @mod . buildToolDepends @mod - cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) cppOptions = buildInfo @mod . cppOptions @mod asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From 9e6b8b94aa6570a9e3b931acd5d30c60968643da Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:13:59 +0200 Subject: [PATCH 039/111] add asmOptions field --- .../PackageDescription/FieldGrammar.hs | 4 ++++ .../src/Distribution/Types/BuildInfo.hs | 21 +++++-------------- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 10 insertions(+), 17 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 238e3a92f02..8214784ab93 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -739,6 +739,7 @@ buildInfoFieldGrammar' = do buildTools <- monoidalFieldAla' "build-tools" (formatBuildTools @mod) L.buildTools buildToolDepends <- monoidalFieldAla' "build-tool-depends" (formatBuildToolDepends @mod) L.buildToolDepends cppOptions <- monoidalFieldAla' "cpp-options" (formatCppOptions @mod) L.cppOptions + asmOptions <- monoidalFieldAla' "asm-options" (formatAsmOptions @mod) L.asmOptions -- TODO(leana8959): add more @@ -939,6 +940,9 @@ formatBuildToolDepends = List formatCppOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String formatCppOptions = List +formatAsmOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String +formatAsmOptions = List + formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 3906adc8001..305ad470177 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -74,7 +74,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- field directly. , cppOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for pre-processing Haskell code - , asmOptions :: [String] + , asmOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for assembler , cmmOptions :: [String] -- ^ options for C-- compiler @@ -183,21 +183,10 @@ unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi { buildable = snd $ buildable bi - , buildTools = - map unAnn - $ join - $ map snd - $ buildTools bi - , buildToolDepends = - map unAnn - $ join - $ map snd - $ buildToolDepends bi - , cppOptions = - map unAnn - $ join - $ map snd - $ cppOptions bi + , buildTools = map unAnn $ join $ map snd $ buildTools bi + , buildToolDepends = map unAnn $ join $ map snd $ buildToolDepends bi + , cppOptions = map unAnn $ join $ map snd $ cppOptions bi + , asmOptions = map unAnn $ join $ map snd $ asmOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index f4eec6bf8f3..37f4a59def7 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -58,7 +58,7 @@ class HasBuildInfoWith mod a | a -> mod where cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) cppOptions = buildInfo @mod . cppOptions @mod - asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) asmOptions = buildInfo @mod . asmOptions @mod cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From df4ffbf6c0622cd1528472f67623d8dbe71f3bad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:17:30 +0200 Subject: [PATCH 040/111] add cmmOptions field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 4 ++++ Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 8214784ab93..e63c0c8dd83 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -740,6 +740,7 @@ buildInfoFieldGrammar' = do buildToolDepends <- monoidalFieldAla' "build-tool-depends" (formatBuildToolDepends @mod) L.buildToolDepends cppOptions <- monoidalFieldAla' "cpp-options" (formatCppOptions @mod) L.cppOptions asmOptions <- monoidalFieldAla' "asm-options" (formatAsmOptions @mod) L.asmOptions + cmmOptions <- monoidalFieldAla' "cmm-options" (formatCmmOptions @mod) L.cmmOptions -- TODO(leana8959): add more @@ -943,6 +944,9 @@ formatCppOptions = List formatAsmOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String formatAsmOptions = List +formatCmmOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String +formatCmmOptions = List + formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 305ad470177..967df3f3e5d 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -76,7 +76,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for pre-processing Haskell code , asmOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for assembler - , cmmOptions :: [String] + , cmmOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for C-- compiler , ccOptions :: [String] -- ^ options for C compiler @@ -187,6 +187,7 @@ unannotateBuildInfo bi = , buildToolDepends = map unAnn $ join $ map snd $ buildToolDepends bi , cppOptions = map unAnn $ join $ map snd $ cppOptions bi , asmOptions = map unAnn $ join $ map snd $ asmOptions bi + , cmmOptions = map unAnn $ join $ map snd $ cmmOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 37f4a59def7..ad6a2a6d74a 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -61,7 +61,7 @@ class HasBuildInfoWith mod a | a -> mod where asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) asmOptions = buildInfo @mod . asmOptions @mod - cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) cmmOptions = buildInfo @mod . cmmOptions @mod ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From 7621557f28bce56a7d3ae405ad1d630ea8c181ac Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:27:50 +0200 Subject: [PATCH 041/111] inline newtypes with new helpers --- .../src/Distribution/FieldGrammar/Newtypes.hs | 15 +++++++++++ .../PackageDescription/FieldGrammar.hs | 26 ++++--------------- 2 files changed, 20 insertions(+), 21 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 3066a7c7ac4..8bcd320badb 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -16,6 +16,8 @@ module Distribution.FieldGrammar.Newtypes ( -- * List alaList , alaList' + , alaListWith + , alaListWith' -- ** Modifiers , CommaVCat (..) @@ -229,10 +231,23 @@ type ListAnn = ListWith Mod.HasAnn 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) + . [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 +alaListWith' + :: forall (mod :: Mod.HasAnnotation) (sep :: Type) (b :: Type) (a :: Type) + . [Annotate mod a] + -> ListWith mod sep b a +alaListWith' = List + instance Newtype [a] (ListWith Mod.HasNoAnn sep wrapper a) instance Newtype [Ann SurroundingText a] (ListWith Mod.HasAnn sep wrapper a) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index e63c0c8dd83..17d9f12e7eb 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -735,12 +735,11 @@ buildInfoFieldGrammar' => g mod (BuildInfoWith mod) (BuildInfoWith mod) buildInfoFieldGrammar' = do buildable <- booleanFieldDef' "buildable" L.buildable True - -- NOTE(leana8959): adding a binding for the lens formatters help type inference - buildTools <- monoidalFieldAla' "build-tools" (formatBuildTools @mod) L.buildTools - buildToolDepends <- monoidalFieldAla' "build-tool-depends" (formatBuildToolDepends @mod) L.buildToolDepends - cppOptions <- monoidalFieldAla' "cpp-options" (formatCppOptions @mod) L.cppOptions - asmOptions <- monoidalFieldAla' "asm-options" (formatAsmOptions @mod) L.asmOptions - cmmOptions <- monoidalFieldAla' "cmm-options" (formatCmmOptions @mod) L.cmmOptions + 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 -- TODO(leana8959): add more @@ -932,21 +931,6 @@ setupBInfoFieldGrammar def = formatDependencyList :: [Annotate mod (DependencyWith mod)] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) formatDependencyList = List -formatBuildTools :: [Annotate mod LegacyExeDependency] -> ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency -formatBuildTools = List - -formatBuildToolDepends :: [Annotate mod ExeDependency] -> ListWith mod CommaFSep (Identity ExeDependency) ExeDependency -formatBuildToolDepends = List - -formatCppOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String -formatCppOptions = List - -formatAsmOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String -formatAsmOptions = List - -formatCmmOptions :: [Annotate mod String] -> ListWith mod NoCommaFSep Token' String -formatCmmOptions = List - formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin formatMixinList = alaList CommaVCat From 3e8a79e016399458f3f39961f79250bfd80c51be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:29:38 +0200 Subject: [PATCH 042/111] test out specialization idea --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 17d9f12e7eb..1dd7ee5f990 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -746,6 +746,11 @@ buildInfoFieldGrammar' = do targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends 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 (AttachPos m [Annotate m (DependencyWith m)]) } From 9372723f6b8253740fbe44bd337b2251abb2f342 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:31:25 +0200 Subject: [PATCH 043/111] add ccOptions field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 1dd7ee5f990..8ebba5f8dac 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -740,6 +740,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 967df3f3e5d..4766fc7de26 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -78,7 +78,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for assembler , cmmOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for C-- compiler - , ccOptions :: [String] + , ccOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for C compiler , cxxOptions :: [String] -- ^ options for C++ compiler @@ -188,6 +188,7 @@ unannotateBuildInfo bi = , cppOptions = map unAnn $ join $ map snd $ cppOptions bi , asmOptions = map unAnn $ join $ map snd $ asmOptions bi , cmmOptions = map unAnn $ join $ map snd $ cmmOptions bi + , ccOptions = map unAnn $ join $ map snd $ ccOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index ad6a2a6d74a..a204fa360ff 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -64,7 +64,7 @@ class HasBuildInfoWith mod a | a -> mod where cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) cmmOptions = buildInfo @mod . cmmOptions @mod - ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) ccOptions = buildInfo @mod . ccOptions @mod cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From 7f2733793f953e7307b8d770d52ed47d20774326 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:33:44 +0200 Subject: [PATCH 044/111] add cxxOptions field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 8ebba5f8dac..b6a1936e8d2 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -741,6 +741,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 4766fc7de26..1028c4562ba 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -80,7 +80,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for C-- compiler , ccOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for C compiler - , cxxOptions :: [String] + , cxxOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for C++ compiler , jsppOptions :: [String] -- ^ options for pre-processing JavaScript code @since 3.16.0.0 @@ -189,6 +189,7 @@ unannotateBuildInfo bi = , asmOptions = map unAnn $ join $ map snd $ asmOptions bi , cmmOptions = map unAnn $ join $ map snd $ cmmOptions bi , ccOptions = map unAnn $ join $ map snd $ ccOptions bi + , cxxOptions = map unAnn $ join $ map snd $ cxxOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index a204fa360ff..d1e48ee6645 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -67,7 +67,7 @@ class HasBuildInfoWith mod a | a -> mod where ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) ccOptions = buildInfo @mod . ccOptions @mod - cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) cxxOptions = buildInfo @mod . cxxOptions @mod jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From 2a1d110a6a0bfab774b294a805dc0270d83817e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:35:53 +0200 Subject: [PATCH 045/111] implement jsppOptions --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index b6a1936e8d2..9809374c7cf 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -742,6 +742,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 1028c4562ba..c8e5072334c 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -82,7 +82,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for C compiler , cxxOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for C++ compiler - , jsppOptions :: [String] + , jsppOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for pre-processing JavaScript code @since 3.16.0.0 , ldOptions :: [String] -- ^ options for linker @@ -190,6 +190,7 @@ unannotateBuildInfo bi = , cmmOptions = map unAnn $ join $ map snd $ cmmOptions bi , ccOptions = map unAnn $ join $ map snd $ ccOptions bi , cxxOptions = map unAnn $ join $ map snd $ cxxOptions bi + , jsppOptions = map unAnn $ join $ map snd $ jsppOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index d1e48ee6645..0e497e8fe88 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -70,7 +70,7 @@ class HasBuildInfoWith mod a | a -> mod where cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) cxxOptions = buildInfo @mod . cxxOptions @mod - jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) jsppOptions = buildInfo @mod . jsppOptions @mod ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From c999682ffc94a6fc108722ecc20ac2cbb1a5f048 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:37:27 +0200 Subject: [PATCH 046/111] add ldOptions field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 9809374c7cf..0d66ecfa373 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -743,6 +743,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index c8e5072334c..5e8bf8de28c 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -84,7 +84,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for C++ compiler , jsppOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for pre-processing JavaScript code @since 3.16.0.0 - , ldOptions :: [String] + , ldOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for linker , hsc2hsOptions :: [String] -- ^ options for hsc2hs @@ -191,6 +191,7 @@ unannotateBuildInfo bi = , ccOptions = map unAnn $ join $ map snd $ ccOptions bi , cxxOptions = map unAnn $ join $ map snd $ cxxOptions bi , jsppOptions = map unAnn $ join $ map snd $ jsppOptions bi + , ldOptions = map unAnn $ join $ map snd $ ldOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 0e497e8fe88..6aed66e7cfe 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -73,7 +73,7 @@ class HasBuildInfoWith mod a | a -> mod where jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) jsppOptions = buildInfo @mod . jsppOptions @mod - ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) ldOptions = buildInfo @mod . ldOptions @mod hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] From c416dd9a5a4a0b4452e3546296e4cf454c388572 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:38:56 +0200 Subject: [PATCH 047/111] add hsc2hsOptions field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 0d66ecfa373..8a86313392d 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -744,6 +744,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 5e8bf8de28c..4e09ab4db23 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -86,7 +86,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for pre-processing JavaScript code @since 3.16.0.0 , ldOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for linker - , hsc2hsOptions :: [String] + , hsc2hsOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for hsc2hs , pkgconfigDepends :: [PkgconfigDependency] -- ^ pkg-config packages that are used @@ -192,6 +192,7 @@ unannotateBuildInfo bi = , cxxOptions = map unAnn $ join $ map snd $ cxxOptions bi , jsppOptions = map unAnn $ join $ map snd $ jsppOptions bi , ldOptions = map unAnn $ join $ map snd $ ldOptions bi + , hsc2hsOptions = map unAnn $ join $ map snd $ hsc2hsOptions bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 6aed66e7cfe..1bbaa686d24 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -76,7 +76,7 @@ class HasBuildInfoWith mod a | a -> mod where ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) ldOptions = buildInfo @mod . ldOptions @mod - hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [String] + hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) hsc2hsOptions = buildInfo @mod . hsc2hsOptions @mod pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [PkgconfigDependency] From a72b642f48230c25a0bd5a2b608f048636b95a33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 11:42:01 +0200 Subject: [PATCH 048/111] add pkgConfigDependency field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 3 +++ Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 8a86313392d..c3ec0ceafb7 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -726,6 +726,8 @@ buildInfoFieldGrammar' , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) , c (ListWith mod NoCommaFSep Token' String) + , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) -- TODO(leana8959): constraints go here @@ -745,6 +747,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 4e09ab4db23..eb6f3ae571c 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -88,7 +88,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for linker , hsc2hsOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) -- ^ options for hsc2hs - , pkgconfigDepends :: [PkgconfigDependency] + , pkgconfigDepends :: PreserveGrouping m (AttachPos m [Annotate m PkgconfigDependency]) -- ^ pkg-config packages that are used , frameworks :: [RelativePath Framework File] -- ^ support frameworks for Mac OS X @@ -193,6 +193,7 @@ unannotateBuildInfo bi = , jsppOptions = map unAnn $ join $ map snd $ jsppOptions bi , ldOptions = map unAnn $ join $ map snd $ ldOptions bi , hsc2hsOptions = map unAnn $ join $ map snd $ hsc2hsOptions bi + , pkgconfigDepends = map unAnn $ join $ map snd $ pkgconfigDepends bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 1bbaa686d24..459bd697d80 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -79,7 +79,7 @@ class HasBuildInfoWith mod a | a -> mod where hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) hsc2hsOptions = buildInfo @mod . hsc2hsOptions @mod - pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [PkgconfigDependency] + pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod PkgconfigDependency])) pkgconfigDepends = buildInfo @mod . pkgconfigDepends @mod frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [RelativePath Framework File] From 03343178f6a29f2c7dce2fd85441d93861ad763a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 12:18:44 +0200 Subject: [PATCH 049/111] stuck at frameworks field --- .../PackageDescription/FieldGrammar.hs | 59 +++++++++++-------- .../src/Distribution/Types/BuildInfo.hs | 3 +- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 39 insertions(+), 25 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index c3ec0ceafb7..0fc777592c7 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -106,6 +106,8 @@ import qualified Distribution.Compat.CharParsing as P import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.Lens as L +import Data.Kind + ------------------------------------------------------------------------------- -- PackageDescription ------------------------------------------------------------------------------- @@ -720,38 +722,49 @@ buildInfoFieldGrammar' , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) - , c (ListWith mod NoCommaFSep Token' String) - , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + -- , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + -- , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + -- , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + -- , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + -- , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) + -- , c (ListWith mod NoCommaFSep Token' String) + -- , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + -- , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + + -- , forall (from :: Type) (to :: FileOrDir). + -- Newtype + -- [Annotate mod (SymbolicPathX 'OnlyRelative from to)] + -- (ListWith mod FSep (RelativePathNT from to) (SymbolicPathX 'OnlyRelative from to)) + + , forall (from :: Type) (to :: FileOrDir). + c (ListWith mod FSep (RelativePathNT from to) (RelativePath from to)) + -- TODO(leana8959): constraints go here - , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + -- , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + -- , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => 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 + -- 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" (alaList' FSep RelativePathNT) L.frameworks -- TODO(leana8959): add more - targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends + -- targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends pure (BuildInfo {..}) -- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasAnn BuildInfoAnn BuildInfoAnn #-} diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index eb6f3ae571c..5c766b47829 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -90,7 +90,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ options for hsc2hs , pkgconfigDepends :: PreserveGrouping m (AttachPos m [Annotate m PkgconfigDependency]) -- ^ pkg-config packages that are used - , frameworks :: [RelativePath Framework File] + , frameworks :: PreserveGrouping m (AttachPos m [Annotate m (RelativePath Framework File)]) -- ^ support frameworks for Mac OS X , extraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)] -- ^ extra locations to find frameworks. @@ -194,6 +194,7 @@ unannotateBuildInfo bi = , ldOptions = map unAnn $ join $ map snd $ ldOptions bi , hsc2hsOptions = map unAnn $ join $ map snd $ hsc2hsOptions bi , pkgconfigDepends = map unAnn $ join $ map snd $ pkgconfigDepends bi + , frameworks = map unAnn $ join $ map snd $ frameworks bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 459bd697d80..e1e5a03eddb 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -82,7 +82,7 @@ class HasBuildInfoWith mod a | a -> mod where pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod PkgconfigDependency])) pkgconfigDepends = buildInfo @mod . pkgconfigDepends @mod - frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [RelativePath Framework File] + frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (RelativePath Framework File)])) frameworks = buildInfo @mod . frameworks @mod extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Framework)] From 74e272f9efa2e2f7282447cded06518e3519bfd9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 14:15:17 +0200 Subject: [PATCH 050/111] implement framework field --- .../PackageDescription/FieldGrammar.hs | 63 ++++++++----------- 1 file changed, 27 insertions(+), 36 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 0fc777592c7..f4684106988 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -106,8 +106,6 @@ import qualified Distribution.Compat.CharParsing as P import qualified Distribution.SPDX as SPDX import qualified Distribution.Types.Lens as L -import Data.Kind - ------------------------------------------------------------------------------- -- PackageDescription ------------------------------------------------------------------------------- @@ -722,49 +720,42 @@ buildInfoFieldGrammar' , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - -- , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - -- , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - -- , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - -- , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - -- , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) - -- , c (ListWith mod NoCommaFSep Token' String) - -- , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - -- , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - - -- , forall (from :: Type) (to :: FileOrDir). - -- Newtype - -- [Annotate mod (SymbolicPathX 'OnlyRelative from to)] - -- (ListWith mod FSep (RelativePathNT from to) (SymbolicPathX 'OnlyRelative from to)) - - , forall (from :: Type) (to :: FileOrDir). - c (ListWith mod FSep (RelativePathNT from to) (RelativePath from to)) - + , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) + , c (ListWith mod NoCommaFSep Token' String) + , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + , Newtype [Annotate mod (RelativePath Framework File)] (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) + , c (ListWith mod FSep (RelativePathNT Framework File) (RelativePath Framework File)) -- TODO(leana8959): constraints go here - -- , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - -- , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => 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" (alaList' FSep RelativePathNT) L.frameworks + 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 -- TODO(leana8959): add more - -- targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends + targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends pure (BuildInfo {..}) -- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasAnn BuildInfoAnn BuildInfoAnn #-} From aa59e8a2a2448b170a02165c4f8823b4885729d4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 14:44:51 +0200 Subject: [PATCH 051/111] add extraFrameworkDirs field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 4 ++++ Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index f4684106988..90db8e69b7f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -731,6 +731,9 @@ buildInfoFieldGrammar' , Newtype [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 [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))) + -- TODO(leana8959): constraints go here , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) @@ -752,6 +755,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 5c766b47829..276fb97f92e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -92,7 +92,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ pkg-config packages that are used , frameworks :: PreserveGrouping m (AttachPos m [Annotate m (RelativePath Framework File)]) -- ^ support frameworks for Mac OS X - , extraFrameworkDirs :: [SymbolicPath Pkg (Dir Framework)] + , extraFrameworkDirs :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg (Dir Framework))]) -- ^ extra locations to find frameworks. , asmSources :: [SymbolicPath Pkg File] -- ^ Assembly files. @@ -195,6 +195,7 @@ unannotateBuildInfo bi = , hsc2hsOptions = map unAnn $ join $ map snd $ hsc2hsOptions bi , pkgconfigDepends = map unAnn $ join $ map snd $ pkgconfigDepends bi , frameworks = map unAnn $ join $ map snd $ frameworks bi + , extraFrameworkDirs = map unAnn $ join $ map snd $ extraFrameworkDirs bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index e1e5a03eddb..929b677914b 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -85,7 +85,7 @@ class HasBuildInfoWith mod a | a -> mod where frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (RelativePath Framework File)])) frameworks = buildInfo @mod . frameworks @mod - extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Framework)] + extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Framework))])) extraFrameworkDirs = buildInfo @mod . extraFrameworkDirs @mod asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] From aa446b4a57630a198f123959a787ffa378eedecb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 14:50:14 +0200 Subject: [PATCH 052/111] add asmSources field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 5 +++-- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 6 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 90db8e69b7f..026b00987f8 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -730,9 +730,10 @@ buildInfoFieldGrammar' , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) , Newtype [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 [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 [Annotate mod (SymbolicPath Pkg File)] (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) + , c (ListWith mod VCat (SymbolicPathNT Pkg File) (SymbolicPath Pkg File)) -- TODO(leana8959): constraints go here @@ -753,9 +754,9 @@ buildInfoFieldGrammar' = do 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 + astSources <- monoidalFieldAla' "asm-sources" (alaListWith' @mod @VCat @(SymbolicPathNT Pkg File) @(SymbolicPath Pkg File)) L.asmSources -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 276fb97f92e..ebed01999f3 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -94,7 +94,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ support frameworks for Mac OS X , extraFrameworkDirs :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg (Dir Framework))]) -- ^ extra locations to find frameworks. - , asmSources :: [SymbolicPath Pkg File] + , asmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) -- ^ Assembly files. , cmmSources :: [SymbolicPath Pkg File] -- ^ C-- files. @@ -196,6 +196,7 @@ unannotateBuildInfo bi = , pkgconfigDepends = map unAnn $ join $ map snd $ pkgconfigDepends bi , frameworks = map unAnn $ join $ map snd $ frameworks bi , extraFrameworkDirs = map unAnn $ join $ map snd $ extraFrameworkDirs bi + , asmSources = map unAnn $ join $ map snd $ asmSources bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 929b677914b..fa6ce51f6f9 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -88,7 +88,7 @@ class HasBuildInfoWith mod a | a -> mod where extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Framework))])) extraFrameworkDirs = buildInfo @mod . extraFrameworkDirs @mod - asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) asmSources = buildInfo @mod . asmSources @mod cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] From 05173e828b2504b9eef4b1ca29212396aa653cea Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 15:03:27 +0200 Subject: [PATCH 053/111] add cmmSources field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 026b00987f8..8156f7f2f22 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -757,6 +757,7 @@ buildInfoFieldGrammar' = do 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 astSources <- 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index ebed01999f3..040d52622e7 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -96,7 +96,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ extra locations to find frameworks. , asmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) -- ^ Assembly files. - , cmmSources :: [SymbolicPath Pkg File] + , cmmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) -- ^ C-- files. , cSources :: [SymbolicPath Pkg File] , cxxSources :: [SymbolicPath Pkg File] @@ -197,6 +197,7 @@ unannotateBuildInfo bi = , frameworks = map unAnn $ join $ map snd $ frameworks bi , extraFrameworkDirs = map unAnn $ join $ map snd $ extraFrameworkDirs bi , asmSources = map unAnn $ join $ map snd $ asmSources bi + , cmmSources = map unAnn $ join $ map snd $ cmmSources bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index fa6ce51f6f9..fb3246c6e89 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -91,7 +91,7 @@ class HasBuildInfoWith mod a | a -> mod where asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) asmSources = buildInfo @mod . asmSources @mod - cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) cmmSources = buildInfo @mod . cmmSources @mod cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] From 08b9326261ef431dfddb5b65b33a18e8c17cc2d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 15:06:16 +0200 Subject: [PATCH 054/111] add cSources field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 8156f7f2f22..e7d91a3dbb4 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -758,6 +758,7 @@ buildInfoFieldGrammar' = do extraFrameworkDirs <- monoidalFieldAla' "extra-framework-dirs" (alaListWith' @mod @FSep @(SymbolicPathNT Pkg (Dir Framework)) @(SymbolicPath Pkg (Dir Framework))) L.extraFrameworkDirs astSources <- 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 040d52622e7..0378dcfad37 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -98,7 +98,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Assembly files. , cmmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) -- ^ C-- files. - , cSources :: [SymbolicPath Pkg File] + , cSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) , cxxSources :: [SymbolicPath Pkg File] , jsSources :: [SymbolicPath Pkg File] , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] @@ -198,6 +198,7 @@ unannotateBuildInfo bi = , extraFrameworkDirs = map unAnn $ join $ map snd $ extraFrameworkDirs bi , asmSources = map unAnn $ join $ map snd $ asmSources bi , cmmSources = map unAnn $ join $ map snd $ cmmSources bi + , cSources = map unAnn $ join $ map snd $ cSources bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index fb3246c6e89..ffa6051491e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -94,7 +94,7 @@ class HasBuildInfoWith mod a | a -> mod where cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) cmmSources = buildInfo @mod . cmmSources @mod - cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) cSources = buildInfo @mod . cSources @mod cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] From 29e0cd79eae328e3af4b96d3bb1e24cee8da6842 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 15:12:32 +0200 Subject: [PATCH 055/111] add cxxSources field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index e7d91a3dbb4..30d8b887694 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -759,6 +759,7 @@ buildInfoFieldGrammar' = do astSources <- 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 0378dcfad37..130fe850e5e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -99,7 +99,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo , cmmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) -- ^ C-- files. , cSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) - , cxxSources :: [SymbolicPath Pkg File] + , cxxSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) , jsSources :: [SymbolicPath Pkg File] , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] -- ^ where to look for the Haskell module hierarchy @@ -199,6 +199,7 @@ unannotateBuildInfo bi = , asmSources = map unAnn $ join $ map snd $ asmSources bi , cmmSources = map unAnn $ join $ map snd $ cmmSources bi , cSources = map unAnn $ join $ map snd $ cSources bi + , cxxSources = map unAnn $ join $ map snd $ cxxSources bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index ffa6051491e..ca71ef7d7de 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -97,7 +97,7 @@ class HasBuildInfoWith mod a | a -> mod where cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) cSources = buildInfo @mod . cSources @mod - cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) cxxSources = buildInfo @mod . cxxSources @mod jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] From 0d99f5216fa6e29d3f0221a58ea2dd06d9fac019 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 15:14:56 +0200 Subject: [PATCH 056/111] add jsSources field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 4 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 30d8b887694..6bd30442dc7 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -760,6 +760,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 130fe850e5e..4b59becea1b 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -100,7 +100,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ C-- files. , cSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) , cxxSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) - , jsSources :: [SymbolicPath Pkg File] + , jsSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] -- ^ where to look for the Haskell module hierarchy , -- NB: these are symbolic paths are not relative paths, @@ -200,6 +200,7 @@ unannotateBuildInfo bi = , cmmSources = map unAnn $ join $ map snd $ cmmSources bi , cSources = map unAnn $ join $ map snd $ cSources bi , cxxSources = map unAnn $ join $ map snd $ cxxSources bi + , jsSources = map unAnn $ join $ map snd $ jsSources bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index ca71ef7d7de..63d4fcff625 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -100,7 +100,7 @@ class HasBuildInfoWith mod a | a -> mod where cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) cxxSources = buildInfo @mod . cxxSources @mod - jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg File] + jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) jsSources = buildInfo @mod . jsSources @mod hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Source)] From dd7149ea3b5649d9ea1dba307a56f0e50e2f4622 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 15:18:12 +0200 Subject: [PATCH 057/111] add hsSourceDirs field --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 6bd30442dc7..338cc28e221 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -734,7 +734,7 @@ buildInfoFieldGrammar' , c (ListWith mod FSep (SymbolicPathNT Pkg (Dir Framework)) (SymbolicPath Pkg (Dir Framework))) , Newtype [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))) -- TODO(leana8959): constraints go here , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) @@ -761,6 +761,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more @@ -808,7 +809,7 @@ hsSourceDirsGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , forall from to. c (List FSep (SymbolicPathNT from to) (SymbolicPath from to)) + , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) ) => g mod (BuildInfoWith mod) [SymbolicPath Pkg (Dir Source)] hsSourceDirsGrammar = From 994902708ab87f6268cd81a37eb13cf1642241c4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 15:54:32 +0200 Subject: [PATCH 058/111] make hsSourceDirs polymorphic /and/ backward compatible --- .../PackageDescription/FieldGrammar.hs | 33 ++++++++++++------- .../src/Distribution/Types/BuildInfo.hs | 3 +- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 25 insertions(+), 13 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 338cc28e221..7b6bcaf0cde 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -735,6 +735,12 @@ buildInfoFieldGrammar' , Newtype [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 (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + , Newtype [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))) + -- TODO(leana8959): constraints go here , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) @@ -761,7 +767,7 @@ buildInfoFieldGrammar' = do 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 + hsSourceDirs <- hsSourceDirsGrammar @mod -- TODO(leana8959): add more @@ -809,18 +815,23 @@ hsSourceDirsGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , c (List FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + + -- is a monoid with or without annotation + , Monoid (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + + , Newtype [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) [SymbolicPath Pkg (Dir Source)] + => g mod (BuildInfoWith mod) (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) hsSourceDirsGrammar = - (++) - <$> monoidalFieldAla "hs-source-dirs" formatHsSourceDirs L.hsSourceDirs - <*> monoidalFieldAla "hs-source-dir" (alaList' FSep SymbolicPathNT) 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 - wrongLens f bi = (\fps -> set (L.hsSourceDirs @mod) fps bi) <$> f [] + (<>) + <$> 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 + 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)] #-} diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 4b59becea1b..ce9d3e0131a 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -101,7 +101,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo , cSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) , cxxSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) , jsSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) - , hsSourceDirs :: [SymbolicPath Pkg (Dir Source)] + , hsSourceDirs :: PreserveGrouping m (AttachPos 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 @@ -201,6 +201,7 @@ unannotateBuildInfo bi = , cSources = map unAnn $ join $ map snd $ cSources bi , cxxSources = map unAnn $ join $ map snd $ cxxSources bi , jsSources = map unAnn $ join $ map snd $ jsSources bi + , hsSourceDirs = map unAnn $ join $ map snd $ hsSourceDirs bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 63d4fcff625..eaf82d1c0a9 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -103,7 +103,7 @@ class HasBuildInfoWith mod a | a -> mod where jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) jsSources = buildInfo @mod . jsSources @mod - hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [SymbolicPath Pkg (Dir Source)] + hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) hsSourceDirs = buildInfo @mod . hsSourceDirs @mod otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ModuleName] From 9bc7f54c0068d4002a2269f4f0f9b93de14a5820 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 10 Apr 2026 16:17:17 +0200 Subject: [PATCH 059/111] add other modules field --- .../Distribution/PackageDescription/FieldGrammar.hs | 10 +++++++--- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 3 ++- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 10 insertions(+), 5 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 7b6bcaf0cde..51991c9d609 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -666,7 +666,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 @@ -741,6 +741,9 @@ buildInfoFieldGrammar' , Newtype [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 [Annotate mod ModuleName] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + -- TODO(leana8959): constraints go here , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) @@ -768,6 +771,7 @@ buildInfoFieldGrammar' = do 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 -- TODO(leana8959): add more @@ -984,8 +988,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 :: [Annotate mod ModuleName] -> ListWith mod VCat (MQuoted ModuleName) ModuleName +formatOtherModules = List ------------------------------------------------------------------------------- -- newtypes diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index ce9d3e0131a..a35a9282d7b 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -105,7 +105,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ 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 (AttachPos 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) @@ -202,6 +202,7 @@ unannotateBuildInfo bi = , cxxSources = map unAnn $ join $ map snd $ cxxSources bi , jsSources = map unAnn $ join $ map snd $ jsSources bi , hsSourceDirs = map unAnn $ join $ map snd $ hsSourceDirs bi + , otherModules = map unAnn $ join $ map snd $ otherModules bi -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index eaf82d1c0a9..38ba06aac74 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -106,7 +106,7 @@ class HasBuildInfoWith mod a | a -> mod where hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) hsSourceDirs = buildInfo @mod . hsSourceDirs @mod - otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ModuleName] + otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod ModuleName])) otherModules = buildInfo @mod . otherModules @mod virtualModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ModuleName] From 20236f8d048341fe345aa4c3aef7b882a3010715 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 09:38:48 +0200 Subject: [PATCH 060/111] example implementation of printer monoidalFieldAla --- .../src/Distribution/FieldGrammar/Parsec.hs | 6 ++--- .../src/Distribution/FieldGrammar/Pretty.hs | 25 ++++--------------- 2 files changed, 7 insertions(+), 24 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index e76bac1df23..26ee8a9a1f4 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -394,8 +394,6 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar Mod.HasAnn s (Positions, Bool) booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - -- TODO(leana8959): implement position - parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Positions, Bool) parser v fields = case Map.lookup fn fields of Nothing -> pure (noPos, def) @@ -411,7 +409,6 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where noPos = Positions Nothing Nothing Nothing - -- TODO(leana8959): implement monoidalFieldAla -- TODO(leana8959): implement all methods -- This function allows us to manage the position coming from a parsed field @@ -436,7 +433,8 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) parseOne v (MkNamelessField pos fls) = do (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls - pure (Positions (Just pos) (Nothing {- TODO(leana8959): "convert linePos" linePos -}) Nothing, x) + -- NOTE(leana8959): do we need all three positions here + pure (Positions (Just pos) Nothing Nothing, x) ------------------------------------------------------------------------------- -- Parsec diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index fb1edcb8bd2..3ee3381555d 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -93,26 +93,6 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where where pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) - -- -- TODO(leana8959): push out the Position - -- monoidalFieldAlaAnn - -- :: forall m b a s - -- . (Pretty b, Newtype a b) - -- => FieldName - -- -> (a -> b) - -- -> ALens' s [(Positions, a)] - -- -> PrettyFieldGrammar m s [(Positions, a)] - -- monoidalFieldAlaAnn fn _pack l = PrettyFG pp - -- where - -- pp v s = - -- -- TODO(leana8959): implement more than one field printing - -- -- - -- -- Here the list represents the "groups" of fields that are defined separately but merged by - -- -- monoidal field. - -- -- - -- -- They should be displayed separately anyway. - -- let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) - -- in ppField fn mempty - prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) where pp xs = @@ -133,6 +113,11 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where availableSince _ _ = id hiddenField _ = PrettyFG (\_ -> mempty) +instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where + monoidalFieldAla' fn _pack l = PrettyFG $ \v s -> + let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) + in ppField fn mempty + ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc | PP.isEmpty fielddoc = [] From f1e811b5de5fe683f41163e91bbab6182df70208 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 09:56:22 +0200 Subject: [PATCH 061/111] attach trivia to boolean --- .../src/Distribution/FieldGrammar/Class.hs | 6 +++--- .../src/Distribution/FieldGrammar/Parsec.hs | 17 ++++++++++------- .../src/Distribution/FieldGrammar/Pretty.hs | 5 +++++ .../src/Distribution/Types/BuildInfo.hs | 4 ++-- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 5 files changed, 21 insertions(+), 13 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 2571a93d53a..cb37b3da4d9 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -33,7 +33,7 @@ import Distribution.Fields.Field import Distribution.Utils.ShortText import Data.Kind -import Distribution.Types.Modify (AttachPos, PreserveGrouping) +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) import qualified Distribution.Types.Modify as Mod type FieldGrammar = FieldGrammarWith Mod.HasNoAnn @@ -85,11 +85,11 @@ class booleanFieldDef' :: FieldName -- ^ field name - -> ALens' s (AttachPos m Bool) + -> ALens' s (AttachPos m (Annotate m Bool)) -- ^ lens into the field -> Bool -- ^ default - -> g m s (AttachPos m Bool) + -> g m s (AttachPos m (Annotate m Bool)) -- | Optional field. optionalFieldAla diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 26ee8a9a1f4..b10602e2565 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -387,25 +387,28 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where :: forall s . FieldName -- ^ field name - -> ALens' s (Positions, Bool) + -> ALens' s (Positions, Ann SurroundingText Bool) -- ^ lens into the field -> Bool -- ^ default - -> ParsecFieldGrammar Mod.HasAnn s (Positions, Bool) + -> ParsecFieldGrammar Mod.HasAnn s (Positions, Ann SurroundingText Bool) booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Positions, Bool) + parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Positions, Ann SurroundingText Bool) parser v fields = case Map.lookup fn fields of - Nothing -> pure (noPos, def) - Just [] -> pure (noPos, def) + 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' = (noPos, Ann IsInserted def) - parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, Bool) + parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, Ann SurroundingText Bool) parseOne v (MkNamelessField pos fls) = do - (noPos,) <$> runFieldParser pos parsec v fls + -- TODO(leana8959): always print the casing correct one, it's not a whitespace crisis + (noPos,) . Ann mempty <$> runFieldParser pos parsec v fls noPos = Positions Nothing Nothing Nothing diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 3ee3381555d..f0a15182f6d 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -118,6 +118,11 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) in ppField fn mempty + booleanFieldDef' fn l def = PrettyFG $ \_v s -> + let (pos, Ann t b) = aview l s + in -- TODO(leana8959): push out position + ppField fn $ applyTriviaDoc t (PP.text (show b)) + ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc | PP.isEmpty fielddoc = [] diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index a35a9282d7b..1150ae321d7 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -53,7 +53,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn -- Consider refactoring into executable and library versions. data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo - { buildable :: AttachPos m Bool + { buildable :: AttachPos m (Annotate m Bool) -- ^ component is buildable here , buildTools :: PreserveGrouping m (AttachPos m [Annotate m LegacyExeDependency]) -- ^ Tools needed to build this bit. @@ -182,7 +182,7 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi - { buildable = snd $ buildable bi + { buildable = unAnn $ snd $ buildable bi , buildTools = map unAnn $ join $ map snd $ buildTools bi , buildToolDepends = map unAnn $ join $ map snd $ buildToolDepends bi , cppOptions = map unAnn $ join $ map snd $ cppOptions bi diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 38ba06aac74..5b0f33eaa51 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -46,7 +46,7 @@ type HasBuildInfoAnn = HasBuildInfoWith Mod.HasAnn class HasBuildInfoWith mod a | a -> mod where buildInfo :: Lens' a (BuildInfoWith mod) - buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod Bool) + buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod (Annotate mod Bool)) buildable = buildInfo @mod . buildable @mod buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod LegacyExeDependency])) From 2b34b0353e8d75951d676bfd21ec2c4cdc52a90a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 10:01:36 +0200 Subject: [PATCH 062/111] relax pretty field grammar output type --- Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs | 11 +++++++---- Cabal-syntax/src/Distribution/Fields/Pretty.hs | 5 ++++- Cabal-syntax/src/Distribution/Types/Modify.hs | 6 ++++++ 3 files changed, 17 insertions(+), 5 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index f0a15182f6d..291febfefb6 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -15,6 +15,7 @@ import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude import Distribution.Trivia +import Distribution.Types.Modify import Distribution.Fields.Field (FieldName) import Distribution.Fields.Pretty (PrettyField (..)) import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3) @@ -28,7 +29,7 @@ import qualified Distribution.Types.Modify as Mod -- 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 -> s -> [PrettyField ()] + { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField (WithPos m)] } deriving (Functor) @@ -39,7 +40,7 @@ instance Applicative (PrettyFieldGrammar m s) where -- | We can use 'PrettyFieldGrammar' to pp print the @s@. -- -- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> [PrettyField ()] +prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> [PrettyField (WithPos m)] prettyFieldGrammar = flip fieldGrammarPretty instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where @@ -116,12 +117,14 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where monoidalFieldAla' fn _pack l = PrettyFG $ \v s -> let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) - in ppField fn mempty + in -- ppField fn mempty + [] booleanFieldDef' fn l def = PrettyFG $ \_v s -> let (pos, Ann t b) = aview l s in -- TODO(leana8959): push out position - ppField fn $ applyTriviaDoc t (PP.text (show b)) + -- ppField fn $ applyTriviaDoc t (PP.text (show b)) + [] ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index d458ca41e80..0ec802eb060 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -25,7 +25,7 @@ import Distribution.Compat.Prelude import Distribution.Pretty (showToken) import Prelude () -import Distribution.Fields.Field (FieldName) +import Distribution.Fields.Field (FieldName, Name) import Distribution.Utils.Generic (fromUTF8BS) import qualified Distribution.Fields.Parser as P @@ -39,6 +39,9 @@ import qualified Text.PrettyPrint as PP -- conjunction with @PrettyField@. data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment +-- 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 data PrettyField ann = PrettyField ann FieldName PP.Doc | PrettySection ann FieldName [PP.Doc] [PrettyField ann] diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 1cc02f8f511..43bf8d492da 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -18,6 +18,8 @@ data HasAnnotation | HasNoAnn deriving (Show, Read, Eq, Ord, Data) +-- Type family combinators that can compose and attach concrete syntax informations conditionally. + type family Annotate (m :: HasAnnotation) (a :: Type) where Annotate HasNoAnn a = a Annotate HasAnn a = Ann SurroundingText a @@ -26,6 +28,10 @@ type family AttachPos (m :: HasAnnotation) (a :: Type) where AttachPos HasAnn a = (Positions, a) AttachPos HasNoAnn a = a +type family WithPos (m :: HasAnnotation) where + WithPos HasAnn = Positions + WithPos HasNoAnn = () + type family PreserveGrouping (m :: HasAnnotation) (a :: Type) where PreserveGrouping HasAnn a = [a] PreserveGrouping HasNoAnn a = a From 15eadb8708e4c6c363b6f3dc94d4b96dff969bfe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 10:18:37 +0200 Subject: [PATCH 063/111] leave some notes --- .../src/Distribution/FieldGrammar/Pretty.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 291febfefb6..6419bd57e34 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -130,3 +130,16 @@ ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc | PP.isEmpty fielddoc = [] | otherwise = [PrettyField () name fielddoc] + +-- NOTE(leana8959): do we need position"s" +ppFieldPos :: FieldName -> Trivia SurroundingText -> [(Positions, Doc)] -> [PrettyField Positions] +ppFieldPos name trivia possFieldDocs = case trivia of + -- TODO(leana8959): should position always exist (it's a maybe now) + + -- TODO(leana8959): Each fieldDoc should carry their associated fieldname's position + -- because they don't always have the same position + -- We then do a post process sorting + IsInserted -> [] -- Absorb + _notInserted -> + possFieldDocs + >>= \(_, fieldDoc) -> [ PrettyField undefined name fieldDoc ] From 2fa1fcac9b018ae5889d929136962bc86ff2d059 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 11:31:36 +0200 Subject: [PATCH 064/111] insert real position in cabalparsec and parsecparser --- .../src/Distribution/FieldGrammar/Parsec.hs | 11 +++++---- .../src/Distribution/FieldGrammar/Pretty.hs | 2 +- Cabal-syntax/src/Distribution/Parsec.hs | 11 ++++++++- .../Distribution/Parsec/FieldLineStream.hs | 24 ++++++++++++------- 4 files changed, 33 insertions(+), 15 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index b10602e2565..fe485de656c 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -537,7 +537,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 6419bd57e34..18844204efa 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -142,4 +142,4 @@ ppFieldPos name trivia possFieldDocs = case trivia of IsInserted -> [] -- Absorb _notInserted -> possFieldDocs - >>= \(_, fieldDoc) -> [ PrettyField undefined name fieldDoc ] + >>= \(poss, fieldDoc) -> [ PrettyField undefined name fieldDoc ] diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index 41675594f4c..c06d666d663 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -76,7 +76,7 @@ import Distribution.Parsec.Error (PError (..), PErrorWithSource (..), showPError 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) @@ -110,6 +110,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 @@ -191,6 +193,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 = 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 From 835c50a1431ad57b84f9a0fedf6562308c7f04c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 12:12:26 +0200 Subject: [PATCH 065/111] thread through real offsetted position --- .../src/Distribution/FieldGrammar/Parsec.hs | 18 +++++++++++------ Cabal-syntax/src/Distribution/Trivia.hs | 20 ++----------------- 2 files changed, 14 insertions(+), 24 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index fe485de656c..762f14e4b7d 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -407,10 +407,15 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, Ann SurroundingText Bool) parseOne v (MkNamelessField pos fls) = do - -- TODO(leana8959): always print the casing correct one, it's not a whitespace crisis - (noPos,) . Ann mempty <$> runFieldParser pos parsec v fls + (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition parsec) v fls + pure (Positions pos fieldLinePos, Ann mempty x) - noPos = Positions Nothing Nothing Nothing + -- TODO(leana8959): the model doesn't fit here + -- + -- we don't care about the position if the thing is inserted anyways + -- actually the model should be more like `Ann Positions Bool` + + noPos = undefined -- TODO(leana8959): implement all methods @@ -426,6 +431,8 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> (a -> b) -> ALens' s [(Positions, a)] -> ParsecFieldGrammar Mod.HasAnn s [(Positions, a)] + -- (Position, a) + -- (Position, Truc Ann) monoidalFieldAla' fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] @@ -435,9 +442,8 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, b) parseOne v (MkNamelessField pos fls) = do - (linePos, x) <- runFieldParser pos (liftA2 (,) (liftParsec P.getPosition) parsec) v fls - -- NOTE(leana8959): do we need all three positions here - pure (Positions (Just pos) Nothing Nothing, x) + (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition parsec) v fls + pure (Positions pos fieldLinePos, x) ------------------------------------------------------------------------------- -- Parsec diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index dd6cdb3412f..a54c1ef4233 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -32,27 +32,11 @@ instance Semigroup SurroundingText where -- | A collection of different kinds of 'Position's, describing -- the provenance of a data. data Positions = Positions - { fieldNamePos :: Maybe Position - , fieldLinePos :: Maybe Position - -- TODO(leana8959): will need to be patched at goSection - -- field grammar don't see sections - , fieldSectionPos :: Maybe Position + { fieldNamePos :: Position + , fieldLinePos :: Position } deriving (Show, Eq, Ord, Read, Data) -instance Semigroup Positions where - i <> j = - Positions - { fieldNamePos = field fieldNamePos - , fieldLinePos = field fieldLinePos - , fieldSectionPos = field fieldSectionPos - } - where - field a = getLast (Last (a i) <> Last (a j)) - -instance Monoid Positions where - mempty = Positions Nothing Nothing Nothing - data Trivia t = HasTrivia t | ExactRepresentation String From 557bc2bcb1ef8a6a028f3b23d5bbb379c8878f9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 12:20:27 +0200 Subject: [PATCH 066/111] remodel buildable boolean field annotation - position can never appear when inserted - there is no string annotation (we ignore the casing here because warning means the cabal file is not valid) --- .../src/Distribution/FieldGrammar/Class.hs | 6 +++--- .../src/Distribution/FieldGrammar/Parsec.hs | 19 ++++++------------- .../src/Distribution/FieldGrammar/Pretty.hs | 2 +- .../src/Distribution/Types/BuildInfo.hs | 6 +++--- .../src/Distribution/Types/BuildInfo/Lens.hs | 5 +++-- Cabal-syntax/src/Distribution/Types/Modify.hs | 8 +++++--- 6 files changed, 21 insertions(+), 25 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index cb37b3da4d9..9780ce75eaa 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -33,7 +33,7 @@ import Distribution.Fields.Field import Distribution.Utils.ShortText import Data.Kind -import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate, AnnotateWith) import qualified Distribution.Types.Modify as Mod type FieldGrammar = FieldGrammarWith Mod.HasNoAnn @@ -85,11 +85,11 @@ class booleanFieldDef' :: FieldName -- ^ field name - -> ALens' s (AttachPos m (Annotate m Bool)) + -> ALens' s (AnnotateWith Positions m Bool) -- ^ lens into the field -> Bool -- ^ default - -> g m s (AttachPos m (Annotate m Bool)) + -> g m s (AnnotateWith Positions m Bool) -- | Optional field. optionalFieldAla diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 762f14e4b7d..725970bbcc4 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -387,14 +387,14 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where :: forall s . FieldName -- ^ field name - -> ALens' s (Positions, Ann SurroundingText Bool) + -> ALens' s (Ann Positions Bool) -- ^ lens into the field -> Bool -- ^ default - -> ParsecFieldGrammar Mod.HasAnn s (Positions, Ann SurroundingText Bool) + -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions Bool) booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Positions, Ann SurroundingText Bool) + parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Ann Positions Bool) parser v fields = case Map.lookup fn fields of Nothing -> pure def' Just [] -> pure def' @@ -403,19 +403,12 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where warnMultipleSingularFields fn xs NE.last <$> traverse (parseOne v) (y :| ys) where - def' = (noPos, Ann IsInserted def) + def' = Ann IsInserted def - parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Positions, Ann SurroundingText Bool) + 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 (Positions pos fieldLinePos, Ann mempty x) - - -- TODO(leana8959): the model doesn't fit here - -- - -- we don't care about the position if the thing is inserted anyways - -- actually the model should be more like `Ann Positions Bool` - - noPos = undefined + pure $ Ann (HasTrivia $ Positions pos fieldLinePos) x -- TODO(leana8959): implement all methods diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 18844204efa..0b04789e2b5 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -121,7 +121,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where [] booleanFieldDef' fn l def = PrettyFG $ \_v s -> - let (pos, Ann t b) = aview l s + let Ann t b = aview l s in -- TODO(leana8959): push out position -- ppField fn $ applyTriviaDoc t (PP.text (show b)) [] diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 1150ae321d7..f17e9801f30 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -41,7 +41,7 @@ import Language.Haskell.Extension import Data.Kind -import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate, AnnotateWith) import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn @@ -53,7 +53,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn -- Consider refactoring into executable and library versions. data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo - { buildable :: AttachPos m (Annotate m Bool) + { buildable :: AnnotateWith Positions m Bool -- ^ component is buildable here , buildTools :: PreserveGrouping m (AttachPos m [Annotate m LegacyExeDependency]) -- ^ Tools needed to build this bit. @@ -182,7 +182,7 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = bi - { buildable = unAnn $ snd $ buildable bi + { buildable = unAnn $ buildable bi , buildTools = map unAnn $ join $ map snd $ buildTools bi , buildToolDepends = map unAnn $ join $ map snd $ buildToolDepends bi , cppOptions = map unAnn $ join $ map snd $ cppOptions bi diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 5b0f33eaa51..1a9d0b047b3 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -36,8 +36,9 @@ 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 (AttachPos, PreserveGrouping, Annotate) +import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate, AnnotateWith) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn @@ -46,7 +47,7 @@ type HasBuildInfoAnn = HasBuildInfoWith Mod.HasAnn class HasBuildInfoWith mod a | a -> mod where buildInfo :: Lens' a (BuildInfoWith mod) - buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AttachPos mod (Annotate mod Bool)) + buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AnnotateWith Positions mod Bool) buildable = buildInfo @mod . buildable @mod buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod LegacyExeDependency])) diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 43bf8d492da..de7a2138fd5 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -20,9 +20,11 @@ data HasAnnotation -- Type family combinators that can compose and attach concrete syntax informations conditionally. -type family Annotate (m :: HasAnnotation) (a :: Type) where - Annotate HasNoAnn a = a - Annotate HasAnn a = Ann SurroundingText a +type family AnnotateWith (trivia :: Type) (m :: HasAnnotation) (a :: Type) where + AnnotateWith t HasNoAnn a = a + AnnotateWith t HasAnn a = Ann t a + +type Annotate (m :: HasAnnotation) (a :: Type) = AnnotateWith SurroundingText m a type family AttachPos (m :: HasAnnotation) (a :: Type) where AttachPos HasAnn a = (Positions, a) From 49db99818c8c4ac3bef355e679a058dc0788f921 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 13:32:53 +0200 Subject: [PATCH 067/111] remove random comment --- Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 725970bbcc4..c6050ce7329 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -380,9 +380,6 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where hiddenField = id instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where - - -- TODO(leana8959): remove multiplicity here because it doesn't have merging - booleanFieldDef' :: forall s . FieldName @@ -424,8 +421,6 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> (a -> b) -> ALens' s [(Positions, a)] -> ParsecFieldGrammar Mod.HasAnn s [(Positions, a)] - -- (Position, a) - -- (Position, Truc Ann) monoidalFieldAla' fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] From ec5ac595c13726c8cfc835ea88ef981c78b720af Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 13:46:04 +0200 Subject: [PATCH 068/111] push out fieldname position --- .../src/Distribution/FieldGrammar/Pretty.hs | 28 ++++++++----------- Cabal-syntax/src/Distribution/Types/Modify.hs | 3 +- 2 files changed, 13 insertions(+), 18 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 0b04789e2b5..3ffadc34d03 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -14,6 +14,7 @@ import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude +import Distribution.Parsec.Position import Distribution.Trivia import Distribution.Types.Modify import Distribution.Fields.Field (FieldName) @@ -117,29 +118,22 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where monoidalFieldAla' fn _pack l = PrettyFG $ \v s -> let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) - in -- ppField fn mempty - [] + in ppFieldPos fn bs booleanFieldDef' fn l def = PrettyFG $ \_v s -> let Ann t b = aview l s - in -- TODO(leana8959): push out position - -- ppField fn $ applyTriviaDoc t (PP.text (show b)) - [] + in case t of + HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] + IsInserted -> mempty ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc | PP.isEmpty fielddoc = [] | otherwise = [PrettyField () name fielddoc] --- NOTE(leana8959): do we need position"s" -ppFieldPos :: FieldName -> Trivia SurroundingText -> [(Positions, Doc)] -> [PrettyField Positions] -ppFieldPos name trivia possFieldDocs = case trivia of - -- TODO(leana8959): should position always exist (it's a maybe now) - - -- TODO(leana8959): Each fieldDoc should carry their associated fieldname's position - -- because they don't always have the same position - -- We then do a post process sorting - IsInserted -> [] -- Absorb - _notInserted -> - possFieldDocs - >>= \(poss, fieldDoc) -> [ PrettyField undefined name fieldDoc ] +-- TODO(leana8959): push out doc position +ppFieldPos :: FieldName -> [(Positions, Doc)] -> [PrettyField Position] +ppFieldPos name possFieldDocs = + [ PrettyField (fieldNamePos poss) name fieldDoc + | (poss, fieldDoc) <- possFieldDocs + ] diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index de7a2138fd5..5148b230379 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -7,6 +7,7 @@ -- Types that can be used as modifiers module Distribution.Types.Modify where +import Distribution.Parsec.Position import Distribution.Trivia import Data.Data @@ -31,7 +32,7 @@ type family AttachPos (m :: HasAnnotation) (a :: Type) where AttachPos HasNoAnn a = a type family WithPos (m :: HasAnnotation) where - WithPos HasAnn = Positions + WithPos HasAnn = Position WithPos HasNoAnn = () type family PreserveGrouping (m :: HasAnnotation) (a :: Type) where From 349099c98ae8c606d6b7f60188c15b6f9d2ae701 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 13:46:44 +0200 Subject: [PATCH 069/111] run fourmolu --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 2 +- .../src/Distribution/FieldGrammar/Class.hs | 16 ++-- .../Distribution/FieldGrammar/FieldDescrs.hs | 4 +- .../src/Distribution/FieldGrammar/Newtypes.hs | 2 +- .../src/Distribution/FieldGrammar/Parsec.hs | 14 ++-- .../src/Distribution/FieldGrammar/Pretty.hs | 30 ++++---- .../PackageDescription/Configuration.hs | 2 +- .../PackageDescription/FieldGrammar.hs | 73 +++++++++---------- .../PackageDescription/PrettyPrint.hs | 2 +- .../src/Distribution/Parsec/Position.hs | 2 +- Cabal-syntax/src/Distribution/Trivia.hs | 3 +- .../src/Distribution/Types/BuildInfo.hs | 17 ++--- .../src/Distribution/Types/BuildInfo/Lens.hs | 4 +- Cabal-syntax/src/Distribution/Types/Modify.hs | 4 +- .../src/Distribution/Types/PackageName.hs | 1 + 15 files changed, 85 insertions(+), 91 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index 3ae9a435f2f..c94c3b6128a 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 9780ce75eaa..b6f04cad8eb 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableSuperClasses #-} module Distribution.FieldGrammar.Class @@ -26,14 +26,14 @@ import Prelude () import Distribution.CabalSpecVersion (CabalSpecVersion) import Distribution.Compat.Newtype (Newtype) -import Distribution.Trivia -import Distribution.Parsec.Position (Position) 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 (AttachPos, PreserveGrouping, Annotate, AnnotateWith) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type FieldGrammar = FieldGrammarWith Mod.HasNoAnn diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs index bf010b483bd..f0c1910e420 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 8bcd320badb..270b5590c1b 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index c6050ce7329..88262c241f4 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE TupleSections #-} +{-# 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. @@ -93,9 +93,9 @@ import Distribution.FieldGrammar.Class import Distribution.Fields.Field import Distribution.Fields.ParseResult import Distribution.Parsec -import Distribution.Trivia import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) +import Distribution.Trivia import Distribution.Types.Modify (AttachPos) import qualified Distribution.Types.Modify as Mod @@ -383,11 +383,11 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where booleanFieldDef' :: forall s . FieldName - -- ^ field name + -- \^ field name -> ALens' s (Ann Positions Bool) - -- ^ lens into the field + -- \^ lens into the field -> Bool - -- ^ default + -- \^ default -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions Bool) booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 3ffadc34d03..79b31d31e64 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} module Distribution.FieldGrammar.Pretty ( PrettyFieldGrammar @@ -14,12 +14,12 @@ import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.Compat.Newtype import Distribution.Compat.Prelude -import Distribution.Parsec.Position -import Distribution.Trivia -import Distribution.Types.Modify import Distribution.Fields.Field (FieldName) import Distribution.Fields.Pretty (PrettyField (..)) +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 @@ -117,14 +117,14 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where monoidalFieldAla' fn _pack l = PrettyFG $ \v s -> - let bs :: [(Positions, Doc)] = fmap (prettyVersioned v . pack' _pack) <$> (aview l s) - in ppFieldPos fn bs + let bs = fmap (prettyVersioned v . pack' _pack) <$> aview l s + in ppFieldPos fn bs booleanFieldDef' fn l def = PrettyFG $ \_v s -> - let Ann t b = aview l s - in case t of - HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] - IsInserted -> mempty + let Ann t b = aview l s + in case t of + HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] + IsInserted -> mempty ppField :: FieldName -> Doc -> [PrettyField ()] ppField name fielddoc @@ -134,6 +134,6 @@ ppField name fielddoc -- TODO(leana8959): push out doc position ppFieldPos :: FieldName -> [(Positions, Doc)] -> [PrettyField Position] ppFieldPos name possFieldDocs = - [ PrettyField (fieldNamePos poss) name fieldDoc - | (poss, fieldDoc) <- possFieldDocs - ] + [ PrettyField (fieldNamePos poss) name fieldDoc + | (poss, fieldDoc) <- possFieldDocs + ] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs index 61aae3903f1..513e1ae501d 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Configuration.hs @@ -1,7 +1,7 @@ -- -Wno-deprecations for use of Map.foldWithKey {-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-deprecations #-} diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 51991c9d609..3eb4dea878f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TupleSections #-} +{-# 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 @@ -74,7 +74,6 @@ module Distribution.PackageDescription.FieldGrammar -- * Component build info , buildInfoFieldGrammar - , MiniBuildInfo (..) , miniBuildInfoFieldGrammar ) where @@ -98,7 +97,7 @@ import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) import Distribution.Trivia -import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate) +import Distribution.Types.Modify (Annotate, AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod import qualified Data.ByteString.Char8 as BS8 @@ -186,10 +185,8 @@ libraryFieldGrammar , Applicative (g mod (LibraryWith mod)) , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - - -- TODO(leana8959): use legacy for now, not completely polymorphic - , mod ~ Mod.HasNoAnn - + , -- TODO(leana8959): use legacy for now, not completely polymorphic + mod ~ Mod.HasNoAnn , c (Identity LibraryVisibility) , c (List CommaFSep (Identity ExeDependency) ExeDependency) , c (List CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -227,6 +224,7 @@ libraryFieldGrammar n = LSubLibName _ -> optionalFieldDef "visibility" L.libVisibility LibraryVisibilityPrivate ^^^ availableSince CabalSpecV3_0 LibraryVisibilityPrivate + -- {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> ParsecFieldGrammar' LibraryAnn #-} -- {-# SPECIALIZE libraryFieldGrammar :: LibraryName -> PrettyFieldGrammar' LibraryAnn #-} @@ -604,10 +602,8 @@ buildInfoFieldGrammar . ( 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 - + , -- 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) @@ -711,6 +707,7 @@ buildInfoFieldGrammar = <*> monoidalFieldAla "build-depends" (formatDependencyList @mod) L.targetBuildDepends <*> monoidalFieldAla "mixins" formatMixinList L.mixins ^^^ availableSince CabalSpecV2_0 [] + -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} @@ -719,7 +716,6 @@ buildInfoFieldGrammar' . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) @@ -735,18 +731,15 @@ buildInfoFieldGrammar' , Newtype [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 (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + , -- is a monoid with or without annotation, for hsSourceDirs compat + Monoid (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) , Newtype [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 [Annotate mod ModuleName] (ListWith mod VCat (MQuoted ModuleName) ModuleName) , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + , -- TODO(leana8959): constraints go here - -- TODO(leana8959): constraints go here - - , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) + Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => g mod (BuildInfoWith mod) (BuildInfoWith mod) @@ -776,7 +769,7 @@ buildInfoFieldGrammar' = do -- TODO(leana8959): add more targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends - pure (BuildInfo {..}) + pure (BuildInfo{..}) -- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasAnn BuildInfoAnn BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasNoAnn BuildInfo BuildInfo #-} @@ -802,11 +795,9 @@ miniBuildInfoFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g , Applicative (g mod (MiniBuildInfo mod)) - , Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) - , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) => g mod (MiniBuildInfo mod) (MiniBuildInfo mod) @@ -819,23 +810,22 @@ hsSourceDirsGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - - -- is a monoid with or without annotation - , Monoid (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) - + , -- is a monoid with or without annotation + Monoid (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) , Newtype [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 (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) hsSourceDirsGrammar = - (<>) - <$> 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 - wrongLens f bi = (\fps -> set (L.hsSourceDirs @mod) fps bi) <$> f mempty + (<>) + <$> 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 + 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)] #-} @@ -859,6 +849,7 @@ optionsFieldGrammar = <* knownField "nhc98-options" where extract flavor = L.options @mod . lookupLens flavor + -- {-# SPECIALIZE optionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} -- {-# SPECIALIZE optionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} @@ -876,6 +867,7 @@ profOptionsFieldGrammar = <*> monoidalFieldAla "ghcjs-prof-options" (alaList' NoCommaFSep Token') (extract GHCJS) where extract flavor = L.profOptions @mod . lookupLens flavor + -- {-# SPECIALIZE profOptionsFieldGrammar :: ParsecFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} -- {-# SPECIALIZE profOptionsFieldGrammar :: PrettyFieldGrammar BuildInfoAnn (PerCompilerFlavor [String]) #-} @@ -930,6 +922,7 @@ flagFieldGrammar 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 #-} @@ -949,6 +942,7 @@ 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 #-} @@ -963,6 +957,7 @@ setupBInfoFieldGrammar setupBInfoFieldGrammar def = flip SetupBuildInfo def <$> monoidalFieldAla "setup-depends" (alaList CommaVCat) L.setupDepends + -- {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> ParsecFieldGrammar' SetupBuildInfo #-} -- {-# SPECIALIZE setupBInfoFieldGrammar :: Bool -> PrettyFieldGrammar' SetupBuildInfo #-} diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 44aa9ef9f09..282a97d2755 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} ----------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Parsec/Position.hs b/Cabal-syntax/src/Distribution/Parsec/Position.hs index 9524fffeb02..8a8a3d54bd4 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Position.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Position.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} module Distribution.Parsec.Position ( Position (..) diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index a54c1ef4233..09edc4a9388 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -6,7 +6,6 @@ module Distribution.Trivia ( SurroundingText (..) , Positions (..) , Trivia (..) - , preTrivia , postTrivia , Ann (..) @@ -17,8 +16,8 @@ module Distribution.Trivia where import Control.Applicative -import Data.Monoid (Last (..)) import Data.Data +import Data.Monoid (Last (..)) import Distribution.Parsec.Position import qualified Text.PrettyPrint as Disp diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index f17e9801f30..5ba2f6b375d 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -41,7 +41,7 @@ import Language.Haskell.Extension import Data.Kind -import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate, AnnotateWith) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn @@ -203,14 +203,13 @@ unannotateBuildInfo bi = , jsSources = map unAnn $ join $ map snd $ jsSources bi , hsSourceDirs = map unAnn $ join $ map snd $ hsSourceDirs bi , otherModules = map unAnn $ join $ map snd $ otherModules bi + , -- TODO(leana8959): add more fields here - -- TODO(leana8959): add more fields here - - , targetBuildDepends = - map (unannotateDependencyAnn . unAnn) - $ join - $ map snd - $ targetBuildDepends bi + targetBuildDepends = + map (unannotateDependencyAnn . unAnn) $ + join $ + map snd $ + targetBuildDepends bi } instance Monoid BuildInfo where diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 1a9d0b047b3..45c6805e1c4 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -1,11 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -38,7 +38,7 @@ import Language.Haskell.Extension (Extension, Language) import Distribution.Trivia import qualified Distribution.Types.BuildInfo as T -import Distribution.Types.Modify (AttachPos, PreserveGrouping, Annotate, AnnotateWith) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPos, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 5148b230379..4cab006d2f0 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Types that can be used as modifiers diff --git a/Cabal-syntax/src/Distribution/Types/PackageName.hs b/Cabal-syntax/src/Distribution/Types/PackageName.hs index e580bb07b93..f130b32902e 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageName.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageName.hs @@ -40,6 +40,7 @@ import qualified Distribution.Types.Modify as Mod -- -- @since 2.0.0.2 type PackageName = PackageNameWith Mod.HasNoAnn + type PackageNameAnn = PackageNameWith Mod.HasAnn newtype PackageNameWith (m :: Mod.HasAnnotation) = PackageName (Annotate m ShortText) From 0455a9c1d978bb6aea933501c7445dcdc90366d3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 14:08:59 +0200 Subject: [PATCH 070/111] distinguish AttachPositions and AttachPosition --- .../src/Distribution/FieldGrammar/Class.hs | 10 ++-- .../src/Distribution/FieldGrammar/Parsec.hs | 2 +- .../src/Distribution/FieldGrammar/Pretty.hs | 16 ++--- .../src/Distribution/Fields/Pretty.hs | 58 +++++++++---------- .../PackageDescription/FieldGrammar.hs | 12 ++-- .../PackageDescription/PrettyPrint.hs | 54 ++++++++--------- .../src/Distribution/Types/BuildInfo.hs | 44 +++++++------- .../src/Distribution/Types/BuildInfo/Lens.hs | 44 +++++++------- Cabal-syntax/src/Distribution/Types/Modify.hs | 15 +++-- 9 files changed, 124 insertions(+), 131 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index b6f04cad8eb..41ca0948924 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -33,7 +33,7 @@ import Distribution.Trivia import Distribution.Utils.ShortText import Data.Kind -import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPos, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type FieldGrammar = FieldGrammarWith Mod.HasNoAnn @@ -169,9 +169,9 @@ class -- ^ field name -> (a -> b) -- ^ 'pack' - -> ALens' s (PreserveGrouping m (AttachPos m a)) + -> ALens' s (PreserveGrouping m (AttachPositions m a)) -- ^ lens into the field - -> g m s (PreserveGrouping m (AttachPos m a)) + -> g m s (PreserveGrouping m (AttachPositions m a)) -- | Monoidal field. -- @@ -196,9 +196,9 @@ class -- ^ field name -> (a -> b) -- ^ 'pack' - -> ALens' s (AttachPos m a) + -> ALens' s (AttachPositions m a) -- ^ lens into the field - -> g m s (AttachPos m a) + -> g m s (AttachPositions m a) -- | Parser matching all fields with a name starting with a prefix. prefixedFields diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 88262c241f4..1a4f53b5f6c 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -97,7 +97,7 @@ import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) import Distribution.Trivia -import Distribution.Types.Modify (AttachPos) +import Distribution.Types.Modify (AttachPositions) import qualified Distribution.Types.Modify as Mod ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 79b31d31e64..4be13f8c77e 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -15,7 +15,7 @@ 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 @@ -30,7 +30,7 @@ import qualified Distribution.Types.Modify as Mod -- 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 -> s -> [PrettyField (WithPos m)] + { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyFieldWith m] } deriving (Functor) @@ -41,7 +41,7 @@ instance Applicative (PrettyFieldGrammar m s) where -- | We can use 'PrettyFieldGrammar' to pp print the @s@. -- -- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> [PrettyField (WithPos m)] +prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> [PrettyFieldWith m] prettyFieldGrammar = flip fieldGrammarPretty instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where @@ -100,7 +100,7 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar 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 ] @@ -126,14 +126,14 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] IsInserted -> mempty -ppField :: FieldName -> Doc -> [PrettyField ()] +ppField :: FieldName -> Doc -> [PrettyField] ppField name fielddoc | PP.isEmpty fielddoc = [] - | otherwise = [PrettyField () name fielddoc] + | otherwise = [PrettyField name fielddoc] -- TODO(leana8959): push out doc position -ppFieldPos :: FieldName -> [(Positions, Doc)] -> [PrettyField Position] +ppFieldPos :: FieldName -> [(Positions, Doc)] -> [PrettyFieldWith Mod.HasAnn] ppFieldPos name possFieldDocs = - [ PrettyField (fieldNamePos poss) name fieldDoc + [ PrettyField (fieldNamePos poss, name) fieldDoc | (poss, fieldDoc) <- possFieldDocs ] diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index 0ec802eb060..e4367065ae2 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase #-} @@ -10,7 +12,8 @@ module Distribution.Fields.Pretty ( -- * Fields CommentPosition (..) - , PrettyField (..) + , PrettyField + , PrettyFieldWith (..) , showFields , showFields' @@ -25,9 +28,12 @@ import Distribution.Compat.Prelude import Distribution.Pretty (showToken) import Prelude () +import Distribution.Parsec.Position import Distribution.Fields.Field (FieldName, Name) import Distribution.Utils.Generic (fromUTF8BS) +import qualified Distribution.Types.Modify as Mod +import Distribution.Types.Modify (AttachPosition, AnnotateWith) import qualified Distribution.Fields.Parser as P import qualified Data.ByteString as BS @@ -39,14 +45,15 @@ import qualified Text.PrettyPrint as PP -- conjunction with @PrettyField@. data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment +type PrettyField = PrettyFieldWith Mod.HasNoAnn + -- 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 -data PrettyField ann - = PrettyField ann FieldName PP.Doc - | PrettySection ann FieldName [PP.Doc] [PrettyField ann] +data PrettyFieldWith (mod :: Mod.HasAnnotation) + = PrettyField (AttachPosition mod FieldName) PP.Doc + | PrettySection FieldName [PP.Doc] [PrettyFieldWith mod] | PrettyEmpty - deriving (Functor, Foldable, Traversable) -- | Prettyprint a list of fields. -- @@ -54,7 +61,7 @@ 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 -- | 'showFields' with user specified indentation. @@ -65,7 +72,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) @@ -90,7 +97,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 @@ -99,7 +106,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 @@ -131,20 +138,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) @@ -158,16 +157,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 ------------------------------------------------------------------------------- @@ -181,13 +175,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 @@ -205,7 +199,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 diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 3eb4dea878f..c78b8941346 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -97,7 +97,7 @@ import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) import Distribution.Trivia -import Distribution.Types.Modify (Annotate, AttachPos, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AttachPositions, PreserveGrouping) import qualified Distribution.Types.Modify as Mod import qualified Data.ByteString.Char8 as BS8 @@ -732,7 +732,7 @@ buildInfoFieldGrammar' , 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 (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + Monoid (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) , Newtype [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 [Annotate mod ModuleName] (ListWith mod VCat (MQuoted ModuleName) ModuleName) @@ -777,7 +777,7 @@ buildInfoFieldGrammar' = do -- {-# SPECIALIZE buildInfoFieldGrammar' :: PrettyFieldGrammar Mod.HasNoAnn BuildInfo BuildInfo #-} data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo - { miniTargetBuildDepends :: PreserveGrouping m (AttachPos m [Annotate m (DependencyWith m)]) + { miniTargetBuildDepends :: PreserveGrouping m (AttachPositions m [Annotate m (DependencyWith m)]) } deriving instance Show (MiniBuildInfo Mod.HasAnn) @@ -786,7 +786,7 @@ deriving instance Show (MiniBuildInfo Mod.HasNoAnn) miniTargetBuildDependsLens :: forall mod f . Functor f - => (PreserveGrouping mod (AttachPos mod [Annotate mod (DependencyWith mod)]) -> f (PreserveGrouping mod (AttachPos mod [Annotate mod (DependencyWith mod)]))) + => (PreserveGrouping mod (AttachPositions mod [Annotate mod (DependencyWith mod)]) -> f (PreserveGrouping mod (AttachPositions mod [Annotate mod (DependencyWith mod)]))) -> MiniBuildInfo mod -> f (MiniBuildInfo mod) miniTargetBuildDependsLens f s = fmap (\x -> s{miniTargetBuildDepends = x}) (f (miniTargetBuildDepends s)) @@ -811,11 +811,11 @@ hsSourceDirsGrammar , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) , -- is a monoid with or without annotation - Monoid (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + Monoid (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) , Newtype [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 (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + => g mod (BuildInfoWith mod) (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) hsSourceDirsGrammar = (<>) <$> monoidalFieldAla' "hs-source-dirs" (alaListWith' @mod @FSep @(SymbolicPathNT Pkg (Dir Source)) @(SymbolicPath Pkg (Dir Source))) L.hsSourceDirs diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 282a97d2755..cb350c06fb7 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -77,7 +77,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) @@ -93,39 +93,39 @@ ppGenericPackageDescription v gpd0 = where gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 -ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField ()] +ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField] ppPackageDescription v pd = prettyFieldGrammar v packageDescriptionFieldGrammar pd ++ ppSourceRepos v (sourceRepos pd) -ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField ()] +ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField] ppSourceRepos = map . ppSourceRepo -ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField () +ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ppSourceRepo v repo = - PrettySection () "source-repository" [pretty kind] $ + PrettySection "source-repository" [pretty kind] $ prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasNoAnn kind) repo where kind = repoKind repo -ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField ()] +ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField] ppSetupBInfo _ Nothing = mempty ppSetupBInfo v (Just sbi) | defaultSetupDepends sbi = mempty | otherwise = pure $ - PrettySection () "custom-setup" [] $ + PrettySection "custom-setup" [] $ prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasNoAnn False) sbi -ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField ()] +ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField] ppGenPackageFlags = map . ppFlag -ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField () +ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ppFlag v flag@(MkPackageFlag name _ _ _) = - PrettySection () "flag" [ppFlagName name] $ + PrettySection "flag" [ppFlagName name] $ prettyFieldGrammar v (flagFieldGrammar @Mod.HasNoAnn name) flag -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 @@ -141,47 +141,47 @@ ppCondTree2 v grammar = go ppIf (CondBranch c thenTree (Just elseTree)) = -- See #6193 [ ppIfCondition c (go thenTree) - , PrettySection () "else" [] (go elseTree) + , PrettySection "else" [] (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 ()] +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 ()] +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 ()] +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 ()] +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 ()] +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 ] @@ -215,8 +215,8 @@ 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] -- | @since 2.0.0.2 writePackageDescription :: FilePath -> PackageDescription -> IO () @@ -314,7 +314,7 @@ showHookedBuildInfo :: HookedBuildInfo -> String showHookedBuildInfo (mb_lib_bi, ex_bis) = showFields (const NoComment) $ maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar) mb_lib_bi - ++ [ PrettySection () "executable:" [pretty name] $ + ++ [ PrettySection "executable:" [pretty name] $ prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi | (name, bi) <- ex_bis ] diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 5ba2f6b375d..24b8cb17899 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -41,7 +41,7 @@ import Language.Haskell.Extension import Data.Kind -import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPos, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn @@ -55,7 +55,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo { buildable :: AnnotateWith Positions m Bool -- ^ component is buildable here - , buildTools :: PreserveGrouping m (AttachPos m [Annotate m LegacyExeDependency]) + , buildTools :: PreserveGrouping m (AttachPositions m [Annotate m LegacyExeDependency]) -- ^ Tools needed to build this bit. -- -- This is a legacy field that 'buildToolDepends' largely supersedes. @@ -63,7 +63,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , buildToolDepends :: PreserveGrouping m (AttachPos m [Annotate m ExeDependency]) + , buildToolDepends :: PreserveGrouping m (AttachPositions m [Annotate m ExeDependency]) -- ^ Haskell tools needed to build this bit -- -- This field is better than 'buildTools' because it allows one to @@ -72,40 +72,40 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , cppOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , cppOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for pre-processing Haskell code - , asmOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , asmOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for assembler - , cmmOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , cmmOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for C-- compiler - , ccOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , ccOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for C compiler - , cxxOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , cxxOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for C++ compiler - , jsppOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , jsppOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for pre-processing JavaScript code @since 3.16.0.0 - , ldOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , ldOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for linker - , hsc2hsOptions :: PreserveGrouping m (AttachPos m [Annotate m String]) + , hsc2hsOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) -- ^ options for hsc2hs - , pkgconfigDepends :: PreserveGrouping m (AttachPos m [Annotate m PkgconfigDependency]) + , pkgconfigDepends :: PreserveGrouping m (AttachPositions m [Annotate m PkgconfigDependency]) -- ^ pkg-config packages that are used - , frameworks :: PreserveGrouping m (AttachPos m [Annotate m (RelativePath Framework File)]) + , frameworks :: PreserveGrouping m (AttachPositions m [Annotate m (RelativePath Framework File)]) -- ^ support frameworks for Mac OS X - , extraFrameworkDirs :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg (Dir Framework))]) + , extraFrameworkDirs :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg (Dir Framework))]) -- ^ extra locations to find frameworks. - , asmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) + , asmSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) -- ^ Assembly files. - , cmmSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) + , cmmSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) -- ^ C-- files. - , cSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) - , cxxSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) - , jsSources :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg File)]) - , hsSourceDirs :: PreserveGrouping m (AttachPos m [Annotate m (SymbolicPath Pkg (Dir Source))]) + , cSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) + , cxxSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) + , jsSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) + , hsSourceDirs :: PreserveGrouping m (AttachPositions 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 :: PreserveGrouping m (AttachPos m [Annotate m ModuleName]) + otherModules :: PreserveGrouping m (AttachPositions 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) @@ -163,7 +163,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: PreserveGrouping m (AttachPos m [Annotate m (DependencyWith m)]) + , targetBuildDepends :: PreserveGrouping m (AttachPositions m [Annotate m (DependencyWith m)]) -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 45c6805e1c4..9ae0dca9c53 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -38,7 +38,7 @@ import Language.Haskell.Extension (Extension, Language) import Distribution.Trivia import qualified Distribution.Types.BuildInfo as T -import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPos, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn @@ -50,64 +50,64 @@ class HasBuildInfoWith mod a | a -> mod where buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AnnotateWith Positions mod Bool) buildable = buildInfo @mod . buildable @mod - buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod LegacyExeDependency])) + buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod LegacyExeDependency])) buildTools = buildInfo @mod . buildTools @mod - buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod ExeDependency])) + buildToolDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod ExeDependency])) buildToolDepends = buildInfo @mod . buildToolDepends @mod - cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + cppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) cppOptions = buildInfo @mod . cppOptions @mod - asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + asmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) asmOptions = buildInfo @mod . asmOptions @mod - cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + cmmOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) cmmOptions = buildInfo @mod . cmmOptions @mod - ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + ccOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) ccOptions = buildInfo @mod . ccOptions @mod - cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + cxxOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) cxxOptions = buildInfo @mod . cxxOptions @mod - jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + jsppOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) jsppOptions = buildInfo @mod . jsppOptions @mod - ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + ldOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) ldOptions = buildInfo @mod . ldOptions @mod - hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod String])) + hsc2hsOptions :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod String])) hsc2hsOptions = buildInfo @mod . hsc2hsOptions @mod - pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod PkgconfigDependency])) + pkgconfigDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod PkgconfigDependency])) pkgconfigDepends = buildInfo @mod . pkgconfigDepends @mod - frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (RelativePath Framework File)])) + frameworks :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (RelativePath Framework File)])) frameworks = buildInfo @mod . frameworks @mod - extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Framework))])) + extraFrameworkDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Framework))])) extraFrameworkDirs = buildInfo @mod . extraFrameworkDirs @mod - asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) + asmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg File)])) asmSources = buildInfo @mod . asmSources @mod - cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) + cmmSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg File)])) cmmSources = buildInfo @mod . cmmSources @mod - cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) + cSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg File)])) cSources = buildInfo @mod . cSources @mod - cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) + cxxSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg File)])) cxxSources = buildInfo @mod . cxxSources @mod - jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg File)])) + jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg File)])) jsSources = buildInfo @mod . jsSources @mod - hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) hsSourceDirs = buildInfo @mod . hsSourceDirs @mod - otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod ModuleName])) + otherModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod ModuleName])) otherModules = buildInfo @mod . otherModules @mod virtualModules :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [ModuleName] @@ -185,7 +185,7 @@ class HasBuildInfoWith mod a | a -> mod where customFieldsBI :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [(String, String)] customFieldsBI = buildInfo @mod . customFieldsBI @mod - targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPos mod [Annotate mod (DependencyWith mod)])) + targetBuildDepends :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (DependencyWith mod)])) targetBuildDepends = buildInfo @mod . targetBuildDepends @mod mixins :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a [Mixin] diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 4cab006d2f0..5d89af03adc 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -21,19 +21,18 @@ data HasAnnotation -- 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 Annotate (m :: HasAnnotation) (a :: Type) = AnnotateWith SurroundingText m a - -type family AttachPos (m :: HasAnnotation) (a :: Type) where - AttachPos HasAnn a = (Positions, a) - AttachPos HasNoAnn a = a +type AttachPositions (m :: HasAnnotation) (a :: Type) = AttachWith Positions m a +type AttachPosition (m :: HasAnnotation) (a :: Type) = AttachWith Position m a -type family WithPos (m :: HasAnnotation) where - WithPos HasAnn = Position - WithPos HasNoAnn = () +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] From bd0778863c05db3b1e5823512555158243a179e3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 15:09:20 +0200 Subject: [PATCH 071/111] patch pretty for now so it builds and runs most tests fine --- Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 4be13f8c77e..f0f9d828dab 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -95,6 +95,8 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where where pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s))) + monoidalFieldAla' = monoidalFieldAla + prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l) where pp xs = From 342de192d0a1d0287fe4936c2e867bc1fadea457 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 13 Apr 2026 18:13:00 +0200 Subject: [PATCH 072/111] test displaying mini build info, add note about model --- Cabal-syntax/src/Distribution/Fields/Pretty.hs | 7 +++++++ Cabal-tests/tests/ParserTests.hs | 2 +- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index e4367065ae2..7f2158263f1 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveTraversable #-} @@ -50,11 +52,16 @@ type PrettyField = PrettyFieldWith Mod.HasNoAnn -- 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) PP.Doc | PrettySection FieldName [PP.Doc] [PrettyFieldWith mod] | PrettyEmpty +deriving instance Show (PrettyFieldWith Mod.HasAnn) + -- | Prettyprint a list of fields. -- -- Note: the first argument should return 'String's without newlines diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 1a5ff4c7d3b..dbd54ea151e 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -274,7 +274,7 @@ miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do Left (_, errs) -> fail "ERROR in running field grammar" Right ok -> pure $ ok - pPrint pr'' + print $ prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar pr'' where input = "tests" "ParserTests" "miniBuildInfoDemo.cabal" From be518bfc92ee0698b26875497e8655cae9e61c92 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 10:36:00 +0200 Subject: [PATCH 073/111] add parsec combinator to store position --- Cabal-syntax/src/Distribution/Parsec.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index c06d666d663..a228bbea881 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -39,6 +39,7 @@ module Distribution.Parsec -- * Position , Position (..) + , parsecWithPosition , incPos , retPos , showPos @@ -325,9 +326,8 @@ 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. +-- | 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 @@ -335,6 +335,10 @@ parsecSpacesAnn p = do 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 + parsecCommaList :: CabalParsing m => m a -> m [a] parsecCommaList p = P.sepBy (p <* P.spaces) (P.char ',' *> P.spaces P. "comma") From 5a14696a462ad54f9b72d7472a3b677b78797a6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 11:02:54 +0200 Subject: [PATCH 074/111] register each element's position in list combinators --- .../src/Distribution/FieldGrammar/Newtypes.hs | 99 ++++++++++--------- Cabal-syntax/src/Distribution/Parsec.hs | 9 ++ Cabal-syntax/src/Distribution/Trivia.hs | 4 + 3 files changed, 67 insertions(+), 45 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index 270b5590c1b..ec73bfe0753 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -68,7 +68,7 @@ import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty import Distribution.Trivia -import Distribution.Types.Modify (Annotate) +import Distribution.Types.Modify (Annotate, AttachPosition) import qualified Distribution.Types.Modify as Mod import Distribution.Utils.Path import Distribution.Version @@ -107,13 +107,13 @@ data FSep = FSep -- | Paragraph fill list without commas. Displayed with 'fsep'. data NoCommaFSep = NoCommaFSep --- TODO(leana8959): Relax Sep to return a list of annotated docs with position --- Use the position propagated back from applyTriviaDoc class Sep (mod :: Mod.HasAnnotation) sep where - prettySep :: Proxy sep -> [Annotate mod Doc] -> Doc + -- 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)] -> Doc - parseSep :: CabalParsing m => Proxy sep -> m a -> m [Annotate mod a] - parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty (Annotate mod 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 Mod.HasNoAnn CommaVCat where prettySep _ = vcat . punctuate comma @@ -125,15 +125,18 @@ instance Sep Mod.HasNoAnn CommaVCat where if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p instance Sep Mod.HasAnn CommaVCat where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd parseSep _ p = do v <- askCabalSpecVersion - let p' = Ann mempty <$> p - if v >= CabalSpecV2_2 then parsecLeadingCommaListAnn p' else parsecCommaListAnn p' + 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 <$> p - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmptyAnn p' else parsecCommaNonEmptyAnn p' + 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 @@ -145,15 +148,17 @@ instance Sep Mod.HasNoAnn CommaFSep where if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p instance Sep Mod.HasAnn CommaFSep where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd parseSep _ p = do v <- askCabalSpecVersion - let p' = Ann mempty <$> p - if v >= CabalSpecV2_2 then parsecLeadingCommaListAnn p' else parsecCommaListAnn p' + 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 <$> p - if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmptyAnn p' else parsecCommaNonEmptyAnn p' + 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 @@ -163,18 +168,20 @@ instance Sep Mod.HasNoAnn VCat where parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep Mod.HasAnn VCat where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd parseSep _ p = do v <- askCabalSpecVersion - let p' = Ann mempty <$> p - if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' parseSepNE _ p = - NE.some1 - ( do - x <- p - post <- P.spaces' - pure (Ann (postTrivia post) x) - ) + fmap extractPosition <$> + NE.some1 + ( do + x <- parsecWithPosition p + post <- P.spaces' + pure (Ann (postTrivia post) x) + ) instance Sep Mod.HasNoAnn FSep where prettySep _ = fsep @@ -184,18 +191,20 @@ instance Sep Mod.HasNoAnn FSep where parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep Mod.HasAnn FSep where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd parseSep _ p = do v <- askCabalSpecVersion - let p' = Ann mempty <$> p - if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' + let p' = Ann mempty <$> parsecWithPosition p + fmap extractPosition <$> + if v >= CabalSpecV3_0 then parsecLeadingOptCommaListAnn p' else parsecOptCommaListAnn p' parseSepNE _ p = - NE.some1 - ( do - x <- p - post <- P.spaces' - pure (Ann (postTrivia post) x) - ) + fmap extractPosition <$> + NE.some1 + ( do + x <- parsecWithPosition p + post <- P.spaces' + pure (Ann (postTrivia post) x) + ) instance Sep Mod.HasNoAnn NoCommaFSep where prettySep _ = fsep @@ -203,19 +212,19 @@ instance Sep Mod.HasNoAnn NoCommaFSep where parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep Mod.HasAnn NoCommaFSep where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) - parseSep _ p = many $ do - x <- p + prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd + parseSep _ p = (fmap . fmap) extractPosition $ many $ do + x <- parsecWithPosition p post <- P.spaces' pure (Ann (postTrivia post) x) - parseSepNE _ p = NE.some1 $ do - x <- p + 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 ListWith mod sep b a = List {_getList :: [Annotate mod a]} +newtype ListWith mod sep b a = List {_getList :: [AttachPosition mod (Annotate mod a)]} type List = ListWith Mod.HasNoAnn type ListAnn = ListWith Mod.HasAnn @@ -234,7 +243,7 @@ alaList _ = List -- | Use Type Application to create a ListWith data alaListWith :: forall (mod :: Mod.HasAnnotation) (sep :: Type) (a :: Type) - . [Annotate mod a] + . [AttachPosition mod (Annotate mod a)] -> ListWith mod sep (Identity a) a alaListWith = List @@ -244,24 +253,24 @@ alaList' _ _ = List alaListWith' :: forall (mod :: Mod.HasAnnotation) (sep :: Type) (b :: Type) (a :: Type) - . [Annotate mod a] + . [AttachPosition mod (Annotate mod a)] -> ListWith mod sep b a alaListWith' = List instance Newtype [a] (ListWith Mod.HasNoAnn sep wrapper a) -instance Newtype [Ann SurroundingText a] (ListWith Mod.HasAnn sep wrapper a) +instance Newtype [(Position, Ann SurroundingText a)] (ListWith Mod.HasAnn sep wrapper a) 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) (unpack :: b -> a) <$> parseSep @Mod.HasAnn (Proxy :: Proxy sep) parsec + 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 - pretty = prettySep @Mod.HasAnn (Proxy :: Proxy sep) . (map . fmap) (pretty . (pack :: a -> b)) . unpack + pretty = prettySep @Mod.HasAnn (Proxy :: Proxy sep) . (map . fmap . fmap) (pretty . (pack :: a -> b)) . unpack -- | Like 'List', but for 'Set'. -- diff --git a/Cabal-syntax/src/Distribution/Parsec.hs b/Cabal-syntax/src/Distribution/Parsec.hs index a228bbea881..5258d6d2459 100644 --- a/Cabal-syntax/src/Distribution/Parsec.hs +++ b/Cabal-syntax/src/Distribution/Parsec.hs @@ -46,6 +46,7 @@ module Distribution.Parsec , zeroPos -- * Utilities + , extractPosition , parsecToken , parsecToken' , parsecFilePath @@ -339,6 +340,14 @@ parsecSpacesAnn p = do 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") diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index 09edc4a9388..c4c8cb8278b 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -68,6 +68,10 @@ data Ann t a = Ann } 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 From cf70a75fdc1971be4053fc6032a59fb8dabc71c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 11:48:33 +0200 Subject: [PATCH 075/111] fix minibuildinfo --- .../PackageDescription/FieldGrammar.hs | 16 ++++++++++------ Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 7 ++++--- .../src/Distribution/Types/BuildInfo/Lens.hs | 4 ++-- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index c78b8941346..0d4e0a5b7c6 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -97,7 +97,7 @@ import Distribution.Utils.Path import Distribution.Version (Version, VersionRange) import Distribution.Trivia -import Distribution.Types.Modify (Annotate, AttachPositions, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AttachPositions, AttachPosition, PreserveGrouping) import qualified Distribution.Types.Modify as Mod import qualified Data.ByteString.Char8 as BS8 @@ -715,6 +715,9 @@ buildInfoFieldGrammar' :: forall mod c g . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) + + , mod ~ Mod.HasNoAnn + , L.HasBuildInfoWith mod (BuildInfoWith mod) , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) @@ -777,7 +780,7 @@ buildInfoFieldGrammar' = do -- {-# SPECIALIZE buildInfoFieldGrammar' :: PrettyFieldGrammar Mod.HasNoAnn BuildInfo BuildInfo #-} data MiniBuildInfo (m :: Mod.HasAnnotation) = MiniBuildInfo - { miniTargetBuildDepends :: PreserveGrouping m (AttachPositions m [Annotate m (DependencyWith m)]) + { miniTargetBuildDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (DependencyWith m))]) } deriving instance Show (MiniBuildInfo Mod.HasAnn) @@ -786,7 +789,7 @@ deriving instance Show (MiniBuildInfo Mod.HasNoAnn) miniTargetBuildDependsLens :: forall mod f . Functor f - => (PreserveGrouping mod (AttachPositions mod [Annotate mod (DependencyWith mod)]) -> f (PreserveGrouping mod (AttachPositions mod [Annotate mod (DependencyWith mod)]))) + => (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)) @@ -796,7 +799,7 @@ miniBuildInfoFieldGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (MiniBuildInfo mod)) , Newtype - [Annotate mod (DependencyWith mod)] + [AttachPosition mod (Annotate mod (DependencyWith mod))] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) , c (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod)) ) @@ -810,6 +813,7 @@ hsSourceDirsGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) + , mod ~ Mod.HasNoAnn , -- is a monoid with or without annotation Monoid (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) , Newtype [Annotate mod (SymbolicPath Pkg (Dir Source))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) @@ -965,7 +969,7 @@ setupBInfoFieldGrammar def = -- Define how field values should be formatted for 'pretty'. ------------------------------------------------------------------------------- -formatDependencyList :: [Annotate mod (DependencyWith mod)] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) +formatDependencyList :: [AttachPosition mod (Annotate mod (DependencyWith mod))] -> ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith mod) formatDependencyList = List formatMixinList :: [Mixin] -> List CommaVCat (Identity Mixin) Mixin @@ -983,7 +987,7 @@ formatHsSourceDirs = alaList' FSep SymbolicPathNT formatOtherExtensions :: [Extension] -> List FSep (MQuoted Extension) Extension formatOtherExtensions = alaList' FSep MQuoted -formatOtherModules :: [Annotate mod ModuleName] -> ListWith mod VCat (MQuoted ModuleName) ModuleName +formatOtherModules :: [AttachPosition mod (Annotate mod ModuleName)] -> ListWith mod VCat (MQuoted ModuleName) ModuleName formatOtherModules = List ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 24b8cb17899..fe79d2a08c0 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -41,7 +41,7 @@ import Language.Haskell.Extension import Data.Kind -import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping, AttachPosition) import qualified Distribution.Types.Modify as Mod type BuildInfo = BuildInfoWith Mod.HasNoAnn @@ -163,7 +163,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- ^ Custom fields starting -- with x-, stored in a -- simple assoc-list. - , targetBuildDepends :: PreserveGrouping m (AttachPositions m [Annotate m (DependencyWith m)]) + , targetBuildDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (DependencyWith m))]) -- ^ Dependencies specific to a library or executable target , mixins :: [Mixin] } @@ -205,8 +205,9 @@ unannotateBuildInfo bi = , otherModules = map unAnn $ join $ map snd $ otherModules bi , -- TODO(leana8959): add more fields here + -- [(Positions, (Position, Ann t dep))] targetBuildDepends = - map (unannotateDependencyAnn . unAnn) $ + map (unannotateDependencyAnn . unAnn . snd) $ join $ map snd $ targetBuildDepends bi diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 9ae0dca9c53..f83079f31ab 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -38,7 +38,7 @@ import Language.Haskell.Extension (Extension, Language) import Distribution.Trivia import qualified Distribution.Types.BuildInfo as T -import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping) +import Distribution.Types.Modify (Annotate, AnnotateWith, AttachPositions, PreserveGrouping, AttachPosition) import qualified Distribution.Types.Modify as Mod type HasBuildInfo = HasBuildInfoWith Mod.HasNoAnn @@ -185,7 +185,7 @@ class HasBuildInfoWith mod a | a -> mod where 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 [Annotate mod (DependencyWith 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] From 5eff7ac3ca35b0f3453902a683aa9fec86b77f60 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 12:00:43 +0200 Subject: [PATCH 076/111] register each field position for hsSourceDirs --- .../Distribution/PackageDescription/FieldGrammar.hs | 11 +++++++---- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 4 ++-- Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs | 2 +- 3 files changed, 10 insertions(+), 7 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 0d4e0a5b7c6..67dd87dc7a1 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -813,13 +813,16 @@ hsSourceDirsGrammar . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , mod ~ Mod.HasNoAnn , -- is a monoid with or without annotation - Monoid (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) - , Newtype [Annotate mod (SymbolicPath Pkg (Dir Source))] (ListWith mod FSep (SymbolicPathNT Pkg (Dir Source)) (SymbolicPath Pkg (Dir Source))) + 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 [Annotate mod (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" (alaListWith' @mod @FSep @(SymbolicPathNT Pkg (Dir Source)) @(SymbolicPath Pkg (Dir Source))) L.hsSourceDirs diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index fe79d2a08c0..65108694396 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -101,7 +101,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo , cSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) , cxxSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) , jsSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) - , hsSourceDirs :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg (Dir Source))]) + , 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 @@ -201,7 +201,7 @@ unannotateBuildInfo bi = , cSources = map unAnn $ join $ map snd $ cSources bi , cxxSources = map unAnn $ join $ map snd $ cxxSources bi , jsSources = map unAnn $ join $ map snd $ jsSources bi - , hsSourceDirs = map unAnn $ join $ map snd $ hsSourceDirs bi + , hsSourceDirs = map (unAnn . snd) $ join $ map snd $ hsSourceDirs bi , otherModules = map unAnn $ join $ map snd $ otherModules bi , -- TODO(leana8959): add more fields here diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index f83079f31ab..06cdbc4c387 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -104,7 +104,7 @@ class HasBuildInfoWith mod a | a -> mod where jsSources :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg File)])) jsSources = buildInfo @mod . jsSources @mod - hsSourceDirs :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod (SymbolicPath Pkg (Dir Source))])) + 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 [Annotate mod ModuleName])) From a69bd578d927eb436d53007ae11c003b3a3e4b20 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 12:01:59 +0200 Subject: [PATCH 077/111] make buildinfofieldgrammar' polymorphic again --- .../PackageDescription/FieldGrammar.hs | 90 +++++++++---------- 1 file changed, 45 insertions(+), 45 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 67dd87dc7a1..1da17f9258c 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -716,58 +716,58 @@ buildInfoFieldGrammar' . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) - , mod ~ Mod.HasNoAnn - , L.HasBuildInfoWith mod (BuildInfoWith mod) - , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) - , c (ListWith mod NoCommaFSep Token' String) - , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - , Newtype [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 [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 [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 [Annotate mod (SymbolicPath Pkg (Dir Source))])) - , Newtype [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 [Annotate mod ModuleName] (ListWith mod VCat (MQuoted ModuleName) ModuleName) - , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) - , -- TODO(leana8959): constraints go here + -- , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + -- , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) + -- , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + -- , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) + -- , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) + -- , c (ListWith mod NoCommaFSep Token' String) + -- , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + -- , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) + -- , Newtype [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 [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 [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 [Annotate mod (SymbolicPath Pkg (Dir Source))])) + -- , Newtype [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 [Annotate mod ModuleName] (ListWith mod VCat (MQuoted ModuleName) ModuleName) + -- , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + -- TODO(leana8959): constraints go here - Newtype [Annotate mod (DependencyWith mod)] (ListWith mod CommaVCat (Identity (DependencyWith mod)) (DependencyWith 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 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 - astSources <- 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 + -- 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 + -- astSources <- 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 -- TODO(leana8959): add more From 584b8fb2d8f0fa6a7e53fe040c6a751c4d90a0ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 13:25:47 +0200 Subject: [PATCH 078/111] remove unused prototype methods --- .../src/Distribution/FieldGrammar/Class.hs | 27 ------------------- 1 file changed, 27 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 41ca0948924..860a9296be9 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -173,33 +173,6 @@ class -- ^ lens into the field -> g m s (PreserveGrouping m (AttachPositions m a)) - -- | Monoidal field. - -- - -- Values are combined with 'mappend'. - -- - -- /Note:/ 'optionalFieldAla' is a @monoidalField@ with 'Last' monoid. - monoidalFieldAlaAnn - :: (c b, Newtype a b) - => FieldName - -- ^ field name - -> (a -> b) - -- ^ 'pack' - -> ALens' s [(Positions, a)] - -- ^ lens into the field - -> g m s [(Positions, a)] - - monoidalFieldAlaAnnProxy - :: forall (m :: Mod.HasAnnotation) b s a - . (c b, Newtype a b) - => Proxy m - -> FieldName - -- ^ field name - -> (a -> b) - -- ^ 'pack' - -> ALens' s (AttachPositions m a) - -- ^ lens into the field - -> g m s (AttachPositions m a) - -- | Parser matching all fields with a name starting with a prefix. prefixedFields :: FieldName From 4602ccc5645567dabe85ee4b73160886544da39a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 13:08:29 +0200 Subject: [PATCH 079/111] leave notes for newtype ListWith --- .../src/Distribution/FieldGrammar/Newtypes.hs | 22 ++++++++++++------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index ec73bfe0753..bfc79032ec6 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -68,7 +68,7 @@ import Distribution.License (License) import Distribution.Parsec import Distribution.Pretty import Distribution.Trivia -import Distribution.Types.Modify (Annotate, AttachPosition) +import Distribution.Types.Modify (Annotate, AttachPosition, PreserveGrouping) import qualified Distribution.Types.Modify as Mod import Distribution.Utils.Path import Distribution.Version @@ -110,7 +110,7 @@ data NoCommaFSep = NoCommaFSep 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)] -> Doc + prettySep :: Proxy sep -> [AttachPosition mod (Annotate mod Doc)] -> PreserveGrouping mod (AttachPosition mod Doc) 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))) @@ -125,7 +125,7 @@ instance Sep Mod.HasNoAnn CommaVCat where if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p instance Sep Mod.HasAnn CommaVCat where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion let p' = Ann mempty <$> parsecWithPosition p @@ -148,7 +148,7 @@ instance Sep Mod.HasNoAnn CommaFSep where if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p instance Sep Mod.HasAnn CommaFSep where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion let p' = Ann mempty <$> parsecWithPosition p @@ -168,7 +168,7 @@ instance Sep Mod.HasNoAnn VCat where parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep Mod.HasAnn VCat where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion let p' = Ann mempty <$> parsecWithPosition p @@ -191,7 +191,7 @@ instance Sep Mod.HasNoAnn FSep where parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep Mod.HasAnn FSep where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = do v <- askCabalSpecVersion let p' = Ann mempty <$> parsecWithPosition p @@ -212,7 +212,7 @@ instance Sep Mod.HasNoAnn NoCommaFSep where parseSepNE _ p = NE.some1 (p <* P.spaces) instance Sep Mod.HasAnn NoCommaFSep where - prettySep _ = mconcat . map (\(Ann t doc) -> applyTriviaDoc t doc) . map snd + prettySep _ = (map . fmap) (\(Ann t doc) -> applyTriviaDoc t doc) parseSep _ p = (fmap . fmap) extractPosition $ many $ do x <- parsecWithPosition p post <- P.spaces' @@ -270,7 +270,13 @@ instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (List sep b a) 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 - pretty = prettySep @Mod.HasAnn (Proxy :: Proxy sep) . (map . fmap . fmap) (pretty . (pack :: a -> b)) . unpack + -- TODO(leana8959): + -- what do we do with the positioning when prettifying every element? + -- what about the grouping? + -- + -- The parser was run locally, so the context of the line number is also local + -- We can implement a local exact print, and push out the resulting doc. + pretty = mconcat . map snd . prettySep @Mod.HasAnn (Proxy :: Proxy sep) . (map . fmap . fmap) (pretty . (pack :: a -> b)) . unpack -- | Like 'List', but for 'Set'. -- From 7c7f2943f4fca71e3ab4076b698eac2adb9ce961 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 14 Apr 2026 14:43:26 +0200 Subject: [PATCH 080/111] update comments on future direction regarding pretty --- Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs index bfc79032ec6..7450f7511ac 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Newtypes.hs @@ -271,11 +271,12 @@ instance (Newtype a b, Sep Mod.HasNoAnn sep, Pretty b) => Pretty (List sep b a) instance (Newtype a b, Sep Mod.HasAnn sep, Pretty b) => Pretty (ListAnn sep b a) where -- TODO(leana8959): - -- what do we do with the positioning when prettifying every element? - -- what about the grouping? + -- 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. -- - -- The parser was run locally, so the context of the line number is also local - -- We can implement a local exact print, and push out the resulting doc. + -- 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'. From bf05e44191ccf91c01b307785c1cc2c427bae18d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 16 Apr 2026 09:37:37 +0200 Subject: [PATCH 081/111] include ExactDoc module from trivia tree attempt for full roundtrip --- Cabal-syntax/Cabal-syntax.cabal | 1 + .../src/Distribution/Pretty/ExactDoc.hs | 171 ++++++++++++++++++ 2 files changed, 172 insertions(+) create mode 100644 Cabal-syntax/src/Distribution/Pretty/ExactDoc.hs diff --git a/Cabal-syntax/Cabal-syntax.cabal b/Cabal-syntax/Cabal-syntax.cabal index 244d27f52a1..a8140bdd2e6 100644 --- a/Cabal-syntax/Cabal-syntax.cabal +++ b/Cabal-syntax/Cabal-syntax.cabal @@ -111,6 +111,7 @@ library Distribution.Parsec.Warning Distribution.Parsec.Source Distribution.Pretty + Distribution.Pretty.ExactDoc Distribution.SPDX Distribution.SPDX.License Distribution.SPDX.LicenseExceptionId 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 From 3f7e889179fa3a54491cebb1acdb8d7b8ccb1856 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 16 Apr 2026 10:20:43 +0200 Subject: [PATCH 082/111] reimplement prettyfield to exactdoc --- .../src/Distribution/FieldGrammar/Pretty.hs | 3 +- .../src/Distribution/Fields/Pretty.hs | 170 +++++++++++++++++- 2 files changed, 168 insertions(+), 5 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index f0f9d828dab..143796d13c2 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -133,9 +133,8 @@ ppField name fielddoc | PP.isEmpty fielddoc = [] | otherwise = [PrettyField name fielddoc] --- TODO(leana8959): push out doc position ppFieldPos :: FieldName -> [(Positions, Doc)] -> [PrettyFieldWith Mod.HasAnn] ppFieldPos name possFieldDocs = - [ PrettyField (fieldNamePos poss, name) fieldDoc + [ PrettyField (fieldNamePos poss, name) (fieldLinePos poss, fieldDoc) | (poss, fieldDoc) <- possFieldDocs ] diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index 7f2158263f1..13420984d0e 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -29,13 +29,22 @@ module Distribution.Fields.Pretty import Distribution.Compat.Prelude import Distribution.Pretty (showToken) import Prelude () +import Control.Monad ((<=<)) import Distribution.Parsec.Position import Distribution.Fields.Field (FieldName, Name) -import Distribution.Utils.Generic (fromUTF8BS) +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 @@ -49,6 +58,8 @@ data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoCommen 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 @@ -56,10 +67,18 @@ type PrettyField = PrettyFieldWith Mod.HasNoAnn -- 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) PP.Doc - | PrettySection FieldName [PP.Doc] [PrettyFieldWith mod] + = PrettyField (AttachPosition mod FieldName) (AttachPosition mod PP.Doc) + | PrettySection (AttachPosition mod FieldName) [PP.Doc] [PrettyFieldWith mod] | PrettyEmpty +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. @@ -71,6 +90,20 @@ deriving instance Show (PrettyFieldWith Mod.HasAnn) showFields :: (ann -> CommentPosition) -> [PrettyField] -> String showFields rann = showFields' rann (const id) 4 +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) @@ -215,3 +248,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 From 249709b64f7fb93a6fa17b4aa652564fc318fba7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 16 Apr 2026 10:27:32 +0200 Subject: [PATCH 083/111] demonstrate roundtrip in cli --- Cabal-syntax/src/Distribution/Fields/Pretty.hs | 1 + Cabal-tests/tests/ParserTests.hs | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index 13420984d0e..1f115a566be 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -17,6 +17,7 @@ module Distribution.Fields.Pretty , PrettyField , PrettyFieldWith (..) , showFields + , exactShowFields , showFields' -- * Transformation from 'P.Field' diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index dbd54ea151e..b10b3de73e3 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -40,6 +40,7 @@ import Distribution.Parsec (Parsec (..), explicitEitherP import Distribution.Pretty (Pretty (..), prettyShow) import Distribution.Fields.Parser (readFields') import Distribution.Fields.ParseResult +import Distribution.Fields.Pretty (PrettyFieldWith (..), exactShowFields) import Distribution.FieldGrammar.Parsec (ParsecFieldGrammar, parseFieldGrammar) import Distribution.FieldGrammar.Pretty (prettyFieldGrammar) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) @@ -274,7 +275,9 @@ miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do Left (_, errs) -> fail "ERROR in running field grammar" Right ok -> pure $ ok - print $ prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar pr'' + let prettyFields :: [PrettyFieldWith Mod.HasAnn] = prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar pr'' + putStrLn + $ exactShowFields prettyFields where input = "tests" "ParserTests" "miniBuildInfoDemo.cabal" From 11fc10c217ff2ae27231bee93c58692037ecce0f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 17 Apr 2026 17:02:35 +0200 Subject: [PATCH 084/111] add a small cabal file test --- Cabal-tests/tests/ParserTests.hs | 24 +++++++++++++++++++ .../tests/ParserTests/miniBuildInfoDemo.cabal | 6 ++--- .../tests/ParserTests/smallCabalFile.cabal | 0 3 files changed, 27 insertions(+), 3 deletions(-) create mode 100644 Cabal-tests/tests/ParserTests/smallCabalFile.cabal diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index b10b3de73e3..109814b629b 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -89,6 +89,7 @@ tests = testGroup "parsec tests" , parsecPrettyTests , miniBuildInfoAnnTest , miniBuildInfoTest + , smallCabalFileTest ] ------------------------------------------------------------------------------- @@ -281,6 +282,29 @@ miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do where input = "tests" "ParserTests" "miniBuildInfoDemo.cabal" +smallCabalFileTest :: TestTree +smallCabalFileTest = testCase "smallCabalFile" $ 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 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" "smallCabalFile.cabal" + miniBuildInfoTest :: TestTree miniBuildInfoTest = testCase "miniBuildInfo NoAnn" $ do fields <- readFields <$> BS.readFile input >>= \case diff --git a/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal b/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal index c40cffcd592..155894e1455 100644 --- a/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal +++ b/Cabal-tests/tests/ParserTests/miniBuildInfoDemo.cabal @@ -2,6 +2,6 @@ build-depends: - foo > 2, - bar > 3, - baz > 4, + 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..e69de29bb2d From d3e5d79392dd7e2e04ceca2d54e71efe77dfbc2f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 17 Apr 2026 17:20:50 +0200 Subject: [PATCH 085/111] XXX tree-wide change is necessary to parse with current entrypoint To parse with parseGenericPackageDescription, it is necessary to use buildInfoFieldGrammar. However, it is not yet fully generic. --- .../Distribution/PackageDescription/Parsec.hs | 58 +++++++++++-------- .../Types/GenericPackageDescription.hs | 4 +- .../Types/GenericPackageDescription/Lens.hs | 6 +- 3 files changed, 40 insertions(+), 28 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index 762246be8c3..bbbafe637ad 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -132,19 +133,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 src mod = StateT (SectionS mod) (ParseResult src) -- | State of section parser -data SectionS = SectionS - { _stateGpd :: !GenericPackageDescription - , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) +data SectionS mod = 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 #-} @@ -156,11 +157,12 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -- * then we parse sections (libraries, executables, etc) parseGenericPackageDescription' - :: Maybe CabalSpecVersion + :: forall mod src + . 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 -> @@ -208,21 +210,29 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do maybeWarnCabalVersion syntax pd -- Sections - let gpd = + let gpd :: GenericPackageDescriptionWith mod + gpd = emptyGenericPackageDescription & L.packageDescription .~ pd gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - checkForUndefinedCustomSetup gpd2 + -- 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 + -- 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 @@ -248,7 +258,7 @@ 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 :: CabalSpecVersion -> [Field Position] -> SectionParser mod src () goSections specVer = traverse_ process where process (Field (Name pos name) _) = @@ -268,24 +278,24 @@ goSections specVer = traverse_ process => ParsecFieldGrammar' a -- \^ grammar -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo + -> Map String CondTreeBuildInfoAnn -- \^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) parseCondTree' = parseCondTreeWithCommonStanzas specVer - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser src () + parseSection :: 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 case Map.lookup name' commonStanzas of - Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas + Nothing -> stateCommonStanzas .= Map.insert name' (biTree :: CondTreeBuildInfoWith mod) commonStanzas Just _ -> lift $ parseFailure pos $ @@ -422,10 +432,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] -> @@ -455,7 +465,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. @@ -599,7 +609,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. @@ -638,7 +650,7 @@ parseCondTreeWithCommonStanzas -- ^ grammar -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo + -> Map String CondTreeBuildInfoAnn -- ^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 330ee9e112a..81454ffa6ac 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -65,7 +65,7 @@ data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDesc , genPackageFlags :: [PackageFlag] , condLibrary :: (Maybe (CondTree ConfVar (LibraryWith m))) , condSubLibraries - :: [(UnqualComponentName, CondTree ConfVar Library)] + :: [(UnqualComponentName, CondTree ConfVar (LibraryWith m))] , condForeignLibs :: [(UnqualComponentName, CondTree ConfVar ForeignLib)] , condExecutables @@ -89,7 +89,7 @@ deriving instance Binary (GenericPackageDescriptionWith Mod.HasNoAnn) instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf -emptyGenericPackageDescription :: GenericPackageDescription +emptyGenericPackageDescription :: GenericPackageDescriptionWith mod emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] -- ----------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index 7d0b0be09cf..d2059433c7a 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -26,7 +26,7 @@ import Distribution.Types.Executable (Executable) import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag)) import Distribution.Types.ForeignLib (ForeignLib) import Distribution.Types.GenericPackageDescription (GenericPackageDescription, GenericPackageDescriptionWith (..)) -import Distribution.Types.Library (Library) +import Distribution.Types.Library (Library, LibraryWith) import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -36,7 +36,7 @@ import Distribution.Version (Version, VersionRange) -- GenericPackageDescription ------------------------------------------------------------------------------- -packageDescription :: Lens' GenericPackageDescription PackageDescription +packageDescription :: Lens' (GenericPackageDescriptionWith mod) PackageDescription packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s)) {-# INLINE packageDescription #-} @@ -48,7 +48,7 @@ genPackageFlags :: Lens' GenericPackageDescription [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 #-} From 5e756602e2833a60267ae8de44c44d046782b204 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Fri, 17 Apr 2026 17:24:48 +0200 Subject: [PATCH 086/111] Revert "XXX tree-wide change is necessary to parse with current entrypoint" This reverts commit d3e5d79392dd7e2e04ceca2d54e71efe77dfbc2f. --- .../Distribution/PackageDescription/Parsec.hs | 58 ++++++++----------- .../Types/GenericPackageDescription.hs | 4 +- .../Types/GenericPackageDescription/Lens.hs | 6 +- 3 files changed, 28 insertions(+), 40 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index bbbafe637ad..762246be8c3 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -133,19 +132,19 @@ fieldlinesToBS :: [FieldLine ann] -> BS.ByteString fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) -- Monad in which sections are parsed -type SectionParser src mod = StateT (SectionS mod) (ParseResult src) +type SectionParser src = StateT SectionS (ParseResult src) -- | State of section parser -data SectionS mod = SectionS - { _stateGpd :: !(GenericPackageDescriptionWith mod) - , _stateCommonStanzas :: !(Map String (CondTreeBuildInfoWith mod)) +data SectionS = SectionS + { _stateGpd :: !GenericPackageDescription + , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) } -stateGpd :: Lens' (SectionS mod) (GenericPackageDescriptionWith mod) +stateGpd :: Lens' SectionS GenericPackageDescription stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd {-# INLINE stateGpd #-} -stateCommonStanzas :: Lens' (SectionS mod) (Map String (CondTreeBuildInfoWith mod)) +stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs {-# INLINE stateCommonStanzas #-} @@ -157,12 +156,11 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -- * then we parse sections (libraries, executables, etc) parseGenericPackageDescription' - :: forall mod src - . Maybe CabalSpecVersion + :: Maybe CabalSpecVersion -> [LexWarning] -> Maybe Int -> [Field Position] - -> ParseResult src (GenericPackageDescriptionWith mod) + -> ParseResult src GenericPackageDescription parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do parseWarnings (toPWarnings lexWarnings) for_ utf8WarnPos $ \pos -> @@ -210,29 +208,21 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do maybeWarnCabalVersion syntax pd -- Sections - let gpd :: GenericPackageDescriptionWith mod - gpd = + let gpd = emptyGenericPackageDescription & L.packageDescription .~ pd gpd1 <- view stateGpd <$> execStateT (goSections 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 - pure gpd1 + gpd2 `deepseq` return gpd2 where safeLast :: [a] -> Maybe a safeLast = listToMaybe . reverse @@ -258,7 +248,7 @@ 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 mod src () +goSections :: CabalSpecVersion -> [Field Position] -> SectionParser src () goSections specVer = traverse_ process where process (Field (Name pos name) _) = @@ -278,24 +268,24 @@ goSections specVer = traverse_ process => ParsecFieldGrammar' a -- \^ grammar -> (BuildInfo -> a) - -> Map String CondTreeBuildInfoAnn + -> Map String CondTreeBuildInfo -- \^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) parseCondTree' = parseCondTreeWithCommonStanzas specVer - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser mod src () + parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser 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 :: Map String (CondTreeBuildInfoWith mod) <- use stateCommonStanzas + commonStanzas <- use stateCommonStanzas name' <- lift $ parseCommonName pos args biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields case Map.lookup name' commonStanzas of - Nothing -> stateCommonStanzas .= Map.insert name' (biTree :: CondTreeBuildInfoWith mod) commonStanzas + Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas Just _ -> lift $ parseFailure pos $ @@ -432,10 +422,10 @@ goSections specVer = traverse_ process parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name -parseName :: Position -> [SectionArg Position] -> SectionParser mod src String +parseName :: Position -> [SectionArg Position] -> SectionParser src String parseName pos args = fromUTF8BS <$> parseNameBS pos args -parseNameBS :: Position -> [SectionArg Position] -> SectionParser mod src BS.ByteString +parseNameBS :: Position -> [SectionArg Position] -> SectionParser src BS.ByteString -- TODO: use strict parser parseNameBS pos args = case args of [SecArgName _pos secName] -> @@ -465,7 +455,7 @@ parseCommonName pos args = case args of pure "" -- TODO: avoid conversion to 'String'. -parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser mod src UnqualComponentName +parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser src UnqualComponentName parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args -- | Parse a non-recursive list of fields. @@ -609,9 +599,7 @@ 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 CondTreeBuildInfoWith (mod :: Mod.HasAnnotation) = CondTree ConfVar (BuildInfoWith mod) -type CondTreeBuildInfo = CondTreeBuildInfoWith Mod.HasNoAnn -type CondTreeBuildInfoAnn = CondTreeBuildInfoWith Mod.HasAnn +type CondTreeBuildInfo = CondTree ConfVar BuildInfo -- | Create @a@ from 'BuildInfo'. -- This class is used to implement common stanza parsing. @@ -650,7 +638,7 @@ parseCondTreeWithCommonStanzas -- ^ grammar -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfoAnn + -> Map String CondTreeBuildInfo -- ^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 81454ffa6ac..330ee9e112a 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -65,7 +65,7 @@ data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDesc , genPackageFlags :: [PackageFlag] , condLibrary :: (Maybe (CondTree ConfVar (LibraryWith m))) , condSubLibraries - :: [(UnqualComponentName, CondTree ConfVar (LibraryWith m))] + :: [(UnqualComponentName, CondTree ConfVar Library)] , condForeignLibs :: [(UnqualComponentName, CondTree ConfVar ForeignLib)] , condExecutables @@ -89,7 +89,7 @@ deriving instance Binary (GenericPackageDescriptionWith Mod.HasNoAnn) instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf -emptyGenericPackageDescription :: GenericPackageDescriptionWith mod +emptyGenericPackageDescription :: GenericPackageDescription emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] -- ----------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index d2059433c7a..7d0b0be09cf 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -26,7 +26,7 @@ import Distribution.Types.Executable (Executable) import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag)) import Distribution.Types.ForeignLib (ForeignLib) import Distribution.Types.GenericPackageDescription (GenericPackageDescription, GenericPackageDescriptionWith (..)) -import Distribution.Types.Library (Library, LibraryWith) +import Distribution.Types.Library (Library) import Distribution.Types.PackageDescription (PackageDescription) import Distribution.Types.TestSuite (TestSuite) import Distribution.Types.UnqualComponentName (UnqualComponentName) @@ -36,7 +36,7 @@ import Distribution.Version (Version, VersionRange) -- GenericPackageDescription ------------------------------------------------------------------------------- -packageDescription :: Lens' (GenericPackageDescriptionWith mod) PackageDescription +packageDescription :: Lens' GenericPackageDescription PackageDescription packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s)) {-# INLINE packageDescription #-} @@ -48,7 +48,7 @@ genPackageFlags :: Lens' GenericPackageDescription [PackageFlag] genPackageFlags f s = fmap (\x -> s{T.genPackageFlags = x}) (f (T.genPackageFlags s)) {-# INLINE genPackageFlags #-} -condLibrary :: Lens' (GenericPackageDescriptionWith mod) (Maybe (CondTree ConfVar (LibraryWith mod))) +condLibrary :: Lens' GenericPackageDescription (Maybe (CondTree ConfVar Library)) condLibrary f s = fmap (\x -> s{T.condLibrary = x}) (f (T.condLibrary s)) {-# INLINE condLibrary #-} From a376ef20aa4b7fe8ca27075cad6750c70a36d02c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 22 Apr 2026 12:17:11 +0200 Subject: [PATCH 087/111] update buildinfofieldgrammar' to compile again --- .../PackageDescription/FieldGrammar.hs | 93 +++++++++++-------- .../src/Distribution/Types/BuildInfo.hs | 86 +++++++++-------- .../src/Distribution/Types/BuildInfo/Lens.hs | 38 ++++---- 3 files changed, 113 insertions(+), 104 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 1da17f9258c..fa6975c4a11 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -717,27 +717,38 @@ buildInfoFieldGrammar' , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - -- , Newtype [Annotate mod LegacyExeDependency] (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - -- , c (ListWith mod CommaFSep (Identity LegacyExeDependency) LegacyExeDependency) - -- , Newtype [Annotate mod ExeDependency] (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - -- , c (ListWith mod CommaFSep (Identity ExeDependency) ExeDependency) - -- , Newtype [Annotate mod String] (ListWith mod NoCommaFSep Token' String) - -- , c (ListWith mod NoCommaFSep Token' String) - -- , Newtype [Annotate mod PkgconfigDependency] (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - -- , c (ListWith mod CommaFSep (Identity PkgconfigDependency) PkgconfigDependency) - -- , Newtype [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 [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 [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 [Annotate mod (SymbolicPath Pkg (Dir Source))])) - -- , Newtype [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 [Annotate mod ModuleName] (ListWith mod VCat (MQuoted ModuleName) ModuleName) - -- , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) + + , 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) + -- TODO(leana8959): constraints go here , Newtype @@ -748,26 +759,26 @@ buildInfoFieldGrammar' => 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 - -- astSources <- 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 + 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 -- TODO(leana8959): add more diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 65108694396..a1de0cc5141 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -55,7 +55,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo { buildable :: AnnotateWith Positions m Bool -- ^ component is buildable here - , buildTools :: PreserveGrouping m (AttachPositions m [Annotate m 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. @@ -63,7 +63,7 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , buildToolDepends :: PreserveGrouping m (AttachPositions m [Annotate m 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 @@ -72,40 +72,40 @@ data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo -- Unless use are very sure what you are doing, use the functions in -- "Distribution.Simple.BuildToolDepends" rather than accessing this -- field directly. - , cppOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , cppOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for pre-processing Haskell code - , asmOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , asmOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for assembler - , cmmOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , cmmOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for C-- compiler - , ccOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , ccOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for C compiler - , cxxOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , cxxOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for C++ compiler - , jsppOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , jsppOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for pre-processing JavaScript code @since 3.16.0.0 - , ldOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , ldOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for linker - , hsc2hsOptions :: PreserveGrouping m (AttachPositions m [Annotate m String]) + , hsc2hsOptions :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m String)]) -- ^ options for hsc2hs - , pkgconfigDepends :: PreserveGrouping m (AttachPositions m [Annotate m PkgconfigDependency]) + , pkgconfigDepends :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m PkgconfigDependency)]) -- ^ pkg-config packages that are used - , frameworks :: PreserveGrouping m (AttachPositions m [Annotate m (RelativePath Framework File)]) + , frameworks :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (RelativePath Framework File))]) -- ^ support frameworks for Mac OS X - , extraFrameworkDirs :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg (Dir Framework))]) + , extraFrameworkDirs :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg (Dir Framework)))]) -- ^ extra locations to find frameworks. - , asmSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) + , asmSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) -- ^ Assembly files. - , cmmSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) + , cmmSources :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m (SymbolicPath Pkg File))]) -- ^ C-- files. - , cSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) - , cxxSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) - , jsSources :: PreserveGrouping m (AttachPositions m [Annotate m (SymbolicPath Pkg File)]) + , 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 :: PreserveGrouping m (AttachPositions m [Annotate m 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) @@ -181,36 +181,34 @@ instance NFData BuildInfo where rnf = genericRnf unannotateBuildInfo :: BuildInfoAnn -> BuildInfo unannotateBuildInfo bi = + let unannotateMonoidalField = map (unAnn . snd) . join . map snd + in bi { buildable = unAnn $ buildable bi - , buildTools = map unAnn $ join $ map snd $ buildTools bi - , buildToolDepends = map unAnn $ join $ map snd $ buildToolDepends bi - , cppOptions = map unAnn $ join $ map snd $ cppOptions bi - , asmOptions = map unAnn $ join $ map snd $ asmOptions bi - , cmmOptions = map unAnn $ join $ map snd $ cmmOptions bi - , ccOptions = map unAnn $ join $ map snd $ ccOptions bi - , cxxOptions = map unAnn $ join $ map snd $ cxxOptions bi - , jsppOptions = map unAnn $ join $ map snd $ jsppOptions bi - , ldOptions = map unAnn $ join $ map snd $ ldOptions bi - , hsc2hsOptions = map unAnn $ join $ map snd $ hsc2hsOptions bi - , pkgconfigDepends = map unAnn $ join $ map snd $ pkgconfigDepends bi - , frameworks = map unAnn $ join $ map snd $ frameworks bi - , extraFrameworkDirs = map unAnn $ join $ map snd $ extraFrameworkDirs bi - , asmSources = map unAnn $ join $ map snd $ asmSources bi - , cmmSources = map unAnn $ join $ map snd $ cmmSources bi - , cSources = map unAnn $ join $ map snd $ cSources bi - , cxxSources = map unAnn $ join $ map snd $ cxxSources bi - , jsSources = map unAnn $ join $ map snd $ jsSources bi - , hsSourceDirs = map (unAnn . snd) $ join $ map snd $ hsSourceDirs bi - , otherModules = map unAnn $ join $ map snd $ otherModules 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 + targetBuildDepends = map (unannotateDependencyAnn . unAnn . snd) $ join $ map snd $ targetBuildDepends bi } instance Monoid BuildInfo where diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index 06cdbc4c387..a3445620a37 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -50,64 +50,64 @@ class HasBuildInfoWith mod a | a -> mod where buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AnnotateWith Positions mod Bool) buildable = buildInfo @mod . buildable @mod - buildTools :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (PreserveGrouping mod (AttachPositions mod [Annotate mod LegacyExeDependency])) + 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 [Annotate mod ExeDependency])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod String])) + 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 [Annotate mod PkgconfigDependency])) + 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 [Annotate mod (RelativePath Framework File)])) + 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 [Annotate mod (SymbolicPath Pkg (Dir Framework))])) + 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 [Annotate mod (SymbolicPath Pkg File)])) + 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 [Annotate mod (SymbolicPath Pkg File)])) + 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 [Annotate mod (SymbolicPath Pkg File)])) + 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 [Annotate mod (SymbolicPath Pkg File)])) + 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 [Annotate mod (SymbolicPath Pkg File)])) + 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 [Annotate mod ModuleName])) + 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] From 326e02904d1e3a5de933326582d5ee264b549303 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 22 Apr 2026 13:32:02 +0200 Subject: [PATCH 088/111] parse all fields of build info --- .../PackageDescription/FieldGrammar.hs | 48 +++++++++++++++++-- 1 file changed, 45 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index fa6975c4a11..ffd139bd903 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -749,12 +749,27 @@ buildInfoFieldGrammar' , Newtype [AttachPosition mod (Annotate mod ModuleName)] (ListWith mod VCat (MQuoted ModuleName) ModuleName) , c (ListWith mod VCat (MQuoted ModuleName) ModuleName) - -- TODO(leana8959): constraints go here + , 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 @@ -780,9 +795,36 @@ buildInfoFieldGrammar' = do hsSourceDirs <- hsSourceDirsGrammar @mod otherModules <- monoidalFieldAla' "other-modules" (formatOtherModules @mod) L.otherModules - -- TODO(leana8959): add more - targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends + + -- 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 + mixins <- monoidalFieldAla "mixins" formatMixinList L.mixins + pure (BuildInfo{..}) -- {-# SPECIALIZE buildInfoFieldGrammar' :: ParsecFieldGrammar Mod.HasAnn BuildInfoAnn BuildInfoAnn #-} From 9d9cf652ebfac3eb11a291e9b10e39b3a9d8c71a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 22 Apr 2026 13:34:00 +0200 Subject: [PATCH 089/111] rewire buildinfofieldgrammar --- .../src/Distribution/FieldGrammar/Parsec.hs | 2 ++ .../src/Distribution/FieldGrammar/Pretty.hs | 2 ++ .../Distribution/PackageDescription/FieldGrammar.hs | 13 +++++++++---- 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 1a4f53b5f6c..603ba1073e6 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -204,6 +204,8 @@ instance FieldGrammarWith Mod.HasNoAnn 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 diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 143796d13c2..f2d6b481fb7 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -58,6 +58,8 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where where b = aview l s + booleanFieldDef' = booleanFieldDef + optionalFieldAla fn _pack l = PrettyFG pp where pp v s = case aview l s of diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index ffd139bd903..c3236276bcc 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -597,6 +597,8 @@ unvalidateBenchmark b = -- Build info ------------------------------------------------------------------------------- +{- + buildInfoFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g @@ -711,7 +713,9 @@ buildInfoFieldGrammar = -- {-# SPECIALIZE buildInfoFieldGrammar :: ParsecFieldGrammar' BuildInfoAnn #-} -- {-# SPECIALIZE buildInfoFieldGrammar :: PrettyFieldGrammar' BuildInfoAnn #-} -buildInfoFieldGrammar' +-} + +buildInfoFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g , Applicative (g mod (BuildInfoWith mod)) @@ -772,7 +776,7 @@ buildInfoFieldGrammar' , c (List CommaVCat (Identity Mixin) Mixin) ) => g mod (BuildInfoWith mod) (BuildInfoWith mod) -buildInfoFieldGrammar' = do +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 @@ -795,8 +799,6 @@ buildInfoFieldGrammar' = do hsSourceDirs <- hsSourceDirsGrammar @mod otherModules <- monoidalFieldAla' "other-modules" (formatOtherModules @mod) L.otherModules - targetBuildDepends <- monoidalFieldAla' "build-depends" (formatDependencyList @mod) L.targetBuildDepends - -- 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 @@ -823,6 +825,9 @@ buildInfoFieldGrammar' = do 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{..}) From 86a5f5bb71ddd9187084b000626e249e285a6691 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 22 Apr 2026 13:44:18 +0200 Subject: [PATCH 090/111] polymorphize libraryFieldGrammar --- .../PackageDescription/FieldGrammar.hs | 45 +++++++++++++++++-- 1 file changed, 42 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index c3236276bcc..50e3c84743b 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -185,8 +185,47 @@ libraryFieldGrammar , Applicative (g mod (LibraryWith mod)) , Applicative (g mod (BuildInfoWith mod)) , L.HasBuildInfoWith mod (BuildInfoWith mod) - , -- TODO(leana8959): use legacy for now, not completely polymorphic - mod ~ Mod.HasNoAnn + + +-- 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) @@ -215,7 +254,7 @@ libraryFieldGrammar n = ^^^ availableSince CabalSpecV2_0 [] <*> 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 From 8231f556f96167eb6ff9eb626faccc884b0f93e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Wed, 22 Apr 2026 19:24:26 +0200 Subject: [PATCH 091/111] checkpoint --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 6 + .../PackageDescription/FieldGrammar.hs | 265 +++++++++++++++--- .../Distribution/PackageDescription/Parsec.hs | 113 ++++---- .../src/Distribution/Types/Benchmark.hs | 22 +- .../src/Distribution/Types/Benchmark/Lens.hs | 10 +- .../src/Distribution/Types/BuildInfo.hs | 1 + .../src/Distribution/Types/CondTree.hs | 18 +- .../src/Distribution/Types/Executable.hs | 19 +- .../src/Distribution/Types/Executable/Lens.hs | 12 +- .../src/Distribution/Types/ForeignLib.hs | 19 +- .../src/Distribution/Types/ForeignLib/Lens.hs | 19 +- .../Types/GenericPackageDescription.hs | 12 +- .../Types/GenericPackageDescription/Lens.hs | 24 +- .../src/Distribution/Types/TestSuite.hs | 22 +- 14 files changed, 406 insertions(+), 156 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index c94c3b6128a..48c2654d043 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,11 +17,13 @@ module Distribution.FieldGrammar -- * Concrete grammar implementations , ParsecFieldGrammar , ParsecFieldGrammar' + , ParsecFieldGrammarWith' , parseFieldGrammar , parseFieldGrammarCheckingStanzas , fieldGrammarKnownFieldList , PrettyFieldGrammar , PrettyFieldGrammar' + , PrettyFieldGrammarWith' , prettyFieldGrammar -- * Auxiliary @@ -51,6 +54,9 @@ import Distribution.Utils.Generic (spanMaybe) 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 diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 50e3c84743b..009975fd97e 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -31,7 +31,8 @@ module Distribution.PackageDescription.FieldGrammar , executableFieldGrammar -- * Test suite - , TestSuiteStanza (..) + , TestSuiteStanza + , TestSuiteStanzaWith (..) , testSuiteFieldGrammar , validateTestSuite , unvalidateTestSuite @@ -272,9 +273,53 @@ libraryFieldGrammar n = ------------------------------------------------------------------------------- foreignLibFieldGrammar - :: ( FieldGrammar c g - , Applicative (g Mod.HasNoAnn ForeignLib) - , Applicative (g Mod.HasNoAnn 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) @@ -296,26 +341,73 @@ foreignLibFieldGrammar , c (MQuoted Language) ) => UnqualComponentName - -> g Mod.HasNoAnn 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 Mod.HasNoAnn Executable) - , Applicative (g Mod.HasNoAnn 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) @@ -338,14 +430,14 @@ executableFieldGrammar , c (MQuoted Language) ) => UnqualComponentName - -> g Mod.HasNoAnn 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 #-} @@ -353,43 +445,89 @@ 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.HasBuildInfoWith Mod.HasNoAnn 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 Mod.HasNoAnn TestSuiteStanza) - , Applicative (g Mod.HasNoAnn 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) @@ -410,13 +548,13 @@ testSuiteFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g Mod.HasNoAnn 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 [] @@ -503,38 +641,85 @@ 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.HasBuildInfoWith Mod.HasNoAnn 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 Mod.HasNoAnn BenchmarkStanza) - , Applicative (g Mod.HasNoAnn 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) @@ -554,7 +739,7 @@ benchmarkFieldGrammar , c (List VCat Token String) , c (MQuoted Language) ) - => g Mod.HasNoAnn BenchmarkStanza BenchmarkStanza + => g mod (BenchmarkStanzaWith mod) (BenchmarkStanzaWith mod) benchmarkFieldGrammar = BenchmarkStanza <$> optionalField "type" benchmarkStanzaBenchmarkType @@ -1152,10 +1337,10 @@ _syntaxFieldNames = mconcat [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar , fieldGrammarKnownFieldList $ (libraryFieldGrammar @Mod.HasNoAnn) LMainLibName - , fieldGrammarKnownFieldList $ executableFieldGrammar "exe" - , fieldGrammarKnownFieldList $ foreignLibFieldGrammar "flib" - , fieldGrammarKnownFieldList testSuiteFieldGrammar - , fieldGrammarKnownFieldList benchmarkFieldGrammar + , 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 762246be8c3..a690c2e92b2 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} @@ -132,19 +133,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 #-} @@ -156,11 +157,12 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -- * then we parse sections (libraries, executables, etc) parseGenericPackageDescription' - :: Maybe CabalSpecVersion + :: forall mod src + . 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 -> @@ -208,21 +210,29 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do maybeWarnCabalVersion syntax pd -- Sections - let gpd = + let gpd :: GenericPackageDescriptionWith mod + gpd = emptyGenericPackageDescription & L.packageDescription .~ pd gpd1 <- view stateGpd <$> execStateT (goSections specVer sectionFields) (SectionS gpd Map.empty) - let gpd2 = postProcessInternalDeps specVer gpd1 - checkForUndefinedFlags gpd2 - checkForUndefinedCustomSetup gpd2 + -- 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 + -- 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 @@ -248,7 +258,7 @@ 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 :: Mod.HasAnnotation) src. CabalSpecVersion -> [Field Position] -> SectionParser mod src () goSections specVer = traverse_ process where process (Field (Name pos name) _) = @@ -264,25 +274,25 @@ goSections specVer = traverse_ process -- we need signature, because this is polymorphic, but not-closed parseCondTree' - :: L.HasBuildInfo a - => ParsecFieldGrammar' a + :: L.HasBuildInfoWith mod a + => ParsecFieldGrammarWith' mod a -- \^ grammar - -> (BuildInfo -> a) - -> Map String CondTreeBuildInfo + -> (BuildInfoWith mod -> a) + -> Map String (CondTreeBuildInfoWith mod) -- \^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) - parseCondTree' = parseCondTreeWithCommonStanzas specVer + parseCondTree' = parseCondTreeWithCommonStanzas @mod @src specVer - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser src () + parseSection :: 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 @mod) name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' buildInfoFieldGrammar id commonStanzas fields + biTree <- lift $ parseCondTree' (buildInfoFieldGrammar @mod) id commonStanzas fields case Map.lookup name' commonStanzas of Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas @@ -298,10 +308,10 @@ 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 @mod name'') commonStanzas fields -- -- TODO check that not set - stateGpd . L.condLibrary ?= lib + (stateGpd @mod) . L.condLibrary ?= lib -- Sublibraries -- TODO: check cabal-version @@ -309,7 +319,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 @mod name'') (libraryFromBuildInfo @mod name'') commonStanzas fields -- TODO check duplicate name here? stateGpd . L.condSubLibraries %= snoc (name', lib) @@ -317,7 +327,7 @@ 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 @mod name') (fromBuildInfo' name') commonStanzas fields let hasType ts = foreignLibType ts /= foreignLibType mempty unless (onAllBranches hasType flib) $ @@ -336,13 +346,13 @@ 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 @mod name') (fromBuildInfo' name') commonStanzas 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 + testStanza <- lift $ parseCondTree' (testSuiteFieldGrammar @mod) (fromBuildInfo' name') commonStanzas fields testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza let hasType ts = testInterface ts /= testInterface mempty @@ -370,7 +380,7 @@ goSections specVer = traverse_ process | name == "benchmark" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' benchmarkFieldGrammar (fromBuildInfo' name') commonStanzas fields + benchStanza <- lift $ parseCondTree' (benchmarkFieldGrammar @mod) (fromBuildInfo' name') commonStanzas fields bench <- lift $ traverse (validateBenchmark specVer pos) benchStanza let hasType ts = benchmarkInterface ts /= benchmarkInterface mempty @@ -422,10 +432,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] -> @@ -455,7 +465,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. @@ -475,14 +485,14 @@ 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 => CabalSpecVersion -> HasElif -- ^ accept @elif@ -> ParsecFieldGrammar' a -- ^ grammar - -> Map String CondTreeBuildInfo + -> Map String CondTreeBuildInfoAnn -- ^ common stanzas -> (BuildInfo -> a) -- ^ constructor from buildInfo @@ -599,7 +609,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. @@ -610,7 +622,7 @@ type CondTreeBuildInfo = CondTree ConfVar BuildInfo class L.HasBuildInfo a => FromBuildInfo a where fromBuildInfo' :: UnqualComponentName -> BuildInfo -> a -libraryFromBuildInfo :: LibraryName -> BuildInfo -> Library +libraryFromBuildInfo :: LibraryName -> BuildInfoWith mod -> LibraryWith mod libraryFromBuildInfo n bi = emptyLibrary { libName = n @@ -631,14 +643,14 @@ instance FromBuildInfo BenchmarkStanza where fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi parseCondTreeWithCommonStanzas - :: forall src a - . L.HasBuildInfo a + :: forall mod src a + . L.HasBuildInfoWith mod a => CabalSpecVersion - -> ParsecFieldGrammar' a + -> ParsecFieldGrammarWith' mod a -- ^ grammar - -> (BuildInfo -> a) + -> (BuildInfoWith mod -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo + -> Map String (CondTreeBuildInfoWith mod) -- ^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) @@ -650,12 +662,12 @@ parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do hasElif = specHasElif v processImports - :: forall src a - . L.HasBuildInfo a + :: forall (mod :: Mod.HasAnnotation) src a + . L.HasBuildInfoWith mod a => CabalSpecVersion -> (BuildInfo -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfo + -> Map String CondTreeBuildInfoAnn -- ^ common stanzas -> [Field Position] -> ParseResult src ([Field Position], CondTree ConfVar a -> CondTree ConfVar a) @@ -666,6 +678,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 @@ -699,9 +715,10 @@ 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 a + . L.HasBuildInfoWith mod a + => (BuildInfoWith mod -> a) + -> CondTree ConfVar (BuildInfoWith mod) -> CondTree ConfVar a -> CondTree ConfVar a mergeCommonStanza fromBuildInfo (CondNode bi bis) (CondNode x cs) = diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/Cabal-syntax/src/Distribution/Types/Benchmark.hs index ccb659f5f0d..a53e0ca037f 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -1,10 +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 @@ -24,19 +29,26 @@ 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 instance Binary Benchmark instance Structured Benchmark instance NFData Benchmark where rnf = genericRnf -instance L.HasBuildInfoWith Mod.HasNoAnn 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 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 a1de0cc5141..1aab2ae2d4e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -11,6 +11,7 @@ module Distribution.Types.BuildInfo ( BuildInfo , BuildInfoAnn , BuildInfoWith (..) + , unannotateBuildInfo , unannotateDependencyAnn , emptyBuildInfo , allLanguages diff --git a/Cabal-syntax/src/Distribution/Types/CondTree.hs b/Cabal-syntax/src/Distribution/Types/CondTree.hs index 7832b483391..22e654fcce3 100644 --- a/Cabal-syntax/src/Distribution/Types/CondTree.hs +++ b/Cabal-syntax/src/Distribution/Types/CondTree.hs @@ -10,10 +10,8 @@ {-# LANGUAGE TypeSynonymInstances #-} module Distribution.Types.CondTree - ( CondTree - , CondTreeWith (..) - , CondBranch - , CondBranchWith (..) + ( CondTree (..) + , CondBranch (..) , condIfThen , condIfThenElse , foldCondTree @@ -64,9 +62,7 @@ import qualified Distribution.Compat.Lens as L -- derived off of 'targetBuildInfo' (perhaps a good refactoring -- would be to convert this into an opaque type, with a smart -- constructor that pre-computes the dependencies.) -type CondTree = CondTreeWith Identity - -data CondTreeWith f v a = CondNode +data CondTree v a = CondNode { condTreeData :: a , condTreeComponents :: [CondBranch v a] } @@ -99,12 +95,10 @@ instance (Semigroup a, Monoid a) => Monoid (CondTree v a) where -- | A 'CondBranch' represents a conditional branch, e.g., @if -- flag(foo)@ on some syntax @a@. It also has an optional false -- branch. -type CondBranch = CondBranchWith Identity - -data CondBranchWith (f :: Type -> Type) v a = CondBranch +data CondBranch v a = CondBranch { condBranchCondition :: Condition v - , condBranchIfTrue :: CondTreeWith f v a - , condBranchIfFalse :: Maybe (CondTreeWith f v a) + , condBranchIfTrue :: CondTree v a + , condBranchIfFalse :: Maybe (CondTree v a) } deriving (Generic) diff --git a/Cabal-syntax/src/Distribution/Types/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs index f89ccc70937..a5621209bd3 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -1,10 +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 @@ -23,13 +27,20 @@ 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.HasBuildInfoWith Mod.HasNoAnn Executable where buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l) 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 fe6efb6827a..8a3545fdcdf 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -1,10 +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 @@ -40,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 @@ -50,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. @@ -64,7 +70,12 @@ 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 data LibVersionInfo = LibVersionInfo Int Int Int deriving (Data, Eq, Generic) 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 330ee9e112a..3d8fe95912e 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -65,15 +65,15 @@ data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDesc , genPackageFlags :: [PackageFlag] , 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 instance Eq (GenericPackageDescriptionWith Mod.HasNoAnn) @@ -89,7 +89,7 @@ deriving instance Binary (GenericPackageDescriptionWith Mod.HasNoAnn) instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf -emptyGenericPackageDescription :: GenericPackageDescription +emptyGenericPackageDescription :: GenericPackageDescriptionWith mod emptyGenericPackageDescription = GenericPackageDescription emptyPackageDescription Nothing [] Nothing [] [] [] [] [] -- ----------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index 7d0b0be09cf..9e1848f00ce 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.ForeignLib (ForeignLib, ForeignLibWith) import Distribution.Types.GenericPackageDescription (GenericPackageDescription, GenericPackageDescriptionWith (..)) -import Distribution.Types.Library (Library) +import Distribution.Types.Library (Library, LibraryWith) import Distribution.Types.PackageDescription (PackageDescription) -import Distribution.Types.TestSuite (TestSuite) +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) PackageDescription packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s)) {-# INLINE packageDescription #-} @@ -48,27 +48,27 @@ genPackageFlags :: Lens' GenericPackageDescription [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/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs index 5440e3f09e0..39d65654a4e 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -1,10 +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 @@ -24,16 +29,23 @@ 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 -instance L.HasBuildInfoWith Mod.HasNoAnn 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 From 9f1467a457742fe08b2c1196ee9b0719cd7aa5ad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 23 Apr 2026 13:59:10 +0200 Subject: [PATCH 092/111] fully generalize goSection && parseGenericParsecDescription --- .../PackageDescription/FieldGrammar.hs | 65 ++++- .../Distribution/PackageDescription/Parsec.hs | 274 ++++++++++++++---- Cabal-syntax/src/Distribution/Trivia.hs | 7 +- .../src/Distribution/Types/BuildInfo.hs | 120 ++++++++ .../src/Distribution/Types/Executable.hs | 23 ++ .../src/Distribution/Types/ForeignLib.hs | 31 ++ .../Types/GenericPackageDescription/Lens.hs | 2 +- Cabal-syntax/src/Distribution/Types/Modify.hs | 1 + .../src/Distribution/Types/TestSuite.hs | 23 ++ 9 files changed, 479 insertions(+), 67 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 009975fd97e..12832fa87a3 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -44,7 +44,8 @@ module Distribution.PackageDescription.FieldGrammar , testStanzaBuildInfo -- * Benchmark - , BenchmarkStanza (..) + , BenchmarkStanza + , BenchmarkStanzaWith (..) , benchmarkFieldGrammar , validateBenchmark , unvalidateBenchmark @@ -77,6 +78,7 @@ module Distribution.PackageDescription.FieldGrammar , buildInfoFieldGrammar , MiniBuildInfo (..) , miniBuildInfoFieldGrammar + , BuildInfoConstraint ) where import Distribution.Compat.Lens @@ -939,6 +941,67 @@ buildInfoFieldGrammar = -} + +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 diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index a690c2e92b2..5df32e06859 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -56,7 +58,7 @@ 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 (..)) @@ -85,7 +87,30 @@ 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) + + , 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 @@ -107,7 +132,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 @@ -125,7 +150,30 @@ 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) + + , 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 @@ -158,7 +206,33 @@ stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs -- * then we parse sections (libraries, executables, etc) parseGenericPackageDescription' :: forall mod src - . Maybe CabalSpecVersion + . ( Semigroup (BuildInfoWith 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] @@ -214,7 +288,7 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do gpd = emptyGenericPackageDescription & 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. @@ -258,9 +332,36 @@ 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 :: forall (mod :: Mod.HasAnnotation) src. CabalSpecVersion -> [Field Position] -> SectionParser mod 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 (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) + ) => + Field Position -> SectionParser mod src () process (Field (Name pos name) _) = lift $ parseWarning pos PWTTrailingFields $ @@ -274,25 +375,46 @@ goSections specVer = traverse_ process -- we need signature, because this is polymorphic, but not-closed parseCondTree' - :: L.HasBuildInfoWith mod a - => ParsecFieldGrammarWith' mod a + :: + -- forall mod src a + -- . + + + ( L.HasBuildInfoWith mod a + , Semigroup (BuildInfoWith mod) + ) => + + ParsecFieldGrammarWith' mod a -- \^ grammar -> (BuildInfoWith mod -> a) -> Map String (CondTreeBuildInfoWith mod) -- \^ common stanzas -> [Field Position] -> ParseResult src (CondTree ConfVar a) - parseCondTree' = parseCondTreeWithCommonStanzas @mod @src specVer - - parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser mod 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) + ) => + 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 :: Map String (CondTreeBuildInfoWith mod) <- use (stateCommonStanzas @mod) + commonStanzas :: Map String (CondTreeBuildInfoWith mod) <- use stateCommonStanzas name' <- lift $ parseCommonName pos args - biTree <- lift $ parseCondTree' (buildInfoFieldGrammar @mod) id commonStanzas fields + biTree :: CondTreeBuildInfoWith mod <- lift $ parseCondTree' (buildInfoFieldGrammar @mod) id commonStanzas fields case Map.lookup name' commonStanzas of Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas @@ -308,10 +430,10 @@ goSections specVer = traverse_ process commonStanzas <- use stateCommonStanzas let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar @mod name'') (libraryFromBuildInfo @mod name'') commonStanzas fields + lib <- lift $ parseCondTree' (libraryFieldGrammar @mod name'') (libraryFromBuildInfo name'') commonStanzas fields -- -- TODO check that not set - (stateGpd @mod) . L.condLibrary ?= lib + stateGpd . L.condLibrary ?= lib -- Sublibraries -- TODO: check cabal-version @@ -319,7 +441,7 @@ goSections specVer = traverse_ process commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args let name'' = LSubLibName name' - lib <- lift $ parseCondTree' (libraryFieldGrammar @mod name'') (libraryFromBuildInfo @mod name'') commonStanzas fields + lib <- lift $ parseCondTree' (libraryFieldGrammar name'') (libraryFromBuildInfo name'') commonStanzas fields -- TODO check duplicate name here? stateGpd . L.condSubLibraries %= snoc (name', lib) @@ -327,9 +449,9 @@ goSections specVer = traverse_ process | name == "foreign-library" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree' (foreignLibFieldGrammar @mod name') (fromBuildInfo' name') commonStanzas fields + flib <- lift $ parseCondTree' (foreignLibFieldGrammar name') (fromBuildInfo' name') commonStanzas fields - let hasType ts = foreignLibType ts /= foreignLibType mempty + let hasType ts = foreignLibType ts /= foreignLibType (mempty :: ForeignLibWith mod) unless (onAllBranches hasType flib) $ lift $ parseFailure pos $ @@ -346,16 +468,18 @@ goSections specVer = traverse_ process | name == "executable" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree' (executableFieldGrammar @mod name') (fromBuildInfo' name') commonStanzas fields + exe <- lift $ parseCondTree' (executableFieldGrammar name') (fromBuildInfo' name') commonStanzas 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 @mod) (fromBuildInfo' name') commonStanzas fields - testSuite <- lift $ traverse (validateTestSuite specVer pos) testStanza + -- 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 + let hasType ts = testInterface ts /= testInterface (mempty :: TestSuiteWith mod) unless (onAllBranches hasType testSuite) $ lift $ parseFailure pos $ @@ -380,28 +504,29 @@ goSections specVer = traverse_ process | name == "benchmark" = do commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree' (benchmarkFieldGrammar @mod) (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) @@ -486,15 +611,18 @@ warnInvalidSubsection (MkSection (Name pos name) _ _) = parseCondTree :: forall mod src a - . L.HasBuildInfoWith mod 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 CondTreeBuildInfoAnn + -> Map String (CondTreeBuildInfoWith mod) -- ^ common stanzas - -> (BuildInfo -> a) + -> (BuildInfoWith mod -> a) -- ^ constructor from buildInfo -> [Field Position] -> ParseResult src (CondTree ConfVar a) @@ -619,8 +747,8 @@ type CondTreeBuildInfoAnn = CondTreeBuildInfoWith Mod.HasAnn -- 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 -> BuildInfoWith mod -> LibraryWith mod libraryFromBuildInfo n bi = @@ -632,20 +760,33 @@ 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 FromBuildInfo TestSuiteStanza where +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) => FromBuildInfoWith mod (TestSuiteStanzaWith mod) where fromBuildInfo' _ bi = TestSuiteStanza Nothing Nothing Nothing bi [] -instance FromBuildInfo BenchmarkStanza where +instance L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) => FromBuildInfoWith mod (BenchmarkStanzaWith mod) where fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi parseCondTreeWithCommonStanzas :: forall mod src a - . L.HasBuildInfoWith mod a - => CabalSpecVersion + . ( L.HasBuildInfoWith mod a + , L.HasBuildInfoWith mod (BuildInfoWith mod) + , Semigroup (BuildInfoWith mod) + ) + => CabalSpecVersion -> ParsecFieldGrammarWith' mod a -- ^ grammar -> (BuildInfoWith mod -> a) @@ -663,11 +804,14 @@ parseCondTreeWithCommonStanzas v grammar fromBuildInfo commonStanzas fields = do processImports :: forall (mod :: Mod.HasAnnotation) src a - . L.HasBuildInfoWith mod a + . ( L.HasBuildInfoWith mod (BuildInfoWith mod) + , L.HasBuildInfoWith mod a + , Semigroup (BuildInfoWith mod) + ) => CabalSpecVersion - -> (BuildInfo -> a) + -> (BuildInfoWith mod -> a) -- ^ construct fromBuildInfo - -> Map String CondTreeBuildInfoAnn + -> Map String (CondTreeBuildInfoWith mod) -- ^ common stanzas -> [Field Position] -> ParseResult src ([Field Position], CondTree ConfVar a -> CondTree ConfVar a) @@ -715,8 +859,10 @@ warnImport v (Field (Name pos name) _) | name == "import" = do warnImport _ f = pure (Just f) mergeCommonStanza - :: forall mod a - . L.HasBuildInfoWith mod a + :: forall (mod :: Mod.HasAnnotation) a + . ( L.HasBuildInfoWith mod a + , Semigroup (BuildInfoWith mod) + ) => (BuildInfoWith mod -> a) -> CondTree ConfVar (BuildInfoWith mod) -> CondTree ConfVar a diff --git a/Cabal-syntax/src/Distribution/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index c4c8cb8278b..e20678991e6 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TupleSections #-} @@ -41,7 +43,7 @@ data Trivia t | ExactRepresentation String | IsInserted | NoTrivia - deriving (Show, Eq, Ord, Read, Data) + deriving (Show, Eq, Ord, Read, Data, Functor) preTrivia :: String -> Trivia SurroundingText preTrivia s = HasTrivia (SurroundingText s mempty) @@ -59,6 +61,9 @@ instance Semigroup t => Semigroup (Trivia t) where 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 diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 1aab2ae2d4e..2435768ff47 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -25,6 +25,9 @@ module Distribution.Types.BuildInfo , hcStaticOptions ) where +import qualified Data.Semigroup as Semigroup (Last(..)) +import Data.Monoid (All (..)) + import Distribution.Compat.Prelude import Prelude () @@ -266,6 +269,9 @@ instance Monoid BuildInfo where } mappend = (<>) +instance Monoid (BuildInfoWith Mod.HasAnn) where + mempty = emptyBuildInfo' + instance Semigroup BuildInfo where a <> b = BuildInfo @@ -324,9 +330,123 @@ instance Semigroup BuildInfo where combineNub field = nub (combine field) combineMby field = field b `mplus` field a +instance Semigroup (BuildInfoWith Mod.HasAnn) where + a <> b = + BuildInfo + { buildable = + mapAnnA (fmap Semigroup.getLast) getAll $ + mapAnnA (fmap Semigroup.Last) All (buildable a) + <> mapAnnA (fmap Semigroup.Last) All (buildable b) + , 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 + emptyBuildInfo :: BuildInfo emptyBuildInfo = mempty +emptyBuildInfo' :: BuildInfoWith Mod.HasAnn +emptyBuildInfo' = + BuildInfo + { buildable = Ann NoTrivia True + , 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/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs index a5621209bd3..f9de0e075cd 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -70,9 +70,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/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs index 8a3545fdcdf..698a0366b6f 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -170,6 +170,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 @@ -183,10 +199,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/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index 9e1848f00ce..90d1e42f684 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -44,7 +44,7 @@ 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 #-} diff --git a/Cabal-syntax/src/Distribution/Types/Modify.hs b/Cabal-syntax/src/Distribution/Types/Modify.hs index 5d89af03adc..40e41385b83 100644 --- a/Cabal-syntax/src/Distribution/Types/Modify.hs +++ b/Cabal-syntax/src/Distribution/Types/Modify.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs index 39d65654a4e..b89abb733f3 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -74,9 +74,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 From fb979ae79f319e60e5ba9765de1381d2b7b13a31 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 27 Apr 2026 10:27:28 +0200 Subject: [PATCH 093/111] fix test suite compilation --- .../Distribution/PackageDescription/Parsec.hs | 50 +++++++++---------- Cabal-tests/tests/HackageTests.hs | 1 + Cabal-tests/tests/ParserTests.hs | 4 +- Cabal/src/Distribution/Simple/Bench.hs | 2 +- Cabal/src/Distribution/Simple/Hpc.hs | 3 +- .../Distribution/Simple/PackageDescription.hs | 5 +- 6 files changed, 35 insertions(+), 30 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index 5df32e06859..082bacb2758 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -103,8 +103,8 @@ parseGenericPackageDescription , Monoid (ExecutableWith mod) , Monoid (TestSuiteWith mod) , Monoid (BenchmarkWith mod) - , Monoid (TestSuiteStanzaWith mod) - , Monoid (BenchmarkStanzaWith mod) + -- , Monoid (TestSuiteStanzaWith mod) + -- , Monoid (BenchmarkStanzaWith mod) , Parsec (DependencyWith mod) @@ -166,8 +166,8 @@ parseGenericPackageDescriptionMaybe , Monoid (ExecutableWith mod) , Monoid (TestSuiteWith mod) , Monoid (BenchmarkWith mod) - , Monoid (TestSuiteStanzaWith mod) - , Monoid (BenchmarkStanzaWith mod) + -- , Monoid (TestSuiteStanzaWith mod) + -- , Monoid (BenchmarkStanzaWith mod) , Parsec (DependencyWith mod) @@ -221,8 +221,8 @@ parseGenericPackageDescription' , Monoid (ExecutableWith mod) , Monoid (TestSuiteWith mod) , Monoid (BenchmarkWith mod) - , Monoid (TestSuiteStanzaWith mod) - , Monoid (BenchmarkStanzaWith mod) + -- , Monoid (TestSuiteStanzaWith mod) + -- , Monoid (BenchmarkStanzaWith mod) -- Why this bound @@ -479,25 +479,25 @@ goSections specVer = traverse_ process -- 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) - ] - ] + -- 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) diff --git a/Cabal-tests/tests/HackageTests.hs b/Cabal-tests/tests/HackageTests.hs index f68bc962aea..607d7a335b4 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-pattern-binds #-} -- pattern match to assert field count diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 109814b629b..302b715abab 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -127,7 +127,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 @@ -434,7 +434,7 @@ formatGoldenTest fp = cabalGoldenTest "format" correct $ 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) 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/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 From 1b449ff5e8f8912ea7b618c082219c5aff94e6c0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 27 Apr 2026 11:32:14 +0200 Subject: [PATCH 094/111] run parser against hackage --- .../PackageDescription/FieldGrammar.hs | 6 --- .../Distribution/PackageDescription/Parsec.hs | 10 ++++- .../src/Distribution/Types/Benchmark.hs | 19 +++++++++ .../src/Distribution/Types/Executable.hs | 2 +- .../src/Distribution/Types/ForeignLib.hs | 2 +- .../src/Distribution/Types/Library.hs | 34 ++++++++++++++- Cabal-tests/tests/HackageTests.hs | 42 +++++++++++++++++++ 7 files changed, 104 insertions(+), 11 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 12832fa87a3..532f7e7b8f8 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -459,9 +459,6 @@ data TestSuiteStanzaWith (mod :: Mod.HasAnnotation) = TestSuiteStanza , _testStanzaCodeGenerators :: [String] } -instance L.HasBuildInfoWith Mod.HasNoAnn TestSuiteStanza where - buildInfo = testStanzaBuildInfo - testStanzaTestType :: Lens' (TestSuiteStanzaWith mod) (Maybe TestType) testStanzaTestType f s = fmap (\x -> s{_testStanzaTestType = x}) (f (_testStanzaTestType s)) {-# INLINE testStanzaTestType #-} @@ -654,9 +651,6 @@ data BenchmarkStanzaWith (mod :: Mod.HasAnnotation) = BenchmarkStanza , _benchmarkStanzaBuildInfo :: BuildInfoWith mod } -instance L.HasBuildInfoWith Mod.HasNoAnn BenchmarkStanza where - buildInfo = benchmarkStanzaBuildInfo - benchmarkStanzaBenchmarkType :: Lens' (BenchmarkStanzaWith mod) (Maybe BenchmarkType) benchmarkStanzaBenchmarkType f s = fmap (\x -> s{_benchmarkStanzaBenchmarkType = x}) (f (_benchmarkStanzaBenchmarkType s)) {-# INLINE benchmarkStanzaBenchmarkType #-} diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index 082bacb2758..ff2903b210f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -774,10 +774,16 @@ instance ) => 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) => FromBuildInfoWith mod (TestSuiteStanzaWith mod) where +instance L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) where + buildInfo f t = (\x -> t{_testStanzaBuildInfo = x}) <$> f (_testStanzaBuildInfo t) + +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 L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) => FromBuildInfoWith mod (BenchmarkStanzaWith mod) where +instance FromBuildInfoWith mod (BenchmarkStanzaWith mod) where fromBuildInfo' _ bi = BenchmarkStanza Nothing Nothing Nothing bi parseCondTreeWithCommonStanzas diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/Cabal-syntax/src/Distribution/Types/Benchmark.hs index a53e0ca037f..dacbc262825 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -60,6 +60,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 @@ -70,6 +79,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/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs index f9de0e075cd..8b6cec01b98 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -42,7 +42,7 @@ deriving instance Eq Executable deriving instance Ord Executable deriving instance Data Executable -instance L.HasBuildInfoWith Mod.HasNoAnn Executable where +instance L.HasBuildInfoWith mod (ExecutableWith mod) where buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l) instance Binary Executable diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs index 698a0366b6f..21dd3ad47c3 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -147,7 +147,7 @@ libVersionNumberShow v = libVersionMajor :: LibVersionInfo -> Int libVersionMajor (LibVersionInfo c _ a) = c - a -instance L.HasBuildInfoWith Mod.HasNoAnn ForeignLib where +instance L.HasBuildInfoWith mod (ForeignLibWith mod) where buildInfo f l = (\x -> l{foreignLibBuildInfo = x}) <$> f (foreignLibBuildInfo l) instance Binary ForeignLib diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs index c26561a2e64..d5a6850721f 100644 --- a/Cabal-syntax/src/Distribution/Types/Library.hs +++ b/Cabal-syntax/src/Distribution/Types/Library.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} @@ -51,7 +53,7 @@ deriving instance Ord Library deriving instance Read Library deriving instance Data Library -instance L.HasBuildInfoWith Mod.HasNoAnn Library where +instance L.HasBuildInfoWith mod (LibraryWith mod) where buildInfo f l = (\x -> l{libBuildInfo = x}) <$> f (libBuildInfo l) instance Binary Library @@ -70,6 +72,18 @@ emptyLibrary = , libBuildInfo = mempty } +emptyLibraryAnn :: LibraryWith Mod.HasAnn +emptyLibraryAnn = + Library + { libName = LMainLibName + , exposedModules = mempty + , reexportedModules = mempty + , signatures = mempty + , libExposed = True + , libVisibility = mempty + , libBuildInfo = mempty + } + -- | This instance is not good. -- -- We need it for 'PackageDescription.Configuration.addBuildableCondition'. @@ -81,6 +95,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-tests/tests/HackageTests.hs b/Cabal-tests/tests/HackageTests.hs index 607d7a335b4..226965b9285 100644 --- a/Cabal-tests/tests/HackageTests.hs +++ b/Cabal-tests/tests/HackageTests.hs @@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} @@ -33,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 @@ -181,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 ------------------------------------------------------------------------------- @@ -362,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 @@ -374,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") <|> @@ -391,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) From 7d101cd041cf692f97ce1212cf744d9a61c41162 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 27 Apr 2026 12:57:11 +0200 Subject: [PATCH 095/111] implement smallCabalFile test --- .../src/Distribution/Types/Benchmark.hs | 2 ++ .../src/Distribution/Types/BuildInfo.hs | 2 ++ .../src/Distribution/Types/Executable.hs | 2 ++ .../src/Distribution/Types/ForeignLib.hs | 2 ++ .../Types/GenericPackageDescription.hs | 2 ++ .../src/Distribution/Types/Library.hs | 2 ++ .../src/Distribution/Types/TestSuite.hs | 2 ++ Cabal-tests/tests/ParserTests.hs | 29 +++++++------------ .../tests/ParserTests/smallCabalFile.cabal | 4 +++ 9 files changed, 29 insertions(+), 18 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Types/Benchmark.hs b/Cabal-syntax/src/Distribution/Types/Benchmark.hs index dacbc262825..daf58c4af58 100644 --- a/Cabal-syntax/src/Distribution/Types/Benchmark.hs +++ b/Cabal-syntax/src/Distribution/Types/Benchmark.hs @@ -44,6 +44,8 @@ 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 diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index 2435768ff47..c65d7af620e 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -179,6 +179,8 @@ 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 diff --git a/Cabal-syntax/src/Distribution/Types/Executable.hs b/Cabal-syntax/src/Distribution/Types/Executable.hs index 8b6cec01b98..cc6149821b4 100644 --- a/Cabal-syntax/src/Distribution/Types/Executable.hs +++ b/Cabal-syntax/src/Distribution/Types/Executable.hs @@ -42,6 +42,8 @@ deriving instance Eq Executable deriving instance Ord Executable deriving instance Data Executable +deriving instance Show (ExecutableWith Mod.HasAnn) + instance L.HasBuildInfoWith mod (ExecutableWith mod) where buildInfo f l = (\x -> l{buildInfo = x}) <$> f (buildInfo l) diff --git a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs index 21dd3ad47c3..be471e61992 100644 --- a/Cabal-syntax/src/Distribution/Types/ForeignLib.hs +++ b/Cabal-syntax/src/Distribution/Types/ForeignLib.hs @@ -77,6 +77,8 @@ 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) instance Ord LibVersionInfo where diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 3d8fe95912e..60875678745 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -81,6 +81,8 @@ 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 diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs index d5a6850721f..aae86c1ef45 100644 --- a/Cabal-syntax/src/Distribution/Types/Library.hs +++ b/Cabal-syntax/src/Distribution/Types/Library.hs @@ -53,6 +53,8 @@ deriving instance Ord Library deriving instance Read Library deriving instance Data Library +deriving instance Show (LibraryWith Mod.HasAnn) + instance L.HasBuildInfoWith mod (LibraryWith mod) where buildInfo f l = (\x -> l{libBuildInfo = x}) <$> f (libBuildInfo l) diff --git a/Cabal-syntax/src/Distribution/Types/TestSuite.hs b/Cabal-syntax/src/Distribution/Types/TestSuite.hs index b89abb733f3..bea9322b2bd 100644 --- a/Cabal-syntax/src/Distribution/Types/TestSuite.hs +++ b/Cabal-syntax/src/Distribution/Types/TestSuite.hs @@ -45,6 +45,8 @@ deriving instance Eq TestSuite deriving instance Ord TestSuite deriving instance Data TestSuite +deriving instance Show (TestSuiteWith Mod.HasAnn) + instance forall (mod :: Mod.HasAnnotation). L.HasBuildInfoWith mod (TestSuiteWith mod) where buildInfo f l = (\x -> l{testBuildInfo = x}) <$> f (testBuildInfo l) diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 302b715abab..7309c9b3967 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -284,26 +284,19 @@ miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do smallCabalFileTest :: TestTree smallCabalFileTest = testCase "smallCabalFile" $ 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 frontFields miniBuildInfoFieldGrammar - - (_warns, pr') = runParseResult pr - - pr'' <- case pr' of - Left (_, errs) -> fail "ERROR in running field grammar" - Right ok -> pure $ ok + contents <- BS.readFile input + let res = withSource (PCabalFile (fp, contents)) $ (parseGenericPackageDescription @Mod.HasAnn) contents + let (_, x) = runParseResult res + case x of + Right gpd -> pPrint gpd + Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPErrorWithSource . fmap renderCabalFileSource) (NE.toList errs) - let prettyFields :: [PrettyFieldWith Mod.HasAnn] = prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar pr'' - putStrLn - $ exactShowFields prettyFields + -- let prettyFields :: [PrettyFieldWith Mod.HasAnn] = prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar + -- putStrLn + -- $ exactShowFields prettyFields where - input = "tests" "ParserTests" "smallCabalFile.cabal" + input = "tests" "ParserTests" fp + fp = "smallCabalFile.cabal" miniBuildInfoTest :: TestTree miniBuildInfoTest = testCase "miniBuildInfo NoAnn" $ do diff --git a/Cabal-tests/tests/ParserTests/smallCabalFile.cabal b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal index e69de29bb2d..397a55614b1 100644 --- a/Cabal-tests/tests/ParserTests/smallCabalFile.cabal +++ b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal @@ -0,0 +1,4 @@ +cabal-version: 3.0 + +name: samll-cabal-file +version: 0.0.0 From 4b885c2086a2388cf1dc58e0d104dc341379ff24 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 27 Apr 2026 13:35:15 +0200 Subject: [PATCH 096/111] implement part of ppGenericPackageDescriptionAnn --- .../PackageDescription/FieldGrammar.hs | 11 +- .../Distribution/PackageDescription/Parsec.hs | 2 +- .../PackageDescription/PrettyPrint.hs | 123 +++++++++++++++++- 3 files changed, 129 insertions(+), 7 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 532f7e7b8f8..50d2f7e8254 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -113,9 +113,10 @@ import qualified Distribution.Types.Lens as L ------------------------------------------------------------------------------- packageDescriptionFieldGrammar - :: ( FieldGrammar c g - , Applicative (g Mod.HasNoAnn PackageDescription) - , Applicative (g Mod.HasNoAnn PackageIdentifier) + :: forall mod c g + . ( FieldGrammarWith mod c g + , Applicative (g mod PackageDescription) + , Applicative (g mod PackageIdentifier) , c (Identity BuildType) , c (Identity PackageName) , c (Identity Version) @@ -125,7 +126,7 @@ packageDescriptionFieldGrammar , c CompatLicenseFile , c CompatDataDir ) - => g Mod.HasNoAnn PackageDescription PackageDescription + => g mod PackageDescription PackageDescription packageDescriptionFieldGrammar = PackageDescription <$> optionalFieldDefAla "cabal-version" SpecVersion L.specVersion CabalSpecV1_0 @@ -1392,7 +1393,7 @@ _syntaxFieldNames = nub $ sort $ mconcat - [ fieldGrammarKnownFieldList packageDescriptionFieldGrammar + [ fieldGrammarKnownFieldList (packageDescriptionFieldGrammar @Mod.HasNoAnn) , fieldGrammarKnownFieldList $ (libraryFieldGrammar @Mod.HasNoAnn) LMainLibName , fieldGrammarKnownFieldList $ (executableFieldGrammar @Mod.HasNoAnn) "exe" , fieldGrammarKnownFieldList $ (foreignLibFieldGrammar @Mod.HasNoAnn) "flib" diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index ff2903b210f..494cd9929fe 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -271,7 +271,7 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do setCabalSpecVersion (Just specVer') -- Package description - pd <- parseFieldGrammar specVer fields packageDescriptionFieldGrammar + pd <- parseFieldGrammar specVer fields (packageDescriptionFieldGrammar @mod) -- Check that scanned and parsed versions match. unless (specVer == specVersion pd) $ diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index cb350c06fb7..3bf02d61a37 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -36,8 +36,9 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Compat.Lens -import Distribution.FieldGrammar (PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.FieldGrammar (PrettyFieldGrammarWith', PrettyFieldGrammar', prettyFieldGrammar) import Distribution.Fields.Pretty +import Distribution.Parsec.Position import Distribution.PackageDescription import Distribution.PackageDescription.Configuration (transformAllBuildInfos) import Distribution.PackageDescription.FieldGrammar @@ -93,14 +94,42 @@ ppGenericPackageDescription v gpd0 = where gpd = preProcessInternalDeps (specVersion (packageDescription gpd0)) gpd0 +-- | 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 ++ ppSourceRepos v (sourceRepos pd) +ppPackageDescriptionAnn :: CabalSpecVersion -> PackageDescription -> [PrettyFieldWith Mod.HasAnn] +ppPackageDescriptionAnn v pd = + prettyFieldGrammar v packageDescriptionFieldGrammar pd + ++ ppSourceReposAnn v (sourceRepos pd) + ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField] ppSourceRepos = map . ppSourceRepo +ppSourceReposAnn :: CabalSpecVersion -> [SourceRepo] -> [PrettyFieldWith Mod.HasAnn] +ppSourceReposAnn = map . ppSourceRepoAnn + ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ppSourceRepo v repo = PrettySection "source-repository" [pretty kind] $ @@ -108,6 +137,14 @@ ppSourceRepo v repo = where kind = repoKind repo +ppSourceRepoAnn :: CabalSpecVersion -> SourceRepo -> PrettyFieldWith Mod.HasAnn +ppSourceRepoAnn v repo = + -- TODO(leana8959): push out position + PrettySection (zeroPos, "source-repository") [pretty kind] $ + prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasAnn kind) repo + where + kind = repoKind repo + ppSetupBInfo :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyField] ppSetupBInfo _ Nothing = mempty ppSetupBInfo v (Just sbi) @@ -117,14 +154,33 @@ ppSetupBInfo v (Just sbi) PrettySection "custom-setup" [] $ prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasNoAnn False) sbi +ppSetupBInfoAnn :: CabalSpecVersion -> Maybe SetupBuildInfo -> [PrettyFieldWith Mod.HasAnn] +ppSetupBInfoAnn _ Nothing = mempty +ppSetupBInfoAnn v (Just sbi) + | defaultSetupDepends sbi = mempty + | otherwise = + -- TODO(leana8959): push out position + pure $ + PrettySection (zeroPos, "custom-setup") [] $ + prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasAnn False) sbi + ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField] ppGenPackageFlags = map . ppFlag +ppGenPackageFlagsAnn :: CabalSpecVersion -> [PackageFlag] -> [PrettyFieldWith Mod.HasAnn] +ppGenPackageFlagsAnn = map . ppFlagAnn + ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection "flag" [ppFlagName name] $ prettyFieldGrammar v (flagFieldGrammar @Mod.HasNoAnn name) flag +ppFlagAnn :: CabalSpecVersion -> PackageFlag -> PrettyFieldWith Mod.HasAnn +ppFlagAnn v flag@(MkPackageFlag name _ _ _) = + -- TODO(leana8959): push out position + PrettySection (zeroPos, "flag") [ppFlagName name] $ + prettyFieldGrammar v (flagFieldGrammar @Mod.HasAnn name) flag + ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar s -> [PrettyField] ppCondTree2 v grammar = go where @@ -144,6 +200,25 @@ ppCondTree2 v grammar = go , PrettySection "else" [] (go elseTree) ] +ppCondTree2Ann :: CabalSpecVersion -> PrettyFieldGrammarWith' Mod.HasAnn s -> CondTree ConfVar s -> [PrettyFieldWith Mod.HasAnn] +ppCondTree2Ann v grammar = go + where + -- TODO: recognise elif opportunities + go (CondNode it ifs) = + prettyFieldGrammar v grammar it + ++ concatMap ppIf ifs + + ppIf (CondBranch c thenTree Nothing) + -- | isEmpty thenDoc = mempty + | otherwise = [ppIfConditionAnn c thenDoc] + where + thenDoc = go thenTree + ppIf (CondBranch c thenTree (Just elseTree)) = + -- See #6193 + [ ppIfConditionAnn c (go thenTree) + , PrettySection (zeroPos, "else") [] (go elseTree) + ] + ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar Library) -> [PrettyField] ppCondLibrary _ Nothing = mempty ppCondLibrary v (Just condTree) = @@ -151,6 +226,13 @@ ppCondLibrary v (Just condTree) = PrettySection "library" [] $ ppCondTree2 v (libraryFieldGrammar LMainLibName) condTree +ppCondLibraryAnn :: CabalSpecVersion -> Maybe (CondTree ConfVar (LibraryWith Mod.HasAnn)) -> [PrettyFieldWith Mod.HasAnn] +ppCondLibraryAnn _ Nothing = mempty +ppCondLibraryAnn v (Just condTree) = + pure $ + PrettySection (zeroPos, "library") [] $ + ppCondTree2Ann v (libraryFieldGrammar LMainLibName) condTree + ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Library)] -> [PrettyField] ppCondSubLibraries v libs = [ PrettySection "library" [pretty n] $ @@ -158,6 +240,13 @@ ppCondSubLibraries v libs = | (n, condTree) <- libs ] +ppCondSubLibrariesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (LibraryWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +ppCondSubLibrariesAnn v libs = + [ PrettySection (zeroPos, "library") [pretty n] $ + ppCondTree2Ann v (libraryFieldGrammar $ LSubLibName n) condTree + | (n, condTree) <- libs + ] + ppCondForeignLibs :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar ForeignLib)] -> [PrettyField] ppCondForeignLibs v flibs = [ PrettySection "foreign-library" [pretty n] $ @@ -165,6 +254,13 @@ ppCondForeignLibs v flibs = | (n, condTree) <- flibs ] +ppCondForeignLibsAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (ForeignLibWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +ppCondForeignLibsAnn v flibs = + [ PrettySection (zeroPos, "foreign-library") [pretty n] $ + ppCondTree2Ann v (foreignLibFieldGrammar n) condTree + | (n, condTree) <- flibs + ] + ppCondExecutables :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Executable)] -> [PrettyField] ppCondExecutables v exes = [ PrettySection "executable" [pretty n] $ @@ -172,6 +268,13 @@ ppCondExecutables v exes = | (n, condTree) <- exes ] +ppCondExecutablesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (ExecutableWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] +ppCondExecutablesAnn v exes = + [ PrettySection (zeroPos, "executable") [pretty n] $ + ppCondTree2Ann v (executableFieldGrammar n) condTree + | (n, condTree) <- exes + ] + ppCondTestSuites :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar TestSuite)] -> [PrettyField] ppCondTestSuites v suites = [ PrettySection "test-suite" [pretty n] $ @@ -179,6 +282,14 @@ ppCondTestSuites v suites = | (n, condTree) <- suites ] +-- 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] $ @@ -186,6 +297,13 @@ ppCondBenchmarks v suites = | (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) @@ -218,6 +336,9 @@ ppFlagName = text . unFlagName 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 () writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) From 765a441b3904c512212e006fa7968fe4833abe3a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 30 Apr 2026 14:13:57 +0200 Subject: [PATCH 097/111] did thing --- .../src/Distribution/FieldGrammar/Parsec.hs | 175 ++++++++++++++++++ .../src/Distribution/FieldGrammar/Pretty.hs | 80 ++++++++ .../PackageDescription/FieldGrammar.hs | 1 + .../PackageDescription/PrettyPrint.hs | 1 + Cabal-tests/tests/ParserTests.hs | 9 +- .../tests/ParserTests/smallCabalFile.cabal | 9 +- 6 files changed, 269 insertions(+), 6 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 603ba1073e6..4e4776d7c20 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -382,6 +382,181 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where 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 -> 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 values + | v >= vs = parser v 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 + + availableSinceWarn vs (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v values + | v >= vs = parser v 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 values + + deprecatedSince vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v 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 values + | otherwise = parser v values + removedIn vs msg (ParsecFG names prefixes parser) = ParsecFG names prefixes parser' + where + parser' v 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 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 + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) + hiddenField = id + + -- New methods + booleanFieldDef' :: forall s . FieldName diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index f2d6b481fb7..11c609ec06f 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} @@ -120,6 +121,78 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where hiddenField _ = PrettyFG (\_ -> mempty) instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where + blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) + + uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> + ppFieldFakePos fn (pretty (pack' _pack (aview l s))) + + booleanFieldDef fn l def = PrettyFG pp + where + pp _v 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 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 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 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 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 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 + [ PrettyField (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 s -> let bs = fmap (prettyVersioned v . pack' _pack) <$> aview l s in ppFieldPos fn bs @@ -140,3 +213,10 @@ ppFieldPos name possFieldDocs = [ PrettyField (fieldNamePos poss, name) (fieldLinePos poss, fieldDoc) | (poss, fieldDoc) <- possFieldDocs ] + +-- TODO(leana8959): push out position +-- | Doesn't push out real position, tbd +ppFieldFakePos :: FieldName -> Doc -> [PrettyFieldWith Mod.HasAnn] +ppFieldFakePos name fieldDoc = + [ PrettyField (zeroPos, name) (zeroPos, fieldDoc) + ] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 50d2f7e8254..98fd8a60633 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -558,6 +558,7 @@ testSuiteFieldGrammar = <*> 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 diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 3bf02d61a37..8ae7daca456 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -21,6 +21,7 @@ module Distribution.PackageDescription.PrettyPrint writeGenericPackageDescription , showGenericPackageDescription , ppGenericPackageDescription + , ppGenericPackageDescriptionAnn -- * Package descriptions , writePackageDescription diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 7309c9b3967..db62fdc1971 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -33,6 +33,7 @@ import Distribution.PackageDescription , condTestSuites , condBenchmarks ) +import Distribution.PackageDescription.PrettyPrint (ppGenericPackageDescriptionAnn) import Distribution.PackageDescription.FieldGrammar(buildInfoFieldGrammar, miniBuildInfoFieldGrammar, MiniBuildInfo (..)) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, sectionizeFields, takeFields) import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) @@ -287,13 +288,11 @@ smallCabalFileTest = testCase "smallCabalFile" $ do contents <- BS.readFile input let res = withSource (PCabalFile (fp, contents)) $ (parseGenericPackageDescription @Mod.HasAnn) contents let (_, x) = runParseResult res - case x of - Right gpd -> pPrint gpd + gpd <- case x of + Right ok -> pPrint ok >> pure ok Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPErrorWithSource . fmap renderCabalFileSource) (NE.toList errs) - -- let prettyFields :: [PrettyFieldWith Mod.HasAnn] = prettyFieldGrammar CabalSpecV3_0 miniBuildInfoFieldGrammar - -- putStrLn - -- $ exactShowFields prettyFields + pPrint (ppGenericPackageDescriptionAnn CabalSpecV3_0 gpd) where input = "tests" "ParserTests" fp fp = "smallCabalFile.cabal" diff --git a/Cabal-tests/tests/ParserTests/smallCabalFile.cabal b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal index 397a55614b1..d7d53270e9f 100644 --- a/Cabal-tests/tests/ParserTests/smallCabalFile.cabal +++ b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal @@ -1,4 +1,11 @@ cabal-version: 3.0 -name: samll-cabal-file +name: small-cabal-file version: 0.0.0 + +library foo + main-is: Main.hs + build-depends: + text + , + base > 4 From a4c1fffd950c185706b8745c5fe249188fd28e38 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 30 Apr 2026 14:55:40 +0200 Subject: [PATCH 098/111] repair boolean field! --- Cabal-syntax/src/Distribution/FieldGrammar/Class.hs | 4 ++-- Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs | 12 ++++++------ Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs | 3 +-- .../Distribution/PackageDescription/FieldGrammar.hs | 2 +- .../src/Distribution/PackageDescription/Parsec.hs | 10 +++++++--- Cabal-syntax/src/Distribution/Types/BuildInfo.hs | 11 ++++------- .../src/Distribution/Types/BuildInfo/Lens.hs | 2 +- Cabal-syntax/src/Distribution/Types/Library.hs | 9 ++++++--- Cabal-syntax/src/Distribution/Types/Library/Lens.hs | 5 ++++- 9 files changed, 32 insertions(+), 26 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 860a9296be9..079a4289c47 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -85,11 +85,11 @@ class booleanFieldDef' :: FieldName -- ^ field name - -> ALens' s (AnnotateWith Positions m Bool) + -> ALens' s (PreserveGrouping m (AnnotateWith Positions m Bool)) -- ^ lens into the field -> Bool -- ^ default - -> g m s (AnnotateWith Positions m Bool) + -> g m s (PreserveGrouping m (AnnotateWith Positions m Bool)) -- | Optional field. optionalFieldAla diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 4e4776d7c20..0d97c65ec84 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -561,14 +561,14 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where :: forall s . FieldName -- \^ field name - -> ALens' s (Ann Positions Bool) + -> ALens' s [Ann Positions Bool] -- \^ lens into the field -> Bool -- \^ default - -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions Bool) + -> ParsecFieldGrammar Mod.HasAnn s [Ann Positions Bool] booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Ann Positions Bool) + parser :: CabalSpecVersion -> Fields Position -> ParseResult src [Ann Positions Bool] parser v fields = case Map.lookup fn fields of Nothing -> pure def' Just [] -> pure def' @@ -577,12 +577,12 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where warnMultipleSingularFields fn xs NE.last <$> traverse (parseOne v) (y :| ys) where - def' = Ann IsInserted def + def' = [Ann IsInserted def] - parseOne :: CabalSpecVersion -> NamelessField Position -> ParseResult src (Ann Positions Bool) + 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 pos fieldLinePos) x + pure . (:[]) $ Ann (HasTrivia $ Positions pos fieldLinePos) x -- TODO(leana8959): implement all methods diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 11c609ec06f..c3c7228eee7 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -198,8 +198,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where in ppFieldPos fn bs booleanFieldDef' fn l def = PrettyFG $ \_v s -> - let Ann t b = aview l s - in case t of + aview l s >>= \(Ann t b) -> case t of HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] IsInserted -> mempty diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 98fd8a60633..1b6c61c40a8 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -256,7 +256,7 @@ libraryFieldGrammar n = <*> 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 @mod) where diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index 494cd9929fe..2ae5ba0f1a6 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -340,6 +340,7 @@ goSections , 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) @@ -360,6 +361,7 @@ goSections specVer = traverse_ process -- ) -- => ( Semigroup (BuildInfoWith mod) + , Monoid (LibraryWith mod) ) => Field Position -> SectionParser mod src () process (Field (Name pos name) _) = @@ -381,6 +383,7 @@ goSections specVer = traverse_ process ( L.HasBuildInfoWith mod a + , Monoid (LibraryWith mod) , Semigroup (BuildInfoWith mod) ) => @@ -401,7 +404,8 @@ goSections specVer = traverse_ process -- , L.HasBuildInfoWith mod (BuildInfoWith mod) -- ) -- => - ( Semigroup (BuildInfoWith mod) + ( Semigroup (BuildInfoWith mod) + , Monoid (LibraryWith mod) ) => Name Position -> [SectionArg Position] @@ -750,9 +754,9 @@ type CondTreeBuildInfoAnn = CondTreeBuildInfoWith Mod.HasAnn class L.HasBuildInfoWith mod a => FromBuildInfoWith mod a where fromBuildInfo' :: UnqualComponentName -> BuildInfoWith mod -> a -libraryFromBuildInfo :: LibraryName -> BuildInfoWith mod -> LibraryWith mod +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 diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs index c65d7af620e..195dfa21eca 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo.hs @@ -57,7 +57,7 @@ type BuildInfoAnn = BuildInfoWith Mod.HasAnn -- Consider refactoring into executable and library versions. data BuildInfoWith (m :: Mod.HasAnnotation) = BuildInfo - { buildable :: AnnotateWith Positions m Bool + { buildable :: PreserveGrouping m (AnnotateWith Positions m Bool) -- ^ component is buildable here , buildTools :: PreserveGrouping m (AttachPositions m [AttachPosition m (Annotate m LegacyExeDependency)]) -- ^ Tools needed to build this bit. @@ -190,7 +190,7 @@ unannotateBuildInfo bi = let unannotateMonoidalField = map (unAnn . snd) . join . map snd in bi - { buildable = unAnn $ buildable bi + { buildable = foldl (&&) False $ map unAnn $ buildable bi , buildTools = unannotateMonoidalField $ buildTools bi , buildToolDepends = unannotateMonoidalField $ buildToolDepends bi , cppOptions = unannotateMonoidalField $ cppOptions bi @@ -335,10 +335,7 @@ instance Semigroup BuildInfo where instance Semigroup (BuildInfoWith Mod.HasAnn) where a <> b = BuildInfo - { buildable = - mapAnnA (fmap Semigroup.getLast) getAll $ - mapAnnA (fmap Semigroup.Last) All (buildable a) - <> mapAnnA (fmap Semigroup.Last) All (buildable b) + { buildable = combine buildable , buildTools = combine buildTools , buildToolDepends = combine buildToolDepends , cppOptions = combine cppOptions @@ -399,7 +396,7 @@ emptyBuildInfo = mempty emptyBuildInfo' :: BuildInfoWith Mod.HasAnn emptyBuildInfo' = BuildInfo - { buildable = Ann NoTrivia True + { buildable = [] , buildTools = [] , buildToolDepends = [] , cppOptions = [] diff --git a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs index a3445620a37..489c4cfa003 100644 --- a/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs @@ -47,7 +47,7 @@ type HasBuildInfoAnn = HasBuildInfoWith Mod.HasAnn class HasBuildInfoWith mod a | a -> mod where buildInfo :: Lens' a (BuildInfoWith mod) - buildable :: HasBuildInfoWith mod (BuildInfoWith mod) => Lens' a (AnnotateWith Positions mod Bool) + 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)])) diff --git a/Cabal-syntax/src/Distribution/Types/Library.hs b/Cabal-syntax/src/Distribution/Types/Library.hs index aae86c1ef45..002395be4a1 100644 --- a/Cabal-syntax/src/Distribution/Types/Library.hs +++ b/Cabal-syntax/src/Distribution/Types/Library.hs @@ -28,7 +28,9 @@ import Distribution.Types.ModuleReexport import qualified Distribution.Types.BuildInfo.Lens as L +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 @@ -39,7 +41,8 @@ data LibraryWith (m :: Mod.HasAnnotation) = Library , 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. @@ -81,7 +84,7 @@ emptyLibraryAnn = , exposedModules = mempty , reexportedModules = mempty , signatures = mempty - , libExposed = True + , libExposed = [] , libVisibility = mempty , libBuildInfo = mempty } @@ -108,7 +111,7 @@ instance Semigroup (LibraryWith Mod.HasAnn) where , exposedModules = combine exposedModules , reexportedModules = combine reexportedModules , signatures = combine signatures - , libExposed = libExposed a && libExposed b -- so False propagates + , libExposed = libExposed a <> libExposed b -- so False propagates , libVisibility = combine libVisibility , libBuildInfo = combine libBuildInfo } diff --git a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs index effd5b72a35..dd74427c90e 100644 --- a/Cabal-syntax/src/Distribution/Types/Library/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/Library/Lens.hs @@ -7,6 +7,9 @@ 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 (BuildInfoWith) import Distribution.Types.Library (Library, LibraryWith) @@ -32,7 +35,7 @@ signatures :: Lens' (LibraryWith mod) [ModuleName] signatures f s = fmap (\x -> s{T.signatures = x}) (f (T.signatures s)) {-# INLINE signatures #-} -libExposed :: Lens' (LibraryWith mod) 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 #-} From bf05e49653e250088a41679df6918b11abd5b105 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 30 Apr 2026 15:45:51 +0200 Subject: [PATCH 099/111] Implement position preserving optionalfieldAla' --- .../src/Distribution/FieldGrammar/Class.hs | 13 +++++++ .../src/Distribution/FieldGrammar/Parsec.hs | 36 ++++++++++++++++++- .../src/Distribution/Parsec/Position.hs | 1 + .../tests/ParserTests/smallCabalFile.cabal | 3 ++ 4 files changed, 52 insertions(+), 1 deletion(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index 079a4289c47..cd66308e20f 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -115,6 +115,19 @@ class -- ^ default value -> 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. -- diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 0d97c65ec84..6fe99740afc 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE KindSignatures #-} @@ -97,7 +98,7 @@ import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) import Distribution.Trivia -import Distribution.Types.Modify (AttachPositions) +import Distribution.Types.Modify (AttachPositions, AnnotateWith) import qualified Distribution.Types.Modify as Mod ------------------------------------------------------------------------------- @@ -610,6 +611,39 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition parsec) v fls pure (Positions 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 -> Fields Position -> ParseResult src (Ann Positions a) + 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) + + def' :: Ann Positions a + def' = Ann IsInserted def + + 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 pos fieldLinePos) (unpack' _pack x)) + ------------------------------------------------------------------------------- -- Parsec ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/Parsec/Position.hs b/Cabal-syntax/src/Distribution/Parsec/Position.hs index 8a8a3d54bd4..dad05cb0bdb 100644 --- a/Cabal-syntax/src/Distribution/Parsec/Position.hs +++ b/Cabal-syntax/src/Distribution/Parsec/Position.hs @@ -35,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-tests/tests/ParserTests/smallCabalFile.cabal b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal index d7d53270e9f..3432f8935f5 100644 --- a/Cabal-tests/tests/ParserTests/smallCabalFile.cabal +++ b/Cabal-tests/tests/ParserTests/smallCabalFile.cabal @@ -5,6 +5,9 @@ version: 0.0.0 library foo main-is: Main.hs + + buildable: True + build-depends: text , From 792ec05ef3ba3d033f185da4d7be1513eda6e459 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 30 Apr 2026 15:53:22 +0200 Subject: [PATCH 100/111] implement position preserving optionalfieldala' (printer) --- Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index c3c7228eee7..a411bf51a3f 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -202,6 +202,16 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where HasTrivia pos -> ppFieldPos fn [(pos, PP.text (show b))] IsInserted -> mempty + optionalFieldDefAla' fn _pack l def = PrettyFG pp + where + pp v 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 + ppField :: FieldName -> Doc -> [PrettyField] ppField name fielddoc | PP.isEmpty fielddoc = [] From 9d59e8fbef315e255c65978cb42db2c974b0634c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Thu, 30 Apr 2026 16:18:26 +0200 Subject: [PATCH 101/111] preserve cabal-version position --- .../PackageDescription/FieldGrammar.hs | 5 +- .../Distribution/PackageDescription/Parsec.hs | 25 ++++-- .../PackageDescription/PrettyPrint.hs | 2 +- .../Types/GenericPackageDescription.hs | 18 +++- .../Types/GenericPackageDescription/Lens.hs | 4 +- .../Distribution/Types/PackageDescription.hs | 66 ++++++++++++++- .../Types/PackageDescription/Lens.hs | 82 ++++++++++--------- Cabal/src/Distribution/Backpack/Configure.hs | 2 +- 8 files changed, 144 insertions(+), 60 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 1b6c61c40a8..f9cace6f483 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -115,6 +115,7 @@ import qualified Distribution.Types.Lens as L packageDescriptionFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g + , Applicative (g mod (PackageDescriptionWith mod)) , Applicative (g mod PackageDescription) , Applicative (g mod PackageIdentifier) , c (Identity BuildType) @@ -126,10 +127,10 @@ packageDescriptionFieldGrammar , c CompatLicenseFile , c CompatDataDir ) - => g mod 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 diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index 2ae5ba0f1a6..d507e7e7563 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -97,6 +97,8 @@ parseGenericPackageDescription , L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) , L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) + , EmptyGPD mod + , Monoid (BuildInfoWith mod) , Monoid (LibraryWith mod) , Monoid (ForeignLibWith mod) @@ -160,6 +162,9 @@ parseGenericPackageDescriptionMaybe , L.HasBuildInfoWith mod (TestSuiteStanzaWith mod) , L.HasBuildInfoWith mod (BenchmarkStanzaWith mod) + + , EmptyGPD mod + , Monoid (BuildInfoWith mod) , Monoid (LibraryWith mod) , Monoid (ForeignLibWith mod) @@ -208,6 +213,8 @@ parseGenericPackageDescription' :: forall mod src . ( Semigroup (BuildInfoWith mod) + , EmptyGPD mod + , L.HasBuildInfoWith mod (BuildInfoWith mod) , L.HasBuildInfoWith mod (LibraryWith mod) , L.HasBuildInfoWith mod (ForeignLibWith mod) @@ -273,20 +280,20 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do -- Package description pd <- parseFieldGrammar specVer 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 :: GenericPackageDescriptionWith mod gpd = - emptyGenericPackageDescription + (emptyGPD @mod) & L.packageDescription .~ pd gpd1 <- view stateGpd <$> execStateT (goSections @mod specVer sectionFields) (SectionS gpd Map.empty) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 8ae7daca456..003b2a581b9 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -120,7 +120,7 @@ ppPackageDescription v pd = prettyFieldGrammar v packageDescriptionFieldGrammar pd ++ ppSourceRepos v (sourceRepos pd) -ppPackageDescriptionAnn :: CabalSpecVersion -> PackageDescription -> [PrettyFieldWith Mod.HasAnn] +ppPackageDescriptionAnn :: CabalSpecVersion -> PackageDescriptionWith Mod.HasAnn -> [PrettyFieldWith Mod.HasAnn] ppPackageDescriptionAnn v pd = prettyFieldGrammar v packageDescriptionFieldGrammar pd ++ ppSourceReposAnn v (sourceRepos pd) diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 60875678745..30488d3f8df 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -19,6 +19,7 @@ module Distribution.Types.GenericPackageDescription , GenericPackageDescriptionAnn , GenericPackageDescriptionWith (..) , emptyGenericPackageDescription + , EmptyGPD (..) ) where import Distribution.Compat.Prelude @@ -52,7 +53,7 @@ type GenericPackageDescription = GenericPackageDescriptionWith Mod.HasNoAnn type GenericPackageDescriptionAnn = GenericPackageDescriptionWith Mod.HasAnn data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDescription - { packageDescription :: PackageDescription + { packageDescription :: PackageDescriptionWith m , gpdScannedVersion :: Maybe Version -- ^ This is a version as specified in source. -- We populate this field in index reading for dummy GPDs, @@ -91,9 +92,22 @@ deriving instance Binary (GenericPackageDescriptionWith Mod.HasNoAnn) instance Structured GenericPackageDescription instance NFData GenericPackageDescription where rnf = genericRnf -emptyGenericPackageDescription :: GenericPackageDescriptionWith mod +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 diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs index 90d1e42f684..10012eefc79 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs @@ -27,7 +27,7 @@ import Distribution.Types.Flag (FlagName, PackageFlag (MkPackageFlag)) import Distribution.Types.ForeignLib (ForeignLib, ForeignLibWith) import Distribution.Types.GenericPackageDescription (GenericPackageDescription, GenericPackageDescriptionWith (..)) import Distribution.Types.Library (Library, LibraryWith) -import Distribution.Types.PackageDescription (PackageDescription) +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' (GenericPackageDescriptionWith mod) PackageDescription +packageDescription :: Lens' (GenericPackageDescriptionWith mod) (PackageDescriptionWith mod) packageDescription f s = fmap (\x -> s{T.packageDescription = x}) (f (T.packageDescription s)) {-# INLINE packageDescription #-} diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs index fcf5032aa44..d7cb56321b5 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -1,4 +1,7 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -29,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 @@ -94,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 @@ -104,10 +115,10 @@ 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 , licenseRaw :: Either SPDX.License License @@ -153,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 @@ -241,6 +260,45 @@ emptyPackageDescription = , extraFiles = [] } +emptyPackageDescriptionAnn :: PackageDescriptionWith Mod.HasAnn +emptyPackageDescriptionAnn = + PackageDescription + { package = + PackageIdentifier + (mkPackageName "") + 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 diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs index a9a669c5e73..32737553c47 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs @@ -25,7 +25,7 @@ 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.PackageDescription (PackageDescription, PackageDescriptionWith) import Distribution.Types.PackageId (PackageIdentifier) import Distribution.Types.SetupBuildInfo (SetupBuildInfo) import Distribution.Types.SourceRepo (SourceRepo) @@ -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) PackageIdentifier 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/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 From ea2614d1b56f835441df8d434eebc95a66e183a8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 13:37:35 +0200 Subject: [PATCH 102/111] make uniqueField polymorphic implement parsec implement pretty --- .../src/Distribution/FieldGrammar/Class.hs | 28 +++++++++++++++ .../src/Distribution/FieldGrammar/Parsec.hs | 35 ++++++++++++++++++- .../src/Distribution/FieldGrammar/Pretty.hs | 27 ++++++++++++++ 3 files changed, 89 insertions(+), 1 deletion(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs index cd66308e20f..ed9689c826b 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Class.hs @@ -14,6 +14,7 @@ module Distribution.FieldGrammar.Class ( FieldGrammar , FieldGrammarWith (..) , uniqueField + , uniqueField' , optionalField , optionalFieldDef , monoidalField @@ -71,6 +72,20 @@ class -- ^ lens into the field -> 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 :: FieldName @@ -251,6 +266,19 @@ uniqueField -> 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 :: (FieldGrammarWith m c g, c (Identity a)) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 6fe99740afc..5bc22f27490 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} @@ -98,7 +99,9 @@ import Distribution.Parsec.FieldLineStream import Distribution.Parsec.Position (positionCol, positionRow) import Distribution.Trivia -import Distribution.Types.Modify (AttachPositions, AnnotateWith) +import Data.Kind + +import Distribution.Types.Modify (AttachPositions, AnnotateWith, PreserveGrouping) import qualified Distribution.Types.Modify as Mod ------------------------------------------------------------------------------- @@ -193,6 +196,8 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -644,6 +649,34 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where (fieldLinePos, x) <- runFieldParser pos (liftA2 (,) getPosition (parsec @b)) v fls pure (Ann (HasTrivia $ Positions pos fieldLinePos) (unpack' _pack x)) + 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 -> Fields Position -> ParseResult src (Ann Positions a) + 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 :: 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 pos fieldLinePos) (unpack' _pack x)) + ------------------------------------------------------------------------------- -- Parsec ------------------------------------------------------------------------------- diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index a411bf51a3f..3b29ecfbc4b 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -26,6 +26,8 @@ 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 @@ -51,6 +53,8 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where 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 @@ -204,6 +208,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where optionalFieldDefAla' fn _pack l def = PrettyFG pp where + -- We absorb fields that have no position for the prototype pp v s = let Ann t u :: Ann Positions Doc = prettyVersioned v . pack' _pack <$> x in case t of @@ -212,6 +217,28 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where 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 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 = [] From 43e77fa43020020b855be3a7578e119f11ef07ba Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 14:13:48 +0200 Subject: [PATCH 103/111] use uniqueField in pkgName --- Cabal-syntax/src/Distribution/FieldGrammar.hs | 1 + Cabal-syntax/src/Distribution/Package.hs | 2 ++ .../PackageDescription/FieldGrammar.hs | 5 ++-- .../src/Distribution/Types/MungedPackageId.hs | 3 ++- .../Distribution/Types/PackageDescription.hs | 4 +-- .../Types/PackageDescription/Lens.hs | 4 +-- .../src/Distribution/Types/PackageId.hs | 27 ++++++++++++++++--- .../src/Distribution/Types/PackageId/Lens.hs | 9 ++++--- .../Types/PackageVersionConstraint.hs | 3 ++- 9 files changed, 42 insertions(+), 16 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar.hs b/Cabal-syntax/src/Distribution/FieldGrammar.hs index 48c2654d043..0e65ab33f75 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar.hs @@ -10,6 +10,7 @@ module Distribution.FieldGrammar FieldGrammar , FieldGrammarWith (..) , uniqueField + , uniqueField' , optionalField , optionalFieldDef , monoidalField 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/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index f9cace6f483..1ad288f9349 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -116,8 +116,7 @@ packageDescriptionFieldGrammar :: forall mod c g . ( FieldGrammarWith mod c g , Applicative (g mod (PackageDescriptionWith mod)) - , Applicative (g mod PackageDescription) - , Applicative (g mod PackageIdentifier) + , Applicative (g mod (PackageIdentifierWith mod)) , c (Identity BuildType) , c (Identity PackageName) , c (Identity Version) @@ -168,7 +167,7 @@ packageDescriptionFieldGrammar = where packageIdentifierGrammar = PackageIdentifier - <$> uniqueField "name" L.pkgName + <$> uniqueField' @mod @c @g @_ @PackageName "name" (L.pkgName @mod) <*> uniqueField "version" L.pkgVersion licenseFilesGrammar = 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 d7cb56321b5..e4674b6b5f1 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -120,7 +120,7 @@ data PackageDescriptionWith (mod :: Mod.HasAnnotation) = PackageDescription 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 @@ -265,7 +265,7 @@ emptyPackageDescriptionAnn = PackageDescription { package = PackageIdentifier - (mkPackageName "") + (Ann IsInserted $ mkPackageName "") nullVersion , licenseRaw = Right UnspecifiedLicense -- TODO: , licenseFiles = [] diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs index 32737553c47..f4e72c34241 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs @@ -26,7 +26,7 @@ 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, PackageDescriptionWith) -import Distribution.Types.PackageId (PackageIdentifier) +import Distribution.Types.PackageId (PackageIdentifier, PackageIdentifierWith) import Distribution.Types.SetupBuildInfo (SetupBuildInfo) import Distribution.Types.SourceRepo (SourceRepo) import Distribution.Types.TestSuite (TestSuite, testModules) @@ -42,7 +42,7 @@ import qualified Distribution.Types.Modify as Mod import Distribution.Types.Modify (AnnotateWith) import Distribution.Trivia -package :: Lens' (PackageDescriptionWith mod) PackageIdentifier +package :: Lens' (PackageDescriptionWith mod) (PackageIdentifierWith mod) package f s = fmap (\x -> s{T.package = x}) (f (T.package s)) {-# INLINE package #-} diff --git a/Cabal-syntax/src/Distribution/Types/PackageId.hs b/Cabal-syntax/src/Distribution/Types/PackageId.hs index 0bdf475abf6..a71f4d095c2 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 -- ^ 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..a614cdc7799 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) Version pkgVersion f s = fmap (\x -> s{T.pkgVersion = x}) (f (T.pkgVersion s)) {-# INLINE pkgVersion #-} 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 From 4e1bb8e043263a66f0521b94d902a96e1703e98f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 14:15:40 +0200 Subject: [PATCH 104/111] use uniqueField in pkgVersion --- .../src/Distribution/PackageDescription/FieldGrammar.hs | 2 +- Cabal-syntax/src/Distribution/Types/PackageDescription.hs | 2 +- Cabal-syntax/src/Distribution/Types/PackageId.hs | 2 +- Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs index 1ad288f9349..b8e571a5eba 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs @@ -168,7 +168,7 @@ packageDescriptionFieldGrammar = packageIdentifierGrammar = PackageIdentifier <$> uniqueField' @mod @c @g @_ @PackageName "name" (L.pkgName @mod) - <*> uniqueField "version" L.pkgVersion + <*> uniqueField' @mod @c @g @_ @Version "version" L.pkgVersion licenseFilesGrammar = (++) diff --git a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs index e4674b6b5f1..3a6fcfd25e3 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageDescription.hs @@ -266,7 +266,7 @@ emptyPackageDescriptionAnn = { package = PackageIdentifier (Ann IsInserted $ mkPackageName "") - nullVersion + (Ann IsInserted $ nullVersion) , licenseRaw = Right UnspecifiedLicense -- TODO: , licenseFiles = [] , specVersion = Ann IsInserted CabalSpecV1_0 diff --git a/Cabal-syntax/src/Distribution/Types/PackageId.hs b/Cabal-syntax/src/Distribution/Types/PackageId.hs index a71f4d095c2..0fb1e152b53 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageId.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageId.hs @@ -36,7 +36,7 @@ type PackageIdentifier = PackageIdentifierWith Mod.HasNoAnn 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 } diff --git a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs index a614cdc7799..c22a6d0450e 100644 --- a/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs +++ b/Cabal-syntax/src/Distribution/Types/PackageId/Lens.hs @@ -20,6 +20,6 @@ pkgName :: Lens' (PackageIdentifierWith mod) (AnnotateWith Positions mod Package pkgName f s = fmap (\x -> s{T.pkgName = x}) (f (T.pkgName s)) {-# INLINE pkgName #-} -pkgVersion :: Lens' (PackageIdentifierWith mod) Version +pkgVersion :: Lens' (PackageIdentifierWith mod) (AnnotateWith Positions mod Version) pkgVersion f s = fmap (\x -> s{T.pkgVersion = x}) (f (T.pkgVersion s)) {-# INLINE pkgVersion #-} From 3520dd1cb20314caa8f9a686baf7d0fae5f4ba04 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 14:56:09 +0200 Subject: [PATCH 105/111] filter out zeroPos fields for now --- Cabal-syntax/src/Distribution/Fields/Pretty.hs | 14 ++++++++++++++ Cabal-tests/tests/ParserTests.hs | 8 +++++--- 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/Cabal-syntax/src/Distribution/Fields/Pretty.hs b/Cabal-syntax/src/Distribution/Fields/Pretty.hs index 1f115a566be..b2571dbeb0c 100644 --- a/Cabal-syntax/src/Distribution/Fields/Pretty.hs +++ b/Cabal-syntax/src/Distribution/Fields/Pretty.hs @@ -16,6 +16,7 @@ module Distribution.Fields.Pretty CommentPosition (..) , PrettyField , PrettyFieldWith (..) + , filterFields , showFields , exactShowFields , showFields' @@ -91,6 +92,19 @@ deriving instance Show (PrettyFieldWith Mod.HasAnn) 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 diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index db62fdc1971..d3bccd12ca5 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -41,7 +41,7 @@ import Distribution.Parsec (Parsec (..), explicitEitherP import Distribution.Pretty (Pretty (..), prettyShow) import Distribution.Fields.Parser (readFields') import Distribution.Fields.ParseResult -import Distribution.Fields.Pretty (PrettyFieldWith (..), exactShowFields) +import Distribution.Fields.Pretty (PrettyFieldWith (..), exactShowFields, filterFields) import Distribution.FieldGrammar.Parsec (ParsecFieldGrammar, parseFieldGrammar) import Distribution.FieldGrammar.Pretty (prettyFieldGrammar) import Distribution.Utils.Generic (fromUTF8BS, toUTF8BS) @@ -289,10 +289,12 @@ smallCabalFileTest = testCase "smallCabalFile" $ do let res = withSource (PCabalFile (fp, contents)) $ (parseGenericPackageDescription @Mod.HasAnn) contents let (_, x) = runParseResult res gpd <- case x of - Right ok -> pPrint ok >> pure ok + Right ok -> pure ok Left (_, errs) -> fail $ unlines $ "ERROR" : map (showPErrorWithSource . fmap renderCabalFileSource) (NE.toList errs) - pPrint (ppGenericPackageDescriptionAnn CabalSpecV3_0 gpd) + let prettyFields = ppGenericPackageDescriptionAnn CabalSpecV3_0 gpd + prettyFields' = filterFields prettyFields + pPrint prettyFields' where input = "tests" "ParserTests" fp fp = "smallCabalFile.cabal" From fd03f544eefc801e51abe7dc6ad32ba0f564229d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 15:22:02 +0200 Subject: [PATCH 106/111] render pretty fields with exactdoc --- Cabal-tests/tests/ParserTests.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index d3bccd12ca5..ad963c936d4 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -294,7 +294,9 @@ smallCabalFileTest = testCase "smallCabalFile" $ do let prettyFields = ppGenericPackageDescriptionAnn CabalSpecV3_0 gpd prettyFields' = filterFields prettyFields - pPrint prettyFields' + + putStrLn $ + exactShowFields prettyFields' where input = "tests" "ParserTests" fp fp = "smallCabalFile.cabal" From a48ef86a64e1d55c4ee536f05cb6293bd0b8a463 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 17:23:21 +0200 Subject: [PATCH 107/111] retain section position --- .../src/Distribution/FieldGrammar/Parsec.hs | 163 +++++++++--------- .../src/Distribution/InstalledPackageInfo.hs | 2 +- .../Distribution/PackageDescription/Parsec.hs | 54 +++--- Cabal-syntax/src/Distribution/Trivia.hs | 3 +- .../Types/GenericPackageDescription.hs | 2 +- Cabal-tests/tests/ParserTests.hs | 8 +- 6 files changed, 118 insertions(+), 114 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs index 5bc22f27490..5ea269ba0ce 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs @@ -128,19 +128,19 @@ data Section ann = MkSection !(Name ann) [SectionArg ann] [Field ann] 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 m 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 m s a -> FieldName -> [NamelessField Position] -> Bool isUnknownField grammar k _ = @@ -149,27 +149,27 @@ isUnknownField grammar k _ = || any (`BS.isPrefixOf` k) (fieldGrammarKnownPrefixes grammar) -- | Parse a ParsecFieldGrammar and check for fields that should be stanzas. -parseFieldGrammarCheckingStanzas :: CabalSpecVersion -> Fields Position -> ParsecFieldGrammar m 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 m s a -> [FieldName] fieldGrammarKnownFieldList = Set.toList . fieldGrammarKnownFields instance Applicative (ParsecFieldGrammar m s) where - pure x = ParsecFG mempty mempty (\_ _ -> pure x) + 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 () @@ -185,7 +185,7 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where 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 @@ -200,7 +200,7 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where 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 @@ -214,7 +214,7 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where 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 @@ -228,7 +228,7 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -242,7 +242,7 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -257,7 +257,7 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -273,7 +273,7 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -297,8 +297,8 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar m s a monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src a - 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 @@ -307,7 +307,7 @@ instance FieldGrammarWith Mod.HasNoAnn Parsec ParsecFieldGrammar where monoidalFieldAla' = monoidalFieldAla - prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs)) + 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 @@ -322,8 +322,8 @@ instance FieldGrammarWith Mod.HasNoAnn 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) -> @@ -335,8 +335,8 @@ instance FieldGrammarWith Mod.HasNoAnn 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) -> @@ -344,12 +344,12 @@ instance FieldGrammarWith Mod.HasNoAnn 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) -> @@ -357,12 +357,12 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -376,14 +376,14 @@ instance FieldGrammarWith Mod.HasNoAnn 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 ()) + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ _ -> pure ()) hiddenField = id @@ -392,7 +392,7 @@ instance FieldGrammarWith Mod.HasAnn 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 @@ -403,7 +403,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where 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 + parser v _ fields = case Map.lookup fn fields of Nothing -> pure def Just [] -> pure def Just [x] -> parseOne v x @@ -413,7 +413,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where 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 + parser v _ fields = case Map.lookup fn fields of Nothing -> pure Nothing Just [] -> pure Nothing Just [x] -> parseOne v x @@ -425,7 +425,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where | 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 + parser v _ fields = case Map.lookup fn fields of Nothing -> pure def Just [] -> pure def Just [x] -> parseOne v x @@ -437,7 +437,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where | 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 + parser v _ fields = case Map.lookup fn fields of Nothing -> pure Nothing Just [] -> pure Nothing Just [x] -> parseOne v x @@ -450,7 +450,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where | otherwise = pure (Just (fieldlinesToFreeText fls)) 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 @@ -463,7 +463,7 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where | otherwise = pure (fieldlinesToFreeText fls) 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 @@ -485,14 +485,14 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar m s a monoidalFieldAla fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src a - 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)) + 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 @@ -505,8 +505,8 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where reorder = map snd . sortBy (comparing fst) 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) -> @@ -517,30 +517,30 @@ instance FieldGrammarWith Mod.HasAnn 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) -> for_ fields $ \(MkNamelessField pos _) -> parseWarning pos PWTUnknownField $ "The field " <> show name <> " is available only since the Cabal specification version " ++ showCabalSpecVersion vs ++ "." - parser v values + parser v spos values 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) -> for_ fields $ \(MkNamelessField pos _) -> 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 @@ -552,13 +552,13 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where 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 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 - knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ -> pure ()) + | otherwise = parser v spos values + knownField fn = ParsecFG (Set.singleton fn) Set.empty (\_ _ _ -> pure ()) hiddenField = id -- New methods @@ -574,8 +574,8 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar Mod.HasAnn s [Ann Positions Bool] booleanFieldDef' fn _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src [Ann Positions Bool] - parser v fields = case Map.lookup fn fields of + 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 @@ -585,10 +585,10 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where 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 pos fieldLinePos) x + 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 @@ -606,15 +606,15 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar Mod.HasAnn s [(Positions, a)] monoidalFieldAla' fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src [(Positions, a)] - parser v fields = case Map.lookup fn fields of + 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 - - 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 pos fieldLinePos, x) + 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 @@ -630,24 +630,25 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions a) optionalFieldDefAla' fn _pack _extract def = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Ann Positions a) - parser v fields = case Map.lookup fn fields of + 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 - 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 pos fieldLinePos) (unpack' _pack x)) uniqueFieldAla' :: forall (b :: Type) (s :: Type) (a :: Type) @@ -663,19 +664,19 @@ instance FieldGrammarWith Mod.HasAnn Parsec ParsecFieldGrammar where -> ParsecFieldGrammar Mod.HasAnn s (Ann Positions a) uniqueFieldAla' fn _pack _extract = ParsecFG (Set.singleton fn) Set.empty parser where - parser :: CabalSpecVersion -> Fields Position -> ParseResult src (Ann Positions a) - parser v fields = case Map.lookup fn fields of + 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) - - 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 pos fieldLinePos) (unpack' _pack x)) + 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 diff --git a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs index 350b9fee757..bfc4d76f980 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' = diff --git a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs index d507e7e7563..1ae288e603f 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/Parsec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} @@ -64,9 +65,12 @@ 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 @@ -278,7 +282,7 @@ parseGenericPackageDescription' scannedVer lexWarnings utf8WarnPos fs = do setCabalSpecVersion (Just specVer') -- Package description - pd <- parseFieldGrammar specVer fields (packageDescriptionFieldGrammar @mod) + pd <- parseFieldGrammar specVer Nothing fields (packageDescriptionFieldGrammar @mod) -- -- Check that scanned and parsed versions match. -- unless (specVer == specVersion pd) $ @@ -384,24 +388,19 @@ goSections specVer = traverse_ process -- we need signature, because this is polymorphic, but not-closed parseCondTree' - :: - -- forall mod src a - -- . - - - ( L.HasBuildInfoWith mod a - , Monoid (LibraryWith mod) - , Semigroup (BuildInfoWith mod) - ) => - - ParsecFieldGrammarWith' mod a + :: ( L.HasBuildInfoWith mod a + , Monoid (LibraryWith mod) + , Semigroup (BuildInfoWith mod) + ) + => ParsecFieldGrammarWith' mod a -- \^ grammar -> (BuildInfoWith mod -> a) -> Map String (CondTreeBuildInfoWith mod) -- \^ common stanzas + -> Maybe Position -> [Field Position] -> ParseResult src (CondTree ConfVar a) - parseCondTree' = (parseCondTreeWithCommonStanzas @mod @src) specVer + parseCondTree' = parseCondTreeWithCommonStanzas @mod @src specVer parseSection :: @@ -425,7 +424,7 @@ goSections specVer = traverse_ process | name == "common" = do commonStanzas :: Map String (CondTreeBuildInfoWith mod) <- use stateCommonStanzas name' <- lift $ parseCommonName pos args - biTree :: CondTreeBuildInfoWith mod <- lift $ parseCondTree' (buildInfoFieldGrammar @mod) 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 @@ -441,7 +440,7 @@ goSections specVer = traverse_ process commonStanzas <- use stateCommonStanzas let name'' = LMainLibName - lib <- lift $ parseCondTree' (libraryFieldGrammar @mod 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 @@ -452,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) @@ -460,7 +459,7 @@ 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 :: ForeignLibWith mod) unless (onAllBranches hasType flib) $ @@ -479,7 +478,7 @@ 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 @@ -614,7 +613,7 @@ 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) _ _) = @@ -635,9 +634,10 @@ parseCondTree -- ^ common stanzas -> (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) <- @@ -646,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 @@ -679,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." @@ -810,11 +811,12 @@ parseCondTreeWithCommonStanzas -- ^ construct fromBuildInfo -> 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 @@ -1135,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/Trivia.hs b/Cabal-syntax/src/Distribution/Trivia.hs index e20678991e6..9f196c129ce 100644 --- a/Cabal-syntax/src/Distribution/Trivia.hs +++ b/Cabal-syntax/src/Distribution/Trivia.hs @@ -33,7 +33,8 @@ instance Semigroup SurroundingText where -- | A collection of different kinds of 'Position's, describing -- the provenance of a data. data Positions = Positions - { fieldNamePos :: Position + { sectionPos :: Maybe Position + , fieldNamePos :: Position , fieldLinePos :: Position } deriving (Show, Eq, Ord, Read, Data) diff --git a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs index 30488d3f8df..5e44d9fa235 100644 --- a/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs +++ b/Cabal-syntax/src/Distribution/Types/GenericPackageDescription.hs @@ -64,7 +64,7 @@ data GenericPackageDescriptionWith (m :: Mod.HasAnnotation) = GenericPackageDesc -- Perfectly, PackageIndex should have sum type, so we don't need to -- have dummy GPDs. , genPackageFlags :: [PackageFlag] - , condLibrary :: (Maybe (CondTree ConfVar (LibraryWith m))) + , condLibrary :: Maybe (CondTree ConfVar (LibraryWith m)) , condSubLibraries :: [(UnqualComponentName, CondTree ConfVar (LibraryWith m))] , condForeignLibs diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index ad963c936d4..0b2a8c7c628 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -269,7 +269,7 @@ miniBuildInfoAnnTest = testCase "miniBuildInfo Ann" $ do -- 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 frontFields miniBuildInfoFieldGrammar + pr = parseFieldGrammar CabalSpecV3_0 Nothing frontFields miniBuildInfoFieldGrammar (_warns, pr') = runParseResult pr @@ -295,8 +295,8 @@ smallCabalFileTest = testCase "smallCabalFile" $ do let prettyFields = ppGenericPackageDescriptionAnn CabalSpecV3_0 gpd prettyFields' = filterFields prettyFields - putStrLn $ - exactShowFields prettyFields' + pPrint $ prettyFields' + putStrLn $ exactShowFields prettyFields' where input = "tests" "ParserTests" fp fp = "smallCabalFile.cabal" @@ -310,7 +310,7 @@ miniBuildInfoTest = testCase "miniBuildInfo NoAnn" $ do -- 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 frontFields miniBuildInfoFieldGrammar + pr = parseFieldGrammar CabalSpecV3_0 Nothing frontFields miniBuildInfoFieldGrammar (_warns, pr') = runParseResult pr From ab864a5c49d4831dc265387f0ea0494afdb5b2e4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Mon, 4 May 2026 19:10:26 +0200 Subject: [PATCH 108/111] push out section position to pretty field (WIP) --- .../src/Distribution/FieldGrammar/Pretty.hs | 43 +++++++++++++++---- .../PackageDescription/PrettyPrint.hs | 30 +++++++++++-- 2 files changed, 61 insertions(+), 12 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 3b29ecfbc4b..58096fcf91b 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} @@ -33,18 +35,37 @@ import qualified Distribution.Types.Modify as Mod -- 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 -> s -> [PrettyFieldWith m] + { fieldGrammarPretty :: CabalSpecVersion -> s -> PrettyFieldGrammarOut m } deriving (Functor) -instance Applicative (PrettyFieldGrammar m 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 m s a -> s -> [PrettyFieldWith m] +prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> PrettyFieldGrammarOut m prettyFieldGrammar = flip fieldGrammarPretty instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where @@ -180,7 +201,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where pp xs = -- always print the field, even its Doc is empty. -- i.e. don't use ppField - [ PrettyField (zeroPos, toUTF8BS n) (zeroPos, PP.vcat $ map PP.text $ lines s) + [ (Just zeroPos,,) (zeroPos, toUTF8BS n) (zeroPos, PP.vcat $ map PP.text $ lines s) | (n, s) <- xs -- fnPfx `isPrefixOf` n ] @@ -244,15 +265,21 @@ ppField name fielddoc | PP.isEmpty fielddoc = [] | otherwise = [PrettyField name fielddoc] -ppFieldPos :: FieldName -> [(Positions, Doc)] -> [PrettyFieldWith Mod.HasAnn] +ppFieldPos :: FieldName -> [(Positions, Doc)] -> PrettyFieldGrammarOut Mod.HasAnn ppFieldPos name possFieldDocs = - [ PrettyField (fieldNamePos poss, name) (fieldLinePos poss, fieldDoc) + [ (,,) + (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 -> [PrettyFieldWith Mod.HasAnn] +ppFieldFakePos :: FieldName -> Doc -> PrettyFieldGrammarOut Mod.HasAnn ppFieldFakePos name fieldDoc = - [ PrettyField (zeroPos, name) (zeroPos, fieldDoc) + [ (,,) + (Just zeroPos) + (zeroPos, name) + (zeroPos, fieldDoc) ] diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 003b2a581b9..3f128510701 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -38,6 +40,7 @@ import Prelude () import Distribution.CabalSpecVersion import Distribution.Compat.Lens import Distribution.FieldGrammar (PrettyFieldGrammarWith', PrettyFieldGrammar', prettyFieldGrammar) +import Distribution.Fields.Field import Distribution.Fields.Pretty import Distribution.Parsec.Position import Distribution.PackageDescription @@ -63,10 +66,13 @@ import qualified Distribution.Types.SetupBuildInfo.Lens as L 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 () @@ -122,7 +128,9 @@ ppPackageDescription v pd = ppPackageDescriptionAnn :: CabalSpecVersion -> PackageDescriptionWith Mod.HasAnn -> [PrettyFieldWith Mod.HasAnn] ppPackageDescriptionAnn v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd + map + (\(_, fname, fdoc) -> PrettyField fname fdoc) + (prettyFieldGrammar v packageDescriptionFieldGrammar pd) ++ ppSourceReposAnn v (sourceRepos pd) ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField] @@ -140,9 +148,22 @@ ppSourceRepo v repo = ppSourceRepoAnn :: CabalSpecVersion -> SourceRepo -> PrettyFieldWith Mod.HasAnn ppSourceRepoAnn v repo = - -- TODO(leana8959): push out position - PrettySection (zeroPos, "source-repository") [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasAnn kind) repo + let fields = prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasAnn kind) repo + + groupedFields :: [[(Maybe Position, (Position, FieldName), (Position, Doc))]] + groupedFields = groupBy (\u v -> fst3 u == fst3 v) $ sortBy (\u v -> fst3 u `compare` fst3 v) fields + where fst3 (a, _, _) = a + + toSection :: [(Maybe Position, (Position, FieldName), (Position, Doc))] -> [PrettyFieldWith Mod.HasAnn] + toSection ((sectionPos, fname, fdoc) : xs) = + let withoutSectionPos = map (\(_, name, doc) -> PrettyField name doc) xs + in [ PrettySection (fromMaybe zeroPos sectionPos, "source-repository") [pretty kind] withoutSectionPos + ] + in case concatMap toSection groupedFields of + [] -> mempty + [x] -> x + -- TODO(leana8959): think of a way to guarantee this invariant + _ -> error "should only have one group" where kind = repoKind repo @@ -231,6 +252,7 @@ ppCondLibraryAnn :: CabalSpecVersion -> Maybe (CondTree ConfVar (LibraryWith Mod ppCondLibraryAnn _ Nothing = mempty ppCondLibraryAnn v (Just condTree) = pure $ + -- TODO(leana8959): assert that there are no more than one library ? PrettySection (zeroPos, "library") [] $ ppCondTree2Ann v (libraryFieldGrammar LMainLibName) condTree From fc01f54f865be9502421823bbf8d7a5aa4a2923b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 5 May 2026 12:09:29 +0200 Subject: [PATCH 109/111] float out position in pretty printer --- .../PackageDescription/PrettyPrint.hs | 65 ++++++++------ Cabal-tests/tests/ParserTests.hs | 88 +++++++++---------- 2 files changed, 80 insertions(+), 73 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 3f128510701..77287324164 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -137,7 +137,7 @@ ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField] ppSourceRepos = map . ppSourceRepo ppSourceReposAnn :: CabalSpecVersion -> [SourceRepo] -> [PrettyFieldWith Mod.HasAnn] -ppSourceReposAnn = map . ppSourceRepoAnn +ppSourceReposAnn v = concatMap (ppSourceRepoAnn v) ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ppSourceRepo v repo = @@ -146,24 +146,32 @@ ppSourceRepo v repo = where kind = repoKind repo -ppSourceRepoAnn :: CabalSpecVersion -> SourceRepo -> PrettyFieldWith Mod.HasAnn +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 + +intoField + :: (Maybe Position, (Position, FieldName), (Position, Doc)) + -> PrettyFieldWith Mod.HasAnn +intoField (_, name, doc) = PrettyField name doc + +intoSection + :: FieldName + -> [Doc] + -> [(Maybe Position, (Position, FieldName), (Position, Doc))] + -> [PrettyFieldWith Mod.HasAnn] +intoSection sectionName sectionArgs ((sectionPos, fname, fdoc) : xs) = + let -- all group members have the same sectionPos, drop it. + withoutSectionPos = map intoField 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) repo - - groupedFields :: [[(Maybe Position, (Position, FieldName), (Position, Doc))]] - groupedFields = groupBy (\u v -> fst3 u == fst3 v) $ sortBy (\u v -> fst3 u `compare` fst3 v) fields - where fst3 (a, _, _) = a - - toSection :: [(Maybe Position, (Position, FieldName), (Position, Doc))] -> [PrettyFieldWith Mod.HasAnn] - toSection ((sectionPos, fname, fdoc) : xs) = - let withoutSectionPos = map (\(_, name, doc) -> PrettyField name doc) xs - in [ PrettySection (fromMaybe zeroPos sectionPos, "source-repository") [pretty kind] withoutSectionPos - ] - in case concatMap toSection groupedFields of - [] -> mempty - [x] -> x - -- TODO(leana8959): think of a way to guarantee this invariant - _ -> error "should only have one group" + in concatMap (intoSection "source-repository" [pretty kind]) $ groupFields fields where kind = repoKind repo @@ -181,27 +189,25 @@ ppSetupBInfoAnn _ Nothing = mempty ppSetupBInfoAnn v (Just sbi) | defaultSetupDepends sbi = mempty | otherwise = - -- TODO(leana8959): push out position - pure $ - PrettySection (zeroPos, "custom-setup") [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasAnn False) sbi + let fields = prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasAnn False) sbi + in + concatMap (intoSection "custom-setup" []) $ groupFields fields ppGenPackageFlags :: CabalSpecVersion -> [PackageFlag] -> [PrettyField] ppGenPackageFlags = map . ppFlag ppGenPackageFlagsAnn :: CabalSpecVersion -> [PackageFlag] -> [PrettyFieldWith Mod.HasAnn] -ppGenPackageFlagsAnn = map . ppFlagAnn +ppGenPackageFlagsAnn v = concatMap (ppFlagAnn v) ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection "flag" [ppFlagName name] $ prettyFieldGrammar v (flagFieldGrammar @Mod.HasNoAnn name) flag -ppFlagAnn :: CabalSpecVersion -> PackageFlag -> PrettyFieldWith Mod.HasAnn +ppFlagAnn :: CabalSpecVersion -> PackageFlag -> [PrettyFieldWith Mod.HasAnn] ppFlagAnn v flag@(MkPackageFlag name _ _ _) = - -- TODO(leana8959): push out position - PrettySection (zeroPos, "flag") [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar @Mod.HasAnn name) flag + let fields = prettyFieldGrammar v (flagFieldGrammar @Mod.HasAnn name) flag + in concatMap (intoSection "flag" [ppFlagName name]) $ groupFields fields ppCondTree2 :: CabalSpecVersion -> PrettyFieldGrammar' s -> CondTree ConfVar s -> [PrettyField] ppCondTree2 v grammar = go @@ -225,10 +231,10 @@ ppCondTree2 v grammar = go ppCondTree2Ann :: CabalSpecVersion -> PrettyFieldGrammarWith' Mod.HasAnn s -> CondTree ConfVar s -> [PrettyFieldWith Mod.HasAnn] ppCondTree2Ann v grammar = go where - -- TODO: recognise elif opportunities go (CondNode it ifs) = - prettyFieldGrammar v grammar it - ++ concatMap ppIf ifs + -- The fields are not contained within conditions + let fields = map intoField $ prettyFieldGrammar v grammar it + in fields ++ concatMap ppIf ifs ppIf (CondBranch c thenTree Nothing) -- | isEmpty thenDoc = mempty @@ -254,6 +260,7 @@ ppCondLibraryAnn v (Just condTree) = pure $ -- TODO(leana8959): assert that there are no more than one library ? PrettySection (zeroPos, "library") [] $ + -- TODO(leana8959): float out the position here, from condtree ppCondTree2Ann v (libraryFieldGrammar LMainLibName) condTree ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Library)] -> [PrettyField] diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 0b2a8c7c628..5625229e2d4 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -88,8 +88,8 @@ tests = testGroup "parsec tests" , errorTests , ipiTests , parsecPrettyTests - , miniBuildInfoAnnTest - , miniBuildInfoTest + -- , miniBuildInfoAnnTest + -- , miniBuildInfoTest , smallCabalFileTest ] @@ -260,28 +260,28 @@ parsecPrettyTests = testGroup "parsec pretty roundtrip" $ 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" +-- 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 @@ -301,26 +301,26 @@ smallCabalFileTest = testCase "smallCabalFile" $ do 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" +-- 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 From 1a40c0aec2ac631c9495745ce1fdd73b99e3461d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 5 May 2026 14:05:15 +0200 Subject: [PATCH 110/111] float out positions from condtrees --- .../PackageDescription/PrettyPrint.hs | 49 ++++++++++--------- Cabal-tests/tests/ParserTests.hs | 2 +- 2 files changed, 28 insertions(+), 23 deletions(-) diff --git a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index 77287324164..a1fa91995e7 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -64,6 +64,8 @@ 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) @@ -152,19 +154,22 @@ groupFields groupFields = groupBy (\u v -> fst3 u == fst3 v) . sortBy (\u v -> fst3 u `compare` fst3 v) where fst3 (a, _, _) = a -intoField - :: (Maybe Position, (Position, FieldName), (Position, Doc)) - -> PrettyFieldWith Mod.HasAnn -intoField (_, name, doc) = PrettyField name doc +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 ((sectionPos, fname, fdoc) : xs) = +intoSection sectionName sectionArgs xs = let -- all group members have the same sectionPos, drop it. - withoutSectionPos = map intoField xs + (sectionPos, withoutSectionPos) = intoFields xs in [ PrettySection (fromMaybe zeroPos sectionPos, sectionName) sectionArgs withoutSectionPos ] @@ -228,23 +233,23 @@ ppCondTree2 v grammar = go , PrettySection "else" [] (go elseTree) ] -ppCondTree2Ann :: CabalSpecVersion -> PrettyFieldGrammarWith' Mod.HasAnn s -> CondTree ConfVar s -> [PrettyFieldWith Mod.HasAnn] +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 fields = map intoField $ prettyFieldGrammar v grammar it - in fields ++ concatMap ppIf ifs + let (sectionPos, fields) = intoFields $ prettyFieldGrammar v grammar it + in (sectionPos, fields ++ concatMap ppIf ifs) ppIf (CondBranch c thenTree Nothing) -- | isEmpty thenDoc = mempty | otherwise = [ppIfConditionAnn c thenDoc] where - thenDoc = go thenTree + thenDoc = snd $ go thenTree ppIf (CondBranch c thenTree (Just elseTree)) = -- See #6193 - [ ppIfConditionAnn c (go thenTree) - , PrettySection (zeroPos, "else") [] (go elseTree) + [ ppIfConditionAnn c (snd $ go thenTree) + , PrettySection (zeroPos, "else") [] (snd $ go elseTree) ] ppCondLibrary :: CabalSpecVersion -> Maybe (CondTree ConfVar Library) -> [PrettyField] @@ -257,11 +262,11 @@ ppCondLibrary v (Just condTree) = ppCondLibraryAnn :: CabalSpecVersion -> Maybe (CondTree ConfVar (LibraryWith Mod.HasAnn)) -> [PrettyFieldWith Mod.HasAnn] ppCondLibraryAnn _ Nothing = mempty ppCondLibraryAnn v (Just condTree) = - pure $ + let (sectionPos, fields) = ppCondTree2Ann v (libraryFieldGrammar LMainLibName) condTree + in -- TODO(leana8959): assert that there are no more than one library ? - PrettySection (zeroPos, "library") [] $ - -- TODO(leana8959): float out the position here, from condtree - ppCondTree2Ann v (libraryFieldGrammar LMainLibName) condTree + [ PrettySection (fromMaybe zeroPos sectionPos, "library") [] fields + ] ppCondSubLibraries :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar Library)] -> [PrettyField] ppCondSubLibraries v libs = @@ -272,9 +277,9 @@ ppCondSubLibraries v libs = ppCondSubLibrariesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (LibraryWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] ppCondSubLibrariesAnn v libs = - [ PrettySection (zeroPos, "library") [pretty n] $ - ppCondTree2Ann v (libraryFieldGrammar $ LSubLibName n) condTree + [ 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] @@ -286,9 +291,9 @@ ppCondForeignLibs v flibs = ppCondForeignLibsAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (ForeignLibWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] ppCondForeignLibsAnn v flibs = - [ PrettySection (zeroPos, "foreign-library") [pretty n] $ - ppCondTree2Ann v (foreignLibFieldGrammar n) condTree + [ 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] @@ -300,9 +305,9 @@ ppCondExecutables v exes = ppCondExecutablesAnn :: CabalSpecVersion -> [(UnqualComponentName, CondTree ConfVar (ExecutableWith Mod.HasAnn))] -> [PrettyFieldWith Mod.HasAnn] ppCondExecutablesAnn v exes = - [ PrettySection (zeroPos, "executable") [pretty n] $ - ppCondTree2Ann v (executableFieldGrammar n) condTree + [ 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] diff --git a/Cabal-tests/tests/ParserTests.hs b/Cabal-tests/tests/ParserTests.hs index 5625229e2d4..ae911fe29e3 100644 --- a/Cabal-tests/tests/ParserTests.hs +++ b/Cabal-tests/tests/ParserTests.hs @@ -296,7 +296,7 @@ smallCabalFileTest = testCase "smallCabalFile" $ do prettyFields' = filterFields prettyFields pPrint $ prettyFields' - putStrLn $ exactShowFields prettyFields' + -- putStrLn $ exactShowFields prettyFields' where input = "tests" "ParserTests" fp fp = "smallCabalFile.cabal" From d3205252eee6b6508e75c27d071219f998869f73 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9ana=20=E6=B1=9F?= Date: Tue, 5 May 2026 19:13:10 +0200 Subject: [PATCH 111/111] inject lens into pretty printer when running --- .../src/Distribution/FieldGrammar/Pretty.hs | 57 +++++++++++-------- .../src/Distribution/InstalledPackageInfo.hs | 2 +- .../PackageDescription/PrettyPrint.hs | 24 ++++---- 3 files changed, 45 insertions(+), 38 deletions(-) diff --git a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs index 58096fcf91b..75b77b3c550 100644 --- a/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs +++ b/Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs @@ -35,7 +35,12 @@ import qualified Distribution.Types.Modify as Mod -- 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 -> s -> PrettyFieldGrammarOut m + { fieldGrammarPretty + :: CabalSpecVersion + -> Maybe (ALens' s Position) + -- ^ A lens to retrieve the section position, if there are any + -> s + -> PrettyFieldGrammarOut m } deriving (Functor) @@ -65,20 +70,20 @@ instance Applicative (PrettyFieldGrammar Mod.HasAnn s) where -- | We can use 'PrettyFieldGrammar' to pp print the @s@. -- -- /Note:/ there is not trailing @($+$ text "")@. -prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar m s a -> s -> PrettyFieldGrammarOut m -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 FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) + 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 @@ -88,13 +93,13 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where 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 @@ -102,7 +107,7 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -111,7 +116,7 @@ instance FieldGrammarWith Mod.HasNoAnn 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 @@ -121,11 +126,11 @@ instance FieldGrammarWith Mod.HasNoAnn 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. @@ -146,14 +151,16 @@ instance FieldGrammarWith Mod.HasNoAnn Pretty PrettyFieldGrammar where hiddenField _ = PrettyFG (\_ -> mempty) instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where - blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f) + -- Nothing because subgrammar is not directly within a section? + blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v _ -> pp v Nothing . aview f) - uniqueFieldAla fn _pack l = PrettyFG $ \_v s -> + -- 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 s + pp _v pl s | b == def = mempty | otherwise = ppFieldFakePos fn (PP.text (show b)) where @@ -161,13 +168,13 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where optionalFieldAla fn _pack l = PrettyFG pp where - pp v s = case aview l s of + 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 s + pp v pl s | x == def = mempty | otherwise = ppFieldFakePos fn (prettyVersioned v (pack' _pack x)) where @@ -175,7 +182,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where freeTextField fn l = PrettyFG pp where - pp v s = maybe mempty (ppFieldFakePos fn . showFT) (aview l s) + pp v pl s = maybe mempty (ppFieldFakePos fn . showFT) (aview l s) where showFT | v >= CabalSpecV3_0 = showFreeTextV3 @@ -184,7 +191,7 @@ instance FieldGrammarWith Mod.HasAnn 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 = ppFieldFakePos fn (showFT (aview l s)) + pp v pl s = ppFieldFakePos fn (showFT (aview l s)) where showFT | v >= CabalSpecV3_0 = showFreeTextV3 @@ -194,9 +201,9 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where monoidalFieldAla fn _pack l = PrettyFG pp where - pp v s = ppFieldFakePos fn (prettyVersioned v (pack' _pack (aview l s))) + pp v pl s = ppFieldFakePos fn (prettyVersioned v (pack' _pack (aview l s))) - 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. @@ -218,11 +225,11 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where -- New methods - monoidalFieldAla' fn _pack l = PrettyFG $ \v s -> + 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 s -> + 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 @@ -230,7 +237,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where optionalFieldDefAla' fn _pack l def = PrettyFG pp where -- We absorb fields that have no position for the prototype - pp v s = + 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)] @@ -252,7 +259,7 @@ instance FieldGrammarWith Mod.HasAnn Pretty PrettyFieldGrammar where -> PrettyFieldGrammar Mod.HasAnn s (Ann Positions a) uniqueFieldAla' fn _pack l = PrettyFG pp where - pp v s = + 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 diff --git a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs index bfc4d76f980..d1273b90032 100644 --- a/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs +++ b/Cabal-syntax/src/Distribution/InstalledPackageInfo.hs @@ -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/PackageDescription/PrettyPrint.hs b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs index a1fa91995e7..2fb945053cc 100644 --- a/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs +++ b/Cabal-syntax/src/Distribution/PackageDescription/PrettyPrint.hs @@ -125,14 +125,14 @@ ppGenericPackageDescriptionAnn v gpd0 = ppPackageDescription :: CabalSpecVersion -> PackageDescription -> [PrettyField] ppPackageDescription v pd = - prettyFieldGrammar v packageDescriptionFieldGrammar pd + prettyFieldGrammar v packageDescriptionFieldGrammar Nothing pd ++ ppSourceRepos v (sourceRepos pd) ppPackageDescriptionAnn :: CabalSpecVersion -> PackageDescriptionWith Mod.HasAnn -> [PrettyFieldWith Mod.HasAnn] ppPackageDescriptionAnn v pd = map (\(_, fname, fdoc) -> PrettyField fname fdoc) - (prettyFieldGrammar v packageDescriptionFieldGrammar pd) + (prettyFieldGrammar v packageDescriptionFieldGrammar Nothing pd) ++ ppSourceReposAnn v (sourceRepos pd) ppSourceRepos :: CabalSpecVersion -> [SourceRepo] -> [PrettyField] @@ -144,7 +144,7 @@ ppSourceReposAnn v = concatMap (ppSourceRepoAnn v) ppSourceRepo :: CabalSpecVersion -> SourceRepo -> PrettyField ppSourceRepo v repo = PrettySection "source-repository" [pretty kind] $ - prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasNoAnn kind) repo + prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasNoAnn kind) Nothing repo where kind = repoKind repo @@ -175,7 +175,7 @@ intoSection sectionName sectionArgs xs = ppSourceRepoAnn :: CabalSpecVersion -> SourceRepo -> [PrettyFieldWith Mod.HasAnn] ppSourceRepoAnn v repo = - let fields = prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasAnn kind) repo + let fields = prettyFieldGrammar v (sourceRepoFieldGrammar @Mod.HasAnn kind) Nothing repo in concatMap (intoSection "source-repository" [pretty kind]) $ groupFields fields where kind = repoKind repo @@ -187,14 +187,14 @@ ppSetupBInfo v (Just sbi) | otherwise = pure $ PrettySection "custom-setup" [] $ - prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasNoAnn False) sbi + prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasNoAnn False) Nothing sbi 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) sbi + let fields = prettyFieldGrammar v (setupBInfoFieldGrammar @Mod.HasAnn False) Nothing sbi in concatMap (intoSection "custom-setup" []) $ groupFields fields @@ -207,11 +207,11 @@ ppGenPackageFlagsAnn v = concatMap (ppFlagAnn v) ppFlag :: CabalSpecVersion -> PackageFlag -> PrettyField ppFlag v flag@(MkPackageFlag name _ _ _) = PrettySection "flag" [ppFlagName name] $ - prettyFieldGrammar v (flagFieldGrammar @Mod.HasNoAnn name) flag + 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) flag + 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] @@ -219,7 +219,7 @@ 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) @@ -238,7 +238,7 @@ ppCondTree2Ann v grammar = go where go (CondNode it ifs) = -- The fields are not contained within conditions - let (sectionPos, fields) = intoFields $ prettyFieldGrammar v grammar it + let (sectionPos, fields) = intoFields $ prettyFieldGrammar v grammar Nothing it in (sectionPos, fields ++ concatMap ppIf ifs) ppIf (CondBranch c thenTree Nothing) @@ -469,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 + maybe mempty (prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar Nothing) mb_lib_bi ++ [ PrettySection "executable:" [pretty name] $ - prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar bi + prettyFieldGrammar cabalSpecLatest buildInfoFieldGrammar Nothing bi | (name, bi) <- ex_bis ]