Distribution/Types/PkgconfigVersionRange.hs

    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE DeriveGeneric      #-}
    module Distribution.Types.PkgconfigVersionRange (
        PkgconfigVersionRange (..),
        anyPkgconfigVersion,
        isAnyPkgconfigVersion,
        withinPkgconfigVersionRange,
        -- * Internal
        versionToPkgconfigVersion,
        versionRangeToPkgconfigVersionRange,
        ) where

    import Distribution.Compat.Prelude
    import Prelude ()

    import Distribution.CabalSpecVersion
    import Distribution.Parsec
    import Distribution.Pretty
    import Distribution.Types.PkgconfigVersion
    import Distribution.Types.Version
    import Distribution.Types.VersionInterval
    import Distribution.Types.VersionRange

    import qualified Data.ByteString.Char8           as BS8
    import qualified Distribution.Compat.CharParsing as P
    import qualified Text.PrettyPrint                as PP

    -- | @since 3.0
    data PkgconfigVersionRange
      = PcAnyVersion
      | PcThisVersion            PkgconfigVersion -- = version
      | PcLaterVersion           PkgconfigVersion -- > version  (NB. not >=)
      | PcEarlierVersion         PkgconfigVersion -- < version
      | PcOrLaterVersion         PkgconfigVersion -- >= version
      | PcOrEarlierVersion       PkgconfigVersion -- =< version
      | PcUnionVersionRanges     PkgconfigVersionRange PkgconfigVersionRange
      | PcIntersectVersionRanges PkgconfigVersionRange PkgconfigVersionRange
      deriving (Generic, Read, Show, Eq, Typeable, Data)

    instance Binary PkgconfigVersionRange
    instance Structured PkgconfigVersionRange
    instance NFData PkgconfigVersionRange where rnf = genericRnf

    instance Pretty PkgconfigVersionRange where
        pretty = pp 0  where
            pp :: Int -> PkgconfigVersionRange -> PP.Doc
            pp _ PcAnyVersion           = PP.text "-any"
            pp _ (PcThisVersion v)      = PP.text "==" <<>> pretty v
            pp _ (PcLaterVersion v)     = PP.text ">" <<>> pretty v
            pp _ (PcEarlierVersion v)   = PP.text "<" <<>> pretty v
            pp _ (PcOrLaterVersion v)   = PP.text ">=" <<>> pretty v
            pp _ (PcOrEarlierVersion v) = PP.text "<=" <<>> pretty v

            pp d (PcUnionVersionRanges v u) = parens (d >= 1) $
                pp 1 v PP.<+> PP.text "||" PP.<+> pp 0 u
            pp d (PcIntersectVersionRanges v u) = parens (d >= 2) $
                pp 2 v PP.<+> PP.text "&&" PP.<+> pp 1 u

            parens True  = PP.parens
            parens False = id

    instance Parsec PkgconfigVersionRange where
        -- note: the wildcard is used in some places, e.g
        -- http://hackage.haskell.org/package/bindings-libzip-0.10.1/bindings-libzip.cabal
        --
        -- however, in the presence of alphanumerics etc. lax version parser,
        -- wildcard is ill-specified

        parsec = do
            csv <- askCabalSpecVersion
            if csv >= CabalSpecV3_0
            then pkgconfigParser
            else versionRangeToPkgconfigVersionRange <$> versionRangeParser P.integral csv

    -- "modern" parser of @pkg-config@ package versions.
    pkgconfigParser :: CabalParsing m => m PkgconfigVersionRange
    pkgconfigParser = P.spaces >> expr where
        -- every parser here eats trailing space
        expr = do
            ts <- term `P.sepByNonEmpty` (P.string "||" >> P.spaces)
            return $ foldr1 PcUnionVersionRanges ts

        term = do
            fs <- factor `P.sepByNonEmpty` (P.string "&&" >> P.spaces)
            return $ foldr1 PcIntersectVersionRanges fs

        factor = parens expr <|> prim

        prim = do
            op <- P.munch1 isOpChar P.<?> "operator"
            case op of
                "-"  -> anyPkgconfigVersion <$ (P.string "any" *> P.spaces)

                "==" -> afterOp PcThisVersion
                ">"  -> afterOp PcLaterVersion
                "<"  -> afterOp PcEarlierVersion
                ">=" -> afterOp PcOrLaterVersion
                "<=" -> afterOp PcOrEarlierVersion

                _ -> P.unexpected $ "Unknown version operator " ++ show op

        -- https://gitlab.haskell.org/ghc/ghc/issues/17752
        isOpChar '<' = True
        isOpChar '=' = True
        isOpChar '>' = True
        isOpChar '^' = True
        isOpChar '-' = True
        isOpChar _   = False

        afterOp f = do
            P.spaces
            v <- parsec
            P.spaces
            return (f v)

        parens = P.between
            ((P.char '(' P.<?> "opening paren") >> P.spaces)
            (P.char ')' >> P.spaces)

    anyPkgconfigVersion :: PkgconfigVersionRange
    anyPkgconfigVersion = PcAnyVersion

    -- | TODO: this is not precise, but used only to prettify output.
    isAnyPkgconfigVersion :: PkgconfigVersionRange -> Bool
    isAnyPkgconfigVersion = (== PcAnyVersion)

    withinPkgconfigVersionRange :: PkgconfigVersion -> PkgconfigVersionRange -> Bool
    withinPkgconfigVersionRange v = go where
        go PcAnyVersion                   = True
        go (PcThisVersion u)              = v == u
        go (PcLaterVersion u)             = v > u
        go (PcEarlierVersion u)           = v < u
        go (PcOrLaterVersion u)           = v >= u
        go (PcOrEarlierVersion u)         = v <= u
        go (PcUnionVersionRanges a b)     = go a || go b
        go (PcIntersectVersionRanges a b) = go a && go b

    -------------------------------------------------------------------------------
    -- Conversion
    -------------------------------------------------------------------------------

    versionToPkgconfigVersion :: Version -> PkgconfigVersion
    versionToPkgconfigVersion = PkgconfigVersion . BS8.pack . prettyShow

    versionRangeToPkgconfigVersionRange :: VersionRange -> PkgconfigVersionRange
    versionRangeToPkgconfigVersionRange vr
        | isAnyVersion vr
        = PcAnyVersion
        | otherwise
        = case asVersionIntervals vr of
            []     -> PcEarlierVersion (PkgconfigVersion (BS8.pack "0"))
            (i:is) -> foldl (\r j -> PcUnionVersionRanges r (conv j)) (conv i) is
      where
        conv (LowerBound v b, NoUpperBound)   = convL v b
        conv (LowerBound v b, UpperBound u c) = PcIntersectVersionRanges (convL v b) (convU u c)

        convL v ExclusiveBound = PcLaterVersion (versionToPkgconfigVersion v)
        convL v InclusiveBound = PcOrLaterVersion (versionToPkgconfigVersion v)

        convU v ExclusiveBound = PcEarlierVersion (versionToPkgconfigVersion v)
        convU v InclusiveBound = PcOrEarlierVersion (versionToPkgconfigVersion v)