{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : event data theory tests
-- Description : An internal module for testing event data theory functions
--               on a dummy event data model
module EventDataTheory.TheoryTest
  ( theoryTests,
  )
where

import Data.Aeson
import Data.Bifunctor (first)
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as B
import Data.Data
import Data.Functor.Contravariant (Predicate (..))
import Data.List (sort)
import Data.Maybe (isNothing)
import Data.Text (Text, pack)
import Data.Time (Day, fromGregorian)
import EventDataTheory.Core
import EventDataTheory.EventLines
import EventDataTheory.Test
import EventDataTheory.Utilities
import GHC.Generics (Generic)
import GHC.Num (Natural)
import IntervalAlgebra
  ( Interval,
    Intervallic (..),
    Iv,
    PointedIv (..),
    SizedIv (..),
    begin,
    beginerval,
    contains,
    end,
    expandr,
    meets,
    metBy,
    momentize,
    overlaps,
  )
import IntervalAlgebra.Arbitrary
import Test.Tasty (TestTree, defaultMain, testGroup)
import Test.Tasty.HUnit
import Test.Tasty.QuickCheck
import Witch (from, into)

-- TODO: assess whether this needs to be provided as a utility
-- in event-data-theory. it was previously only used here.
-- Note Ord a implies Iv (Interval a).

-- | Temporary stand-in for a utility that has been removed from
-- interval-algebra. The slightly odd type signature is there to match
-- the old API and usage here.
filterContains :: (Ord a, Intervallic i) => Interval a -> [i a] -> [i a]
filterContains :: forall a (i :: * -> *).
(Ord a, Intervallic i) =>
Interval a -> [i a] -> [i a]
filterContains Interval a
iv = forall a. (a -> Bool) -> [a] -> [a]
filter (Interval a
iv forall a (i0 :: * -> *) (i1 :: * -> *).
(Iv (Interval a), Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
`contains`)

-- | Just a dummy type with which to define an event

{- tag::exampleEvent[] -}
data SillySchema
  = A Int
  | B Text
  | C
  | D
  deriving (Int -> SillySchema -> ShowS
[SillySchema] -> ShowS
SillySchema -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SillySchema] -> ShowS
$cshowList :: [SillySchema] -> ShowS
show :: SillySchema -> String
$cshow :: SillySchema -> String
showsPrec :: Int -> SillySchema -> ShowS
$cshowsPrec :: Int -> SillySchema -> ShowS
Show, SillySchema -> SillySchema -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SillySchema -> SillySchema -> Bool
$c/= :: SillySchema -> SillySchema -> Bool
== :: SillySchema -> SillySchema -> Bool
$c== :: SillySchema -> SillySchema -> Bool
Eq, forall x. Rep SillySchema x -> SillySchema
forall x. SillySchema -> Rep SillySchema x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SillySchema x -> SillySchema
$cfrom :: forall x. SillySchema -> Rep SillySchema x
Generic, Typeable SillySchema
SillySchema -> DataType
SillySchema -> Constr
(forall b. Data b => b -> b) -> SillySchema -> SillySchema
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> SillySchema -> u
forall u. (forall d. Data d => d -> u) -> SillySchema -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SillySchema -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SillySchema -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SillySchema
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SillySchema -> c SillySchema
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SillySchema)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SillySchema)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SillySchema -> m SillySchema
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SillySchema -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SillySchema -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> SillySchema -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SillySchema -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SillySchema -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SillySchema -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SillySchema -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SillySchema -> r
gmapT :: (forall b. Data b => b -> b) -> SillySchema -> SillySchema
$cgmapT :: (forall b. Data b => b -> b) -> SillySchema -> SillySchema
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SillySchema)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c SillySchema)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SillySchema)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SillySchema)
dataTypeOf :: SillySchema -> DataType
$cdataTypeOf :: SillySchema -> DataType
toConstr :: SillySchema -> Constr
$ctoConstr :: SillySchema -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SillySchema
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SillySchema
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SillySchema -> c SillySchema
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SillySchema -> c SillySchema
Data)

instance FromJSON SillySchema

instance Arbitrary SillySchema where
  arbitrary :: Gen SillySchema
arbitrary =
    forall a. [Gen a] -> Gen a
oneof
      [ forall (f :: * -> *) a. Applicative f => a -> f a
pure SillySchema
C,
        forall (f :: * -> *) a. Applicative f => a -> f a
pure SillySchema
D,
        Int -> SillySchema
A forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary,
        Text -> SillySchema
B forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
      ]

type SillyEvent1 a = Event String SillySchema a

{- end::exampleEvent[] -}

instance ToJSON SillySchema

-- | Just a dummy type to test non-text tag set
data SillyTagSet = Mouse | Giraffe | Hornbill
  deriving (Int -> SillyTagSet -> ShowS
[SillyTagSet] -> ShowS
SillyTagSet -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SillyTagSet] -> ShowS
$cshowList :: [SillyTagSet] -> ShowS
show :: SillyTagSet -> String
$cshow :: SillyTagSet -> String
showsPrec :: Int -> SillyTagSet -> ShowS
$cshowsPrec :: Int -> SillyTagSet -> ShowS
Show, SillyTagSet -> SillyTagSet -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SillyTagSet -> SillyTagSet -> Bool
$c/= :: SillyTagSet -> SillyTagSet -> Bool
== :: SillyTagSet -> SillyTagSet -> Bool
$c== :: SillyTagSet -> SillyTagSet -> Bool
Eq, Eq SillyTagSet
SillyTagSet -> SillyTagSet -> Bool
SillyTagSet -> SillyTagSet -> Ordering
SillyTagSet -> SillyTagSet -> SillyTagSet
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SillyTagSet -> SillyTagSet -> SillyTagSet
$cmin :: SillyTagSet -> SillyTagSet -> SillyTagSet
max :: SillyTagSet -> SillyTagSet -> SillyTagSet
$cmax :: SillyTagSet -> SillyTagSet -> SillyTagSet
>= :: SillyTagSet -> SillyTagSet -> Bool
$c>= :: SillyTagSet -> SillyTagSet -> Bool
> :: SillyTagSet -> SillyTagSet -> Bool
$c> :: SillyTagSet -> SillyTagSet -> Bool
<= :: SillyTagSet -> SillyTagSet -> Bool
$c<= :: SillyTagSet -> SillyTagSet -> Bool
< :: SillyTagSet -> SillyTagSet -> Bool
$c< :: SillyTagSet -> SillyTagSet -> Bool
compare :: SillyTagSet -> SillyTagSet -> Ordering
$ccompare :: SillyTagSet -> SillyTagSet -> Ordering
Ord, forall x. Rep SillyTagSet x -> SillyTagSet
forall x. SillyTagSet -> Rep SillyTagSet x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SillyTagSet x -> SillyTagSet
$cfrom :: forall x. SillyTagSet -> Rep SillyTagSet x
Generic)

instance FromJSON SillyTagSet

instance ToJSON SillyTagSet

instance Arbitrary SillyTagSet where
  arbitrary :: Gen SillyTagSet
arbitrary = forall a. [Gen a] -> Gen a
oneof [forall (f :: * -> *) a. Applicative f => a -> f a
pure SillyTagSet
Mouse, forall (f :: * -> *) a. Applicative f => a -> f a
pure SillyTagSet
Giraffe, forall (f :: * -> *) a. Applicative f => a -> f a
pure SillyTagSet
Hornbill]

type SillyEvent2 a = Event SillyTagSet SillySchema a

-- TODO: remove these if they can still just alias `arbitrary`
-- Generators for SillyEvents
genSillyEvent1 :: (Arbitrary (Interval a)) => Gen (SillyEvent1 a)
genSillyEvent1 :: forall a. Arbitrary (Interval a) => Gen (SillyEvent1 a)
genSillyEvent1 = forall a. Arbitrary a => Gen a
arbitrary

genSillyEvent2 :: (Arbitrary (Interval a)) => Gen (SillyEvent2 a)
genSillyEvent2 :: forall a. Arbitrary (Interval a) => Gen (SillyEvent2 a)
genSillyEvent2 = forall a. Arbitrary a => Gen a
arbitrary

-- Examples for SillyEvents

c1 :: Context String SillySchema
c1 :: Context String SillySchema
c1 = forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall source target. From source target => source -> target
from @[String] [String
"this", String
"that"]) (Int -> SillySchema
A Int
1) forall a. Maybe a
Nothing

e1 :: SillyEvent1 Int
e1 :: SillyEvent1 Int
e1 = forall a t m. Interval a -> Context t m -> Event t m a
event (forall a.
SizedIv (Interval a) =>
Moment (Interval a) -> a -> Interval a
beginerval Int
2 Int
1) Context String SillySchema
c1

c2 :: Context String SillySchema
c2 :: Context String SillySchema
c2 = forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall source target. From source target => source -> target
from @[String] [String
"this", String
"another"]) (Int -> SillySchema
A Int
1) forall a. Maybe a
Nothing

e2 :: SillyEvent1 Int
e2 :: SillyEvent1 Int
e2 = forall a t m. Interval a -> Context t m -> Event t m a
event (forall a.
SizedIv (Interval a) =>
Moment (Interval a) -> a -> Interval a
beginerval Int
4 Int
3) Context String SillySchema
c2

{- UNIT TESTS -}

{-
These tests of the interval algebra are in a way silly
because events are basically PairedIntervals
which are well tested in the interval-algebra library
These few tests are here for a basic sanity check
to be sure interval functions work on events.
-}
eventIntervalUnitTests :: TestTree
eventIntervalUnitTests :: TestTree
eventIntervalUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Interval algebra sanity checks"
    [ String -> Assertion -> TestTree
testCase String
"e1 meets e2" forall a b. (a -> b) -> a -> b
$ forall a (i0 :: * -> *) (i1 :: * -> *).
(Iv (Interval a), Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
meets SillyEvent1 Int
e1 SillyEvent1 Int
e2 forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True,
      String -> Assertion -> TestTree
testCase String
"e2 metBy e1" forall a b. (a -> b) -> a -> b
$ forall a (i0 :: * -> *) (i1 :: * -> *).
(Iv (Interval a), Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
metBy SillyEvent1 Int
e2 SillyEvent1 Int
e1 forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True,
      String -> Assertion -> TestTree
testCase String
"e1 does not overlap e2" forall a b. (a -> b) -> a -> b
$ forall a (i0 :: * -> *) (i1 :: * -> *).
(Iv (Interval a), Intervallic i0, Intervallic i1) =>
ComparativePredicateOf2 (i0 a) (i1 a)
overlaps SillyEvent1 Int
e1 SillyEvent1 Int
e2 forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False,
      String -> Assertion -> TestTree
testCase String
"(0, 10) contains both e1 and e2" forall a b. (a -> b) -> a -> b
$ forall a (i :: * -> *).
(Ord a, Intervallic i) =>
Interval a -> [i a] -> [i a]
filterContains Interval Int
ci [SillyEvent1 Int]
es forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= [SillyEvent1 Int]
es,
      String -> Assertion -> TestTree
testCase String
"(4, 10) contains neither e1 and e2" forall a b. (a -> b) -> a -> b
$ forall a (i :: * -> *).
(Ord a, Intervallic i) =>
Interval a -> [i a] -> [i a]
filterContains Interval Int
ni [SillyEvent1 Int]
es forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= []
    ]
  where
    es :: [SillyEvent1 Int]
es = [SillyEvent1 Int
e1, SillyEvent1 Int
e2]
    ci :: Interval Int
ci = forall a.
SizedIv (Interval a) =>
Moment (Interval a) -> a -> Interval a
beginerval Moment (Interval Int)
10 Int
0
    ni :: Interval Int
ni = forall a.
SizedIv (Interval a) =>
Moment (Interval a) -> a -> Interval a
beginerval Moment (Interval Int)
6 Int
4

{-
Tests of the hasTagSet functions.
-}
hasTagUnitTests :: TestTree
hasTagUnitTests :: TestTree
hasTagUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit tests for hasTagSet using a dummy event model"
    [ String -> Assertion -> TestTree
testCase String
"hasTag should have tag" forall a b. (a -> b) -> a -> b
$ forall a t. HasTag a t => a -> t -> Bool
hasTag SillyEvent1 Int
e1 (String
"this" :: String) forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True,
      String -> Assertion -> TestTree
testCase String
"hasTag should not have tag" forall a b. (a -> b) -> a -> b
$ forall a t. HasTag a t => a -> t -> Bool
hasTag SillyEvent1 Int
e1 (String
"not" :: String) forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False,
      String -> Assertion -> TestTree
testCase String
"hasAnyTag works" forall a b. (a -> b) -> a -> b
$ forall a t. HasTag a t => a -> [t] -> Bool
hasAnyTag SillyEvent1 Int
e1 ([String
"this"] :: [String]) forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True,
      String -> Assertion -> TestTree
testCase String
"hasAnyTags works" forall a b. (a -> b) -> a -> b
$ forall a t. HasTag a t => a -> [t] -> Bool
hasAnyTag SillyEvent1 Int
e1 ([String
"not"] :: [String]) forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False,
      String -> Assertion -> TestTree
testCase String
"hasAnyTags works" forall a b. (a -> b) -> a -> b
$
        forall a t. HasTag a t => a -> [t] -> Bool
hasAnyTag SillyEvent1 Int
e1 ([String
"not", String
"this"] :: [String])
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True,
      String -> Assertion -> TestTree
testCase String
"hasAllTags works" forall a b. (a -> b) -> a -> b
$
        forall a t. HasTag a t => a -> [t] -> Bool
hasAllTags SillyEvent1 Int
e1 ([String
"not", String
"this"] :: [String])
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False,
      String -> Assertion -> TestTree
testCase String
"hasAllTags works" forall a b. (a -> b) -> a -> b
$
        forall a t. HasTag a t => a -> [t] -> Bool
hasAllTags SillyEvent1 Int
e1 ([String
"that", String
"this"] :: [String])
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
True,
      String -> Assertion -> TestTree
testCase String
"hasAllTags works" forall a b. (a -> b) -> a -> b
$
        forall a t. HasTag a t => a -> [t] -> Bool
hasAllTags SillyEvent1 Int
e1 ([String
"that", String
"this", String
"not"] :: [String])
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool
False
    ]

cPred1 :: Predicate (Context String SillySchema)
cPred1 :: Predicate (Context String SillySchema)
cPred1 = forall a. (a -> Bool) -> Predicate a
Predicate (\Context String SillySchema
x -> forall t m. Context t m -> m
getFacts Context String SillySchema
x forall a. Eq a => a -> a -> Bool
== SillySchema
C)

cPred2 :: Predicate (Maybe Source)
cPred2 :: Predicate (Maybe Source)
cPred2 = forall a. (a -> Bool) -> Predicate a
Predicate forall a. Maybe a -> Bool
isNothing

cPred3 :: Predicate SillySchema
cPred3 :: Predicate SillySchema
cPred3 = forall a. (a -> Bool) -> Predicate a
Predicate (Int -> SillySchema
A Int
1 forall a. Eq a => a -> a -> Bool
==)

eventPredicateUnitTests :: TestTree
eventPredicateUnitTests :: TestTree
eventPredicateUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit tests that predicate on event components successfully lift"
    [ String -> Assertion -> TestTree
testCase String
"Context" forall a b. (a -> b) -> a -> b
$
        forall a. Predicate a -> a -> Bool
getPredicate Predicate (Context String SillySchema)
cPred1 Context String SillySchema
c1
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Predicate a -> a -> Bool
getPredicate (forall element t m a.
EventPredicate element t m a =>
Predicate element -> Predicate (Event t m a)
liftToEventPredicate Predicate (Context String SillySchema)
cPred1) SillyEvent1 Int
e1,
      String -> Assertion -> TestTree
testCase String
"Maybe Source" forall a b. (a -> b) -> a -> b
$
        forall a. Predicate a -> a -> Bool
getPredicate Predicate (Maybe Source)
cPred2 forall a. Maybe a
Nothing
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Predicate a -> a -> Bool
getPredicate (forall element t m a.
EventPredicate element t m a =>
Predicate element -> Predicate (Event t m a)
liftToEventPredicate Predicate (Maybe Source)
cPred2) SillyEvent1 Int
e1,
      String -> Assertion -> TestTree
testCase String
"Facts" forall a b. (a -> b) -> a -> b
$
        forall a. Predicate a -> a -> Bool
getPredicate Predicate SillySchema
cPred3 SillySchema
C
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= Bool -> Bool
not
            (forall a. Predicate a -> a -> Bool
getPredicate (forall element t m a.
EventPredicate element t m a =>
Predicate element -> Predicate (Event t m a)
liftToEventPredicate Predicate SillySchema
cPred3) SillyEvent1 Int
e1),
      String -> Assertion -> TestTree
testCase String
"Facts" forall a b. (a -> b) -> a -> b
$
        forall a. Predicate a -> a -> Bool
getPredicate Predicate SillySchema
cPred3 (Int -> SillySchema
A Int
1)
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Predicate a -> a -> Bool
getPredicate (forall element t m a.
EventPredicate element t m a =>
Predicate element -> Predicate (Event t m a)
liftToEventPredicate Predicate SillySchema
cPred3) SillyEvent1 Int
e1
    ]

toFromTagSetUnitTests :: TestTree
toFromTagSetUnitTests :: TestTree
toFromTagSetUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit test that pack/unpack getTagSet roundtrips"
    [ String -> Assertion -> TestTree
testCase String
"single tag" forall a b. (a -> b) -> a -> b
$ String
"foo" forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (forall t. Tag t -> t
unpackTag forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. t -> Tag t
packTag) String
"foo",
      String -> Assertion -> TestTree
testCase String
"tag set" forall a b. (a -> b) -> a -> b
$
        forall a. Ord a => [a] -> [a]
sort [String
"foo", String
"bar"]
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= (forall t. Ord t => TagSet t -> [t]
unpackTagSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Ord t => [t] -> TagSet t
packTagSet)
            [String
"foo", String
"bar"]
    ]

-- | Check that files in test/events-day-text-good successfully parse
decodeSillyTests1 :: TestTree
decodeSillyTests1 :: TestTree
decodeSillyTests1 =
  forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
String -> TestTree
eventDecodeTests @SillySchema @Text @Day String
"test/events-day-text-good"

-- | Check that files in test/events-day-text-good successfully parse
roundtripSillyTests1 :: TestTree
roundtripSillyTests1 :: TestTree
roundtripSillyTests1 =
  forall m t a b.
(Eventable t m a, FromJSONEvent t m a, ToJSONEvent t m a,
 SizedIv (Interval a)) =>
String -> TestTree
eventLineRoundTripTests @SillySchema @Text @Day String
"test/events-day-text-good"

-- | Check that files in test/events-day-text-good successfully parse
modifySillyTests1 :: TestTree
modifySillyTests1 :: TestTree
modifySillyTests1 =
  forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Data m) =>
String -> TestTree
eventLineModifyTests @SillySchema @Text @Day String
"test/events-day-text-good"

-- | Check that files in test/events-day-text-bad successfully fail
decodeSillyFailTests1 :: TestTree
decodeSillyFailTests1 :: TestTree
decodeSillyFailTests1 =
  forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
String -> TestTree
eventDecodeFailTests @SillySchema @Text @Day String
"test/events-day-text-bad"

-- | Check that files in test/events-integer-silly-good successfully parse
decodeSillyTests2 :: TestTree
decodeSillyTests2 :: TestTree
decodeSillyTests2 =
  forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
String -> TestTree
eventDecodeTests @SillySchema @SillyTagSet @Integer
    String
"test/events-integer-silly-good"

-- | Check that files in test/events-integer-silly-bad successfully fail
decodeSillyFailTests2 :: TestTree
decodeSillyFailTests2 :: TestTree
decodeSillyFailTests2 =
  forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
String -> TestTree
eventDecodeFailTests @SillySchema @Text @Day String
"test/events-integer-silly-bad"

{- Unit tests on line parsers -}
testInput1Good :: C.ByteString
testInput1Good :: ByteString
testInput1Good =
  ByteString
"[\"abc\", \"2020-01-01\", \"2020-01-02\", \"A\",\
  \[\"someThing\"],\
  \{\"facts\" : {\"tag\":\"A\", \"contents\" : 1},\
  \ \"patient_id\":\"abc\",\
  \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-01\"}}]"

testInput2Good :: C.ByteString
testInput2Good :: ByteString
testInput2Good =
  ByteString
"[\"abc\", \"2020-01-05\", \"2020-01-06\", \"C\",\
  \[\"someThing\"],\
  \{\"facts\": { \"tag\" : \"C\", \"contents\":{}},\
  \ \"patient_id\":\"abc\",\
  \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"

testInput1Bad :: C.ByteString
testInput1Bad :: ByteString
testInput1Bad =
  ByteString
"[\"def\", \"2020-01-01\", null, \"D\",\
  \[\"someThing\"],\
  \{\"facts\": { \"tag\" : \"D\", \"contents\":{}},\
  \ \"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-01\"}}]"

testInput2Bad :: C.ByteString
testInput2Bad :: ByteString
testInput2Bad =
  ByteString
"[\"def\", \"2020-01-05\", null, \"C\",\
  \[\"someThing\"],\
  \ {\"facts\":{\"tag\":\"C\", \"contents\":{}},\
  \ \"time\":{\"begin\":\"2020-01-05\",\"end\":\"2020-01-06\"}}]"

testInputBad :: C.ByteString
testInputBad :: ByteString
testInputBad = ByteString
testInput1Bad forall a. Semigroup a => a -> a -> a
<> ByteString
"\n" forall a. Semigroup a => a -> a -> a
<> ByteString
testInput2Bad

testOutput1Good, testOutput2Good, testOutputBad :: ([LineParseError], [(SubjectID, Event Text SillySchema Day)])
testOutput1Good :: ([LineParseError], [(Text, Event Text SillySchema Day)])
testOutput1Good = ([], [(Text
"abc", forall a t m. Interval a -> Context t m -> Event t m a
event (forall a.
SizedIv (Interval a) =>
Moment (Interval a) -> a -> Interval a
beginerval Integer
1 (Integer -> Int -> Int -> Day
fromGregorian Integer
2020 Int
1 Int
1)) (forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall target source. From source target => source -> target
into [Text
"someThing" :: Text]) (Int -> SillySchema
A Int
1) forall a. Maybe a
Nothing))])
testOutput2Good :: ([LineParseError], [(Text, Event Text SillySchema Day)])
testOutput2Good = ([], [(Text
"abc", forall a t m. Interval a -> Context t m -> Event t m a
event (forall a.
SizedIv (Interval a) =>
Moment (Interval a) -> a -> Interval a
beginerval Integer
2 (Integer -> Int -> Int -> Day
fromGregorian Integer
2020 Int
1 Int
5)) (forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall target source. From source target => source -> target
into [Text
"someThing" :: Text]) SillySchema
C forall a. Maybe a
Nothing))])
testOutputBad :: ([LineParseError], [(Text, Event Text SillySchema Day)])
testOutputBad =
  ( [ forall source target. From source target => source -> target
from @(Natural, String) (Natural
1, String
"Error in $[5]: parsing EventDataTheory.EventLines.FactsLine(MkFactsLine) failed, key \"patient_id\" not found"),
      forall source target. From source target => source -> target
from @(Natural, String) (Natural
2, String
"Error in $[5]: parsing EventDataTheory.EventLines.FactsLine(MkFactsLine) failed, key \"patient_id\" not found")
    ],
    []
  )

parserUnitTests :: TestTree
parserUnitTests :: TestTree
parserUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit tests of EventLines parsers"
    [ String -> Assertion -> TestTree
testCase String
"with valid inputs 1" forall a b. (a -> b) -> a -> b
$
        forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption
-> ByteString -> ([LineParseError], [(Text, Event t m a)])
parseEventLinesL' @SillySchema @Text @Day
          ParseEventLineOption
AddMomentAndFix
          ByteString
testInput1Good
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ([LineParseError], [(Text, Event Text SillySchema Day)])
testOutput1Good,
      String -> Assertion -> TestTree
testCase String
"with valid inputs 2" forall a b. (a -> b) -> a -> b
$
        forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption
-> ByteString -> ([LineParseError], [(Text, Event t m a)])
parseEventLinesL' @SillySchema @Text @Day
          ParseEventLineOption
AddMomentAndFix
          ByteString
testInput2Good
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ([LineParseError], [(Text, Event Text SillySchema Day)])
testOutput2Good,
      String -> Assertion -> TestTree
testCase String
"with invalid inputs" forall a b. (a -> b) -> a -> b
$
        forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption
-> ByteString -> ([LineParseError], [(Text, Event t m a)])
parseEventLinesL' @SillySchema @Text @Day
          ParseEventLineOption
AddMomentAndFix
          ByteString
testInputBad
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= ([LineParseError], [(Text, Event Text SillySchema Day)])
testOutputBad
    ]

-- | Unit tests on Core utilities
singleEventGoodIn :: B.ByteString
singleEventGoodIn :: ByteString
singleEventGoodIn =
  ByteString
"[\"abc\",\"2020-01-01\",\"2020-01-02\",\"A\",\
  \[],\
  \{\"facts\":{\"contents\":1,\"tag\":\"A\"},\
  \\"patient_id\":\"abc\",\
  \\"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]"

singleEventGoodOut :: B.ByteString
singleEventGoodOut :: ByteString
singleEventGoodOut =
  ByteString
"[\"abc\",\"2020-01-01\",\"2020-01-02\",\"A\",\
  \[\"bar\",\"foo\"],\
  \{\"facts\":{\"contents\":1,\"tag\":\"A\"},\
  \\"patient_id\":\"abc\",\
  \\"time\":{\"begin\":\"2020-01-01\",\"end\":\"2020-01-02\"}}]"

testAddTagViaEventLine :: Assertion
testAddTagViaEventLine :: Assertion
testAddTagViaEventLine =
  let x :: Either String (EventLine Text SillySchema Day)
x =
        forall m m' t t' a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Eventable t' m' a, Data m') =>
ParseEventLineOption
-> (Context t m -> Context t' m')
-> ByteString
-> Either String (EventLine t' m' a)
modifyEventLineWithContext @SillySchema @SillySchema @Text @Text @Day
          ParseEventLineOption
AddMomentAndFix
          (forall f t t' m m'.
(ContextFunction f t t' m m', Ord t, Ord t') =>
f -> Context t m -> Context t' m'
liftToContextFunction forall a b. (a -> b) -> a -> b
$ forall t. Ord t => [t] -> TagSet t -> TagSet t
addTagSet [Text
"foo", Text
"bar" :: Text])
          ByteString
singleEventGoodIn
   in case Either String (EventLine Text SillySchema Day)
x of
        Left String
s -> forall a. HasCallStack => String -> IO a
assertFailure String
s
        Right EventLine Text SillySchema Day
e ->
          forall a. FromJSON a => ByteString -> Maybe a
decode (forall a. ToJSON a => a -> ByteString
encode EventLine Text SillySchema Day
e)
            forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. FromJSON a => ByteString -> Maybe a
decode @(EventLine Text SillySchema Day) ByteString
singleEventGoodOut

-- | Unit tests on utilities
coreUtilitiesUnitTests :: TestTree
coreUtilitiesUnitTests :: TestTree
coreUtilitiesUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit tests on Core utilities"
    [String -> Assertion -> TestTree
testCase String
"check that tag set is added as expected" Assertion
testAddTagViaEventLine]

-- | Unit tests on utilities
utilitiesUnitTests :: TestTree
utilitiesUnitTests :: TestTree
utilitiesUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Unit tests on utilities"
    [ String -> Assertion -> TestTree
testCase String
"find first occurrence of Tag 'this'" forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) t m a.
(Witherable f, Ord t) =>
[t] -> f (Event t m a) -> Maybe (Event t m a)
firstOccurrenceOfTag [String
"this"] [SillyEvent1 Int
e1, SillyEvent1 Int
e2]
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. a -> Maybe a
Just SillyEvent1 Int
e1,
      String -> Assertion -> TestTree
testCase String
"find last occurrence of Tag 'this'" forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) t m a.
(Witherable f, Ord t) =>
[t] -> f (Event t m a) -> Maybe (Event t m a)
lastOccurrenceOfTag [String
"this"] [SillyEvent1 Int
e1, SillyEvent1 Int
e2]
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. a -> Maybe a
Just SillyEvent1 Int
e2,
      String -> Assertion -> TestTree
testCase String
"find first occurrence of Tag 'another'" forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) t m a.
(Witherable f, Ord t) =>
[t] -> f (Event t m a) -> Maybe (Event t m a)
firstOccurrenceOfTag [String
"another"] [SillyEvent1 Int
e1, SillyEvent1 Int
e2]
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. a -> Maybe a
Just SillyEvent1 Int
e2,
      String -> Assertion -> TestTree
testCase String
"find first occurrence of Tag 'blah'" forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) t m a.
(Witherable f, Ord t) =>
[t] -> f (Event t m a) -> Maybe (Event t m a)
firstOccurrenceOfTag [String
"blah"] [SillyEvent1 Int
e1, SillyEvent1 Int
e2]
          forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
@?= forall a. Maybe a
Nothing
    ]

-- | Test group
theoryUnitTests :: TestTree
theoryUnitTests :: TestTree
theoryUnitTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Event Theory unit tests"
    [ TestTree
decodeSillyTests1,
      TestTree
decodeSillyTests2,
      TestTree
decodeSillyFailTests1,
      TestTree
decodeSillyFailTests2,
      TestTree
roundtripSillyTests1,
      TestTree
modifySillyTests1,
      TestTree
coreUtilitiesUnitTests,
      TestTree
eventIntervalUnitTests,
      TestTree
hasTagUnitTests,
      TestTree
eventPredicateUnitTests,
      TestTree
toFromTagSetUnitTests,
      TestTree
utilitiesUnitTests,
      TestTree
parserUnitTests,
      TestTree
eventOrdTests
    ]

{- PROPERTY TESTS -}

-- TODO: revise these constraints when you do so for parseEventLinesL'

-- | Utility to parse a Bytestring eventline and grab the
-- correctly parsed events, ignoring the rest. Uses the specified
-- parsing option.
parsedEvents ::
  (Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
  ParseEventLineOption ->
  C.ByteString ->
  [Event t m a]
parsedEvents :: forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
opt = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption
-> ByteString -> ([LineParseError], [(Text, Event t m a)])
parseEventLinesL' ParseEventLineOption
opt

-- TODO: modify this to support creating begin == end intervals.

-- | Utility to wrap an event into a single eventline, with the provided Text as subject ID.
-- The 'modFact' input allows to modify the FactLine before parsing.
eventToEventLine ::
  (Eventable t m a, EventLineAble t m a b) =>
  (FactsLine m a -> FactsLine m a) -> 
  Text ->
  Event t m a ->
  EventLine t m a
eventToEventLine :: forall t m a b.
(Eventable t m a, EventLineAble t m a b) =>
(FactsLine m a -> FactsLine m a)
-> Text -> Event t m a -> EventLine t m a
eventToEventLine FactsLine m a -> FactsLine m a
modFact Text
sid Event t m a
e = forall t m a.
Value
-> Value
-> Value
-> Value
-> [t]
-> FactsLine m a
-> EventLine t m a
MkEventLine Value
Null Value
Null Value
Null Value
Null [t]
tgs forall a b. (a -> b) -> a -> b
$ FactsLine m a -> FactsLine m a
modFact FactsLine m a
factline
  where
    factline :: FactsLine m a
factline =
      MkFactsLine
        { $sel:valid:MkFactsLine :: Maybe Bool
valid = forall a. Maybe a
Nothing,
          $sel:time:MkFactsLine :: TimeLine a
time =
            MkTimeLine
              { $sel:timeEnd:MkTimeLine :: Maybe a
timeEnd = forall a. a -> Maybe a
Just (forall iv. PointedIv iv => iv -> Point iv
ivEnd Interval a
i),
                $sel:timeBegin:MkTimeLine :: a
timeBegin = forall iv. PointedIv iv => iv -> Point iv
ivBegin Interval a
i
              },
          $sel:source:MkFactsLine :: Maybe Source
source = forall t m. Context t m -> Maybe Source
getSource Context t m
ctx,
          $sel:patient_id:MkFactsLine :: Text
patient_id = Text
sid,
          $sel:facts:MkFactsLine :: m
facts = forall t m. Context t m -> m
getFacts Context t m
ctx
        }
    ctx :: Context t m
ctx = forall t m a. Event t m a -> Context t m
getContext Event t m a
e
    i :: Interval a
i = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
e
    tgs :: [t]
tgs = forall target source. From source target => source -> target
into forall a b. (a -> b) -> a -> b
$ forall t m. Context t m -> TagSet t
getTagSet Context t m
ctx

-- | Utility to set the timeEnd in a 'FactLine'.
setTimeEnd :: Maybe a -> FactsLine m a -> FactsLine m a
setTimeEnd :: forall a m. Maybe a -> FactsLine m a -> FactsLine m a
setTimeEnd Maybe a
e FactsLine m a
f = FactsLine m a
f
      { $sel:time:MkFactsLine :: TimeLine a
time = MkTimeLine {$sel:timeEnd:MkTimeLine :: Maybe a
timeEnd = Maybe a
e, $sel:timeBegin:MkTimeLine :: a
timeBegin = forall a. TimeLine a -> a
timeBegin forall a b. (a -> b) -> a -> b
$ forall m a. FactsLine m a -> TimeLine a
time FactsLine m a
f}
      }

-- | Transform a list of events into EventLines, then encode as a single bytestring,
-- with one eventline per line. The Bool flag if True sets timeEnd to Nothing
encodeEventList ::
  (EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m, ToJSON a) =>
  (FactsLine m a -> FactsLine m a) -> 
  [Event t m a] ->
  C.ByteString
encodeEventList :: forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList FactsLine m a -> FactsLine m a
modFact [Event t m a]
es = ByteString -> [ByteString] -> ByteString
C.intercalate ByteString
"\n" [ByteString]
bs
  where
    bs :: [ByteString]
bs = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {t} {a}.
(ToJSON t, Ord t, Typeable t, Show t, Show a) =>
a -> Event t m a -> ByteString
op [Integer
1 ..] [Event t m a]
es
    op :: a -> Event t m a -> ByteString
op a
t Event t m a
e = ByteString -> ByteString
C.toStrict forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ forall t m a b.
(Eventable t m a, EventLineAble t m a b) =>
(FactsLine m a -> FactsLine m a)
-> Text -> Event t m a -> EventLine t m a
eventToEventLine FactsLine m a -> FactsLine m a
modFact (String -> Text
pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
t) Event t m a
e

-- | Valid events should round-trip through JSON with the DoNotModifyTime
-- parsing option.
prop_noModTimeOption :: [SillyEvent2 Int] -> Property
prop_noModTimeOption :: [SillyEvent2 Int] -> Property
prop_noModTimeOption [SillyEvent2 Int]
es = [SillyEvent2 Int]
es forall a. (Eq a, Show a) => a -> a -> Property
=== [SillyEvent2 Int]
es'
  where
    es' :: [SillyEvent2 Int]
es' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
DoNotModifyTime forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList forall a. a -> a
id [SillyEvent2 Int]
es

-- | AddMomentToEnd works as advertised for valid events.
prop_addMoment :: [SillyEvent2 Int] -> Property
prop_addMoment :: [SillyEvent2 Int] -> Property
prop_addMoment [SillyEvent2 Int]
es = [SillyEvent2 Int]
esExpanded forall a. (Eq a, Show a) => a -> a -> Property
=== [SillyEvent2 Int]
es'
  where
    m :: Moment (Interval Int)
m = forall iv. SizedIv iv => Moment iv
moment @(Interval Int)
    esExpanded :: [SillyEvent2 Int]
esExpanded = forall a b. (a -> b) -> [a] -> [b]
map (forall a (i :: * -> *).
(SizedIv (Interval a), Intervallic i) =>
Moment (Interval a) -> i a -> i a
expandr Int
m) [SillyEvent2 Int]
es
    es' :: [SillyEvent2 Int]
es' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
AddMomentToEnd forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList forall a. a -> a
id [SillyEvent2 Int]
es

-- | AddMomentAndFix creates a moment-length interval when
-- only a 'begin' is provided.
prop_addMomentToPoint :: [SillyEvent2 Int] -> Property
prop_addMomentToPoint :: [SillyEvent2 Int] -> Property
prop_addMomentToPoint [SillyEvent2 Int]
es = [SillyEvent2 Int]
esMoment forall a. (Eq a, Show a) => a -> a -> Property
=== [SillyEvent2 Int]
es'
  where
    esMoment :: [SillyEvent2 Int]
esMoment = forall a b. (a -> b) -> [a] -> [b]
map forall (i :: * -> *) a.
(SizedIv (Interval a), Intervallic i) =>
i a -> i a
momentize [SillyEvent2 Int]
es
    es' :: [SillyEvent2 Int]
es' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
AddMomentAndFix forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList (forall a m. Maybe a -> FactsLine m a -> FactsLine m a
setTimeEnd forall a. Maybe a
Nothing) [SillyEvent2 Int]
es

-- | AddMomentToEnd does *not* fixup missing end, and no such events should parse.
prop_addMomentMissingEnd :: [SillyEvent2 Int] -> Property
prop_addMomentMissingEnd :: [SillyEvent2 Int] -> Property
prop_addMomentMissingEnd [SillyEvent2 Int]
es = [SillyEvent2 Int]
es' forall a. (Eq a, Show a) => a -> a -> Property
=== ([] :: [SillyEvent2 Int])
  where es' :: [SillyEvent2 Int]
es' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
AddMomentToEnd forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList (forall a m. Maybe a -> FactsLine m a -> FactsLine m a
setTimeEnd forall a. Maybe a
Nothing) [SillyEvent2 Int]
es

-- | AddMomentToEnd works as advertised for events where begin == end.
prop_addMomentToPoint' :: [SillyEvent2 Int] -> Property
prop_addMomentToPoint' :: [SillyEvent2 Int] -> Property
prop_addMomentToPoint' [SillyEvent2 Int]
es = [SillyEvent2 Int]
esPoint forall a. (Eq a, Show a) => a -> a -> Property
=== [SillyEvent2 Int]
es'
  where
    esPoint :: [SillyEvent2 Int]
esPoint = forall a b. (a -> b) -> [a] -> [b]
map forall (i :: * -> *) a.
(SizedIv (Interval a), Intervallic i) =>
i a -> i a
momentize [SillyEvent2 Int]
es
    es' :: [SillyEvent2 Int]
es' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
AddMomentToEnd forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList (\FactsLine SillySchema Int
f -> forall a m. Maybe a -> FactsLine m a -> FactsLine m a
setTimeEnd (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. TimeLine a -> a
timeBegin forall a b. (a -> b) -> a -> b
$ forall m a. FactsLine m a -> TimeLine a
time FactsLine SillySchema Int
f) FactsLine SillySchema Int
f) [SillyEvent2 Int]
es

-- | FixEnd creates a moment-length interval when
-- only a 'begin' is provided and otherwise leaves events untouched.
-- Note this does *not* check whether it fails when it should.
prop_FixEnd :: [SillyEvent2 Int] -> Property
prop_FixEnd :: [SillyEvent2 Int] -> Property
prop_FixEnd [SillyEvent2 Int]
es = ([SillyEvent2 Int]
es forall a. [a] -> [a] -> [a]
++ [SillyEvent2 Int]
esMoment) forall a. (Eq a, Show a) => a -> a -> Property
=== ([SillyEvent2 Int]
es' forall a. [a] -> [a] -> [a]
++ [SillyEvent2 Int]
es'')
  where
    esMoment :: [SillyEvent2 Int]
esMoment = forall a b. (a -> b) -> [a] -> [b]
map forall (i :: * -> *) a.
(SizedIv (Interval a), Intervallic i) =>
i a -> i a
momentize [SillyEvent2 Int]
es
    es'' :: [SillyEvent2 Int]
es'' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
FixEnd forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList (forall a m. Maybe a -> FactsLine m a -> FactsLine m a
setTimeEnd forall a. Maybe a
Nothing) [SillyEvent2 Int]
es
    es' :: [SillyEvent2 Int]
es' = forall t m a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption -> ByteString -> [Event t m a]
parsedEvents ParseEventLineOption
FixEnd forall a b. (a -> b) -> a -> b
$ forall t m a b.
(EventLineAble t m a b, Eventable t m a, ToJSON t, ToJSON m,
 ToJSON a) =>
(FactsLine m a -> FactsLine m a) -> [Event t m a] -> ByteString
encodeEventList forall a. a -> a
id [SillyEvent2 Int]
es

-- | Test group
theoryPropTests :: TestTree
theoryPropTests :: TestTree
theoryPropTests =
  String -> [TestTree] -> TestTree
testGroup
    String
"Event Data Theory property tests"
    [ forall a. Testable a => String -> a -> TestTree
testProperty
        String
"DoNotModifyTime gives JSON roundtrip with valid events"
        [SillyEvent2 Int] -> Property
prop_noModTimeOption,
      forall a. Testable a => String -> a -> TestTree
testProperty
        String
"AddMomentToEnd gives JSON roundtrip re: valid events expanded rightward by moment"
        [SillyEvent2 Int] -> Property
prop_addMoment,
      forall a. Testable a => String -> a -> TestTree
testProperty
        String
"AddMomentToEnd does not fix up missing end"
        [SillyEvent2 Int] -> Property
prop_addMomentMissingEnd,
      forall a. Testable a => String -> a -> TestTree
testProperty
        String
"AddMomentAndFix gives JSON roundtrip for eventlines with no end point"
        [SillyEvent2 Int] -> Property
prop_addMomentToPoint,
      forall a. Testable a => String -> a -> TestTree
testProperty
        String
"AddMomentToEnd gives JSON roundtrip for eventlines where end == begin"
        [SillyEvent2 Int] -> Property
prop_addMomentToPoint',
      forall a. Testable a => String -> a -> TestTree
testProperty
        String
"FixEnd gives JSON roundtrip for eventlines with no end point, leaving rest untouched"
        [SillyEvent2 Int] -> Property
prop_FixEnd
    ]

{- TEST RUNNER -}

-- |
-- The set of tests used to test the @event-data-theory@ package.
theoryTests :: IO ()
theoryTests :: Assertion
theoryTests =
  TestTree -> Assertion
defaultMain forall a b. (a -> b) -> a -> b
$
    String -> [TestTree] -> TestTree
testGroup
      String
"Event Data Theory tests"
      [ TestTree
theoryUnitTests,
        TestTree
theoryPropTests
      ]