{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications      #-}
module IntervalAlgebraSpec
  ( spec
  ) where

import           Data.Either               (isRight)
import           Data.Fixed                (Pico)
import           Data.Maybe                (fromJust, isJust, isNothing)
import           Data.Set                  (Set, disjointUnion, fromList,
                                            member)
import           Data.Time                 as DT (Day (..), DiffTime,
                                                  NominalDiffTime, UTCTime (..),
                                                  fromGregorian,
                                                  picosecondsToDiffTime,
                                                  secondsToDiffTime)
import           GHC.Real                  (Rational (..), Real (..))
import           IntervalAlgebra           as IA
import           IntervalAlgebra.Arbitrary ()
import           Test.Hspec                (Spec, describe, hspec, it, shouldBe)
import           Test.Hspec.QuickCheck     (modifyMaxDiscardRatio,
                                            modifyMaxSuccess)
import           Test.QuickCheck           (Arbitrary (arbitrary), Gen (..),
                                            Property, Testable (property),
                                            generate, quickCheck, (===), (==>))

mkIntrvl :: Int -> Int -> Interval Int
mkIntrvl = beginerval

prop_expandl_end
  :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property
prop_expandl_end d i = end (expandl d i) === end i


prop_expandr_begin
  :: (IntervalSizeable a b, Show a) => b -> Interval a -> Property
prop_expandr_begin d i = begin (expandr d i) === begin i

-- | The relation between x and z should be an element of the set of the
--   composed relations between x y and between y z.
prop_compose :: Ord a => Interval a -> Interval a -> Interval a -> Property
prop_compose x y z =
  member (relate x z) (compose (relate x y) (relate y z)) === True

-- | If two intervals are disjoint and not meeting, then there should be a gap
-- between the two (by ><), after the intervals are sorted.
prop_combinable_gap_exists :: Ord a => Interval a -> Interval a -> Property
prop_combinable_gap_exists x y =
  (before <|> after) x y ==> isJust ((><) (min x y) (max x y))

-- | If two intervals are not disjoint or meeting, then there should be NO gap
-- between the two (by ><), after the intervals are sorted.
prop_combinable_nogap_exists :: Ord a => Interval a -> Interval a -> Property
prop_combinable_nogap_exists x y =
  (predicate $ complement $ fromList [Before, After]) x y
    ==> isNothing ((><) (min x y) (max x y))


spec :: Spec
spec = do
  describe "Basic Interval unit tests of typeclass and creation methods" $ do
    it "equality works"
      $          beginerval 6 (1 :: Int)
      ==         beginerval 6 1
      `shouldBe` True
    it "equality works"
      $          beginerval 0    (1 :: Int)
      ==         beginerval (-1) 1
      `shouldBe` True
    it "equality works"
      $          enderval 1 (2 :: Int)
      ==         beginerval 1 1
      `shouldBe` True
    it "not equality works"
      $          enderval 5 (2 :: Int)
      /=         beginerval 1 1
      `shouldBe` True

    it "beginervalMoment duration is moment"
      $          duration (beginervalMoment (-13 :: Int))
      `shouldBe` (moment @Int)
    it "endervalMoment duration is moment"
      $          duration (endervalMoment (26 :: Int))
      `shouldBe` (moment @Int)

    it "parsing fails on bad inputs" $ parseInterval 10 0 `shouldBe` Left
      (IA.ParseErrorInterval "0<=10")
    it "parsing fails on bad inputs" $ parseInterval 0 0 `shouldBe` Left
      (IA.ParseErrorInterval "0<=0")
    it "parsing works on good inputs" $ parseInterval 0 10 `shouldBe` Right
      (beginerval 10 (0 :: Int))

    it "show displays intervals as expected"
      $          show (beginerval 10 (0 :: Int))
      `shouldBe` "(0, 10)"

    -- NOTE toEnum (fromGregorian 1858 11 17) is 0,
    -- since that date is the origin in the modified
    -- Julian calendar.
    it "fromEnumInterval converts Interval Day"
      $          fromEnumInterval (beginerval 0 (fromGregorian 1858 11 17))
      `shouldBe` beginerval 0 0

    it "(0, 2) <= (1, 3) is True"
      $          beginerval 2 (0 :: Int)
      <=         beginerval 2 1
      `shouldBe` True

    it "(1, 2) < (0, 3) is True"
      $          beginerval 2 (1 :: Int)
      <          beginerval 3 0
      `shouldBe` False
    it "(0, 2) < (1, 3) is True"
      $          beginerval 2 (0 :: Int)
      <          beginerval 2 1
      `shouldBe` True
    it "(0, 2) < (0, 3) is True"
      $          beginerval 2 (0 :: Int)
      <          beginerval 3 0
      `shouldBe` True

  describe "Basic IntervalRelation unit tests" $ do
    it "equality of IntervalRelations" $ Before == Before `shouldBe` True
    it "equality of IntervalRelations" $ Before /= After `shouldBe` True

    it "Bounds are set correctly" $ minBound @IntervalRelation `shouldBe` Before
    it "Bounds are set correctly" $ maxBound @IntervalRelation `shouldBe` After

    it "show Before is Before" $ show Before `shouldBe` "Before"

  describe "Relate unit tests" $ do
    it "relate before"
      $          relate (beginerval 1 (0 :: Int)) (beginerval 1 2)
      `shouldBe` Before
    it "relate after"
      $          relate (beginerval 1 (2 :: Int)) (beginerval 1 0)
      `shouldBe` After
    it "relate meets"
      $          relate (beginerval 1 (0 :: Int)) (beginerval 1 1)
      `shouldBe` Meets
    it "relate metBy"
      $          relate (beginerval 1 (1 :: Int)) (beginerval 1 0)
      `shouldBe` MetBy
    it "relate overlaps"
      $          relate (beginerval 3 (0 :: Int)) (beginerval 5 2)
      `shouldBe` Overlaps
    it "relate overlappedBy"
      $          relate (beginerval 5 (2 :: Int)) (beginerval 3 0)
      `shouldBe` OverlappedBy
    it "relate starts"
      $          relate (beginerval 3 (0 :: Int)) (beginerval 5 0)
      `shouldBe` Starts
    it "relate startedBy"
      $          relate (beginerval 5 (0 :: Int)) (beginerval 3 0)
      `shouldBe` StartedBy
    it "relate finishes"
      $          relate (enderval 3 (0 :: Int)) (enderval 5 0)
      `shouldBe` Finishes
    it "relate finishedBy"
      $          relate (enderval 5 (0 :: Int)) (enderval 3 0)
      `shouldBe` FinishedBy
    it "relate during"
      $          relate (beginerval 1 (1 :: Int)) (beginerval 3 0)
      `shouldBe` During
    it "relate Contains"
      $          relate (beginerval 3 (0 :: Int)) (beginerval 1 1)
      `shouldBe` Contains

  describe "IntervalRelation algebraic operations" $ do
    it "converse of Before is After"
      $          converse (fromList [Before])
      `shouldBe` fromList [After]

    it "union of IntervalRelations"
      $          union (fromList [Before]) (fromList [After])
      `shouldBe` fromList [Before, After]
    it "intersection of IntervalRelations"
      $          intersection (fromList [Before]) (fromList [After])
      `shouldBe` fromList []

  describe "IntervalSizeable tests" $ do
    it "moment is 1" $ moment @Int `shouldBe` 1
    it "expandl doesn't change end" $ property (prop_expandl_end @Int)
    it "expandr doesn't change begin" $ property (prop_expandr_begin @Int)
    it "expand 0 5 Interval (0, 1) should be Interval (0, 6)"
      $          expand 0 5 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (0 :: Int)
    it "expand 5 0 Interval (0, 1) should be Interval (-5, 1)"
      $          expand 5 0 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (-5 :: Int)
    it "expand 5 5 Interval (0, 1) should be Interval (-5, 6)"
      $          expand 5 5 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (11 :: Int) (-5 :: Int)
    it "expand -1 5 Interval (0, 1) should be Interval (-5, 6)"
      $          expand (-1) 5 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (0 :: Int)
    it "expand 5 -5 Interval (0, 1) should be Interval (-5, 1)"
      $          expand 5 (-5) (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (6 :: Int) (-5 :: Int)
    it "expand moment 0 Interval (0, 1) should be Interval (-1, 1)"
      $          expand (moment @Int) 0 (beginerval (1 :: Int) (0 :: Int))
      `shouldBe` beginerval (2 :: Int) (-1 :: Int)

    it "beginerval 2 10 should be Interval (10, 12)"
      $          Right (beginerval (2 :: Int) 10)
      `shouldBe` parseInterval (10 :: Int) (12 :: Int)
    it "beginerval 0 10 should be Interval (10, 11)"
      $          Right (beginerval (0 :: Int) 10)
      `shouldBe` parseInterval (10 :: Int) (11 :: Int)
    it "beginerval -2 10 should be Interval (10, 11)"
      $          Right (beginerval (-2 :: Int) 10)
      `shouldBe` parseInterval (10 :: Int) (11 :: Int)
    it "enderval 2 10 should be Interval (8, 10)"
      $          Right (enderval (2 :: Int) 10)
      `shouldBe` parseInterval (8 :: Int) (10 :: Int)
    it "enderval 0 10 should be Interval (9, 10)"
      $          Right (enderval (0 :: Int) 10)
      `shouldBe` parseInterval (9 :: Int) (10 :: Int)
    it "enderval -2 10 should be Interval (9, 10)"
      $          Right (enderval (-2 :: Int) 10)
      `shouldBe` parseInterval (9 :: Int) (10 :: Int)

    it "shiftFromBegin can convert Interval Int to Interval Int"
      $          shiftFromBegin (beginerval 2 (4 :: Int)) (beginerval 2 10)
      `shouldBe` beginerval 2 6 -- (6, 8)

    it "shiftFromEnd can convert Interval Int to Interval Int"
      $          shiftFromEnd (beginerval 2 (4 :: Int)) (beginerval 2 10)
      `shouldBe` beginerval 2 4 -- (4, 6)

    it "shiftFromBegin can convert Interval Day to Interval Integer"
      $          shiftFromBegin (beginerval 2 (fromGregorian 2001 1 1))
                                (beginerval 2 (fromGregorian 2001 1 10))
      `shouldBe` beginerval 2 9 -- (9, 11)

    it "shiftFromEnd can convert Interval Day to Interval Integer"
      $          shiftFromEnd (beginerval 2 (fromGregorian 2001 1 1))
                              (beginerval 2 (fromGregorian 2001 1 10))
      `shouldBe` beginerval 2 7 -- (7, 9)

    it "momentize works"
      $          momentize (beginerval 2 (fromGregorian 2001 1 1))
      `shouldBe` beginerval 1 (fromGregorian 2001 1 1)


  describe "Intervallic tests" $
    --  modifyMaxSuccess (*10000) $
                                 do
    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 4) is True"
      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 5 (-1))
      `shouldBe` True
    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (0, 4) is True"
      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 4 0)
      `shouldBe` True
    it "(startedBy <|> overlappedBy) Interval (0, 9) Interval (-1, 9) is False"
      $          (startedBy <|> overlappedBy) (mkIntrvl 9 0) (mkIntrvl 10 (-1))
      `shouldBe` False
    it "disjoint x y same as explicit union of predicates"
      $          disjoint (mkIntrvl 2 0) (mkIntrvl 2 3)
      `shouldBe` (before <|> after <|> meets <|> metBy) (mkIntrvl 2 0)
                                                        (mkIntrvl 2 3)
    it "within x y same as explicit union of predicates"
      $          within (mkIntrvl 2 3) (mkIntrvl 2 3)
      `shouldBe` (starts <|> during <|> finishes <|> equals) (mkIntrvl 2 3)
                                                             (mkIntrvl 2 3)
    it "prop_compose holds" $ property (prop_compose @Int)

  describe "IntervalCombinable tests" $ do
    it "join non-meeting intervals is Nothing"
      $          beginerval 2 (0 :: Int)
      .+.        beginerval 6 5
      `shouldBe` Nothing
    it "join meeting intervals is Just _"
      $          beginerval 2 (0 :: Int)
      .+.        beginerval 6 2
      `shouldBe` Just (beginerval 8 0)

    it "gap of disjoint intervals should be something"
      $ property (prop_combinable_gap_exists @Int)
    it "gap of disjoint intervals should be something"
      $ property (prop_combinable_gap_exists @Day)
    it "gap of disjoint intervals should be something"
      $ property (prop_combinable_gap_exists @UTCTime)

    it "gap of nondisjoint, nonmeeting intervals should be nothing"
      $ property (prop_combinable_nogap_exists @Int)
    it "gap of nondisjoint, nonmeeting intervals should be nothing"
      $ property (prop_combinable_nogap_exists @Day)

  describe "Interval Algebra relation unit tests for synonyms" $ do
    it "(0, 2) precedes (10, 12)"
      $          beginerval 2 (0 :: Int)
      `precedes` beginerval 2 10
      `shouldBe` True
    it "precedes matches before"
      $          beginerval 10 (0 :: Int)
      `precedes` beginerval 1  11
      `shouldBe` beginerval 10 (0 :: Int)
      `before`   beginerval 1  11
    it "(10, 12) precededBy (0, 2)"
      $          precededBy (beginerval 2 10) (beginerval 2 (0 :: Int))
      `shouldBe` True
    it "precededBy matches after"
      $          precededBy (beginerval 1 11) (beginerval 10 (0 :: Int))
      `shouldBe` after (beginerval 1 11) (beginerval 10 (0 :: Int))
    it "concur matches notDdisjoint"
      $          concur (beginerval 1 11) (beginerval 10 (0 :: Int))
      `shouldBe` notDisjoint (beginerval 1 11) (beginerval 10 (0 :: Int))
    it "concur matches notDisjoint"
      $          concur (beginerval 1 0) (beginerval 10 (0 :: Int))
      `shouldBe` notDisjoint (beginerval 1 0) (beginerval 10 (0 :: Int))