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

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE InstanceSigs #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE RankNTypes #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9
  10 -- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar".
  11 module Distribution.FieldGrammar.Newtypes
  12   ( -- * List
  13     alaList
  14   , alaList'
  15
  16     -- ** Modifiers
  17   , CommaVCat (..)
  18   , CommaFSep (..)
  19   , VCat (..)
  20   , FSep (..)
  21   , NoCommaFSep (..)
  22   , Sep (..)
  23
  24     -- ** Type
  25   , List
  26
  27     -- ** Set
  28   , alaSet
  29   , alaSet'
  30   , Set'
  31
  32     -- ** NonEmpty
  33   , alaNonEmpty
  34   , alaNonEmpty'
  35   , NonEmpty'
  36
  37     -- * Version & License
  38   , SpecVersion (..)
  39   , TestedWith (..)
  40   , SpecLicense (..)
  41
  42     -- * Identifiers
  43   , Token (..)
  44   , Token' (..)
  45   , MQuoted (..)
  46   , FilePathNT (..)
  47   , SymbolicPathNT (..)
  48   , RelativePathNT (..)
  49   ) where
  50
  51 import Distribution.Compat.Newtype
  52 import Distribution.Compat.Prelude
  53 import Prelude ()
  54
  55 import Distribution.CabalSpecVersion
  56 import Distribution.Compiler (CompilerFlavor)
  57 import Distribution.License (License)
  58 import Distribution.Parsec
  59 import Distribution.Pretty
  60 import Distribution.Utils.Path
  61 import Distribution.Version
  62   ( LowerBound (..)
  63   , Version
  64   , VersionInterval (..)
  65   , VersionRange
  66   , VersionRangeF (..)
  67   , anyVersion
  68   , asVersionIntervals
  69   , cataVersionRange
  70   , mkVersion
  71   , version0
  72   , versionNumbers
  73   )
  74 import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat)
  75
  76 import qualified Data.List.NonEmpty as NE
  77 import qualified Data.Set as Set
  78 import qualified Distribution.Compat.CharParsing as P
  79 import qualified Distribution.SPDX as SPDX
  80
  81 -- | Vertical list with commas. Displayed with 'vcat'
  82 data CommaVCat = CommaVCat
  83
  84 -- | Paragraph fill list with commas. Displayed with 'fsep'
  85 data CommaFSep = CommaFSep
  86
  87 -- | Vertical list with optional commas. Displayed with 'vcat'.
  88 data VCat = VCat
  89
  90 -- | Paragraph fill list with optional commas. Displayed with 'fsep'.
  91 data FSep = FSep
  92
  93 -- | Paragraph fill list without commas. Displayed with 'fsep'.
  94 data NoCommaFSep = NoCommaFSep
  95
  96 class Sep sep where
  97   prettySep :: Proxy sep -> [Doc] -> Doc
  98
  99   parseSep :: CabalParsing m => Proxy sep -> m a -> m [a]
 100   parseSepNE :: CabalParsing m => Proxy sep -> m a -> m (NonEmpty a)
 101
 102 instance Sep CommaVCat where
 103   prettySep _ = vcat . punctuate comma
 104   parseSep _ p = do
 105     v <- askCabalSpecVersion
 106     if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
 107   parseSepNE _ p = do
 108     v <- askCabalSpecVersion
 109     if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
 110 instance Sep CommaFSep where
 111   prettySep _ = fsep . punctuate comma
 112   parseSep _ p = do
 113     v <- askCabalSpecVersion
 114     if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p
 115   parseSepNE _ p = do
 116     v <- askCabalSpecVersion
 117     if v >= CabalSpecV2_2 then parsecLeadingCommaNonEmpty p else parsecCommaNonEmpty p
 118 instance Sep VCat where
 119   prettySep _ = vcat
 120   parseSep _ p = do
 121     v <- askCabalSpecVersion
 122     if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
 123   parseSepNE _ p = NE.some1 (p <* P.spaces)
 124 instance Sep FSep where
 125   prettySep _ = fsep
 126   parseSep _ p = do
 127     v <- askCabalSpecVersion
 128     if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p
 129   parseSepNE _ p = NE.some1 (p <* P.spaces)
 130 instance Sep NoCommaFSep where
 131   prettySep _ = fsep
 132   parseSep _ p = many (p <* P.spaces)
 133   parseSepNE _ p = NE.some1 (p <* P.spaces)
 134
 135 -- | List separated with optional commas. Displayed with @sep@, arguments of
 136 -- type @a@ are parsed and pretty-printed as @b@.
 137 newtype List sep b a = List {_getList :: [a]}
 138
 139 -- | 'alaList' and 'alaList'' are simply 'List', with additional phantom
 140 -- arguments to constrain the resulting type
 141 --
 142 -- >>> :t alaList VCat
 143 -- alaList VCat :: [a] -> List VCat (Identity a) a
 144 --
 145 -- >>> :t alaList' FSep Token
 146 -- alaList' FSep Token :: [String] -> List FSep Token String
 147 alaList :: sep -> [a] -> List sep (Identity a) a
 148 alaList _ = List
 149
 150 -- | More general version of 'alaList'.
 151 alaList' :: sep -> (a -> b) -> [a] -> List sep b a
 152 alaList' _ _ = List
 153
 154 instance Newtype [a] (List sep wrapper a)
 155
 156 instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where
 157   parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec
 158
 159 instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where
 160   pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack
 161
 162 --
 163
 164 -- | Like 'List', but for 'Set'.
 165 --
 166 -- @since 3.2.0.0
 167 newtype Set' sep b a = Set' {_getSet :: Set a}
 168
 169 -- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom
 170 -- arguments to constrain the resulting type
 171 --
 172 -- >>> :t alaSet VCat
 173 -- alaSet VCat :: Set a -> Set' VCat (Identity a) a
 174 --
 175 -- >>> :t alaSet' FSep Token
 176 -- alaSet' FSep Token :: Set String -> Set' FSep Token String
 177 --
 178 -- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo"
 179 -- Right (fromList ["bar","foo"])
 180 --
 181 -- @since 3.2.0.0
 182 alaSet :: sep -> Set a -> Set' sep (Identity a) a
 183 alaSet _ = Set'
 184
 185 -- | More general version of 'alaSet'.
 186 --
 187 -- @since 3.2.0.0
 188 alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a
 189 alaSet' _ _ = Set'
 190
 191 instance Newtype (Set a) (Set' sep wrapper a)
 192
 193 instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where
 194   parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec
 195
 196 instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where
 197   pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack
 198
 199 --
 200
 201 -- | Like 'List', but for 'NonEmpty'.
 202 --
 203 -- @since 3.2.0.0
 204 newtype NonEmpty' sep b a = NonEmpty' {_getNonEmpty :: NonEmpty a}
 205
 206 -- | 'alaNonEmpty' and 'alaNonEmpty'' are simply 'NonEmpty'' constructor, with additional phantom
 207 -- arguments to constrain the resulting type
 208 --
 209 -- >>> :t alaNonEmpty VCat
 210 -- alaNonEmpty VCat :: NonEmpty a -> NonEmpty' VCat (Identity a) a
 211 --
 212 -- >>> unpack' (alaNonEmpty' FSep Token) <$> eitherParsec "foo bar foo"
 213 -- Right ("foo" :| ["bar","foo"])
 214 --
 215 -- @since 3.2.0.0
 216 alaNonEmpty :: sep -> NonEmpty a -> NonEmpty' sep (Identity a) a
 217 alaNonEmpty _ = NonEmpty'
 218
 219 -- | More general version of 'alaNonEmpty'.
 220 --
 221 -- @since 3.2.0.0
 222 alaNonEmpty' :: sep -> (a -> b) -> NonEmpty a -> NonEmpty' sep b a
 223 alaNonEmpty' _ _ = NonEmpty'
 224
 225 instance Newtype (NonEmpty a) (NonEmpty' sep wrapper a)
 226
 227 instance (Newtype a b, Sep sep, Parsec b) => Parsec (NonEmpty' sep b a) where
 228   parsec = pack . fmap (unpack :: b -> a) <$> parseSepNE (Proxy :: Proxy sep) parsec
 229
 230 instance (Newtype a b, Sep sep, Pretty b) => Pretty (NonEmpty' sep b a) where
 231   pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . NE.toList . unpack
 232
 233 -------------------------------------------------------------------------------
 234 -- Identifiers
 235 -------------------------------------------------------------------------------
 236
 237 -- | Haskell string or @[^ ,]+@
 238 newtype Token = Token {getToken :: String}
 239
 240 instance Newtype String Token
 241
 242 instance Parsec Token where
 243   parsec = pack <$> parsecToken
 244
 245 instance Pretty Token where
 246   pretty = showToken . unpack
 247
 248 -- | Haskell string or @[^ ]+@
 249 newtype Token' = Token' {getToken' :: String}
 250
 251 instance Newtype String Token'
 252
 253 instance Parsec Token' where
 254   parsec = pack <$> parsecToken'
 255
 256 instance Pretty Token' where
 257   pretty = showToken . unpack
 258
 259 -- | Either @"quoted"@ or @un-quoted@.
 260 newtype MQuoted a = MQuoted {getMQuoted :: a}
 261
 262 instance Newtype a (MQuoted a)
 263
 264 instance Parsec a => Parsec (MQuoted a) where
 265   parsec = pack <$> parsecMaybeQuoted parsec
 266
 267 instance Pretty a => Pretty (MQuoted a) where
 268   pretty = pretty . unpack
 269
 270 -- | Filepath are parsed as 'Token'.
 271 newtype FilePathNT = FilePathNT {getFilePathNT :: String}
 272
 273 instance Newtype String FilePathNT
 274
 275 instance Parsec FilePathNT where
 276   parsec = do
 277     token <- parsecToken
 278     if null token
 279       then P.unexpected "empty FilePath"
 280       else return (FilePathNT token)
 281
 282 instance Pretty FilePathNT where
 283   pretty = showFilePath . unpack
 284
 285 -- | Newtype for 'SymbolicPath', with a different 'Parsec' instance
 286 -- to disallow empty paths.
 287 newtype SymbolicPathNT from to = SymbolicPathNT {getSymbolicPathNT :: SymbolicPath from to}
 288
 289 instance Newtype (SymbolicPath from to) (SymbolicPathNT from to)
 290
 291 instance Parsec (SymbolicPathNT from to) where
 292   parsec = do
 293     token <- parsecToken
 294     if null token
 295       then P.unexpected "empty FilePath"
 296       else return (SymbolicPathNT $ makeSymbolicPath token)
 297
 298 instance Pretty (SymbolicPathNT from to) where
 299   pretty = showFilePath . getSymbolicPath . getSymbolicPathNT
 300
 301 -- | Newtype for 'RelativePath', with a different 'Parsec' instance
 302 -- to disallow empty paths but allow non-relative paths (which get rejected
 303 -- later with a different error message, see 'Distribution.PackageDescription.Check.Paths.checkPath')
 304 newtype RelativePathNT from to = RelativePathNT {getRelativePathNT :: RelativePath from to}
 305
 306 instance Newtype (RelativePath from to) (RelativePathNT from to)
 307
 308 -- NB: we don't reject non-relative paths here; we allow them here and reject
 309 -- later (see 'Distribution.PackageDescription.Check.Paths.checkPath').
 310 instance Parsec (RelativePathNT from to) where
 311   parsec = do
 312     token <- parsecToken
 313     if null token
 314       then P.unexpected "empty FilePath"
 315       else return (RelativePathNT $ unsafeMakeSymbolicPath token)
 316
 317 instance Pretty (RelativePathNT from to) where
 318   pretty = showFilePath . getSymbolicPath . getRelativePathNT
 319
 320 -------------------------------------------------------------------------------
 321 -- SpecVersion
 322 -------------------------------------------------------------------------------
 323
 324 -- | Version range or just version, i.e. @cabal-version@ field.
 325 --
 326 -- There are few things to consider:
 327 --
 328 -- * Starting with 2.2 the cabal-version field should be the first field in the
 329 --   file and only exact version is accepted. Therefore if we get e.g.
 330 --   @>= 2.2@, we fail.
 331 --   See <https://github.com/haskell/cabal/issues/4899>
 332 --
 333 -- We have this newtype, as writing Parsec and Pretty instances
 334 -- for CabalSpecVersion would cause cycle in modules:
 335 --     Version -> CabalSpecVersion -> Parsec -> ...
 336 newtype SpecVersion = SpecVersion {getSpecVersion :: CabalSpecVersion}
 337   deriving (Eq, Show) -- instances needed for tests
 338
 339 instance Newtype CabalSpecVersion SpecVersion
 340
 341 instance Parsec SpecVersion where
 342   parsec = do
 343     e <- parsecSpecVersion
 344     let ver :: Version
 345         ver = either id specVersionFromRange e
 346
 347         digits :: [Int]
 348         digits = versionNumbers ver
 349
 350     case cabalSpecFromVersionDigits digits of
 351       Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver
 352       Just csv -> do
 353         -- Check some warnings:
 354         case e of
 355           -- example:   cabal-version: 1.10
 356           -- should be  cabal-version: >=1.10
 357           Left _v
 358             | csv < CabalSpecV1_12 ->
 359                 parsecWarning PWTSpecVersion $
 360                   concat
 361                     [ "With 1.10 or earlier, the 'cabal-version' field must use "
 362                     , "range syntax rather than a simple version number. Use "
 363                     , "'cabal-version: >= " ++ prettyShow ver ++ "'."
 364                     ]
 365           -- example:   cabal-version: >=1.12
 366           -- should be  cabal-version: 1.12
 367           Right _vr
 368             | csv >= CabalSpecV1_12 ->
 369                 parsecWarning PWTSpecVersion $
 370                   concat
 371                     [ "Packages with 'cabal-version: 1.12' or later should specify a "
 372                     , "specific version of the Cabal spec of the form "
 373                     , "'cabal-version: x.y'. "
 374                     , "Use 'cabal-version: " ++ prettyShow ver ++ "'."
 375                     ]
 376           -- example:   cabal-version: >=1.10 && <1.12
 377           -- should be  cabal-version: >=1.10
 378           Right vr
 379             | csv < CabalSpecV1_12
 380             , not (simpleSpecVersionRangeSyntax vr) ->
 381                 parsecWarning PWTSpecVersion $
 382                   concat
 383                     [ "It is recommended that the 'cabal-version' field only specify a "
 384                     , "version range of the form '>= x.y' for older cabal versions. Use "
 385                     , "'cabal-version: >= " ++ prettyShow ver ++ "'. "
 386                     , "Tools based on Cabal 1.10 and later will ignore upper bounds."
 387                     ]
 388           -- otherwise no warnings
 389           _ -> pure ()
 390
 391         return (pack csv)
 392     where
 393       parsecSpecVersion = Left <$> parsec <|> Right <$> range
 394
 395       range = do
 396         vr <- parsec
 397         if specVersionFromRange vr >= mkVersion [2, 1]
 398           then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899"
 399           else return vr
 400
 401       specVersionFromRange :: VersionRange -> Version
 402       specVersionFromRange versionRange = case asVersionIntervals versionRange of
 403         [] -> version0
 404         VersionInterval (LowerBound version _) _ : _ -> version
 405
 406       simpleSpecVersionRangeSyntax = cataVersionRange alg
 407         where
 408           alg (OrLaterVersionF _) = True
 409           alg _ = False
 410
 411 instance Pretty SpecVersion where
 412   pretty (SpecVersion csv)
 413     | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv)
 414     | otherwise = text ">=" <<>> text (showCabalSpecVersion csv)
 415
 416 -------------------------------------------------------------------------------
 417 -- SpecLicense
 418 -------------------------------------------------------------------------------
 419
 420 -- | SPDX License expression or legacy license
 421 newtype SpecLicense = SpecLicense {getSpecLicense :: Either SPDX.License License}
 422   deriving (Show, Eq)
 423
 424 instance Newtype (Either SPDX.License License) SpecLicense
 425
 426 instance Parsec SpecLicense where
 427   parsec = do
 428     v <- askCabalSpecVersion
 429     if v >= CabalSpecV2_2
 430       then SpecLicense . Left <$> parsec
 431       else SpecLicense . Right <$> parsec
 432
 433 instance Pretty SpecLicense where
 434   pretty = either pretty pretty . unpack
 435
 436 -------------------------------------------------------------------------------
 437 -- TestedWith
 438 -------------------------------------------------------------------------------
 439
 440 -- | Version range or just version
 441 newtype TestedWith = TestedWith {getTestedWith :: (CompilerFlavor, VersionRange)}
 442
 443 instance Newtype (CompilerFlavor, VersionRange) TestedWith
 444
 445 instance Parsec TestedWith where
 446   parsec = pack <$> parsecTestedWith
 447
 448 instance Pretty TestedWith where
 449   pretty x = case unpack x of
 450     (compiler, vr) -> pretty compiler <+> pretty vr
 451
 452 parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange)
 453 parsecTestedWith = do
 454   name <- lexemeParsec
 455   ver <- parsec <|> pure anyVersion
 456   return (name, ver)