Version.hs

{-# LANGUAGE OverloadedStrings #-}
-- | Versions and version ranges. "Aihc.Cabal" exports the public part. The
-- parsers and the specification version helpers are for the other internal
-- modules.
module Aihc.Cabal.Internal.Version
  ( -- * Public
    Version, versionNumbers, mkVersion, parseVersion, renderVersion
  , VersionRange (..), anyVersion, noVersion, thisVersion, withinVersion, withinRange, intersectRanges
  , unionRanges, simplifyVersionRange, parseVersionRange, renderVersionRange
    -- * Internal
  , Parser, specVersion, latestSpec, versionParser, versionDigits, rangeParser
  ) where

import Control.Applicative ((<|>))
import Control.Monad (when)
import Data.Char (isAlphaNum, isDigit)
import Data.List (sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Text (Text)
import qualified Data.Text as T
import Data.Void (Void)
import Text.Megaparsec (Parsec, between, eof, errorBundlePretty, many, runParser, satisfy, sepBy1, some, takeWhile1P)
import Text.Megaparsec.Char (char, space, string)

-- | A version: one or more numbers that are not negative. Versions compare
-- as lists, so @1.2@ is before @1.2.0@.
newtype Version = Version (NonEmpty Integer) deriving (Eq, Ord, Show)

-- | A version range as a Cabal file gives it. The constructors are exported
-- so that the caller can examine, simplify, or show a range. Equality is
-- structural: a @^>=@ bound and its expanded intersection are different
-- values. Use 'withinRange' to test membership.
data VersionRange
  = AnyVersion
  -- ^ @-any@, or an absent range. The same set of versions as @>= 0@.
  | Equal Version
  -- ^ @== v@
  | Later Version
  -- ^ @> v@
  | Earlier Version
  -- ^ @< v@
  | AtLeast Version
  -- ^ @>= v@
  | AtMost Version
  -- ^ @<= v@
  | MajorBound Version
  -- ^ @^>= v@
  | Both VersionRange VersionRange
  -- ^ @a && b@
  | EitherRange VersionRange VersionRange
  -- ^ @a || b@
  deriving (Eq, Show)

type Parser = Parsec Void Text

-- | The numbers of a version.
versionNumbers :: Version -> NonEmpty Integer
versionNumbers (Version ns) = ns

-- | Make a version from its numbers. The result is 'Nothing' for an empty
-- list and for a negative number.
mkVersion :: [Integer] -> Maybe Version
mkVersion ns = case NE.nonEmpty ns of
  Just xs | all (>= 0) xs -> Just (Version xs)
  _ -> Nothing

-- | A known Cabal specification version, for example @specVersion [2, 2]@.
specVersion :: [Integer] -> Version
specVersion = Version . NE.fromList

-- | The newest Cabal specification version that the parser knows.
latestSpec :: Version
latestSpec = specVersion [3, 14]

-- | A version number part: at most nine digits and no leading zero.
versionDigits :: Parser Integer
versionDigits = do
  ds <- some (satisfy isDigit)
  case ds of
    "0" -> pure 0
    '0' : _ -> fail "Version digit with leading zero"
    _ | length ds > 9 -> fail "At most 9 numbers are allowed per version number part"
      | otherwise -> pure (read ds)

-- | A version with optional tags, for example @1.2.3-rc1@. The tags are not kept.
versionParser :: Parser Version
versionParser = Version . NE.fromList <$> versionDigits `sepBy1` char '.' <* tags

tags :: Parser ()
tags = () <$ many (char '-' *> some (satisfy isAlphaNum))

parseWith :: Parser a -> Text -> Either Text a
parseWith p input = case runParser (space *> p <* space <* eof) "" input of
  Left err -> Left (T.pack (errorBundlePretty err))
  Right value -> Right value

-- | Parse a version such as @9.12.2@. Spaces around the version are
-- permitted. Tags such as @-rc1@ are accepted and not kept.
parseVersion :: Text -> Either Text Version
parseVersion = parseWith versionParser

-- | Show a version with dots, as in @9.12.2@.
renderVersion :: Version -> Text
renderVersion (Version ns) = T.intercalate "." (map (T.pack . show) (NE.toList ns))

-- | The range of all versions.
anyVersion :: VersionRange
anyVersion = AnyVersion

-- | The empty range @-none@, as @< 0@.
noVersion :: VersionRange
noVersion = Earlier (Version (0 :| []))

-- | The range @== v@.
thisVersion :: Version -> VersionRange
thisVersion = Equal

-- | The range @a && b@ or @a || b@. The functions do not simplify. Use
-- 'simplifyVersionRange' for that.
intersectRanges, unionRanges :: VersionRange -> VersionRange -> VersionRange
intersectRanges = Both
unionRanges = EitherRange

-- | Test if a version is in a range.
withinRange :: Version -> VersionRange -> Bool
withinRange v range = case range of
  AnyVersion -> True
  Equal w -> v == w
  Later w -> v > w
  Earlier w -> v < w
  AtLeast w -> v >= w
  AtMost w -> v <= w
  MajorBound w -> v >= w && v < majorUpperBound w
  Both a b -> withinRange v a && withinRange v b
  EitherRange a b -> withinRange v a || withinRange v b

-- | Parse a version range as Cabal-syntax does for the given specification version.
-- Unparenthesized @&&@ and @||@ associate to the right.
rangeParser :: Version -> Parser VersionRange
rangeParser spec = expr
  where
    expr = do
      space
      t <- term
      space
      (EitherRange t <$> (string "||" *> space *> expr)) <|> pure t
    term = do
      f <- factor
      space
      (Both f <$> (string "&&" *> space *> term)) <|> pure f
    factor = parens <|> prim
    parens = between (char '(' *> space) (char ')' *> space) (expr <* space)
    prim = do
      op <- takeWhile1P (Just "operator") isOpChar
      case op of
        "-" -> AnyVersion <$ string "any" <|> (string "none" *> none)
        "==" -> space *> (wildOrVersion <|> (versionSet >>= set Equal))
        "^>=" -> space *> (major <|> (versionSet >>= set MajorBound))
        _ -> do
          space
          (wild, v) <- versionOrWild
          when wild (fail ("wild-card version after non-== operator: " ++ T.unpack op))
          case op of
            ">=" -> pure (AtLeast v)
            "<" -> pure (Earlier v)
            "<=" -> pure (AtMost v)
            ">" -> pure (Later v)
            _ -> fail ("Unknown version operator " ++ T.unpack op)
    isOpChar c = c `elem` ("<=>^" :: String) || (c == '-' && spec < specVersion [3, 4])
    none
      | spec >= specVersion [1, 22] = pure noVersion
      | otherwise = fail "-none version range used"
    wildOrVersion = do
      (wild, v) <- versionOrWild
      pure (if wild then withinVersion v else Equal v)
    major = do
      (wild, v) <- versionOrWild
      when wild (fail "wild-card version after ^>= operator")
      if spec >= specVersion [2, 0] then pure (MajorBound v)
        else fail "major bounded version syntax (caret, ^>=) used"
    set constructor vs
      | spec >= specVersion [3, 0] = pure (foldr1 EitherRange (fmap constructor vs))
      | otherwise = fail "version set syntax used"
    versionSet = do
      _ <- char '{' *> space
      v <- plain <* space
      vs <- many (char ',' *> space *> plain <* space)
      _ <- char '}'
      pure (v :| vs)
    plain = Version . NE.fromList <$> versionDigits `sepBy1` char '.'
    versionOrWild = versionDigits >>= loop . pure
    loop acc = (char '.' *> ((versionDigits >>= loop . (: acc)) <|> ((True, done acc) <$ char '*')))
      <|> ((False, done acc) <$ tags)
    done = Version . NE.fromList . reverse

-- | The range @== v.*@.
withinVersion :: Version -> VersionRange
withinVersion v = Both (AtLeast v) (Earlier (wildcardUpperBound v))
wildcardUpperBound :: Version -> Version
wildcardUpperBound (Version ns) = Version (NE.fromList (NE.init ns ++ [NE.last ns + 1]))

majorUpperBound :: Version -> Version
majorUpperBound (Version ns) = Version $ case ns of
  x :| [] -> x :| [1]
  x :| (y:_) -> x :| [y + 1]

-- | Parse a version range. The parser accepts the syntax of all Cabal
-- format versions: @-any@, @-none@, @^>=@, and version sets. Operators
-- without parentheses associate to the right, as in Cabal-syntax.
parseVersionRange :: Text -> Either Text VersionRange
parseVersionRange = parseWith (rangeParser (specVersion [3, 0]))

-- | Show a range in Cabal syntax, for example @>=1.2 && <1.3 || ==2.0@.
-- The text has parentheses only where the structure needs them. A @||@
-- operand of @&&@ gets parentheses. A left operand with the same operator
-- gets parentheses, so that 'parseVersionRange' gives the same value.
renderVersionRange :: VersionRange -> Text
renderVersionRange r = case r of
  AnyVersion -> "-any"
  Equal v -> "==" <> renderVersion v
  Later v -> ">" <> renderVersion v
  Earlier v -> "<" <> renderVersion v
  AtLeast v -> ">=" <> renderVersion v
  AtMost v -> "<=" <> renderVersion v
  MajorBound v -> "^>=" <> renderVersion v
  Both a b -> parens (isBoth a || isEither a) a <> " && " <> parens (isEither b) b
  EitherRange a b -> parens (isEither a) a <> " || " <> renderVersionRange b
  where
    parens needed x
      | needed = "(" <> renderVersionRange x <> ")"
      | otherwise = renderVersionRange x
    isBoth Both {} = True
    isBoth _ = False
    isEither EitherRange {} = True
    isEither _ = False

-- | The same set of versions as a union of separate intervals in increasing
-- order. An empty range gives 'noVersion'. A range of all versions gives
-- 'anyVersion'.
--
-- An interval becomes @==v@, a bound, or two bounds with @&&@. The bounds
-- keep their operators, so @>1@ stays @>1@. A @^>=@ bound and a @==v.*@ range
-- become two bounds. The unions associate to the right, as the parser reads
-- them.
--
-- Version @0@ is the smallest version, so a lower bound @>=0@ has no effect.
-- No version is between @v@ and @v.0@, so @>1 && <1.0@ is empty and
-- @>1 && <=1.0@ is @==1.0@.
simplifyVersionRange :: VersionRange -> VersionRange
simplifyVersionRange range = case map fromInterval (intervals range) of
  [] -> noVersion
  parts -> foldr1 EitherRange parts
  where
    fromInterval (Interval low high)
      | Just high' <- high, upperKey high' == successor (lowerKey low) = Equal (lowerKey low)
      | otherwise = case (lowerPart, upperPart) of
          (Nothing, Nothing) -> AnyVersion
          (Just a, Nothing) -> a
          (Nothing, Just b) -> b
          (Just a, Just b) -> Both a b
      where
        lowerPart
          | lowerKey low == zero = Nothing
          | otherwise = Just (let Bound v inclusive = low in if inclusive then AtLeast v else Later v)
        upperPart = fmap (\(Bound v inclusive) -> if inclusive then AtMost v else Earlier v) high

-- | A bound version, and whether the version itself is in the interval.
data Bound = Bound Version Bool

-- | An interval from a lower bound to an upper bound. 'Nothing' is no upper
-- bound.
data Interval = Interval Bound (Maybe Bound)

zero :: Version
zero = Version (0 :| [])

-- | The next version: no version is between @v@ and @v.0@.
successor :: Version -> Version
successor (Version ns) = Version (ns <> (0 :| []))

-- | The smallest version in the interval above a lower bound.
lowerKey :: Bound -> Version
lowerKey (Bound v inclusive) = if inclusive then v else successor v

-- | The smallest version above the interval below an upper bound.
upperKey :: Bound -> Version
upperKey (Bound v inclusive) = if inclusive then successor v else v

-- | Separate, nonempty intervals in increasing order.
intervals :: VersionRange -> [Interval]
intervals range = case range of
  AnyVersion -> [Interval (Bound zero True) Nothing]
  Equal v -> [Interval (Bound v True) (Just (Bound v True))]
  Later v -> [Interval (Bound v False) Nothing]
  Earlier v -> normalize [Interval (Bound zero True) (Just (Bound v False))]
  AtLeast v -> [Interval (Bound v True) Nothing]
  AtMost v -> [Interval (Bound zero True) (Just (Bound v True))]
  MajorBound v -> normalize [Interval (Bound v True) (Just (Bound (majorUpperBound v) False))]
  EitherRange a b -> normalize (intervals a ++ intervals b)
  Both a b -> normalize [intersect x y | x <- intervals a, y <- intervals b]
  where
    intersect (Interval low high) (Interval low' high') =
      Interval (if lowerKey low' > lowerKey low then low' else low) (minUpper high high')
    minUpper Nothing b = b
    minUpper a Nothing = a
    minUpper (Just a) (Just b) = Just (if upperKey b < upperKey a then b else a)

normalize :: [Interval] -> [Interval]
normalize = merge . sortOn (\(Interval low _) -> lowerKey low) . filter nonEmpty
  where
    nonEmpty (Interval _ Nothing) = True
    nonEmpty (Interval low (Just high)) = lowerKey low < upperKey high
    merge (Interval low high : Interval low' high' : rest)
      | touches high low' = merge (Interval low (maxUpper high high') : rest)
    merge (x : rest) = x : merge rest
    merge [] = []
    touches Nothing _ = True
    touches (Just high) low' = lowerKey low' <= upperKey high
    maxUpper Nothing _ = Nothing
    maxUpper _ Nothing = Nothing
    maxUpper (Just a) (Just b) = Just (if upperKey b > upperKey a then b else a)