{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans
                -fno-warn-incomplete-patterns
                -fno-warn-deprecations
                -fno-warn-unused-binds #-} --FIXME
module UnitTests.Distribution.Version (versionTests) where

import Distribution.Version
import Distribution.Text

import Text.PrettyPrint as Disp (text, render, parens, hcat
                                ,punctuate, int, char, (<>), (<+>))

import Test.Tasty
import Test.Tasty.QuickCheck
import qualified Test.Laws as Laws

import Test.QuickCheck.Utils

import Control.Monad (liftM, liftM2)
import Data.Maybe (isJust, fromJust)
import Data.List (sort, sortBy, nub)
import Data.Ord  (comparing)
import Data.Function (on)
#if MIN_VERSION_base(4,6,0)
import Text.Read (readMaybe)
#endif

versionTests :: [TestTree]
versionTests =
    -- test 'Version' type
    [ tp "versionNumbers . mkVersion = id @[NonNegative Int]"  prop_VersionId
    , tp "versionNumbers . mkVersion = id @Base.Version"       prop_VersionId2
    , tp "(==) = (==) `on` versionNumbers"                     prop_VersionEq
    , tp "(==) = (==) `on` mkVersion"                          prop_VersionEq2
    , tp "compare = compare `on` versionNumbers"               prop_VersionOrd
    , tp "compare = compare `on` mkVersion"                    prop_VersionOrd2

    , tp "readMaybe . show = Just"                             prop_ShowRead
    , tp "read example"                                        prop_ShowRead_example
    ]

    ++ 
    zipWith (\n p -> testProperty ("Range Property " ++ show n) p) [1::Int ..]
      -- properties to validate the test framework
    [ property prop_nonNull
    , property prop_gen_intervals1
    , property prop_gen_intervals2
  --, property prop_equivalentVersionRange --FIXME: runs out of test cases
    , property prop_intermediateVersion

    , property prop_anyVersion
    , property prop_noVersion
    , property prop_thisVersion
    , property prop_notThisVersion
    , property prop_laterVersion
    , property prop_orLaterVersion
    , property prop_earlierVersion
    , property prop_orEarlierVersion
    , property prop_unionVersionRanges
    , property prop_intersectVersionRanges
    , property prop_differenceVersionRanges
    , property prop_invertVersionRange
    , property prop_withinVersion
    , property prop_foldVersionRange
    , property prop_foldVersionRange'

      -- the semantic query functions
  --, property prop_isAnyVersion1       --FIXME: runs out of test cases
  --, property prop_isAnyVersion2       --FIXME: runs out of test cases
  --, property prop_isNoVersion         --FIXME: runs out of test cases
  --, property prop_isSpecificVersion1  --FIXME: runs out of test cases
  --, property prop_isSpecificVersion2  --FIXME: runs out of test cases
    , property prop_simplifyVersionRange1
    , property prop_simplifyVersionRange1'
  --, property prop_simplifyVersionRange2   --FIXME: runs out of test cases
  --, property prop_simplifyVersionRange2'  --FIXME: runs out of test cases
  --, property prop_simplifyVersionRange2'' --FIXME: actually wrong

      -- converting between version ranges and version intervals
    , property prop_to_intervals
  --, property prop_to_intervals_canonical  --FIXME: runs out of test cases
  --, property prop_to_intervals_canonical' --FIXME: runs out of test cases
    , property prop_from_intervals
    , property prop_to_from_intervals
    , property prop_from_to_intervals
    , property prop_from_to_intervals'

      -- union and intersection of version intervals
    , property prop_unionVersionIntervals
    , property prop_unionVersionIntervals_idempotent
    , property prop_unionVersionIntervals_commutative
    , property prop_unionVersionIntervals_associative
    , property prop_intersectVersionIntervals
    , property prop_intersectVersionIntervals_idempotent
    , property prop_intersectVersionIntervals_commutative
    , property prop_intersectVersionIntervals_associative
    , property prop_union_intersect_distributive
    , property prop_intersect_union_distributive

      -- inversion of version intervals
    , property prop_invertVersionIntervals
    , property prop_invertVersionIntervalsTwice
    ]
  where
    tp :: Testable p => String -> p -> TestTree
    tp = testProperty

-- parseTests :: [TestTree]
-- parseTests =
--   zipWith (\n p -> testProperty ("Parse Property " ++ show n) p) [1::Int ..]
--    -- parsing and pretty printing
--   [ -- property prop_parse_disp1  --FIXME: actually wrong

--     --  These are also wrong, see
--     --  https://github.com/haskell/cabal/issues/3037#issuecomment-177671011

--     --   property prop_parse_disp2
--     -- , property prop_parse_disp3
--     -- , property prop_parse_disp4
--     -- , property prop_parse_disp5
--   ]

instance Arbitrary Version where
  arbitrary = do
      branch <- smallListOf1 $
                  frequency [(3, return 0)
                            ,(3, return 1)
                            ,(2, return 2)
                            ,(2, return 3)
                            ,(1, return 0xfffd)
                            ,(1, return 0xfffe) -- max fitting into packed W64
                            ,(1, return 0xffff)
                            ,(1, return 0x10000)]
      return (mkVersion branch)
    where
      smallListOf1 = adjustSize (\n -> min 6 (n `div` 3)) . listOf1

  shrink ver = [ mkVersion ns | ns <- shrink (versionNumbers ver)
                              , not (null ns) ]

newtype VersionArb = VersionArb [Int]
                   deriving (Eq,Ord,Show)

-- | 'Version' instance as used by QC 2.9
instance Arbitrary VersionArb where
  arbitrary = sized $ \n ->
    do k <- choose (0, log2 n)
       xs <- vectorOf (k+1) arbitrarySizedNatural
       return (VersionArb xs)
    where
      log2 :: Int -> Int
      log2 n | n <= 1 = 0
             | otherwise = 1 + log2 (n `div` 2)

  shrink (VersionArb xs) =
    [ VersionArb xs'
    | xs' <- shrink xs
    , length xs' > 0
    , all (>=0) xs'
    ]

instance Arbitrary VersionRange where
  arbitrary = sized verRangeExp
    where
      verRangeExp n = frequency $
        [ (2, return anyVersion)
        , (1, liftM thisVersion arbitrary)
        , (1, liftM laterVersion arbitrary)
        , (1, liftM orLaterVersion arbitrary)
        , (1, liftM orLaterVersion' arbitrary)
        , (1, liftM earlierVersion arbitrary)
        , (1, liftM orEarlierVersion arbitrary)
        , (1, liftM orEarlierVersion' arbitrary)
        , (1, liftM withinVersion arbitrary)
        , (2, liftM VersionRangeParens arbitrary)
        ] ++ if n == 0 then [] else
        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)
        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)
        ]
        where
          verRangeExp2 = verRangeExp (n `div` 2)

      orLaterVersion'   v =
        unionVersionRanges (LaterVersion v)   (ThisVersion v)
      orEarlierVersion' v =
        unionVersionRanges (EarlierVersion v) (ThisVersion v)

---------------------
-- Version properties
--

prop_VersionId :: [NonNegative Int] -> Bool
prop_VersionId lst0 =
    (versionNumbers . mkVersion) lst == lst
  where
    lst = map getNonNegative lst0

prop_VersionId2 :: VersionArb -> Bool
prop_VersionId2 (VersionArb lst) =
    (versionNumbers . mkVersion) lst == lst

prop_VersionEq :: Version -> Version -> Bool
prop_VersionEq v1 v2 = (==) v1 v2 == ((==) `on` versionNumbers) v1 v2

prop_VersionEq2 :: VersionArb -> VersionArb -> Bool
prop_VersionEq2 (VersionArb v1) (VersionArb v2) =
    (==) v1 v2 == ((==) `on` mkVersion) v1 v2

prop_VersionOrd :: Version -> Version -> Bool
prop_VersionOrd v1 v2 =
    compare v1 v2 == (compare `on` versionNumbers) v1 v2

prop_VersionOrd2 :: VersionArb -> VersionArb -> Bool
prop_VersionOrd2 (VersionArb v1) (VersionArb v2) =
    (==) v1 v2 == ((==) `on` mkVersion) v1 v2

prop_ShowRead :: Version -> Property
#if MIN_VERSION_base(4,6,0)
prop_ShowRead v = Just v === readMaybe (show v)
#else
-- readMaybe is since base-4.6
prop_ShowRead v = v === read (show v)
#endif

prop_ShowRead_example :: Bool
prop_ShowRead_example = show (mkVersion [1,2,3]) == "mkVersion [1,2,3]"

---------------------------
-- VersionRange properties
--

prop_nonNull :: Version -> Bool
prop_nonNull = (/= nullVersion)

prop_anyVersion :: Version -> Bool
prop_anyVersion v' =
  withinRange v' anyVersion == True

prop_noVersion :: Version -> Bool
prop_noVersion v' =
  withinRange v' noVersion == False

prop_thisVersion :: Version -> Version -> Bool
prop_thisVersion v v' =
     withinRange v' (thisVersion v)
  == (v' == v)

prop_notThisVersion :: Version -> Version -> Bool
prop_notThisVersion v v' =
     withinRange v' (notThisVersion v)
  == (v' /= v)

prop_laterVersion :: Version -> Version -> Bool
prop_laterVersion v v' =
     withinRange v' (laterVersion v)
  == (v' > v)

prop_orLaterVersion :: Version -> Version -> Bool
prop_orLaterVersion v v' =
     withinRange v' (orLaterVersion v)
  == (v' >= v)

prop_earlierVersion :: Version -> Version -> Bool
prop_earlierVersion v v' =
     withinRange v' (earlierVersion v)
  == (v' < v)

prop_orEarlierVersion :: Version -> Version -> Bool
prop_orEarlierVersion v v' =
     withinRange v' (orEarlierVersion v)
  == (v' <= v)

prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
prop_unionVersionRanges vr1 vr2 v' =
     withinRange v' (unionVersionRanges vr1 vr2)
  == (withinRange v' vr1 || withinRange v' vr2)

prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
prop_intersectVersionRanges vr1 vr2 v' =
     withinRange v' (intersectVersionRanges vr1 vr2)
  == (withinRange v' vr1 && withinRange v' vr2)

prop_differenceVersionRanges :: VersionRange -> VersionRange -> Version -> Bool
prop_differenceVersionRanges vr1 vr2 v' =
     withinRange v' (differenceVersionRanges vr1 vr2)
  == (withinRange v' vr1 && not (withinRange v' vr2))

prop_invertVersionRange :: VersionRange -> Version -> Bool
prop_invertVersionRange vr v' =
     withinRange v' (invertVersionRange vr)
  == not (withinRange v' vr)

prop_withinVersion :: Version -> Version -> Bool
prop_withinVersion v v' =
     withinRange v' (withinVersion v)
  == (v' >= v && v' < upper v)
  where
    upper = alterVersion $ \numbers -> init numbers ++ [last numbers + 1]

prop_foldVersionRange :: VersionRange -> Bool
prop_foldVersionRange range =
     expandWildcard range
  == foldVersionRange anyVersion thisVersion
                      laterVersion earlierVersion
                      unionVersionRanges intersectVersionRanges
                      range
  where
    expandWildcard (WildcardVersion v) =
        intersectVersionRanges (orLaterVersion v) (earlierVersion (upper v))
    expandWildcard (UnionVersionRanges     v1 v2) =
      UnionVersionRanges (expandWildcard v1) (expandWildcard v2)
    expandWildcard (IntersectVersionRanges v1 v2) =
      IntersectVersionRanges (expandWildcard v1) (expandWildcard v2)
    expandWildcard (VersionRangeParens v) = expandWildcard v
    expandWildcard v = v

    upper = alterVersion $ \numbers -> init numbers ++ [last numbers + 1]

prop_foldVersionRange' :: VersionRange -> Bool
prop_foldVersionRange' range =
     canonicalise range
  == foldVersionRange' anyVersion thisVersion
                       laterVersion earlierVersion
                       orLaterVersion orEarlierVersion
                       (\v _ -> withinVersion v)
                       (\v _ -> majorBoundVersion v)
                       unionVersionRanges intersectVersionRanges id
                       range
  where
    canonicalise (UnionVersionRanges (LaterVersion v)
                                     (ThisVersion  v')) | v == v'
                = UnionVersionRanges (ThisVersion   v')
                                     (LaterVersion  v)
    canonicalise (UnionVersionRanges (EarlierVersion v)
                                     (ThisVersion    v')) | v == v'
                = UnionVersionRanges (ThisVersion    v')
                                     (EarlierVersion v)
    canonicalise (UnionVersionRanges v1 v2) =
      UnionVersionRanges (canonicalise v1) (canonicalise v2)
    canonicalise (IntersectVersionRanges v1 v2) =
      IntersectVersionRanges (canonicalise v1) (canonicalise v2)
    canonicalise (VersionRangeParens v) = canonicalise v
    canonicalise v = v


prop_isAnyVersion1 :: VersionRange -> Version -> Property
prop_isAnyVersion1 range version =
  isAnyVersion range ==> withinRange version range

prop_isAnyVersion2 :: VersionRange -> Property
prop_isAnyVersion2 range =
  isAnyVersion range ==>
    foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)
                          (\_ _ -> False) (\_ _ -> False)
      (simplifyVersionRange range)

prop_isNoVersion :: VersionRange -> Version -> Property
prop_isNoVersion range version =
  isNoVersion range ==> not (withinRange version range)

prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property
prop_isSpecificVersion1 range (NonEmpty versions) =
  isJust version && not (null versions') ==>
    allEqual (fromJust version : versions')
  where
    version     = isSpecificVersion range
    versions'   = filter (`withinRange` range) versions
    allEqual xs = and (zipWith (==) xs (tail xs))

prop_isSpecificVersion2 :: VersionRange -> Property
prop_isSpecificVersion2 range =
  isJust version ==>
    foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)
                     (\_ _ -> Nothing) (\_ _ -> Nothing)
      (simplifyVersionRange range)
    == version

  where
    version = isSpecificVersion range

-- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'.
--
prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool
prop_simplifyVersionRange1 range version =
  withinRange version range == withinRange version (simplifyVersionRange range)

prop_simplifyVersionRange1' :: VersionRange -> Bool
prop_simplifyVersionRange1' range =
  range `equivalentVersionRange` (simplifyVersionRange range)

-- | 'simplifyVersionRange' produces a canonical form for ranges with
-- equivalent semantics.
--
prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property
prop_simplifyVersionRange2 r r' v =
  r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
    withinRange v r == withinRange v r'

prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property
prop_simplifyVersionRange2' r r' =
  r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>
    r `equivalentVersionRange` r'

--FIXME: see equivalentVersionRange for details
prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property
prop_simplifyVersionRange2'' r r' =
  r /= r' && r `equivalentVersionRange` r' ==>
       simplifyVersionRange r == simplifyVersionRange r'
    || isNoVersion r
    || isNoVersion r'

--------------------
-- VersionIntervals
--

-- | Generating VersionIntervals
--
-- This is a tad tricky as VersionIntervals is an abstract type, so we first
-- make a local type for generating the internal representation. Then we check
-- that this lets us construct valid 'VersionIntervals'.
--
newtype VersionIntervals' = VersionIntervals' [VersionInterval]
  deriving (Eq, Show)

instance Arbitrary VersionIntervals' where
  arbitrary = do
    ubound <- arbitrary
    bounds <- arbitrary
    let intervals = mergeTouching
                  . map fixEmpty
                  . replaceUpper ubound
                  . pairs
                  . sortBy (comparing fst)
                  $ bounds
    return (VersionIntervals' intervals)

    where
      pairs ((l, lb):(u, ub):bs) = (LowerBound l lb, UpperBound u ub)
                                 : pairs bs
      pairs _                    = []

      replaceUpper NoUpperBound [(l,_)] = [(l, NoUpperBound)]
      replaceUpper NoUpperBound (i:is)  = i : replaceUpper NoUpperBound is
      replaceUpper _               is   = is

      -- merge adjacent intervals that touch
      mergeTouching (i1@(l,u):i2@(l',u'):is)
        | doesNotTouch u l' = i1 : mergeTouching (i2:is)
        | otherwise         =      mergeTouching ((l,u'):is)
      mergeTouching is      = is

      doesNotTouch :: UpperBound -> LowerBound -> Bool
      doesNotTouch NoUpperBound _ = False
      doesNotTouch (UpperBound u ub) (LowerBound l lb) =
            u <  l
        || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)

      fixEmpty (LowerBound l _, UpperBound u _)
        | l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound)
      fixEmpty i = i

  shrink (VersionIntervals' intervals) =
    [ VersionIntervals' intervals' | intervals' <- shrink intervals ]

instance Arbitrary Bound where
  arbitrary = elements [ExclusiveBound, InclusiveBound]

instance Arbitrary LowerBound where
  arbitrary = liftM2 LowerBound arbitrary arbitrary

instance Arbitrary UpperBound where
  arbitrary = oneof [return NoUpperBound
                    ,liftM2 UpperBound arbitrary arbitrary]

-- | Check that our VersionIntervals' arbitrary instance generates intervals
-- that satisfies the invariant.
--
prop_gen_intervals1 :: VersionIntervals' -> Bool
prop_gen_intervals1 (VersionIntervals' intervals) =
  isJust (mkVersionIntervals intervals)

instance Arbitrary VersionIntervals where
  arbitrary = do
    VersionIntervals' intervals <- arbitrary
    case mkVersionIntervals intervals of
      Just xs -> return xs

-- | Check that constructing our intervals type and converting it to a
-- 'VersionRange' and then into the true intervals type gives us back
-- the exact same sequence of intervals. This tells us that our arbitrary
-- instance for 'VersionIntervals'' is ok.
--
prop_gen_intervals2 :: VersionIntervals' -> Bool
prop_gen_intervals2 (VersionIntervals' intervals') =
    asVersionIntervals (fromVersionIntervals intervals) == intervals'
  where
    Just intervals = mkVersionIntervals intervals'

-- | Check that 'VersionIntervals' models 'VersionRange' via
-- 'toVersionIntervals'.
--
prop_to_intervals :: VersionRange -> Version -> Bool
prop_to_intervals range version =
  withinRange version range == withinIntervals version intervals
  where
    intervals = toVersionIntervals range

-- | Check that semantic equality on 'VersionRange's is the same as converting
-- to 'VersionIntervals' and doing syntactic equality.
--
prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property
prop_to_intervals_canonical r r' =
  r /= r' && r `equivalentVersionRange` r' ==>
    toVersionIntervals r == toVersionIntervals r'

prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property
prop_to_intervals_canonical' r r' =
  r /= r' && toVersionIntervals r == toVersionIntervals r' ==>
    r `equivalentVersionRange` r'

-- | Check that 'VersionIntervals' models 'VersionRange' via
-- 'fromVersionIntervals'.
--
prop_from_intervals :: VersionIntervals -> Version -> Bool
prop_from_intervals intervals version =
  withinRange version range == withinIntervals version intervals
  where
    range = fromVersionIntervals intervals

-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on
-- 'VersionIntervals'.
--
prop_to_from_intervals :: VersionIntervals -> Bool
prop_to_from_intervals intervals =
  toVersionIntervals (fromVersionIntervals intervals) == intervals

-- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on
-- 'VersionRange', though not necessarily a syntactic identity.
--
prop_from_to_intervals :: VersionRange -> Bool
prop_from_to_intervals range =
  range' `equivalentVersionRange` range
  where
    range' = fromVersionIntervals (toVersionIntervals range)

-- | Equivalent of 'prop_from_to_intervals'
--
prop_from_to_intervals' :: VersionRange -> Version -> Bool
prop_from_to_intervals' range version =
  withinRange version range' == withinRange version range
  where
    range' = fromVersionIntervals (toVersionIntervals range)

-- | The semantics of 'unionVersionIntervals' is (||).
--
prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals
                           -> Version -> Bool
prop_unionVersionIntervals is1 is2 v =
     withinIntervals v (unionVersionIntervals is1 is2)
  == (withinIntervals v is1 || withinIntervals v is2)

-- | 'unionVersionIntervals' is idempotent
--
prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool
prop_unionVersionIntervals_idempotent =
  Laws.idempotent_binary unionVersionIntervals

-- | 'unionVersionIntervals' is commutative
--
prop_unionVersionIntervals_commutative :: VersionIntervals
                                       -> VersionIntervals -> Bool
prop_unionVersionIntervals_commutative =
  Laws.commutative unionVersionIntervals

-- | 'unionVersionIntervals' is associative
--
prop_unionVersionIntervals_associative :: VersionIntervals
                                       -> VersionIntervals
                                       -> VersionIntervals -> Bool
prop_unionVersionIntervals_associative =
  Laws.associative unionVersionIntervals

-- | The semantics of 'intersectVersionIntervals' is (&&).
--
prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals
                               -> Version -> Bool
prop_intersectVersionIntervals is1 is2 v =
     withinIntervals v (intersectVersionIntervals is1 is2)
  == (withinIntervals v is1 && withinIntervals v is2)

-- | 'intersectVersionIntervals' is idempotent
--
prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool
prop_intersectVersionIntervals_idempotent =
  Laws.idempotent_binary intersectVersionIntervals

-- | 'intersectVersionIntervals' is commutative
--
prop_intersectVersionIntervals_commutative :: VersionIntervals
                                           -> VersionIntervals -> Bool
prop_intersectVersionIntervals_commutative =
  Laws.commutative intersectVersionIntervals

-- | 'intersectVersionIntervals' is associative
--
prop_intersectVersionIntervals_associative :: VersionIntervals
                                           -> VersionIntervals
                                           -> VersionIntervals -> Bool
prop_intersectVersionIntervals_associative =
  Laws.associative intersectVersionIntervals

-- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals'
--
prop_union_intersect_distributive :: Property
prop_union_intersect_distributive =
      Laws.distributive_left  unionVersionIntervals intersectVersionIntervals
  .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals

-- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals'
--
prop_intersect_union_distributive :: Property
prop_intersect_union_distributive =
      Laws.distributive_left  intersectVersionIntervals unionVersionIntervals
  .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals

-- | The semantics of 'invertVersionIntervals' is 'not'.
--
prop_invertVersionIntervals :: VersionIntervals
                               -> Version -> Bool
prop_invertVersionIntervals vi v =
     withinIntervals v (invertVersionIntervals vi)
  == not (withinIntervals v vi)

-- | Double application of 'invertVersionIntervals' is the identity function
prop_invertVersionIntervalsTwice :: VersionIntervals -> Bool
prop_invertVersionIntervalsTwice vi =
    invertVersionIntervals (invertVersionIntervals vi) == vi



--------------------------------
-- equivalentVersionRange helper

prop_equivalentVersionRange :: VersionRange  -> VersionRange
                            -> Version -> Property
prop_equivalentVersionRange range range' version =
  equivalentVersionRange range range' && range /= range' ==>
    withinRange version range == withinRange version range'

--FIXME: this is wrong. consider version ranges "<=1" and "<1.0"
--       this algorithm cannot distinguish them because there is no version
--       that is included by one that is excluded by the other.
--       Alternatively we must reconsider the semantics of '<' and '<='
--       in version ranges / version intervals. Perhaps the canonical
--       representation should use just < v and interpret "<= v" as "< v.0".
equivalentVersionRange :: VersionRange -> VersionRange -> Bool
equivalentVersionRange vr1 vr2 =
  let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))
      minPoint = mkVersion [0]
      maxPoint | null allVersionsUsed = minPoint
               | otherwise = alterVersion (++[1]) (maximum allVersionsUsed)
      probeVersions = minPoint : maxPoint
                    : intermediateVersions allVersionsUsed

  in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions

  where
    versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++)
    intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2
                                         : intermediateVersions (v2:vs)
    intermediateVersions vs = vs

intermediateVersion :: Version -> Version -> Version
intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2"
intermediateVersion v1 v2 =
  mkVersion (intermediateList (versionNumbers v1) (versionNumbers v2))
  where
    intermediateList :: [Int] -> [Int] -> [Int]
    intermediateList []     (_:_) = [0]
    intermediateList (x:xs) (y:ys)
        | x <  y    = x : xs ++ [0]
        | otherwise = x : intermediateList xs ys

prop_intermediateVersion :: Version -> Version -> Property
prop_intermediateVersion v1 v2 =
  (v1 /= v2) && not (adjacentVersions v1 v2) ==>
  if v1 < v2
    then let v = intermediateVersion v1 v2
          in (v1 < v && v < v2)
    else let v = intermediateVersion v2 v1
          in v1 > v && v > v2

adjacentVersions :: Version -> Version -> Bool
adjacentVersions ver1 ver2 = v1 ++ [0] == v2 || v2 ++ [0] == v1
  where
    v1 = versionNumbers ver1
    v2 = versionNumbers ver2

--------------------------------
-- Parsing and pretty printing
--

prop_parse_disp1 :: VersionRange -> Bool
prop_parse_disp1 vr =
  fmap stripParens (simpleParse (display vr)) == Just (canonicalise vr)

  where
    canonicalise = swizzle . swap

    swizzle     (UnionVersionRanges (UnionVersionRanges v1 v2) v3)
      | not (isOrLaterVersion v1 v2) && not (isOrEarlierVersion v1 v2)
      = swizzle (UnionVersionRanges v1 (UnionVersionRanges v2  v3))

    swizzle     (IntersectVersionRanges (IntersectVersionRanges v1 v2) v3)
      = swizzle (IntersectVersionRanges v1 (IntersectVersionRanges v2  v3))

    swizzle (UnionVersionRanges v1 v2) =
      UnionVersionRanges (swizzle v1) (swizzle v2)
    swizzle (IntersectVersionRanges v1 v2) =
      IntersectVersionRanges (swizzle v1) (swizzle v2)
    swizzle (VersionRangeParens v) = swizzle v
    swizzle v = v

    isOrLaterVersion (ThisVersion  v) (LaterVersion v') = v == v'
    isOrLaterVersion _                _                 = False

    isOrEarlierVersion (ThisVersion v)    (EarlierVersion v') = v == v'
    isOrEarlierVersion _                  _                   = False

    swap =
      foldVersionRange' anyVersion thisVersion
                        laterVersion earlierVersion
                        orLaterVersion orEarlierVersion
                        (\v _ -> withinVersion v)
                        (\v _ -> MajorBoundVersion v)
                        unionVersionRanges intersectVersionRanges id

    stripParens :: VersionRange -> VersionRange
    stripParens (VersionRangeParens v) = stripParens v
    stripParens (UnionVersionRanges v1 v2) =
      UnionVersionRanges (stripParens v1) (stripParens v2)
    stripParens (IntersectVersionRanges v1 v2) =
      IntersectVersionRanges (stripParens v1) (stripParens v2)
    stripParens v = v

prop_parse_disp2 :: VersionRange -> Property
prop_parse_disp2 vr =
  let b = fmap (display :: VersionRange -> String) (simpleParse (display vr))
      a = Just (display vr)
  in
   counterexample ("Expected: " ++ show a) $
   counterexample ("But got: " ++ show b) $
   b == a

prop_parse_disp3 :: VersionRange -> Property
prop_parse_disp3 vr =
  let a = Just (display vr)
      b = fmap displayRaw (simpleParse (display vr))
  in
   counterexample ("Expected: " ++ show a) $
   counterexample ("But got: " ++ show b) $
   b == a

prop_parse_disp4 :: VersionRange -> Property
prop_parse_disp4 vr =
  let a = Just vr
      b = (simpleParse (display vr))
  in
   counterexample ("Expected: " ++ show a) $
   counterexample ("But got: " ++ show b) $
   b == a

prop_parse_disp5 :: VersionRange -> Property
prop_parse_disp5 vr =
  let a = Just vr
      b = simpleParse (displayRaw vr)
  in
   counterexample ("Expected: " ++ show a) $
   counterexample ("But got: " ++ show b) $
   b == a

displayRaw :: VersionRange -> String
displayRaw =
   Disp.render
 . foldVersionRange'                         -- precedence:
     -- All the same as the usual pretty printer, except for the parens
     (          Disp.text "-any")
     (\v     -> Disp.text "==" <> disp v)
     (\v     -> Disp.char '>'  <> disp v)
     (\v     -> Disp.char '<'  <> disp v)
     (\v     -> Disp.text ">=" <> disp v)
     (\v     -> Disp.text "<=" <> disp v)
     (\v _   -> Disp.text "==" <> dispWild v)
     (\v _   -> Disp.text "^>=" <> disp v)
     (\r1 r2 -> r1 <+> Disp.text "||" <+> r2)
     (\r1 r2 -> r1 <+> Disp.text "&&" <+> r2)
     (\r     -> Disp.parens r) -- parens

  where
    dispWild v =
           Disp.hcat (Disp.punctuate (Disp.char '.')
                                     (map Disp.int (versionNumbers v)))
        <> Disp.text ".*"