merge queue: checking #12350 on master (ac7bea9)

Cabal-syntax/src/Distribution/FieldGrammar.hs

@@ -25,7 +25,6 @@ module Distribution.FieldGrammar
   , takeFields
   , runFieldParser
   , runFieldParser'
-  , defaultFreeTextFieldDefST
 
     -- * Newtypes
   , module Distribution.FieldGrammar.Newtypes

Cabal-syntax/src/Distribution/FieldGrammar/Class.hs

@@ -8,19 +8,18 @@ module Distribution.FieldGrammar.Class
   , optionalField
   , optionalFieldDef
   , monoidalField
-  , defaultFreeTextFieldDefST
   ) where
 
 import Data.Coerce (Coercible)
 import Data.Kind (Constraint, Type)
+import Data.Text (Text)
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
 
 import Distribution.CabalSpecVersion (CabalSpecVersion)
 import Distribution.FieldGrammar.Newtypes
 import Distribution.Fields.Field
-import Distribution.Utils.ShortText
 
 -- | @g@ is parametrised by
 --
@@ -91,26 +90,19 @@ class
   -- @since 3.0.0.0
   freeTextField
     :: FieldName
-    -> ALens' s (Maybe String)
+    -> ALens' s (Maybe Text)
     -- ^ lens into the field
-    -> g s (Maybe String)
+    -> g s (Maybe Text)
 
   --  | Free text field is essentially 'optionalFieldDefAla` with @""@
   --  as the default and "accept everything" parser.
   --
   -- @since 3.0.0.0
   freeTextFieldDef
     :: FieldName
-    -> ALens' s String
+    -> ALens' s Text
     -- ^ lens into the field
-    -> g s String
-
-  -- | @since 3.2.0.0
-  freeTextFieldDefST
-    :: FieldName
-    -> ALens' s ShortText
-    -- ^ lens into the field
-    -> g s ShortText
+    -> g s Text
 
   -- | Monoidal field.
   --
@@ -130,9 +122,9 @@ class
   prefixedFields
     :: FieldName
     -- ^ field name prefix
-    -> ALens' s [(String, String)]
+    -> ALens' s [(Text, Text)]
     -- ^ lens into the field
-    -> g s [(String, String)]
+    -> g s [(Text, Text)]
 
   -- | Known field, which we don't parse, nor pretty print.
   knownField :: FieldName -> g s ()
@@ -222,16 +214,3 @@ monoidalField
   -- ^ lens into the field
   -> g s a
 monoidalField fn l = monoidalFieldAla fn Identity l
-
--- | Default implementation for 'freeTextFieldDefST'.
-defaultFreeTextFieldDefST
-  :: FieldGrammar c g
-  => FieldName
-  -> ALens' s ShortText
-  -- ^ lens into the field
-  -> g s ShortText
-defaultFreeTextFieldDefST fn l =
-  toShortText <$> freeTextFieldDef fn (cloneLens l . st)
-  where
-    st :: Lens' ShortText String
-    st f s = toShortText <$> f (fromShortText s)

Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs

@@ -17,6 +17,7 @@ import Distribution.Utils.String (trim)
 
 import Data.Coerce
 import qualified Data.Map as Map
+import qualified Data.Text as T
 import qualified Distribution.Compat.CharParsing as C
 import qualified Distribution.Fields as P
 import qualified Distribution.Parsec as P
@@ -107,15 +108,13 @@ instance FieldGrammar ParsecPretty FieldDescrs where
 
   freeTextField fn l = singletonF fn f g
     where
-      f s = maybe mempty showFreeText (aview l s)
-      g s = cloneLens l (const (Just <$> parsecFreeText)) s
+      f s = maybe mempty (showFreeText . T.unpack) (aview l s)
+      g s = cloneLens l (const (Just . T.pack <$> parsecFreeText)) s
 
   freeTextFieldDef fn l = singletonF fn f g
     where
-      f s = showFreeText (aview l s)
-      g s = cloneLens l (const parsecFreeText) s
-
-  freeTextFieldDefST = defaultFreeTextFieldDefST
+      f s = showFreeText (T.unpack (aview l s))
+      g s = cloneLens l (const (T.pack <$> parsecFreeText)) s
 
   monoidalFieldAla
     :: forall s proxy a b

Cabal-syntax/src/Distribution/FieldGrammar/Parsec.hs

@@ -75,6 +75,8 @@ import Data.Coerce (Coercible, coerce)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import qualified Distribution.Utils.ShortText as ShortText
 import qualified Text.Parsec as P
 import qualified Text.Parsec.Error as P
@@ -260,26 +262,10 @@ instance FieldGrammar Parsec ParsecFieldGrammar where
 
       parseOne v (MkNamelessField pos fls)
         | null fls = pure Nothing
-        | v >= freeTextIgnoreDotlineVers = pure (Just (fieldlinesToFreeText3 pos fls))
-        | otherwise = pure (Just (fieldlinesToFreeText fls))
+        | v >= freeTextIgnoreDotlineVers = pure (Just (T.pack (fieldlinesToFreeText3 pos fls)))
+        | otherwise = pure (Just (T.pack (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 = defaultFreeTextFieldDefST
-  freeTextFieldDefST fn _ = ParsecFG (Set.singleton fn) Set.empty parser
     where
       parser v fields = case Map.lookup fn fields of
         Nothing -> pure mempty
@@ -315,12 +301,12 @@ instance FieldGrammar Parsec ParsecFieldGrammar where
 
   prefixedFields fnPfx _extract = ParsecFG mempty (Set.singleton fnPfx) (\_ fs -> pure (parser fs))
     where
-      parser :: Fields Position -> [(String, String)]
+      parser :: Fields Position -> [(T.Text, T.Text)]
       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))
+        [ (pos, (T.decodeUtf8 fn, T.strip $ T.decodeUtf8 $ fieldlinesToBS fls))
         | MkNamelessField pos fls <- fields
         ]
       -- hack: recover the order of prefixed fields

Cabal-syntax/src/Distribution/FieldGrammar/Pretty.hs

@@ -4,13 +4,14 @@ module Distribution.FieldGrammar.Pretty
   ) where
 
 import Data.Coerce (Coercible, coerce)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
 import Distribution.CabalSpecVersion
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Distribution.Fields.Field (FieldName)
 import Distribution.Fields.Pretty (PrettyField (..))
 import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3)
-import Distribution.Utils.Generic (toUTF8BS)
 import Text.PrettyPrint (Doc)
 import qualified Text.PrettyPrint as PP
 import Prelude ()
@@ -84,7 +85,7 @@ instance FieldGrammar Pretty PrettyFieldGrammar where
 
   freeTextField fn l = PrettyFG pp
     where
-      pp v s = maybe mempty (ppField fn . showFT) (aview l s)
+      pp v s = maybe mempty (ppField fn . showFT . T.unpack) (aview l s)
         where
           showFT
             | v >= CabalSpecV3_0 = showFreeTextV3
@@ -93,14 +94,12 @@ instance FieldGrammar Pretty PrettyFieldGrammar where
   -- it's ok to just show, as showFreeText of empty string is empty.
   freeTextFieldDef fn l = PrettyFG pp
     where
-      pp v s = ppField fn (showFT (aview l s))
+      pp v s = ppField fn (showFT (T.unpack (aview l s)))
         where
           showFT
             | v >= CabalSpecV3_0 = showFreeTextV3
             | otherwise = showFreeText
 
-  freeTextFieldDefST = defaultFreeTextFieldDefST
-
   monoidalFieldAla
     :: forall s proxy a b
      . (Coercible a b, Pretty b)
@@ -117,7 +116,7 @@ instance FieldGrammar 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 () (T.encodeUtf8 n) $ PP.vcat $ map (PP.text . T.unpack) $ T.lines s
         | (n, s) <- xs
         -- fnPfx `isPrefixOf` n
         ]

Cabal-syntax/src/Distribution/PackageDescription/FieldGrammar.hs

@@ -82,8 +82,10 @@ import Distribution.Pretty (Pretty (..), prettyShow, showToken)
 import Distribution.Utils.Path
 import Distribution.Version (Version, VersionRange)
 
+import Data.Bifunctor
 import qualified Data.ByteString.Char8 as BS8
 import Data.Coerce (coerce)
+import qualified Data.Text as T
 import qualified Distribution.Compat.CharParsing as P
 import qualified Distribution.SPDX as SPDX
 import qualified Distribution.Types.Lens as L
@@ -111,19 +113,19 @@ packageDescriptionFieldGrammar = do
   package <- blurFieldGrammar L.package packageIdentifierGrammar
   licenseRaw <- optionalFieldDefAla "license" SpecLicense L.licenseRaw (Left SPDX.NONE)
   licenseFiles <- licenseFilesGrammar
-  copyright <- freeTextFieldDefST "copyright" L.copyright
-  maintainer <- freeTextFieldDefST "maintainer" L.maintainer
-  author <- freeTextFieldDefST "author" L.author
-  stability <- freeTextFieldDefST "stability" L.stability
+  copyright <- freeTextFieldDef "copyright" L.copyright
+  maintainer <- freeTextFieldDef "maintainer" L.maintainer
+  author <- freeTextFieldDef "author" L.author
+  stability <- freeTextFieldDef "stability" L.stability
   testedWith <- monoidalFieldAla "tested-with" (alaList' FSep TestedWith) L.testedWith
-  homepage <- freeTextFieldDefST "homepage" L.homepage
-  pkgUrl <- freeTextFieldDefST "package-url" L.pkgUrl
-  bugReports <- freeTextFieldDefST "bug-reports" L.bugReports
+  homepage <- freeTextFieldDef "homepage" L.homepage
+  pkgUrl <- freeTextFieldDef "package-url" L.pkgUrl
+  bugReports <- freeTextFieldDef "bug-reports" L.bugReports
   let sourceRepos = []
-  synopsis <- freeTextFieldDefST "synopsis" L.synopsis
-  description <- freeTextFieldDefST "description" L.description
-  category <- freeTextFieldDefST "category" L.category
-  customFieldsPD <- prefixedFields "x-" L.customFieldsPD
+  synopsis <- freeTextFieldDef "synopsis" L.synopsis
+  description <- freeTextFieldDef "description" L.description
+  category <- freeTextFieldDef "category" L.category
+  customFieldsPD <- map (bimap T.unpack T.unpack) <$> prefixedFields "x-" L.customFieldsPDText
   buildTypeRaw <- optionalField "build-type" L.buildTypeRaw
   let setupBuildInfo = Nothing
       -- components
@@ -712,7 +714,7 @@ buildInfoFieldGrammar = do
   sharedOptions <- sharedOptionsFieldGrammar
   profSharedOptions <- profSharedOptionsFieldGrammar
   let staticOptions = mempty
-  customFieldsBI <- prefixedFields "x-" L.customFieldsBI
+  customFieldsBI <- map (bimap T.unpack T.unpack) <$> prefixedFields "x-" L.customFieldsBIText
   targetBuildDepends <- monoidalFieldAla "build-depends" formatDependencyList L.targetBuildDepends
   mixins <-
     monoidalFieldAla "mixins" formatMixinList L.mixins
@@ -807,7 +809,7 @@ flagFieldGrammar
   => FlagName
   -> g PackageFlag PackageFlag
 flagFieldGrammar flagName = do
-  flagDescription <- freeTextFieldDef "description" L.flagDescription
+  flagDescription <- T.unpack <$> freeTextFieldDef "description" L.flagDescription
   flagDefault <- booleanFieldDef "default" L.flagDefault True
   flagManual <- booleanFieldDef "manual" L.flagManual False
   pure MkPackageFlag{..}
@@ -824,7 +826,7 @@ sourceRepoFieldGrammar
   -> g SourceRepo SourceRepo
 sourceRepoFieldGrammar repoKind = do
   repoType <- optionalField "type" L.repoType
-  repoLocation <- freeTextField "location" L.repoLocation
+  repoLocation <- fmap T.unpack <$> freeTextField "location" L.repoLocation
   repoModule <- optionalFieldAla "module" Token L.repoModule
   repoBranch <- optionalFieldAla "branch" Token L.repoBranch
   repoTag <- optionalFieldAla "tag" Token L.repoTag

Cabal-syntax/src/Distribution/Types/BuildInfo/Lens.hs

@@ -3,9 +3,11 @@
 module Distribution.Types.BuildInfo.Lens
   ( BuildInfo
   , HasBuildInfo (..)
+  , customFieldsBIText
   , HasBuildInfos (..)
   ) where
 
+import Data.Bifunctor
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
@@ -21,6 +23,7 @@ import Distribution.Types.PkgconfigDependency (PkgconfigDependency)
 import Distribution.Utils.Path
 import Language.Haskell.Extension (Extension, Language)
 
+import qualified Data.Text as T
 import qualified Distribution.Types.BuildInfo as T
 
 -- | Classy lenses for 'BuildInfo'.
@@ -219,6 +222,13 @@ class HasBuildInfo a where
   mixins = buildInfo . mixins
   {-# INLINE mixins #-}
 
+customFieldsBIText :: HasBuildInfo a => Lens' a [(T.Text, T.Text)]
+customFieldsBIText = customFieldsBI . textLens
+  where
+    textLens :: Lens' [(String, String)] [(T.Text, T.Text)]
+    textLens f = fmap (map (bimap T.unpack T.unpack)) . f . map (bimap T.pack T.pack)
+{-# INLINE customFieldsBIText #-}
+
 instance HasBuildInfo BuildInfo where
   buildInfo = id
   {-# INLINE buildInfo #-}

Cabal-syntax/src/Distribution/Types/GenericPackageDescription/Lens.hs

@@ -6,6 +6,8 @@ module Distribution.Types.GenericPackageDescription.Lens
   , module Distribution.Types.GenericPackageDescription.Lens
   ) where
 
+import Data.Text (Text)
+import qualified Data.Text as T
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
@@ -95,8 +97,8 @@ flagName :: Lens' PackageFlag FlagName
 flagName f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag y1 x2 x3 x4) (f x1)
 {-# INLINE flagName #-}
 
-flagDescription :: Lens' PackageFlag String
-flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 y1 x3 x4) (f x2)
+flagDescription :: Lens' PackageFlag Text
+flagDescription f (MkPackageFlag x1 x2 x3 x4) = fmap (\y1 -> MkPackageFlag x1 (T.unpack y1) x3 x4) (f (T.pack x2))
 {-# INLINE flagDescription #-}
 
 flagDefault :: Lens' PackageFlag Bool

Cabal-syntax/src/Distribution/Types/InstalledPackageInfo/FieldGrammar.hs

@@ -83,15 +83,15 @@ ipiFieldGrammar =
     <@> optionalFieldDefAla "instantiated-with" InstWith L.instantiatedWith []
     <@> optionalFieldDefAla "key" CompatPackageKey L.compatPackageKey ""
     <@> optionalFieldDefAla "license" SpecLicenseLenient L.license (Left SPDX.NONE)
-    <@> freeTextFieldDefST "copyright" L.copyright
-    <@> freeTextFieldDefST "maintainer" L.maintainer
-    <@> freeTextFieldDefST "author" L.author
-    <@> freeTextFieldDefST "stability" L.stability
-    <@> freeTextFieldDefST "homepage" L.homepage
-    <@> freeTextFieldDefST "package-url" L.pkgUrl
-    <@> freeTextFieldDefST "synopsis" L.synopsis
-    <@> freeTextFieldDefST "description" L.description
-    <@> freeTextFieldDefST "category" L.category
+    <@> freeTextFieldDef "copyright" L.copyright
+    <@> freeTextFieldDef "maintainer" L.maintainer
+    <@> freeTextFieldDef "author" L.author
+    <@> freeTextFieldDef "stability" L.stability
+    <@> freeTextFieldDef "homepage" L.homepage
+    <@> freeTextFieldDef "package-url" L.pkgUrl
+    <@> freeTextFieldDef "synopsis" L.synopsis
+    <@> freeTextFieldDef "description" L.description
+    <@> freeTextFieldDef "category" L.category
     -- Installed fields
     <@> optionalFieldDef "abi" L.abiHash (mkAbiHash "")
     <@> booleanFieldDef "indefinite" L.indefinite False

Cabal-syntax/src/Distribution/Types/PackageDescription/Lens.hs

@@ -5,6 +5,7 @@ module Distribution.Types.PackageDescription.Lens
   , module Distribution.Types.PackageDescription.Lens
   ) where
 
+import Data.Bifunctor
 import Distribution.Compat.Lens
 import Distribution.Compat.Prelude
 import Prelude ()
@@ -34,6 +35,7 @@ import Distribution.Utils.Path
 import Distribution.Utils.ShortText (ShortText)
 import Distribution.Version (VersionRange)
 
+import qualified Data.Text as T
 import qualified Distribution.SPDX as SPDX
 import qualified Distribution.Types.PackageDescription as T
 
@@ -101,6 +103,13 @@ customFieldsPD :: Lens' PackageDescription [(String, String)]
 customFieldsPD f s = fmap (\x -> s{T.customFieldsPD = x}) (f (T.customFieldsPD s))
 {-# INLINE customFieldsPD #-}
 
+customFieldsPDText :: Lens' PackageDescription [(T.Text, T.Text)]
+customFieldsPDText = customFieldsPD . textLens
+  where
+    textLens :: Lens' [(String, String)] [(T.Text, T.Text)]
+    textLens f = fmap (map (bimap T.unpack T.unpack)) . f . map (bimap T.pack T.pack)
+{-# INLINE customFieldsPDText #-}
+
 specVersion :: Lens' PackageDescription CabalSpecVersion
 specVersion f s = fmap (\x -> s{T.specVersion = x}) (f (T.specVersion s))
 {-# INLINE specVersion #-}