{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Hasklepias Event Tests
-- Description : Provides test making functions for event models
module EventDataTheory.Test
  ( eventDecodeTests,
    eventDecodeFailTests,
    eventLineRoundTripTests,
    eventLineModifyTests,
    eventOrdTests,
  )
where

import Data.Aeson
  ( FromJSON,
    ToJSON,
    decode,
    decode',
    eitherDecode,
    encode,
  )
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Data
import Data.Either (fromLeft, isLeft, isRight)
import qualified Data.List as L
import Data.Text (Text)
import Data.Time (Day)
import EventDataTheory.Core
import EventDataTheory.EventLines
import GHC.Generics (Generic)
import IntervalAlgebra
import System.FilePath (FilePath, takeBaseName)
import Test.Tasty (TestName, TestTree, testGroup)
import Test.Tasty.HUnit
import Test.Tasty.Silver (findByExtension)
import Type.Reflection (Typeable)

-- |
-- Creates a group of tests
-- using 'createDecodeSmokeTest'
-- from all the files
-- in given directory
-- with given file extensions.
-- Each test passes if the decoding results in a @Right a@ value.
createDecodeSmokeTestGroup ::
  -- | name to give this group of tests
  TestName ->
  -- | a function which tests the decoding result, first value is the string if test fails
  (Either String a -> (String, Bool)) ->
  -- | a function which decodes a @ByteString@ to @Either String a@
  (C.ByteString -> Either String a) ->
  -- | a list of file extensions to find in the provided directory
  [FilePath] ->
  -- | name of directory containing files to be parsed
  FilePath ->
  TestTree
createDecodeSmokeTestGroup :: forall a.
TestName
-> (Either TestName a -> (TestName, Bool))
-> (ByteString -> Either TestName a)
-> [TestName]
-> TestName
-> TestTree
createDecodeSmokeTestGroup TestName
n Either TestName a -> (TestName, Bool)
testf ByteString -> Either TestName a
decoder [TestName]
exts TestName
dir = TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
n forall a b. (a -> b) -> a -> b
$ \TestName -> IO ()
step -> do
  [TestName]
sources <- [TestName] -> TestName -> IO [TestName]
findByExtension [TestName]
exts TestName
dir
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestName
f -> TestName -> IO ()
step TestName
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TestName -> IO ()
createDecodeAssertion TestName
f) [TestName]
sources
  where createDecodeAssertion :: TestName -> IO ()
createDecodeAssertion TestName
testFile = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry HasCallStack => TestName -> Bool -> IO ()
assertBool forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either TestName a -> (TestName, Bool)
testf forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either TestName a
decoder forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<  TestName -> IO ByteString
C.readFile TestName
testFile

-- |
-- Creates a group of tests
-- from all the files
-- in given directory
-- for all files ending in '.jsonl'.
-- Each file should contain 1 line containing 1 event.
-- Each test passes if the decoding results in a @Right a@ value.
--
-- The test group is meant as a smoke test
-- to check that events you think should parse
-- do in fact parse.
eventDecodeTests ::
  forall m t a b.
  (Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
  FilePath ->
  TestTree
eventDecodeTests :: forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
TestName -> TestTree
eventDecodeTests TestName
dir =
  forall a.
TestName
-> (Either TestName a -> (TestName, Bool))
-> (ByteString -> Either TestName a)
-> [TestName]
-> TestName
-> TestTree
createDecodeSmokeTestGroup
    (TestName
"Checking that .jsonl files in " forall a. Semigroup a => a -> a -> a
<> TestName
dir forall a. Semigroup a => a -> a -> a
<> TestName
" can be decoded")
    (\Either TestName (SubjectID, Event t m a)
x -> (forall a b. a -> Either a b -> a
fromLeft TestName
"" Either TestName (SubjectID, Event t m a)
x, forall a b. Either a b -> Bool
isRight Either TestName (SubjectID, Event t m a)
x))
    (forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption
-> ByteString -> Either TestName (SubjectID, Event t m a)
eitherDecodeEvent' @m @t @a ParseEventLineOption
AddMomentAndFix)
    [TestName
".jsonl"]
    TestName
dir

-- |
-- Creates a group of tests
-- from all the files
-- in given directory
-- for all files ending in '.jsonl'.
-- Each file should contain 1 line containing 1 event.
-- Each test passes if the decoding results in a @Left String@ value.
--
-- The test group is meant as a smoke test
-- to check that events you think should _not_ parse
-- do not in fact parse.
eventDecodeFailTests ::
  forall m t a b.
  (Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
  FilePath ->
  TestTree
eventDecodeFailTests :: forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
TestName -> TestTree
eventDecodeFailTests TestName
dir =
  forall a.
TestName
-> (Either TestName a -> (TestName, Bool))
-> (ByteString -> Either TestName a)
-> [TestName]
-> TestName
-> TestTree
createDecodeSmokeTestGroup
    (TestName
"Checking that .jsonl files in " forall a. Semigroup a => a -> a -> a
<> TestName
dir forall a. Semigroup a => a -> a -> a
<> TestName
" fail to decode")
    (\Either TestName (SubjectID, Event t m a)
x -> (TestName
"successly parsed; should fail", forall a b. Either a b -> Bool
isLeft Either TestName (SubjectID, Event t m a)
x))
    (forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a) =>
ParseEventLineOption
-> ByteString -> Either TestName (SubjectID, Event t m a)
eitherDecodeEvent' @m @t @a ParseEventLineOption
AddMomentAndFix)
    [TestName
".jsonl"]
    TestName
dir

-- |
-- Creates a single test case
-- which decodes the contents of a file.
-- The test passes if the decoding
-- then encoding and decoding again
-- results in the same value.
createJSONRoundtripSmokeTest ::
  forall a.
  (FromJSON a, ToJSON a, Eq a, Show a) =>
  -- | path to file to be decoded
  FilePath ->
  IO ()
createJSONRoundtripSmokeTest :: forall a. (FromJSON a, ToJSON a, Eq a, Show a) => TestName -> IO ()
createJSONRoundtripSmokeTest TestName
testFile = do
  ByteString
x <- TestName -> IO ByteString
B.readFile TestName
testFile
  let d1 :: Maybe a
d1 = forall a. FromJSON a => ByteString -> Maybe a
decode' @a ByteString
x
  let d2 :: Maybe a
d2 = forall a. FromJSON a => ByteString -> Maybe a
decode' @a (forall a. ToJSON a => a -> ByteString
encode Maybe a
d1)
  Maybe a
d1 forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= Maybe a
d2

-- |
-- Creates a group of tests
-- using 'createJSONRoundtripSmokeTest'
-- from all the files
-- in given directory
-- with given file extensions.
createJSONRoundtripSmokeTestGroup ::
  forall a.
  (FromJSON a, ToJSON a, Eq a, Show a) =>
  TestName ->
  -- | a list of file extensions to find in the provided directory
  [FilePath] ->
  -- | name of directory containing files to be parsed
  FilePath ->
  TestTree
createJSONRoundtripSmokeTestGroup :: forall a.
(FromJSON a, ToJSON a, Eq a, Show a) =>
TestName -> [TestName] -> TestName -> TestTree
createJSONRoundtripSmokeTestGroup TestName
n [TestName]
exts TestName
dir = TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
n forall a b. (a -> b) -> a -> b
$ \TestName -> IO ()
step -> do
  [TestName]
sources <- [TestName] -> TestName -> IO [TestName]
findByExtension [TestName]
exts TestName
dir
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestName
f -> TestName -> IO ()
step TestName
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. (FromJSON a, ToJSON a, Eq a, Show a) => TestName -> IO ()
createJSONRoundtripSmokeTest @a TestName
f) [TestName]
sources

-- |
-- Creates a group of tests
-- from all the files
-- in given directory
-- for all files ending in '.jsonl'.
-- Each file should contain 1 line containing 1 event.
-- Each test passes if the decoding results in a @Right a@ value.
--
-- The test group is meant as a smoke test
-- to check that events you think should parse
-- do in fact parse.
eventLineRoundTripTests ::
  forall m t a b.
  ( Eventable t m a,
    FromJSONEvent t m a,
    ToJSONEvent t m a,
    SizedIv (Interval a)
  ) =>
  FilePath ->
  TestTree
eventLineRoundTripTests :: forall m t a b.
(Eventable t m a, FromJSONEvent t m a, ToJSONEvent t m a,
 SizedIv (Interval a)) =>
TestName -> TestTree
eventLineRoundTripTests TestName
dir =
  forall a.
(FromJSON a, ToJSON a, Eq a, Show a) =>
TestName -> [TestName] -> TestName -> TestTree
createJSONRoundtripSmokeTestGroup @(EventLine t m a)
    ( TestName
"Checking that .jsonl files in "
        forall a. Semigroup a => a -> a -> a
<> TestName
dir
        forall a. Semigroup a => a -> a -> a
<> TestName
" can be decoded then encoded as EventLines"
    )
    [TestName
".jsonl"]
    TestName
dir

-- |
-- Creates a single test case
-- which decodes the contents of a file.
--
-- The test passes if:
--   * the file decodes into an 'EventLine'
--   * the result can be passed through 'modifyEventLineWithContext'
--     using the identity function without modifying the result.
createModifyEventLineTest ::
  forall m t a b.
  (Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a, Data m) =>
  -- | path to file to be decoded
  FilePath ->
  IO ()
createModifyEventLineTest :: forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Data m) =>
TestName -> IO ()
createModifyEventLineTest TestName
testFile = do
  ByteString
x <- TestName -> IO ByteString
B.readFile TestName
testFile
  let d1 :: Maybe (EventLine t m a)
d1 = forall a. FromJSON a => ByteString -> Maybe a
decode' @(EventLine t m a) ByteString
x

  case Maybe (EventLine t m a)
d1 of
        Maybe (EventLine t m a)
Nothing ->
          forall a. HasCallStack => TestName -> IO a
assertFailure (TestName
"failed to parse contents of " forall a. Semigroup a => a -> a -> a
<> TestName -> TestName
takeBaseName TestName
testFile)
        Just EventLine t m a
el -> do
          let d2 :: Either TestName (EventLine t m a)
d2 =
                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 TestName (EventLine t' m' a)
modifyEventLineWithContext @m @m @t @t @a
                  ParseEventLineOption
AddMomentAndFix
                  forall a. a -> a
id
                  ByteString
x
          case Either TestName (EventLine t m a)
d2 of
            Left TestName
s -> forall a. HasCallStack => TestName -> IO a
assertFailure TestName
s
            Right EventLine t m a
el' -> EventLine t m a
el forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= EventLine t m a
el'

-- |
-- Creates a group of tests
-- using 'createModifyEventLineTest'
-- from all the files
-- in given directory
-- with given file extensions.
createModifyEventLineTestGroup ::
  forall m t a b.
  (Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a, Data m) =>
  TestName ->
  -- | a list of file extensions to find in the provided directory
  [FilePath] ->
  -- | name of directory containing files to be parsed
  FilePath ->
  TestTree
createModifyEventLineTestGroup :: forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Data m) =>
TestName -> [TestName] -> TestName -> TestTree
createModifyEventLineTestGroup TestName
n [TestName]
exts TestName
dir = TestName -> ((TestName -> IO ()) -> IO ()) -> TestTree
testCaseSteps TestName
n forall a b. (a -> b) -> a -> b
$ \TestName -> IO ()
step -> do
  [TestName]
sources <- [TestName] -> TestName -> IO [TestName]
findByExtension [TestName]
exts TestName
dir
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\TestName
f -> TestName -> IO ()
step TestName
f forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Data m) =>
TestName -> IO ()
createModifyEventLineTest @m @t @a TestName
f) [TestName]
sources

-- |
-- Creates a group of tests
-- from all the files
-- in given directory
-- for all files ending in '.jsonl'.
-- Each file should contain 1 line containing 1 event.
--
-- Tests pass if:
--   * the file decodes into an 'EventLine'
--   * the result can be passed through 'modifyEventLineWithContext'
--     using the identity function without modifying the result.
--
-- NOTE:
-- Tags need to be ordered within the JSON files.
-- The underlying type of @TagSet@ is @Set@,
-- thus elements will be ordered by their @Ord@ instance
-- in the result.
eventLineModifyTests ::
  forall m t a b.
  (Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a, Data m) =>
  FilePath ->
  TestTree
eventLineModifyTests :: forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Data m) =>
TestName -> TestTree
eventLineModifyTests TestName
dir =
  forall m t a b.
(Eventable t m a, EventLineAble t m a b, FromJSONEvent t m a,
 Data m) =>
TestName -> [TestName] -> TestName -> TestTree
createModifyEventLineTestGroup @m @t @a
    ( TestName
"Checking that .jsonl files in "
        forall a. Semigroup a => a -> a -> a
<> TestName
dir
        forall a. Semigroup a => a -> a -> a
<> TestName
" are not modified by modifyEventLine with the id function"
    )
    [TestName
".jsonl"]
    TestName
dir

-- | Events to use with sorting tests. Note these are all just
-- moment-length intervals with none overlapping. That's fine: interval-algebra is responsible for the
-- Ord instance on intervals themselves.
exampleEvents :: [[Event Int () Int]]
exampleEvents :: [[Event Int () Int]]
exampleEvents = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {t}.
(SizedIv (Interval a), Ord t, Num t) =>
[a] -> [Event t () a]
eventList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
L.permutations [Int
0 .. Int
5]
  where
    ctx :: t -> Context t ()
ctx t
t = forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall t. Ord t => [t] -> TagSet t
packTagSet [t
t]) () forall a. Maybe a
Nothing
    eventList :: [a] -> [Event t () a]
eventList [a]
xs = [forall a t m. Interval a -> Context t m -> Event t m a
event (forall a. SizedIv (Interval a) => a -> Interval a
beginervalMoment a
i) (forall {t}. Ord t => t -> Context t ()
ctx t
0) | a
i <- [a]
xs]

-- | These are sorted by tagset.
exampleEvents' :: [[Event Int () Int]]
exampleEvents' :: [[Event Int () Int]]
exampleEvents' = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {t}.
(SizedIv (Interval a), Num a, Ord t) =>
[t] -> [Event t () a]
eventList forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]]
L.permutations [Int
0 .. Int
5]
  where
    ctx :: t -> Context t ()
ctx t
t = forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall t. Ord t => [t] -> TagSet t
packTagSet [t
t]) () forall a. Maybe a
Nothing
    eventList :: [t] -> [Event t () a]
eventList [t]
xs = [forall a t m. Interval a -> Context t m -> Event t m a
event (forall a. SizedIv (Interval a) => a -> Interval a
beginervalMoment a
0) (forall {t}. Ord t => t -> Context t ()
ctx t
i) | t
i <- [t]
xs]

-- | Sorting any sublist above should give this.
sortedEvents :: [Event Int () Int]
sortedEvents :: [Event Int () Int]
sortedEvents = [forall a t m. Interval a -> Context t m -> Event t m a
event (forall a. SizedIv (Interval a) => a -> Interval a
beginervalMoment Int
i) (forall {t}. Ord t => t -> Context t ()
ctx Int
0) | Int
i <- [Int
0 .. Int
5]]
  where
    ctx :: t -> Context t ()
ctx t
t = forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall t. Ord t => [t] -> TagSet t
packTagSet [t
t]) () forall a. Maybe a
Nothing

sortedEvents' :: [Event Int () Int]
sortedEvents' :: [Event Int () Int]
sortedEvents' = [forall a t m. Interval a -> Context t m -> Event t m a
event (forall a. SizedIv (Interval a) => a -> Interval a
beginervalMoment Int
0) (forall {t}. Ord t => t -> Context t ()
ctx Int
i) | Int
i <- [Int
0 .. Int
5]]
  where
    ctx :: t -> Context t ()
ctx t
t = forall t d. TagSet t -> d -> Maybe Source -> Context t d
context (forall t. Ord t => [t] -> TagSet t
packTagSet [t
t]) () forall a. Maybe a
Nothing

-- | Tests of Ord instance for Event.
eventOrdTests :: TestTree
eventOrdTests :: TestTree
eventOrdTests =
  TestName -> [TestTree] -> TestTree
testGroup
    TestName
"Ord instance for Event"
    forall a b. (a -> b) -> a -> b
$ [TestTree]
ivord forall a. [a] -> [a] -> [a]
++ [TestTree]
tagord
  where
    ivord :: [TestTree]
ivord = forall a b. (a -> b) -> [a] -> [b]
map (\[Event Int () Int]
ivs -> TestName -> IO () -> TestTree
testCase TestName
"Sort by intervals using 'compare'" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort [Event Int () Int]
ivs forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [Event Int () Int]
sortedEvents) [[Event Int () Int]]
exampleEvents
    tagord :: [TestTree]
tagord = forall a b. (a -> b) -> [a] -> [b]
map (\[Event Int () Int]
ivs -> TestName -> IO () -> TestTree
testCase TestName
"Sort by tag set" forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
L.sort [Event Int () Int]
ivs forall a. (Eq a, Show a, HasCallStack) => a -> a -> IO ()
@?= [Event Int () Int]
sortedEvents') [[Event Int () Int]]
exampleEvents'