{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
-- Module      : Data.SemVer.Constraint
-- Copyright   : (c) 2020 Brendan Hay <brendan.g.hay@gmail.com>, Keagan McClelland <keagan.mcclelland@gmail.com>
-- License     : This Source Code Form is subject to the terms of
--               the Mozilla Public License, v. 2.0.
--               A copy of the MPL can be found in the LICENSE file or
--               you can obtain it at http://mozilla.org/MPL/2.0/.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)

-- | An implementation of the Semantic Versioning Constraints.
-- In absence of a standard around constraints, the behavior of node-semver is closely followed.
-- The behavior is outlined here: https://github.com/npm/node-semver#ranges
module Data.SemVer.Constraint
    ( Constraint(..)
    , satisfies
    , fromText
    )
where

import           Control.Applicative
import           Data.Attoparsec.Text
import           Data.Monoid           ((<>))
import           Data.SemVer.Internal
import qualified Data.SemVer.Delimited as DL
import           Data.Text             (Text)

data Constraint
    = CAny
    | CLt !Version
    | CLtEq !Version
    | CGt !Version
    | CGtEq !Version
    | CEq !Version
    | CAnd !Constraint !Constraint
    | COr !Constraint !Constraint
    deriving (Constraint -> Constraint -> Bool
(Constraint -> Constraint -> Bool)
-> (Constraint -> Constraint -> Bool) -> Eq Constraint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Constraint -> Constraint -> Bool
$c/= :: Constraint -> Constraint -> Bool
== :: Constraint -> Constraint -> Bool
$c== :: Constraint -> Constraint -> Bool
Eq, Int -> Constraint -> ShowS
[Constraint] -> ShowS
Constraint -> String
(Int -> Constraint -> ShowS)
-> (Constraint -> String)
-> ([Constraint] -> ShowS)
-> Show Constraint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Constraint] -> ShowS
$cshowList :: [Constraint] -> ShowS
show :: Constraint -> String
$cshow :: Constraint -> String
showsPrec :: Int -> Constraint -> ShowS
$cshowsPrec :: Int -> Constraint -> ShowS
Show)

-- | Checks whether the 'Version' satisfies the 'Constraint'
--
-- Note: Semantics of this are strange in the presence of pre-release identifiers. Without a proper standard for how
-- constraint satisfaction should behave, this implementation attempts to follow the behavior of node-semver
-- which can be found here: https://github.com/npm/node-semver#prerelease-tags.
--
-- This choice was made because node-semver is the most widely deployed implementation of semantic versioning with
-- the best documentation around how to treat pre-release identifiers.
--
-- The summary is that you must opt into using pre-release identifiers by specifying them in the constraint
-- and they __must__ match the __exact__ version that attempts to use a pre-release identifier.
satisfies :: Version -> Constraint -> Bool
satisfies :: Version -> Constraint -> Bool
satisfies Version
version Constraint
constraint = if Version -> Bool
containsPrerelease Version
version
    then if Bool -> Bool
not (Bool -> Bool)
-> ([(Version -> Constraint, Version)] -> Bool)
-> [(Version -> Constraint, Version)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Version -> Constraint, Version)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([(Version -> Constraint, Version)] -> Bool)
-> ([(Version -> Constraint, Version)]
    -> [(Version -> Constraint, Version)])
-> [(Version -> Constraint, Version)]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Version -> Constraint, Version) -> Bool)
-> [(Version -> Constraint, Version)]
-> [(Version -> Constraint, Version)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Version -> (Int, Int, Int)
triple Version
version (Int, Int, Int) -> (Int, Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
==) ((Int, Int, Int) -> Bool)
-> ((Version -> Constraint, Version) -> (Int, Int, Int))
-> (Version -> Constraint, Version)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> (Int, Int, Int)
triple (Version -> (Int, Int, Int))
-> ((Version -> Constraint, Version) -> Version)
-> (Version -> Constraint, Version)
-> (Int, Int, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Version -> Constraint, Version) -> Version
forall a b. (a, b) -> b
snd) ([(Version -> Constraint, Version)] -> Bool)
-> [(Version -> Constraint, Version)] -> Bool
forall a b. (a -> b) -> a -> b
$ (Constraint -> [(Version -> Constraint, Version)]
prereleaseComparators Constraint
constraint)
        then Version -> Constraint -> Bool
go Version
version Constraint
constraint
        else if Constraint
constraint Constraint -> Constraint -> Bool
forall a. Eq a => a -> a -> Bool
== Constraint
CAny then Bool
True else Bool
False
    else Version -> Constraint -> Bool
go Version
version Constraint
constraint
  where
    triple :: Version -> (Int, Int, Int)
    triple :: Version -> (Int, Int, Int)
triple = (Int -> Int -> Int -> (Int, Int, Int))
-> (Version -> Int)
-> (Version -> Int)
-> (Version -> Int)
-> Version
-> (Int, Int, Int)
forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 (,,) Version -> Int
_versionMajor Version -> Int
_versionMinor Version -> Int
_versionPatch
    containsPrerelease :: Version -> Bool
    containsPrerelease :: Version -> Bool
containsPrerelease Version
v = Bool -> Bool
not (Bool -> Bool) -> (Version -> Bool) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Identifier] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Identifier] -> Bool)
-> (Version -> [Identifier]) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Identifier]
_versionRelease (Version -> Bool) -> Version -> Bool
forall a b. (a -> b) -> a -> b
$ Version
v
    -- this helps us gather the comparators that actually consented to prerelease versions
    prereleaseComparators :: Constraint -> [(Version -> Constraint, Version)]
    prereleaseComparators :: Constraint -> [(Version -> Constraint, Version)]
prereleaseComparators = \case
        Constraint
CAny     -> []
        CLt   Version
v  -> if Version -> Bool
containsPrerelease Version
v then [(Version -> Constraint
CLt, Version
v)] else []
        CLtEq Version
v  -> if Version -> Bool
containsPrerelease Version
v then [(Version -> Constraint
CLtEq, Version
v)] else []
        CGt   Version
v  -> if Version -> Bool
containsPrerelease Version
v then [(Version -> Constraint
CGt, Version
v)] else []
        CGtEq Version
v  -> if Version -> Bool
containsPrerelease Version
v then [(Version -> Constraint
CGtEq, Version
v)] else []
        CEq   Version
v  -> if Version -> Bool
containsPrerelease Version
v then [(Version -> Constraint
CEq, Version
v)] else []
        CAnd Constraint
a Constraint
b -> Constraint -> [(Version -> Constraint, Version)]
prereleaseComparators Constraint
a [(Version -> Constraint, Version)]
-> [(Version -> Constraint, Version)]
-> [(Version -> Constraint, Version)]
forall a. Semigroup a => a -> a -> a
<> Constraint -> [(Version -> Constraint, Version)]
prereleaseComparators Constraint
b
        COr  Constraint
a Constraint
b -> Constraint -> [(Version -> Constraint, Version)]
prereleaseComparators Constraint
a [(Version -> Constraint, Version)]
-> [(Version -> Constraint, Version)]
-> [(Version -> Constraint, Version)]
forall a. Semigroup a => a -> a -> a
<> Constraint -> [(Version -> Constraint, Version)]
prereleaseComparators Constraint
b
    -- naive satisfaction checking
    go :: Version -> Constraint -> Bool
    go :: Version -> Constraint -> Bool
go Version
v Constraint
c = case Constraint
c of
        Constraint
CAny     -> Bool
True
        CLt   Version
vc -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< Version
vc
        CLtEq Version
vc -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
<= Version
vc
        CGt   Version
vc -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
> Version
vc
        CGtEq Version
vc -> Version
v Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
vc
        CEq   Version
vc -> Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
vc
        CAnd Constraint
a Constraint
b -> Version -> Constraint -> Bool
go Version
v Constraint
a Bool -> Bool -> Bool
&& Version -> Constraint -> Bool
go Version
v Constraint
b
        COr  Constraint
a Constraint
b -> Version -> Constraint -> Bool
go Version
v Constraint
a Bool -> Bool -> Bool
|| Version -> Constraint -> Bool
go Version
v Constraint
b

-- | Parsing function to create a 'Constraint' from 'Text' according to the rules specified
-- here: https://github.com/npm/node-semver#ranges
--
-- Advanced syntax is not yet supported.
fromText :: Text -> Either String Constraint
fromText :: Text -> Either String Constraint
fromText = Parser Constraint -> Text -> Either String Constraint
forall a. Parser a -> Text -> Either String a
parseOnly Parser Constraint
parser

parser :: Parser Constraint
parser :: Parser Constraint
parser = Delimiters -> Parser Constraint
parserD Delimiters
DL.semantic

parserD :: Delimiters -> Parser Constraint
parserD :: Delimiters -> Parser Constraint
parserD d :: Delimiters
d@Delimiters {Char
_delimIdent :: Delimiters -> Char
_delimMeta :: Delimiters -> Char
_delimRelease :: Delimiters -> Char
_delimPatch :: Delimiters -> Char
_delimMinor :: Delimiters -> Char
_delimIdent :: Char
_delimMeta :: Char
_delimRelease :: Char
_delimPatch :: Char
_delimMinor :: Char
..} = [Parser Constraint] -> Parser Constraint
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice ([Parser Constraint] -> Parser Constraint)
-> ([Parser Constraint] -> [Parser Constraint])
-> [Parser Constraint]
-> Parser Constraint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Parser Constraint -> Parser Constraint)
-> [Parser Constraint] -> [Parser Constraint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Parser Constraint -> Parser Text () -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput) ([Parser Constraint] -> Parser Constraint)
-> [Parser Constraint] -> Parser Constraint
forall a b. (a -> b) -> a -> b
$ [Parser Constraint
primP, Parser Constraint
andP, Parser Constraint
orP]
  where
    primP :: Parser Constraint
primP = [Parser Constraint] -> Parser Constraint
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
        [ Char -> Parser Char
char Char
'*' Parser Char -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Constraint -> Parser Constraint
forall (f :: * -> *) a. Applicative f => a -> f a
pure Constraint
CAny
        , Char -> Parser Char
char Char
'<' Parser Char -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Version -> Constraint
CLt (Version -> Constraint) -> Parser Text Version -> Parser Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delimiters -> Bool -> Parser Text Version
DL.parser Delimiters
d Bool
False)
        , Text -> Parser Text
string Text
"<=" Parser Text -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Version -> Constraint
CLtEq (Version -> Constraint) -> Parser Text Version -> Parser Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delimiters -> Bool -> Parser Text Version
DL.parser Delimiters
d Bool
False)
        , Char -> Parser Char
char Char
'>' Parser Char -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Version -> Constraint
CGt (Version -> Constraint) -> Parser Text Version -> Parser Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delimiters -> Bool -> Parser Text Version
DL.parser Delimiters
d Bool
False)
        , Text -> Parser Text
string Text
">=" Parser Text -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Version -> Constraint
CGtEq (Version -> Constraint) -> Parser Text Version -> Parser Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Delimiters -> Bool -> Parser Text Version
DL.parser Delimiters
d Bool
False)
        , Version -> Constraint
CEq (Version -> Constraint) -> Parser Text Version -> Parser Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Char
'=' (Parser Char -> Parser Char) -> Parser Char -> Parser Char
forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
'=') Parser Char -> Parser Text Version -> Parser Text Version
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Delimiters -> Bool -> Parser Text Version
DL.parser Delimiters
d Bool
False)
        ]
    andP :: Parser Constraint
andP = (Constraint -> Constraint -> Constraint)
-> Parser Constraint -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Constraint -> Constraint -> Constraint
CAnd Parser Constraint
primP (Parser Text ()
skipSpace Parser Text () -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Constraint
andP Parser Constraint -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Constraint
primP))
    orP :: Parser Constraint
orP = (Constraint -> Constraint -> Constraint)
-> Parser Constraint -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Constraint -> Constraint -> Constraint
COr (Parser Constraint
andP Parser Constraint -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Constraint
primP) (Parser Text ()
skipSpace Parser Text () -> Parser Text -> Parser Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text
string Text
"||" Parser Text -> Parser Text () -> Parser Text ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text ()
skipSpace Parser Text () -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Parser Constraint
orP Parser Constraint -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Constraint
andP Parser Constraint -> Parser Constraint -> Parser Constraint
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Constraint
primP))