{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-}
module Test.Distribution.Version (properties) where

import Distribution.Version
import Distribution.Text

import Test.QuickCheck
import Test.QuickCheck.Utils
import qualified Test.Laws as Laws

import Control.Monad (liftM, liftM2)
import Data.Maybe (isJust, fromJust)
import Data.List (sort, sortBy, nub)
import Data.Ord  (comparing)

properties :: [Property]
properties =
    -- properties to validate the test framework
  [ property prop_nonNull
  , property prop_gen_intervals1
  , property prop_gen_intervals2
  , property prop_equivalentVersionRange
  , property prop_intermediateVersion

    -- the basic syntactic version range functions
  , 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_withinVersion
  , property prop_foldVersionRange
  , property prop_foldVersionRange'

    -- the semantic query functions
  , property prop_isAnyVersion1
  , property prop_isAnyVersion2
  , property prop_isNoVersion
  , property prop_isSpecificVersion1
  , property prop_isSpecificVersion2
  , property prop_simplifyVersionRange1
  , property prop_simplifyVersionRange1'
  , property prop_simplifyVersionRange2
  , property prop_simplifyVersionRange2'
  , property prop_simplifyVersionRange2'' --FIXME

    -- converting between version ranges and version intervals
  , property prop_to_intervals
  , property prop_to_intervals_canonical
  , property prop_to_intervals_canonical'
  , 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

   -- parsing an pretty printing
  , property prop_parse_disp
  ]

instance Arbitrary Version where
  arbitrary = do
    branch <- smallListOf1 $
                frequency [(3, return 0)
                          ,(3, return 1)
                          ,(2, return 2)
                          ,(1, return 3)]
    return (Version branch []) -- deliberate []
    where
      smallListOf1 = adjustSize (\n -> min 5 (n `div` 3)) . listOf1

  shrink (Version branch []) =
    [ Version branch' [] | branch' <- shrink branch, not (null branch') ]
  shrink (Version branch _tags) =
    [ Version branch [] ]

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)
        ] ++ 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)

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

prop_nonNull :: Version -> Bool
prop_nonNull = not . null . versionBranch

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_withinVersion :: Version -> Version -> Bool
prop_withinVersion v v' =
     withinRange v' (withinVersion v)
  == (v' >= v && v' < upper v)
  where
    upper (Version lower t) = Version (init lower ++ [last lower + 1]) t

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))
      where
        upper (Version lower t) = Version (init lower ++ [last lower + 1]) t

    expandWildcard (UnionVersionRanges     v1 v2) =
      UnionVersionRanges (expandWildcard v1) (expandWildcard v2)
    expandWildcard (IntersectVersionRanges v1 v2) =
      IntersectVersionRanges (expandWildcard v1) (expandWildcard v2)
    expandWildcard v = v


prop_foldVersionRange' :: VersionRange -> Bool
prop_foldVersionRange' range =
     canonicalise range
  == foldVersionRange' anyVersion thisVersion
                       laterVersion earlierVersion
                       orLaterVersion orEarlierVersion
                       (\v _ -> withinVersion v)
                       unionVersionRanges intersectVersionRanges
                       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 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'

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

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

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

equivalentVersionRange :: VersionRange -> VersionRange -> Bool
equivalentVersionRange vr1 vr2 =
  let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))
      minPoint = Version [0] []
      maxPoint | null allVersionsUsed = minPoint
               | otherwise = case maximum allVersionsUsed of
                   Version vs _ -> Version (vs ++ [1]) []
      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 (Version v1 _) (Version v2 _) =
  Version (intermediateList v1 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 (Version v1 _) (Version v2 _) = v1 ++ [0] == v2
                                              || v2 ++ [0] == v1

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

prop_parse_disp :: VersionRange -> Bool
prop_parse_disp vr =
  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 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)
                        unionVersionRanges intersectVersionRanges