{-|
Module      : Functions and types for creating tests for templates 
Description : Misc types and functions useful in Hasklepias.
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com

These functions may be moved to more appropriate modules in future versions.
-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}

module Hasklepias.Templates.TestUtilities (
    TestCase(..)
  , evalTestCase
  , makeAssertion
  , readIntervalSafe
  , makeEnrollmentEvent
  , makeEventWithConcepts
) where

import Control.Applicative ( Applicative(pure) )
import Data.Bool ( Bool (True) )
import Data.Eq                          ( Eq )
import Data.Monoid ( Monoid(mempty) )
import Data.Text ( Text )
import Data.Tuple                       ( uncurry )
import           Data.Tuple.Curry
-- ( uncurryN )
import           GHC.Real                       ( Integral )

import GHC.Show                         ( Show )
import EventData
import Cohort.Index
import Features.Compose                 ( Feature
                                        , Definition(..)
                                        , Define(..)
                                        , Eval(..) )
import Hasklepias.Misc

import IntervalAlgebra
import Test.Tasty                       ( TestName )
import Test.Tasty.HUnit                 ( (@?=), Assertion )


data TestCase a b builderArgs = MkTestCase {
    TestCase a b builderArgs -> builderArgs
getBuilderArgs :: builderArgs
  , TestCase a b builderArgs -> TestName
getTestName :: TestName
  , TestCase a b builderArgs -> a
getInputs :: a
  , TestCase a b builderArgs -> Feature "result" b
getTruth  :: Feature "result" b
  } deriving (TestCase a b builderArgs -> TestCase a b builderArgs -> Bool
(TestCase a b builderArgs -> TestCase a b builderArgs -> Bool)
-> (TestCase a b builderArgs -> TestCase a b builderArgs -> Bool)
-> Eq (TestCase a b builderArgs)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b builderArgs.
(Eq builderArgs, Eq a, Eq b) =>
TestCase a b builderArgs -> TestCase a b builderArgs -> Bool
/= :: TestCase a b builderArgs -> TestCase a b builderArgs -> Bool
$c/= :: forall a b builderArgs.
(Eq builderArgs, Eq a, Eq b) =>
TestCase a b builderArgs -> TestCase a b builderArgs -> Bool
== :: TestCase a b builderArgs -> TestCase a b builderArgs -> Bool
$c== :: forall a b builderArgs.
(Eq builderArgs, Eq a, Eq b) =>
TestCase a b builderArgs -> TestCase a b builderArgs -> Bool
Eq, Int -> TestCase a b builderArgs -> ShowS
[TestCase a b builderArgs] -> ShowS
TestCase a b builderArgs -> TestName
(Int -> TestCase a b builderArgs -> ShowS)
-> (TestCase a b builderArgs -> TestName)
-> ([TestCase a b builderArgs] -> ShowS)
-> Show (TestCase a b builderArgs)
forall a.
(Int -> a -> ShowS) -> (a -> TestName) -> ([a] -> ShowS) -> Show a
forall a b builderArgs.
(Show builderArgs, Show a, Show b) =>
Int -> TestCase a b builderArgs -> ShowS
forall a b builderArgs.
(Show builderArgs, Show a, Show b) =>
[TestCase a b builderArgs] -> ShowS
forall a b builderArgs.
(Show builderArgs, Show a, Show b) =>
TestCase a b builderArgs -> TestName
showList :: [TestCase a b builderArgs] -> ShowS
$cshowList :: forall a b builderArgs.
(Show builderArgs, Show a, Show b) =>
[TestCase a b builderArgs] -> ShowS
show :: TestCase a b builderArgs -> TestName
$cshow :: forall a b builderArgs.
(Show builderArgs, Show a, Show b) =>
TestCase a b builderArgs -> TestName
showsPrec :: Int -> TestCase a b builderArgs -> ShowS
$cshowsPrec :: forall a b builderArgs.
(Show builderArgs, Show a, Show b) =>
Int -> TestCase a b builderArgs -> ShowS
Show)


evalTestCase :: (Eval def defArgs return) =>
  TestCase defArgs b builderArgs
  -> Definition def
  -> ( return, Feature "result" b )
evalTestCase :: TestCase defArgs b builderArgs
-> Definition def -> (return, Feature "result" b)
evalTestCase (MkTestCase builderArgs
buildArgs TestName
_ defArgs
inputs Feature "result" b
truth) Definition def
def = ( Definition def -> defArgs -> return
forall def args return.
Eval def args return =>
Definition def -> args -> return
eval Definition def
def defArgs
inputs, Feature "result" b
truth )

makeAssertion :: (Eq b, Show b, Eval def defArgs (Feature "result" b)) =>
  TestCase defArgs b  builderArgs -> Definition def -> Assertion
makeAssertion :: TestCase defArgs b builderArgs -> Definition def -> Assertion
makeAssertion TestCase defArgs b builderArgs
x Definition def
def = (Feature "result" b -> Feature "result" b -> Assertion)
-> (Feature "result" b, Feature "result" b) -> Assertion
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Feature "result" b -> Feature "result" b -> Assertion
forall a. (Eq a, Show a, HasCallStack) => a -> a -> Assertion
(@?=) (TestCase defArgs b builderArgs
-> Definition def -> (Feature "result" b, Feature "result" b)
forall def defArgs return b builderArgs.
Eval def defArgs return =>
TestCase defArgs b builderArgs
-> Definition def -> (return, Feature "result" b)
evalTestCase TestCase defArgs b builderArgs
x Definition def
def)

readIntervalSafe :: (Integral b, IntervalSizeable a b) => (a, a) -> Interval a
readIntervalSafe :: (a, a) -> Interval a
readIntervalSafe (a
b, a
e) = b -> a -> Interval a
forall a b. IntervalSizeable a b => b -> a -> Interval a
beginerval (a -> a -> b
forall a b. IntervalSizeable a b => a -> a -> b
diff a
e a
b) a
b

makeEnrollmentEvent :: (Integral b, IntervalSizeable a b) => (a, a) -> Event a
makeEnrollmentEvent :: (a, a) -> Event a
makeEnrollmentEvent (a, a)
intrvl =
  Interval a -> Context -> Event a
forall a. Interval a -> Context -> Event a
event ((a, a) -> Interval a
forall b a.
(Integral b, IntervalSizeable a b) =>
(a, a) -> Interval a
readIntervalSafe (a, a)
intrvl) (Domain -> Concepts -> Context
context (EnrollmentFacts -> Domain
Enrollment (() -> EnrollmentFacts
EnrollmentFacts ())) Concepts
forall a. Monoid a => a
mempty)

makeEventWithConcepts :: (Integral b, IntervalSizeable a b) => [Text] -> (a, a) -> Event a
makeEventWithConcepts :: [Text] -> (a, a) -> Event a
makeEventWithConcepts [Text]
cpts (a, a)
intrvl = Interval a -> Context -> Event a
forall a. Interval a -> Context -> Event a
event
  ((a, a) -> Interval a
forall b a.
(Integral b, IntervalSizeable a b) =>
(a, a) -> Interval a
readIntervalSafe (a, a)
intrvl)
  (Domain -> Concepts -> Context
context (EnrollmentFacts -> Domain
Enrollment (() -> EnrollmentFacts
EnrollmentFacts ())) ([Text] -> Concepts
packConcepts [Text]
cpts))

makeTestTemplate
  :: (Integral b, IntervalSizeable a b)
  => TestName  -- ^ name of the test
  -> builderArgs -- ^ tuple of arguments pass to the definition builder
  -> (a, a)    -- ^ index interval 
  -> [Event a] -- ^ test events
  -> resultType -- ^ expected result
  -> TestCase
       (F "index" (Index Interval a), F "events" [Event a])
       resultType
       builderArgs
makeTestTemplate :: TestName
-> builderArgs
-> (a, a)
-> [Event a]
-> resultType
-> TestCase
     (F "index" (Index Interval a), F "events" [Event a])
     resultType
     builderArgs
makeTestTemplate TestName
name builderArgs
buildArgs (a, a)
intrvl [Event a]
e resultType
b = builderArgs
-> TestName
-> (F "index" (Index Interval a), F "events" [Event a])
-> Feature "result" resultType
-> TestCase
     (F "index" (Index Interval a), F "events" [Event a])
     resultType
     builderArgs
forall a b builderArgs.
builderArgs
-> TestName -> a -> Feature "result" b -> TestCase a b builderArgs
MkTestCase
  builderArgs
buildArgs
  TestName
name
  (Index Interval a -> F "index" (Index Interval a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Interval a -> Index Interval a
forall (i :: * -> *) a. Intervallic i a => i a -> Index i a
makeIndex ((a, a) -> Interval a
forall b a.
(Integral b, IntervalSizeable a b) =>
(a, a) -> Interval a
readIntervalSafe (a, a)
intrvl) ), [Event a] -> F "events" [Event a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Event a]
e)
  (resultType -> Feature "result" resultType
forall (f :: * -> *) a. Applicative f => a -> f a
pure resultType
b)