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