1{-# LANGUAGE FlexibleContexts #-} 2{-# LANGUAGE FlexibleInstances #-} 3{-# LANGUAGE FunctionalDependencies #-} 4{-# LANGUAGE OverloadedStrings #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE ScopedTypeVariables #-} 7-- | This module provides @newtype@ wrappers to be used with "Distribution.FieldGrammar". 8module Distribution.FieldGrammar.Newtypes ( 9 -- * List 10 alaList, 11 alaList', 12 -- ** Modifiers 13 CommaVCat (..), 14 CommaFSep (..), 15 VCat (..), 16 FSep (..), 17 NoCommaFSep (..), 18 Sep (..), 19 -- ** Type 20 List, 21 -- * Set 22 alaSet, 23 alaSet', 24 Set', 25 -- * Version & License 26 SpecVersion (..), 27 TestedWith (..), 28 SpecLicense (..), 29 -- * Identifiers 30 Token (..), 31 Token' (..), 32 MQuoted (..), 33 FilePathNT (..), 34 ) where 35 36import Distribution.Compat.Newtype 37import Distribution.Compat.Prelude 38import Prelude () 39 40import Distribution.CabalSpecVersion 41import Distribution.Compiler (CompilerFlavor) 42import Distribution.License (License) 43import Distribution.Parsec 44import Distribution.Pretty 45import Distribution.Version 46 (LowerBound (..), Version, VersionRange, VersionRangeF (..), anyVersion, asVersionIntervals, cataVersionRange, mkVersion, version0, versionNumbers) 47import Text.PrettyPrint (Doc, comma, fsep, punctuate, text, vcat) 48 49import qualified Data.Set as Set 50import qualified Distribution.Compat.CharParsing as P 51import qualified Distribution.SPDX as SPDX 52 53-- | Vertical list with commas. Displayed with 'vcat' 54data CommaVCat = CommaVCat 55 56-- | Paragraph fill list with commas. Displayed with 'fsep' 57data CommaFSep = CommaFSep 58 59-- | Vertical list with optional commas. Displayed with 'vcat'. 60data VCat = VCat 61 62-- | Paragraph fill list with optional commas. Displayed with 'fsep'. 63data FSep = FSep 64 65-- | Paragraph fill list without commas. Displayed with 'fsep'. 66data NoCommaFSep = NoCommaFSep 67 68class Sep sep where 69 prettySep :: Proxy sep -> [Doc] -> Doc 70 71 parseSep :: CabalParsing m => Proxy sep -> m a -> m [a] 72 73instance Sep CommaVCat where 74 prettySep _ = vcat . punctuate comma 75 parseSep _ p = do 76 v <- askCabalSpecVersion 77 if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p 78instance Sep CommaFSep where 79 prettySep _ = fsep . punctuate comma 80 parseSep _ p = do 81 v <- askCabalSpecVersion 82 if v >= CabalSpecV2_2 then parsecLeadingCommaList p else parsecCommaList p 83instance Sep VCat where 84 prettySep _ = vcat 85 parseSep _ p = do 86 v <- askCabalSpecVersion 87 if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p 88instance Sep FSep where 89 prettySep _ = fsep 90 parseSep _ p = do 91 v <- askCabalSpecVersion 92 if v >= CabalSpecV3_0 then parsecLeadingOptCommaList p else parsecOptCommaList p 93instance Sep NoCommaFSep where 94 prettySep _ = fsep 95 parseSep _ p = many (p <* P.spaces) 96 97-- | List separated with optional commas. Displayed with @sep@, arguments of 98-- type @a@ are parsed and pretty-printed as @b@. 99newtype List sep b a = List { _getList :: [a] } 100 101-- | 'alaList' and 'alaList'' are simply 'List', with additional phantom 102-- arguments to constraint the resulting type 103-- 104-- >>> :t alaList VCat 105-- alaList VCat :: [a] -> List VCat (Identity a) a 106-- 107-- >>> :t alaList' FSep Token 108-- alaList' FSep Token :: [String] -> List FSep Token String 109-- 110alaList :: sep -> [a] -> List sep (Identity a) a 111alaList _ = List 112 113-- | More general version of 'alaList'. 114alaList' :: sep -> (a -> b) -> [a] -> List sep b a 115alaList' _ _ = List 116 117instance Newtype [a] (List sep wrapper a) 118 119instance (Newtype a b, Sep sep, Parsec b) => Parsec (List sep b a) where 120 parsec = pack . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec 121 122instance (Newtype a b, Sep sep, Pretty b) => Pretty (List sep b a) where 123 pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . unpack 124 125-- 126-- | Like 'List', but for 'Set'. 127-- 128-- @since 3.2.0.0 129newtype Set' sep b a = Set' { _getSet :: Set a } 130 131-- | 'alaSet' and 'alaSet'' are simply 'Set'' constructor, with additional phantom 132-- arguments to constraint the resulting type 133-- 134-- >>> :t alaSet VCat 135-- alaSet VCat :: Set a -> Set' VCat (Identity a) a 136-- 137-- >>> :t alaSet' FSep Token 138-- alaSet' FSep Token :: Set String -> Set' FSep Token String 139-- 140-- >>> unpack' (alaSet' FSep Token) <$> eitherParsec "foo bar foo" 141-- Right (fromList ["bar","foo"]) 142-- 143-- @since 3.2.0.0 144alaSet :: sep -> Set a -> Set' sep (Identity a) a 145alaSet _ = Set' 146 147-- | More general version of 'alaSet'. 148-- 149-- @since 3.2.0.0 150alaSet' :: sep -> (a -> b) -> Set a -> Set' sep b a 151alaSet' _ _ = Set' 152 153instance Newtype (Set a) (Set' sep wrapper a) 154 155instance (Newtype a b, Ord a, Sep sep, Parsec b) => Parsec (Set' sep b a) where 156 parsec = pack . Set.fromList . map (unpack :: b -> a) <$> parseSep (Proxy :: Proxy sep) parsec 157 158instance (Newtype a b, Sep sep, Pretty b) => Pretty (Set' sep b a) where 159 pretty = prettySep (Proxy :: Proxy sep) . map (pretty . (pack :: a -> b)) . Set.toList . unpack 160 161------------------------------------------------------------------------------- 162-- Identifiers 163------------------------------------------------------------------------------- 164 165-- | Haskell string or @[^ ,]+@ 166newtype Token = Token { getToken :: String } 167 168instance Newtype String Token 169 170instance Parsec Token where 171 parsec = pack <$> parsecToken 172 173instance Pretty Token where 174 pretty = showToken . unpack 175 176-- | Haskell string or @[^ ]+@ 177newtype Token' = Token' { getToken' :: String } 178 179instance Newtype String Token' 180 181instance Parsec Token' where 182 parsec = pack <$> parsecToken' 183 184instance Pretty Token' where 185 pretty = showToken . unpack 186 187-- | Either @"quoted"@ or @un-quoted@. 188newtype MQuoted a = MQuoted { getMQuoted :: a } 189 190instance Newtype a (MQuoted a) 191 192instance Parsec a => Parsec (MQuoted a) where 193 parsec = pack <$> parsecMaybeQuoted parsec 194 195instance Pretty a => Pretty (MQuoted a) where 196 pretty = pretty . unpack 197 198-- | Filepath are parsed as 'Token'. 199newtype FilePathNT = FilePathNT { getFilePathNT :: String } 200 201instance Newtype String FilePathNT 202 203instance Parsec FilePathNT where 204 parsec = pack <$> parsecToken 205 206instance Pretty FilePathNT where 207 pretty = showFilePath . unpack 208 209------------------------------------------------------------------------------- 210-- SpecVersion 211------------------------------------------------------------------------------- 212 213-- | Version range or just version, i.e. @cabal-version@ field. 214-- 215-- There are few things to consider: 216-- 217-- * Starting with 2.2 the cabal-version field should be the first field in the 218-- file and only exact version is accepted. Therefore if we get e.g. 219-- @>= 2.2@, we fail. 220-- See <https://github.com/haskell/cabal/issues/4899> 221-- 222-- We have this newtype, as writing Parsec and Pretty instances 223-- for CabalSpecVersion would cause cycle in modules: 224-- Version -> CabalSpecVersion -> Parsec -> ... 225-- 226newtype SpecVersion = SpecVersion { getSpecVersion :: CabalSpecVersion } 227 deriving (Eq, Show) -- instances needed for tests 228 229instance Newtype CabalSpecVersion SpecVersion 230 231instance Parsec SpecVersion where 232 parsec = do 233 e <- parsecSpecVersion 234 let ver :: Version 235 ver = either id specVersionFromRange e 236 237 digits :: [Int] 238 digits = versionNumbers ver 239 240 case cabalSpecFromVersionDigits digits of 241 Nothing -> fail $ "Unknown cabal spec version specified: " ++ prettyShow ver 242 Just csv -> do 243 -- Check some warnings: 244 case e of 245 -- example: cabal-version: 1.10 246 -- should be cabal-version: >=1.10 247 Left _v | csv < CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat 248 [ "With 1.10 or earlier, the 'cabal-version' field must use " 249 , "range syntax rather than a simple version number. Use " 250 , "'cabal-version: >= " ++ prettyShow ver ++ "'." 251 ] 252 253 -- example: cabal-version: >=1.12 254 -- should be cabal-version: 1.12 255 Right _vr | csv >= CabalSpecV1_12 -> parsecWarning PWTSpecVersion $ concat 256 [ "Packages with 'cabal-version: 1.12' or later should specify a " 257 , "specific version of the Cabal spec of the form " 258 , "'cabal-version: x.y'. " 259 , "Use 'cabal-version: " ++ prettyShow ver ++ "'." 260 ] 261 262 -- example: cabal-version: >=1.10 && <1.12 263 -- should be cabal-version: >=1.10 264 Right vr | csv < CabalSpecV1_12 265 , not (simpleSpecVersionRangeSyntax vr) -> parsecWarning PWTSpecVersion $ concat 266 [ "It is recommended that the 'cabal-version' field only specify a " 267 , "version range of the form '>= x.y' for older cabal versions. Use " 268 , "'cabal-version: >= " ++ prettyShow ver ++ "'. " 269 , "Tools based on Cabal 1.10 and later will ignore upper bounds." 270 ] 271 272 -- otherwise no warnings 273 _ -> pure () 274 275 return (pack csv) 276 where 277 parsecSpecVersion = Left <$> parsec <|> Right <$> range 278 279 range = do 280 vr <- parsec 281 if specVersionFromRange vr >= mkVersion [2,1] 282 then fail "cabal-version higher than 2.2 cannot be specified as a range. See https://github.com/haskell/cabal/issues/4899" 283 else return vr 284 285 specVersionFromRange :: VersionRange -> Version 286 specVersionFromRange versionRange = case asVersionIntervals versionRange of 287 [] -> version0 288 ((LowerBound version _, _):_) -> version 289 290 simpleSpecVersionRangeSyntax = cataVersionRange alg where 291 alg (OrLaterVersionF _) = True 292 alg _ = False 293 294 295instance Pretty SpecVersion where 296 pretty (SpecVersion csv) 297 | csv >= CabalSpecV1_12 = text (showCabalSpecVersion csv) 298 | otherwise = text ">=" <<>> text (showCabalSpecVersion csv) 299 300------------------------------------------------------------------------------- 301-- SpecLicense 302------------------------------------------------------------------------------- 303 304-- | SPDX License expression or legacy license 305newtype SpecLicense = SpecLicense { getSpecLicense :: Either SPDX.License License } 306 307instance Newtype (Either SPDX.License License) SpecLicense 308 309instance Parsec SpecLicense where 310 parsec = do 311 v <- askCabalSpecVersion 312 if v >= CabalSpecV2_2 313 then SpecLicense . Left <$> parsec 314 else SpecLicense . Right <$> parsec 315 316instance Pretty SpecLicense where 317 pretty = either pretty pretty . unpack 318 319------------------------------------------------------------------------------- 320-- TestedWith 321------------------------------------------------------------------------------- 322 323-- | Version range or just version 324newtype TestedWith = TestedWith { getTestedWith :: (CompilerFlavor, VersionRange) } 325 326instance Newtype (CompilerFlavor, VersionRange) TestedWith 327 328instance Parsec TestedWith where 329 parsec = pack <$> parsecTestedWith 330 331instance Pretty TestedWith where 332 pretty x = case unpack x of 333 (compiler, vr) -> pretty compiler <+> pretty vr 334 335parsecTestedWith :: CabalParsing m => m (CompilerFlavor, VersionRange) 336parsecTestedWith = do 337 name <- lexemeParsec 338 ver <- parsec <|> pure anyVersion 339 return (name, ver) 340